first steps towards PMCFG generation

gf.cabal

@@ -116,7 +116,6 @@ executable gf
     GF.Compile.GeneratePMCFG
     GF.Compile.GrammarToPGF
     GF.Compile.Multi
-    GF.Compile.Optimize
     GF.Compile.OptimizePGF
     GF.Compile.PGFtoHaskell
     GF.Compile.PGFtoJava

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

@@ -3,9 +3,12 @@
 -- | Functions for computing the values of terms in the concrete syntax, in
 -- | preparation for PMCFG generation.
 module GF.Compile.Compute.Concrete
-           (normalForm,
-            Value(..), Env, value2term, eval
+           ( normalForm
+           , Value(..), Thunk, ThunkState(..), Env, EvalM, runEvalM
+           , eval, apply, force, value2term
+           , newMeta,newEvaluatedThunk,getAllParamValues
            ) where
+
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Grammar hiding (Env, VGen, VApp, VRecType)
@@ -72,6 +75,8 @@ data Value s
   | VPattType (Value s)
   | VAlts (Value s) [(Value s, Value s)]
   | VStrs [Value s]
+  | VSymCat Int Int     -- This is only generated internally in
+                        -- the PMCFG generator.
 
 
 eval env (Vr x)         vs  = case lookup x env of
@@ -322,6 +327,10 @@ value2term i (VMeta m env tnks) = do
   case res of
     Right i -> foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (Meta i) tnks
     Left  v -> value2term i v
+value2term i (VSusp j env vs k) = do
+  tnk <- newEvaluatedThunk (VGen maxBound vs)
+  v <- k tnk
+  value2term i v
 value2term i (VGen j tnks) =
   foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (Vr (identS ('v':show j))) tnks
 value2term i (VClosure env (Abs b x t)) = do

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -13,628 +13,82 @@ module GF.Compile.GeneratePMCFG
     (generatePMCFG, pgfCncCat, addPMCFG
     ) where
 
-import qualified PGF2 as PGF2
-import qualified PGF2.Internal as PGF2
-import PGF2.Internal(Symbol(..),fidVar)
-
-import GF.Infra.Option
-import GF.Grammar hiding (Env, mkRecord, mkTable)
-import GF.Grammar.Lookup
+import GF.Grammar
 import GF.Grammar.Predef
-import GF.Grammar.Lockfield (isLockLabel)
-import GF.Data.BacktrackM
-import GF.Data.Operations
-import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
-import GF.Data.Utilities (updateNthM) --updateNth
-import GF.Compile.Compute.Concrete(normalForm)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.List as List
---import qualified Data.IntMap as IntMap
-import qualified Data.IntSet as IntSet
-import GF.Text.Pretty
-import Data.Array.IArray
-import Data.Array.Unboxed
---import Data.Maybe
---import Data.Char (isDigit)
-import Control.Applicative(Applicative(..))
-import Control.Monad
-import Control.Monad.Identity
---import Control.Exception
---import Debug.Trace(trace)
-import qualified Control.Monad.Fail as Fail
+import GF.Infra.CheckM
+import GF.Infra.Option
+import GF.Compile.Compute.Concrete
+import PGF2.Transactions
+import qualified Data.Map.Strict as Map
 
-----------------------------------------------------------------------
--- main conversion function
+generatePMCFG :: Options -> SourceGrammar -> SourceModule -> Check SourceModule
+generatePMCFG opts gr cmo@(cm,cmi) = do
+  js <- mapM (addPMCFG opts gr) (Map.toList (jments cmi))
+  return (cm,cmi{jments = (Map.fromAscList js)})
 
---generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
-generatePMCFG opts sgr opath cmo@(cm,cmi) = do
-  (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr opath am cm) Map.empty (jments cmi)
-  when (verbAtLeast opts Verbose) $ ePutStrLn ""
-  return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
+addPMCFG opts gr (id,CncFun mty@(Just (cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) = do
+  lins <- pmcfgForm gr (L loc id) term ctxt
+  return (id,CncFun mty mlin mprn (Just (PMCFG lins)))
+addPMCFG opts gr id_info = return id_info
+
+pmcfgForm :: Grammar -> L Ident -> Term -> Context -> Check [[[Symbol]]]
+pmcfgForm gr _ t ctxt =
+  runEvalM gr $ do
+    (_,args) <- mapAccumM (\(d,r) (_,_,ty) -> do (r,v) <- type2metaValue d r ty
+                                                 return ((d+1,r),v))
+                          (0,0) ctxt
+    v <- eval [] t args
+    (lins,_) <- value2pmcfg v []
+    return (reverse lins)
+
+type2metaValue :: Int -> Int -> Type -> EvalM s (Int,Thunk s)
+type2metaValue d r (Sort s) | s == cStr = do
+  tnk <- newEvaluatedThunk (VSymCat d r)
+  return (r+1,tnk)
+type2metaValue d r (RecType lbls) = do
+  (r,lbls) <- mapAccumM (\i (lbl,ty) -> do (i,tnk) <- type2metaValue d i ty
+                                           return (i,(lbl,tnk)))
+                        r lbls
+  tnk <- newEvaluatedThunk (VR lbls)
+  return (r,tnk)
+type2metaValue d r (Table p q) = do
+  ts <- getAllParamValues p
+  (r,vs) <- mapAccumM (\r _ -> type2metaValue d r q) r ts
+  tnk <- newEvaluatedThunk (VV p vs)
+  return (r, tnk)
+type2metaValue d r (QC q) = do
+  tnk <- newMeta 0
+  return (r, tnk)
+
+value2pmcfg (VR as) lins = do
+  (lins,as) <- collectFields lins as
+  return (lins,VR as)
   where
-    gr = prependModule sgr cmo
-    MTConcrete am = mtype cmi
-
-mapAccumWithKeyM :: (Monad m, Ord k) => (a -> k -> b -> m (a,c)) -> a
-                                     -> Map.Map k b -> m (a,Map.Map k c)
-mapAccumWithKeyM f a m = do let xs = Map.toAscList m
-                            (a,ys) <- mapAccumM f a xs
-                            return (a,Map.fromAscList ys)
-  where
-    mapAccumM f a []          = return (a,[])
-    mapAccumM f a ((k,x):kxs) = do (a,y ) <- f a k x
-                                   (a,kys) <- mapAccumM f a kxs
-                                   return (a,(k,y):kys)
-
-
---addPMCFG :: Options -> SourceGrammar -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
-addPMCFG opts gr opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
---when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
-  let pres  = protoFCat gr res val
-      pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
-
-      pmcfgEnv0   = emptyPMCFGEnv
-  b             <- convert opts gr (floc opath loc id) term (cont,val) pargs
-  let (seqs1,b1) = addSequencesB seqs b
-      pmcfgEnv1  = foldBM addRule
-                          pmcfgEnv0
-                          (goB b1 CNil [])
-                          (pres,pargs)
-      pmcfg      = getPMCFG pmcfgEnv1
-
-      stats      = let PMCFG prods funs = pmcfg
-                       (s,e)            = bounds funs
-                       !prods_cnt       = length prods
-                       !funs_cnt        = e-s+1
-                   in (prods_cnt,funs_cnt)
-
-  when (verbAtLeast opts Verbose) $
-    ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
-  seqs1 `seq` stats `seq` return ()
-  when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
-  return (seqs1,CncFun mty mlin mprn (Just pmcfg))
-  where
-    (ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
-
-    addRule lins (newCat', newArgs') env0 =
-      let [newCat] = getFIds newCat'
-          !fun     = mkArray lins
-          newArgs  = map getFIds newArgs'
-      in addFunction env0 newCat fun newArgs
-
-addPMCFG opts gr opath am cm seqs id (CncCat mty@(Just (L _ lincat)) 
-                                             mdef@(Just (L loc1 def))
-                                             mref@(Just (L loc2 ref))
-                                             mprn
-                                             Nothing) = do
-  let pcat = protoFCat gr (am,id) lincat
-      pvar = protoFCat gr (MN identW,cVar) typeStr
-
-      pmcfgEnv0  = emptyPMCFGEnv
-
-  let lincont    = [(Explicit, varStr, typeStr)]
-  b             <- convert opts gr (floc opath loc1 id) def (lincont,lincat) [pvar]
-  let (seqs1,b1) = addSequencesB seqs b
-      pmcfgEnv1  = foldBM addLindef
-                          pmcfgEnv0
-                          (goB b1 CNil [])
-                          (pcat,[pvar])
-
-  let lincont    = [(Explicit, varStr, lincat)]
-  b             <- convert opts gr (floc opath loc2 id) ref (lincont,typeStr) [pcat]
-  let (seqs2,b2) = addSequencesB seqs1 b
-      pmcfgEnv2  = foldBM addLinref
-                          pmcfgEnv1
-                          (goB b2 CNil [])
-                          (pvar,[pcat])
-
-  let pmcfg     = getPMCFG pmcfgEnv2
-
-  when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
-  seqs2 `seq` pmcfg `seq` return (seqs2,CncCat mty mdef mref mprn (Just pmcfg))
-  where
-    addLindef lins (newCat', newArgs') env0 =
-      let [newCat] = getFIds newCat'
-          !fun     = mkArray lins
-      in addFunction env0 newCat fun [[fidVar]]
-
-    addLinref lins (newCat', [newArg']) env0 =
-      let newArg   = getFIds newArg'
-          !fun     = mkArray lins
-      in addFunction env0 fidVar fun [newArg]
-
-addPMCFG opts gr opath am cm seqs id info = return (seqs, info)
-
-floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
-
-convert opts gr loc term ty@(_,val) pargs = error "TODO: convert"
-{-  case normalForm gr loc (etaExpand ty term) of
-    term    -> return $ runCnvMonad gr (convertTerm opts CNil val term) (pargs,[])-}
-  where
-    etaExpand (context,val) = mkAbs pars . flip mkApp args
-      where pars = [(Explicit,v) | v <- vars]
-            args = map Vr vars
-            vars = map (\(bt,x,t) -> x) context
-
-pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String])
-pgfCncCat gr id lincat index =
-  let ((_,size),schema) = computeCatRange gr lincat
-  in ( id
-     , index
-     , index+size-1
-     , map (renderStyle style{mode=OneLineMode} . ppPath)
-           (getStrPaths schema)
-     )
-  where
-    getStrPaths :: Schema Identity s c -> [Path]
-    getStrPaths = collect CNil []
-      where
-        collect path paths (CRec rs)   = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
-        collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel  trm path) paths t) paths cs
-        collect path paths (CStr _)    = reversePath path : paths
-        collect path paths (CPar _)    = paths
-
-----------------------------------------------------------------------
--- CnvMonad monad
---
--- The branching monad provides backtracking together with
--- recording of the choices made. We have two cases
--- when we have alternative choices:
---
---      * when we have parameter type, then
---        we have to try all possible values
---      * when we have variants we have to try all alternatives
---
--- The conversion monad keeps track of the choices and they are
--- returned as 'Branch' data type.
-
-data Branch a
-  = Case Int Path [(Term,Branch a)]
-  | Variant [Branch a]
-  | Return  a
-
-newtype CnvMonad a = CM {unCM :: SourceGrammar
-                              -> forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b)
-                              -> ([ProtoFCat],[Symbol])
-                              -> Branch b}
-
-instance Fail.MonadFail CnvMonad where
-  fail = bug
-
-instance Applicative CnvMonad where
-  pure = return
-  (<*>) = ap
-
-instance Monad CnvMonad where
-    return a   = CM (\gr c s -> c a s)
-    CM m >>= k = CM (\gr c s -> m gr (\a s -> unCM (k a) gr c s) s)
-
-instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where
-    get = CM (\gr c s -> c s s)
-    put s = CM (\gr c _ -> c () s)
-
-instance Functor CnvMonad where
-    fmap f (CM m) = CM (\gr c s -> m gr (c . f) s)
-
-runCnvMonad :: SourceGrammar -> CnvMonad a -> ([ProtoFCat],[Symbol]) -> Branch a
-runCnvMonad gr (CM m) s = m gr (\v s -> Return v) s
-
--- | backtracking for all variants
-variants :: [a] -> CnvMonad a
-variants xs = CM (\gr c s -> Variant [c x s | x <- xs])
-
--- | backtracking for all parameter values that a variable could take
-choices :: Int -> Path -> CnvMonad Term
-choices nr path = do (args,_) <- get
-                     let PFCat _ _ schema = args !! nr
-                     descend schema path CNil
-  where
-    descend (CRec rs)     (CProj lbl path) rpath = case lookup lbl rs of
-                                                     Just (Identity t) -> descend t path (CProj lbl rpath)
-    descend (CRec rs)     CNil             rpath = do rs <- mapM (\(lbl,Identity t) -> fmap (assign lbl) (descend t CNil (CProj lbl rpath))) rs
-                                                      return (R rs)
-    descend (CTbl pt cs)  (CSel  trm path) rpath = case lookup trm cs of
-                                                     Just (Identity t) -> descend t path (CSel trm rpath)
-    descend (CTbl pt cs)  CNil             rpath = do cs <- mapM (\(trm,Identity t) -> descend t CNil (CSel trm rpath)) cs
-                                                      return (V pt cs)
-    descend (CPar (m,vs)) CNil             rpath = case vs of
-                                                     [(value,index)] -> return value
-                                                     values          -> let path = reversePath rpath
-                                                                        in CM (\gr c s -> Case nr path [(value, updateEnv path value gr c s)
-                                                                                                                    | (value,index) <- values])
-    descend schema       path              rpath = bug $ "descend "++show (schema,path,rpath)
-
-    updateEnv path value gr c (args,seq) =
-      case updateNthM (restrictProtoFCat path value) nr args of
-        Just args -> c value (args,seq)
-        Nothing   -> bug "conflict in updateEnv"
-
--- | the argument should be a parameter type and then
--- the function returns all possible values.
-getAllParamValues :: Type -> CnvMonad [Term]
-getAllParamValues ty = CM (\gr c -> c (err bug id (allParamValues gr ty)))
-
-mkRecord :: [(Label,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
-mkRecord xs = CM (\gr c -> foldl (\c (lbl,CM m) bs s -> c ((lbl,m gr (\v s -> Return v) s) : bs) s) (c . CRec) xs [])
-
-mkTable  :: Type -> [(Term ,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
-mkTable pt xs = CM (\gr c -> foldl (\c (trm,CM m) bs s -> c ((trm,m gr (\v s -> Return v) s) : bs) s) (c . CTbl pt) xs [])
-
-----------------------------------------------------------------------
--- Term Schema
---
--- The term schema is a term-like structure, with records, tables,
--- strings and parameters values, but in addition we could add
--- annotations of arbitrary types
-
--- | Term schema
-data Schema b s c
-  = CRec      [(Label,b (Schema b s c))]
-  | CTbl Type [(Term, b (Schema b s c))]
-  | CStr s
-  | CPar c
---deriving Show -- doesn't work
-
-instance Show s => Show (Schema b s c) where
-  showsPrec _ sch =
-      case sch of
-        CRec r   -> showString "CRec " . shows (map fst r)
-        CTbl t _ -> showString "CTbl " . showsPrec 10 t . showString " _"
-        CStr s   -> showString "CStr " . showsPrec 10 s
-        CPar c   -> showString "CPar{}"
-
--- | Path into a term or term schema
-data Path
-  = CProj Label Path
-  | CSel  Term  Path
-  | CNil
-  deriving (Eq,Show)
-
--- | The ProtoFCat represents a linearization type as term schema.
--- The annotations are as follows: the strings are annotated with
--- their index in the PMCFG tuple, the parameters are annotated
--- with their value both as term and as index.
-data ProtoFCat  = PFCat Ident Int (Schema Identity Int (Int,[(Term,Int)]))
-type Env        = (ProtoFCat, [ProtoFCat])
-
-protoFCat :: SourceGrammar -> Cat -> Type -> ProtoFCat
-protoFCat gr cat lincat =
-  case computeCatRange gr lincat of
-    ((_,f),schema) -> PFCat (snd cat) f schema
-
-getFIds :: ProtoFCat -> [FId]
-getFIds (PFCat _ _ schema) =
-  reverse (solutions (variants schema) ())
-  where
-    variants (CRec rs)         = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
-    variants (CTbl _ cs)       = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
-    variants (CStr _)          = return 0
-    variants (CPar (m,values)) = do (value,index) <- member values
-                                    return (m*index)
-
-catFactor :: ProtoFCat -> Int
-catFactor (PFCat _ f _) = f
-
-computeCatRange gr lincat = compute (0,1) lincat
-  where
-    compute st (RecType  rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> case lbl of
-                                                                                LVar _ -> let (st',t') = compute st t
-                                                                                          in (st ,(lbl,Identity t'))
-                                                                                _      -> let (st',t') = compute st t
-                                                                                          in (st',(lbl,Identity t'))) st rs
-                               in (st',CRec rs')
-    compute st (Table pt vt) = let vs        = err bug id (allParamValues gr pt)
-                                   (st',cs') = List.mapAccumL (\st v       -> let (st',vt') = compute st vt
-                                                                              in (st',(v,Identity vt'))) st vs
-                               in (st',CTbl pt cs')
-    compute st (Sort s)
-                   | s == cStr = let (index,m) = st
-                                 in ((index+1,m),CStr index)
-    compute st t               = let vs = err bug id (allParamValues gr t)
-                                     (index,m) = st
-                                 in ((index,m*length vs),CPar (m,zip vs [0..]))
-
-ppPath (CProj lbl path) = lbl <+> ppPath path
-ppPath (CSel  trm path) = ppU 5 trm   <+> ppPath path
-ppPath CNil             = empty
-
-reversePath path = rev CNil path
-  where
-    rev path0 CNil             = path0
-    rev path0 (CProj lbl path) = rev (CProj lbl path0) path
-    rev path0 (CSel  trm path) = rev (CSel  trm path0) path
-
-
-----------------------------------------------------------------------
--- term conversion
-
-type Value a = Schema Branch a Term
-
-convertTerm :: Options -> Path -> Type -> Term -> CnvMonad (Value [Symbol])
-convertTerm opts sel ctype (Vr x)       = convertArg opts ctype (getVarIndex x) (reversePath sel)
-convertTerm opts sel ctype (Abs _ _ t)  = convertTerm opts sel ctype t                -- there are only top-level abstractions and we ignore them !!!
-convertTerm opts sel ctype (R record)   = convertRec opts sel ctype record
-convertTerm opts sel ctype (P term l)   = convertTerm opts (CProj l sel) ctype term
-convertTerm opts sel ctype (V pt ts)    = convertTbl opts sel ctype pt ts
-convertTerm opts sel ctype (S term p)   = do v <- evalTerm CNil p
-                                             convertTerm opts (CSel v sel) ctype term
-convertTerm opts sel ctype (FV vars)    = do term <- variants vars
-                                             convertTerm opts sel ctype term
-convertTerm opts sel ctype (C t1 t2)    = do v1 <- convertTerm opts sel ctype t1
-                                             v2 <- convertTerm opts sel ctype t2
-                                             return (CStr (concat [s | CStr s <- [v1,v2]]))
-convertTerm opts sel ctype (K t)        = return (CStr [SymKS t])
-convertTerm opts sel ctype Empty        = return (CStr [])
-convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil ctype s
-                                             alts <- forM alts $ \(u,alt) -> do
-                                                            CStr u <- convertTerm opts CNil ctype u
-                                                            Strs ps <- unPatt alt
-                                                            ps     <- mapM (convertTerm opts CNil ctype) ps
-                                                            return (u,map unSym ps)
-                                             return (CStr [SymKP s alts])
-  where
-    unSym (CStr [])        = ""
-    unSym (CStr [SymKS t]) = t
-    unSym _                = ppbug $ hang ("invalid prefix in pre expression:") 4 (Alts s alts)
-
-    unPatt (EPatt _ _ p) = fmap Strs (getPatts p)
-    unPatt u             = return u
-
-    getPatts p = case p of
-      PAlt a b  -> liftM2 (++) (getPatts a) (getPatts b)
-      PString s -> return [K s]
-      PSeq _ _ a _ _ b  -> do
-        as <- getPatts a
-        bs <- getPatts b
-        return [K (s ++ t) | K s <- as, K t <- bs]
-      _ -> fail (render ("not valid pattern in pre expression" <+> ppPatt Unqualified 0 p))
-
-convertTerm opts sel ctype (Q (m,f))
-  | m == cPredef &&
-    f == cBIND                          = return (CStr [SymBIND])
-  | m == cPredef &&
-    f == cSOFT_BIND                     = return (CStr [SymSOFT_BIND])
-  | m == cPredef &&
-    f == cSOFT_SPACE                    = return (CStr [SymSOFT_SPACE])
-  | m == cPredef &&
-    f == cCAPIT                         = return (CStr [SymCAPIT])
-  | m == cPredef &&
-    f == cALL_CAPIT                     = return (CStr [SymALL_CAPIT])
-  | m == cPredef &&
-    f == cNonExist                      = return (CStr [SymNE])
-{-
-convertTerm opts sel@(CProj l _) ctype (ExtR t1 t2@(R rs2))
-                    | l `elem` map fst rs2 = convertTerm opts sel ctype t2
-                    | otherwise            = convertTerm opts sel ctype t1
-
-convertTerm opts sel@(CProj l _) ctype (ExtR t1@(R rs1) t2)
-                    | l `elem` map fst rs1 = convertTerm opts sel ctype t1
-                    | otherwise            = convertTerm opts sel ctype t2
--}
-convertTerm opts CNil ctype t           = do v <- evalTerm CNil t
-                                             return (CPar v)
-convertTerm _    sel  _     t           = ppbug ("convertTerm" <+> sep [parens (show sel),ppU 10 t])
-
-convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
-convertArg opts (RecType rs)  nr path =
-  mkRecord (map (\(lbl,ctype) -> (lbl,convertArg opts ctype nr (CProj lbl path))) rs)
-convertArg opts (Table pt vt) nr path = do
-  vs <- getAllParamValues pt
-  mkTable pt (map (\v -> (v,convertArg opts vt nr (CSel v path))) vs)
-convertArg opts (Sort _)      nr path = do
-  (args,_) <- get
-  let PFCat cat _ schema = args !! nr
-      l = index (reversePath path) schema
-      sym | CProj (LVar i) CNil <- path = SymVar nr i
-          | isLiteralCat opts cat       = SymLit nr l
-          | otherwise                   = SymCat nr l
-  return (CStr [sym])
-  where
-    index (CProj lbl path) (CRec   rs) = case lookup lbl rs of
-                                           Just (Identity t) -> index path t
-    index (CSel  trm path) (CTbl _ rs) = case lookup trm rs of
-                                           Just (Identity t) -> index path t
-    index CNil             (CStr idx)  = idx
-convertArg opts ty nr path              = do
-  value <- choices nr (reversePath path)
-  return (CPar value)
-
-convertRec opts CNil (RecType rs) record =
-    mkRecord [(lbl,convertTerm opts CNil ctype (proj lbl))|(lbl,ctype)<-rs]
-  where proj lbl = if isLockLabel lbl then R [] else projectRec lbl record
-convertRec opts (CProj lbl path) ctype record =
-  convertTerm opts path ctype (projectRec lbl record)
-convertRec opts _ ctype _ = bug ("convertRec: "++show ctype)
-
-convertTbl opts CNil (Table _ vt) pt ts = do
-  vs <- getAllParamValues pt
-  mkTable pt (zipWith (\v t -> (v,convertTerm opts CNil vt t)) vs ts)
-convertTbl opts (CSel v sub_sel) ctype pt ts = do
-  vs <- getAllParamValues pt
-  case lookup v (zip vs ts) of
-    Just t  -> convertTerm opts sub_sel ctype t
-    Nothing -> ppbug ( "convertTbl:" <+> ("missing value" <+> v $$
-                                          "among" <+> vcat vs))
-convertTbl opts _ ctype _ _ = bug ("convertTbl: "++show ctype)
-
-
-goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId]
-goB (Case nr path bs) rpath ss = do (value,b) <- member bs
-                                    restrictArg nr path value
-                                    goB b rpath ss
-goB (Variant bs)      rpath ss = do b <- member bs
-                                    goB b rpath ss
-goB (Return  v)       rpath ss = goV v rpath ss
-
-goV :: Value SeqId -> Path -> [SeqId] -> BacktrackM Env [SeqId]
-goV (CRec xs)    rpath ss = foldM (\ss (lbl,b) -> goB b (CProj lbl rpath) ss) ss (reverse xs)
-goV (CTbl _ xs)  rpath ss = foldM (\ss (trm,b) -> goB b (CSel  trm rpath) ss) ss (reverse xs)
-goV (CStr seqid) rpath ss = return (seqid : ss)
-goV (CPar t)     rpath ss = restrictHead (reversePath rpath) t >> return ss
-
-
-----------------------------------------------------------------------
--- SeqSet
-
-type SeqSet   = Map.Map [Symbol] SeqId
-
-addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
-addSequencesB seqs (Case nr path bs) = let !(seqs1,bs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b
-                                                                                       in (seqs',(trm,b'))) seqs bs
-                                       in (seqs1,Case nr path bs1)
-addSequencesB seqs (Variant bs)      = let !(seqs1,bs1) = mapAccumL' addSequencesB seqs bs
-                                       in (seqs1,Variant bs1)
-addSequencesB seqs (Return  v)       = let !(seqs1,v1) = addSequencesV seqs v
-                                       in (seqs1,Return v1)
-
-addSequencesV :: SeqSet -> Value [Symbol] -> (SeqSet, Value SeqId)
-addSequencesV seqs (CRec vs)  = let !(seqs1,vs1) = mapAccumL' (\seqs (lbl,b) -> let !(seqs',b') = addSequencesB seqs b
-                                                                                in (seqs',(lbl,b'))) seqs vs
-                                in (seqs1,CRec vs1)
-addSequencesV seqs (CTbl pt vs)=let !(seqs1,vs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b
-                                                                                in (seqs',(trm,b'))) seqs vs
-                                in (seqs1,CTbl pt vs1)
-addSequencesV seqs (CStr lin) = let !(seqs1,seqid) = addSequence seqs lin
-                                in (seqs1,CStr seqid)
-addSequencesV seqs (CPar i)   = (seqs,CPar i)
-
--- a strict version of Data.List.mapAccumL
-mapAccumL' f s []     = (s,[])
-mapAccumL' f s (x:xs) = (s'',y:ys)
-                        where !(s', y ) = f s x
-                              !(s'',ys) = mapAccumL' f s' xs
-
-addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
-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)
-
-
-------------------------------------------------------------
--- eval a term to ground terms
-
-evalTerm :: Path -> Term -> CnvMonad Term
-evalTerm CNil (QC f)       = return (QC f)
-evalTerm CNil (App x y)    = do x <- evalTerm CNil x
-                                y <- evalTerm CNil y
-                                return (App x y)
-evalTerm path (Vr x)       = choices (getVarIndex x) path
-evalTerm path (R rs)       =
-    case path of
-      CProj lbl path -> evalTerm path (projectRec lbl rs)
-      CNil           -> R `fmap` mapM (\(lbl,(_,t)) -> assign lbl `fmap` evalTerm path t) rs
-evalTerm path (P term lbl) = evalTerm (CProj lbl path) term
-evalTerm path (V pt ts)    =
-   case path of
-     CNil          -> V pt `fmap` mapM (evalTerm path) ts
-     CSel trm path ->
-         do vs <- getAllParamValues pt
-            case lookup trm (zip vs ts) of
-              Just t  -> evalTerm path t
-              Nothing -> ppbug $ "evalTerm: missing value:"<+>trm
-                                 $$ "among:" <+>fsep (map (ppU 10) vs)
-evalTerm path (S term sel) = do v <- evalTerm CNil sel
-                                evalTerm (CSel v path) term
-evalTerm path (FV terms)   = variants terms >>= evalTerm path
-evalTerm path (EInt n)     = return (EInt n)
-evalTerm path t            = ppbug ("evalTerm" <+> parens t)
---evalTerm path t            = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))])
-
-getVarIndex x = maybe err id $ getArgIndex x
-  where err = bug ("getVarIndex "++show x)
-
-----------------------------------------------------------------------
--- GrammarEnv
-
-data PMCFGEnv = PMCFGEnv !ProdSet !FunSet
-type ProdSet  = Set.Set Production
-type FunSet   = Map.Map (UArray LIndex SeqId) FunId
-
-emptyPMCFGEnv =
-  PMCFGEnv Set.empty Map.empty
-
-addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> [[FId]] -> PMCFGEnv
-addFunction (PMCFGEnv prodSet funSet) !fid fun args =
-  case Map.lookup fun funSet of
-    Just !funid -> PMCFGEnv (Set.insert (Production fid funid args) prodSet)
-                            funSet
-    Nothing     -> let !funid = Map.size funSet
-                   in PMCFGEnv (Set.insert (Production fid funid args) prodSet)
-                               (Map.insert fun funid funSet)
-
-getPMCFG :: PMCFGEnv -> PMCFG
-getPMCFG (PMCFGEnv prodSet funSet) =
-  PMCFG (optimize prodSet) (mkSetArray funSet)
-  where
-    optimize ps = Map.foldrWithKey ff [] (Map.fromListWith (++) [((fid,funid),[args]) | (Production fid funid args) <- Set.toList ps])
-      where
-        ff :: (FId,FunId) -> [[[FId]]] -> [Production] -> [Production]
-        ff (fid,funid) xs prods
-          | product (map IntSet.size ys) == count
-                      = (Production fid funid (map IntSet.toList ys)) : prods
-          | otherwise = map (Production fid funid) xs ++ prods
-          where
-            count = sum (map (product . map length) xs)
-            ys    = foldl (zipWith (foldr IntSet.insert)) (repeat IntSet.empty) xs
-
-------------------------------------------------------------
--- updating the MCF rule
-
-restrictArg :: LIndex -> Path -> Term -> BacktrackM Env ()
-restrictArg nr path index = do
-  (head, args) <- get
-  args <- updateNthM (restrictProtoFCat path index) nr args
-  put (head, args)
-
-restrictHead :: Path -> Term -> BacktrackM Env ()
-restrictHead path term = do
-  (head, args) <- get
-  head <- restrictProtoFCat path term head
-  put (head, args)
-
-restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat
-restrictProtoFCat path v (PFCat cat f schema) = do
-  schema <- addConstraint path v schema
-  return (PFCat cat f schema)
-  where
-    addConstraint (CProj lbl path) v (CRec rs)     = fmap CRec      $ update lbl (addConstraint path v) rs
-    addConstraint (CSel  trm path) v (CTbl pt cs)  = fmap (CTbl pt) $ update trm (addConstraint path v) cs
-    addConstraint CNil             v (CPar (m,vs)) = case lookup v vs of
-                                                       Just index -> return (CPar (m,[(v,index)]))
-                                                       Nothing    -> mzero
-    addConstraint CNil             v (CStr _)      = bug "restrictProtoFCat: string path"
-
-    update k0 f [] = return []
-    update k0 f (x@(k,Identity v):xs)
-      | k0 == k    = do v <- f v
-                        return ((k,Identity v):xs)
-      | otherwise  = do xs <- update k0 f xs
-                        return (x:xs)
-
-mkArray    lst = listArray (0,length lst-1) lst
-mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
-
-bug msg = ppbug msg
-ppbug msg = error completeMsg
- where
-  originalMsg = render $ hang "Internal error in GeneratePMCFG:" 4 msg
-  completeMsg =
-    case render msg of -- the error message for pattern matching a runtime string
-      "descend (CStr 0,CNil,CProj (LIdent (Id {rawId2utf8 = \"s\"})) CNil)"
-        -> unlines [originalMsg -- add more helpful output
-            ,""
-            ,"1) Check that you are not trying to pattern match a /runtime string/."
-            ,"   These are illegal:"
-            ,"     lin Test foo = case foo.s of {"
-            ,"                       \"str\" => … } ;   <- explicit matching argument of a lin"
-            ,"     lin Test foo = opThatMatches foo   <- calling an oper that pattern matches"
-            ,""
-            ,"2) Not about pattern matching? Submit a bug report and we update the error message."
-            ,"     https://github.com/GrammaticalFramework/gf-core/issues"
-            ]
-      _ -> originalMsg -- any other message: just print it as is
-
-ppU = ppTerm Unqualified
+    collectFields lins []             = do
+      return (lins,[])
+    collectFields lins ((lbl,tnk):as) = do
+      v <- force tnk []
+      (lins,v) <- value2pmcfg v lins
+      case v of
+        VR [] -> collectFields lins as
+        _     -> do (lins,as) <- collectFields lins as
+                    tnk <- newEvaluatedThunk v
+                    return (lins,(lbl,tnk):as)
+value2pmcfg v lins = do
+  lin <- value2lin v
+  return (lin:lins,VR [])
+
+value2lin (VStr s) =
+  return [SymKS s]
+value2lin (VC vs) =
+  fmap concat (mapM value2lin vs)
+value2lin (VSymCat d r) =
+  return [SymCat d r]
+
+
+mapAccumM f a []     = return (a,[])
+mapAccumM f a (x:xs) = do (a, y) <- f a x
+                          (a,ys) <- mapAccumM f a xs
+                          return (a,y:ys)
+
+pgfCncCat = error "TODO: pgfCncCat"

