manually copy the "c-runtime" branch from the old repository.

src/compiler/GF/Compile/CFGtoPGF.hs

@@ -1,8 +1,10 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, ImplicitParams #-}
 module GF.Compile.CFGtoPGF (cf2pgf) where
 
 import GF.Grammar.CFG
 import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.Compile.OptimizePGF
 
 import PGF
 import PGF.Internal
@@ -12,88 +14,97 @@ import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import Data.Array.IArray
 import Data.List
+import Data.Maybe(fromMaybe)
 
 --------------------------
 -- the compiler ----------
 --------------------------
 
-cf2pgf :: FilePath -> ParamCFG -> PGF
-cf2pgf fpath cf = 
- let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
- in updateProductionIndices pgf
+cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map CId Double -> PGF
+cf2pgf opts fpath cf probs = 
+ build (let abstr = cf2abstr cf probs
+        in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)])
  where
    name = justModuleName fpath
    aname = mkCId (name ++ "Abs")
    cname = mkCId name
 
-cf2abstr :: ParamCFG -> Abstr
-cf2abstr cfg = Abstr aflags afuns acats
+cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map CId Double -> B s AbstrInfo
+cf2abstr cfg probs = newAbstr aflags acats afuns
   where
-    aflags = Map.singleton (mkCId "startcat") (LStr (fst (cfgStartCat cfg)))
+    aflags = [(mkCId "startcat", LStr (fst (cfgStartCat cfg)))]
 
-    acats  = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
-                            | (cat,rules) <- (Map.toList . Map.fromListWith (++))
-                                                [(cat2id cat, catRules cfg cat) | 
-                                                     cat <- allCats' cfg]]
-    afuns  = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
-                            | rule <- allRules cfg]
+    acats  = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat]
+    afuns  = [(f', dTyp [hypo Explicit wildCId (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs)))
+                            | rule <- allRules cfg
+                            , let f' = mkRuleName rule]
+
+    funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
+                     [(cat,[(f',Map.lookup f' probs)]) | rule <- allRules cfg,
+                                                         let cat = cat2id (ruleLhs rule),
+                                                         let f' = mkRuleName rule]
+      where
+        pad :: [(a,Maybe Double)] -> [(a,Double)]
+        pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
+          where
+            deflt = case length [f | (f,Nothing) <- pfs] of
+                      0 -> 0
+                      n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
+
+    toLogProb = realToFrac . negate . log
 
     cat2id = mkCId . fst
 
-cf2concr :: ParamCFG -> Concr
-cf2concr cfg = Concr Map.empty Map.empty
-                     cncfuns lindefsrefs lindefsrefs
-                     sequences productions
-                     IntMap.empty Map.empty
-                     cnccats
-                     IntMap.empty
-                     totalCats
+cf2concr :: (?builder :: Builder s) => Options -> B s AbstrInfo -> ParamCFG -> B s ConcrInfo
+cf2concr opts abstr cfg = 
+  let (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
+           (if flag optOptimizePGF opts then optimizePGF (mkCId (fst (cfgStartCat cfg))) else id)
+                (lindefsrefs,lindefsrefs,IntMap.toList productions,cncfuns,sequences,cnccats)
+  in newConcr abstr [] []
+              lindefs' linrefs'
+              productions' cncfuns'
+              sequences' cnccats' totalCats
   where
     cats  = allCats' cfg
     rules = allRules cfg
 
-    sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : 
-                               map mkSequence rules)
-    sequences  = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
+    idSeq = [SymCat 0 0]
 
-    idFun = CncFun [wildCId] (listArray (0,0) [seqid])
-      where
-        seq   = listArray (0,0) [SymCat 0 0]
-        seqid = binSearch seq sequences (bounds sequences)
+    sequences0 = Set.fromList (idSeq : 
+                               map mkSequence rules)
+    sequences  = Set.toList sequences0
+
+    idFun = (wildCId,[Set.findIndex idSeq sequences0])
     ((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
     productions = foldl addProd IntMap.empty (concat (productions0++coercions))
-    cncfuns = listArray (0,fun_cnt-1) (reverse cncfuns0)
+    cncfuns = reverse cncfuns0
 
-    lbls = listArray (0,0) ["s"]
-    (fid,cnccats0) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
-                              [(c,p) | (c,ps) <- cats, p <- ps]
+    lbls = ["s"]
+    (fid,cnccats) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
+                         [(c,p) | (c,ps) <- cats, p <- ps]
     ((totalCats,cs), coercions) = mapAccumL mkCoercions (fid,Map.empty) cats
-    cnccats = Map.fromList cnccats0
 
-    lindefsrefs =
-       IntMap.fromList (map mkLinDefRef cats)
+    lindefsrefs = map mkLinDefRef cats
 
     convertRule cs (funid,funs) rule =
       let args   = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
           prod   = PApply funid args
-          seqid  = binSearch (mkSequence rule) sequences (bounds sequences)
-          fun    = CncFun [mkRuleName rule] (listArray (0,0) [seqid])
+          seqid  = Set.findIndex (mkSequence rule) sequences0
+          fun    = (mkRuleName rule, [seqid])
           funid' = funid+1
       in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
 
-    mkSequence rule = listArray (0,length syms-1) syms
+    mkSequence rule = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
       where
-        syms   = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
-
         convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
         convertSymbol d (Terminal t)        = (d,  SymKS t)
 
     mkCncCat fid (cat,n)
-      | cat == "Int"    = (fid, (mkCId cat, CncCat fidInt    fidInt    lbls))
-      | cat == "Float"  = (fid, (mkCId cat, CncCat fidFloat  fidFloat  lbls))
-      | cat == "String" = (fid, (mkCId cat, CncCat fidString fidString lbls))
+      | cat == "Int"    = (fid, (mkCId cat, fidInt,    fidInt,    lbls))
+      | cat == "Float"  = (fid, (mkCId cat, fidFloat,  fidFloat,  lbls))
+      | cat == "String" = (fid, (mkCId cat, fidString, fidString, lbls))
       | otherwise       = let fid' = fid+n+1
-                          in fid' `seq` (fid', (mkCId cat,CncCat fid (fid+n) lbls))
+                          in fid' `seq` (fid', (mkCId cat, fid, fid+n, lbls))
 
     mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
     mkCoercions (fid,cs) c@(cat,ps ) =
@@ -102,25 +113,16 @@ cf2concr cfg = Concr Map.empty Map.empty
 
     mkLinDefRef (cat,_) =
       (cat2fid cat 0,[0])
-      
+
     addProd prods (fid,prod) =
       case IntMap.lookup fid prods of
-        Just set -> IntMap.insert fid (Set.insert prod set) prods
-        Nothing  -> IntMap.insert fid (Set.singleton prod)  prods
-
-    binSearch v arr (i,j)
-      | i <= j    = case compare v (arr ! k) of
-                      LT -> binSearch v arr (i,k-1)
-                      EQ -> k
-                      GT -> binSearch v arr (k+1,j)
-      | otherwise = error "binSearch"
-      where
-        k = (i+j) `div` 2
+        Just set -> IntMap.insert fid (prod:set) prods
+        Nothing  -> IntMap.insert fid [prod]     prods
 
     cat2fid cat p =
-      case Map.lookup (mkCId cat) cnccats of
-        Just (CncCat fid _ _) -> fid+p
-        _                     -> error "cat2fid"
+      case [start | (cat',start,_,_) <- cnccats, mkCId cat == cat'] of
+        (start:_) -> fid+p
+        _         -> error "cat2fid"
 
     cat2arg c@(cat,[p]) = cat2fid cat p
     cat2arg c@(cat,ps ) =
@@ -132,3 +134,4 @@ mkRuleName rule =
   case ruleName rule of
 	CFObj n _ -> n
 	_         -> wildCId
+

src/compiler/GF/Compile/CheckGrammar.hs

@@ -21,7 +21,6 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.CheckGrammar(checkModule) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Infra.Ident
 import GF.Infra.Option

src/compiler/GF/Compile/Compute/ConcreteNew.hs

@@ -5,7 +5,6 @@ module GF.Compile.Compute.ConcreteNew
             normalForm,
             Value(..), Bind(..), Env, value2term, eval, vapply
            ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Grammar hiding (Env, VGen, VApp, VRecType)
 import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)

src/compiler/GF/Compile/Export.hs

@@ -1,7 +1,6 @@
 module GF.Compile.Export where
 
 import PGF
-import PGF.Internal(ppPGF)
 import GF.Compile.PGFtoHaskell
 import GF.Compile.PGFtoJava
 import GF.Compile.PGFtoProlog
@@ -33,7 +32,7 @@ exportPGF :: Options
           -> [(FilePath,String)] -- ^ List of recommended file names and contents.
 exportPGF opts fmt pgf = 
     case fmt of
-      FmtPGFPretty    -> multi "txt" (render . ppPGF)
+      FmtPGFPretty    -> multi "txt" (showPGF)
       FmtJavaScript   -> multi "js"  pgf2js
       FmtPython       -> multi "py"  pgf2python
       FmtHaskell      -> multi "hs"  (grammar2haskell opts name)

src/compiler/GF/Compile/GenerateBC.hs

@@ -1,14 +1,15 @@
+{-# LANGUAGE CPP #-}
 module GF.Compile.GenerateBC(generateByteCode) where
 
 import GF.Grammar
 import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
 import GF.Data.Operations
-import PGF(CId,utf8CId)
 import PGF.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
 import qualified Data.Map as Map
 import Data.List(nub,mapAccumL)
 import Data.Maybe(fromMaybe)
 
+#if C_RUNTIME
 generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
 generateByteCode gr arity eqs =
   let (bs,instrs) = compileEquations gr arity (arity+1) is 
@@ -63,7 +64,7 @@ compileEquations gr arity st (i:is) eqs       fl bs = whilePP eqs Map.empty
 
     case_instr t =
       case t of
-        (Q (_,id)) -> CASE (i2i id)
+        (Q (_,id)) -> CASE (showIdent id)
         (EInt n)   -> CASE_LIT (LInt n)
         (K s)      -> CASE_LIT (LStr s)
         (EFloat d) -> CASE_LIT (LFlt d)
@@ -105,7 +106,7 @@ compileFun gr eval st vs (App e1 e2) h0 bs args =
 compileFun gr eval st vs (Q (m,id))  h0 bs args =
   case lookupAbsDef gr m id of
     Ok (_,Just _)
-       -> (h0,bs,eval st (GLOBAL (i2i id)) args)
+       -> (h0,bs,eval st (GLOBAL (showIdent id)) args)
     _  -> let Ok ty = lookupFunType gr m id
               (ctxt,_,_) = typeForm ty
               c_arity    = length ctxt
@@ -114,14 +115,14 @@ compileFun gr eval st vs (Q (m,id))  h0 bs args =
               diff   = c_arity-n_args
           in if diff <= 0
                then if n_args == 0
-                      then (h0,bs,eval st (GLOBAL (i2i id)) [])
+                      then (h0,bs,eval st (GLOBAL (showIdent id)) [])
                       else let h1  = h0 + 2 + n_args
-                           in (h1,bs,PUT_CONSTR (i2i id):is1++eval st (HEAP h0) [])
+                           in (h1,bs,PUT_CONSTR (showIdent id):is1++eval st (HEAP h0) [])
                else let h1  = h0 + 1 + n_args
                         is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
                         b   = CHECK_ARGS diff :
                               ALLOC (c_arity+2) : 
-                              PUT_CONSTR (i2i id) : 
+                              PUT_CONSTR (showIdent id) : 
                               is2 ++
                               TUCK (ARG_VAR 0) diff :
                               EVAL (HEAP h0) (TailCall diff) :
@@ -167,16 +168,16 @@ compileFun gr eval st vs e _ _ _ = error (show e)
 
 compileArg gr st vs (Q(m,id)) h0 bs =
   case lookupAbsDef gr m id of
-    Ok (_,Just _) -> (h0,bs,GLOBAL (i2i id),[])
+    Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[])
     _             -> let Ok ty = lookupFunType gr m id
                          (ctxt,_,_) = typeForm ty
                          c_arity    = length ctxt
                      in if c_arity == 0
-                          then (h0,bs,GLOBAL (i2i id),[])
+                          then (h0,bs,GLOBAL (showIdent id),[])
                           else let is2 = [SET (ARG_VAR (i+1)) | i <- [0..c_arity-1]]
                                    b   = CHECK_ARGS c_arity :
                                          ALLOC (c_arity+2) :
-                                         PUT_CONSTR (i2i id) :
+                                         PUT_CONSTR (showIdent id) :
                                          is2 ++
                                          TUCK (ARG_VAR 0) c_arity :
                                          EVAL (HEAP h0) (TailCall c_arity) :
@@ -224,12 +225,12 @@ compileArg gr st vs e           h0 bs =
                 diff   = c_arity-n_args
             in if diff <= 0
                  then let h2  = h1 + 2 + n_args
-                      in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (i2i id) : is2))
+                      in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (showIdent id) : is2))
                  else let h2  = h1 + 1 + n_args
                           is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
                           b   = CHECK_ARGS diff :
                                 ALLOC (c_arity+2) :
