debugging AbsCompute

1 files changed, 17 insertions, 11 deletions

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