partial support for runtime parameters

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

@@ -8,7 +8,7 @@ module GF.Compile.Compute.Concrete
            , EvalM, runEvalM, evalError
            , eval, apply, force, value2term
            , newMeta,getMeta,setMeta
-           , newEvaluatedThunk,getAllParamValues
+           , newThunk,newEvaluatedThunk,getAllParamValues
            , lookupParams
            ) where
 
@@ -34,6 +34,7 @@ import Control.Applicative
 import qualified Control.Monad.Fail as Fail
 import qualified Data.Map as Map
 import GF.Text.Pretty
+import PGF2.Transactions(LIndex)
 
 -- * Main entry points
 
@@ -78,8 +79,9 @@ 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
+    -- This last constructor is only generated internally
-                        -- the PMCFG generator.
+    -- in the PMCFG generator.
+  | VSymCat Int LIndex [(LIndex, Thunk s)]
 
 
 eval env (Vr x)         vs  = case lookup x env of
@@ -181,6 +183,11 @@ eval env (Alts d as)    []  = do vd <- eval env d []
                                  return (VAlts vd vas)
 eval env (Strs ts)      []  = do vs <- mapM (\t -> eval env t []) ts
                                  return (VStrs vs)
+eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,pv) ->
+                                         case lookup pv env of
+                                           Just tnk -> return (i,tnk)
+                                           Nothing  -> evalError ("Variable" <+> pp pv <+> "is not in scope")
+                                 return (VSymCat d r rs)
 eval env t              vs  = evalError ("Cannot reduce term" <+> pp t)
 
 apply (VMeta m env vs0)             vs  = do st <- getMeta m

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -15,13 +15,17 @@ module GF.Compile.GeneratePMCFG
 
 import GF.Grammar hiding (VApp)
 import GF.Grammar.Predef
+import GF.Grammar.Lookup
 import GF.Infra.CheckM
 import GF.Infra.Option
 import GF.Text.Pretty
 import GF.Compile.Compute.Concrete
+import GF.Data.Operations(Err(..))
 import PGF2.Transactions
 import qualified Data.Map.Strict as Map
 import Control.Monad
+import Data.List(mapAccumL)
+import Debug.Trace
 
 generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
 generatePMCFG opts cwd gr cmo@(cm,cmi) = do
