fixed bug leading to looping in Devel.Compute

2 files changed, 29 insertions, 17 deletions

diff --git a/src/GF/Devel/Compute.hs b/src/GF/Devel/Compute.hs
index f92da26c9..c0a99f4fd 100644
--- a/src/GF/Devel/Compute.hs
+++ b/src/GF/Devel/Compute.hs
@@ -45,9 +45,9 @@ computeTerm = computeTermOpt False
 -- have already been computed (mainly with -optimize=noexpand in .gfr)
 
 computeTermOpt :: Bool -> SourceGrammar -> Substitution -> Term -> Err Term
-computeTermOpt rec gr = comp where
+computeTermOpt rec gr = comput True where
 
-   comp g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging 
+   comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging 
               case t of
 
      Q (IC "Predef") _ -> return t
@@ -62,9 +62,14 @@ computeTermOpt rec gr = comp where
          _ | t == t' -> return t
          _ -> comp g t'
 
-     Abs x b -> do 
-       b' <- comp (ext x (Vr x) g) b
-       return $ Abs x b'
+     -- Abs x@(IA _) b -> do 
+     Abs x b | full -> do 
+       let (xs,b1) = termFormCnc t   
+       b' <- comp ([(x,Vr x) | x <- xs] ++ g) b1
+       return $ mkAbs xs b'
+     --  b' <- comp (ext x (Vr x) g) b
+     --  return $ Abs x b'
+     Abs _ _ -> return t -- hnf
 
      Let (x,(_,a)) b -> do
        a' <- comp g a
@@ -76,10 +81,9 @@ computeTermOpt rec gr = comp where
        return $ Prod x a' b'
 
      -- beta-convert
-
      App f a -> case appForm t of
       (h,as) | length as > 1 -> do
-        h' <- comp g h
+        h' <- hnf g h
         as' <- mapM (comp g) as
         case h' of
           _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as')
@@ -163,9 +167,8 @@ computeTermOpt rec gr = comp where
      S t v -> do
 
       t'     <- case t of
----- why not? ResFin.Agr "has no values"
-----        T (TComp _) _ -> return t
-----        V _ _ -> return t
+--        T _ _ -> return t
+--        V _ _ -> return t
         _ -> comp g t
 
       v'     <- comp g v
@@ -295,7 +298,7 @@ computeTermOpt rec gr = comp where
 ----       return $ V ty (map snd cs')
        return $ T i cs'
      --- this means some extra work; should implement TSh directly
-     TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps] --- OBSOLETE
+     TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps]
 
      T i cs -> do
        pty0 <- getTableType i
@@ -303,18 +306,18 @@ computeTermOpt rec gr = comp where
        case allParamValues gr ptyp of
          Ok vs -> do
 
-           cs'  <- mapM (compBranchOpt g) cs  ---- why is this needed??
+           cs'  <- mapM (compBranchOpt g) cs
            sts  <- mapM (matchPattern cs') vs 
            ts   <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
            ps   <- mapM term2patt vs
            let ps' = ps --- PT ptyp (head ps) : tail ps
-----           return $ V ptyp ts -- to save space ---- why doesn't this work??
+----           return $ V ptyp ts -- to save space, just course of values
            return $ T (TComp ptyp) (zip ps' ts)
          _ -> do
            cs' <- mapM (compBranch g) cs
            return $ T i cs'  -- happens with variable types
 
-     Alias c a d -> do --- OBSOLETE
+     Alias c a d -> do
        d' <- comp g d
        return $ Alias c a d'  -- alias only disappears in certain redexes
 
@@ -324,7 +327,7 @@ computeTermOpt rec gr = comp where
     where
 
      compApp g (App f a) = do
-       f' <- comp g f
+       f' <- hnf g f
        a' <- comp g a
        case (f',a') of
          (Abs x b, FV as) -> 
@@ -332,6 +335,7 @@ computeTermOpt rec gr = comp where
          (_, FV as)  -> mapM (\c -> comp g (App f' c)) as >>= return . variants
          (FV fs, _)  -> mapM (\c -> comp g (App c a')) fs >>= return . variants
          (Abs x b,_) -> comp (ext x a' g) b
+
          (QC _ _,_)  -> returnC $ App f' a'
 
          (Alias _ _ d, _) -> comp g (App d a')
@@ -343,6 +347,9 @@ computeTermOpt rec gr = comp where
            (t',b) <- appPredefined (App f' a')
            if b then return t' else comp g t'
 
+     hnf  = comput False
+     comp = comput True
+
      look p c
        | rec       = lookupResDef gr p c >>= comp []
        | otherwise = lookupResDef gr p c
@@ -407,6 +414,7 @@ computeTermOpt rec gr = comp where
        cs' <- mapM (comp g) [(f v) | v <- cs]
        return $ S (V i cs') e
 
+
 -- | argument variables cannot be glued
 checkNoArgVars :: Term -> Err Term
 checkNoArgVars t = case t of
diff --git a/src/GF/Devel/GetGrammar.hs b/src/GF/Devel/GetGrammar.hs
index 49546b6ea..4b54f789d 100644
--- a/src/GF/Devel/GetGrammar.hs
+++ b/src/GF/Devel/GetGrammar.hs
@@ -15,7 +15,7 @@
 module GF.Devel.GetGrammar where
 
 import GF.Data.Operations
-import qualified GF.Data.ErrM as E ----
+import qualified GF.Source.ErrM as E
 
 import GF.Devel.UseIO
 import GF.Grammar.Grammar
@@ -49,6 +49,10 @@ getSourceModule opts file0 = do
     _ -> return file0
   string    <- readFileIOE file
   let tokens = myLexer string
-  mo1  <- ioeErr $ {- err2err $ -} pModDef tokens
+  mo1  <- ioeErr $ err2err $ pModDef tokens
   ioeErr $ transModDef mo1
 
+err2err :: E.Err a -> Err a
+err2err (E.Ok v) = Ok v
+err2err (E.Bad s) = Bad s
+