GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-24 03:52:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

fixed bug with prawitz transform of course-of-values tables in Compute

Browse Source
This commit is contained in:
aarne
2007-11-12 12:36:40 +00:00
parent b801149fbf
commit 6158445114
2 changed files with 16 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
src/GF/Devel/GrammarToGFCC.hs
View File

@@ -391,10 +391,15 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
--- this is mainly needed for parameter record projections --- this is mainly needed for parameter record projections
---- was: errVal t $ Compute.computeConcreteRec cgr t ---- was: errVal t $ Compute.computeConcreteRec cgr t
comp t = case t of comp t = case t of
S (V typ ts) v0 -> errVal t $ do T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should
T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should
V typ ts -> V typ (map comp ts)
S (V typ ts) v0 -> err error id $ do
let v = comp v0 let v = comp v0
vs <- Look.allParamValues cgr typ vs <- Look.allParamValues cgr typ
return $ maybe t (comp . (ts !!)) $ lookup v (zip vs [0 .. length vs - 1]) return $ maybe t ---- (error (prt t)) -- should be safe after doVar though
(comp . (ts !!)) $ lookup v (zip vs [0 .. length vs - 1])
R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r]
P (R r) l -> maybe t (comp . snd) $ lookup l r P (R r) l -> maybe t (comp . snd) $ lookup l r
_ -> GM.composSafeOp comp t _ -> GM.composSafeOp comp t
@@ -481,6 +486,6 @@ unlockTyp = filter notlock where
_ -> True _ -> True
prtTrace tr n = prtTrace tr n =
trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show tr ++++ show n) n trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show n) n
prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n

8
src/GF/Grammar/Compute.hs
View File

@@ -90,6 +90,7 @@ computeTermOpt rec gr = comp where
(Alias _ _ d, _) -> comp g (App d a') (Alias _ _ d, _) -> comp g (App d a')
(S (T i cs) e,_) -> prawitz g i (flip App a') cs e (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
(S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
_ -> do _ -> do
(t',b) <- appPredefined (App f' a') (t',b) <- appPredefined (App f' a')
@@ -122,6 +123,7 @@ computeTermOpt rec gr = comp where
Alias _ _ r -> comp g (P r l) Alias _ _ r -> comp g (P r l)
S (T i cs) e -> prawitz g i (flip P l) cs e S (T i cs) e -> prawitz g i (flip P l) cs e
S (V i cs) e -> prawitzV g i (flip P l) cs e
_ -> returnC $ P t' l _ -> returnC $ P t' l
@@ -197,6 +199,7 @@ computeTermOpt rec gr = comp where
Alias _ _ d -> comp g (S d v') Alias _ _ d -> comp g (S d v')
S (T i cs) e -> prawitz g i (flip S v') cs e S (T i cs) e -> prawitz g i (flip S v') cs e
S (V i cs) e -> prawitzV g i (flip S v') cs e
_ -> returnC $ S t' v' _ -> returnC $ S t' v'
-- normalize away empty tokens -- normalize away empty tokens
@@ -219,6 +222,8 @@ computeTermOpt rec gr = comp where
(S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
(s, S (T i cs) e) -> prawitz g i (Glue s) cs e (s, S (T i cs) e) -> prawitz g i (Glue s) cs e
(S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e
(s, S (V i cs) e) -> prawitzV g i (Glue s) cs e
(_,Empty) -> return x (_,Empty) -> return x
(Empty,_) -> return y (Empty,_) -> return y
(K a, K b) -> return $ K (a ++ b) (K a, K b) -> return $ K (a ++ b)
@@ -373,6 +378,9 @@ computeTermOpt rec gr = comp where
prawitz g i f cs e = do prawitz g i f cs e = do
cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
return $ S (T i cs') e return $ S (T i cs') e
prawitzV g i f cs e = do
cs' <- mapM (comp g) [(f v) | v <- cs]
return $ S (V i cs') e
-- | argument variables cannot be glued -- | argument variables cannot be glued
checkNoArgVars :: Term -> Err Term checkNoArgVars :: Term -> Err Term