src/compiler/GF/Compile/Optimize.hs

@@ -1,237 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------
--- |
--- Module      : Optimize
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/16 13:56:13 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.18 $
---
--- Top-level partial evaluation for GF source modules.
------------------------------------------------------------------------------
-
-module GF.Compile.Optimize (optimizeModule) where
-
-import GF.Infra.Ident
-import GF.Infra.CheckM
-import GF.Infra.Option
-import GF.Grammar.Grammar
-import GF.Grammar.Printer
-import GF.Grammar.Macros
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Compile.Compute.Concrete(normalForm)
-import GF.Data.Operations
-
-import Control.Monad
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import GF.Text.Pretty
-import Debug.Trace
-
--- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
-
-optimizeModule :: Options -> SourceGrammar -> SourceModule -> Check SourceModule
-optimizeModule opts sgr m@(name,mi)
-  | mstatus mi == MSComplete = do
-      ids <- topoSortJments m
-      mi <- foldM updateEvalInfo mi ids
-      return (name,mi)
-  | otherwise = return m
- where
-   oopts = opts `addOptions` mflags mi
-
-   updateEvalInfo mi (i,info) = do
-     info <- evalInfo oopts sgr (name,mi) i info
-     return (mi{jments=Map.insert i info (jments mi)})
-
-evalInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
-evalInfo opts sgr m c info = do
-
- (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return ()
-
- errIn ("optimizing " ++ showIdent c) $ case info of
-
-  CncCat ptyp pde pre ppr mpmcfg -> do
-    pde' <- case (ptyp,pde) of
-      (Just (L _ typ), Just (L loc de)) -> do
-        de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
-        return (Just (L loc (factor param c 0 de)))
-      (Just (L loc typ), Nothing) -> do
-        de <- mkLinDefault gr typ
-        de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
-        return (Just (L loc (factor param c 0 de)))
-      _ -> return pde   -- indirection
-
-    pre' <- case (ptyp,pre) of
-      (Just (L _ typ), Just (L loc re)) -> do
-        re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
-        return (Just (L loc (factor param c 0 re)))
-      (Just (L loc typ), Nothing) -> do
-        re <- mkLinReference gr typ
-        re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
-        return (Just (L loc (factor param c 0 re)))
-      _ -> return pre   -- indirection
-
-    ppr' <- case ppr of
-              Just pr -> fmap Just (evalPrintname sgr c pr)
-              Nothing -> return ppr
-
-    return (CncCat ptyp pde' pre' ppr' mpmcfg)
-
-  CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
-       eIn ("linearization in type" <+> mkProd cont val [] $$ "of function") $ do
-    pde' <- case pde of
-      Just (L loc de) -> do de <- partEval opts gr (cont,val) de
-                            return (Just (L loc (factor param c 0 de)))
-      Nothing -> return pde
-    ppr' <- case ppr of
-              Just pr -> fmap Just (evalPrintname sgr c pr)
-              Nothing -> return ppr
-    return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
-{-
-  ResOper pty pde
-    | not new && OptExpand `Set.member` optim -> do
-         pde' <- case pde of
-                   Just (L loc de) -> do de <- computeConcrete gr de
-                                         return (Just (L loc (factor param c 0 de)))
-                   Nothing -> return Nothing
-         return $ ResOper pty pde'
--}
-  _ ->  return info
- where
--- new = flag optNewComp opts -- computations moved to GF.Compile.GeneratePMCFG
-
-   gr = prependModule sgr m
-   optim = flag optOptimizations opts
-   param = OptParametrize `Set.member` optim
-   eIn cat = errIn (render ("Error optimizing" <+> cat <+> c <+> ':'))
-
--- | the main function for compiling linearizations
-partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Check Term
-partEval opts = error "TODO: partEval"
-                {-if flag optNewComp opts
-                then partEvalNew opts-}
-                {-else partEvalOld opts-}
-{-
-partEvalNew opts gr (context, val) trm =
-    errIn (render ("partial evaluation" <+> ppTerm Qualified 0 trm)) $
-    checkPredefError trm
-
-partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do
-  let vars  = map (\(bt,x,t) -> x) context
-      args  = map Vr vars
-      subst = [(v, Vr v) | v <- vars]
-      trm1 = mkApp trm args
-  trm2 <- computeTerm gr subst trm1
-  trm3 <- if rightType trm2
-          then computeTerm gr subst trm2 -- compute twice??
-          else recordExpand val trm2 >>= computeTerm gr subst
-  trm4 <- checkPredefError trm3
-  return $ mkAbs [(Explicit,v) | v <- vars] trm4
-  where
-    -- don't eta expand records of right length (correct by type checking)
-    rightType (R rs) = case val of
-                         RecType ts -> length rs == length ts
-                         _          -> False
-    rightType _      = False
-
-
--- here we must be careful not to reduce
---   variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
---   {s  = variants {"Auto" ; "Wagen"} ; g  = variants {N ; M}} ;
-
-recordExpand :: Type -> Term -> Err Term
-recordExpand typ trm = case typ of
-  RecType tys -> case trm of
-    FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
-    _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
-  _ -> return trm
-
--}
--- | auxiliaries for compiling the resource
-
-mkLinDefault :: SourceGrammar -> Type -> Check Term
-mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
- where
-   mkDefField typ = case typ of
-     Table p t  -> do
-       t' <- mkDefField t
-       let T _ cs = mkWildCases t'
-       return $ T (TWild p) cs
-     Sort s | s == cStr -> return $ Vr varStr
-     QC p           -> do case lookupParamValues gr p of
-                            Ok (v:_) -> return v
-                            _   -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p)
-     RecType r  -> do
-       let (ls,ts) = unzip r
-       ts <- mapM mkDefField ts
-       return $ R (zipWith assign ls ts)
-     _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
-     _ -> checkError ("linearization type field cannot be" <+> typ)
-
-mkLinReference :: SourceGrammar -> Type -> Check Term
-mkLinReference gr typ =
- liftM (Abs Explicit varStr) $
-   case mkDefField typ (Vr varStr) of
-     Bad "no string" -> return Empty
-     Ok x            -> return x
- where
-   mkDefField ty trm =
-     case ty of
-       Table pty ty -> do ps <- allParamValues gr pty
-                          case ps of
-                            []     -> Bad "no string"
-                            (p:ps) -> mkDefField ty (S trm p)
-       Sort s | s == cStr -> return trm
-       QC p       -> Bad "no string"
-       RecType [] -> Bad "no string"
-       RecType rs -> do
-         msum (map (\(l,ty) -> mkDefField ty (P trm l)) (sortRec rs))
-           `mplus` Bad "no string"
-       _ | Just _ <- isTypeInts typ -> Bad "no string"
-       _ -> Bad (render ("linearization type field cannot be" <+> typ))
-
-evalPrintname :: Grammar -> Ident -> L Term -> Check (L Term)
-evalPrintname gr c (L loc pr) = do
-  pr <- normalForm gr (L loc c) pr
-  return (L loc pr)
-
--- do even more: factor parametric branches
-
-factor :: Bool -> Ident -> Int -> Term -> Term
-factor param c i t =
-  case t of
-    T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs]
-    _               -> composSafeOp (factor param c i) t
-  where
-    factors ty pvs0
-                 | not param = V ty (map snd pvs0)
-    factors ty []            = V ty []
-    factors ty pvs0@[(p,v)]  = V ty [v]
-    factors ty pvs0@(pv:pvs) =
-      let t  = mkFun pv
-          ts = map mkFun pvs
-      in if all (==t) ts
-           then T (TTyped ty) (mkCases t)
-           else V ty (map snd pvs0)
-
-    --- we hope this will be fresh and don't check... in GFC would be safe
-    qvar = identS ("q_" ++ showIdent c ++ "__" ++ show i)
-
-    mkFun (patt, val) = replace (patt2term patt) (Vr qvar) val
-    mkCases t = [(PV qvar, t)]
-
---  we need to replace subterms
-replace :: Term -> Term -> Term -> Term
-replace old new trm =
-  case trm of
-    -- these are the important cases, since they can correspond to patterns
-    QC _     | trm == old -> new
-    App _ _  | trm == old -> new
-    R _      | trm == old -> new
-    App x y               -> App (replace old new x) (replace old new y)
-    _                     -> composSafeOp (replace old new) trm

