From 2bd22e078aa0205f60bb414d2e7f17d73db1eaea Mon Sep 17 00:00:00 2001
From: aarne <unknown>
Date: Mon, 1 Nov 2004 21:41:18 +0000
Subject: some bug fixes in type check and solve

---
 src/GF/Grammar/AbsCompute.hs | 20 ++++++++++++--------
 1 file changed, 12 insertions(+), 8 deletions(-)

(limited to 'src/GF/Grammar/AbsCompute.hs')

diff --git a/src/GF/Grammar/AbsCompute.hs b/src/GF/Grammar/AbsCompute.hs
index d80fc57f3..55d051f81 100644
--- a/src/GF/Grammar/AbsCompute.hs
+++ b/src/GF/Grammar/AbsCompute.hs
@@ -17,10 +17,13 @@ compute :: GFCGrammar -> Exp -> Err Exp
 compute = computeAbsTerm
 
 computeAbsTerm :: GFCGrammar -> Exp -> Err Exp
-computeAbsTerm gr = computeAbsTermIn gr []
+computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
 
-computeAbsTermIn :: GFCGrammar -> [Ident] -> Exp -> Err Exp
-computeAbsTermIn gr xs e = errIn ("computing" +++ prt e) $ compt xs e where
+--- a hack to make compute work on source grammar as well
+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)
@@ -46,11 +49,12 @@ computeAbsTermIn gr xs e = errIn ("computing" +++ prt e) $ compt xs e where
         _ -> do
           return $ mkAbs yy $ mkApp f aa'
 
-  look (Q m f) = case lookupAbsDef gr m f of
-    Ok (Just EData) -> Nothing  -- canonical --- should always be QC
-    Ok md -> md
-    _ -> Nothing
-  look _ = Nothing
+  look t = case t of
+     (Q m f) -> case lookd m f of
+       Ok (Just EData) -> Nothing  -- canonical --- should always be QC
+       Ok md -> md
+       _ -> Nothing
+     _ -> Nothing
 
 beta :: [Ident] -> Exp -> Exp
 beta vv c = case c of
-- 
cgit v1.2.3