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

@@ -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

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

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.

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]

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
 

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)
+block xs = braces (semiSep xs)