From 0ea372f230f57371fcb8910e51f9c09f2567ee6f Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Wed, 4 Mar 2015 18:20:16 +0000
Subject: [PATCH] GF.Compile.Compute.ConcreteNew: add dynamic table conversion

If the enumaration of table parameter values fails during the static
traversal phase, try again in the dynamic computation phase, when the values
of bound variables are known.

This is necessary to properly deal with generic table construction in opers,
like the ones found in prelude/Coordination.gf, e.g.

  consTable : (P : PType) -> ... = \P ... -> {s1 = table P {...} ; ... }
---
 .../GF/Compile/Compute/ConcreteNew.hs         | 39 ++++++++++++-------
 1 file changed, 24 insertions(+), 15 deletions(-)

diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
index 64bfeec55..5183ebf32 100644
--- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
@@ -323,19 +323,28 @@ valueTable env i cs =
     case i of
       TComp ty -> do pvs <- paramValues env ty
                      ((VV ty pvs .) # sequence) # mapM (value env.snd) cs
-      _ -> err keep return convert
+      _ -> do ty <- getTableType i
+              cs' <- mapM valueCase cs
+              err (dynamic cs' ty) return (convert cs' ty)
   where
-    keep _ = do vty <- value env =<< getTableType i
-                cases vty # mapM valueCase cs
-    cases vty cs vs = VT wild (vty vs) (mapSnd ($vs) cs)
+    dynamic cs' ty _ = cases cs' # value env ty
+
+    cases cs' vty vs = err keep ($vs) (convertv cs' (vty vs))
+      where
+        keep msg = --trace (msg++"\n"++render (ppT 0 (T i cs))) $
+                   VT wild (vty vs) (mapSnd ($vs) cs')
+
     wild = case i of TWild _ -> True; _ -> False
 
-    convert :: Err OpenValue
-    convert = do ((pty,vs),pvs) <- paramValues' env =<< getTableType i
-                 cs'  <- mapM valueCase cs
-                 sts  <- mapM (matchPattern cs') vs 
-                 return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env)
-                                                   (mapFst ($vs) sts)
+    convertv cs' vty = convert' cs' =<< paramValues'' env pty
+      where pty = value2term (gloc env) [] vty
+
+    convert cs' ty = convert' cs' =<< paramValues' env ty
+
+    convert' cs' ((pty,vs),pvs) =
+      do sts  <- mapM (matchPattern cs') vs
+         return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env)
+                                           (mapFst ($vs) sts)
 
     valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p
                          pvs <- linPattVars p'
@@ -354,11 +363,11 @@ valueTable env i cs =
 
 paramValues env ty = snd # paramValues' env ty
 
-paramValues' env ty = do let ge = global env
-                         pty <- nfx ge ty
-                         ats <- allParamValues (srcgr env) pty
-                         pvs <- mapM (eval ge) ats
-                         return ((pty,ats),pvs)
+paramValues' env ty = paramValues'' env =<< nfx (global env) ty
+
+paramValues'' env pty = do ats <- allParamValues (srcgr env) pty
+                           pvs <- mapM (eval (global env)) ats
+                           return ((pty,ats),pvs)
 
 push' p bs xs = if length bs/=length xs
                 then bug $ "push "++show (p,bs,xs)