src/compiler/GF/Compile/OptimizePGF.hs

@@ -2,7 +2,7 @@
 module GF.Compile.OptimizePGF(optimizePGF) where
 
 import PGF2(Cat,Fun)
-import PGF2.Internal
+import PGF2.Transactions
 import Data.Array.ST
 import Data.Array.Unboxed
 import qualified Data.Map as Map
@@ -12,13 +12,14 @@ import qualified Data.IntMap as IntMap
 import qualified Data.List as List
 import Control.Monad.ST
 
-type ConcrData = ([(FId,[FunId])],          -- ^ Lindefs
+type ConcrData = ()
+{-([(FId,[FunId])],          -- ^ Lindefs
                   [(FId,[FunId])],          -- ^ Linrefs
                   [(FId,[Production])],     -- ^ Productions
                   [(Fun,[SeqId])],          -- ^ Concrete functions   (must be sorted by Fun)
                   [[Symbol]],               -- ^ Sequences            (must be sorted)
                   [(Cat,FId,FId,[String])]) -- ^ Concrete categories
-
+-}
 optimizePGF :: Cat -> ConcrData -> ConcrData
 optimizePGF startCat = error "TODO: optimizePGF" {- topDownFilter startCat . bottomUpFilter
 

src/compiler/GF/Compile/Update.hs

@@ -78,7 +78,7 @@ extendModule cwd gr (name,m)
 -- | rebuilding instance + interface, and "with" modules, prior to renaming.
 -- AR 24/10/2003
 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
-rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
+rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) =
   checkInModule cwd mi NoLoc empty $ do
 
 ----  deps <- moduleDeps ms
@@ -115,7 +115,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
                     else MSIncomplete
       unless (stat' == MSComplete || stat == MSIncomplete)
              (checkError ("module" <+> i <+> "remains incomplete"))
-      ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
+      ModInfo mt0 _ fs me' _ ops0 _ fpath js <- lookupModule gr ext
       let ops1 = nub $
                    ops_ ++ -- N.B. js has been name-resolved already
                    [OQualif i j | (i,j) <- ops] ++
@@ -131,7 +131,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
                                     js
       let js1 = Map.union js0 js_
       let med1= nub (ext : infs ++ insts ++ med_)
-      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ env_ js1
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ js1
 
   return (i,mi')
 

src/compiler/GF/CompileOne.hs

@@ -8,7 +8,6 @@ module GF.CompileOne(-- ** Compiling a single module
 import GF.Compile.GetGrammar(getSourceModule)
 import GF.Compile.Rename(renameModule)
 import GF.Compile.CheckGrammar(checkModule)
-import GF.Compile.Optimize(optimizeModule)
 import GF.Compile.SubExOpt(subexpModule,unsubexpModule)
 import GF.Compile.GeneratePMCFG(generatePMCFG)
 import GF.Compile.Update(extendModule,rebuildModule)
@@ -107,10 +106,9 @@ compileSourceModule opts cwd mb_gfFile gr =
 
     -- Apply to complete modules when not generating tags
     backend mo3 =
-      do mo4 <- runPass Optimize "optimizing" $ optimizeModule opts gr mo3
-         if isModCnc (snd mo4) && flag optPMCFG opts
-          then runPassI "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
-          else runPassI "" $ return mo4
+      do if isModCnc (snd mo3) && flag optPMCFG opts
+          then runPassI "generating PMCFG" $ fmap fst $ runCheck' opts (generatePMCFG opts gr mo3)
+          else runPassI "" $ return mo3
 
     ifComplete yes mo@(_,mi) =
       if isCompleteModule mi then yes mo else return mo

src/compiler/GF/Grammar/Binary.hs

@@ -23,10 +23,10 @@ import GF.Infra.UseIO(MonadIO(..))
 import GF.Grammar.Grammar
 
 import PGF2(Literal(..))
-import PGF2.Internal(Symbol(..))
+import PGF2.Transactions(Symbol(..))
 
 -- Please change this every time when the GFO format is changed
-gfoVersion = "GF04"
+gfoVersion = "GF05"
 
 instance Binary Ident where
   put id = put (ident2utf8 id)
@@ -44,9 +44,9 @@ instance Binary Grammar where
   get = fmap mGrammar get
 
 instance Binary ModuleInfo where
-  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)
-  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
-              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
+  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)
+  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,jments) <- get
+              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments)
 
 instance Binary ModuleType where
   put MTAbstract       = putWord8 0
