first draft for Diophantine grammars

src/compiler/api/GF/Command/Importing.hs

@@ -1,7 +1,7 @@
 module GF.Command.Importing (importGrammar, importSource) where
 
 import PGF2
-import PGF2.Transactions
+import PGF2.Transactions hiding (Rule(..))
 
 import GF.Compile
 import GF.Compile.Multi (readMulti)

src/compiler/api/GF/Compile/Compute/Concrete2.hs

@@ -658,7 +658,7 @@ value2term g xs v = do
 
 data MetaState
   = Bound Scope Value
-  | Narrowing   Type
+  | Narrowing   Choice Type
   | Residuation Scope
 data OptionInfo
   = OptionInfo

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

@@ -49,7 +49,6 @@ exportPGF opts fmt pgf =
       FmtSLF          -> single "slf"  slfPrinter
       FmtRegExp       -> single "rexp" regexpPrinter
       FmtFA           -> single "dot"  slfGraphvizPrinter
-      FmtLR           -> single "dot"  (\_ -> graphvizLRAutomaton)
  where
    name = fromMaybe (abstractName pgf) (flag optName opts)
 

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

@@ -1,316 +1,110 @@
-{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------
--- |
--- Maintainer  : Krasimir Angelov
--- Stability   : (stable)
--- Portability : (portable)
---
--- Convert PGF grammar to PMCFG grammar.
---
------------------------------------------------------------------------------
-
 module GF.Compile.GeneratePMCFG
     (generatePMCFG, pmcfgForm, type2fields
     ) where
 
-import GF.Grammar hiding (VApp,VRecType)
+import GF.Infra.Ident
-import GF.Grammar.Predef
-import GF.Grammar.Lookup
-import GF.Infra.CheckM
 import GF.Infra.Option
-import GF.Text.Pretty
+import GF.Infra.CheckM
-import GF.Compile.Compute.Concrete
+import GF.Data.Operations
-import GF.Data.Operations(Err(..))
+import GF.Grammar.Grammar
-import PGF2.Transactions
+import GF.Grammar.Lookup
-import Control.Monad
+import GF.Grammar.Macros
-import Control.Monad.State
+import GF.Grammar.Predef
-import Control.Monad.ST
+import GF.Grammar.Printer hiding (ppValue)
-import qualified Data.Map.Strict as Map
+import GF.Text.Pretty hiding (empty)
-import qualified Data.Sequence as Seq
+import GF.Compile.Compute.Concrete2 hiding ( getMeta, setMeta, globals, variants )
-import Data.List(mapAccumL,sortOn,sortBy)
+import qualified GF.Text.Pretty as PP
-import Data.Maybe(fromMaybe,isNothing)
+import qualified Data.Map as Map
-import Data.STRef
+import qualified Data.Set as Set
+import Control.Applicative
+import Control.Monad (foldM,zipWithM,liftM,liftM2,forM,MonadPlus(..))
+import Control.Monad.Fix
+import Data.Maybe
+import Data.List(mapAccumL,sortBy,intersperse)
+import Prelude hiding ((<>))
+import System.Environment
+
 
 generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
 generatePMCFG opts cwd gr cmo@(cm,cmi)
-  | mstatus cmi == MSComplete && isModCnc cmi && isNothing (mseqs cmi) =
+  | mstatus cmi == MSComplete && isModCnc cmi =
                 do let gr' = prependModule gr cmo
-                   (js,seqs) <- runStateT (Map.traverseWithKey (\id info -> StateT (addPMCFG opts cwd gr' cmi id info)) (jments cmi)) Map.empty
+                       g   = Gl gr' (stdPredef g)
-                   return (cm,cmi{jments = js, mseqs=Just (mapToSequence seqs)})
+                   js <- Map.traverseWithKey (addPMCFG cwd g cmi) (jments cmi)
+                   return (cm,cmi{jments = js})
   | otherwise = return cmo
-  where
-    mapToSequence m = Seq.fromList (map fst (sortOn snd (Map.toList m)))
 
-type SequenceSet = Map.Map [Symbol] Int
+addPMCFG cwd g cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) = do
-
+  defs <- case mdef of
-addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) seqs = do
+            Nothing        -> checkInModule cwd cmi loc ("Happened in the rule generation for the lindef of" <+> id) $ do
-  (defs,seqs) <-
+                                t <- mkLinDefault sgr ty
-          case mdef of
+                                pmcfgForm g t [(Explicit,identW,Sort cStr)] ty
-            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+            Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
-                                   term <- mkLinDefault gr ty
+                                pmcfgForm g t [(Explicit,identW,Sort cStr)] ty
-                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
+  refs <- case mref of
-            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+            Nothing        -> checkInModule cwd cmi loc ("Happened in the rule generation for the linref of" <+> id) $ do
-                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
+                                t <- mkLinReference sgr ty
-  (refs,seqs) <- 
+                                pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr)
-          case mref of
+            Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
-            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
+                                pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr)
-                                   term <- mkLinReference gr ty
-                                   pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
-            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
-                                   pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
   mprn  <- case mprn of
              Nothing          -> return Nothing
              Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
-                                   prn <- normalForm (Gl gr stdPredef) prn
+                                   prn <- normalForm g prn
                                    return (Just (L loc prn))
-  return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs)
+  return (CncCat mty mdef mref mprn (Just (defs,refs)))
-addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do
+  where
-  (rules,seqs) <-
+    Gl sgr _ = g
-           checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $
+addPMCFG cwd g cmi id (CncFun (Just lty@(cats,cat,ctxt,ty)) mlin@(Just (L loc term)) mprn Nothing) = do
-             pmcfgForm gr term ctxt val seqs
+  rules <- checkInModule cwd cmi loc ("Happened in the rule generation for" <+> id) $
+             pmcfgForm g term ctxt ty
   mprn  <- case mprn of
              Nothing          -> return Nothing
              Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
-                                   prn <- normalForm (Gl gr stdPredef) prn
+                                   prn <- normalForm g prn
                                    return (Just (L loc prn))
-  return (CncFun mty mlin mprn (Just rules),seqs)
+  return (CncFun (Just lty) mlin mprn (Just rules))
-addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
-
-pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
-pmcfgForm gr t ctxt ty seqs = do
-  res <- runEvalM (Gl gr stdPredef) $ do
-           (_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
-                                          t <- EvalM (\(Gl gr _) k e mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty
-                                                                                       k t mt d r msgs)
-                                          tnk <- newThunk [] t
-                                          return (arg_no+1,tnk))
-                                      0 ctxt
-           v <- eval [] t args
-           (lins,params) <- flatten v ty ([],[])
-           lins <- fmap reverse $ mapM str2lin lins
-           (r,rs,_) <- compute params
-           args <- zipWithM tnk2lparam args ctxt
-           vars <- getVariables
-           let res = LParam r (order rs)
-           return (vars,args,res,lins)
-  return (runState (mapM mkProduction res) seqs)
   where
