3 files changed, 60 insertions, 12 deletions
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]