From e4abff772556ebee68a7e3b2cbe4fd413a5e845e Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Tue, 22 Jan 2019 17:16:32 +0100 Subject: [PATCH] More work on the canonica_gf export + Abstract syntax now is converted directly from the Grammar and not via PGF, so you can use `gf -batch -no-pmcfg -f canonical_gf ...`, to export to canonical_gf while skipping PMCFG and PGF file generation completely. + Flags that are normally copied to PGF files are now included in the caninical_gf output as well (in particular the startcat flag). --- gf.cabal | 2 +- .../GF/Compile/ConcreteToCanonical.hs | 60 ++++++++++++++++--- src/compiler/GF/Compile/ConcreteToHaskell.hs | 5 ++ src/compiler/GF/Compile/Export.hs | 7 ++- src/compiler/GF/Compiler.hs | 17 ++++-- src/compiler/GF/Grammar/Canonical.hs | 37 +++++++++--- 6 files changed, 101 insertions(+), 27 deletions(-) diff --git a/gf.cabal b/gf.cabal index 898968a48..3a4604d49 100644 --- a/gf.cabal +++ b/gf.cabal @@ -186,7 +186,7 @@ Library GF.Compile.Multi GF.Compile.Optimize GF.Compile.PGFtoHaskell - GF.Compile.PGFtoAbstract +-- GF.Compile.PGFtoAbstract GF.Compile.PGFtoJava GF.Haskell GF.Compile.ConcreteToHaskell diff --git a/src/compiler/GF/Compile/ConcreteToCanonical.hs b/src/compiler/GF/Compile/ConcreteToCanonical.hs index 5208fd005..7422b6205 100644 --- a/src/compiler/GF/Compile/ConcreteToCanonical.hs +++ b/src/compiler/GF/Compile/ConcreteToCanonical.hs @@ -1,25 +1,57 @@ --- | Translate concrete syntax to canonical form -module GF.Compile.ConcreteToCanonical(concretes2canonical) where -import Data.List(nub,sort,sortBy,partition) ---import Data.Function(on) +-- | 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.Data.Utilities(mapSnd) import GF.Text.Pretty import GF.Grammar.Grammar -import GF.Grammar.Lookup(lookupFunType,lookupOrigInfo,allOrigInfos,allParamValues) +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,identS,prefixIdent,showIdent,isWildIdent) --,moduleNameS ---import GF.Infra.Option +import GF.Infra.Ident(ModuleName(..),Ident,identS,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 = @@ -34,7 +66,7 @@ concretes2canonical opts absname gr = -- 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) + Concrete (modId cnc) (modId absname) (convFlags gr cnc) (neededParamTypes S.empty (params defs)) [lincat|(_,Left lincat)<-defs] [lin|(_,Right lin)<-defs] @@ -402,3 +434,13 @@ 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 ad4775697..fc5c689fc 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -18,6 +18,8 @@ import GF.Infra.Ident(Ident,identS,prefixIdent) --,moduleNameS import GF.Infra.Option import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) import GF.Haskell +--import GF.Grammar.Canonical +--import GF.Compile.ConcreteToCanonical import Debug.Trace -- | Generate Haskell code for the all concrete syntaxes associated with @@ -28,6 +30,9 @@ concretes2haskell opts absname gr = cnc<-allConcretes gr absname, let cncname = render cnc ++ ".hs" :: FilePath Ok cncmod = lookupModule gr cnc +{- (_,cnc)<-concretes2canonical opt absname gr, + let ModId name = concName cnc + cncname = name ++ ".hs" :: FilePath--} ] -- | Generate Haskell code for the given concrete module. diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs index 5403298f9..c86c9dd03 100644 --- a/src/compiler/GF/Compile/Export.hs +++ b/src/compiler/GF/Compile/Export.hs @@ -3,7 +3,7 @@ module GF.Compile.Export where import PGF import PGF.Internal(ppPGF) import GF.Compile.PGFtoHaskell -import GF.Compile.PGFtoAbstract +--import GF.Compile.PGFtoAbstract import GF.Compile.PGFtoJava import GF.Compile.PGFtoProlog import GF.Compile.PGFtoJS @@ -35,7 +35,7 @@ exportPGF :: Options exportPGF opts fmt pgf = case fmt of FmtPGFPretty -> multi "txt" (render . ppPGF) - FmtCanonicalGF -> canon "gf" (render80 . abstract2canonical) + FmtCanonicalGF -> [] -- canon "gf" (render80 . abstract2canonical) FmtJavaScript -> multi "js" pgf2js FmtPython -> multi "py" pgf2python FmtHaskell -> multi "hs" (grammar2haskell opts name) @@ -58,7 +58,8 @@ exportPGF opts fmt pgf = multi :: String -> (PGF -> String) -> [(FilePath,String)] multi ext pr = [(name <.> ext, pr pgf)] - canon ext pr = [("canonical"name<.>ext,pr pgf)] + +-- canon ext pr = [("canonical"name<.>ext,pr pgf)] single :: String -> (PGF -> CId -> String) -> [(FilePath,String)] single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- languages pgf] diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index 334bbd592..2bd0fc0cb 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.ConcreteToCanonical--(concretes2canonical) import GF.Compile.CFGtoPGF import GF.Compile.GetGrammar import GF.Grammar.BNFC @@ -60,17 +60,24 @@ compileSourceFiles opts fs = do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $ mapM_ cnc2haskell (snd output) when (FmtCanonicalGF `elem` ofmts) $ - mapM_ cnc2canonical (snd output) + do createDirectoryIfMissing False "canonical" + mapM_ abs2canonical (snd output) + mapM_ cnc2canonical (snd output) where ofmts = flag optOutputFormats opts cnc2haskell (cnc,gr) = do mapM_ writeExport $ concretes2haskell opts (srcAbsName gr cnc) gr + abs2canonical (cnc,gr) = + writeExport ("canonical/"++render absname++".gf",render80 canAbs) + where + absname = srcAbsName gr cnc + canAbs = abstract2canonical absname gr + cnc2canonical (cnc,gr) = - do createDirectoryIfMissing False "canonical" - mapM_ (writeExport.fmap render80) $ - concretes2canonical opts (srcAbsName gr cnc) gr + mapM_ (writeExport.fmap render80) $ + concretes2canonical opts (srcAbsName gr cnc) gr writeExport (path,s) = writing opts path $ writeUTF8File path s diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 8d61a8a53..6d08b815f 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -1,6 +1,7 @@ -- | 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. +-- 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 @@ -12,7 +13,7 @@ data Grammar = Grammar Abstract [Concrete] deriving Show -- ** Abstract Syntax -- | Abstract Syntax -data Abstract = Abstract ModId [CatDef] [FunDef] deriving Show +data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show data CatDef = CatDef CatId [CatId] deriving Show data FunDef = FunDef FunId Type deriving Show @@ -25,8 +26,9 @@ data TypeBinding = TypeBinding VarId Type deriving Show -- ** Concreate syntax -- | Concrete Syntax -data Concrete = Concrete ModId ModId [ParamDef] [LincatDef] [LinDef] +data Concrete = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef] deriving Show +concName (Concrete cnc _ _ _ _ _) = cnc data ParamDef = ParamDef ParamId [ParamValueDef] | ParamAliasDef ParamId LinType @@ -99,6 +101,10 @@ newtype FunId = FunId String deriving (Eq,Show) data VarId = Anonymous | VarId String deriving Show +newtype Flags = Flags [(FlagName,FlagValue)] deriving Show +type FlagName = String +data FlagValue = Str String | Int Int | Flt Double deriving Show + -------------------------------------------------------------------------------- -- ** Pretty printing @@ -106,10 +112,12 @@ instance Pretty Grammar where pp (Grammar abs cncs) = abs $+$ vcat cncs instance Pretty Abstract where - pp (Abstract m cats funs) = "abstract" <+> m <+> "=" <+> "{" $$ - "cat" <+> fsep cats $$ - "fun" <+> vcat funs $$ - "}" + pp (Abstract m flags cats funs) = + "abstract" <+> m <+> "=" <+> "{" $$ + flags $$ + "cat" <+> fsep cats $$ + "fun" <+> vcat funs $$ + "}" instance Pretty CatDef where pp (CatDef c cs) = hsep (c:cs)<>";" @@ -139,7 +147,7 @@ instance Pretty VarId where -------------------------------------------------------------------------------- instance Pretty Concrete where - pp (Concrete cncid absid params lincats lins) = + pp (Concrete cncid absid flags params lincats lins) = "concrete" <+> cncid <+> "of" <+> absid <+> "=" <+> "{" $$ vcat params $$ section "lincat" lincats $$ @@ -241,6 +249,17 @@ 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 Flags where + pp (Flags []) = empty + pp (Flags flags) = "flags" <+> vcat (map ppFlag flags) + where + ppFlag (name,value) = name <+> "=" <+> value <>";" + +instance Pretty FlagValue where + pp (Str s) = pp s + pp (Int i) = pp i + pp (Flt d) = pp d + -------------------------------------------------------------------------------- -- | Pretty print atomically (i.e. wrap it in parentheses if necessary) class Pretty a => PPA a where ppA :: a -> Doc @@ -248,4 +267,4 @@ class Pretty a => PPA a where ppA :: a -> Doc class Pretty rhs => RhsSeparator rhs where rhsSep :: rhs -> Doc semiSep xs = punctuate ";" xs -block xs = braces (semiSep xs) \ No newline at end of file +block xs = braces (semiSep xs)