@@ -103,18 +103,9 @@ instance Binary Options where
              toString (LInt n) = show n
              toString (LFlt d) = show d
 
-instance Binary Production where
-  put (Production res funid args) = put (res,funid,args)
-  get = do res   <- get
-           funid <- get
-           args  <- get
-           return (Production res funid args)
-
 instance Binary PMCFG where
-  put (PMCFG prods funs) = put (prods,funs)
-  get = do prods <- get
-           funs  <- get
-           return (PMCFG prods funs)
+  put (PMCFG lins) = put lins
+  get = fmap PMCFG get
 
 instance Binary Info where
   put (AbsCat x)       = putWord8 0 >> put x
@@ -377,7 +368,7 @@ decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module)
 decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile'
   where
     conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) =
-        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)
+        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Map.empty)
 
 encodeModule :: MonadIO io => FilePath -> SourceModule -> io ()
 encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo)

src/compiler/GF/Grammar/CFG.hs

@@ -8,7 +8,7 @@ module GF.Grammar.CFG(Cat,Token, module GF.Grammar.CFG) where
 
 import GF.Data.Utilities
 import PGF2(Fun,Cat)
-import PGF2.Internal(Token)
+import PGF2.Transactions(Token)
 import GF.Data.Relation
 
 import Data.Map (Map)

