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

debugging AbsCompute

Browse Source
This commit is contained in:
aarne
2006-12-17 22:34:03 +00:00
parent 44af93a9c9
commit 9ab11fe720
1 changed files with 17 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

28
src/GF/Grammar/AbsCompute.hs
View File

@@ -29,6 +29,8 @@ import GF.Grammar.LookAbs
import GF.Grammar.PatternMatch
import GF.Grammar.Compute
import Debug.Trace
import Control.Monad (liftM, liftM2)
compute :: GFCGrammar -> Exp -> Err Exp
@@ -43,26 +45,28 @@ type LookDef = Ident -> Ident -> Err (Maybe Term)
computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
compt vv t = case t of
Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
Abs x b -> liftM (Abs x) (compt (x:vv) b)
-- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
-- Abs x b -> liftM (Abs x) (compt (x:vv) b)
_ -> do
let t' = beta vv t
(yy,f,aa) <- termForm t'
let vv' = yy ++ vv
aa' <- mapM (compt vv') aa
case look f of
Just (Eqs eqs) -> case findMatch eqs aa' of
Just (Eqs eqs) -> ----trace ("matching" +++ prt f) $
case findMatch eqs aa' of
Ok (d,g) -> do
let (xs,ts) = unzip g
ts' <- alphaFreshAll vv' ts ---
let g' = zip xs ts'
d' <- compt vv' $ substTerm vv' g' d
return $ mkAbs yy $ d'
_ -> do
return $ mkAbs yy $ mkApp f aa'
_ -> ---- trace ("no match" +++ prt t') $
do
let v = mkApp f aa'
return $ mkAbs yy $ v
Just d -> do
d' <- compt vv' d
da <- ifNull (return d') (compt vv' . mkApp d') aa'
da <- compt vv' $ mkApp d aa'
return $ mkAbs yy $ da
_ -> do
return $ mkAbs yy $ mkApp f aa'
@@ -77,12 +81,14 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
beta :: [Ident] -> Exp -> Exp
beta vv c = case c of
App (Abs x b) a -> beta vv $ substTerm vv [xvv] (beta (x:vv) b)
where xvv = (x,beta vv a)
Let (x,(_,a)) b -> beta vv $ substTerm vv [xvv] (beta (x:vv) b)
where xvv = (x,beta vv a)
App f a -> let (a',f') = (beta vv a, beta vv f) in
(if a'==a && f'==f then id else beta vv) $ App f' a'
App f a ->
let (a',f') = (beta vv a, beta vv f) in
case f' of
Abs x b -> beta vv $ substTerm vv [xvv] (beta (x:vv) b)
where xvv = (x,beta vv a)
_ -> (if a'==a && f'==f then id else beta vv) $ App f' a'
Prod x a b -> Prod x (beta vv a) (beta (x:vv) b)
Abs x b -> Abs x (beta (x:vv) b)
_ -> c