-    tnk2lparam tnk (_,_,ty) = do
+    Gl sgr _ = g
-      v <- force tnk
-      (_,params) <- flatten v ty ([],[])
-      (r,rs,_) <- compute params
-      return (PArg [] (LParam r (order rs)))
 
-    compute []              = return (0,[],1)
+addPMCFG cwd g cmi id info = return info
-    compute ((v,ty):params) = do
-      (r, rs ,cnt ) <- param2int v ty
-      (r',rs',cnt') <- compute params
-      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
 
-    mkProduction (vars,args,res,lins) = do
+pmcfgForm g t ctxt ty = do
-      lins <- mapM getSeqId lins
+  let (ms,s',t',arg_params) = apply 0 Map.empty unit ctxt t []
-      return (Production vars args res lins)
+  let v = eval g [] s' t' []
+  (ms,_,_,fn) <- breakDown g ms unit 0 [] v ty (return []) empty
+  runGenM g ms [] $ do
+    (r,rs,v,res_params) <- fn
+    arg_params <- mapM params2int arg_params
+    res_params <- params2int res_params
+    lin_idx    <- params2int' r rs
+    seq        <- flatten v
+    qs <- quantifiers (arg_params++[res_params,lin_idx])
+    return (Rule qs res_params arg_params lin_idx seq)
+  where
+    Gl sgr _ = g
+
+    quantifiers params = GenM (\(Gl sgr _) k svs ms ->
+      k ((Set.toList . Set.fromList)
+            [(variable,boundsOf sgr ms variable) | LParam _ terms <- params, (factor,variable) <- terms])
+        svs ms)
       where
-        getSeqId :: [Symbol] -> State (Map.Map [Symbol] SeqId) SeqId
+        boundsOf sgr ms i =
-        getSeqId lin = state $ \m ->
+          case Map.lookup (i+1) ms of
-          case Map.lookup lin m of
+            Just (Narrowing _ pty) -> case allParamValues sgr pty of
-            Just seqid -> (seqid,m)
+                                        Ok ps   -> length ps
-            Nothing    -> let seqid = Map.size m
+                                        Bad msg -> error msg
-                          in (seqid,Map.insert lin seqid m)
+            _                      -> error (show (ppLVar i <+> "is not a free variable"))
 
-type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term)
+    apply d ms s []              t args = (ms,s,t,reverse args)
-type2metaTerm gr d ms r rs (Sort s) | s == cStr =
+    apply d ms s ((_,_,ty):ctxt) t args =
-  return (ms,r+1,TSymCat d r rs)
+       let (ms',s',_,t2,params) = type2metaTerm sgr d ms s 0 [] ty []
-type2metaTerm gr d ms r rs (RecType lbls) = do
+       in apply (d+1) ms' s' ctxt (App t t2) (params:args)
-  ((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
-                                                        LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
-                                                        lbl    -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
-                                                                     return ((ms',r'),(lbl,(Just ty,t))))
-                                 (ms,r) lbls
-  return (ms',r',R ass)
-type2metaTerm gr d ms r rs (Table p q)
-  | count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
-                    return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
-  | null (collectParams q)
-               = do let pv    = varX (length rs+1)
-                    (ms',delta,t) <-
-                        fixST $ \(~(_,delta,_)) ->
-                                     do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
-                                        return (ms',r'-r,t)
-                    return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
-  | otherwise = do ((ms',r'),ts) <- mapAccumM (\(ms,r) _ -> do (ms',r',t) <- type2metaTerm gr d ms r rs q
-                                                               return ((ms',r'),t))
-                                              (ms,r) [0..count-1]
-                   return (ms',r+(r'-r),V p ts)
-  where
-    collectParams (QC q)      = [q]
-    collectParams (Table _ t) = collectParams t
-    collectParams t           = collectOp collectParams t
 
-    count = case allParamValues gr p of
-              Ok ts   -> length ts
-              Bad msg -> error msg
-type2metaTerm gr d ms r rs ty@(QC q) = do
-  let i = Map.size ms + 1
-  tnk <- newSTRef (Narrowing i ty)
-  return (Map.insert i tnk ms,r,Meta i)
-type2metaTerm gr d ms r rs ty
-  | Just n <- isTypeInts ty = do
-      let i = Map.size ms + 1
-      tnk <- newSTRef (Narrowing i ty)
-      return (Map.insert i tnk ms,r,Meta i)
-
-flatten (VR as) (RecType lbls) st = do
-  foldM collect st lbls
-  where
-    collect st (lbl,ty) =
-      case lookup lbl as of
-        Just tnk -> do v <- force tnk
-                       flatten v ty st
-        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
-                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
-flatten v@(VT _ env cs) (Table p q) st = do
-  ts <- getAllParamValues p
-  foldM collect st ts
-  where
-    collect st t = do
-      tnk <- newThunk [] t
-      let v0 = VS v tnk []
-      v <- patternMatch v0 (map (\(p,t) -> (env,[p],[tnk],t)) cs)
-      flatten v q st
-flatten (VV _ tnks) (Table _ q) st = do
-  foldM collect st tnks
-  where
-    collect st tnk = do
-      v <- force tnk
-      flatten v q st
-flatten v (Sort s) (lins,params) | s == cStr = do
-  deepForce v
-  return (v:lins,params)
-flatten v ty@(QC q) (lins,params) = do
-  deepForce v
-  return (lins,(v,ty):params)
-flatten v ty (lins,params)
-  | Just n <- isTypeInts ty = do deepForce v
-                                 return (lins,(v,ty):params)
-  | otherwise               = evalError (pp (showValue v))
-
-deepForce (VR as)          = mapM_ (\(lbl,v) -> force v >>= deepForce) as
-deepForce (VApp q tnks)    = mapM_ (\tnk -> force tnk >>= deepForce) tnks
-deepForce (VC v1 v2)       = deepForce v1 >> deepForce v2
-deepForce (VAlts def alts) = do deepForce def
-                                mapM_ (\(v,_) -> deepForce v) alts
-deepForce (VSymCat d r rs) = mapM_ (\(_,(tnk,_)) -> force tnk >>= deepForce) rs
-deepForce _                = return ()
-
-str2lin (VApp q [])
-  | q == (cPredef, cBIND)       = return [SymBIND]
-  | q == (cPredef, cNonExist)   = return [SymNE]
-  | q == (cPredef, cSOFT_BIND)  = return [SymSOFT_BIND]
-  | q == (cPredef, cSOFT_SPACE) = return [SymSOFT_SPACE]
-  | q == (cPredef, cCAPIT)      = return [SymCAPIT]
-  | q == (cPredef, cALL_CAPIT)  = return [SymALL_CAPIT]
-str2lin (VStr s)         = return [SymKS s]
-str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
-                              return [SymCat d (LParam r (order rs))]
-  where
-    compute r' []                     = return (r',[])
-    compute r' ((cnt',(tnk,ty)):tnks) = do
-      v <- force tnk
-      (r, rs, cnt) <- param2int v ty
-      (r',rs') <- compute r' tnks
-      return (r*cnt'+r',combine cnt' rs rs')
-str2lin (VSymVar d r)    = return [SymVar d r]
-str2lin VEmpty           = return []
-str2lin (VC v1 v2)       = liftM2 (++) (str2lin v1) (str2lin v2)
-str2lin v0@(VAlts def alts)
-                         = do def <- str2lin def
-                              alts <- forM alts $ \(v1,v2) -> do
-                                lin <- str2lin v1
-                                ss  <- to_strs v2
-                                return (lin,ss)
-                              return [SymKP def alts]
-  where
-    to_strs (VStrs vs)    = mapM to_str vs
-    to_strs (VPatt _ _ p) = from_patt p
-    to_strs v             = fail
-
-    to_str (VStr s) = return s
-    to_str _        = fail
-
-    from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
-    from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
-    from_patt (PString s)  = return [s]
-    from_patt (PChars cs)  = return (map (:[]) cs)
-    from_patt _            = fail
-
-    fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0)))
-str2lin v                = do t <- value2term False [] v
-                              evalError ("the string:" <+> ppTerm Unqualified 0 t $$
-                                         "cannot be evaluated at compile time.")
-
-param2int (VR as) (RecType lbls) = compute lbls
-  where
-    compute []              = return (0,[],1)
-    compute ((lbl,ty):lbls) = do
-      case lookup lbl as of
-        Just tnk -> do v <- force tnk
-                       (r, rs ,cnt ) <- param2int v ty
-                       (r',rs',cnt') <- compute lbls
-                       return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
-        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
-                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
-param2int (VApp q tnks) ty = do
-  (r ,    ctxt,cnt ) <- getIdxCnt q
-  (r',rs',     cnt') <- compute ctxt tnks
-  return (r+r',rs',cnt)
-  where
-    getIdxCnt q = do
-      (_,ResValue (L _ ty) idx) <- getInfo q
-      let (ctxt,QC p) = typeFormCnc ty
-      (_,ResParam _ (Just (_,cnt))) <- getInfo p
-      return (idx,ctxt,cnt)
-
-    compute []              []         = return (0,[],1)
-    compute ((_,_,ty):ctxt) (tnk:tnks) = do
-      v <- force tnk
-      (r, rs ,cnt ) <- param2int v ty
-      (r',rs',cnt') <- compute ctxt tnks
-      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
-param2int (VInt n)        ty
-  | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
-param2int (VMeta tnk _) ty = do
-  tnk_st <- getRef tnk
-  case tnk_st of
-    Evaluated _ v  -> param2int v ty
-    Narrowing j ty -> do ts <- getAllParamValues ty
-                         return (0,[(1,j-1)],length ts)
-param2int v ty = do t <- value2term True [] v
-                    evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
-                               "cannot be evaluated at compile time.")
-
-combine' 1   rs 1    rs' = []
-combine' 1   rs cnt' rs' = rs'
-combine' cnt rs 1    rs' = rs
-combine' cnt rs cnt' rs' = combine cnt' rs rs'
-
-combine cnt'          []            rs' = rs'
-combine cnt'          rs             [] = [(r*cnt',pv) | (r,pv) <- rs]
-combine cnt' ((r,pv):rs) ((r',pv'):rs') =
-  case compare pv pv' of
-    LT -> (r*cnt',   pv ) : combine cnt' rs ((r',pv'):rs')
-    EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
-    GT -> (       r',pv') : combine cnt' ((r,pv):rs) rs'
-
-order = sortBy (\(r1,_) (r2,_) -> compare r2 r1)
-
-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)
 
 type2fields :: SourceGrammar -> Type -> [String]
-type2fields gr = type2fields empty
+type2fields gr = map show . type2fields PP.empty
   where
     type2fields d (Sort s) | s == cStr = [show d]
     type2fields d (RecType lbls) =
@@ -320,6 +114,7 @@ type2fields gr = type2fields empty
       in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts
     type2fields d _ = []
 
+
 mkLinDefault :: SourceGrammar -> Type -> Check Term
 mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
  where
@@ -347,18 +142,388 @@ mkLinReference gr typ = do
   where
     mkRefField ty trm =
       case ty of
-        Table pty ty -> case allParamValues gr pty of
+        Table pty ty -> do ps <- allParamValues gr pty
-                          Ok []     -> checkError ("no parameter values given to type" <+> pty)
+                           case ps of
-                          Ok (p:ps) -> mkRefField ty (S trm p)
+                             []     -> fail (render ("no parameter values given to type" <+> pty))
-                          Bad msg   -> fail msg
+                             (p:ps) -> mkRefField ty (S trm p)
         Sort s | s == cStr -> return (Just trm)
         QC p       -> return Nothing
         RecType rs -> traverse rs trm
         _ | Just _ <- isTypeInts ty -> return Nothing
-        _ -> checkError ("a field in a linearization type cannot be" <+> typ)
+        _ -> fail (render ("a field in a linearization type cannot be" <+> typ))
 
     traverse []          trm = return Nothing
     traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l)
                                   case res of
                                     Just trm -> return (Just trm)
                                     Nothing  -> traverse rs trm
