From eb46577f58dac48267d22ad752518d46acc82c14 Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Tue, 5 Mar 2019 16:19:46 +0100 Subject: debian/rules bug fix: the RGL was not included in .deb packages The problem was that the RGL was both built and copied to the destdir during the build step, which caused it to be deleted before the install step. It is now copied to destdir during the install step. --- gf.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gf.cabal') diff --git a/gf.cabal b/gf.cabal index 36a673e17..1f8a8caac 100644 --- a/gf.cabal +++ b/gf.cabal @@ -1,5 +1,5 @@ name: gf -version: 3.10 +version: 3.10-git cabal-version: >= 1.22 build-type: Custom -- cgit v1.2.3 From bf17fa0bb24c8e122817060bf3958a85b7a1da22 Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Tue, 5 Mar 2019 20:18:30 +0100 Subject: Bump version number to 3.10.3-git This is not an announced realase, but this is version now installed on our server. --- debian/changelog | 6 ++++++ gf.cabal | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'gf.cabal') diff --git a/debian/changelog b/debian/changelog index 709070841..3425e7dcb 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +gf (3.10.3-1) xenial bionic cosmic; urgency=low + + * GF 3.10.3 + + -- Thomas Hallgren Fri, 5 Mar 2019 19:30:00 +0100 + gf (3.10-2) xenial bionic cosmic; urgency=low * GF 3.10 diff --git a/gf.cabal b/gf.cabal index 1f8a8caac..5142294f6 100644 --- a/gf.cabal +++ b/gf.cabal @@ -1,5 +1,5 @@ name: gf -version: 3.10-git +version: 3.10.3-git cabal-version: >= 1.22 build-type: Custom -- cgit v1.2.3 From b783299b73b5c8a8229a45a830cf9b6be0be4f8c Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Thu, 7 Mar 2019 14:47:37 +0100 Subject: Rename module GF.Compile.ConcreteToCanonical to GF.Compile.GrammarToCanonical --- gf.cabal | 2 +- src/compiler/GF/Compile/ConcreteToCanonical.hs | 370 ------------------------- src/compiler/GF/Compile/ConcreteToHaskell.hs | 2 +- src/compiler/GF/Compile/GrammarToCanonical.hs | 368 ++++++++++++++++++++++++ src/compiler/GF/Compiler.hs | 2 +- 5 files changed, 371 insertions(+), 373 deletions(-) delete mode 100644 src/compiler/GF/Compile/ConcreteToCanonical.hs create mode 100644 src/compiler/GF/Compile/GrammarToCanonical.hs (limited to 'gf.cabal') diff --git a/gf.cabal b/gf.cabal index 5142294f6..fb4acef69 100644 --- a/gf.cabal +++ b/gf.cabal @@ -189,7 +189,7 @@ Library GF.Compile.PGFtoJava GF.Haskell GF.Compile.ConcreteToHaskell - GF.Compile.ConcreteToCanonical + GF.Compile.GrammarToCanonical GF.Grammar.Canonical GF.Grammar.CanonicalJSON GF.Compile.PGFtoJS diff --git a/src/compiler/GF/Compile/ConcreteToCanonical.hs b/src/compiler/GF/Compile/ConcreteToCanonical.hs deleted file mode 100644 index 34c7bee73..000000000 --- a/src/compiler/GF/Compile/ConcreteToCanonical.hs +++ /dev/null @@ -1,370 +0,0 @@ --- | Translate grammars to Canonical form --- (a common intermediate representation to simplify export to other formats) -module GF.Compile.ConcreteToCanonical(grammar2canonical,abstract2canonical,concretes2canonical) where -import Data.List(nub,partition) -import qualified Data.Map as M -import qualified Data.Set as S -import GF.Data.ErrM -import GF.Text.Pretty -import GF.Grammar.Grammar -import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues) -import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt) -import GF.Grammar.Lockfield(isLockLabel) -import GF.Grammar.Predef(cPredef,cInts) -import GF.Compile.Compute.Predef(predef) -import GF.Compile.Compute.Value(Predefined(..)) -import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent) -import GF.Infra.Option(optionsPGF) -import PGF.Internal(Literal(..)) -import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) -import GF.Grammar.Canonical as C -import Debug.Trace - --- | Generate Canonical code for the named abstract syntax and all associated --- concrete syntaxes -grammar2canonical opts absname gr = - Grammar (abstract2canonical absname gr) - (map snd (concretes2canonical opts absname gr)) - --- | Generate Canonical code for the named abstract syntax -abstract2canonical absname gr = - Abstract (modId absname) (convFlags gr absname) cats funs - where - cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs] - - funs = [FunDef (gId f) (convType ty) | - ((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs] - - adefs = allOrigInfos gr absname - - convCtx = maybe [] (map convHypo . unLoc) - convHypo (bt,name,t) = - case typeForm t of - ([],(_,cat),[]) -> gId cat -- !! - - convType t = - case typeForm t of - (hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as) - where - bs = map convHypo' hyps - as = map convType args - - convHypo' (bt,name,t) = TypeBinding (gId name) (convType t) - - --- | Generate Canonical code for the all concrete syntaxes associated with --- the named abstract syntax in given the grammar. -concretes2canonical opts absname gr = - [(cncname,concrete2canonical opts gr cenv absname cnc cncmod) - | let cenv = resourceValues opts gr, - cnc<-allConcretes gr absname, - let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath - Ok cncmod = lookupModule gr cnc - ] - --- | Generate Canonical GF for the given concrete module. --- The only options that make a difference are --- @-haskell=noprefix@ and @-haskell=variants@. -concrete2canonical opts gr cenv absname cnc modinfo = - Concrete (modId cnc) (modId absname) (convFlags gr cnc) - (neededParamTypes S.empty (params defs)) - [lincat|(_,Left lincat)<-defs] - [lin|(_,Right lin)<-defs] - where - defs = concatMap (toCanonical gr absname cenv) . - M.toList $ - jments modinfo - - params = S.toList . S.unions . map fst - - neededParamTypes have [] = [] - neededParamTypes have (q:qs) = - if q `S.member` have - then neededParamTypes have qs - else let ((got,need),def) = paramType gr q - in def++neededParamTypes (S.union got have) (S.toList need++qs) - -toCanonical gr absname cenv (name,jment) = - case jment of - CncCat (Just (L loc typ)) _ _ pprn _ -> - [(pts,Left (LincatDef (gId name) (convType ntyp)))] - where - pts = paramTypes gr ntyp - ntyp = nf loc typ - CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> - [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))] - where - tts = tableTypes gr [e'] - - e' = unAbs (length params) $ - nf loc (mkAbs params (mkApp def (map Vr args))) - params = [(b,x)|(b,x,_)<-ctx] - args = map snd params - - AnyInd _ m -> case lookupOrigInfo gr (m,name) of - Ok (m,jment) -> toCanonical gr absname cenv (name,jment) - _ -> [] - _ -> [] - where - nf loc = normalForm cenv (L loc name) --- aId n = prefixIdent "A." (gId n) - - unAbs 0 t = t - unAbs n (Abs _ _ t) = unAbs (n-1) t - unAbs _ t = t - -tableTypes gr ts = S.unions (map tabtys ts) - where - tabtys t = - case t of - V t cc -> S.union (paramTypes gr t) (tableTypes gr cc) - T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs)) - _ -> collectOp tabtys t - -paramTypes gr t = - case t of - RecType fs -> S.unions (map (paramTypes gr.snd) fs) - Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2) - App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta) - Sort _ -> S.empty - EInt _ -> S.empty - Q q -> lookup q - QC q -> lookup q - FV ts -> S.unions (map (paramTypes gr) ts) - _ -> ignore - where - lookup q = case lookupOrigInfo gr q of - Ok (_,ResOper _ (Just (L _ t))) -> - S.insert q (paramTypes gr t) - Ok (_,ResParam {}) -> S.singleton q - _ -> ignore - - ignore = trace ("Ignore: "++show t) S.empty - - -convert gr = convert' gr [] - -convert' gr vs = ppT - where - ppT0 = convert' gr vs - ppTv vs' = convert' gr vs' - - ppT t = - case t of --- Abs b x t -> ... --- V ty ts -> VTableValue (convType ty) (map ppT ts) - V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts] - where - Ok pts = allParamValues gr ty - Ok ps = mapM term2patt pts - T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs) - S t p -> selection (ppT t) (ppT p) - C t1 t2 -> concatValue (ppT t1) (ppT t2) - App f a -> ap (ppT f) (ppT a) - R r -> RecordValue (fields r) - P t l -> projection (ppT t) (lblId l) - Vr x -> VarValue (gId x) - Cn x -> VarValue (gId x) -- hmm - Con c -> ParamConstant (Param (gId c) []) - Sort k -> VarValue (gId k) - EInt n -> IntConstant n - Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n)) - QC (m,n) -> ParamConstant (Param (gId (qual m n)) []) - K s -> StrConstant s - Empty -> StrConstant "" - FV ts -> VariantValue (map ppT ts) - Alts t' vs -> alts vs (ppT t') - _ -> error $ "convert' "++show t - - ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t) - - ppPredef n = - case predef n of - Ok BIND -> p "BIND" - Ok SOFT_BIND -> p "SOFT_BIND" - Ok SOFT_SPACE -> p "SOFT_SPACE" - Ok CAPIT -> p "CAPIT" - Ok ALL_CAPIT -> p "ALL_CAPIT" - _ -> VarValue (gId n) - where - p = PredefValue . PredefId - - ppP p = - case p of - PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) - PP (m,c) ps -> ParamPattern (Param (gId (qual m c)) (map ppP ps)) - PR r -> RecordPattern (fields r) {- - PW -> WildPattern - PV x -> VarP x - PString s -> Lit (show s) -- !! - PInt i -> Lit (show i) - PFloat x -> Lit (show x) - PT _ p -> ppP p - PAs x p -> AsP x (ppP p) -} - where - fields = map field . filter (not.isLockLabel.fst) - field (l,p) = RecordRow (lblId l) (ppP p) - --- patToParam p = case ppP p of ParamPattern pv -> pv - --- token s = single (c "TK" `Ap` lit s) - - alts vs = PreValue (map alt vs) - where - alt (t,p) = (pre p,ppT0 t) - - pre (K s) = [s] - pre (Strs ts) = concatMap pre ts - pre (EPatt p) = pat p - pre t = error $ "pre "++show t - - pat (PString s) = [s] - pat (PAlt p1 p2) = pat p1++pat p2 - pat p = error $ "pat "++show p - - fields = map field . filter (not.isLockLabel.fst) - field (l,(_,t)) = RecordRow (lblId l) (ppT t) - --c = Const - --c = VarValue . VarValueId - --lit s = c (show s) -- hmm - - ap f a = case f of - ParamConstant (Param p ps) -> - ParamConstant (Param p (ps++[a])) - _ -> error $ "convert' ap: "++render (ppA f <+> ppA a) - -concatValue v1 v2 = - case (v1,v2) of - (StrConstant "",_) -> v2 - (_,StrConstant "") -> v1 - _ -> ConcatValue v1 v2 - -projection r l = maybe (Projection r l) id (proj r l) - -proj r l = - case r of - RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of - [v] -> Just v - _ -> Nothing - _ -> Nothing - -selection t v = - case t of - TableValue tt r -> - case nub [rv|TableRowValue _ rv<-keep] of - [rv] -> rv - _ -> Selection (TableValue tt r') v - where - r' = if null discard - then r - else keep++[TableRowValue WildPattern impossible] - (keep,discard) = partition (mightMatchRow v) r - _ -> Selection t v - -impossible = ErrorValue "impossible" - -mightMatchRow v (TableRowValue p _) = - case p of - WildPattern -> True - _ -> mightMatch v p - -mightMatch v p = - case v of - ConcatValue _ _ -> False - ParamConstant (Param c1 pvs) -> - case p of - ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps && - and [mightMatch v p|(v,p)<-zip pvs pps] - _ -> False - RecordValue rv -> - case p of - RecordPattern rp -> - and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp] - _ -> False - _ -> True - -patVars p = - case p of - PV x -> [x] - PAs x p -> x:patVars p - _ -> collectPattOp patVars p - -convType = ppT - where - ppT t = - case t of - Table ti tv -> TableType (ppT ti) (ppT tv) - RecType rt -> RecordType (convFields rt) --- App tf ta -> TAp (ppT tf) (ppT ta) --- FV [] -> tcon0 (identS "({-empty variant-})") - Sort k -> convSort k --- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal - FV (t:ts) -> ppT t -- !! - QC (m,n) -> ParamType (ParamTypeId (gId (qual m n))) - Q (m,n) -> ParamType (ParamTypeId (gId (qual m n))) - _ -> error $ "Missing case in convType for: "++show t - - convFields = map convField . filter (not.isLockLabel.fst) - convField (l,r) = RecordRow (lblId l) (ppT r) - - convSort k = case showIdent k of - "Float" -> FloatType - "Int" -> IntType - "Str" -> StrType - _ -> error ("convSort "++show k) - -toParamType t = case convType t of - ParamType pt -> pt - _ -> error ("toParamType "++show t) - -toParamId t = case toParamType t of - ParamTypeId p -> p - -paramType gr q@(_,n) = - case lookupOrigInfo gr q of - Ok (m,ResParam (Just (L _ ps)) _) - {- - | m/=cPredef && m/=moduleNameS "Prelude"-} -> - ((S.singleton (m,n),argTypes ps), - [ParamDef name (map (param m) ps)] - ) - where name = gId (qual m n) - Ok (m,ResOper _ (Just (L _ t))) - | m==cPredef && n==cInts -> - ((S.empty,S.empty),[]) {- - ((S.singleton (m,n),S.empty), - [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-} - | otherwise -> - ((S.singleton (m,n),paramTypes gr t), - [ParamAliasDef (gId (qual m n)) (convType t)]) - _ -> ((S.empty,S.empty),[]) - where - param m (n,ctx) = Param (gId (qual m n)) [toParamId t|(_,_,t)<-ctx] - argTypes = S.unions . map argTypes1 - argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] - -qual :: ModuleName -> Ident -> Ident -qual m = prefixIdent (render m++"_") - - -lblId = LabelId . render -- hmm -modId (MN m) = ModId (showIdent m) - -class FromIdent i where gId :: Ident -> i - -instance FromIdent VarId where - gId i = if isWildIdent i then Anonymous else VarId (showIdent i) - -instance FromIdent C.FunId where gId = C.FunId . showIdent -instance FromIdent CatId where gId = CatId . showIdent -instance FromIdent ParamId where gId = ParamId . showIdent -instance FromIdent VarValueId where gId = VarValueId . showIdent - -convFlags gr mn = - Flags [(n,convLit v) | - (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)] - where - convLit l = - case l of - LStr s -> Str s - LInt i -> C.Int i - LFlt d -> Flt d diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index 51ed5242e..804db9d50 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -11,7 +11,7 @@ import GF.Infra.Ident(Ident,identS,identW,prefixIdent) import GF.Infra.Option import GF.Haskell as H import GF.Grammar.Canonical as C -import GF.Compile.ConcreteToCanonical +import GF.Compile.GrammarToCanonical import Debug.Trace(trace) -- | Generate Haskell code for the all concrete syntaxes associated with diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs new file mode 100644 index 000000000..4bd9130b2 --- /dev/null +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -0,0 +1,368 @@ +-- | Translate grammars to Canonical form +-- (a common intermediate representation to simplify export to other formats) +module GF.Compile.GrammarToCanonical(grammar2canonical,abstract2canonical,concretes2canonical) where +import Data.List(nub,partition) +import qualified Data.Map as M +import qualified Data.Set as S +import GF.Data.ErrM +import GF.Text.Pretty +import GF.Grammar.Grammar +import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues) +import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt) +import GF.Grammar.Lockfield(isLockLabel) +import GF.Grammar.Predef(cPredef,cInts) +import GF.Compile.Compute.Predef(predef) +import GF.Compile.Compute.Value(Predefined(..)) +import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent) +import GF.Infra.Option(optionsPGF) +import PGF.Internal(Literal(..)) +import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) +import GF.Grammar.Canonical as C +import Debug.Trace + +-- | Generate Canonical code for the named abstract syntax and all associated +-- concrete syntaxes +grammar2canonical opts absname gr = + Grammar (abstract2canonical absname gr) + (map snd (concretes2canonical opts absname gr)) + +-- | Generate Canonical code for the named abstract syntax +abstract2canonical absname gr = + Abstract (modId absname) (convFlags gr absname) cats funs + where + cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs] + + funs = [FunDef (gId f) (convType ty) | + ((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs] + + adefs = allOrigInfos gr absname + + convCtx = maybe [] (map convHypo . unLoc) + convHypo (bt,name,t) = + case typeForm t of + ([],(_,cat),[]) -> gId cat -- !! + + convType t = + case typeForm t of + (hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as) + where + bs = map convHypo' hyps + as = map convType args + + convHypo' (bt,name,t) = TypeBinding (gId name) (convType t) + + +-- | Generate Canonical code for the all concrete syntaxes associated with +-- the named abstract syntax in given the grammar. +concretes2canonical opts absname gr = + [(cncname,concrete2canonical gr cenv absname cnc cncmod) + | let cenv = resourceValues opts gr, + cnc<-allConcretes gr absname, + let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath + Ok cncmod = lookupModule gr cnc + ] + +-- | Generate Canonical GF for the given concrete module. +concrete2canonical gr cenv absname cnc modinfo = + Concrete (modId cnc) (modId absname) (convFlags gr cnc) + (neededParamTypes S.empty (params defs)) + [lincat|(_,Left lincat)<-defs] + [lin|(_,Right lin)<-defs] + where + defs = concatMap (toCanonical gr absname cenv) . + M.toList $ + jments modinfo + + params = S.toList . S.unions . map fst + + neededParamTypes have [] = [] + neededParamTypes have (q:qs) = + if q `S.member` have + then neededParamTypes have qs + else let ((got,need),def) = paramType gr q + in def++neededParamTypes (S.union got have) (S.toList need++qs) + +toCanonical gr absname cenv (name,jment) = + case jment of + CncCat (Just (L loc typ)) _ _ pprn _ -> + [(pts,Left (LincatDef (gId name) (convType ntyp)))] + where + pts = paramTypes gr ntyp + ntyp = nf loc typ + CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> + [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))] + where + tts = tableTypes gr [e'] + + e' = unAbs (length params) $ + nf loc (mkAbs params (mkApp def (map Vr args))) + params = [(b,x)|(b,x,_)<-ctx] + args = map snd params + + AnyInd _ m -> case lookupOrigInfo gr (m,name) of + Ok (m,jment) -> toCanonical gr absname cenv (name,jment) + _ -> [] + _ -> [] + where + nf loc = normalForm cenv (L loc name) +-- aId n = prefixIdent "A." (gId n) + + unAbs 0 t = t + unAbs n (Abs _ _ t) = unAbs (n-1) t + unAbs _ t = t + +tableTypes gr ts = S.unions (map tabtys ts) + where + tabtys t = + case t of + V t cc -> S.union (paramTypes gr t) (tableTypes gr cc) + T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs)) + _ -> collectOp tabtys t + +paramTypes gr t = + case t of + RecType fs -> S.unions (map (paramTypes gr.snd) fs) + Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2) + App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta) + Sort _ -> S.empty + EInt _ -> S.empty + Q q -> lookup q + QC q -> lookup q + FV ts -> S.unions (map (paramTypes gr) ts) + _ -> ignore + where + lookup q = case lookupOrigInfo gr q of + Ok (_,ResOper _ (Just (L _ t))) -> + S.insert q (paramTypes gr t) + Ok (_,ResParam {}) -> S.singleton q + _ -> ignore + + ignore = trace ("Ignore: "++show t) S.empty + + +convert gr = convert' gr [] + +convert' gr vs = ppT + where + ppT0 = convert' gr vs + ppTv vs' = convert' gr vs' + + ppT t = + case t of +-- Abs b x t -> ... +-- V ty ts -> VTableValue (convType ty) (map ppT ts) + V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts] + where + Ok pts = allParamValues gr ty + Ok ps = mapM term2patt pts + T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs) + S t p -> selection (ppT t) (ppT p) + C t1 t2 -> concatValue (ppT t1) (ppT t2) + App f a -> ap (ppT f) (ppT a) + R r -> RecordValue (fields r) + P t l -> projection (ppT t) (lblId l) + Vr x -> VarValue (gId x) + Cn x -> VarValue (gId x) -- hmm + Con c -> ParamConstant (Param (gId c) []) + Sort k -> VarValue (gId k) + EInt n -> IntConstant n + Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n)) + QC (m,n) -> ParamConstant (Param (gId (qual m n)) []) + K s -> StrConstant s + Empty -> StrConstant "" + FV ts -> VariantValue (map ppT ts) + Alts t' vs -> alts vs (ppT t') + _ -> error $ "convert' "++show t + + ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t) + + ppPredef n = + case predef n of + Ok BIND -> p "BIND" + Ok SOFT_BIND -> p "SOFT_BIND" + Ok SOFT_SPACE -> p "SOFT_SPACE" + Ok CAPIT -> p "CAPIT" + Ok ALL_CAPIT -> p "ALL_CAPIT" + _ -> VarValue (gId n) + where + p = PredefValue . PredefId + + ppP p = + case p of + PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) + PP (m,c) ps -> ParamPattern (Param (gId (qual m c)) (map ppP ps)) + PR r -> RecordPattern (fields r) {- + PW -> WildPattern + PV x -> VarP x + PString s -> Lit (show s) -- !! + PInt i -> Lit (show i) + PFloat x -> Lit (show x) + PT _ p -> ppP p + PAs x p -> AsP x (ppP p) -} + where + fields = map field . filter (not.isLockLabel.fst) + field (l,p) = RecordRow (lblId l) (ppP p) + +-- patToParam p = case ppP p of ParamPattern pv -> pv + +-- token s = single (c "TK" `Ap` lit s) + + alts vs = PreValue (map alt vs) + where + alt (t,p) = (pre p,ppT0 t) + + pre (K s) = [s] + pre (Strs ts) = concatMap pre ts + pre (EPatt p) = pat p + pre t = error $ "pre "++show t + + pat (PString s) = [s] + pat (PAlt p1 p2) = pat p1++pat p2 + pat p = error $ "pat "++show p + + fields = map field . filter (not.isLockLabel.fst) + field (l,(_,t)) = RecordRow (lblId l) (ppT t) + --c = Const + --c = VarValue . VarValueId + --lit s = c (show s) -- hmm + + ap f a = case f of + ParamConstant (Param p ps) -> + ParamConstant (Param p (ps++[a])) + _ -> error $ "convert' ap: "++render (ppA f <+> ppA a) + +concatValue v1 v2 = + case (v1,v2) of + (StrConstant "",_) -> v2 + (_,StrConstant "") -> v1 + _ -> ConcatValue v1 v2 + +projection r l = maybe (Projection r l) id (proj r l) + +proj r l = + case r of + RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of + [v] -> Just v + _ -> Nothing + _ -> Nothing + +selection t v = + case t of + TableValue tt r -> + case nub [rv|TableRowValue _ rv<-keep] of + [rv] -> rv + _ -> Selection (TableValue tt r') v + where + r' = if null discard + then r + else keep++[TableRowValue WildPattern impossible] + (keep,discard) = partition (mightMatchRow v) r + _ -> Selection t v + +impossible = ErrorValue "impossible" + +mightMatchRow v (TableRowValue p _) = + case p of + WildPattern -> True + _ -> mightMatch v p + +mightMatch v p = + case v of + ConcatValue _ _ -> False + ParamConstant (Param c1 pvs) -> + case p of + ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps && + and [mightMatch v p|(v,p)<-zip pvs pps] + _ -> False + RecordValue rv -> + case p of + RecordPattern rp -> + and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp] + _ -> False + _ -> True + +patVars p = + case p of + PV x -> [x] + PAs x p -> x:patVars p + _ -> collectPattOp patVars p + +convType = ppT + where + ppT t = + case t of + Table ti tv -> TableType (ppT ti) (ppT tv) + RecType rt -> RecordType (convFields rt) +-- App tf ta -> TAp (ppT tf) (ppT ta) +-- FV [] -> tcon0 (identS "({-empty variant-})") + Sort k -> convSort k +-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal + FV (t:ts) -> ppT t -- !! + QC (m,n) -> ParamType (ParamTypeId (gId (qual m n))) + Q (m,n) -> ParamType (ParamTypeId (gId (qual m n))) + _ -> error $ "Missing case in convType for: "++show t + + convFields = map convField . filter (not.isLockLabel.fst) + convField (l,r) = RecordRow (lblId l) (ppT r) + + convSort k = case showIdent k of + "Float" -> FloatType + "Int" -> IntType + "Str" -> StrType + _ -> error ("convSort "++show k) + +toParamType t = case convType t of + ParamType pt -> pt + _ -> error ("toParamType "++show t) + +toParamId t = case toParamType t of + ParamTypeId p -> p + +paramType gr q@(_,n) = + case lookupOrigInfo gr q of + Ok (m,ResParam (Just (L _ ps)) _) + {- - | m/=cPredef && m/=moduleNameS "Prelude"-} -> + ((S.singleton (m,n),argTypes ps), + [ParamDef name (map (param m) ps)] + ) + where name = gId (qual m n) + Ok (m,ResOper _ (Just (L _ t))) + | m==cPredef && n==cInts -> + ((S.empty,S.empty),[]) {- + ((S.singleton (m,n),S.empty), + [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-} + | otherwise -> + ((S.singleton (m,n),paramTypes gr t), + [ParamAliasDef (gId (qual m n)) (convType t)]) + _ -> ((S.empty,S.empty),[]) + where + param m (n,ctx) = Param (gId (qual m n)) [toParamId t|(_,_,t)<-ctx] + argTypes = S.unions . map argTypes1 + argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] + +qual :: ModuleName -> Ident -> Ident +qual m = prefixIdent (render m++"_") + + +lblId = LabelId . render -- hmm +modId (MN m) = ModId (showIdent m) + +class FromIdent i where gId :: Ident -> i + +instance FromIdent VarId where + gId i = if isWildIdent i then Anonymous else VarId (showIdent i) + +instance FromIdent C.FunId where gId = C.FunId . showIdent +instance FromIdent CatId where gId = CatId . showIdent +instance FromIdent ParamId where gId = ParamId . showIdent +instance FromIdent VarValueId where gId = VarValueId . showIdent + +convFlags gr mn = + Flags [(n,convLit v) | + (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)] + where + convLit l = + case l of + LStr s -> Str s + LInt i -> C.Int i + LFlt d -> Flt d diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index efb1ae70f..4003285b8 100644 --- a/src/compiler/GF/Compiler.hs +++ b/src/compiler/GF/Compiler.hs @@ -7,7 +7,7 @@ import GF.Compile as S(batchCompile,link,srcAbsName) import GF.CompileInParallel as P(parallelBatchCompile) import GF.Compile.Export import GF.Compile.ConcreteToHaskell(concretes2haskell) -import GF.Compile.ConcreteToCanonical--(concretes2canonical) +import GF.Compile.GrammarToCanonical--(concretes2canonical) import GF.Compile.CFGtoPGF import GF.Compile.GetGrammar import GF.Grammar.BNFC -- cgit v1.2.3 From 5b401f3880f68828272dccfb3787cc3b3abd4cc3 Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Thu, 7 Mar 2019 17:41:16 +0100 Subject: Expose GF.Grammar.Canonical + some refactoring to make it available in other tools by depending on the gf package and importing it --- gf.cabal | 2 +- src/compiler/GF.hs | 6 ++- src/compiler/GF/Compile/ConcreteToHaskell.hs | 26 +++++++---- src/compiler/GF/Compile/GrammarToCanonical.hs | 46 +++++++++++--------- src/compiler/GF/Grammar/Canonical.hs | 62 +++++++++++++++++++-------- src/compiler/GF/Grammar/CanonicalJSON.hs | 16 +++++-- 6 files changed, 105 insertions(+), 53 deletions(-) (limited to 'gf.cabal') diff --git a/gf.cabal b/gf.cabal index fb4acef69..f350b2ca1 100644 --- a/gf.cabal +++ b/gf.cabal @@ -151,6 +151,7 @@ Library GF.Support GF.Text.Pretty GF.Text.Lexing + GF.Grammar.Canonical other-modules: GF.Main GF.Compiler GF.Interactive @@ -190,7 +191,6 @@ Library GF.Haskell GF.Compile.ConcreteToHaskell GF.Compile.GrammarToCanonical - GF.Grammar.Canonical GF.Grammar.CanonicalJSON GF.Compile.PGFtoJS GF.Compile.PGFtoProlog diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs index 8938a053e..a99970a57 100644 --- a/src/compiler/GF.hs +++ b/src/compiler/GF.hs @@ -19,7 +19,9 @@ module GF( module GF.Grammar.Printer, module GF.Infra.Ident, -- ** Binary serialisation - module GF.Grammar.Binary + module GF.Grammar.Binary, + -- * Canonical GF + module GF.Compile.GrammarToCanonical ) where import GF.Main import GF.Compiler @@ -36,3 +38,5 @@ import GF.Grammar.Macros import GF.Grammar.Printer import GF.Infra.Ident import GF.Grammar.Binary + +import GF.Compile.GrammarToCanonical diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index 804db9d50..6d2bf398f 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -142,8 +142,8 @@ concrete2haskell opts rhs = lets (zipWith letlin args absctx) (convert vs (coerce env lincat rhs0)) where - vs = [(VarValueId x,a)|(VarId x,a)<-zip xs args] - env= [(VarValueId x,lc)|(VarId x,lc)<-zip xs (map arglincat absctx)] + vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args] + env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)] letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) = (a,Ap (Var (linfunName acat)) (Var (abs_arg a))) @@ -173,15 +173,20 @@ concrete2haskell opts VariantValue [] -> empty VariantValue ts@(_:_) -> variants ts VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs - IntConstant n -> pure (lit n) - StrConstant s -> pure (token s) PreValue vs t' -> pure (alts t' vs) ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs) ErrorValue s -> ap (Const "error") (Const (show s)) -- !! + LiteralValue l -> ppL l _ -> error ("convert "++show t) + ppL l = + case l of + FloatConstant x -> pure (lit x) + IntConstant n -> pure (lit n) + StrConstant s -> pure (token s) + pId p@(ParamId s) = - if "to_R_" `isPrefixOf` s then toIdent p else gId p -- !! a hack + if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack table cs = if all (null.patVars) ps @@ -329,7 +334,7 @@ coerce env ty t = _ -> t where app f ts = ParamConstant (Param f ts) -- !! a hack - to_rcon = ParamId . to_rcon' . labels + to_rcon = ParamId . Unqual . to_rcon' . labels patVars p = [] @@ -395,11 +400,16 @@ linfunName c = prefixIdent "lin" (toIdent c) class ToIdent i where toIdent :: i -> Ident -instance ToIdent ParamId where toIdent (ParamId s) = identS s +instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q instance ToIdent PredefId where toIdent (PredefId s) = identS s instance ToIdent CatId where toIdent (CatId s) = identS s instance ToIdent C.FunId where toIdent (FunId s) = identS s -instance ToIdent VarValueId where toIdent (VarValueId s) = identS s +instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q + +qIdentS = identS . unqual + +unqual (Qual (ModId m) n) = m++"_"++n +unqual (Unqual n) = n instance ToIdent VarId where toIdent Anonymous = identW diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 4bd9130b2..7442bd495 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -165,11 +165,11 @@ convert' gr vs = ppT Cn x -> VarValue (gId x) -- hmm Con c -> ParamConstant (Param (gId c) []) Sort k -> VarValue (gId k) - EInt n -> IntConstant n - Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n)) - QC (m,n) -> ParamConstant (Param (gId (qual m n)) []) - K s -> StrConstant s - Empty -> StrConstant "" + EInt n -> LiteralValue (IntConstant n) + Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n)) + QC (m,n) -> ParamConstant (Param ((gQId m n)) []) + K s -> LiteralValue (StrConstant s) + Empty -> LiteralValue (StrConstant "") FV ts -> VariantValue (map ppT ts) Alts t' vs -> alts vs (ppT t') _ -> error $ "convert' "++show t @@ -183,14 +183,14 @@ convert' gr vs = ppT Ok SOFT_SPACE -> p "SOFT_SPACE" Ok CAPIT -> p "CAPIT" Ok ALL_CAPIT -> p "ALL_CAPIT" - _ -> VarValue (gId n) + _ -> VarValue (gQId cPredef n) -- hmm where p = PredefValue . PredefId ppP p = case p of PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) - PP (m,c) ps -> ParamPattern (Param (gId (qual m c)) (map ppP ps)) + PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps)) PR r -> RecordPattern (fields r) {- PW -> WildPattern PV x -> VarP x @@ -233,8 +233,8 @@ convert' gr vs = ppT concatValue v1 v2 = case (v1,v2) of - (StrConstant "",_) -> v2 - (_,StrConstant "") -> v1 + (LiteralValue (StrConstant ""),_) -> v2 + (_,LiteralValue (StrConstant "")) -> v1 _ -> ConcatValue v1 v2 projection r l = maybe (Projection r l) id (proj r l) @@ -298,8 +298,8 @@ convType = ppT Sort k -> convSort k -- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal FV (t:ts) -> ppT t -- !! - QC (m,n) -> ParamType (ParamTypeId (gId (qual m n))) - Q (m,n) -> ParamType (ParamTypeId (gId (qual m n))) + QC (m,n) -> ParamType (ParamTypeId ((gQId m n))) + Q (m,n) -> ParamType (ParamTypeId ((gQId m n))) _ -> error $ "Missing case in convType for: "++show t convFields = map convField . filter (not.isLockLabel.fst) @@ -325,25 +325,21 @@ paramType gr q@(_,n) = ((S.singleton (m,n),argTypes ps), [ParamDef name (map (param m) ps)] ) - where name = gId (qual m n) + where name = (gQId m n) Ok (m,ResOper _ (Just (L _ t))) | m==cPredef && n==cInts -> ((S.empty,S.empty),[]) {- ((S.singleton (m,n),S.empty), - [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-} + [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-} | otherwise -> ((S.singleton (m,n),paramTypes gr t), - [ParamAliasDef (gId (qual m n)) (convType t)]) + [ParamAliasDef ((gQId m n)) (convType t)]) _ -> ((S.empty,S.empty),[]) where - param m (n,ctx) = Param (gId (qual m n)) [toParamId t|(_,_,t)<-ctx] + param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx] argTypes = S.unions . map argTypes1 argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] -qual :: ModuleName -> Ident -> Ident -qual m = prefixIdent (render m++"_") - - lblId = LabelId . render -- hmm modId (MN m) = ModId (showIdent m) @@ -354,8 +350,16 @@ instance FromIdent VarId where instance FromIdent C.FunId where gId = C.FunId . showIdent instance FromIdent CatId where gId = CatId . showIdent -instance FromIdent ParamId where gId = ParamId . showIdent -instance FromIdent VarValueId where gId = VarValueId . showIdent +instance FromIdent ParamId where gId = ParamId . unqual +instance FromIdent VarValueId where gId = VarValueId . unqual + +class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i + +instance QualIdent ParamId where gQId m n = ParamId (qual m n) +instance QualIdent VarValueId where gQId m n = VarValueId (qual m n) + +qual m n = Qual (modId m) (showIdent n) +unqual n = Unqual (showIdent n) convFlags gr mn = Flags [(n,convLit v) | diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 0da72d634..ab9bf280c 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -1,7 +1,12 @@ --- | Abstract syntax for canonical GF grammars, i.e. what's left after +-- | +-- Module : GF.Grammar.Canonical +-- Stability : provisional +-- +-- Abstract syntax for canonical GF grammars, i.e. what's left after -- high-level constructions such as functors and opers have been eliminated -- by partial evaluation. This is intended as a common intermediate -- representation to simplify export to other formats. + module GF.Grammar.Canonical where import Prelude hiding ((<>)) import GF.Text.Pretty @@ -51,13 +56,11 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show) -- | Linearization value, RHS of @lin@ data LinValue = ConcatValue LinValue LinValue + | LiteralValue LinLiteral | ErrorValue String - | FloatConstant Float - | IntConstant Int | ParamConstant ParamValue | PredefValue PredefId | RecordValue [RecordRowValue] - | StrConstant String | TableValue LinType [TableRowValue] --- | VTableValue LinType [LinValue] | TupleValue [LinValue] @@ -66,7 +69,12 @@ data LinValue = ConcatValue LinValue LinValue | PreValue [([String], LinValue)] LinValue | Projection LinValue LabelId | Selection LinValue LinValue - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) + +data LinLiteral = FloatConstant Float + | IntConstant Int + | StrConstant String + deriving (Eq,Ord,Show) data LinPattern = ParamPattern ParamPattern | RecordPattern [RecordRow LinPattern] @@ -87,27 +95,33 @@ data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Ord,Show) -- *** Identifiers in Concrete Syntax -newtype PredefId = PredefId String deriving (Eq,Ord,Show) -newtype LabelId = LabelId String deriving (Eq,Ord,Show) -data VarValueId = VarValueId String deriving (Eq,Ord,Show) +newtype PredefId = PredefId Id deriving (Eq,Ord,Show) +newtype LabelId = LabelId Id deriving (Eq,Ord,Show) +data VarValueId = VarValueId QualId deriving (Eq,Ord,Show) -- | Name of param type or param value -newtype ParamId = ParamId String deriving (Eq,Ord,Show) +newtype ParamId = ParamId QualId deriving (Eq,Ord,Show) -------------------------------------------------------------------------------- -- ** Used in both Abstract and Concrete Syntax -newtype ModId = ModId String deriving (Eq,Show) +newtype ModId = ModId Id deriving (Eq,Ord,Show) -newtype CatId = CatId String deriving (Eq,Ord,Show) -newtype FunId = FunId String deriving (Eq,Show) +newtype CatId = CatId Id deriving (Eq,Ord,Show) +newtype FunId = FunId Id deriving (Eq,Show) -data VarId = Anonymous | VarId String deriving Show +data VarId = Anonymous | VarId Id deriving Show newtype Flags = Flags [(FlagName,FlagValue)] deriving Show -type FlagName = String +type FlagName = Id data FlagValue = Str String | Int Int | Flt Double deriving Show + +-- *** Identifiers + +type Id = String +data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show) + -------------------------------------------------------------------------------- -- ** Pretty printing @@ -203,8 +217,7 @@ instance Pretty LinValue where instance PPA LinValue where ppA lv = case lv of - FloatConstant f -> pp f - IntConstant n -> pp n + LiteralValue l -> ppA l ParamConstant pv -> ppA pv PredefValue p -> ppA p RecordValue [] -> pp "<>" @@ -214,13 +227,20 @@ instance PPA LinValue where where alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss))) 2 ("=>"<+>lv) - StrConstant s -> doubleQuotes s -- hmm TableValue _ tvs -> "table"<+>block tvs -- VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts) TupleValue lvs -> "<"<>punctuate "," lvs<>">" VarValue v -> pp v _ -> parens lv +instance Pretty LinLiteral where pp = ppA + +instance PPA LinLiteral where + ppA l = case l of + FloatConstant f -> pp f + IntConstant n -> pp n + StrConstant s -> doubleQuotes s -- hmm + instance RhsSeparator LinValue where rhsSep _ = pp "=" instance Pretty LinPattern where @@ -250,11 +270,17 @@ instance Pretty CatId where pp (CatId s) = pp s instance Pretty FunId where pp (FunId s) = pp s instance Pretty LabelId where pp (LabelId s) = pp s instance Pretty PredefId where pp = ppA -instance PPA PredefId where ppA (PredefId s) = pp s +instance PPA PredefId where ppA (PredefId s) = "Predef."<>s instance Pretty ParamId where pp = ppA instance PPA ParamId where ppA (ParamId s) = pp s instance Pretty VarValueId where pp (VarValueId s) = pp s +instance Pretty QualId where pp = ppA + +instance PPA QualId where + ppA (Qual m n) = m<>"_"<>n -- hmm + ppA (Unqual n) = pp n + instance Pretty Flags where pp (Flags []) = empty pp (Flags flags) = "flags" <+> vcat (map ppFlag flags) diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index d791e0d9b..c14716eea 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -95,10 +95,7 @@ instance JSON LinType where instance JSON LinValue where showJSON lv = case lv of - -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: - StrConstant s -> showJSON s - FloatConstant f -> showJSON f - IntConstant n -> showJSON n + LiteralValue l -> showJSON l -- concatenation is encoded as a JSON array: ConcatValue v v' -> showJSON [showJSON v, showJSON v'] -- most values are encoded as JSON objects: @@ -115,6 +112,13 @@ instance JSON LinValue where -- records are encoded directly as JSON records: RecordValue rows -> showJSON rows +instance JSON LinLiteral where + showJSON l = case l of + -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: + StrConstant s -> showJSON s + FloatConstant f -> showJSON f + IntConstant n -> showJSON n + instance JSON LinPattern where showJSON linpat = case linpat of -- wildcards and patterns without arguments are encoded as strings: @@ -161,6 +165,10 @@ instance JSON VarId where showJSON Anonymous = showJSON "_" showJSON (VarId x) = showJSON x +instance JSON QualId where + showJSON (Qual (ModId m) n) = showJSON (m++"_"++n) + showJSON (Unqual n) = showJSON n + instance JSON Flags where -- flags are encoded directly as JSON records (i.e., objects): showJSON (Flags fs) = makeObj [(f,showJSON v) | (f, v) <- fs] -- cgit v1.2.3