src/compiler/GF/Grammar/Grammar.hs

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
         Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
-        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex
+        PMCFG(..)
         ) where
 
 import GF.Infra.Ident
@@ -74,7 +74,7 @@ import GF.Infra.Location
 import GF.Data.Operations
 
 import PGF2(BindType(..))
-import PGF2.Internal(FId, FunId, SeqId, LIndex, Symbol)
+import PGF2.Transactions(Symbol)
 
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
@@ -100,7 +100,6 @@ data ModuleInfo = ModInfo {
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
-    mseqs   :: Maybe (Array SeqId [Symbol]),
     jments  :: Map.Map Ident Info
   }
 
@@ -305,13 +304,7 @@ allConcreteModules gr =
   [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
 
 
-data Production = Production {-# UNPACK #-} !FId
-                             {-# UNPACK #-} !FunId
-                             [[FId]]
-                  deriving (Eq,Ord,Show)
-
-data PMCFG = PMCFG [Production]
-                   (Array FunId (UArray LIndex SeqId)) 
+data PMCFG = PMCFG [[[Symbol]]]
              deriving (Eq,Show)
 
 -- | the constructors are judgements in 

src/compiler/GF/Grammar/Parser.y

@@ -132,14 +132,14 @@ ModDef
                                           (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
                                       jments <- mapM (checkInfoType mtype) jments
                                       defs <- buildAnyTree id jments
-                                      return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs)  }
+                                      return (id, ModInfo mtype mstat opts extends with opens [] "" defs)  }
 
 ModHeader :: { SourceModule }
 ModHeader
   : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
                                                (mtype,id) = $2 ;
                                                (extends,with,opens) = $4 }