+
+
+type2metaTerm :: SourceGrammar -> Int -> MetaVars -> Choice -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> [(Value,Type)] -> (MetaVars,Choice,Int,Term,[(Value,Type)])
+type2metaTerm gr d ms s r rs (Sort srt)     params | srt == cStr = (ms,s,r+1,TSymCat d r rs,params)
+type2metaTerm gr d ms s r rs (RecType lbls) params =
+  let ((ms',s',r',params'),ass) =
+          mapAccumL (\(ms,s,r,params) (lbl,ty) -> case lbl of
+                                                    LVar j -> ((ms,s,r,params),(lbl,(Just ty,TSymVar d j)))
+                                                    lbl    -> let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs ty params
+                                                              in ((ms',s',r',params'),(lbl,(Just ty,t))))
+                    (ms,s,r,params) lbls
+  in (ms',s',r',R ass,params')
+type2metaTerm gr d ms s r rs (Table p q) params
+  | count == 1 = let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs q params
+                 in (ms',s',r+(r'-r),T (TTyped p) [(PW,t)],params')
+  | otherwise  = let pv     = varX (length rs+1)
+                     (ms',s',r',t,params') = type2metaTerm gr d ms s r ((delta,(pv,p)):rs) q params
+                     delta  = r'-r
+                 in (ms',s',r+delta*count,T (TTyped p) [(PV pv,t)],params')
+  where
+    count = case allParamValues gr p of
+              Ok ts   -> length ts
+              Bad msg -> error msg
+type2metaTerm gr d ms c r rs ty@(QC q) params =
+  let i = Map.size ms + 1
+      (c1,c2) = split c
+  in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params)
+type2metaTerm gr d ms c r rs ty params
+  | Just n <- isTypeInts ty =
+      let i = Map.size ms + 1
+          (c1,c2) = split c
+      in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params)
+
+
+breakDown g ms s r rs v (Sort sort)    fn0 fn
+  | sort == cStr                              =
+      let fn' = do params <- fn0
+                   v      <- force v
+                   return (r,rs,v,params)
+                <|>
+                do fn
+      in return (ms,r+1,fn0,fn')
+breakDown g ms s r rs v (RecType lbls) fn0 fn = traverse ms r rs lbls fn0 fn
+  where
+    traverse ms r rs []              fn0 fn = return (ms,r,fn0,fn)
+    traverse ms r rs ((lbl,ty):lbls) fn0 fn = do (ms,r,fn0,fn) <- breakDown g ms s r rs (project v) ty fn0 fn
+                                                 traverse ms r rs lbls fn0 fn
+      where
+        project (VR as)       = case lookup lbl as of
+                                  Nothing -> error (render ("Missing value for label" <+> pp lbl $$
+                                                            "in" <+> ppValue Unqualified 0 (VR as)))
+                                  Just v  -> v
+        project (VFV c fvs)   = VFV c (fmap project fvs)
+        project (VMeta i vs)  = VSusp i (\v -> project (apply g v vs)) []
+        project (VSusp i k vs)= VSusp i (\v -> project (apply g (k v) vs)) []
+        project v             = VP v lbl []
+breakDown g ms c r rs v (Table p q) fn0 fn = do
+  let i  = Map.size ms + 1
+      v2 = VMeta i []
+      v0 = VS v v2 []
+      (c1,c2) = split c
+      Gl gr _ = g
+  cnt <- fmap length $ allParamValues gr p
+  (ms,r',fn0,fn) <- mfix $ \(~(_,r',_,_)) ->
+       breakDown g (Map.insert i (Narrowing c1 p) ms) c2 r ((r'-r,(v2,p)):rs) (select v0 v v2) q fn0 fn
+  return (ms,r+(r'-r)*cnt,fn0,fn)
+  where
+    select v0 (VT _  env s cs) v2 = patternMatch g s v0 (map (\(p,t) -> (env,[p],[v2],t)) cs)
+    select v0 (VV vty tvs)     v2 = vtableSelect g v0 p tvs v2 []
+    select v0 (VFV i fvs)      v2 = VFV i (fmap (\v1 -> select v0 v1 v2) fvs)
+    select v0 (VMeta i vs)     v2 = VSusp i (\v -> select v0 (apply g v vs) v2) []
+    select v0 (VSusp i k vs)   v2 = VSusp i (\v -> select v0 (apply g (k v) vs) v2) []
+    select v0 v1               v2 = v0
+breakDown g ms s r rs v ty@(QC q) fn0 fn =
+  let fn0' = do params <- fn0
+                v <- force v
+                return ((v,ty):params)
+      fn'  = do (r,rs,v',res_params) <- fn
+                v <- force v
+                return (r,rs,v',(v,ty):res_params)
+  in return (ms,r,fn0',fn')
+breakDown g ms s r rs v ty@(App (Q q) _) fn0 fn =
+  let fn0' = do params <- fn0
+                v <- force v
+                return ((v,ty):params)
+      fn'  = do (r,rs,v',res_params) <- fn
+                v <- force v
+                return (r,rs,v',(v,ty):res_params)
+  in return (ms,r,fn0',fn')
+
+force (VStr s) = return (VStr s)
+force (VInt n) = return (VInt n)
+force (VFlt d) = return (VFlt d)
+force (VSymCat d r rs) = do
+  rs <- mapM force_ rs
+  return (VSymCat d r rs)
+  where
+    force_ (factor, (v, ty)) = do
+      v <- force v
+      return (factor, (v, ty))
+force (VApp c q vs) = do
+  vs <- mapM force vs
+  return (VApp c q vs)
+force (VAlts def alts) = do
+  def  <- force def
+  alts <- mapM force_ alts
+  return (VAlts def alts)
+  where
+    force_ (x,y) = do
+      x <- force x
+      y <- force y
+      return (x,y)
+force VEmpty     = return VEmpty
+force (VC v1 v2) = do
+  v1 <- force v1
+  v2 <- force v2
+  return (VC v1 v2)
+force (VMeta i vs) = do
+  vs <- mapM force vs
+  return (VMeta i vs)
+force (VSusp i k vs) = do
+  vs <- mapM force vs
+  st <- getMeta i
+  v <- case st of
+         Narrowing c ty -> do v <- chooseMetaValue c ty
+                              setMeta i (Bound undefined v)
+                              return v
+         Bound _ v      -> return v
+  g <- globals
+  force (apply g (k v) vs)
+force (VStrs vs) = do
+  vs <- mapM force vs
+  return (VStrs vs)
+force (VR as) = do
+  as <- mapM (\(l,v) -> fmap ((,) l) (force v)) as
+  return (VR as)
+force v@(VPatt _ _ _) = return v
+force (VFV c vs) = do
+  v <- variants c (unvariants vs)
+  force v
+force v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v)
+
+
+flatten (VStr s) = return [SymKS s]
+flatten (VSymCat d r rs) = do
+  lin_index <- params2int' r rs
+  return [SymCat d lin_index]
+flatten (VApp _ (m,id) [])
+  | m == cPredef && id == cBIND       = return [SymBIND]
+  | m == cPredef && id == cSOFT_BIND  = return [SymSOFT_BIND]
+  | m == cPredef && id == cSOFT_SPACE = return [SymSOFT_SPACE]
+  | m == cPredef && id == cNonExist   = return [SymNE]
+  | m == cPredef && id == cCAPIT      = return [SymCAPIT]
+  | m == cPredef && id == cALL_CAPIT  = return [SymALL_CAPIT]
+flatten v0@(VAlts def alts) = do
+  def <- flatten def
+  alts <- forM alts $ \(alt,ps) -> do
+    alt <- flatten alt
+    ps  <- to_strs ps
+    return (alt,ps)
+  return [SymKP def alts]
+  where
+    to_strs (VStrs vs)    = mapM to_str vs
+    to_strs (VPatt _ _ p) = from_patt p
+    to_strs v             = fail
+
+    to_str (VStr s) = return s
+    to_str _        = fail
+
+    from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
+    from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
+    from_patt (PString s)  = return [s]
+    from_patt (PChars cs)  = return (map (:[]) cs)
+    from_patt _            = fail
+
+    fail = compileError ("Complex patterns are not supported in:" $$ nest 2 (ppValue Unqualified 0 v0))
+flatten VEmpty     = return []
+flatten (VC v1 v2) = do
+  s1 <- flatten v1
+  s2 <- flatten v2
+  return (s1++s2)
+flatten (VSusp i k vs) = do
+  st <- getMeta i
+  v <- case st of
+         Narrowing c ty -> do v <- chooseMetaValue c ty
+                              setMeta i (Bound undefined v)
+                              return v
+         Bound _ v      -> return v
+  g <- globals
+  flatten (apply g (k v) vs)
+flatten (VFV c vs) = do
+  v <- variants c (unvariants vs)
+  flatten v
+flatten v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v  <+> "to a string")
+
+
+params2int rs = do
+  (r,rs,_) <- compute rs
+  return (LParam r (order rs))
+  where
+    compute []              = return (0,[],1)
+    compute ((v,ty):params) = do
+      (r, rs, cnt ) <- param2int v ty
+      (r',rs',cnt') <- compute params
+      return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
+
+params2int' r0 rs = do
+  (r,rs) <- compute rs
+  return (LParam (r0+r) (order rs))
+  where
+    compute []                     = return (0,[])
+    compute ((cnt',(v,ty)):params) = do
+      (r, rs, cnt) <- param2int v ty
+      (r',rs')     <- compute params
+      return (r*cnt'+r',combine cnt' rs rs')
+
+param2int (VR as) (RecType lbls) = compute lbls
+  where
+    compute []              = return (0,[],1)
+    compute ((lbl,ty):lbls) = do
+      case lookup lbl as of
+        Just v   -> do (r, rs ,cnt ) <- param2int v ty
+                       (r',rs',cnt') <- compute lbls
+                       return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+        Nothing  -> compileError ("Missing value for label" <+> pp lbl $$
+                                  "among" <+> hsep (punctuate (pp ',') (map fst as)))
+param2int (VApp _ q vs) ty = do
+  (r ,    ctxt,cnt ) <- getIdxCnt q
+  (r',rs',     cnt') <- compute ctxt vs
+  return (r+r',rs',cnt)
+  where
+    compute []              []     = return (0,[],1)
+    compute ((_,_,ty):ctxt) (v:vs) = do
+      (r, rs ,cnt ) <- param2int v ty
+      (r',rs',cnt') <- compute ctxt vs
+      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+param2int (VInt n) ty
+  | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
+param2int (VMeta i _) ty = do
+  st <- getMeta i
+  case st of
+    Narrowing c ty -> do count <- getCnt ty
+                         return (0,[(1,i-1)],count)
+    Bound _ v      -> param2int v ty
+param2int (VSusp i k vs) ty = do
+  st <- getMeta i
+  v <- case st of
+         Narrowing c ty -> do v <- chooseMetaValue c ty
+                              setMeta i (Bound undefined v)
+                              return v
+         Bound _ v      -> return v
+  g <- globals
+  param2int (apply g (k v) vs) ty
+param2int (VFV c vs) ty = do
+  v <- variants c (unvariants vs)
+  param2int v ty
+param2int v ty = compileError ("the parameter:" <+> ppValue Unqualified 0 v $$
+                               "cannot be evaluated at compile time.")
+
+combine' 1   rs 1    rs' = []
+combine' 1   rs cnt' rs' = rs'
+combine' cnt rs 1    rs' = rs
+combine' cnt rs cnt' rs' = combine cnt' rs rs'
+
+combine cnt'          []            rs' = rs'
+combine cnt'          rs             [] = [(r*cnt',pv) | (r,pv) <- rs]
+combine cnt' ((r,pv):rs) ((r',pv'):rs') =
+  case compare pv pv' of
+    LT -> (r*cnt',   pv ) : combine cnt' rs ((r',pv'):rs')
+    EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
+    GT -> (       r',pv') : combine cnt' ((r,pv):rs) rs'
+
+
+type ChoiceMap = Map.Map Choice Int
+type MetaVars = Map.Map Int MetaState
+
+newtype GenM a = GenM {unGen :: forall r . Globals -> (a -> ChoiceMap -> MetaVars -> r -> Check r) -> ChoiceMap -> MetaVars -> r -> Check r}
+
+instance Functor GenM where
+  fmap f (GenM m) = GenM (\g k -> m g (k . f))
+
+instance Applicative GenM where
+  pure x = GenM (\g k -> k x)
+  (GenM f) <*> (GenM h) = GenM (\g k -> f g (\fn -> h g (\x -> k (fn x))))
+
+instance Alternative GenM where
+  empty = GenM (\g k svs ms r -> pure r)
+  (GenM f) <|> (GenM h) = GenM (\g k svs ms r -> f g k svs ms r >>= h g k svs ms)
+
+instance Monad GenM where
+  (GenM f) >>= h = GenM (\g k -> f g (\x -> case h x of {GenM h -> h g k}))
+
+instance MonadFail GenM where
+  fail msg = GenM (\_ _ _ _ _ -> fail msg)
+
+runGenM g ms r (GenM f) = f g (\x svs ms xs -> pure (x:xs)) Map.empty ms r
+
+compileError d = GenM (\_ _ _ _ _ -> checkError d)
+
+globals = GenM $ \g k -> k g
+
+variants :: Choice -> [a] -> GenM a
+variants c xs = GenM (\g k svs ms r ->
+                          case Map.lookup c svs of
+                            Just j  -> k (xs !! j) svs ms r
+                            Nothing -> foldM (\r (j,x) -> k x (Map.insert c j svs) ms r) r (zip [0..] xs))
+
+newMeta c ty = GenM $ \_ k svs ms ->
+  let i = Map.size ms + 1
+  in k i svs (Map.insert i (Narrowing c ty) ms)
+
+getMeta i = GenM $ \_ k svs ms r ->
+  case Map.lookup i ms of
+    Just v  -> k v svs ms r
+    Nothing -> checkError (pp "Meta variable" <+> ppMeta i <+> "is not defined")
+
+setMeta i st = GenM $ \_ k svs ms ->
+  k () svs (Map.insert i st ms)
+
+getCnt ty = GenM $ \(Gl gr _) k svs ms r ->
+  case allParamValues gr ty of
+    Ok ts   -> k (length ts) svs ms r
+    Bad msg -> checkError (pp msg)
+
+getIdxCnt q = GenM $ \(Gl gr _) k svs ms r ->
+  case lookupOrigInfo gr q of
+    Ok (_,ResValue (L _ ty) idx) -> 
+      let (ctxt,QC p) = typeFormCnc ty
+      in case lookupOrigInfo gr p of
+           Ok (_,ResParam _ (Just (_,cnt))) -> k (idx,ctxt,cnt) svs ms r
+           Bad msg -> checkError (pp msg)
+    Bad msg -> checkError (pp msg)
+
+chooseMetaValue :: Choice -> Type -> GenM Value
+chooseMetaValue s ptyp = GenM $ \g@(Gl gr _) k svs ms r ->
+  case ptyp of
+    _ | Just n <- isTypeInts ptyp -> foldM (\r i -> k (VInt i) svs ms r) r [0..n]
+    QC c -> do (mod,info) <- lookupOrigInfo gr c
+               case info of
+                 ResParam (Just ps) _ -> mkValue mod k svs ms r 0 (unLoc ps)
+                 _                    -> checkError (ppQIdent Qualified c <+> "has no parameter values defined")
+    Q  c -> lookupResDef gr c >>= \ty -> unGen (chooseMetaValue s ty) g k svs ms r
+    RecType lbls -> unGen (mapAccumM mkField s lbls >>= \(_,lbls) -> return (VR lbls)) g k svs ms r
+    _ -> checkError ("cannot find parameter values for" <+> ptyp)
+  where
+    mkValue mod k svs ms r idx []             = return r
+    mkValue mod k svs ms r idx ((id,ctxt):ps) = do
+      let (ms',args) = mkVars ms s ctxt
+      r <- k (VApp poison (mod,id) args) (Map.insert s idx svs) ms' r
+      mkValue mod k svs ms r (idx+1) ps
+
+    mkVars ms c []              = (ms,[])
+    mkVars ms c ((_,_,ty):ctxt) =
+      let i = Map.size ms + 1
+          (c1,c2) = split c
+          (ms',args) = mkVars (Map.insert i (Narrowing c1 ty) ms) c2 ctxt
+      in (ms',VMeta i []:args)
+
+    mkField c (l,ty) = do
+       let (c1,c2) = split c
+       v <- chooseMetaValue c1 ty
+       return (c2,(l,v))
+
+order :: Ord a => [(a,b)] -> [(a,b)]
+order = sortBy (\(r1,_) (r2,_) -> compare r2 r1)
+
+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)

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

@@ -36,7 +36,6 @@ abstract2canonical absname gr = do
                      mopens  = [],
                      mexdeps = [],
                      msrc    = "",
-                     mseqs   = Nothing,
                      jments  = Map.fromList infos
                    })
 
@@ -74,7 +73,6 @@ concretes2canonical opts absname gr = do
         mopens  = [],
         mexdeps = [],
         msrc    = "",
-        mseqs   = Nothing,
         jments  = Map.empty
       }
 
@@ -96,17 +94,16 @@ concrete2canonical gr absname cncname modinfo = do
                       mopens  = [],
                       mexdeps = [],
                       msrc    = "",
-                      mseqs   = Nothing,
                       jments  = Map.fromList (mapMaybe snd infos)
                     }))
   where
-    convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do
+    convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mpmcfg) = do
       typ <- normalForm g typ
       let pts = paramTypes typ
-      return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mb_prods))
+      return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mpmcfg))
-    convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mb_prods) = do
+    convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mpmcfg) = do
       def <- normalForm g (eta_expand def ctx)