-                                PUT_CONSTR (i2i id) :
+                                PUT_CONSTR (showIdent id) :
                                 is2 ++
                                 TUCK (ARG_VAR 0) diff :
                                 EVAL (HEAP h0) (TailCall diff) :
@@ -298,9 +299,10 @@ freeVars xs (Vr x)
   | not (elem x xs)     = [x]
 freeVars xs e           = collectOp (freeVars xs) e
 
-i2i :: Ident -> CId
-i2i = utf8CId . ident2utf8
-
 push_is :: Int -> Int -> [IVal] -> [IVal]
 push_is i 0 is = is
 push_is i n is = ARG_VAR i : push_is (i-1) (n-1) is
+
+#else
+generateByteCode = error "generateByteCode is not implemented"
+#endif

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -14,7 +14,7 @@ module GF.Compile.GeneratePMCFG
     ) where
 
 --import PGF.CId
-import PGF.Internal as PGF(CncCat(..),Symbol(..),fidVar)
+import PGF.Internal as PGF(CId,Symbol(..),fidVar)
 
 import GF.Infra.Option
 import GF.Grammar hiding (Env, mkRecord, mkTable)
@@ -157,12 +157,15 @@ convert opts gr cenv loc term ty@(_,val) pargs =
             args = map Vr vars
             vars = map (\(bt,x,t) -> x) context
 
-pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat
-pgfCncCat gr lincat index =
+pgfCncCat :: SourceGrammar -> CId -> Type -> Int -> (CId,Int,Int,[String])
+pgfCncCat gr id lincat index =
   let ((_,size),schema) = computeCatRange gr lincat
-  in PGF.CncCat index (index+size-1)
-                      (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) 
-                                    (getStrPaths schema)))
+  in ( id
+     , index
+     , index+size-1
+     , map (renderStyle style{mode=OneLineMode} . ppPath)
+           (getStrPaths schema)
+     )
   where
     getStrPaths :: Schema Identity s c -> [Path]
     getStrPaths = collect CNil []
