From b783299b73b5c8a8229a45a830cf9b6be0be4f8c Mon Sep 17 00:00:00 2001
From: Thomas Hallgren <th-github@altocumulus.org>
Date: Thu, 7 Mar 2019 14:47:37 +0100
Subject: Rename module GF.Compile.ConcreteToCanonical to
 GF.Compile.GrammarToCanonical

---
 src/compiler/GF/Compile/ConcreteToCanonical.hs | 370 -------------------------
 src/compiler/GF/Compile/ConcreteToHaskell.hs   |   2 +-
 src/compiler/GF/Compile/GrammarToCanonical.hs  | 368 ++++++++++++++++++++++++
 3 files changed, 369 insertions(+), 371 deletions(-)
 delete mode 100644 src/compiler/GF/Compile/ConcreteToCanonical.hs
 create mode 100644 src/compiler/GF/Compile/GrammarToCanonical.hs

(limited to 'src/compiler/GF/Compile')

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
-- 
cgit v1.2.3


From 5b401f3880f68828272dccfb3787cc3b3abd4cc3 Mon Sep 17 00:00:00 2001
From: Thomas Hallgren <th-github@altocumulus.org>
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/compiler/GF/Compile')

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 b11d7d93dcb22b26564f49158414f07f1bd3f4cc Mon Sep 17 00:00:00 2001
From: Thomas Hallgren <th-github@altocumulus.org>
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/compiler/GF/Compile')

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 <th-github@altocumulus.org>
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/compiler/GF/Compile')

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