diff --git a/src/GF/Grammar/AbsCompute.hs b/src/GF/Grammar/AbsCompute.hs index b2139f90a..593c6d96f 100644 --- a/src/GF/Grammar/AbsCompute.hs +++ b/src/GF/Grammar/AbsCompute.hs @@ -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