-                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Map.empty) }
 
 ComplMod :: { ModuleStatus }
 ComplMod 

src/compiler/GF/Grammar/Printer.hs

@@ -25,7 +25,7 @@ module GF.Grammar.Printer
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import PGF2 as PGF2
-import PGF2.Internal as PGF2
+import PGF2.Transactions as PGF2
 import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Grammar.Values
@@ -46,11 +46,10 @@ instance Pretty Grammar where
   pp = vcat . map (ppModule Qualified) . modules
 
 ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =
     hdr $$
     nest 2 (ppOptions opts $$
-            vcat (map (ppJudgement q) (Map.toList jments)) $$
-            maybe empty (ppSequences q) mseqs) $$
+            vcat (map (ppJudgement q) (Map.toList jments))) $$
     ftr
     where
       hdr = complModDoc <+> modTypeDoc <+> '=' <+>
@@ -136,13 +135,9 @@ ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
      Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
      Nothing        -> empty) $$
   (case (mpmcfg,q) of
-     (Just (PMCFG prods funs),Internal)
+     (Just (PMCFG lins),Internal)
                     -> "pmcfg" <+> id <+> '=' <+> '{' $$
-                       nest 2 (vcat (map ppProduction prods) $$
-                               ' ' $$
-                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
-                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
-                                         (Array.assocs funs))) $$
+                       nest 2 (vcat (map ppPmcfgLin lins)) $$
                        '}'
      _              -> empty)
 ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
