generate and store the ranges for all linearization rules

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

@@ -8,7 +8,7 @@ module GF.Compile.Compute.Concrete
            , EvalM, runEvalM, evalError
            , eval, apply, force, value2term, patternMatch
            , newThunk, newEvaluatedThunk
-           , newResiduation, newNarrowing
+           , newResiduation, newNarrowing, getVariables
            , getRef
            , getResDef, getInfo, getAllParamValues
            ) where
@@ -387,16 +387,25 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
       where
         bind gr k mt r s m []             = return (Success r)
         bind gr k mt r s m ((p, ctxt):ps) = do
-          tnks <- mapM (\(_,_,ty) -> newSTRef (Narrowing 0 ty)) ctxt
+          (mt',tnks) <- mkArgs mt ctxt
           let v = VApp (m,p) tnks
           writeSTRef i (Evaluated v)
           res <- case ki v of
-                   EvalM f -> f gr k mt r
+                   EvalM f -> f gr k mt' r
           writeSTRef i s
           case res of
             Fail msg  -> return (Fail msg)
             Success r -> bind gr k mt r s m ps
 
+        mkArgs mt []              = return (mt,[])
+        mkArgs mt ((_,_,ty):ctxt) = do
+          let i = case Map.maxViewWithKey mt of
+                    Just ((i,_),_) -> i+1
+                    _              -> 0
+          tnk  <- newSTRef (Narrowing i ty)
+          (mt,tnks) <- mkArgs (Map.insert i tnk mt) ctxt
+          return (mt,tnk:tnks)
+
 value2term i (VApp q tnks) =
   foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (QC q) tnks
 value2term i (VMeta m env tnks) = do
@@ -619,6 +628,22 @@ newNarrowing i ty = EvalM $ \gr k mt r ->
            Nothing  -> do tnk <- newSTRef (Narrowing i ty)
                           k tnk (Map.insert i tnk mt) r
 
+getVariables :: EvalM s [(LVar,LIndex)]
+getVariables = EvalM $ \gr k mt r -> do
+  ps <- metas2params gr (Map.elems mt)
+  k ps mt r
+  where
+    metas2params gr []         = return []
+    metas2params gr (tnk:tnks) = do
+      st <- readSTRef tnk
+      case st of
+        Narrowing i ty -> do let range = case allParamValues gr ty of
+                                           Ok ts   -> length ts
+                                           Bad msg -> error msg
+                             params <- metas2params gr tnks
+                             return ((i,range):params)
+        _              -> metas2params gr tnks
+
 getRef tnk = EvalM $ \gr k mt r -> readSTRef tnk >>= \st -> k st mt r
 
 force tnk = EvalM $ \gr k mt r -> do 

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -52,7 +52,8 @@ pmcfgForm gr t ctxt ty =
     lins <- mapM str2lin lins
     (r,rs,_) <- compute params
     args <- zipWithM tnk2lparam args ctxt
-    return (Production args (LParam r rs) (reverse lins))
+    vars <- getVariables
+    return (Production vars args (LParam r rs) (reverse lins))
     where
       tnk2lparam tnk (_,_,ty) = do
         v <- force tnk

src/compiler/GF/Grammar/Binary.hs

@@ -112,8 +112,8 @@ instance Binary PArg where
   get = get >>= \(x,y) -> return (PArg x y)
 
 instance Binary Production where
-  put (Production args res rules) = put (args,res,rules)
-  get = get >>= \(args,res,rules) -> return (Production args res rules)
+  put (Production ps args res rules) = put (ps,args,res,rules)
+  get = get >>= \(ps,args,res,rules) -> return (Production ps args res rules)
 
 instance Binary Info where
   put (AbsCat x)       = putWord8 0 >> put x

src/compiler/GF/Grammar/Printer.hs

@@ -158,8 +158,11 @@ 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 args res lins) =
+ppPmcfgRule id arg_cats res_cat (Production vars args res lins) =
   pp id <+> (':' <+>
+             (if null vars
+                then empty
+                else "∀{" <> hsep (punctuate ',' [ppLVar v <> '<' <> m | (v,m) <- vars]) <> '}'  <+> '.') <+>
              (if null args
                 then empty
                 else hsep (intersperse (pp '*') (zipWith ppPArg arg_cats args)) <+> "->") <+>