-      return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mb_prods))
+      return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mpmcfg))
     convInfo g  _ = return (Set.empty,Nothing)
 
     eta_expand t []                   = t

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

@@ -57,18 +57,17 @@ grammar2PGF opts mb_pgf gr am probs = do
       createConcrete (mi2i cm) $ do
         let cflags = err (const noOptions) mflags (lookupModule gr cm)
         sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags]
-        let infos = ( Seq.fromList [Left [SymCat 0 (LParam 0 [])]]
+        let infos = ( let z       = LParam 0 []
-                    , let id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [0]
+                          id_rule = Rule [] z [z] z [SymCat 0 z]
-                          prods   = ([id_prod],[id_prod])
+                          rules   = ([id_rule],[id_rule])
-                      in [(cInt,   CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                      in [((cm,cInt),   CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
-                         ,(cString,CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ,((cm,cString),CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
-                         ,(cFloat, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ,((cm,cFloat), CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
                          ]
                     )
-                    : prepareSeqTbls (Look.allOrigInfos gr cm)
+                    ++ Look.allOrigInfos gr cm
-        infos <- processInfos createCncCats infos
+        mapM_ createCncCats infos
-        infos <- processInfos createCncFuns infos
+        mapM_ createCncFuns infos
-        return ()
   return pgf
   where
     aflags = err (const noOptions) mflags (lookupModule gr am)
@@ -100,38 +99,19 @@ grammar2PGF opts mb_pgf gr am probs = do
                       0 -> 0
                       n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
 
-    prepareSeqTbls infos = 
+    createCncCats ((_,c),CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
-       (map addSeqTable . Map.toList . Map.fromListWith (++))
+      createLincat (i2i c) (type2fields gr ty) lindefs linrefs
-               [(m,[(c,info)]) | ((m,c),info) <- infos]
-       where
-         addSeqTable (m,infos) = 
-           case lookupModule gr m of
-             Ok mi   -> case mseqs mi of
-                          Just seqs -> (fmap Left seqs,infos)
-                          Nothing   -> (Seq.empty,[])
-             Bad msg -> error msg
-
-    processInfos f []                    = return []
-    processInfos f ((seqtbl,infos):rest) = do
-      seqtbl <- foldM f seqtbl infos
-      rest <- processInfos f rest
-      return ((seqtbl,infos):rest)
-
-    createCncCats seqtbl (c,CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
-      seqtbl <- createLincat (i2i c) (type2fields gr ty) lindefs linrefs seqtbl
       case mprn of
         Nothing        -> return ()
         Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn))
-      return seqtbl
+    createCncCats _ = return ()
-    createCncCats seqtbl _ = return seqtbl
 
-    createCncFuns seqtbl (f,CncFun _ _ mprn (Just prods)) = do
+    createCncFuns ((_,f),CncFun _ _ mprn (Just rules)) = do
-      seqtbl <- createLin (i2i f) prods seqtbl
+      createLin (i2i f) rules
       case mprn of
         Nothing        -> return ()
         Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn))
-      return seqtbl
+    createCncFuns _ = return ()
-    createCncFuns seqtbl _ = return seqtbl
 
     term2tokens (K tok)     = [tok]
     term2tokens (C t1 t2)   = term2tokens t1 ++ term2tokens t2

src/compiler/api/GF/Compile/TypeCheck/Concrete.hs

@@ -1063,7 +1063,7 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do      -
   (scope,mkProj,wrap) <- mkAccess scope t
 
   let fields = [(l,o2,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
-  case [l | (l,_,_,Nothing) <- fields, not ext1 && not (isLockLabel l)] of
+  case [l | (l,_,_,Nothing) <- fields, not ext1] of
     []      -> return ()
     missing -> evalError ("In the term" <+> pp t $$
                           "there are no values for fields:" <+> hsep missing)

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

@@ -82,7 +82,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_ mseqs 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
@@ -119,7 +119,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs j
                     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] ++
@@ -135,7 +135,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs j
                                     js
       let js1 = Map.union js0 js_
       let med1= nub (ext : infs ++ insts ++ med_)
-      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ mseqs js1
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ js1
 
   return (i,mi')
 
@@ -214,7 +214,7 @@ unifyAnyInfo m i j = case (i,j) of
     liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
 
   (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
-    liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2)  (unifyMaybe mpmcfg1 mpmcfg2)
+    liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2)
   (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
     liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
 

src/compiler/api/GF/Compiler.hs

@@ -1,7 +1,7 @@
 module GF.Compiler (mainGFC, writeGrammar, writeOutputs) where
 
 import PGF2
-import PGF2.Transactions
+import PGF2.Transactions hiding (Rule(..))
 import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
@@ -11,11 +11,10 @@ import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
 import GF.Grammar.CFG
-import GF.Grammar.Grammar
+import GF.Grammar.Grammar hiding (Rule(..))
 import GF.Grammar.JSON(grammar2json)
 import GF.Grammar.Printer(TermPrintQual(..),ppModule)
 
---import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
 import GF.Infra.Option
 import GF.Infra.CheckM

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

@@ -23,7 +23,6 @@ import GF.Infra.UseIO(MonadIO(..))
 import GF.Grammar.Grammar
 
 import PGF2(Literal(..))
-import PGF2.Transactions(Symbol(..))
 
 -- Please change this every time when the GFO format is changed
 gfoVersion = "GF05"
@@ -33,9 +32,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)
+  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,mseqs,jments) <- get
+  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,jments) <- get
-              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
+              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments)
 
 instance Binary ModuleType where
   put MTAbstract       = putWord8 0
@@ -100,9 +99,9 @@ instance Binary PArg where
   put (PArg x y) = put (x,y)
   get = get >>= \(x,y) -> return (PArg x y)
 
-instance Binary Production where
+instance Binary Rule where
-  put (Production ps args res rules) = put (ps,args,res,rules)
+  put (Rule v w x y z) = put (v,w,x,y,z)
-  get = get >>= \(ps,args,res,rules) -> return (Production ps args res rules)
+  get = get >>= \(v,w,x,y,z) -> return (Rule v w x y z)
 
 instance Binary Info where
   put (AbsCat x)       = putWord8 0 >> put x
@@ -369,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/api/GF/Grammar/Grammar.hs

@@ -65,7 +65,7 @@ module GF.Grammar.Grammar (
         Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
-        LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)
+        LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..)
         ) where
 
 import GF.Infra.Ident
@@ -75,7 +75,7 @@ import GF.Infra.Location
 import GF.Data.Operations
 
 import PGF2(BindType(..),PGF)
-import PGF2.Transactions(SeqId,LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..))
+import PGF2.Transactions(LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..))
 
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
@@ -103,7 +103,6 @@ data ModuleInfo
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
-    mseqs   :: Maybe (Seq.Seq [Symbol]),
     jments  :: Map.Map Ident Info
    }
  | ModPGF {
@@ -336,8 +335,8 @@ data Info =
  | ResOverload [ModuleName] [(L Type,L Term)]        -- ^ (/RES/) idents: modules inherited
 
 -- judgements in concrete syntax
- | CncCat  (Maybe (L Type))                     (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Production],[Production])) -- ^ (/CNC/) lindef ini'zed, 
+ | CncCat  (Maybe (L Type))                     (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Rule],[Rule])) -- ^ (/CNC/) lindef ini'zed, 
- | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC'
+ | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [Rule]) -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool ModuleName                        -- ^ (/INDIR/) the 'Bool' says if canonical

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