@@ -500,13 +503,11 @@ mapAccumL' f s (x:xs) = (s'',y:ys)
                               !(s'',ys) = mapAccumL' f s' xs
 
 addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
-addSequence seqs lst =
+addSequence seqs seq =
   case Map.lookup seq seqs of
     Just id -> (seqs,id)
     Nothing -> let !last_seq = Map.size seqs
                in (Map.insert seq last_seq seqs, last_seq)
-  where
-    seq = mkArray lst
 
 
 ------------------------------------------------------------

src/compiler/GF/Compile/GetGrammar.hs

@@ -52,11 +52,9 @@ getSourceModule opts file0 =
             let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
                 optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0)
             case (optCoding,optCoding') of
-              {-
               (Nothing,Nothing) ->
                   unless (BS.all isAscii raw) $
                     ePutStrLn $ file0++":\n    Warning: default encoding has changed from Latin-1 to UTF-8"
-              -}
               (_,Just coding') -> 
                   when (coding/=coding') $
                   raise $ "Encoding mismatch: "++coding++" /= "++coding'

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -1,17 +1,14 @@
-{-# LANGUAGE BangPatterns, FlexibleContexts #-}
-module GF.Compile.GrammarToPGF (mkCanon2pgf) where
+{-# LANGUAGE ImplicitParams, BangPatterns, FlexibleContexts #-}
+module GF.Compile.GrammarToPGF (grammar2PGF) where
 
---import GF.Compile.Export
 import GF.Compile.GeneratePMCFG
 import GF.Compile.GenerateBC
+import GF.Compile.OptimizePGF
 
-import PGF(CId,mkCId,utf8CId)
-import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
-import PGF.Internal(updateProductionIndices)
-import qualified PGF.Internal as C
+import PGF(CId,mkCId,Type,Hypo,Expr)
+import PGF.Internal
 import GF.Grammar.Predef
---import GF.Grammar.Printer
-import GF.Grammar.Grammar
+import GF.Grammar.Grammar hiding (Production)
 import qualified GF.Grammar.Lookup as Look
 import qualified GF.Grammar as A
 import qualified GF.Grammar.Macros as GM
@@ -26,104 +23,132 @@ import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import Data.Array.IArray
+import Data.Maybe(fromMaybe)
 
-mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE C.PGF
-mkCanon2pgf opts gr am = do
-  (an,abs) <- mkAbstr am
-  cncs     <- mapM mkConcr (allConcretes gr am)
-  return $ updateProductionIndices (C.PGF Map.empty an abs (Map.fromList cncs))
+grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map CId Double -> IO PGF
+grammar2PGF opts gr am probs = do
+  cnc_infos <- getConcreteInfos gr am
+  return $
+    build (let gflags   = if flag optSplitPGF opts 
+                            then [(mkCId "split", LStr "true")]
+                            else []
+               (an,abs) = mkAbstr am probs
+               cncs     = map (mkConcr opts abs) cnc_infos
+           in newPGF gflags an abs cncs)
   where
     cenv = resourceValues opts gr
+    aflags = err (const noOptions) mflags (lookupModule gr am)
 
-    mkAbstr am = return (mi2i am, C.Abstr flags funs cats)
+    mkAbstr :: (?builder :: Builder s) => ModuleName -> Map.Map CId Double -> (CId, B s AbstrInfo)
+    mkAbstr am probs = (mi2i am, newAbstr flags cats funs)
       where
-        aflags = err (const noOptions) mflags (lookupModule gr am)
-
         adefs =
             [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ 
             Look.allOrigInfos gr am
 
-        flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
+        flags = [(mkCId f,x) | (f,x) <- optionsPGF aflags]
 
-        funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) | 
+        toLogProb = realToFrac . negate . log
+
+        cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
+                                   ((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
+
+        funs = [(f', mkType [] ty, arity, {-mkDef gr arity mdef,-} toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
                                    ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
-                                   let arity = mkArity ma mdef ty]
+                                   let arity = mkArity ma mdef ty,
+                                   let f' = i2i f]
+                                   
+        funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
+                        [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs,
+                                                                   let (_,(_,cat),_) = GM.typeForm ty,
+                                                                   let f' = i2i f]
+          where
+            pad :: [(a,Maybe Double)] -> [(a,Double)]
+            pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
+              where
+                deflt = case length [f | (f,Nothing) <- pfs] of
+                          0 -> 0
+                          n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
 
-        cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0)) |
-                                   ((m,c),AbsCat (Just (L _ cont))) <- adefs]
-
-        catfuns cat =
-              [(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
-
-    mkConcr cm = do
-      let cflags  = err (const noOptions) mflags (lookupModule gr cm)
-
-      (ex_seqs,cdefs) <- addMissingPMCFGs
-                            Map.empty 
-                            ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
-                             Look.allOrigInfos gr cm)
-
-      let flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF cflags]
+    mkConcr opts abs (cm,ex_seqs,cdefs) =
+      let cflags = err (const noOptions) mflags (lookupModule gr cm)
+          flags  = [(mkCId f,x) | (f,x) <- optionsPGF cflags]
 
           seqs = (mkSetArray . Set.fromList . concat) $
-                     (Map.keys ex_seqs : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
-
-          ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence
+                       (elems (ex_seqs :: Array SeqId [Symbol]) : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
 
           !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
+          cnccat_ranges = Map.fromList (map (\(cid,s,e,_) -> (cid,(s,e))) cnccats)
           !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
-                                = genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
-        
+                                = genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt1 cnccat_ranges
+
           printnames = genPrintNames cdefs
-      return (mi2i cm, C.Concr flags
-                              printnames
-                              cncfuns
-                              lindefs
-                              linrefs
-                              seqs
-                              productions
-                              IntMap.empty
-                              Map.empty
-                              cnccats
-                              IntMap.empty
-                              fid_cnt2)
+
+          startCat = mkCId (fromMaybe "S" (flag optStartCat aflags))
+
+          (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
+               (if flag optOptimizePGF opts then optimizePGF startCat else id)
+                    (lindefs,linrefs,productions,cncfuns,elems seqs,cnccats)
+
+      in (mi2i cm, newConcr abs
+                            flags
+                            printnames
+                            lindefs'
+                            linrefs'
+                            productions'
+                            cncfuns'
+                            sequences'
+                            cnccats'
+                            fid_cnt2)
+
+    getConcreteInfos gr am = mapM flatten (allConcretes gr am)
       where
+        flatten cm = do
+          (seqs,infos) <- addMissingPMCFGs cm Map.empty
+                                           (lit_infos ++ Look.allOrigInfos gr cm)
+          return (cm,mkMapArray seqs :: Array SeqId [Symbol],infos)
+
+        lit_infos = [((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]]
+
         -- if some module was compiled with -no-pmcfg, then
         -- we have to create the PMCFG code just before linking
-        addMissingPMCFGs seqs []                  = return (seqs,[])
-        addMissingPMCFGs seqs (((m,id), info):is) = do
-          (seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
-          (seqs,is  ) <- addMissingPMCFGs seqs is
-          return (seqs, ((m,id), info) : is)
+        addMissingPMCFGs cm seqs []                  = return (seqs,[])
+        addMissingPMCFGs cm seqs (((m,id), info):is) = do
+          (seqs,info)  <- addPMCFG opts gr cenv Nothing am cm seqs id info
+          (seqs,infos) <- addMissingPMCFGs cm seqs is
+          return (seqs, ((m,id), info) : infos)
+
+mkSetArray set = listArray (0,Set.size set-1) (Set.toList set)
+mkMapArray map = array (0,Map.size map-1) [(k,v) | (v,k) <- Map.toList map]
 
 i2i :: Ident -> CId
-i2i = utf8CId . ident2utf8
+i2i = mkCId . showIdent
 
 mi2i :: ModuleName -> CId
 mi2i (MN i) = i2i i
 
-mkType :: [Ident] -> A.Type -> C.Type
+mkType :: (?builder :: Builder s) => [Ident] -> A.Type -> B s PGF.Type
 mkType scope t =
   case GM.typeForm t of
     (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
-                           in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
+                           in dTyp hyps' (i2i cat) (map (mkExp scope') args)
 
-mkExp :: [Ident] -> A.Term -> C.Expr
-mkExp scope t = 
+mkExp :: (?builder :: Builder s) => [Ident] -> A.Term -> B s Expr
+mkExp scope t =
   case t of
-    Q (_,c)  -> C.EFun (i2i c)
-    QC (_,c) -> C.EFun (i2i c)
+    Q (_,c)  -> eFun (i2i c)
+    QC (_,c) -> eFun (i2i c)
     Vr x     -> case lookup x (zip scope [0..]) of
-                  Just i  -> C.EVar  i
-                  Nothing -> C.EMeta 0
-    Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t)
-    App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
-    EInt i   -> C.ELit (C.LInt (fromIntegral i))
-    EFloat f -> C.ELit (C.LFlt f)
-    K s      -> C.ELit (C.LStr s)
-    Meta i   -> C.EMeta i
-    _        -> C.EMeta 0
-
+                  Just i  -> eVar  i
+                  Nothing -> eMeta 0
+    Abs b x t-> eAbs b (i2i x) (mkExp (x:scope) t)
+    App t1 t2-> eApp (mkExp scope t1) (mkExp scope t2)
+    EInt i   -> eLit (LInt (fromIntegral i))
+    EFloat f -> eLit (LFlt f)
+    K s      -> eLit (LStr s)
+    Meta i   -> eMeta i
+    _        -> eMeta 0
+{-
 mkPatt scope p = 
   case p of
     A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
@@ -138,147 +163,146 @@ mkPatt scope p =
     A.PImplArg p-> let (scope',p') = mkPatt scope p
                    in (scope',C.PImplArg p')
     A.PTilde t  -> (  scope,C.PTilde (mkExp scope t))
-
-mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
+-}
+mkContext :: (?builder :: Builder s) => [Ident] -> A.Context -> ([Ident],[B s PGF.Hypo])
 mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
                                                       in if x == identW
-                                                           then (  scope,(bt,i2i x,ty'))
-                                                           else (x:scope,(bt,i2i x,ty'))) scope hyps 
-
+                                                           then (  scope,hypo bt (i2i x) ty')
+                                                           else (x:scope,hypo bt (i2i x) ty')) scope hyps 
+{-
 mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
                                  ,generateByteCode gr arity eqs
                                  )
 mkDef gr arity Nothing    = Nothing
-
+-}
 mkArity (Just a) _        ty = a   -- known arity, i.e. defined function
 mkArity Nothing  (Just _) ty = 0   -- defined function with no arity - must be an axiom
 mkArity Nothing  _        ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
                                in length ctxt
 
-genCncCats gr am cm cdefs =
-  let (index,cats) = mkCncCats 0 cdefs
-  in (index, Map.fromList cats)
+genCncCats gr am cm cdefs = mkCncCats 0 cdefs
   where
     mkCncCats index []                                                = (index,[])
     mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs) 
       | id == cInt    = 
-            let cc            = pgfCncCat gr lincat fidInt
+            let cc            = pgfCncCat gr (i2i id) lincat fidInt
                 (index',cats) = mkCncCats index cdefs
-            in (index', (i2i id,cc) : cats)
+            in (index', cc : cats)
       | id == cFloat  = 
-            let cc            = pgfCncCat gr lincat fidFloat
+            let cc            = pgfCncCat gr (i2i id) lincat fidFloat
                 (index',cats) = mkCncCats index cdefs
-            in (index', (i2i id,cc) : cats)
+            in (index', cc : cats)
       | id == cString = 
-            let cc            = pgfCncCat gr lincat fidString
+            let cc            = pgfCncCat gr (i2i id) lincat fidString
                 (index',cats) = mkCncCats index cdefs
-            in (index', (i2i id,cc) : cats)
+            in (index', cc : cats)
       | otherwise     =
-            let cc@(C.CncCat _s e _) = pgfCncCat gr lincat index
-                (index',cats)        = mkCncCats (e+1) cdefs
-            in (index', (i2i id,cc) : cats)
-    mkCncCats index (_                      :cdefs) = mkCncCats index cdefs
+            let cc@(_, _s, e, _) = pgfCncCat gr (i2i id) lincat index
+                (index',cats)    = mkCncCats (e+1) cdefs
+            in (index', cc : cats)
+    mkCncCats index (_                                          :cdefs) = mkCncCats index cdefs
 
 genCncFuns :: Grammar
            -> ModuleName
            -> ModuleName
-           -> Array SeqId Sequence
-           -> Array SeqId Sequence
+           -> Array SeqId [Symbol]
+           -> Array SeqId [Symbol]
            -> [(QIdent, Info)]
            -> FId
-           -> Map.Map CId C.CncCat
+           -> Map.Map CId (Int,Int)
            -> (FId,
-               IntMap.IntMap (Set.Set C.Production),
-               IntMap.IntMap [FunId],
-               IntMap.IntMap [FunId],
-               Array FunId C.CncFun)
-genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
-  let (fid_cnt1,lindefs,linrefs,fun_st1) = mkCncCats cdefs fid_cnt IntMap.empty IntMap.empty Map.empty
-      ((fid_cnt2,crc,prods),fun_st2)     = mkCncFuns cdefs lindefs ((fid_cnt1,Map.empty,IntMap.empty),fun_st1)
-  in (fid_cnt2,prods,lindefs,linrefs,array (0,Map.size fun_st2-1) (Map.elems fun_st2))
+               [(FId, [Production])],
+               [(FId, [FunId])],
+               [(FId, [FunId])],
+               [(CId,[SeqId])])
+genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccat_ranges =
+  let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty IntMap.empty
+      (fid_cnt2,funs_cnt2,funs2,prods0)          = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
+      prods                                      = [(fid,Set.toList prodSet) | (fid,prodSet) <- IntMap.toList prods0]
+  in (fid_cnt2,prods,IntMap.toList lindefs,IntMap.toList linrefs,reverse funs2)
   where
-    mkCncCats []                                                          fid_cnt lindefs linrefs fun_st =
-      (fid_cnt,lindefs,linrefs,fun_st)
-    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt lindefs linrefs fun_st =
-      let mseqs   = case lookupModule gr m of
-                      Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
-                      _                              -> ex_seqs
-          (lindefs',fun_st1) = foldl' (toLinDef (m,id) funs0 mseqs) (lindefs,fun_st ) prods0
-          (linrefs',fun_st2) = foldl' (toLinRef (m,id) funs0 mseqs) (linrefs,fun_st1) prods0
-      in mkCncCats cdefs fid_cnt lindefs' linrefs' fun_st2
-    mkCncCats (_                                                  :cdefs) fid_cnt lindefs linrefs fun_st =
-      mkCncCats cdefs fid_cnt lindefs linrefs fun_st
+    mkCncCats []                                                          fid_cnt funs_cnt funs lindefs linrefs =
+      (fid_cnt,funs_cnt,funs,lindefs,linrefs)
+    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+      let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
+                       in funs_cnt+(e_funid-s_funid+1)
+          lindefs'   = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
+          linrefs'   = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
+          funs'      = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
+      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
+    mkCncCats (_                                                  :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+      mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
 
-    mkCncFuns []                                                        lindefs st = st
-    mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) lindefs st =
-      let ty_C    = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
-          mseqs   = case lookupModule gr m of
-                      Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
-                      _                              -> ex_seqs
-          bundles = [([(args0,res0) | Production res0 funid0 args0 <- prods0, funid0==funid],lins) | (funid,lins) <- assocs funs0]
-          !st'    = foldl' (toProd id lindefs mseqs ty_C) st bundles
-      in mkCncFuns cdefs lindefs st'
-    mkCncFuns (_                                                :cdefs) lindefs st =
-      mkCncFuns cdefs lindefs st
+    mkCncFuns []                                                        fid_cnt funs_cnt funs lindefs crc prods =
+      (fid_cnt,funs_cnt,funs,prods)
+    mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
+      let ty_C           = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
+          !funs_cnt'     = let (s_funid, e_funid) = bounds funs0
+                           in funs_cnt+(e_funid-s_funid+1)
+          !(fid_cnt',crc',prods')
+                         = foldl' (toProd lindefs ty_C funs_cnt)
+                                  (fid_cnt,crc,prods) prods0
+          funs'          = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
+      in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods'
+    mkCncFuns (_                                                :cdefs) fid_cnt funs_cnt funs lindefs crc prods = 
+      mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods
 
-    toLinDef mid funs0 mseqs st@(lindefs,fun_st) (Production res0 funid0 [arg0])
-      | arg0 == [fidVar] =
-          let res  = mkFId mid res0
-
-              lins = amap (newSeqId mseqs) (funs0 ! funid0)
-
-              !funid    = Map.size fun_st
-              !fun_st'  = Map.insert ([([C.PArg [] fidVar],res)],lins) (funid, C.CncFun [] lins) fun_st
-
-              !lindefs' = IntMap.insertWith (++) res [funid] lindefs
-          in (lindefs',fun_st')
-    toLinDef res funs0 mseqs st _ = st
-
-    toLinRef mid funs0 mseqs st (Production res0 funid0 [arg0])
-      | res0 == fidVar  =
-          let arg  = map (mkFId mid) arg0
-
-              lins = amap (newSeqId mseqs) (funs0 ! funid0)
-
-          in foldr (\arg (linrefs,fun_st) -> 
-                          let !funid    = Map.size fun_st
-                              !fun_st'  = Map.insert ([([C.PArg [] arg],fidVar)],lins) (funid, C.CncFun [] lins) fun_st
-
-                              !linrefs' = IntMap.insertWith (++) arg [funid] linrefs
-                          in (linrefs',fun_st'))
-                   st arg
-    toLinRef res funs0 mseqs st _ = st
-
-    toProd id lindefs mseqs (ctxt_C,res_C,_) (prod_st,fun_st) (sigs0,lins0) =
-      let (prod_st',sigs) = mapAccumL mkCncSig prod_st sigs0
-          lins            = amap (newSeqId mseqs) lins0
-      in addBundle id (prod_st',fun_st) (concat sigs,lins)
+    toProd lindefs (ctxt_C,res_C,_) offs st (A.Production fid0 funid0 args0) =
+      let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
+          set0    = Set.fromList (map (PApply (offs+funid0)) (sequence args))
+          fid     = mkFId res_C fid0
+          !prods' = case IntMap.lookup fid prods of
+                     Just set -> IntMap.insert fid (Set.union set0 set) prods
+                     Nothing  -> IntMap.insert fid set0 prods
+      in (fid_cnt,crc,prods')
       where
-        mkCncSig prod_st (args0,res0) =
-          let !(prod_st',args) = mapAccumL mkArg prod_st (zip ctxt_C args0)
-              res              = mkFId res_C res0
-          in (prod_st',[(args,res) | args <- sequence args])
-
         mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s) =
           case fid0s of
-            [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
+            [fid0] -> (st,map (flip PArg (mkFId arg_C fid0)) ctxt)
             fid0s  -> case Map.lookup fids crc of
-                        Just fid -> (st,map (flip C.PArg fid) ctxt)
+                        Just fid -> (st,map (flip PArg fid) ctxt)
                         Nothing  -> let !crc'   = Map.insert fids fid_cnt crc
-                                        !prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods
-                                    in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
+                                        !prods' = IntMap.insert fid_cnt (Set.fromList (map PCoerce fids)) prods
+                                    in ((fid_cnt+1,crc',prods'),map (flip PArg fid_cnt) ctxt)
           where
             (hargs_C,arg_C) = GM.catSkeleton ty
-            ctxt = mapM mkCtxt hargs_C
+            ctxt = mapM (mkCtxt lindefs) hargs_C
             fids = map (mkFId arg_C) fid0s
 
-        mkCtxt (_,cat) =
-          case Map.lookup (i2i cat) cnccats of
-            Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
-            Nothing               -> error "GrammarToPGF.mkCtxt failed"
+    mkLinDefId id = prefixIdent "lindef " id
 
-    newSeqId mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
+    toLinDef res offs lindefs (A.Production fid0 funid0 args) =
+      if args == [[fidVar]]
+        then IntMap.insertWith (++) fid [offs+funid0] lindefs
+        else lindefs
       where
+        fid = mkFId res fid0
+
+    toLinRef res offs linrefs (A.Production fid0 funid0 [fargs]) =
+      if fid0 == fidVar
+        then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
+        else linrefs
+      where
+        fids = map (mkFId res) fargs
+
+    mkFId (_,cat) fid0 =
+      case Map.lookup (i2i cat) cnccat_ranges of
+        Just (s,e) -> s+fid0
+        Nothing    -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
+
+    mkCtxt lindefs (_,cat) =
+      case Map.lookup (i2i cat) cnccat_ranges of
+        Just (s,e) -> [(fid,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
+        Nothing    -> error "GrammarToPGF.mkCtxt failed"
+
+    toCncFun offs (m,id) funs (funid0,lins0) =
+      let mseqs = case lookupModule gr m of
+                    Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
+                    _                              -> ex_seqs
+      in (i2i id, map (newIndex mseqs) (elems lins0)):funs
+      where
+        newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
+
         binSearch v arr (i,j)
           | i <= j    = case compare v (arr ! k) of
                           LT -> binSearch v arr (i,k-1)
@@ -288,26 +312,9 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
           where
             k = (i+j) `div` 2
 
-    addBundle id ((fid_cnt,crc,prods),fun_st) bundle@(sigs,lins) =
-      case Map.lookup bundle fun_st of
-        Just (funid, C.CncFun funs lins) -> 
-          let !fun_st' = Map.insert bundle (funid, C.CncFun (i2i id:funs) lins) fun_st
-              !prods'  = foldl' (\prods (args,res) -> IntMap.insert res (Set.singleton (C.PApply funid args)) prods) prods sigs
-          in ((fid_cnt,crc,prods'),fun_st')
-        Nothing                          -> 
-          let !funid   = Map.size fun_st
-              !fun_st' = Map.insert bundle (funid, C.CncFun [i2i id] lins) fun_st
-              !prods'  = foldl' (\prods (args,res) -> IntMap.insert res (Set.singleton (C.PApply funid args)) prods) prods sigs
-          in ((fid_cnt,crc,prods'),fun_st')
-
-    mkFId (_,cat) fid0 =
-      case Map.lookup (i2i cat) cnccats of
-        Just (C.CncCat s e _) -> s+fid0
-        Nothing               -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
-
 
 genPrintNames cdefs =
-  Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
+  [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
   where
     prn (CncFun _ _   (Just (L _ tr)) _) = [flatten tr]
     prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
@@ -316,7 +323,3 @@ genPrintNames cdefs =
     flatten (K s)      = s
     flatten (Alts x _) = flatten x
     flatten (C x y)    = flatten x +++ flatten y
-
---mkArray    lst = listArray (0,length lst-1) lst
-mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
-mkSetArray set = listArray (0,Set.size set-1) [v | v <- Set.toList set]

src/compiler/GF/Compile/PGFtoHaskell.hs

@@ -16,13 +16,14 @@
 
 module GF.Compile.PGFtoHaskell (grammar2haskell) where
 
-import PGF(showCId)
+import PGF
 import PGF.Internal
 
 import GF.Data.Operations
 import GF.Infra.Option
 
-import Data.List --(isPrefixOf, find, intersperse)
+import Data.List
+import Data.Maybe(mapMaybe)
 import qualified Data.Map as Map
 
 type Prefix = String -> String
@@ -39,7 +40,7 @@ grammar2haskell opts name gr = foldr (++++) [] $
           lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
           gId | haskellOption opts HaskellNoPrefix = id
               | otherwise = ("G"++)
-          pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}","{-# LANGUAGE GADTs #-}"]
+          pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"]
                   | otherwise = []
           types | gadt = datatypesGADT gId lexical gr'
                 | otherwise = datatypes gId lexical gr'
@@ -262,18 +263,21 @@ fInstance gId lexical m (cat,rules) =
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
 hSkeleton gr = 
-  (showCId (absname gr), 
+  (showCId (abstractName gr),
    let fs = 
-         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | 
-                                        fs@((_, (_,c)):_) <- fns]
+         [(showCId c, [(showCId f, map showCId cs) | (f, cs,_) <- fs]) | 
+                                        fs@((_, _,c):_) <- fns]
    in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
   )
  where
-   cts = Map.keys (cats (abstract gr)) 
-   fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
-   valtyps (_, (_,x)) (_, (_,y)) = compare x y
-   valtypg (_, (_,x)) (_, (_,y)) = x == y
-   jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
+   cts = categories gr
+   fns = groupBy valtypg (sortBy valtyps (mapMaybe jty (functions gr)))
+   valtyps (_,_,x) (_,_,y) = compare x y
+   valtypg (_,_,x) (_,_,y) = x == y
+   jty f = case functionType gr f of
+             Just ty -> let (hypos,valcat,_) = unType ty
+                        in Just (f,[argcat | (_,_,ty) <- hypos, let (_,argcat,_) = unType ty],valcat)
+             Nothing -> Nothing
 {-
 updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
 updateSkeleton cat skel rule =

src/compiler/GF/Compile/PGFtoJS.hs

@@ -1,17 +1,9 @@
 module GF.Compile.PGFtoJS (pgf2js) where
 
-import PGF(showCId)
-import PGF.Internal as M
+import PGF
+import PGF.Internal
 import qualified GF.JavaScript.AbsJS as JS
 import qualified GF.JavaScript.PrintJS as JS
-
---import GF.Data.ErrM
---import GF.Infra.Option
-
---import Control.Monad (mplus)
---import Data.Array.Unboxed (UArray)
-import qualified Data.Array.IArray as Array
---import Data.Maybe (fromMaybe)
 import Data.Map (Map)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
@@ -21,54 +13,44 @@ pgf2js :: PGF -> String
 pgf2js pgf =
   JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
  where
-   n  = showCId $ absname pgf
-   as = abstract pgf
-   cs = Map.assocs (concretes pgf)
-   start = showCId $ M.lookStartCat pgf
+   n  = showCId $ abstractName pgf
+   start = showType [] $ startCat pgf
    grammar = new "GFGrammar" [js_abstract, js_concrete]
-   js_abstract = abstract2js start as
-   js_concrete = JS.EObj $ map concrete2js cs
+   js_abstract = abstract2js start pgf
+   js_concrete = JS.EObj $ map (concrete2js pgf) (languages pgf)
 
-abstract2js :: String -> Abstr -> JS.Expr
-abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
+abstract2js :: String -> PGF -> JS.Expr
+abstract2js start pgf = new "GFAbstract" [JS.EStr start, JS.EObj [absdef2js f ty | f <- functions pgf, Just ty <- [functionType pgf f]]]
 
-absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
-absdef2js (f,(typ,_,_,_)) =
-  let (args,cat) = M.catSkeleton typ in 
-    JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
+absdef2js :: CId -> Type -> JS.Property
+absdef2js f typ =
+  let (hypos,cat,_) = unType typ
+      args          = [cat | (_,_,typ) <- hypos, let (hypos,cat,_) = unType typ]
+  in JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
 
 lit2js (LStr s) = JS.EStr s
 lit2js (LInt n) = JS.EInt n
 lit2js (LFlt d) = JS.EDbl d
 
-concrete2js :: (CId,Concr) -> JS.Property
-concrete2js (c,cnc) =
-  JS.Prop l (new "GFConcrete" [mapToJSObj (lit2js) $ cflags cnc,
-                               JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)],
-                               JS.EArray $ (map ffun2js (Array.elems (cncfuns cnc))),
-                               JS.EArray $ (map seq2js (Array.elems (sequences cnc))),
-                               JS.EObj $ map cats (Map.assocs (cnccats cnc)),
-                               JS.EInt (totalCats cnc)])
-  where 
-   l  = JS.IdentPropName (JS.Ident (showCId c))
-{-
+concrete2js :: PGF -> Language -> JS.Property
+concrete2js pgf lang =
+  JS.Prop l (new "GFConcrete" [mapToJSObj (lit2js) $ concrFlags cnc,
+                               JS.EObj [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (concrProductions cnc cat))) | cat <- [0..concrTotalCats cnc]],
+                               JS.EArray [ffun2js (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc]],
+                               JS.EArray [seq2js (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc]],
+                               JS.EObj $ map cats (concrCategories cnc),
+                               JS.EInt (concrTotalCats cnc)])
+  where
+   cnc = lookConcr pgf lang
+   l  = JS.IdentPropName (JS.Ident (showCId lang))
+
    litslins = [JS.Prop (JS.StringPropName    "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), 
                JS.Prop (JS.StringPropName  "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
                JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
--}
-   cats (c,CncCat start end _) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
-                                                                                            ,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
-{-
-mkStr :: String -> JS.Expr
-mkStr s = new "Str" [JS.EStr s]
 
-mkSeq :: [JS.Expr] -> JS.Expr
-mkSeq [x] = x
-mkSeq xs = new "Seq" xs
+   cats (c,start,end,_) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
+                                                                                     ,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
 
-argIdent :: Integer -> JS.Ident
-argIdent n = JS.Ident ("x" ++ show n)
--}
 children :: JS.Ident
 children = JS.Ident "cs"
 
@@ -78,10 +60,10 @@ frule2js (PCoerce arg)       = new "Coerce" [JS.EInt arg]
 
 farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid])
 
-ffun2js (CncFun fns lins) = new "CncFun" [JS.EArray (map (JS.EStr . showCId) fns), JS.EArray (map JS.EInt (Array.elems lins))]
+ffun2js (f,lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt lins)]
 
-seq2js :: Array.Array DotPos Symbol -> JS.Expr
-seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq]
+seq2js :: [Symbol] -> JS.Expr
+seq2js seq = JS.EArray [sym2js s | s <- seq]
 
 sym2js :: Symbol -> JS.Expr
 sym2js (SymCat n l)    = new "SymCat" [JS.EInt n, JS.EInt l]
@@ -103,3 +85,4 @@ new f xs = JS.ENew (JS.Ident f) xs
 
 mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr
 mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ]
+

src/compiler/GF/Compile/PGFtoProlog.hs

@@ -8,9 +8,8 @@
 
 module GF.Compile.PGFtoProlog (grammar2prolog) where
 
-import PGF(mkCId,wildCId,showCId)
+import PGF
 import PGF.Internal
---import PGF.Macros
 
 import GF.Data.Operations
 
@@ -29,70 +28,56 @@ grammar2prolog pgf
                    [[plp name]] ++++
        plFacts wildCId "concrete" 2 "(?AbstractName, ?ConcreteName)" 
                    [[plp name, plp cncname] | 
-                    cncname <- Map.keys (concretes pgf)] ++++
+                    cncname <- languages pgf] ++++
        plFacts wildCId "flag" 2 "(?Flag, ?Value): global flags" 
                    [[plp f, plp v] | 
-                    (f, v) <- Map.assocs (gflags pgf)] ++++
-       plAbstract name (abstract pgf) ++++
-       unlines (map plConcrete (Map.assocs (concretes pgf)))
+                    (f, v) <- Map.assocs (globalFlags pgf)] ++++
+       plAbstract name pgf ++++
+       unlines [plConcrete name (lookConcr pgf name) | name <- languages pgf]
       )
-    where name = absname pgf
+    where name = abstractName pgf
 
 ----------------------------------------------------------------------
 -- abstract syntax
 
-plAbstract :: CId -> Abstr -> String
-plAbstract name abs 
+plAbstract :: CId -> PGF -> String
+plAbstract name pgf
     = (plHeader "Abstract syntax" ++++
        plFacts name "flag" 2 "(?Flag, ?Value): flags for abstract syntax"
                    [[plp f, plp v] | 
-                    (f, v) <- Map.assocs (aflags abs)] ++++
+                    (f, v) <- Map.assocs (abstrFlags pgf)] ++++
        plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
-                   [[plType cat args, plHypos hypos'] |
-                    (cat, (hypos,_,_)) <- Map.assocs (cats abs),
-                    let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
-                        let args = reverse [EFun x | (_,x) <- subst]] ++++
+                   [[plType cat, []] | cat <- categories pgf] ++++
        plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
-                   [[plp fun, plType cat args, plHypos hypos] |
-                    (fun, (typ, _, _, _)) <- Map.assocs (funs abs),
-                    let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
-       plFacts name "def" 2 "(?Fun, ?Expr)" 
-                   [[plp fun, plp expr] |
-                    (fun, (_, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
-                    let (_, expr) = alphaConvert emptyEnv eqs]
+                   [[plp fun, plType cat, plHypos hypos] |
+                    fun <- functions pgf, Just typ <- [functionType pgf fun],
+                    let (hypos,cat,_) = unType typ]
       )
-    where plType cat args = plTerm (plp cat) (map plp args)
+    where plType cat = plTerm (plp cat) []
           plHypos hypos = plList [plOper ":" (plp x) (plp ty) | (_, x, ty) <- hypos]
 
 ----------------------------------------------------------------------
 -- concrete syntax
 
-plConcrete :: (CId, Concr) -> String
-plConcrete (name, cnc) 
+plConcrete :: CId -> Concr -> String
+plConcrete name cnc
     = (plHeader ("Concrete syntax: " ++ plp name) ++++
        plFacts name "flag" 2 "(?Flag, ?Value): flags for concrete syntax"
                    [[plp f, plp v] | 
-                    (f, v) <- Map.assocs (cflags cnc)] ++++
-       plFacts name "printname" 2 "(?AbsFun/AbsCat, ?Atom)"
-                   [[plp f, plp n] | 
-                    (f, n) <- Map.assocs (printnames cnc)] ++++
-       plFacts name "lindef" 2 "(?CncCat, ?CncFun)"
-                   [[plCat cat, plFun fun] | 
-                    (cat, funs) <- IntMap.assocs (lindefs cnc),
-                    fun <- funs] ++++
+                    (f, v) <- Map.assocs (concrFlags cnc)] ++++
        plFacts name "prod" 3 "(?CncCat, ?CncFun, ?[CncCat])"
                    [[plCat cat, fun, plTerm "c" (map plCat args)] |
-                    (cat, set) <- IntMap.toList (productions cnc),
-                    (fun, args) <- map plProduction (Set.toList set)] ++++
+                    cat <- [0..concrTotalCats cnc-1],
+                    (fun, args) <- map plProduction (concrProductions cnc cat)] ++++
        plFacts name "cncfun" 3 "(?CncFun, ?[Seq,...], ?AbsFun)"
-                   [[plFun fun, plTerm "s" (map plSeq (Array.elems lins)), plp absfun] |
-                    (fun, CncFun absfun lins) <- Array.assocs (cncfuns cnc)] ++++
+                   [[plFun funid, plTerm "s" (map plSeq lins), plp absfun] |
+                    funid <- [0..concrTotalFuns cnc-1], let (absfun,lins) = concrFunction cnc funid] ++++
        plFacts name "seq" 2 "(?Seq, ?[Term])"
-                   [[plSeq seq, plp (Array.elems symbols)] |
-                    (seq, symbols) <- Array.assocs (sequences cnc)] ++++
+                   [[plSeq seqid, plp (concrSequence cnc seqid)] |
+                    seqid <- [0..concrTotalSeqs cnc-1]] ++++
        plFacts name "cnccat" 2 "(?AbsCat, ?[CnCCat])" 
                    [[plp cat, plList (map plCat [start..end])] |
-                    (cat, CncCat start end _) <- Map.assocs (cnccats cnc)]
+                    (cat,start,end,_) <- concrCategories cnc]
       )
     where plProduction (PCoerce arg)       = ("-", [arg])
           plProduction (PApply funid args) = (plFun funid, [fid | PArg hypos fid <- args])
@@ -101,26 +86,12 @@ plConcrete (name, cnc)
 -- prolog-printing pgf datatypes
 
 instance PLPrint Type where
-    plp (DTyp hypos cat args) 
-        | null hypos = result
-        | otherwise  = plOper " -> " plHypos result
-        where result = plTerm (plp cat) (map plp args)
-              plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
-
-instance PLPrint Expr where
-    plp (EFun x)    = plp x
-    plp (EAbs _ x e)= plOper "^" (plp x) (plp e)
-    plp (EApp e e') = plOper " * " (plp e) (plp e')
-    plp (ELit lit)  = plp lit
-    plp (EMeta n)   = "Meta_" ++ show n
-
-instance PLPrint Patt where
-    plp (PVar x)    = plp x
-    plp (PApp f ps) = plOper " * " (plp f) (plp ps)
-    plp (PLit lit)  = plp lit
-
-instance PLPrint Equation where
-    plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
+    plp ty
+      | null hypos = result
+      | otherwise  = plOper " -> " plHypos result
+      where (hypos,cat,_) = unType ty
+            result = plTerm (plp cat) []
+            plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
 
 instance PLPrint CId where
     plp cid | isLogicalVariable str || cid == wildCId = plVar str
@@ -213,50 +184,3 @@ isLogicalVariable = isPrefixOf logicalVariablePrefix
 
 logicalVariablePrefix :: String 
 logicalVariablePrefix = "X"
-
-----------------------------------------------------------------------
--- alpha convert variables to (unique) logical variables
--- * this is needed if we want to translate variables to Prolog variables
--- * used for abstract syntax, not concrete
--- * not (yet?) used for variables bound in pattern equations
-
-type ConvertEnv = (Int, [(CId,CId)])
-
-emptyEnv :: ConvertEnv
-emptyEnv = (0, [])
-
-class AlphaConvert a where
-    alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a)
-
-instance AlphaConvert a => AlphaConvert [a] where
-    alphaConvert env [] = (env, [])
-    alphaConvert env (a:as) = (env'', a':as')
-        where (env',  a')  = alphaConvert env  a
-              (env'', as') = alphaConvert env' as
-
-instance AlphaConvert Type where
-    alphaConvert env@(_,subst) (DTyp hypos cat args) 
-        = ((ctr,subst), DTyp hypos' cat args')
-        where (env',   hypos') = mapAccumL alphaConvertHypo env hypos
-              ((ctr,_), args') = alphaConvert env' args
-
-alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ'))
-    where ((ctr,subst), typ') = alphaConvert env typ
-          x' = createLogicalVariable ctr
-
-instance AlphaConvert Expr where
-    alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e')
-        where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e
-              x' = createLogicalVariable ctr
-    alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2')
-        where (env',  e1') = alphaConvert env  e1
-              (env'', e2') = alphaConvert env' e2
-    alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env)))
-    alphaConvert env expr = (env, expr)
-
--- pattern variables are not alpha converted
--- (but they probably should be...)
-instance AlphaConvert Equation where
-    alphaConvert env@(_,subst) (Equ patterns result)
-        = ((ctr,subst), Equ patterns result')
-        where ((ctr,_), result') = alphaConvert env result

src/compiler/GF/Compile/PGFtoPython.hs

@@ -9,40 +9,34 @@
 {-# LANGUAGE FlexibleContexts #-}
 module GF.Compile.PGFtoPython (pgf2python) where
 
-import PGF(showCId)
-import PGF.Internal as M
-
-import GF.Data.Operations
-
-import qualified Data.Array.IArray as Array
-import qualified Data.Set as Set
+import PGF
+import PGF.Internal
 import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
---import Data.List (intersperse)
+import GF.Data.Operations
 
 pgf2python :: PGF -> String
 pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
                   "# This file was automatically generated by GF" +++++
                   showCId name +++ "=" +++ 
                   pyDict 1 pyStr id [
-                              ("flags", pyDict 2 pyCId pyLiteral (Map.assocs (gflags pgf))),
+                              ("flags", pyDict 2 pyCId pyLiteral (Map.assocs (globalFlags pgf))),
                               ("abstract", pyDict 2 pyStr id [
                                               ("name", pyCId name), 
-                                              ("start", pyCId start), 
-                                              ("flags", pyDict 3 pyCId pyLiteral (Map.assocs (aflags abs))),
-                                              ("funs", pyDict 3 pyCId pyAbsdef (Map.assocs (funs abs)))
+                                              ("start", pyCId start),
+                                              ("flags", pyDict 3 pyCId pyLiteral (Map.assocs (abstrFlags pgf))),
+                                              ("funs", pyDict 3 pyCId pyAbsdef [(f,ty) | f <- functions pgf, Just ty <- [functionType pgf f]])
                                              ]),
-                              ("concretes", pyDict 2 pyCId pyConcrete (Map.assocs cncs))
+                              ("concretes", pyDict 2 pyCId pyConcrete [(lang,lookConcr pgf lang) | lang <- languages pgf])
                              ] ++ "\n")
     where
-      name  = absname pgf
-      start = M.lookStartCat pgf
-      abs = abstract pgf
-      cncs = concretes pgf
+      name  = abstractName pgf
+      (_,start,_) = unType (startCat pgf)
+--      cncs = concretes pgf
 
-pyAbsdef :: (Type, Int, Maybe ([Equation], [[M.Instr]]), Double) -> String
-pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
-    where (args, cat) = M.catSkeleton typ 
+pyAbsdef :: Type -> String
+pyAbsdef typ = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
+    where (hypos,cat,_) = unType typ
+          args = [cat | (_,_,typ) <- hypos, let (_,cat,_) = unType typ]
 
 pyLiteral :: Literal -> String
 pyLiteral (LStr s) = pyStr s
@@ -51,19 +45,17 @@ pyLiteral (LFlt d) = show d
 
 pyConcrete :: Concr -> String
 pyConcrete cnc = pyDict 3 pyStr id [
-                  ("flags", pyDict 0 pyCId pyLiteral (Map.assocs (cflags cnc))),
-                  ("printnames", pyDict 4 pyCId pyStr (Map.assocs (printnames cnc))),
-                  ("lindefs", pyDict 4 pyCat (pyList 0 pyFun) (IntMap.assocs (lindefs cnc))),
-                  ("productions", pyDict 4 pyCat pyProds (IntMap.assocs (productions cnc))),
-                  ("cncfuns", pyDict 4 pyFun pyCncFun (Array.assocs (cncfuns cnc))),
-                  ("sequences",  pyDict 4 pySeq pySymbols (Array.assocs (sequences cnc))),
-                  ("cnccats", pyDict 4 pyCId pyCncCat (Map.assocs (cnccats cnc))),
-                  ("size",  show (totalCats cnc))
+                  ("flags", pyDict 0 pyCId pyLiteral (Map.assocs (concrFlags cnc))),
+                  ("productions", pyDict 4 pyCat pyProds [(fid,concrProductions cnc fid) | fid <- [0..concrTotalCats cnc-1]]),
+                  ("cncfuns", pyDict 4 pyFun pyCncFun [(funid,concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]]),
+                  ("sequences",  pyDict 4 pySeq pySymbols [(seqid,concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]]),
+                  ("cnccats", pyDict 4 pyCId pyCncCat [(cat,(s,e,lbls)) | (cat,s,e,lbls) <- concrCategories cnc]),
+                  ("size",  show (concrTotalCats cnc))
                  ]
-    where pyProds prods = pyList 5 pyProduction (Set.toList prods)
-          pyCncCat (CncCat start end _) = pyList 0 pyCat [start..end]
-          pyCncFun (CncFun fns lins) = pyTuple 0 id [pyList 0 pySeq (Array.elems lins), pyList 0 pyCId fns]
-          pySymbols syms = pyList 0 pySymbol (Array.elems syms)
+    where pyProds prods = pyList 5 pyProduction prods
+          pyCncCat (start,end,_) = pyList 0 pyCat [start..end]
+          pyCncFun (f,lins) = pyTuple 0 id [pyList 0 pySeq lins, pyCId f]
+          pySymbols syms = pyList 0 pySymbol syms
 
 pyProduction :: Production -> String
 pyProduction (PCoerce arg)       = pyTuple 0 id [pyStr "", pyList 0 pyCat [arg]]

src/compiler/GF/Compile/ToAPI.hs

@@ -2,8 +2,7 @@ module GF.Compile.ToAPI
  (stringToAPI,exprToAPI)
   where
 
-import PGF.Internal
-import PGF(showCId)
+import PGF
 import Data.Maybe
 --import System.IO
 --import Control.Monad

src/compiler/GF/Compile/TypeCheck/RConcrete.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE PatternGuards #-}
 module GF.Compile.TypeCheck.RConcrete( checkLType, inferLType, computeLType, ppType ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Infra.CheckM
 import GF.Data.Operations