@@ -154,13 +149,9 @@ ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
      Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
      Nothing        -> empty) $$
   (case (mpmcfg,q) of
-     (Just (PMCFG prods funs),Internal)
+     (Just (PMCFG lins),Internal)
                     -> "pmcfg" <+> id <+> '=' <+> '{' $$
-                       nest 2 (vcat (map ppProduction prods) $$
-                               ' ' $$
-                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
-                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
-                                         (Array.assocs funs))) $$
+                       nest 2 (vcat (map ppPmcfgLin lins)) $$
                        '}'
      _              -> empty)
 ppJudgement q (id, AnyInd cann mid) =
@@ -168,6 +159,9 @@ ppJudgement q (id, AnyInd cann mid) =
     Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
     _        -> empty
 
+ppPmcfgLin lin =
+  brackets (vcat (map (hsep . map ppSymbol) lin))
+
 instance Pretty Term where pp = ppTerm Unqualified 0
 
 ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
@@ -330,18 +324,6 @@ ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
 ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
 ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
 
-ppProduction (Production fid funid args) =
-  ppFId fid <+> "->" <+> ppFunId funid <>
-  brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
-
-ppSequences q seqsArr
-  | null seqs || q /= Internal = empty
-  | otherwise                  = "sequences" <+> '{' $$
-                                 nest 2 (vcat (map ppSeq seqs)) $$
-                                 '}'
-  where
-    seqs = Array.assocs seqsArr
-
 commaPunct f ds = (hcat (punctuate "," (map f ds)))
 
 prec d1 d2 doc
