the JSON dump now supports the entire GF language

src/compiler/api/GF/Compile/ConcreteToHaskell.hs

@@ -3,91 +3,76 @@ module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
 
 import PGF2(Literal(..))
 import Data.List(isPrefixOf,sort,sortOn)
-import qualified Data.Map as M
+import qualified Data.Map as Map
-import qualified Data.Set as S
 import GF.Text.Pretty
---import GF.Grammar.Predef(cPredef,cInts)
+import GF.Grammar.Predef
---import GF.Compile.Compute.Predef(predef)
+import GF.Grammar.Grammar
---import GF.Compile.Compute.Value(Predefined(..))
+import GF.Grammar.Macros
-import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
+import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Haskell as H
-import GF.Grammar.Canonical as C
 import GF.Compile.GrammarToCanonical
-import Debug.Trace(trace)
 
 -- | Generate Haskell code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
 concretes2haskell opts absname gr = do
-  Grammar abstr cncs <- grammar2canonical opts absname gr
+  gr <- grammar2canonical opts absname gr
-  return [(filename,render80 $ concrete2haskell opts abstr cncmod)
+  let abstr:concrs = modules gr
-             | cncmod<-cncs,
+  return [(filename,render80 $ concrete2haskell opts abstr concr)
-               let ModId name = concName cncmod
+             | concr@(MN mn,_) <- concrs,
-                   filename = showRawIdent name ++ ".hs" :: FilePath
+               let filename = showIdent mn ++ ".hs" :: FilePath
          ]
 
 -- | Generate Haskell code for the given concrete module.
 -- The only options that make a difference are
 -- @-haskell=noprefix@ and @-haskell=variants@.
-concrete2haskell opts
+concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) =
-                 abstr@(Abstract _ _ cats funs)
+  haskPreamble absname cncname $$
-                 modinfo@(Concrete cnc absname _ ps lcs lns) =
-  haskPreamble absname cnc $$
   vcat (
     nl:Comment "--- Parameter types ---":
-    map paramDef ps ++
+    [paramDef id ps | (id,ResParam (Just (L _ ps)) _) <- Map.toList (jments mi)] ++
     nl:Comment "--- Type signatures for linearization functions ---":
-    map signature cats ++
+    [signature id | (id,CncCat _ _ _ _ _) <- Map.toList (jments mi)] ++
-    nl:Comment "--- Linearization functions for empty categories ---":
-    emptydefs ++
     nl:Comment "--- Linearization types ---":
-    map lincatDef lcs ++
+    [lincatDef id ty | (id,CncCat (Just (L _ ty)) _ _ _ _) <- Map.toList (jments mi)] ++
     nl:Comment "--- Linearization functions ---":
-    lindefs ++
+    concat (Map.elems lindefs) ++
     nl:Comment "--- Type classes for projection functions ---":
-    map labelClass (S.toList labels) ++
+    -- map labelClass (S.toList labels) ++
     nl:Comment "--- Record types ---":
-    concatMap recordType recs)
+    [] -- concatMap recordType recs
+    )
   where
     nl = Comment ""
-    recs = S.toList (S.difference (records (lcs,lns)) common_records)
 
-    labels = S.difference (S.unions (map S.fromList recs)) common_labels
+    signature c = TypeSig lf (Fun abs (pure lin))
-    common_records = S.fromList [[label_s]]
-    common_labels = S.fromList [label_s]
-    label_s = LabelId (rawIdentS "s")
-
-    signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
       where
         abs = tcon0 (prefixIdent "A." (gId c))
         lin = tcon0 lc
         lf = linfunName c
         lc = lincatName c
 
-    emptydefs = map emptydef (S.toList emptyCats)
+    gId :: Ident -> Ident
-    emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined")
-
-    emptyCats = allcats `S.difference` linfuncats
-      where
-     --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
-       allcats = S.fromList [c | CatDef c _<-cats]
-
-    gId :: ToIdent i => i -> Ident
     gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
-          . toIdent
 
     va = haskellOption opts HaskellVariants
     pure = if va then ListT else id
 
-    haskPreamble :: ModId -> ModId -> Doc
+    haskPreamble :: ModuleName -> ModuleName -> Doc
     haskPreamble absname cncname =
       "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
       "module" <+> cncname <+> "where" $$
       "import Prelude hiding (Ordering(..))" $$
       "import Control.Applicative((<$>),(<*>))" $$
-      "import PGF.Haskell" $$
       "import qualified" <+> absname <+> "as A" $$
       "" $$
+      "-- | Token sequences, output form linearization functions" $$
+      "type Str = [Tok] -- token sequence" $$
+      "" $$
+      "-- | Tokens" $$
+      "data Tok = TK String | TP [([Prefix],Str)] Str | BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT" $$
+      "         deriving (Eq,Ord,Show)" $$
+      "" $$
       "--- Standard definitions ---" $$
       "linString (A.GString s) ="<+>pure "R_s [TK s]" $$
       "linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
@@ -99,319 +84,122 @@ concrete2haskell opts
       where
         pure = if va then brackets else pp
 
-    paramDef pd =
+    paramDef id pvs = Data (conap0 (gId id)) (map paramCon pvs) derive
-      case pd of
-        ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
-        ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
       where
-            paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
+        paramCon (id,ctxt) = ConAp (gId id) [tcon0 (gId cat) | (_,_,QC (_,cat)) <- ctxt]
         derive = ["Eq","Ord","Show"]
 
