partial support for runtime parameters

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
-                                                 return ((d+1,r),v))
-                          (0,0) ctxt
+    ((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do
+                                   let (ms',_,t) = type2metaTerm gr d ms 0 [] ty
+                                   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)
-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 ty@(QC q) = do
-  tnk <- newMeta (Just ty) 0
-  return (r, tnk)
+type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,Ident)] -> Type -> (Map.Map MetaId Type,Int,Term)
+type2metaTerm gr d ms r rs (Sort s) | s == cStr =
+  (ms,r+1,TSymCat d r rs)
+type2metaTerm gr d ms r rs (RecType lbls) =
+  let ((ms',r'),ass) = mapAccumL (\(ms,r) (lbl,ty) -> let (ms',r',t) = type2metaTerm gr d ms r rs ty
+                                                      in ((ms',r'),(lbl,(Just ty,t))))
+                                 (ms,r) lbls
+  in (ms',r',R ass)  
+type2metaTerm gr d ms r rs (Table p q) =
+  let pv = identS ('p':show (length rs))
+      (ms',r',t) = type2metaTerm gr d ms r ((r'-r,pv):rs) q
+      count = case allParamValues gr p of
+                Ok ts   -> length ts
+                Bad msg -> error msg
+  in (ms',(r'-r)*count,T (TTyped p) [(PV pv,t)])
+type2metaTerm gr d ms r rs ty@(QC q) =
+  let i = Map.size ms + 1
+  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
-    Just lin -> return (lin:lins,VR [])
-    Nothing  -> do t <- value2term 0 v
-                   evalError ("the term" <+> ppTerm Unqualified 0 t $$
-                              "cannot be evaluated at compile time.")
+  lin <- value2lin v
+  return (lin:lins,VR [])
 
-value2lin (VStr s)      = Just [SymKS s]
-value2lin (VSymCat d r) = Just [SymCat d r]
-value2lin (VC vs)       = fmap concat (mapM value2lin vs)
-value2lin _             = Nothing
+value2lin (VStr s)         = return [SymKS s]
+value2lin (VSymCat d r rs) = do rs <- forM rs $ \(i,tnk) -> do
+                                        v <- force tnk []
+                                        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