@@ -110,7 +110,7 @@ lookupResDef gr (m,c)
         ResOper _ (Just (L _ t)) -> return t
         ResOper _ Nothing  -> return (Q (m,c))
         CncCat (Just (L _ ty)) _ _ _ _ -> lock c ty
-        CncCat _ _ _ _ _         -> lock c defLinType
+        CncCat _ _ _ _ _        -> lock c defLinType
 
         CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
         CncFun _                  (Just (L _ tr)) _ _ -> return tr

src/compiler/api/GF/Grammar/Parser.y

@@ -135,14 +135,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 
@@ -481,7 +481,7 @@ Exp6 :: { Term }
 Exp6 
   : Ident                 { Vr $1 } 
   | Sort                  { Sort $1 }
-  | String                { K $1 }
+  | String                { words2term (words $1) }
   | Integer               { EInt $1 }
   | Double                { EFloat $1 }
   | '?'                   { Meta 0 }
@@ -892,4 +892,8 @@ mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
 mkMarkup [t] = t
 mkMarkup ts  = Markup identW [] ts
 
+words2term []     = Empty
+words2term [w]    = K w
+words2term (w:ws) = C (K w) (words2term ws)
+
 }

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

@@ -21,12 +21,12 @@ module GF.Grammar.Printer
            , ppConstrs
            , ppQIdent
            , ppMeta