-    convLinType = ppT
+    convLinType (Sort s)
-      where
+      | s == cStr = tcon0 (identS "Str")
-        ppT t =
+    convLinType (QC (_,p)) = tcon0 (gId p)
-          case t of
+    convLinType (RecType lbls) = tcon (rcon' ls) (map convLinType ts)
-            FloatType -> tcon0 (identS "Float")
+      where (ls,ts) = unzip $ sortOn fst lbls
-            IntType -> tcon0 (identS "Int")
+    convLinType (Table pt lt) = Fun (convLinType pt) (convLinType lt)
-            ParamType (ParamTypeId p) -> tcon0 (gId p)
-            RecordType rs -> tcon (rcon' ls) (map ppT ts)
-              where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
-            StrType -> tcon0 (identS "Str")
-            TableType pt lt -> Fun (ppT pt) (ppT lt)
---          TupleType lts ->
 
-    lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
+    lincatDef c ty = tsyn0 (lincatName c) (convLinType ty)
 
-    linfuncats = S.fromList linfuncatl
+    lindefs =
-    (linfuncatl,lindefs) = unzip (linDefs lns)
+      Map.fromListWith (++) 
+        [linDef id absctx cat lincat rhs |
+            (id,CncFun (Just (absctx,cat,_,lincat)) (Just (L _ rhs)) _ _) <- Map.toList (jments mi)]
 
-    linDefs = map eqn . sortOn fst . map linDef
+    linDef f absctx cat lincat rhs0 =
-      where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
+      (cat,[Eqn (linfunName cat,lhs) rhs'])
-
-    linDef (LinDef f xs rhs0) =
-        (cat,(linfunName cat,(lhs,rhs)))
       where
         lhs = [ConP (aId f) (map VarP abs_args)]
         aId f = prefixIdent "A." (gId f)
 
-        [lincat] = [lincat | LincatDef c lincat<-lcs,c==cat]
+        --[C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
-        [C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
+        (xs,rhs) = termFormCnc rhs0
 
         abs_args = map abs_arg args
         abs_arg = prefixIdent "abs_"
-        args = map (prefixIdent "g" . toIdent) xs
+        args = map (prefixIdent "g" . snd) xs
 
-        rhs = lets (zipWith letlin args absctx)
+        rhs' = lets (zipWith letlin args absctx)
-                   (convert vs (coerce env lincat rhs0))
+                    (convert rhs)
           where
-            vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
+            vs = [(x,a)|((_,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 _))) =
+        letlin a acat =
           (a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
 
-        arglincat (TypeBinding _ (C.Type _ (TypeApp acat _))) = lincat
+    convert (Vr v) = Var (gId v)
+    convert (EInt n) = lit n
+    convert (EFloat d) = lit d
+    convert (K s) = single (Const "TK" `Ap` lit s)
+    convert Empty = List []
+    convert (App t1 t2) = Ap (convert t1) (convert t2)
+    convert (R lbls) = aps (rcon ls) (map (convert.snd) ts)
+                         where (ls,ts) = unzip (sortOn fst lbls)
+    convert (P t lbl) = ap (proj lbl) (convert t)
+    convert (ExtR t1 t2) = Const "ExtR" -- TODO
+    convert (T _ cs) = LambdaCase (map ppCase cs)
       where
-            [lincat] = [lincat | LincatDef c lincat<-lcs,c==acat]
+        ppCase (p,t) = (convertPatt p,convert t)
-
+    convert (V _ ts) = Const "V" -- TODO
-    convert = convert' va
+    convert (S t p)
-
+      | va        = select_va (convert t) (convert p)
-    convert' va vs = ppT
+      | otherwise = Ap (convert t) (convert p)
       where
-        ppT0 = convert' False vs
+        select_va (List [t]) (List [p]) = Op t "!" p
-        ppTv vs' = convert' va vs'
+        select_va (List [t]) p = Op t "!$" p
-
+        select_va t p = Op t "!*" p
-        pure = if va then single else id
+    convert (Q  (_,id)) = single (Var id)
-
+    convert (QC (_,id)) = single (Var id)
-        ppT t =
+    convert (C t1 t2)
-          case t of
+      | va        = concat_va (convert t1) (convert t2)
-            TableValue ty cs -> pure (table cs)
+      | otherwise = plusplus  (convert t1) (convert t2)
-            Selection t p -> select (ppT t) (ppT p)
-            ConcatValue t1 t2 -> concat (ppT t1) (ppT t2)
-            RecordValue r -> aps (rcon ls) (map ppT ts)
-              where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-r]
-            PredefValue p -> single (Var (toIdent p)) -- hmm
-            Projection t l -> ap (proj l) (ppT t)
-            VariantValue [] -> empty
-            VariantValue ts@(_:_) -> variants ts
-            VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
-            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
-            LFlt x -> pure (lit x)
-            LInt n -> pure (lit n)
-            LStr s -> pure (token s)
-
-        pId p@(ParamId s) =
-          if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
-
-        table cs =
-            if all (null.patVars) ps
-            then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
-            else LambdaCase (map ppCase cs)
       where
-            (ds,ts') = dedup ts
+        concat_va (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
-            (ps,ts) = unzip [(p,t)|TableRow p t<-cs]
+        concat_va t1 t2 = Op t1 "+++" t2
-        ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
+    convert (Glue t1 t2) = Const "Glue"
-{-
+    convert (FV ts)
-        ppPredef n =
+      | va        = join (List (map convert ts))
-          case predef n of
+      | otherwise = case ts of
-            Ok BIND       -> single (c "BIND")
+                      []     -> Const "error" `Ap` Const (show "empty variant")
-            Ok SOFT_BIND  -> single (c "SOFT_BIND")
+                      (t:ts) -> convert t
-            Ok SOFT_SPACE -> single (c "SOFT_SPACE")
-            Ok CAPIT      -> single (c "CAPIT")
-            Ok ALL_CAPIT  -> single (c "ALL_CAPIT")
-            _ -> Var n
--}
-        ppP p =
-          case p of
-            ParamPattern (Param c ps) -> ConP (gId c) (map ppP ps)
-            RecordPattern r -> ConP (rcon' ls) (map ppP ps)
-              where (ls,ps) = unzip $ sortOn fst [(l,p)|RecordRow l p<-r]
-            WildPattern -> WildP
-
-        token s = single (c "TK" `Ap` lit s)
-
-        alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
       where
-            alt (s,t) = Pair (List (pre s)) (ppT0 t)
+        join (List [x]) = x
-            pre s = map lit s
+        join x = Const "concat" `Ap` x
-
+    convert (Alts def alts) = single (Const "TP" `Ap` List (map convAlt alts) `Ap` convert def)
-        c = Const
-        lit s = c (show s) -- hmm
-        concat = if va then concat' else plusplus
       where
-            concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
+        convAlt (t1,t2) = Pair (convert t1) (convert t2)
-            concat' t1 t2 = Op t1 "+++" t2
+    convert (Strs ss) = List (map lit ss)
+    convert t = error (show t)
 
-        pure' = single -- forcing the list monad
+    convertPatt (PC c     ps) = ConP (gId c) (map convertPatt ps)
+    convertPatt (PP (_,c) ps) = ConP (gId c) (map convertPatt ps)
+    convertPatt (PV v)        = VarP v
+    convertPatt PW            = WildP
+    convertPatt (PR lbls)     = ConP (rcon' ls) (map convertPatt ps)
+      where (ls,ps) = unzip $ sortOn fst lbls
+    convertPatt (PString s)   = Lit s
+    convertPatt (PT _ p)      = convertPatt p
+    convertPatt (PAs v p)     = AsP v (convertPatt p)
+    convertPatt (PImplArg p)  = convertPatt p
+    convertPatt (PTilde _)    = WildP
+    convertPatt (PAlt _ _)    = WildP -- TODO
+    convertPatt p = error (show p)
 
-        select = if va then select' else Ap
+    lit s = Const (show s) -- hmm
-        select' (List [t]) (List [p]) = Op t "!" p
-        select' (List [t]) p = Op t "!$" p
-        select' t p = Op t "!*" p
 
     ap = if va then ap' else Ap
        where
          ap' (List [f]) x = fmap f x
          ap' f x = Op f "<*>" x
-            fmap f (List [x]) = pure' (Ap f x)
+         fmap f (List [x]) = Ap f x
          fmap f x = Op f "<$>" x
 
-    --  join = if va then join' else id
-        join' (List [x]) = x
-        join' x = c "concat" `Ap` x
-
-        empty = if va then List [] else c "error" `Ap` c (show "empty variant")
-        variants = if va then \ ts -> join' (List (map ppT ts))
-                         else \ (t:_) -> ppT t
-
     aps f [] = f
     aps f (a:as) = aps (ap f a) as
 
-        dedup ts =
-            if M.null dups
-            then ([],map ppT ts)
-            else ([(ev i,ppT t)|(i,t)<-defs],zipWith entry ts is)
-          where
-            entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
-            ev i = identS ("e'"++show i)
-
-            defs = [(i1,t)|(t,i1:_:_)<-ms]
-            dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
-            ms = M.toList m
-            m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
-            is = [0..]::[Int]
-
-
---con = Cn . identS
-
-class Records t where
-  records :: t -> S.Set [LabelId]
-
-instance Records t => Records [t] where
-  records = S.unions . map records
-
-instance (Records t1,Records t2) => Records (t1,t2) where
-  records (t1,t2) = S.union (records t1) (records t2)
-
-instance Records LincatDef where
-  records (LincatDef _ lt) = records lt
-
-instance Records LinDef where
-  records (LinDef _ _ lv) = records lv
-
-instance Records LinType where
-  records t =
-    case t of
-      RecordType r -> rowRecords r
-      TableType pt lt -> records (pt,lt)
-      TupleType ts -> records ts
-      _ -> S.empty
-
-rowRecords r = S.insert (sort ls) (records ts)
-  where (ls,ts) = unzip [(l,t)|RecordRow l t<-r]
-
-instance Records LinValue where
-  records v =
-    case v of
-      ConcatValue v1 v2 -> records (v1,v2)
-      ParamConstant (Param c vs) -> records vs
-      RecordValue r -> rowRecords r
-      TableValue t r -> records (t,r)
-      TupleValue vs -> records vs
-      VariantValue vs -> records vs
-      PreValue alts d -> records (map snd alts,d)
-      Projection v l -> records v
-      Selection v1 v2 -> records (v1,v2)
-      _ -> S.empty
-
-instance Records rhs => Records (TableRow rhs) where
-  records (TableRow _ v) = records v
-
-
--- | Record subtyping is converted into explicit coercions in Haskell
-coerce env ty t =
-  case (ty,t) of
-    (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
-    (TableType ti tv,TableValue _ 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]]
-    (RecordType rt,VarValue x)->
-      case lookup x env of
-        Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
-                            --trace ("coerce "++render ty'++" to "++render ty) $
-                            app (to_rcon rt) [t]
-                 | otherwise -> t -- types match, no coercion needed
-        _ -> trace (render ("missing type to coerce"<+>x<+>"to"<+>render ty
-                            $$ "in" <+> map fst env))
-                   t
-    _ -> t
-  where
-    app f ts = ParamConstant (Param f ts) -- !! a hack
-    to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
-
-patVars p = []
-
-labels r = [l | RecordRow l _ <- r]
-
 proj = Var . identS . proj'
-proj' (LabelId l) = "proj_" ++ showRawIdent l
+proj' (LIdent l) = "proj_" ++ showRawIdent l
 rcon = Var . rcon'
 rcon' = identS . rcon_name
-rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
+rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LIdent l <- ls])
-to_rcon' = ("to_"++) . rcon_name
 
-recordType ls =
+lincatName,linfunName :: Ident -> Ident
-    Data lhs [app] ["Eq","Ord","Show"]:
+lincatName c = prefixIdent "Lin" c
-    enumAllInstance:
+linfunName c = prefixIdent "lin" c
-    zipWith projection vs ls ++
-    [Eqn (identS (to_rcon' ls),[VarP r])
-         (foldl Ap (Var cn) [Var (identS (proj' l)) `Ap` Var r|l<-ls])]
-  where
-    r = identS "r"
-    cn = rcon' ls
- -- Not all record labels are syntactically correct as type variables in Haskell
- -- app = cn<+>ls
-    lhs = ConAp cn vs -- don't reuse record labels
-    app = fmap TId lhs
-    tapp = foldl TAp (TId cn) (map TId vs)
-    vs = [identS ('t':show i)|i<-[1..n]]
-    n = length ls
-
-    projection v l = Instance [] (TId name `TAp` tapp `TAp` TId v)
-                              [((prj,[papp]),Var v)]
-     where
-       name = identS ("Has_"++render l)
-       prj = identS (proj' l)
-       papp = ConP cn (map VarP vs)
-
-    enumAllInstance =
-       Instance ctx (tEnumAll `TAp` tapp)[(lhs0 "enumAll",enumCon cn n)]
-      where
-        ctx =  [tEnumAll `TAp` TId v|v<-vs]
-        tEnumAll = TId (identS "EnumAll")
-
-labelClass l =
-    Class [] (ConAp name [r,a]) [([r],[a])]
-          [(identS (proj' l),TId r `Fun` TId a)]
-  where
-    name = identS ("Has_"++render l)
-    r = identS "r"
-    a = identS "a"
-
-enumCon name arity =
-    if arity==0
-    then single (Var name)
-    else foldl ap (single (Var name)) (replicate arity (Const "enumAll"))
-  where
-    ap (List [f]) a = Op f "<$>" a
-    ap f a = Op f "<*>" a
-
-lincatName,linfunName :: CatId -> Ident
-lincatName c = prefixIdent "Lin" (toIdent c)
-linfunName c = prefixIdent "lin" (toIdent c)
-
-class ToIdent i where toIdent :: i -> Ident
-
-instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
-instance ToIdent PredefId where toIdent (PredefId s) = identC s
-instance ToIdent CatId   where toIdent (CatId s) = identC s
-instance ToIdent C.FunId where toIdent (FunId s) = identC s
-instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
-
-qIdentC = identS . unqual
-
-unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
-unqual (Unqual n) = showRawIdent n
-
-instance ToIdent VarId where
-  toIdent Anonymous = identW
-  toIdent (VarId s) = identC s

src/compiler/api/GF/Compile/GrammarToCanonical.hs

@@ -2,422 +2,104 @@
 -- (a common intermediate representation to simplify export to other formats)
 module GF.Compile.GrammarToCanonical(
        grammar2canonical,abstract2canonical,concretes2canonical,
-       projection,selection
        ) where
-import Data.List(nub,partition)
-import qualified Data.Map as M
-import Data.Maybe(fromMaybe)
-import qualified Data.Set as S
-import GF.Data.ErrM
-import GF.Text.Pretty
-import GF.Grammar.Grammar as G
-import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
-import GF.Grammar.Lockfield(isLockLabel)
-import GF.Grammar.Predef(cPredef,cInts)
-import GF.Infra.Ident(ModuleName(..),Ident,identW,ident2raw,rawIdentS,showIdent)
-import GF.Infra.Option(Options,optionsPGF)
-import GF.Infra.CheckM
-import PGF2(Literal(..))
-import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
-import GF.Grammar.Canonical as C
-import System.FilePath ((</>), (<.>))
-import qualified Debug.Trace as T
 
+import GF.Data.ErrM
+import GF.Grammar.Grammar
+import GF.Grammar.Lookup(allOrigInfos,lookupOrigInfo)
+import GF.Infra.Option(Options,noOptions)
+import GF.Infra.CheckM
+import GF.Compile.Compute.Concrete2
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Maybe(mapMaybe)
+import Control.Monad (forM)
 
 -- | Generate Canonical code for the named abstract syntax and all associated
 -- concrete syntaxes
-grammar2canonical :: Options -> ModuleName -> G.Grammar -> Check C.Grammar
+grammar2canonical :: Options -> ModuleName -> Grammar -> Check Grammar
 grammar2canonical opts absname gr = do
   abs <- abstract2canonical absname gr
   cncs <- concretes2canonical opts absname gr
-  return (Grammar abs (map snd cncs))
+  return (mGrammar (abs:cncs))
 
 -- | Generate Canonical code for the named abstract syntax
-abstract2canonical :: ModuleName -> G.Grammar -> Check Abstract
+abstract2canonical :: ModuleName -> Grammar -> Check Module
-abstract2canonical absname gr =
+abstract2canonical absname gr = do
-  return (Abstract (modId absname) (convFlags gr absname) cats funs)
+  let infos = [(id,info) | ((mn,id),info) <- allOrigInfos gr absname]
-  where
+  return (absname, ModInfo {
-    cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
+                     mtype   = MTAbstract,
-
+                     mstatus = MSComplete,
-    funs = [FunDef (gId f) (convType ty) |
+                     mflags  = convFlags gr absname,
-            ((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs]
+                     mextend = [],
-
+                     mwith   = Nothing,
-    adefs = allOrigInfos gr absname
+                     mopens  = [],
-
+                     mexdeps = [],
-    convCtx = maybe [] (map convHypo . unLoc)
+                     msrc    = "",
-    convHypo (bt,name,t) =
+                     mseqs   = Nothing,
-      case typeForm t of
+                     jments  = Map.fromList infos
-        ([],(_,cat),[]) -> gId cat -- !!
+                   })
-        tf -> error ("abstract2canonical convHypo: " ++ show tf)
-
-    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 :: Options -> ModuleName -> G.Grammar -> Check [(FilePath, Concrete)]
+concretes2canonical :: Options -> ModuleName -> Grammar -> Check [Module]
 concretes2canonical opts absname gr =
   sequence
-    [fmap ((,) cncname) (concrete2canonical gr absname cnc cncmod)
+    [concrete2canonical gr absname cnc modinfo
         | cnc<-allConcretes gr absname,
-          let cncname = "canonical" </> render cnc <.> "gf"
+          let Ok modinfo = lookupModule gr cnc
-              Ok cncmod = lookupModule gr cnc
         ]
 
 -- | Generate Canonical GF for the given concrete module.
-concrete2canonical :: G.Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Concrete
+concrete2canonical :: Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Module
-concrete2canonical gr absname cnc modinfo = do
+concrete2canonical gr absname cncname modinfo = do
-  defs <- fmap concat $ mapM (toCanonical gr absname) (M.toList (jments modinfo))
+  let g = Gl gr (stdPredef g)
-  return (Concrete (modId cnc) (modId absname) (convFlags gr cnc)
+  infos <- mapM (convInfo g) (allOrigInfos gr cncname)
-                   (neededParamTypes S.empty (params defs))
+  let pts = Set.unions (map fst infos)
-                   [lincat | (_,Left lincat) <- defs]
+  pts <- closure pts (Set.toList pts)
-                   [lin | (_,Right lin) <- defs])
+  return (cncname, ModInfo {
+                     mtype   = MTConcrete absname,
+                     mstatus = MSComplete,
+                     mflags  = convFlags gr cncname,
+                     mextend = [],
+                     mwith   = Nothing,
+                     mopens  = [],
+                     mexdeps = [],
+                     msrc    = "",
+                     mseqs   = Nothing,
+                     jments  = Map.union (Map.fromList (mapMaybe snd infos))
+                                         pts
+                   })
   where
-    params = S.toList . S.unions . map fst
+    convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do
+      typ <- normalForm g typ
+      let pts = paramTypes typ
+      return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mb_prods))
+    convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mb_prods) = do
+      def <- normalForm g (eta_expand def ctx)
+      return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mb_prods))
+    convInfo g  _ = return (Set.empty,Nothing)
 
-    neededParamTypes have [] = []
+    eta_expand t []                   = t
-    neededParamTypes have (q:qs) =
+    eta_expand t ((Implicit,x,_):ctx) = Abs Implicit x (eta_expand (App t (ImplArg (Vr x))) ctx)
-        if q `S.member` have
+    eta_expand t ((Explicit,x,_):ctx) = Abs Explicit x (eta_expand (App t (Vr x))           ctx)
-        then neededParamTypes have qs
-        else let ((got,need),def) = paramType gr q
-             in def++neededParamTypes (S.union got have) (S.toList need++qs)
 
--- toCanonical :: G.Grammar -> ModuleName -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
+    paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
-toCanonical gr absname (name,jment) =
+    paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
-  case jment of
+    paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
-    CncCat (Just (L loc typ)) _ _ pprn _ -> do
+    paramTypes (Sort _) = Set.empty
-      ntyp <- normalForm (Gl gr stdPredef) typ
+    paramTypes (EInt _) = Set.empty
-      let pts = paramTypes gr ntyp
+    paramTypes (QC q) = Set.singleton q
-      return [(pts,Left (LincatDef (gId name) (convType ntyp)))]
+    paramTypes (FV ts) = Set.unions (map paramTypes ts)
-    CncFun (Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do
+    paramTypes _ = Set.empty
-      let params = [(b,x)|(b,x,_)<-ctx]
-          args   = map snd params
-      e0 <- normalForm (Gl gr stdPredef) (mkAbs params (mkApp def (map Vr args)))
-      let e   = cleanupRecordFields lincat (unAbs (length params) e0)
-          tts = tableTypes gr [e]
-      return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))]
-    AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
-                     Ok (m,jment) -> toCanonical gr absname (name,jment)
-                     _ -> return []
-    _ -> return []
-  where
-    unAbs 0 t = t
-    unAbs n (Abs _ _ t) = unAbs (n-1) t
-    unAbs _ t = t
 
-tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
+    closure pts []            = return Map.empty
-tableTypes gr ts = S.unions (map tabtys ts)
+    closure pts (q@(_,id):qs) = do
-  where
+      (_,info@(ResParam (Just (L _ ps)) _)) <- lookupOrigInfo gr q
-    tabtys t =
+      let pts'    = Set.unions [paramTypes ty | (_,ctx) <- ps, (_,_,ty) <- ctx]
-      case t of
+          new_pts = Set.difference pts' pts
-        V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
+      infos <- closure (Set.union new_pts pts) (Set.toList new_pts++qs)
-        T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
+      return (Map.insert id info infos)
-        _ -> collectOp tabtys t
 
-paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
+convFlags :: Grammar -> ModuleName -> Options
-paramTypes gr t =
+convFlags gr mn = err (const noOptions) mflags (lookupModule gr mn)
-  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 = T.trace ("Ignore: " ++ show t) S.empty
-
--- | Filter out record fields from definitions which don't appear in lincat.
-cleanupRecordFields :: G.Type -> Term -> Term
-cleanupRecordFields (RecType ls) (R as) =
-  let defnFields = M.fromList ls
-  in R
-      [ (lbl, (mty, t'))
-      | (lbl, (mty, t)) <- as
-      , M.member lbl defnFields
-      , let Just ty = M.lookup lbl defnFields
-      , let t' = cleanupRecordFields ty t
-      ]
-cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
-cleanupRecordFields _ t = t
-
-convert :: G.Grammar -> Term -> LinValue
-convert gr = convert' gr []
-
-convert' :: G.Grammar -> [Ident] -> Term -> LinValue
-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) [TableRow (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 (sortRec 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 -> LiteralValue (LInt 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 (LStr s)
-        Empty -> LiteralValue (LStr "")
-        FV ts -> VariantValue (map ppT ts)
-        Alts t' vs -> alts vs (ppT t')
-        _ -> error $ "convert' ppT: " ++ show t
-
-    ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
-
-    ppPredef n = error "TODO: ppPredef" {-
-      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 (gQId cPredef n) -- hmm
-      where
-       p = PredefValue . PredefId . rawIdentS
--}
-    ppP p =
-      case p of
-        PC c ps -> ParamPattern (Param (gId 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
-        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) -}
-        _ -> error $ "convert' ppP: " ++ show 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 Empty = [""]  -- Empty == K ""
-        pre (Strs ts) = concatMap pre ts
-        pre (EPatt _ _ p) = pat p
-        pre t = error $ "convert' alts pre: " ++ show t
-
-        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 $ "convert' alts 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 :: LinValue -> LinValue -> LinValue
-concatValue v1 v2 =
-  case (v1,v2) of
-    (LiteralValue (LStr ""),_) -> v2
-    (_,LiteralValue (LStr "")) -> v1
-    _ -> ConcatValue v1 v2
-
--- | Smart constructor for projections
-projection :: LinValue -> LabelId -> LinValue
-projection r l = fromMaybe (Projection r l) (proj r l)
-
-proj :: LinValue -> LabelId -> Maybe LinValue
-proj r l =
-  case r of
-    RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
-                          [v] -> Just v
-                          _ -> Nothing
-    _ -> Nothing
-
--- | Smart constructor for selections
-selection :: LinValue -> LinValue -> LinValue
-selection t v =
-  -- Note: impossible cases can become possible after grammar transformation
-  case t of
-    TableValue tt r ->
-        case nub [rv | TableRow _ rv <- keep] of
-          [rv] -> rv
-          _ -> Selection (TableValue tt r') v
-      where
-        -- Don't introduce wildcard patterns, true to the canonical format,
-        -- annotate (or eliminate) rhs in impossible rows
-        r' = map trunc r
-        trunc r@(TableRow p e) = if mightMatchRow v r
-                                 then r
-                                 else TableRow p (impossible e)
-        {-
-        -- Creates smaller tables, but introduces wildcard patterns
-        r' = if null discard
-             then r
-             else keep++[TableRow WildPattern impossible]
-        -}
-        (keep,discard) = partition (mightMatchRow v) r
-    _ -> Selection t v
-
-impossible :: LinValue -> LinValue
-impossible = CommentedValue "impossible"
-
-mightMatchRow :: LinValue -> TableRow rhs -> Bool
-mightMatchRow v (TableRow p _) =
-  case p of
-    WildPattern -> True
-    _ -> mightMatch v p
-
-mightMatch :: LinValue -> LinPattern -> Bool
-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 (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
-        _ -> False
-    _ -> True
-
-patVars :: Patt -> [Ident]
-patVars p =
-  case p of
-    PV x -> [x]
-    PAs x p -> x:patVars p
-    _ -> collectPattOp patVars p
-
-convType :: Term -> LinType
-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 (gQId m n))
-        Q (m,n) -> ParamType (ParamTypeId (gQId m n))
-        _ -> error $ "convType ppT: " ++ 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 $ "convType convSort: " ++ show k
-
-toParamType :: Term -> ParamType
-toParamType t = case convType t of
-                  ParamType pt -> pt
-                  _ -> error $ "toParamType: " ++ show t
-
-toParamId :: Term -> ParamId
-toParamId t = case toParamType t of
-                   ParamTypeId p -> p
-
-paramType :: G.Grammar
-             -> (ModuleName, Ident)
-             -> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
-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 = 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 ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
-        | otherwise ->
-           ((S.singleton (m,n),paramTypes gr t),
-            [ParamAliasDef (gQId m n) (convType t)])
-      _ -> ((S.empty,S.empty),[])
-  where
-    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]
-
-lblId :: Label -> C.LabelId
-lblId (LIdent ri) = LabelId ri
-lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
-
-modId :: ModuleName -> C.ModId
-modId (MN m) = ModId (ident2raw m)
-
-class FromIdent i where
-  gId :: Ident -> i
-
-instance FromIdent VarId where
-  gId i = if i == identW then Anonymous else VarId (ident2raw i)
-
-instance FromIdent C.FunId where gId = C.FunId . ident2raw
-instance FromIdent CatId where gId = CatId . ident2raw
-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 :: ModuleName -> Ident -> QualId
-qual m n = Qual (modId m) (ident2raw n)
-
-unqual :: Ident -> QualId
-unqual n = Unqual (ident2raw n)
-
-convFlags :: G.Grammar -> ModuleName -> Flags
-convFlags gr mn =
-  Flags [(rawIdentS n,v) |
-         (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]

src/compiler/api/GF/Compile/PGFtoHaskell.hs

@@ -39,7 +39,6 @@ grammar2haskell opts name gr = foldr (++++) [] $
     where gr' = hSkeleton gr
           gadt = haskellOption opts HaskellGADT
           dataExt = haskellOption opts HaskellData
-          pgf2 = haskellOption opts HaskellPGF2
           lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
           gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
               | otherwise = ("G"++) . rmForbiddenChars
@@ -54,8 +53,7 @@ grammar2haskell opts name gr = foldr (++++) [] $
           extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
                        | dataExt = ["import Data.Data"]
                        | otherwise = []
-          pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
+          pgfImports = ["import PGF2", ""]
-                     | otherwise = ["import PGF hiding (Tree)"]
           types | gadt = datatypesGADT gId lexical gr'
                 | otherwise = datatypes gId derivingClause lexical gr'
           compos | gadt = prCompos gId lexical gr' ++ composClass
@@ -78,7 +76,7 @@ haskPreamble gadt name derivingClause imports =
   "",
   predefInst gadt derivingClause "GString" "String"  "unStr"    "mkStr",
   "",
-  predefInst gadt derivingClause "GInt"    "Int"     "unInt"    "mkInt",
+  predefInst gadt derivingClause "GInt"    "Integer"     "unInt"    "mkInt",
   "",
   predefInst gadt derivingClause "GFloat"  "Double"  "unFloat"  "mkFloat",
   "",
@@ -234,14 +232,14 @@ hInstance gId lexical m (cat,rules)
  | otherwise =
   "instance Gf" +++ gId cat +++ "where\n" ++
   unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
-            ++ if lexical cat then ["  gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else [])
+            ++ if lexical cat then ["  gf (" ++ lexicalConstructor cat +++ "x) = mkApp x []"] else [])
  where
    ec = elemCat cat
    baseVars = mkVars (baseSize (cat,rules))
    mkInst f xx = let xx' = mkVars (length xx) in "  gf " ++
      (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
      "=" +++ mkRHS f xx'
-   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
+   mkRHS f vars = "mkApp \"" ++ f ++ "\"" +++
        "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
 
 mkVars :: Int -> [String]
@@ -265,7 +263,7 @@ fInstance gId lexical m (cat,rules) =
     mkInst f xx =
      "      Just (i," ++
      "[" ++ prTList "," xx' ++ "])" +++
-     "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
+     "| i == \"" ++ f ++ "\" ->" +++ mkRHS f xx'
        where
          xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
          mkRHS f vars

src/compiler/api/GF/Compiler.hs

@@ -6,11 +6,13 @@ 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.GrammarToCanonical--(concretes2canonical)
+import GF.Compile.GrammarToCanonical
 import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
 import GF.Grammar.CFG
+import GF.Grammar.JSON(grammar2json)
+import GF.Grammar.Printer(TermPrintQual(..),ppModule)
 
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
@@ -24,7 +26,7 @@ import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.ByteString.Lazy as BSL
-import GF.Grammar.CanonicalJSON (encodeJSON)
+import Text.JSON (encode)
 import System.FilePath
 import Control.Monad(when,unless,forM_,foldM)
 
@@ -64,7 +66,7 @@ compileSourceFiles opts fs =
            do createDirectoryIfMissing False "canonical"
               mapM_ abs2canonical canonical
               mapM_ cnc2canonical canonical
-         when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2json canonical
+         when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2canonical_json canonical
       where
         ofmts = flag optOutputFormats opts
 
@@ -74,17 +76,17 @@ compileSourceFiles opts fs =
 
     abs2canonical (cnc,gr) = do
       (canAbs,_) <- runCheck (abstract2canonical absname gr)
-      writeExport ("canonical/"++render absname++".gf",render80 canAbs)
+      writeExport ("canonical/"++render absname++".gf",render80 (ppModule Unqualified canAbs))
       where
         absname = srcAbsName gr cnc
 
     cnc2canonical (cnc,gr) = do
       (res,_) <- runCheck (concretes2canonical opts (srcAbsName gr cnc) gr)
-      mapM_ (writeExport.fmap render80) res
+      sequence_ [writeExport ("canonical/"++render mn++".gf",render80 (ppModule Unqualified m)) | m@(mn,mi) <- res]
 
-    grammar2json (cnc,gr) = do
+    grammar2canonical_json (cnc,gr) = do
       (gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
-      return (encodeJSON (render absname ++ ".json") gr_canon)
+      writeExport (render absname ++ ".json", encode (grammar2json Unqualified gr_canon))
       where
         absname = srcAbsName gr cnc
 

src/compiler/api/GF/Grammar/Canonical.hs

@@ -1,304 +0,0 @@
--- |
--- 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.
-
-{-# LANGUAGE DeriveTraversable #-}
-module GF.Grammar.Canonical where
-
-import Prelude hiding ((<>))
-import GF.Text.Pretty
-import GF.Infra.Ident (RawIdent)
-import PGF(Literal(..))
-
--- | A Complete grammar
-data Grammar = Grammar Abstract [Concrete] deriving Show
-
---------------------------------------------------------------------------------
--- ** Abstract Syntax
-
--- | Abstract Syntax
-data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show
-abstrName (Abstract mn _ _ _) = mn
-
-data CatDef   = CatDef CatId [CatId]        deriving Show
-data FunDef   = FunDef FunId Type           deriving Show
-data Type     = Type [TypeBinding] TypeApp  deriving Show
-data TypeApp  = TypeApp CatId [Type]        deriving Show
-
-data TypeBinding = TypeBinding VarId Type   deriving Show
-
---------------------------------------------------------------------------------
--- ** Concreate syntax
-
--- | Concrete Syntax
-data Concrete  = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
-                 deriving Show
-concName (Concrete cnc _ _ _ _ _) = cnc
-
-data ParamDef  = ParamDef ParamId [ParamValueDef]
-               | ParamAliasDef ParamId LinType
-               deriving Show
-data LincatDef = LincatDef CatId LinType  deriving Show
-data LinDef    = LinDef FunId [VarId] LinValue  deriving Show
-
--- | Linearization type, RHS of @lincat@
-data LinType = FloatType
-             | IntType
-             | ParamType ParamType
-             | RecordType [RecordRowType]
-             | StrType
-             | TableType LinType LinType
-             | TupleType [LinType]
-              deriving (Eq,Ord,Show)
-
-newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
-
--- | Linearization value, RHS of @lin@
-data LinValue = ConcatValue LinValue LinValue
-              | LiteralValue Literal
-              | ErrorValue String
-              | ParamConstant ParamValue
-              | PredefValue PredefId
-              | RecordValue [RecordRowValue]
-              | TableValue LinType [TableRowValue]
----           | VTableValue LinType [LinValue]
-              | TupleValue [LinValue]
-              | VariantValue [LinValue]
-              | VarValue VarValueId
-              | PreValue [([String], LinValue)] LinValue
-              | Projection LinValue LabelId
-              | Selection LinValue LinValue
-              | CommentedValue String LinValue
-              deriving (Eq,Ord,Show)
-
-data LinPattern = ParamPattern ParamPattern
-                | RecordPattern [RecordRow LinPattern]
-                | TuplePattern [LinPattern]
-                | WildPattern
-                deriving (Eq,Ord,Show)
-
-type ParamValue = Param LinValue
-type ParamPattern = Param LinPattern
-type ParamValueDef = Param ParamId
-
-data Param arg = Param ParamId [arg]
-                 deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
-
-type RecordRowType  = RecordRow LinType
-type RecordRowValue = RecordRow LinValue
-type TableRowValue  = TableRow LinValue
-
-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
-
-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 QualId  deriving (Eq,Ord,Show)
-
---------------------------------------------------------------------------------
--- ** Used in both Abstract and Concrete Syntax
-
-newtype ModId = ModId Id  deriving (Eq,Ord,Show)
-
-newtype CatId = CatId Id  deriving (Eq,Ord,Show)
-newtype FunId = FunId Id  deriving (Eq,Show)
-
-data VarId = Anonymous | VarId Id  deriving Show
-
-newtype Flags = Flags [(FlagName,Literal)] deriving Show
-type FlagName = Id
-
-
--- *** Identifiers
-
-type Id = RawIdent
-data QualId = Qual ModId Id | Unqual Id  deriving (Eq,Ord,Show)
-
---------------------------------------------------------------------------------
--- ** Pretty printing
-
-instance Pretty Grammar where
-  pp (Grammar abs cncs) = abs $+$ vcat cncs
-
-instance Pretty Abstract where
-  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)<>";"
-
-instance Pretty FunDef where
-  pp (FunDef f ty) = f <+> ":" <+> ty <>";"
-
-instance Pretty Type where
-  pp (Type bs ty) = sep (punctuate " ->" (map pp bs ++ [pp ty]))
-
-instance PPA Type where
-  ppA (Type [] (TypeApp c [])) = pp c
-  ppA t = parens t
-
-instance Pretty TypeBinding where
-  pp (TypeBinding Anonymous (Type [] tapp)) = pp tapp
-  pp (TypeBinding Anonymous ty) = parens ty
-  pp (TypeBinding (VarId x) ty) = parens (x<+>":"<+>ty)
-
-instance Pretty TypeApp where
- pp (TypeApp c targs) = c<+>hsep (map ppA targs)
-
-instance Pretty VarId where
-  pp Anonymous = pp "_"
-  pp (VarId x) = pp x
-
---------------------------------------------------------------------------------
-
-instance Pretty Concrete where
-  pp (Concrete cncid absid flags params lincats lins) =
-      "concrete" <+> cncid <+> "of" <+> absid <+> "=" <+> "{" $$
-      vcat params $$
-      section "lincat" lincats $$
-      section "lin" lins $$
-      "}"
-    where
-      section name [] = empty
-      section name ds = name <+> vcat (map (<> ";") ds)
-
-instance Pretty ParamDef where
-  pp (ParamDef p pvs) = hang ("param"<+> p <+> "=") 4 (punctuate " |" pvs)<>";"
-  pp (ParamAliasDef p t) = hang ("oper"<+> p <+> "=") 4 t<>";"
-
-instance PPA arg => Pretty (Param arg) where
-  pp (Param p ps) = pp p<+>sep (map ppA ps)
-
-instance PPA arg => PPA (Param arg) where
-  ppA (Param p []) = pp p
-  ppA pv = parens pv
-
-instance Pretty LincatDef where
-  pp (LincatDef c lt) = hang (c <+> "=") 4 lt
-
-instance Pretty LinType where
- pp lt = case lt of
-           FloatType -> pp "Float"
-           IntType -> pp "Int"
-           ParamType pt -> pp pt
-           RecordType rs -> block rs
-           StrType -> pp "Str"
-           TableType pt lt -> sep [pt <+> "=>",pp lt]
-           TupleType lts -> "<"<>punctuate "," lts<>">"
-
-instance RhsSeparator LinType  where rhsSep _ = pp ":"
-
-instance Pretty ParamType where
-  pp (ParamTypeId p) = pp p
-
-instance Pretty LinDef where
-  pp (LinDef f xs lv) = hang (f<+>hsep xs<+>"=") 4 lv
-
-instance Pretty LinValue where
-  pp lv = case lv of
-            ConcatValue v1 v2 -> sep [v1 <+> "++",pp v2]
-            ErrorValue s -> "Predef.error"<+>doubleQuotes s
-            ParamConstant pv -> pp pv
-            Projection lv l -> ppA lv<>"."<>l
-            Selection tv pv -> ppA tv<>"!"<>ppA pv
-            VariantValue vs -> "variants"<+>block vs
-            CommentedValue s v -> "{-" <+> s <+> "-}" $$ v
-            _ -> ppA lv
-
-instance PPA LinValue where
-  ppA lv = case lv of
-             LiteralValue l -> ppA l
-             ParamConstant pv -> ppA pv
-             PredefValue p -> ppA p
-             RecordValue [] -> pp "<>"
-             RecordValue rvs -> block rvs
-             PreValue alts def ->
-               "pre"<+>block (map alt alts++["_"<+>"=>"<+>def])
-               where
-                 alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
-                                    2 ("=>"<+>lv)
-             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 Literal where pp = ppA
-
-instance PPA Literal where
-  ppA l = case l of
-            LFlt f -> pp f
-            LInt n -> pp n
-            LStr s -> doubleQuotes s -- hmm
-
-instance RhsSeparator LinValue where rhsSep _ = pp "="
-
-instance Pretty LinPattern where
-  pp p =
-    case p of
-      ParamPattern pv -> pp pv
-      _ -> ppA p
-
-instance PPA LinPattern where
-  ppA p =
-    case p of
-      ParamPattern pv -> ppA pv
-      RecordPattern r -> block r
-      TuplePattern ps -> "<"<>punctuate "," ps<>">"
-      WildPattern     -> pp "_"
-
-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 rhs => Pretty (TableRow rhs) where
-  pp (TableRow l v) = hang (l<+>"=>") 2 v
-
---------------------------------------------------------------------------------
-instance Pretty ModId where pp (ModId s) = pp s
-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) = "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)
-    where
-      ppFlag (name,value) = name <+> "=" <+> value <>";"
-
---------------------------------------------------------------------------------
--- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
-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)

src/compiler/api/GF/Grammar/CanonicalJSON.hs

@@ -1,289 +0,0 @@
-module GF.Grammar.CanonicalJSON (
-  encodeJSON
-  ) where
-
-import Text.JSON
-import Control.Applicative ((<|>))
-import Data.Ratio (denominator, numerator)
-import GF.Grammar.Canonical
-import Control.Monad (guard)
-import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
-import PGF(Literal(..))
-
-encodeJSON :: FilePath -> Grammar -> IO ()
-encodeJSON fpath g = writeFile fpath (encode g)
-
-
--- in general we encode grammars using JSON objects/records,
--- except for newtypes/coercions/direct values
-
--- the top-level definitions use normal record labels,
--- but recursive types/values/ids use labels staring with a "."
-
-instance JSON Grammar where
-  showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
-
-  readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
-
-
---------------------------------------------------------------------------------
--- ** Abstract Syntax
-
-instance JSON Abstract where
-  showJSON (Abstract absid flags cats funs)
-    = makeObj [("abs", showJSON absid),
-               ("flags", showJSON flags),
-               ("cats", showJSON cats),
-               ("funs", showJSON funs)]
-
-  readJSON o = Abstract
-    <$> o!"abs"
-    <*>(o!"flags" <|> return (Flags []))
-    <*> o!"cats"
-    <*> o!"funs"
-
-instance JSON CatDef where
-  -- non-dependent categories are encoded as simple strings:
-  showJSON (CatDef c []) = showJSON c
-  showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
-
-  readJSON o = CatDef <$> readJSON o <*> return []
-    <|>        CatDef <$> o!"cat" <*> o!"args"
-
-instance JSON FunDef where
-  showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
-
-  readJSON o = FunDef <$> o!"fun" <*> o!"type"
-
-instance JSON Type where
-  showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
-
-  readJSON o = Type <$> o!".args" <*> o!".result"
-
-instance JSON TypeApp where
-  -- non-dependent categories are encoded as simple strings:
-  showJSON (TypeApp c [])   = showJSON c
-  showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
-
-  readJSON o = TypeApp <$> readJSON o <*> return []
-    <|>        TypeApp <$> o!".cat" <*> o!".args"
-
-instance JSON TypeBinding where
-  -- non-dependent categories are encoded as simple strings:
-  showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
-  showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
-
-  readJSON o = do c <- readJSON o
-                  return (TypeBinding Anonymous (Type [] (TypeApp c [])))
-           <|> TypeBinding <$> o!".var" <*> o!".type"
-
-
---------------------------------------------------------------------------------
--- ** Concrete syntax
-
-instance JSON Concrete where
-  showJSON (Concrete cncid absid flags params lincats lins)
-    = makeObj [("cnc", showJSON cncid),
-               ("abs", showJSON absid),
-               ("flags", showJSON flags),
-               ("params", showJSON params),
-               ("lincats", showJSON lincats),
-               ("lins", showJSON lins)]
-
-  readJSON o = Concrete
-    <$> o!"cnc"
-    <*> o!"abs"
-    <*>(o!"flags" <|> return (Flags []))
-    <*> o!"params"
-    <*> o!"lincats"
-    <*> o!"lins"
-
-instance JSON ParamDef where
-  showJSON (ParamDef      p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
-  showJSON (ParamAliasDef p t)   = makeObj [("param", showJSON p), ("alias", showJSON t)]
-
-  readJSON o = ParamDef      <$> o!"param" <*> o!"values"
-    <|>        ParamAliasDef <$> o!"param" <*> o!"alias"
-
-instance JSON LincatDef where
-  showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
-
-  readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
-
-instance JSON LinDef where
-  showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
-
-  readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
-
-instance JSON LinType where
-  -- the basic types (Str, Float, Int) are encoded as strings:
-  showJSON (StrType)         = showJSON "Str"
-  showJSON (FloatType)       = showJSON "Float"
-  showJSON (IntType)         = showJSON "Int"
-  -- parameters are also encoded as strings:
-  showJSON (ParamType pt)    = showJSON pt
-  -- tables/tuples are encoded as JSON objects:
-  showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
-  showJSON (TupleType lts)   = makeObj [(".tuple",  showJSON lts)]
-  -- records are encoded as records:
-  showJSON (RecordType rows) = showJSON rows
-
-  readJSON o = StrType   <$ parseString "Str"   o
-    <|>        FloatType <$ parseString "Float" o
-    <|>        IntType   <$ parseString "Int"   o
-    <|>        ParamType <$> readJSON o
-    <|>        TableType  <$> o!".tblarg" <*> o!".tblval"
-    <|>        TupleType  <$> o!".tuple"
-    <|>        RecordType <$> readJSON o
-
-instance JSON LinValue where
-  showJSON (LiteralValue  l ) = showJSON l
-  -- most values are encoded as JSON objects:
-  showJSON (ParamConstant pv) = makeObj [(".param",    showJSON pv)]
-  showJSON (PredefValue   p ) = makeObj [(".predef",   showJSON p)]
-  showJSON (TableValue t tvs) = makeObj [(".tblarg",   showJSON t), (".tblrows", showJSON tvs)]
-  showJSON (TupleValue   lvs) = makeObj [(".tuple",    showJSON lvs)]
-  showJSON (VarValue      v ) = makeObj [(".var",      showJSON v)]
-  showJSON (ErrorValue    s ) = makeObj [(".error",    showJSON s)]
-  showJSON (Projection lv l ) = makeObj [(".project",  showJSON lv), (".label", showJSON l)]
-  showJSON (Selection  tv pv) = makeObj [(".select",   showJSON tv), (".key", showJSON pv)]
-  showJSON (VariantValue  vs) = makeObj [(".variants", showJSON vs)]
-  showJSON (PreValue pre def) = makeObj [(".pre",      showJSON pre),(".default", showJSON def)]
-  -- records are encoded directly as JSON records:
-  showJSON (RecordValue rows) = showJSON rows
-  -- concatenation is encoded as a JSON array:
-  showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
-    where flatten (ConcatValue v v') = flatten v . flatten v'
-          flatten  v                 = (v :)
-
-  readJSON o = LiteralValue  <$> readJSON o
-    <|>        ParamConstant <$> o!".param"
-    <|>        PredefValue   <$> o!".predef"
-    <|>        TableValue    <$> o!".tblarg"  <*> o!".tblrows"
-    <|>        TupleValue    <$> o!".tuple"
-    <|>        VarValue      <$> o!".var"
-    <|>        ErrorValue    <$> o!".error"
-    <|>        Projection    <$> o!".project" <*> o!".label"
-    <|>        Selection     <$> o!".select"  <*> o!".key"
-    <|>        VariantValue  <$> o!".variants"
-    <|>        PreValue      <$> o!".pre"     <*> o!".default"
-    <|>        RecordValue   <$> readJSON o
-    <|>        do vs <- readJSON o :: Result [LinValue]
-                  return (foldr1 ConcatValue vs)
-
-instance JSON Literal where
-  -- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
-  showJSON (LStr s) = showJSON s
-  showJSON (LFlt f) = showJSON f
-  showJSON (LInt n) = showJSON n
-
-  readJSON = readBasicJSON LStr LInt LFlt
-
-instance JSON LinPattern where
-  -- wildcards and patterns without arguments are encoded as strings:
-  showJSON (WildPattern) = showJSON "_"
-  showJSON (ParamPattern (Param p [])) = showJSON p
-  -- complex patterns are encoded as JSON objects:
-  showJSON (ParamPattern pv) = showJSON pv
-  -- and records as records:
-  showJSON (RecordPattern r) = showJSON r
-
-  readJSON o = do  p  <- parseString "_" o; return WildPattern
-    <|>        do  p  <- readJSON o; return (ParamPattern (Param p []))
-    <|>        ParamPattern  <$> readJSON o
-    <|>        RecordPattern <$> readJSON o
-
-instance JSON arg => JSON (Param arg) where
-  -- parameters without arguments are encoded as strings:
-  showJSON (Param p [])   = showJSON p
-  showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
-
-  readJSON o = Param <$> readJSON o <*> return []
-    <|>        Param <$> o!".paramid" <*> o!".args"
-
-instance JSON a => JSON (RecordRow a) where
-  -- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
-  showJSON  row  = showJSONs [row]
-  showJSONs rows = makeObj (map toRow rows)
-    where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
-
-  readJSON  obj = head <$> readJSONs obj
-  readJSONs obj = mapM fromRow (assocsJSObject obj)
-    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (RecordRow (LabelId (rawIdentS lbl)) value)
-
-instance JSON rhs => JSON (TableRow rhs) where
-  showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
-
-  readJSON o = TableRow <$> o!".pattern" <*> o!".value"
-
-
--- *** Identifiers in Concrete Syntax
-
-instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON
-instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON
-instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON
-instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON
-instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
-
-
---------------------------------------------------------------------------------
--- ** Used in both Abstract and Concrete Syntax
-
-instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
-instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
-instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
-
-instance JSON VarId where
-  -- the anonymous variable is the underscore:
-  showJSON Anonymous = showJSON "_"
-  showJSON (VarId x) = showJSON x
-
-  readJSON o = do parseString "_" o; return Anonymous
-    <|>        VarId <$> readJSON o
-
-instance JSON QualId where
-  showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
-  showJSON (Unqual n) = showJSON n
-
-  readJSON o = do qualid <- readJSON o
-                  let (mod, id) = span (/= '.') qualid
-                  return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
-
-instance JSON RawIdent where
-  showJSON i = showJSON $ showRawIdent i
-  readJSON o = rawIdentS <$> readJSON o
-
-instance JSON Flags where
-  -- flags are encoded directly as JSON records (i.e., objects):
-  showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
-
-  readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
-    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (rawIdentS lbl, value)
-
---------------------------------------------------------------------------------
--- ** Convenience functions
-
-parseString :: String -> JSValue -> Result ()
-parseString s o = guard . (== s) =<< readJSON o
-
-(!) :: JSON a => JSValue -> String -> Result a
-obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
-            readJSON
-            (lookup key (assocsJSObject obj))
-
-assocsJSObject :: JSValue -> [(String, JSValue)]
-assocsJSObject (JSObject o) = fromJSObject o
-assocsJSObject (JSArray  _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
-assocsJSObject  jsvalue     = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
-
-
-readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
-                 (String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
-readBasicJSON str int flt o
-  =   str        <$> readJSON o
-  <|> int_or_flt <$> readJSON o
-  where int_or_flt f | f == fromIntegral n = int n
-                     | otherwise           = flt f
-          where n = round f

src/compiler/api/GF/Infra/Ident.hs

@@ -31,6 +31,7 @@ import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
                  -- UTF-8-encoded bytestrings!
 import Data.Char(isDigit)
 import Data.Binary(Binary(..))
+import Text.JSON hiding (Result(..))
 import GF.Text.Pretty
 
 
@@ -46,6 +47,10 @@ instance Binary ModuleName where
   put (MN id) = put id
   get = fmap MN get
 
+instance JSON ModuleName where
+  showJSON (MN id) = showJSON id
+  readJSON o = MN <$> readJSON o
+
 -- | the constructors labelled /INTERNAL/ are
 -- internal representation never returned by the parser
 data Ident =
@@ -101,6 +106,14 @@ instance Pretty Ident where pp = pp . showIdent
 
 instance Pretty RawIdent where pp = pp . showRawIdent
 
+instance JSON Ident where
+  showJSON i = showJSON $ ident2raw i
+  readJSON o = identC <$> readJSON o
+
+instance JSON RawIdent where
+  showJSON i = showJSON $ showRawIdent i
+  readJSON o = rawIdentS <$> readJSON o
+
 identS :: String -> Ident
 identS = identC . rawIdentS
 

src/compiler/api/GF/Infra/Option.hs

@@ -134,7 +134,6 @@ data HaskellOption = HaskellNoPrefix
                    | HaskellConcrete
                    | HaskellVariants
                    | HaskellData
-                   | HaskellPGF2
   deriving (Show,Eq,Ord)
 
 data Warning = WarnMissingLincat
@@ -530,8 +529,7 @@ haskellOptionNames =
      ("lexical",  HaskellLexical),
      ("concrete", HaskellConcrete),
      ("variants", HaskellVariants),
-     ("data",     HaskellData),
+     ("data",     HaskellData)]
-     ("pgf2",     HaskellPGF2)]
 
 -- | This is for bacward compatibility. Since GHC 6.12 we
 -- started using the native Unicode support in GHC but it

src/compiler/gf.cabal

@@ -87,7 +87,6 @@ library
     GF.Support
     GF.Text.Pretty
     GF.Text.Lexing
-    GF.Grammar.Canonical
 
     GF.CompileOne  GF.Compile.GetGrammar
 
@@ -120,7 +119,6 @@ library
     GF.Haskell
     GF.Compile.ConcreteToHaskell
     GF.Compile.GrammarToCanonical
-    GF.Grammar.CanonicalJSON
     GF.Compile.ReadFiles
     GF.Compile.Rename
     GF.Compile.Repl
@@ -156,6 +154,7 @@ library
     GF.Grammar.ShowTerm
     GF.Grammar.Unify
     GF.Grammar.Values
+    GF.Grammar.JSON
     GF.Infra.Concurrency
     GF.Infra.Dependencies
     GF.Infra.GetOpt