msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

GF.Compile.Compute.ConcreteNew: add dynamic table conversion

Browse Source 
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 {...} ; ... }
This commit is contained in:
hallgren
2015-03-04 18:20:16 +00:00
parent 814c80124b
commit 854fec6d3a
1 changed files with 24 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

39
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

@@ -323,19 +323,28 @@ valueTable env i cs =
case i of case i of
TComp ty -> do pvs <- paramValues env ty TComp ty -> do pvs <- paramValues env ty
((VV ty pvs .) # sequence) # mapM (value env.snd) cs ((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 where
keep _ = do vty <- value env =<< getTableType i dynamic cs' ty _ = cases cs' # value env ty
cases vty # mapM valueCase cs
cases vty cs vs = VT wild (vty vs) (mapSnd ($vs) cs) 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 wild = case i of TWild _ -> True; _ -> False
convert :: Err OpenValue convertv cs' vty = convert' cs' =<< paramValues'' env pty
convert = do ((pty,vs),pvs) <- paramValues' env =<< getTableType i where pty = value2term (gloc env) [] vty
cs' <- mapM valueCase cs
sts <- mapM (matchPattern cs') vs convert cs' ty = convert' cs' =<< paramValues' env ty
return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env)
(mapFst ($vs) sts) 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 valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p
pvs <- linPattVars p' pvs <- linPattVars p'
@@ -354,11 +363,11 @@ valueTable env i cs =
paramValues env ty = snd # paramValues' env ty paramValues env ty = snd # paramValues' env ty
paramValues' env ty = do let ge = global env paramValues' env ty = paramValues'' env =<< nfx (global env) ty
pty <- nfx ge ty
ats <- allParamValues (srcgr env) pty paramValues'' env pty = do ats <- allParamValues (srcgr env) pty
pvs <- mapM (eval ge) ats pvs <- mapM (eval (global env)) ats
return ((pty,ats),pvs) return ((pty,ats),pvs)
push' p bs xs = if length bs/=length xs push' p bs xs = if length bs/=length xs
then bug $ "push "++show (p,bs,xs) then bug $ "push "++show (p,bs,xs)