+           , ppLVar
            , getAbs
            ) where
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import PGF2(Literal(..),pgfFilePath)
-import PGF2.Transactions(SeqId)
 import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Grammar.Values
@@ -49,11 +49,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)) $$
+            vcat (map (ppJudgement q) (Map.toList jments))) $$
-            maybe empty (ppSequences q) mseqs) $$
     ftr
     where
       hdr = complModDoc <+> modTypeDoc <+> '=' <+>
@@ -142,9 +141,9 @@ ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) =
      Nothing        -> empty) $$
   (case (mtyp,mpmcfg,q) of
      (Just (L _ typ),Just (lindefs,linrefs),Internal)
-                    -> "pmcfg" <+> '{' $$
+                    -> "rules" <+> '{' $$
-                       nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)  $$
+                       nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)) $$
-                               vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
+                       nest 2 (vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
                        '}'
      _              -> empty)
 ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
@@ -157,7 +156,7 @@ ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
      Nothing        -> empty) $$
   (case (mtyp,mpmcfg,q) of
      (Just (args,res,_,_),Just rules,Internal)
-                    -> "pmcfg" <+> '{' $$
+                    -> "rules" <+> '{' $$
                        nest 2 (vcat (map (ppPmcfgRule id args res) rules)) $$
                        '}'
      _              -> empty)