@@ -365,17 +347,6 @@ getLet (Let l e) = let (ls,e') = getLet e
                    in (l:ls,e')
 getLet e         = ([],e)
 
-ppFunId funid = pp 'F' <> pp funid
-ppSeqId seqid = pp 'S' <> pp seqid
-
-ppFId fid
-  | fid == PGF2.fidString = pp "CString"
-  | fid == PGF2.fidInt    = pp "CInt"
-  | fid == PGF2.fidFloat  = pp "CFloat"
-  | fid == PGF2.fidVar    = pp "CVar"
-  | fid == PGF2.fidStart  = pp "CStart"
-  | otherwise             = pp 'C' <> pp fid
-
 ppMeta :: Int -> Doc
 ppMeta n
   | n == 0    = pp '?'
@@ -385,9 +356,6 @@ ppLit (PGF2.LStr s) = pp (show s)
 ppLit (PGF2.LInt n) = pp n
 ppLit (PGF2.LFlt d) = pp d
 
-ppSeq (seqid,seq) = 
-  ppSeqId seqid <+> pp ":=" <+> hsep (map ppSymbol seq)
-
 ppSymbol (PGF2.SymCat d r) = pp '<' <> pp d <> pp ',' <> pp r <> pp '>'
 ppSymbol (PGF2.SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
 ppSymbol (PGF2.SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'

src/runtime/haskell/PGF2/Internal.hsc

@@ -7,38 +7,13 @@ module PGF2.Internal(-- * Access the internal structures
                      -- * Byte code
                      CodeLabel, Instr(..), IVal(..), TailInfo(..),
 
-                     SeqId,LIndex,
-                     FunId,Token,Production(..),PArg(..),Symbol(..),
-
                      unionPGF, writeConcr
                     ) where
 
 import PGF2.FFI
 import PGF2.Expr
 
-type Token  = String
-type LIndex = Int
-data Symbol
-  = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
-  | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
-  | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
-  | SymKS Token
-  | SymKP [Symbol] [([Symbol],[String])]
-  | SymBIND                         -- the special BIND token
-  | SymNE                           -- non exist
-  | SymSOFT_BIND                    -- the special SOFT_BIND token
-  | SymSOFT_SPACE                   -- the special SOFT_SPACE token
-  | SymCAPIT                        -- the special CAPIT token
-  | SymALL_CAPIT                    -- the special ALL_CAPIT token
-  deriving (Eq,Ord,Show)
-data Production
-  = PApply  {-# UNPACK #-} !FunId [PArg]
-  | PCoerce {-# UNPACK #-} !FId
-  deriving (Eq,Ord,Show)
-type FunId = Int
-type SeqId = Int
 type FId = Int
-data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
 
 fidString, fidInt, fidFloat, fidVar, fidStart :: FId
 fidString = (-1)

src/runtime/haskell/PGF2/Transactions.hsc

@@ -1,5 +1,7 @@
 module PGF2.Transactions
           ( Transaction
+
+            -- abstract syntax
           , modifyPGF
           , branchPGF
           , checkoutPGF
@@ -9,6 +11,9 @@ module PGF2.Transactions
           , dropCategory
           , setGlobalFlag
           , setAbstractFlag
+
+            -- concrete syntax
+          , Token, LIndex, Symbol(..)
           ) where
 
 import PGF2.FFI
@@ -144,3 +149,20 @@ setAbstractFlag name value = Transaction $ \c_db c_revision c_exn ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
   withForeignPtr marshaller $ \m ->
     pgf_set_abstract_flag c_db c_revision c_name c_value m c_exn
+
+
+type Token  = String
+type LIndex = Int
+data Symbol
+  = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
+  | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
+  | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
+  | SymKS Token
+  | SymKP [Symbol] [([Symbol],[String])]
+  | SymBIND                         -- the special BIND token
+  | SymNE                           -- non exist
+  | SymSOFT_BIND                    -- the special SOFT_BIND token
+  | SymSOFT_SPACE                   -- the special SOFT_SPACE token
+  | SymCAPIT                        -- the special CAPIT token
+  | SymALL_CAPIT                    -- the special ALL_CAPIT token
+  deriving (Eq,Show)