From 0970d678cf87fac95f9baf11ce56db4bdf0b0835 Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Thu, 7 Mar 2019 14:11:29 +0100 Subject: haskell-bind/utils.c: add missing return Found via C compiler warning --- src/runtime/haskell-bind/utils.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/runtime/haskell-bind/utils.c b/src/runtime/haskell-bind/utils.c index 5afb33b5c..91d62ea56 100644 --- a/src/runtime/haskell-bind/utils.c +++ b/src/runtime/haskell-bind/utils.c @@ -100,7 +100,7 @@ hspgf_predict_callback(PgfOracleCallback* self, size_t offset) { HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle); - oracle->predict(cat,label,hspgf_offset2hs(oracle->sentence, offset)); + return oracle->predict(cat,label,hspgf_offset2hs(oracle->sentence, offset)); } static bool @@ -110,7 +110,7 @@ hspgf_complete_callback(PgfOracleCallback* self, size_t offset) { HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle); - oracle->complete(cat,label,hspgf_offset2hs(oracle->sentence, offset)); + return oracle->complete(cat,label,hspgf_offset2hs(oracle->sentence, offset)); } static PgfExprProb* -- 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 'src') 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 'src') 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 From 8cf4446e8cf2cf65aa308c2d69c59a3368194bf5 Mon Sep 17 00:00:00 2001 From: Peter Ljunglöf Date: Fri, 8 Mar 2019 17:21:23 +0100 Subject: Remove "canonical_yaml" from the option descriptions --- src/compiler/GF/Infra/Option.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index b99e2dbe9..7e1c22b9d 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -327,7 +327,7 @@ optDescr = Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').", Option ['f'] ["output-format"] (ReqArg outFmt "FMT") (unlines ["Output format. FMT can be one of:", - "Canonical GF grammar: canonical_gf, canonical_json, canonical_yaml, (and haskell with option --haskell=concrete)", + "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)", "Multiple concrete: pgf (default), js, pgf_pretty, prolog, python, ...", -- gar, "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf, "Abstract only: haskell, ..."]), -- prolog_abs, -- cgit v1.2.3 From 3328279120ce771c676b30689283cd7f2493c0f6 Mon Sep 17 00:00:00 2001 From: Peter Ljunglöf Date: Fri, 8 Mar 2019 17:35:01 +0100 Subject: corrected json printing some object labels must be preceded by ".", to not be in conflict with GF records (which are stored as json objects) plus some minor bugfixes and cleaning --- src/compiler/GF/Grammar/CanonicalJSON.hs | 55 +++++++++++++++----------------- 1 file changed, 25 insertions(+), 30 deletions(-) (limited to 'src') diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index c14716eea..347af1390 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -3,7 +3,6 @@ module GF.Grammar.CanonicalJSON ( ) where import Text.JSON -import qualified Control.Monad as CM (mapM, msum) import GF.Grammar.Canonical @@ -38,23 +37,19 @@ instance JSON CatDef where instance JSON FunDef where showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)] -{- -instance FromJSON FunDef where - parseJSON = withObject "FunDef" $ \o -> FunDef <$> o .: "fun" <*> o .: "type" --} instance JSON Type where - showJSON (Type bs ty) = makeObj [("args", showJSON bs), ("result", showJSON ty)] + showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)] instance JSON TypeApp where -- non-dependent categories are encoded as simple strings: showJSON (TypeApp c []) = showJSON c - showJSON (TypeApp c args) = makeObj [("cat", showJSON c), ("args", showJSON args)] + showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)] instance JSON TypeBinding where -- non-dependent categories are encoded as simple strings: showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c - showJSON (TypeBinding x ty) = makeObj [("var", showJSON x), ("type", showJSON ty)] + showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)] -------------------------------------------------------------------------------- @@ -88,29 +83,29 @@ instance JSON LinType where -- parameters are also encoded as strings: ParamType pt -> showJSON pt -- tables/tuples are encoded as JSON objects: - TableType pt lt -> makeObj [("tblarg", showJSON pt), ("tblval", showJSON lt)] - TupleType lts -> makeObj [("tuple", showJSON lts)] + TableType pt lt -> makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)] + TupleType lts -> makeObj [(".tuple", showJSON lts)] -- records are encoded as records: RecordType rows -> showJSON rows instance JSON LinValue where showJSON lv = case lv of - LiteralValue l -> showJSON l + LiteralValue l -> showJSON l -- concatenation is encoded as a JSON array: - ConcatValue v v' -> showJSON [showJSON v, showJSON v'] + ConcatValue v v' -> showJSON [showJSON v, showJSON v'] -- most values are encoded as JSON objects: - ParamConstant pv -> makeObj [("param", showJSON pv)] - PredefValue p -> makeObj [("predef", showJSON p)] - TableValue t tvs -> makeObj [("tblarg", showJSON t), ("tblrows", showJSON tvs)] - TupleValue lvs -> makeObj [("tuple", showJSON lvs)] - VarValue v -> makeObj [("var", showJSON v)] - ErrorValue s -> makeObj [("error", showJSON s)] - Projection lv l -> makeObj [("project", showJSON lv), ("label", showJSON l)] - Selection tv pv -> makeObj [("select", showJSON tv), ("key", showJSON pv)] - VariantValue vs -> makeObj [("variants", showJSON vs)] - PreValue alts def -> makeObj [("pre", showJSON alts), ("default", showJSON def)] + ParamConstant pv -> makeObj [(".param", showJSON pv)] + PredefValue p -> makeObj [(".predef", showJSON p)] + TableValue t tvs -> makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)] + TupleValue lvs -> makeObj [(".tuple", showJSON lvs)] + VarValue v -> makeObj [(".var", showJSON v)] + ErrorValue s -> makeObj [(".error", showJSON s)] + Projection lv l -> makeObj [(".project", showJSON lv), (".label", showJSON l)] + Selection tv pv -> makeObj [(".select", showJSON tv), (".key", showJSON pv)] + VariantValue vs -> makeObj [(".variants", showJSON vs)] + PreValue pre def -> makeObj [(".pre", showJSON pre),(".default", showJSON def)] -- records are encoded directly as JSON records: - RecordValue rows -> showJSON rows + RecordValue rows -> showJSON rows instance JSON LinLiteral where showJSON l = case l of @@ -132,17 +127,17 @@ instance JSON LinPattern where instance JSON arg => JSON (Param arg) where -- parameters without arguments are encoded as strings: showJSON (Param p []) = showJSON p - showJSON (Param p args) = makeObj [("paramid", showJSON p), ("args", showJSON args)] + showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)] instance JSON a => JSON (RecordRow a) where -- record rows and lists of record rows are both encoded as JSON records (i.e., objects) - showJSON row = makeObj [toJSONRecordRow row] + showJSON row = showJSONs [row] + showJSONs rows = makeObj (map toRow rows) + where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val) -toJSONRecordRow :: JSON a => RecordRow a -> (String,JSValue) -toJSONRecordRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val) instance JSON TableRowValue where - showJSON (TableRowValue l v) = makeObj [("pattern", showJSON l), ("value", showJSON l)] + showJSON (TableRowValue l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] -- *** Identifiers in Concrete Syntax @@ -166,12 +161,12 @@ instance JSON VarId where showJSON (VarId x) = showJSON x instance JSON QualId where - showJSON (Qual (ModId m) n) = showJSON (m++"_"++n) + 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] + showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs] instance JSON FlagValue where -- flag values are encoded as basic JSON types: -- cgit v1.2.3 From 21140fc0c0dce1e7730a3d679815e48db0ab3804 Mon Sep 17 00:00:00 2001 From: Peter Ljunglöf Date: Fri, 8 Mar 2019 17:57:02 +0100 Subject: remove case expressions (no particular reason) --- src/compiler/GF/Grammar/CanonicalJSON.hs | 80 +++++++++++++++----------------- 1 file changed, 38 insertions(+), 42 deletions(-) (limited to 'src') diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 347af1390..3be47a1a8 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -75,54 +75,50 @@ instance JSON LinDef where showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)] instance JSON LinType where - showJSON lt = case lt of - -- the basic types (Str, Float, Int) are encoded as strings: - StrType -> showJSON "Str" - FloatType -> showJSON "Float" - IntType -> showJSON "Int" - -- parameters are also encoded as strings: - ParamType pt -> showJSON pt - -- tables/tuples are encoded as JSON objects: - TableType pt lt -> makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)] - TupleType lts -> makeObj [(".tuple", showJSON lts)] - -- records are encoded as records: - RecordType rows -> showJSON rows + -- the basic types (Str, Float, Int) are encoded as strings: + showJSON (StrType) = showJSON "Str" + showJSON (FloatType) = showJSON "Float" + showJSON (IntType) = showJSON "Int" + -- parameters are also encoded as strings: + showJSON (ParamType pt) = showJSON pt + -- tables/tuples are encoded as JSON objects: + showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)] + showJSON (TupleType lts) = makeObj [(".tuple", showJSON lts)] + -- records are encoded as records: + showJSON (RecordType rows) = showJSON rows instance JSON LinValue where - showJSON lv = case lv of - 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: - ParamConstant pv -> makeObj [(".param", showJSON pv)] - PredefValue p -> makeObj [(".predef", showJSON p)] - TableValue t tvs -> makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)] - TupleValue lvs -> makeObj [(".tuple", showJSON lvs)] - VarValue v -> makeObj [(".var", showJSON v)] - ErrorValue s -> makeObj [(".error", showJSON s)] - Projection lv l -> makeObj [(".project", showJSON lv), (".label", showJSON l)] - Selection tv pv -> makeObj [(".select", showJSON tv), (".key", showJSON pv)] - VariantValue vs -> makeObj [(".variants", showJSON vs)] - PreValue pre def -> makeObj [(".pre", showJSON pre),(".default", showJSON def)] - -- records are encoded directly as JSON records: - RecordValue rows -> showJSON rows + showJSON (LiteralValue l ) = showJSON l + -- concatenation is encoded as a JSON array: + showJSON (ConcatValue v v') = showJSON [showJSON v, showJSON v'] + -- most values are encoded as JSON objects: + showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)] + showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)] + showJSON (TableValue t tvs) = makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)] + showJSON (TupleValue lvs) = makeObj [(".tuple", showJSON lvs)] + showJSON (VarValue v ) = makeObj [(".var", showJSON v)] + showJSON (ErrorValue s ) = makeObj [(".error", showJSON s)] + showJSON (Projection lv l ) = makeObj [(".project", showJSON lv), (".label", showJSON l)] + showJSON (Selection tv pv) = makeObj [(".select", showJSON tv), (".key", showJSON pv)] + showJSON (VariantValue vs) = makeObj [(".variants", showJSON vs)] + showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)] + -- records are encoded directly as JSON records: + showJSON (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 + -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: + showJSON (StrConstant s) = showJSON s + showJSON (FloatConstant f) = showJSON f + showJSON (IntConstant n) = showJSON n instance JSON LinPattern where - showJSON linpat = case linpat of - -- wildcards and patterns without arguments are encoded as strings: - WildPattern -> showJSON "_" - ParamPattern (Param p []) -> showJSON p - -- complex patterns are encoded as JSON objects: - ParamPattern pv -> showJSON pv - -- and records as records: - RecordPattern r -> showJSON r + -- wildcards and patterns without arguments are encoded as strings: + showJSON (WildPattern) = showJSON "_" + showJSON (ParamPattern (Param p [])) = showJSON p + -- complex patterns are encoded as JSON objects: + showJSON (ParamPattern pv) = showJSON pv + -- and records as records: + showJSON (RecordPattern r) = showJSON r instance JSON arg => JSON (Param arg) where -- parameters without arguments are encoded as strings: -- cgit v1.2.3 From 926a5cf41475e7aec0b40920d2bc30444afda39c Mon Sep 17 00:00:00 2001 From: Peter Ljunglöf Date: Fri, 8 Mar 2019 17:58:24 +0100 Subject: added parsing of json into canonical GF --- src/compiler/GF/Grammar/CanonicalJSON.hs | 129 +++++++++++++++++++++++++++++-- 1 file changed, 121 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 3be47a1a8..ae2c5fab5 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -3,6 +3,8 @@ module GF.Grammar.CanonicalJSON ( ) where import Text.JSON +import Control.Applicative ((<|>)) +import Data.Ratio (denominator, numerator) import GF.Grammar.Canonical @@ -19,6 +21,8 @@ encodeJSON fpath g = writeFile fpath (encode g) instance JSON Grammar where showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)] + readJSON o = Grammar <$> o!"abstract" <*> o!"concretes" + -------------------------------------------------------------------------------- -- ** Abstract Syntax @@ -30,27 +34,47 @@ instance JSON Abstract where ("cats", showJSON cats), ("funs", showJSON funs)] + readJSON o = Abstract + <$> o!"abs" + <*>(o!"flags" <|> return (Flags [])) + <*> o!"cats" + <*> o!"funs" + instance JSON CatDef where -- non-dependent categories are encoded as simple strings: showJSON (CatDef c []) = showJSON c showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)] + readJSON o = CatDef <$> readJSON o <*> return [] + <|> CatDef <$> o!"cat" <*> o!"args" + instance JSON FunDef where showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)] + readJSON o = FunDef <$> o!"fun" <*> o!"type" + instance JSON Type where showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)] + readJSON o = Type <$> o!".args" <*> o!".result" + instance JSON TypeApp where -- non-dependent categories are encoded as simple strings: showJSON (TypeApp c []) = showJSON c showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)] + readJSON o = TypeApp <$> readJSON o <*> return [] + <|> TypeApp <$> o!".cat" <*> o!".args" + instance JSON TypeBinding where -- non-dependent categories are encoded as simple strings: showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)] + readJSON o = do c <- readJSON o + return (TypeBinding Anonymous (Type [] (TypeApp c []))) + <|> TypeBinding <$> o!".var" <*> o!".type" + -------------------------------------------------------------------------------- -- ** Concrete syntax @@ -64,16 +88,31 @@ instance JSON Concrete where ("lincats", showJSON lincats), ("lins", showJSON lins)] + readJSON o = Concrete + <$> o!"cnc" + <*> o!"abs" + <*>(o!"flags" <|> return (Flags [])) + <*> o!"params" + <*> o!"lincats" + <*> o!"lins" + instance JSON ParamDef where showJSON (ParamDef p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)] showJSON (ParamAliasDef p t) = makeObj [("param", showJSON p), ("alias", showJSON t)] + readJSON o = ParamDef <$> o!"param" <*> o!"values" + <|> ParamAliasDef <$> o!"param" <*> o!"alias" + instance JSON LincatDef where showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)] + readJSON o = LincatDef <$> o!"cat" <*> o!"lintype" + instance JSON LinDef where showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)] + readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin" + instance JSON LinType where -- the basic types (Str, Float, Int) are encoded as strings: showJSON (StrType) = showJSON "Str" @@ -87,6 +126,14 @@ instance JSON LinType where -- records are encoded as records: showJSON (RecordType rows) = showJSON rows + readJSON o = do "Str" <- readJSON o; return StrType + <|> do "Float" <- readJSON o; return FloatType + <|> do "Int" <- readJSON o; return IntType + <|> do ptype <- readJSON o; return (ParamType ptype) + <|> TableType <$> o!".tblarg" <*> o!".tblval" + <|> TupleType <$> o!".tuple" + <|> RecordType <$> readJSON o + instance JSON LinValue where showJSON (LiteralValue l ) = showJSON l -- concatenation is encoded as a JSON array: @@ -105,12 +152,27 @@ instance JSON LinValue where -- records are encoded directly as JSON records: showJSON (RecordValue rows) = showJSON rows + readJSON o = LiteralValue <$> readJSON o + <|> ParamConstant <$> o!".param" + <|> PredefValue <$> o!".predef" + <|> TableValue <$> o!".tblarg" <*> o!".tblrows" + <|> TupleValue <$> o!".tuple" + <|> VarValue <$> o!".var" + <|> ErrorValue <$> o!".error" + <|> Projection <$> o!".project" <*> o!".label" + <|> Selection <$> o!".select" <*> o!".key" + <|> VariantValue <$> o!".variants" + <|> PreValue <$> o!".pre" <*> o!".default" + <|> RecordValue <$> readJSON o + instance JSON LinLiteral where -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: showJSON (StrConstant s) = showJSON s showJSON (FloatConstant f) = showJSON f showJSON (IntConstant n) = showJSON n + readJSON = readBasicJSON StrConstant IntConstant FloatConstant + instance JSON LinPattern where -- wildcards and patterns without arguments are encoded as strings: showJSON (WildPattern) = showJSON "_" @@ -120,53 +182,104 @@ instance JSON LinPattern where -- and records as records: showJSON (RecordPattern r) = showJSON r + readJSON o = do "_" <- readJSON o; return WildPattern + <|> do p <- readJSON o; return (ParamPattern (Param p [])) + <|> ParamPattern <$> readJSON o + <|> RecordPattern <$> readJSON o + instance JSON arg => JSON (Param arg) where -- parameters without arguments are encoded as strings: showJSON (Param p []) = showJSON p showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)] + readJSON o = Param <$> readJSON o <*> return [] + <|> Param <$> o!".paramid" <*> o!".args" + instance JSON a => JSON (RecordRow a) where -- record rows and lists of record rows are both encoded as JSON records (i.e., objects) showJSON row = showJSONs [row] showJSONs rows = makeObj (map toRow rows) where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val) + readJSON obj = head <$> readJSONs obj + readJSONs obj = mapM fromRow (assocsJSObject obj) + where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue + return (RecordRow (LabelId lbl) value) instance JSON TableRowValue where showJSON (TableRowValue l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] + readJSON o = TableRowValue <$> o!".pattern" <*> o!".value" + -- *** Identifiers in Concrete Syntax -instance JSON PredefId where showJSON (PredefId s) = showJSON s -instance JSON LabelId where showJSON (LabelId s) = showJSON s -instance JSON VarValueId where showJSON (VarValueId s) = showJSON s -instance JSON ParamId where showJSON (ParamId s) = showJSON s -instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s +instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON +instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON +instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON +instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON +instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON + -------------------------------------------------------------------------------- -- ** Used in both Abstract and Concrete Syntax -instance JSON ModId where showJSON (ModId s) = showJSON s -instance JSON CatId where showJSON (CatId s) = showJSON s -instance JSON FunId where showJSON (FunId s) = showJSON s +instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON +instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON +instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON instance JSON VarId where -- the anonymous variable is the underscore: showJSON Anonymous = showJSON "_" showJSON (VarId x) = showJSON x + readJSON o = do "_" <- readJSON o; return Anonymous + <|> VarId <$> readJSON o + instance JSON QualId where showJSON (Qual (ModId m) n) = showJSON (m++"."++n) showJSON (Unqual n) = showJSON n + readJSON o = do qualid <- readJSON o + let (mod, id) = span (/= '.') qualid + return $ if null mod then Unqual id else Qual (ModId mod) id + instance JSON Flags where -- flags are encoded directly as JSON records (i.e., objects): showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs] + readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj) + where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue + return (lbl, value) + instance JSON FlagValue where -- flag values are encoded as basic JSON types: showJSON (Str s) = showJSON s showJSON (Int i) = showJSON i showJSON (Flt f) = showJSON f + readJSON = readBasicJSON Str Int Flt + + +-------------------------------------------------------------------------------- +-- ** Convenience functions + +(!) :: JSON a => JSValue -> String -> Result a +obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key) + readJSON + (lookup key (assocsJSObject obj)) + +assocsJSObject :: JSValue -> [(String, JSValue)] +assocsJSObject (JSObject o) = fromJSObject o +assocsJSObject (JSArray _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array" +assocsJSObject jsvalue = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue + + +readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) => + (String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v +readBasicJSON str int flt o + = str <$> readJSON o + <|> int_or_flt <$> readJSON o + where int_or_flt f | f == fromIntegral n = int n + | otherwise = flt f + where n = round f -- cgit v1.2.3 From 01b9e8da8da56279122395219440760972b4fe49 Mon Sep 17 00:00:00 2001 From: Peter Ljunglöf Date: Fri, 8 Mar 2019 18:33:56 +0100 Subject: canonical GF: flatten several concatenations into one json array, and parse the array back into concatenations --- src/compiler/GF/Grammar/CanonicalJSON.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index ae2c5fab5..8024fe99a 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -136,8 +136,6 @@ instance JSON LinType where instance JSON LinValue where showJSON (LiteralValue l ) = showJSON l - -- concatenation is encoded as a JSON array: - showJSON (ConcatValue v v') = showJSON [showJSON v, showJSON v'] -- most values are encoded as JSON objects: showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)] showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)] @@ -151,6 +149,10 @@ instance JSON LinValue where showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)] -- records are encoded directly as JSON records: showJSON (RecordValue rows) = showJSON rows + -- concatenation is encoded as a JSON array: + showJSON v@(ConcatValue _ _) = showJSON (flatten v []) + where flatten (ConcatValue v v') = flatten v . flatten v' + flatten v = (v :) readJSON o = LiteralValue <$> readJSON o <|> ParamConstant <$> o!".param" @@ -164,6 +166,8 @@ instance JSON LinValue where <|> VariantValue <$> o!".variants" <|> PreValue <$> o!".pre" <*> o!".default" <|> RecordValue <$> readJSON o + <|> do vs <- readJSON o :: Result [LinValue] + return (foldr1 ConcatValue vs) instance JSON LinLiteral where -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: -- cgit v1.2.3 From 8e2424af49dfc8289fe938a36c5cdab96386c074 Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Tue, 12 Mar 2019 22:32:54 +0100 Subject: GF.Grammar.Canonical: add TuplePattern and CommentedValue --- src/compiler/GF/Grammar/Canonical.hs | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src') diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index ab9bf280c..8be659e1b 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -69,6 +69,7 @@ data LinValue = ConcatValue LinValue LinValue | PreValue [([String], LinValue)] LinValue | Projection LinValue LabelId | Selection LinValue LinValue + | CommentedValue String LinValue deriving (Eq,Ord,Show) data LinLiteral = FloatConstant Float @@ -78,6 +79,7 @@ data LinLiteral = FloatConstant Float data LinPattern = ParamPattern ParamPattern | RecordPattern [RecordRow LinPattern] + | TuplePattern [LinPattern] | WildPattern deriving (Eq,Ord,Show) @@ -213,6 +215,7 @@ instance Pretty LinValue where Projection lv l -> ppA lv<>"."<>l Selection tv pv -> ppA tv<>"!"<>ppA pv VariantValue vs -> "variants"<+>block vs + CommentedValue s v -> "{-" <+> s <+> "-}" $$ v _ -> ppA lv instance PPA LinValue where @@ -253,6 +256,7 @@ instance PPA LinPattern where ppA p = case p of RecordPattern r -> block r + TuplePattern ps -> "<"<>punctuate "," ps<>">" WildPattern -> pp "_" _ -> parens p -- cgit v1.2.3 From b11d7d93dcb22b26564f49158414f07f1bd3f4cc Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Wed, 13 Mar 2019 01:51:26 +0100 Subject: GF.Grammar.Canonical: some Functor/Foldable/Traversable instances --- src/compiler/GF/Compile/ConcreteToHaskell.hs | 10 +++++----- src/compiler/GF/Compile/GrammarToCanonical.hs | 10 +++++----- src/compiler/GF/Grammar/Canonical.hs | 17 +++++++++++------ src/compiler/GF/Grammar/CanonicalJSON.hs | 6 +++--- 4 files changed, 24 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index 6d2bf398f..d74fcdacd 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -194,8 +194,8 @@ concrete2haskell opts else LambdaCase (map ppCase cs) where (ds,ts') = dedup ts - (ps,ts) = unzip [(p,t)|TableRowValue p t<-cs] - ppCase (TableRowValue p t) = (ppP p,ppTv (patVars p++vs) t) + (ps,ts) = unzip [(p,t)|TableRow p t<-cs] + ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t) {- ppPredef n = case predef n of @@ -309,8 +309,8 @@ instance Records LinValue where Selection v1 v2 -> records (v1,v2) _ -> S.empty -instance Records TableRowValue where - records (TableRowValue _ v) = records v +instance Records rhs => Records (TableRow rhs) where + records (TableRow _ v) = records v -- | Record subtyping is converted into explicit coercions in Haskell @@ -318,7 +318,7 @@ coerce env ty t = case (ty,t) of (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts) (TableType ti tv,TableValue _ cs) -> - TableValue ti [TableRowValue p (coerce env tv t)|TableRowValue p t<-cs] + TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs] (RecordType rt,RecordValue r) -> RecordValue [RecordRow l (coerce env ft f) | RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]] diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 7442bd495..3b21f7702 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -151,7 +151,7 @@ convert' gr vs = ppT 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] + V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts] where Ok pts = allParamValues gr ty Ok ps = mapM term2patt pts @@ -174,7 +174,7 @@ convert' gr vs = ppT Alts t' vs -> alts vs (ppT t') _ -> error $ "convert' "++show t - ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t) + ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t) ppPredef n = case predef n of @@ -249,19 +249,19 @@ proj r l = selection t v = case t of TableValue tt r -> - case nub [rv|TableRowValue _ rv<-keep] of + case nub [rv|TableRow _ rv<-keep] of [rv] -> rv _ -> Selection (TableValue tt r') v where r' = if null discard then r - else keep++[TableRowValue WildPattern impossible] + else keep++[TableRow WildPattern impossible] (keep,discard) = partition (mightMatchRow v) r _ -> Selection t v impossible = ErrorValue "impossible" -mightMatchRow v (TableRowValue p _) = +mightMatchRow v (TableRow p _) = case p of WildPattern -> True _ -> mightMatch v p diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 8be659e1b..ed4f3fc9e 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -7,6 +7,7 @@ -- by partial evaluation. This is intended as a common intermediate -- representation to simplify export to other formats. +{-# LANGUAGE DeriveTraversable #-} module GF.Grammar.Canonical where import Prelude hiding ((<>)) import GF.Text.Pretty @@ -87,13 +88,17 @@ type ParamValue = Param LinValue type ParamPattern = Param LinPattern type ParamValueDef = Param ParamId -data Param arg = Param ParamId [arg] deriving (Eq,Ord,Show) +data Param arg = Param ParamId [arg] + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) -type RecordRowType = RecordRow LinType +type RecordRowType = RecordRow LinType type RecordRowValue = RecordRow LinValue +type TableRowValue = TableRow LinValue -data RecordRow rhs = RecordRow LabelId rhs deriving (Eq,Ord,Show) -data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Ord,Show) +data RecordRow rhs = RecordRow LabelId rhs + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) +data TableRow rhs = TableRow LinPattern rhs + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) -- *** Identifiers in Concrete Syntax @@ -265,8 +270,8 @@ instance RhsSeparator LinPattern where rhsSep _ = pp "=" instance RhsSeparator rhs => Pretty (RecordRow rhs) where pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v -instance Pretty TableRowValue where - pp (TableRowValue l v) = hang (l<+>"=>") 2 v +instance Pretty rhs => Pretty (TableRow rhs) where + pp (TableRow l v) = hang (l<+>"=>") 2 v -------------------------------------------------------------------------------- instance Pretty ModId where pp (ModId s) = pp s diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 8024fe99a..8b3464674 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -210,10 +210,10 @@ instance JSON a => JSON (RecordRow a) where where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue return (RecordRow (LabelId lbl) value) -instance JSON TableRowValue where - showJSON (TableRowValue l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] +instance JSON rhs => JSON (TableRow rhs) where + showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] - readJSON o = TableRowValue <$> o!".pattern" <*> o!".value" + readJSON o = TableRow <$> o!".pattern" <*> o!".value" -- *** Identifiers in Concrete Syntax -- cgit v1.2.3 From 2979864752d4f6c80089716f3e52db95785f3e37 Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Thu, 14 Mar 2019 16:52:37 +0100 Subject: GF.Compile.GrammarToCanonical: allow + in reg exps in pre { } --- src/compiler/GF/Compile/GrammarToCanonical.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 3b21f7702..32a4e301b 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -218,6 +218,7 @@ convert' gr vs = ppT pat (PString s) = [s] pat (PAlt p1 p2) = pat p1++pat p2 + pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2] pat p = error $ "pat "++show p fields = map field . filter (not.isLockLabel.fst) -- cgit v1.2.3