@@ -166,20 +165,22 @@ ppJudgement q (id, AnyInd cann mid) =
     Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
     _        -> empty
 
-ppPmcfgRule id arg_cats res_cat (Production vars args res seqids) =
-  pp id <+> (':' <+>
-             (if null vars
-                then empty
-                else "∀{" <> hsep (punctuate ',' [ppLVar v <> '<' <> m | (v,m) <- vars]) <> '}'  <+> '.') <+>
-             ppPmcfgCat res_cat res <+> "->" <+>
-             brackets (hcat (intersperse (pp ',') (zipWith ppPArg arg_cats args))) <+> '=' <+> 
-             brackets (hcat (intersperse (pp ',') (map ppSeqId seqids))))
-
 ppPArg cat (PArg _ p) = ppPmcfgCat cat p
 
 ppPmcfgCat :: Ident -> LParam -> Doc
 ppPmcfgCat cat p = pp cat <> parens (ppLParam p)
 
+ppPmcfgRule id arg_cats res_cat (Rule quantifiers res args lin_idx seq) =
+  ppQuantifiers quantifiers <+>
+  ppCat res_cat res <+> "->" <+> pp id <> brackets (hcat (punctuate ',' (zipWith ppCat arg_cats args))) <> ';' <+> ppLParam lin_idx <+> ':' <+> hsep (map ppSymbol seq)
+  where
+    ppCat id value = pp id <> parens (ppLParam value)
+
+    ppQuantifiers [] = empty
+    ppQuantifiers qs = pp '{' <> hsep (punctuate (pp ',') (map ppQuantifier qs)) <> pp '}'
+
+    ppQuantifier (var,range) = ppLVar var <> pp '<' <> pp (range::Int)
+
 instance Pretty Term where pp = ppTerm Unqualified 0
 
 ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
