Expose GF.Grammar.Canonical + some refactoring

to make it available in other tools by depending on the gf package and
importing it

5 files changed, 104 insertions, 52 deletions

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]