GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-22 11:19:32 -06:00
Code Issues Packages Projects Releases Wiki 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.PatternMatch
import GF.Grammar.Compute import GF.Grammar.Compute
import Debug.Trace
import Control.Monad (liftM, liftM2) import Control.Monad (liftM, liftM2)
compute :: GFCGrammar -> Exp -> Err Exp compute :: GFCGrammar -> Exp -> Err Exp
@@ -43,26 +45,28 @@ type LookDef = Ident -> Ident -> Err (Maybe Term)
computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
compt vv t = case t of compt vv t = case t of
Prod x a b -> liftM2 (Prod x) (compt vv a) (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) -- Abs x b -> liftM (Abs x) (compt (x:vv) b)
_ -> do _ -> do
let t' = beta vv t let t' = beta vv t
(yy,f,aa) <- termForm t' (yy,f,aa) <- termForm t'
let vv' = yy ++ vv let vv' = yy ++ vv
aa' <- mapM (compt vv') aa aa' <- mapM (compt vv') aa
case look f of 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 Ok (d,g) -> do
let (xs,ts) = unzip g let (xs,ts) = unzip g
ts' <- alphaFreshAll vv' ts --- ts' <- alphaFreshAll vv' ts ---
let g' = zip xs ts' let g' = zip xs ts'
d' <- compt vv' $ substTerm vv' g' d d' <- compt vv' $ substTerm vv' g' d
return $ mkAbs yy $ d' return $ mkAbs yy $ d'
_ -> do _ -> ---- trace ("no match" +++ prt t') $
return $ mkAbs yy $ mkApp f aa' do
let v = mkApp f aa'
return $ mkAbs yy $ v
Just d -> do Just d -> do
d' <- compt vv' d da <- compt vv' $ mkApp d aa'
da <- ifNull (return d') (compt vv' . mkApp d') aa'
return $ mkAbs yy $ da return $ mkAbs yy $ da
_ -> do _ -> do
return $ mkAbs yy $ mkApp f aa' 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 :: [Ident] -> Exp -> Exp
beta vv c = case c of 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) Let (x,(_,a)) b -> beta vv $ substTerm vv [xvv] (beta (x:vv) b)
where xvv = (x,beta vv a) where xvv = (x,beta vv a)
App f a -> let (a',f') = (beta vv a, beta vv f) in App f a ->
(if a'==a && f'==f then id else beta vv) $ 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) Prod x a b -> Prod x (beta vv a) (beta (x:vv) b)
Abs x b -> Abs x (beta (x:vv) b) Abs x b -> Abs x (beta (x:vv) b)
_ -> c _ -> c