@@ -372,18 +373,6 @@ ppMarkupChildren q (t:ts) =
      _         -> ppTerm q 0 t <> ';') $$
   ppMarkupChildren q ts
 
-ppSeqId :: SeqId -> Doc
-ppSeqId seqid = 'S' <> pp seqid
-
-ppSequences q seqs
-  | Seq.null seqs || q /= Internal = empty
-  | otherwise                      = "sequences" <+> '{' $$
-                                     nest 2 (vcat (zipWith ppSeq [0..] (toList seqs))) $$
-                                    '}'
-  where
-    ppSeq seqid seq =
-      ppSeqId seqid <+> ":=" <+> hsep (map ppSymbol seq)
-
 commaPunct f ds = (hcat (punctuate "," (map f ds)))
 
 prec d1 d2 doc

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

@@ -107,7 +107,6 @@ data OutputFormat = FmtPGFPretty
                   | FmtSLF
                   | FmtRegExp
                   | FmtFA
-                  | FmtLR
   deriving (Eq,Ord)
 
 data SISRFormat =
@@ -492,8 +491,7 @@ outputFormatsExpl =
      (("vxml",         FmtVoiceXML),"Voice XML based on abstract syntax"),
      (("slf",          FmtSLF),"SLF speech recognition format"),
      (("regexp",       FmtRegExp),"regular expression"),
-     (("fa",           FmtFA),"finite automaton in graphviz format"),
+     (("fa",           FmtFA),"finite automaton in graphviz format")
-     (("lr",           FmtLR),"LR(0) automaton for PMCFG in graphviz format")
      ]
 
 instance Show OutputFormat where

src/compiler/api/GF/Interactive.hs

@@ -301,9 +301,9 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
            mb_fields <- getCategoryFields cat
            case mb_fields of
              Just fields -> case runCheck (compileLinTerm sgr mo f mb_t (type2term mo ty)) of
-                              Ok ((prods,seqtbl,fields'),_)
+                              Ok ((rules,fields'),_)
                                    | fields == fields' -> do
-                                       (if is_alter then alterLin else createLin) f prods seqtbl
+                                       (if is_alter then alterLin else createLin) f rules
                                        return ()
                                    | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match"
                               Bad msg      -> fail msg
@@ -327,10 +327,9 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
                                              return (t,ty)
                                Bad msg -> fail msg
       let (ctxt,res_ty) = typeFormCnc ty
-      (prods,seqs) <- pmcfgForm sgr t ctxt res_ty Map.empty
+      let g = Gl sgr (stdPredef g)
-      return (prods,mapToSequence seqs,type2fields sgr res_ty)
+      rules <- pmcfgForm g t ctxt res_ty
-      where
+      return (rules,type2fields sgr res_ty)
-        mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m)))
 
 transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
   sgr <- getGrammar
@@ -339,7 +338,7 @@ transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
           Just mo -> return mo
   lang <- optLang pgf opts
   case runCheck (compileLincatTerm sgr mo mb_t) of
-    Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ()))
+    Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] >> return ()))
                        return ()
     Bad msg      -> fail msg
   where