fixed bug leading to looping in Devel.Compute

lib/resource/finnish/LexiconFin.gf

@@ -114,7 +114,7 @@ lin
   leather_N = mkN "nahka" ; --- nahan
   leave_V2 = mkV2 (mkV "jättää") ;
   like_V2 = mkV2 (mkV "pitää") elative ;
-  listen_V2 = mkV2 (mkV "kuunnella" "kuuntelen" "kuunteli") partitive ;
+  listen_V2 = mkV2 (mkV "kuunnella" "kuunteli") partitive ;
   live_V = mkV "elää" ;
   long_A = mkA (mkN "pitkä") "pitempi" "pisin" ;
   lose_V2 = mkV2 (mkV "hävitä" "hävisi") ; --- hukata
@@ -247,7 +247,7 @@ lin
   dull_A = mkA (mkN "tylsä") "tylsempi" "tylsin" ;
   full_A = mkA (mk3N "täysi" "täyden" "täysiä") "täydempi" "täysin" ;
   heavy_A = mkA "raskas" ;
-  near_A = mkA "läheinen" ;
+  near_A = mkA (mkN "läheinen") ;
   rotten_A = mkA "mätä" ;
   round_A = mkA "pyöreä" ;
   sharp_A = mkA "terävä" ;
@@ -338,8 +338,8 @@ lin
   hold_V2 = mkV2 (mkV "pitää") cpartitive ;
   hunt_V2 = mkV2 (mkV "metsästää") cpartitive ;
   kill_V2 = mkV2 (mkV "tappaa") ;
-  laugh_V = mkV "nauraa" "nauran" "nauroi" ;
-  lie_V = mkV "maata" "makaan" "makasi" ;
+  laugh_V = mkV "nauraa" "nauroi" ;
+  lie_V = mkV "maata" "makasi" ;
   play_V = mkV "pelata" ;
   pull_V2 = mkV2 (mkV "vetää") ;
   push_V2 = mkV2 (mkV "työntää") ;
@@ -376,7 +376,7 @@ lin
 
     john_PN = mkPN "Jussi" ;
     question_N = mkN "kysymys" ;
-    ready_A = mkA "valmis" ;
+    ready_A = mkA (mkN "valmis") ;
     reason_N = mkN "syy" ;
     today_Adv = mkAdv "tänään" ;
     uncertain_A = mkA "epävarma" ;

lib/resource/finnish/ParadigmsFin.gf

@@ -141,13 +141,13 @@ oper
 -- a table.
 -- The worst case needs twelve forms, as shown in the following.
 
-  mkV = overload {
-    mkV : (huutaa : Str) -> V = mk1V ;
-    mkV : (huutaa,huusi : Str) -> V = mk2V ;
-    mkV : (huutaa,huudan,huusi : Str) -> V = \x,_,y -> mk2V x y ; ----
+  mkV : overload {
+    mkV : (huutaa : Str) -> V ;
+    mkV : (huutaa,huusi : Str) -> V ;
+    mkV : (huutaa,huudan,huusi : Str) -> V ;
     mkV : (
       huutaa,huudan,huutaa,huutavat,huutakaa,huudetaan,
-      huusin,huusi,huusisi,huutanut,huudettu,huutanee : Str) -> V = mk12V ;
+      huusin,huusi,huusisi,huutanut,huudettu,huutanee : Str) -> V ;
   } ;
 
 -- All the patterns above have $nominative$ as subject case.
@@ -416,19 +416,24 @@ oper
   mkN3 = \n,c,e -> n ** {c2 = c ; c3 = e ; lock_N3 = <>} ;
   
   mkPN = overload {
-    mkPN : Str -> PN = \s -> {s = \\c => (mk1N s).s ! NCase Sg c ; lock_PN = <>} ;
+    mkPN : Str -> PN = mkPN_1 ;
     mkPN : N -> PN = \s -> {s = \\c => s.s ! NCase Sg c ; lock_PN = <>} ;
     } ;
 
+  mkPN_1 : Str -> PN = \s -> {s = \\c => (mk1N s).s ! NCase Sg c ; lock_PN = <>} ;
+
 -- adjectives
 
   mkA = overload {
-    mkA : Str -> A  = \s -> noun2adjDeg (mk1N s) ** {lock_A = <>} ;
+--    mkA : Str -> A  = \x -> noun2adjDeg (mk1N x) ** {lock_A = <>} ;
+    mkA : Str -> A  = mkA_1 ;
     mkA : N -> A = \n -> noun2adjDeg n ** {lock_A = <>} ;
     mkA : N -> (kivempaa,kivinta : Str) -> A = regAdjective ;
 --    mkA : (hyva,parempi,paras : N) -> (hyvin,paremmin,parhaiten : Str) -> A ;
   } ;
 
+  mkA_1 : Str -> A = \x -> noun2adjDeg (mk1N x) ** {lock_A = <>} ;
+
 -- auxiliaries
   mkAdjective : (_,_,_ : Adj) -> A = \hyva,parempi,paras -> 
     {s = table {
@@ -454,9 +459,18 @@ oper
 
 -- verbs
 
-  mk1V : Str -> V = \s -> vforms2V (vForms1 s) ** {sc = NPCase Nom ; lock_V = <>} ;
-  mk2V : (_,_ : Str) -> V = \s,t -> vforms2V (vForms2 s t) ** {sc = NPCase Nom ; lock_V = <>} ;
+  mkV = overload {
+    mkV : (huutaa : Str) -> V = mk1V ;
+    mkV : (huutaa,huusi : Str) -> V = mk2V ;
+    mkV : (huutaa,huudan,huusi : Str) -> V = mk3V ;
+    mkV : (
+      huutaa,huudan,huutaa,huutavat,huutakaa,huudetaan,
+      huusin,huusi,huusisi,huutanut,huudettu,huutanee : Str) -> V = mk12V ;
+  } ;
 
+  mk1V : Str -> V = \s -> vforms2V (vForms1 s) ** {sc = NPCase Nom ; lock_V = <>} ;
+  mk2V : (_,_ : Str) -> V = \x,y -> vforms2V (vForms2 x y) ** {sc = NPCase Nom ; lock_V = <>} ;
+  mk3V : (huutaa,huudan,huusi : Str) -> V = \x,_,y -> mk2V x y ; ----
   mk12V : (
       huutaa,huudan,huutaa,huutavat,huutakaa,huudetaan,
       huusin,huusi,huusisi,huutanut,huudettu,huutanee : Str) -> V = 

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

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
+