@@ -38,35 +42,40 @@ addPMCFG opts cwd gr cmi 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
+    ((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do
-                                                 return ((d+1,r),v))
+                                   let (ms',_,t) = type2metaTerm gr d ms 0 [] ty
-                          (0,0) ctxt
+                                   tnk <- trace (show (ppTerm Unqualified 0 t)) $ newThunk [] t
+                                   return ((d+1,ms'),tnk))
+                               (0,Map.empty) ctxt
+    sequence_ [newMeta (Just ty) i | (i,ty) <- Map.toList ms]
     v <- eval [] t args
     (lins,_) <- value2pmcfg v []
     return (reverse lins)
 
-type2metaValue :: Int -> Int -> Type -> EvalM s (Int,Thunk s)
+type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,Ident)] -> Type -> (Map.Map MetaId Type,Int,Term)
-type2metaValue d r (Sort s) | s == cStr = do
+type2metaTerm gr d ms r rs (Sort s) | s == cStr =
-  tnk <- newEvaluatedThunk (VSymCat d r)
+  (ms,r+1,TSymCat d r rs)
-  return (r+1,tnk)
+type2metaTerm gr d ms r rs (RecType lbls) =
-type2metaValue d r (RecType lbls) = do
+  let ((ms',r'),ass) = mapAccumL (\(ms,r) (lbl,ty) -> let (ms',r',t) = type2metaTerm gr d ms r rs ty
-  (r,lbls) <- mapAccumM (\i (lbl,ty) -> do (i,tnk) <- type2metaValue d i ty
+                                                      in ((ms',r'),(lbl,(Just ty,t))))
-                                           return (i,(lbl,tnk)))
+                                 (ms,r) lbls
-                        r lbls
+  in (ms',r',R ass)  
-  tnk <- newEvaluatedThunk (VR lbls)
+type2metaTerm gr d ms r rs (Table p q) =
-  return (r,tnk)
+  let pv = identS ('p':show (length rs))
-type2metaValue d r (Table p q) = do
+      (ms',r',t) = type2metaTerm gr d ms r ((r'-r,pv):rs) q
-  ts <- getAllParamValues p
+      count = case allParamValues gr p of
-  (r,vs) <- mapAccumM (\r _ -> type2metaValue d r q) r ts
+                Ok ts   -> length ts
-  tnk <- newEvaluatedThunk (VV p vs)
+                Bad msg -> error msg
-  return (r, tnk)
+  in (ms',(r'-r)*count,T (TTyped p) [(PV pv,t)])
-type2metaValue d r ty@(QC q) = do
+type2metaTerm gr d ms r rs ty@(QC q) =
-  tnk <- newMeta (Just ty) 0
+  let i = Map.size ms + 1
-  return (r, tnk)
+  in (Map.insert i ty ms,r,Meta i)
 
 value2pmcfg (VSusp tnk env vs k) lins = do
   st <- getMeta tnk
   case st of
+    Unevaluated _ t         -> do v <- eval env t vs
+                                  value2pmcfg v lins
     Evaluated v             -> do v <- apply v vs
                                   value2pmcfg v lins
     Unbound (Just (QC q)) _ -> do (m,ps) <- lookupParams q
@@ -92,16 +101,22 @@ value2pmcfg (VR as) lins = do
                     tnk <- newEvaluatedThunk v
                     return (lins,(lbl,tnk):as)
 value2pmcfg v lins = do
-  case  value2lin v of
+  lin <- value2lin v
-    Just lin -> return (lin:lins,VR [])
+  return (lin:lins,VR [])
-    Nothing  -> do t <- value2term 0 v
-                   evalError ("the term" <+> ppTerm Unqualified 0 t $$
-                              "cannot be evaluated at compile time.")
 
-value2lin (VStr s)      = Just [SymKS s]
+value2lin (VStr s)         = return [SymKS s]
-value2lin (VSymCat d r) = Just [SymCat d r]
+value2lin (VSymCat d r rs) = do rs <- forM rs $ \(i,tnk) -> do
-value2lin (VC vs)       = fmap concat (mapM value2lin vs)
+                                        v <- force tnk []
-value2lin _             = Nothing
+                                        j <- case v of
+                                               VMeta tnk _ _ -> do st <- getMeta tnk
+                                                                   case st of
+                                                                     Unbound _ j -> return j
+                                        return (i,j)
+                                return [SymCat d r rs]
+value2lin (VC vs)          = fmap concat (mapM value2lin vs)
+value2lin v                = do t <- value2term 0 v
+                                evalError ("the term" <+> ppTerm Unqualified 0 t $$
+                                           "cannot be evaluated at compile time.")
 
 mapAccumM f a []     = return (a,[])
 mapAccumM f a (x:xs) = do (a, y) <- f a x

src/compiler/GF/Grammar/Binary.hs

@@ -308,7 +308,7 @@ instance Binary Literal where
              _ -> decodingError
 
 instance Binary Symbol where
-  put (SymCat n l)       = putWord8 0 >> put (n,l)
+  put (SymCat d r rs)    = putWord8 0 >> put (d,r,rs)
   put (SymLit n l)       = putWord8 1 >> put (n,l)
   put (SymVar n l)       = putWord8 2 >> put (n,l)
   put (SymKS ts)         = putWord8 3 >> put ts
@@ -321,7 +321,7 @@ instance Binary Symbol where
   put SymALL_CAPIT       = putWord8 10
   get = do tag <- getWord8
            case tag of
-             0 -> liftM2 SymCat get get
+             0 -> liftM3 SymCat get get get
              1 -> liftM2 SymLit get get
              2 -> liftM2 SymVar get get
              3 -> liftM  SymKS  get

src/compiler/GF/Grammar/Grammar.hs

@@ -74,7 +74,7 @@ import GF.Infra.Location
 import GF.Data.Operations
 
 import PGF2(BindType(..))
-import PGF2.Transactions(Symbol)
+import PGF2.Transactions(Symbol,LIndex)
 
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
@@ -391,6 +391,7 @@ data Term =
 
  | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
  | Strs [Term]                   -- ^ conditioning prefix strings: @strs {s ; ...}@
+ | TSymCat Int LIndex [(LIndex,Ident)]
   deriving (Show, Eq, Ord)
 
 -- | Patterns

src/compiler/GF/Grammar/Printer.hs

@@ -234,6 +234,7 @@ ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
 ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
 ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
 ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (TSymCat i r rs) = pp '<' <> pp i <> pp ',' <> ppLinFun pp r rs <> pp '>'
 
 ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
 
@@ -356,16 +357,31 @@ ppLit (PGF2.LStr s) = pp (show s)
 ppLit (PGF2.LInt n) = pp n
 ppLit (PGF2.LFlt d) = pp d
 
-ppSymbol (PGF2.SymCat d r) = pp '<' <> pp d <> pp ',' <> pp r <> pp '>'
+ppSymbol (PGF2.SymCat d r rs)= pp '<' <> pp d <> pp ',' <> ppLinFun ppIntVar r rs <> pp '>'
-ppSymbol (PGF2.SymLit 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 '>'
+ppSymbol (PGF2.SymVar d r)   = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
-ppSymbol (PGF2.SymKS t)    = doubleQuotes (pp t)
+ppSymbol (PGF2.SymKS t)      = doubleQuotes (pp t)
-ppSymbol PGF2.SymNE        = pp "nonExist"
+ppSymbol PGF2.SymNE          = pp "nonExist"
-ppSymbol PGF2.SymBIND      = pp "BIND"
+ppSymbol PGF2.SymBIND        = pp "BIND"
-ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND"
+ppSymbol PGF2.SymSOFT_BIND   = pp "SOFT_BIND"
-ppSymbol PGF2.SymSOFT_SPACE= pp "SOFT_SPACE"
+ppSymbol PGF2.SymSOFT_SPACE  = pp "SOFT_SPACE"
-ppSymbol PGF2.SymCAPIT     = pp "CAPIT"
+ppSymbol PGF2.SymCAPIT       = pp "CAPIT"
-ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT"
+ppSymbol PGF2.SymALL_CAPIT   = pp "ALL_CAPIT"
 ppSymbol (PGF2.SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
 
+ppLinFun ppParam r rs
+  | r == 0 && not (null rs) = hcat (intersperse (pp '+') (       map ppTerm rs))
+  | otherwise               = hcat (intersperse (pp '+') (pp r : map ppTerm rs))
+  where
+    ppTerm (i,p)
+      | i == 1    = ppParam p
+      | otherwise = pp i <> pp '*' <> ppParam p
+
+ppIntVar p
+  | i == 0    = pp (chars !! j)
+  | otherwise = pp (chars !! j : show i)
+  where
+    chars = "ijklmnopqr"
+    (i,j) = p `divMod` (length chars)
+
 ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps)

src/runtime/haskell/PGF2/Transactions.hsc

@@ -153,8 +153,9 @@ setAbstractFlag name value = Transaction $ \c_db c_revision c_exn ->
 
 type Token  = String
 type LIndex = Int
+type Param  = Int
 data Symbol
-  = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
+  = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex [(LIndex,Param)]
   | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
   | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
   | SymKS Token