From 1196bbe21f21b0922e12fd3423cb6aa2689a052f Mon Sep 17 00:00:00 2001 From: aarne Date: Sat, 15 Mar 2008 19:00:09 +0000 Subject: [PATCH] fixed bug leading to looping in Devel.Compute --- lib/resource/finnish/LexiconFin.gf | 10 ++++---- lib/resource/finnish/ParadigmsFin.gf | 32 ++++++++++++++++------- src/GF/Devel/Compute.hs | 38 +++++++++++++++++----------- src/GF/Devel/GetGrammar.hs | 8 ++++-- 4 files changed, 57 insertions(+), 31 deletions(-) diff --git a/lib/resource/finnish/LexiconFin.gf b/lib/resource/finnish/LexiconFin.gf index 45f7c645c..feff5be3a 100644 --- a/lib/resource/finnish/LexiconFin.gf +++ b/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" ; diff --git a/lib/resource/finnish/ParadigmsFin.gf b/lib/resource/finnish/ParadigmsFin.gf index 73b67dc88..3e84b5935 100644 --- a/lib/resource/finnish/ParadigmsFin.gf +++ b/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 = 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 +