diff --git a/devel/koe/Koe.gf b/devel/koe/Koe.gf index 203367bcd..afbf0261d 100644 --- a/devel/koe/Koe.gf +++ b/devel/koe/Koe.gf @@ -5,7 +5,7 @@ cat S ; NP ; VP ; fun Pred : NP -> VP -> S ; - He, She : NP ; + Je, Tu, Il, Elle, Nous, Vous, Ils, Elles : NP ; Strong : VP ; diff --git a/devel/koe/KoeFre.gf b/devel/koe/KoeFre.gf index 9841e5bc4..7b36ae67c 100644 --- a/devel/koe/KoeFre.gf +++ b/devel/koe/KoeFre.gf @@ -3,16 +3,21 @@ concrete KoeFre of Koe = { param Gen = Masc | Fem ; Num = Sg | Pl ; + Per = P1 | P2 | P3 ; oper - Agr : Type = {g : Gen ; n : Num} ; + Agr : Type = {g : Gen ; n : Num ; p : Per} ; predA : Str -> {s : Agr => Str} = \adj -> - {s = \\a => copula a.n ++ regA adj a.g a.n} ; + {s = \\a => copula a.n a.p ++ regA adj a.g a.n} ; - copula : Num -> Str = \n -> case n of { - Sg => "est" ; - Pl => "sont" + copula : Num -> Per -> Str = \n,p -> case of { + => "suis" ; + => "es" ; + => "est" ; + => "sommes" ; + => "ĂȘtes" ; + => "sont" } ; regA : Str -> Gen -> Num -> Str = \s,g,n -> case of { @@ -29,8 +34,14 @@ lincat lin Pred np vp = {s = np.s ++ vp.s ! np.a} ; - He = {s = "il" ; a = {g = Masc ; n = Sg}} ; - She = {s = "elle" ; a = {g = Fem ; n = Sg}} ; + Je = {s = "je" ; a = {g = Masc ; n = Sg ; p = P1}} ; + Tu = {s = "tu" ; a = {g = Masc ; n = Sg ; p = P2}} ; + Il = {s = "il" ; a = {g = Masc ; n = Sg ; p = P3}} ; + Elle = {s = "elle" ; a = {g = Fem ; n = Sg ; p = P3}} ; + Nous = {s = "nous" ; a = {g = Masc ; n = Pl ; p = P1}} ; + Vous = {s = "vous" ; a = {g = Masc ; n = Pl ; p = P2}} ; + Ils = {s = "ils" ; a = {g = Masc ; n = Pl ; p = P3}} ; + Elles = {s = "elles" ; a = {g = Fem ; n = Pl ; p = P3}} ; Strong = predA "fort" ; diff --git a/src/GF/Canon/GFCC/CheckGFCC.hs b/src/GF/Canon/GFCC/CheckGFCC.hs index 113a1f311..19e816e95 100644 --- a/src/GF/Canon/GFCC/CheckGFCC.hs +++ b/src/GF/Canon/GFCC/CheckGFCC.hs @@ -29,50 +29,62 @@ checkLin gfcc lang (f,t) = labelBoolIO ("happened in function " ++ printTree f) $ checkTerm (lintype gfcc lang f) $ inline gfcc lang t -inferTerm :: [Tpe] -> Term -> Maybe Tpe +inferTerm :: [Tpe] -> Term -> Err Tpe inferTerm args trm = case trm of K _ -> return str C i -> return $ ints i - V i -> if i < length args - then (return $ args !! i) - else error ("index " ++ show i) + V i -> do + testErr (i < length args) ("too large index " ++ show i) + return $ args !! i S ts -> do tys <- mapM infer ts - if all (==str) tys - then return str - else error ("only strings expected in: " ++ printTree trm - ++ " instead of " ++ unwords (map printTree tys) - ) + let tys' = filter (/=str) tys + testErr (null tys') + ("expected Str in " ++ prt trm ++ " not " ++ unwords (map prt tys')) + return str R ts -> do tys <- mapM infer ts return $ tuple tys P t u -> do - R tys <- infer t - case u of + tt <- infer t + tu <- infer u + case tt of + R tys -> case tu of R [v] -> infer $ P t v R (v:vs) -> infer $ P (head tys) (R vs) ----- - C i -> if (i < length tys) - then (return $ tys !! i) -- record: index must be known - else error ("too few fields in " ++ printTree (R tys)) - _ -> if all (==head tys) tys -- table: must be same - then return (head tys) - else error ("projection " ++ printTree trm) - FV ts -> return $ head ts ---- empty variants; check equality + C i -> do + testErr (i < length tys) + ("required more than " ++ show i ++ " fields in " ++ prt (R tys)) + (return $ tys !! i) -- record: index must be known + _ -> do + let typ = head tys + testErr (all (==typ) tys) ("different types in table " ++ prt trm) + return typ -- table: must be same + _ -> Bad $ "projection from " ++ prt t ++ " : " ++ prt tt + FV [] -> return str ---- + FV (t:ts) -> do + ty <- infer t + tys <- mapM infer ts + testErr (all (==ty) tys) ("different types in variants " ++ prt trm) + return ty W s r -> infer r - _ -> error ("no type inference for " ++ printTree trm) + _ -> Bad ("no type inference for " ++ prt trm) where infer = inferTerm args + prt = printTree checkTerm :: LinType -> Term -> IO Bool checkTerm (args,val) trm = case inferTerm args trm of - Just ty -> if eqType ty val then return True else do + Ok ty -> if eqType ty val + then return True + else do putStrLn $ "term: " ++ printTree trm ++ "\nexpected type: " ++ printTree val ++ "\ninferred type: " ++ printTree ty return False - _ -> do - putStrLn $ "cannot infer type of " ++ printTree trm + Bad s -> do + putStrLn s return False eqType :: Tpe -> Tpe -> Bool @@ -117,14 +129,31 @@ inline gfcc lang t = case t of composOp :: Monad m => (Term -> m Term) -> Term -> m Term composOp f trm = case trm of - R ts -> liftM R $ mapM comp ts - S ts -> liftM S $ mapM comp ts - FV ts -> liftM FV $ mapM comp ts - P t u -> liftM2 P (comp t) (comp u) - W s t -> liftM (W s) $ comp t + R ts -> liftM R $ mapM f ts + S ts -> liftM S $ mapM f ts + FV ts -> liftM FV $ mapM f ts + P t u -> liftM2 P (f t) (f u) + W s t -> liftM (W s) $ f t _ -> return trm - where - comp = composOp f composSafeOp :: (Term -> Term) -> Term -> Term composSafeOp f = maybe undefined id . composOp (return . f) + +-- from GF.Data.Oper + +maybeErr :: String -> Maybe a -> Err a +maybeErr s = maybe (Bad s) Ok + +testErr :: Bool -> String -> Err () +testErr cond msg = if cond then return () else Bad msg + +errVal :: a -> Err a -> a +errVal a = err (const a) id + +errIn :: String -> Err a -> Err a +errIn msg = err (\s -> Bad (s ++ "\nOCCURRED IN\n" ++ msg)) return + +err :: (String -> b) -> (a -> b) -> Err a -> b +err d f e = case e of + Ok a -> f a + Bad s -> d s diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs index 780ca3589..b841a0ce3 100644 --- a/src/GF/Canon/GFCC/DataGFCC.hs +++ b/src/GF/Canon/GFCC/DataGFCC.hs @@ -1,6 +1,7 @@ module GF.Canon.GFCC.DataGFCC where import GF.Canon.GFCC.AbsGFCC +import GF.Canon.GFCC.PrintGFCC import Data.Map import Data.List import Debug.Trace ---- @@ -92,10 +93,14 @@ compute mcfg lang args = comp where look = lookLin mcfg lang - idx xs i = if i > length xs - 1 then trace "overrun !!\n" (last xs) else xs !! i + idx xs i = if i > length xs - 1 + then trace + ("too large " ++ show i ++ " for\n" ++ unlines (Prelude.map prt xs) ++ "\n") TM + else xs !! i proj r p = case (r,p) of (_, FV ts) -> FV $ Prelude.map (proj r) ts + (FV ts, _ ) -> FV $ Prelude.map (\t -> proj t r) ts (W s t, _) -> kks (s ++ getString (proj t p)) (_,R is) -> comp $ foldl P r is _ -> comp $ getField r (getIndex p) @@ -116,6 +121,8 @@ compute mcfg lang args = comp where TM -> TM _ -> trace ("ERROR in grammar compiler: field from " ++ show t) t + prt = printTree + mkGFCC :: Grammar -> GFCC mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC { absname = a, diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index a7ac02689..7d0c19b60 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -10,6 +10,7 @@ import qualified GF.Grammar.Macros as GM import qualified GF.Infra.Modules as M import qualified GF.Infra.Option as O +import GF.Devel.PrGrammar import GF.Devel.ModDeps import GF.Infra.Ident import GF.Infra.Option @@ -38,7 +39,9 @@ mkCanon2gfcc opts cnc gr = canon2gfcc :: Options -> SourceGrammar -> C.Grammar canon2gfcc opts cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = - C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs where + (if (oElem (iOpt "show_canon") opts) then trace (prGrammar cgr) else id) $ + C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs + where cs = map (i2i . fst) cms adefs = [C.Fun f' (mkType ty) (C.Tr (C.AC f') []) | (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f] @@ -66,7 +69,7 @@ mkCType t = case t of EInt i -> C.C $ fromInteger i RecType rs -> C.R [mkCType t | (_, t) <- rs] Table pt vt -> case pt of - EInt i -> C.R $ replicate (fromInteger i) $ mkCType vt + EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt RecType rs -> mkCType $ foldr Table vt (map snd rs) Sort "Str" -> C.S [] --- Str only _ -> error $ "mkCType " ++ show t @@ -150,7 +153,7 @@ canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs where recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules - cl2cl cg = tr $ M.MGrammar $ map c2c $ M.modules cg where + cl2cl cg = {- tr $ -} M.MGrammar $ map c2c $ M.modules cg where c2c (c,m) = case m of M.ModMod mo@(M.Module _ _ _ _ _ js) -> (c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js) @@ -202,7 +205,7 @@ paramValues cgr = (labels,untyps,typs) where ] typsFrom ty = case ty of Table p t -> typsFrom p ++ typsFrom t - RecType ls -> RecType (unlockTyp ls) : concat [typsFrom t | (_, t) <- ls] + RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls] _ -> [ty] typsFromTrm :: Term -> STM [Type] Term @@ -210,6 +213,8 @@ paramValues cgr = (labels,untyps,typs) where V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr T (TTyped ty) cs -> updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr + T (TComp ty) cs -> + updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr _ -> GM.composOp typsFromTrm tr jments = @@ -244,7 +249,7 @@ type2type cgr env@(labels,untyps,typs) ty = case ty of _ -> ty where t2t = type2type cgr env - look ty = EInt $ toInteger $ case Map.lookup ty typs of + look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of Just vs -> length $ Map.assocs vs _ -> trace ("unknown partype " ++ show ty) 66669 @@ -253,12 +258,13 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of App _ _ -> mkValCase tr QC _ _ -> mkValCase tr R rs -> R [(mkLab i, (Nothing, t2t t)) | - (i,(l,(_,t))) <- zip [0..] (unlock rs)] + (i,(l,(_,t))) <- zip [0..] (sort (unlock rs))] P t l -> r2r tr PI t l i -> EInt $ toInteger i - T (TTyped ty) cs -> mkCurry $ V ty [t2t t | (_, t) <- cs] + T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc + T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc V ty ts -> mkCurry $ V ty [t2t t | t <- ts] - S t p -> S (t2t t) (t2t p) + S t p -> mkCurrySel (t2t t) (t2t p) _ -> GM.composSafeOp t2t tr where t2t = term2term cgr env @@ -321,9 +327,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of Just v -> EInt v _ -> valNumFV $ tryVar tr _ -> valNumFV $ tryVar tr - tryVar tr = case tr of ------ Par c ts -> [Par c ts' | ts' <- combinations (map tryVar ts)] - FV ts -> ts + tryVar tr = case GM.appForm tr of + ---(c, ts) -> [ts' | ts' <- combinations (map tryVar ts)] + (FV ts,_) -> ts _ -> [tr] valNumFV ts = case ts of [tr] -> EInt 66667 ----K (KS (A.prt tr +++ prtTrace tr "66667")) @@ -332,7 +338,8 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of mkCurry trm = case trm of V (RecType [(_,ty)]) ts -> V ty ts V (RecType ((_,ty):ltys)) ts -> - V ty [mkCurry (V (RecType ltys) cs) | cs <- chop (lengthtyp ty) ts] + V ty [mkCurry (V (RecType ltys) cs) | + cs <- chop (product (map (lengthtyp . snd) ltys)) ts] _ -> trm lengthtyp ty = case Map.lookup ty typs of Just m -> length (Map.assocs m) @@ -342,6 +349,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of (xs1,xs2) -> xs1:chop i xs2 + mkCurrySel t p = S t p ---- + + mkLab k = LIdent (("_" ++ show k))