From 3917291e92ae5070fc9ec0ea8d37f77a68f243ba Mon Sep 17 00:00:00 2001 From: aarne Date: Fri, 15 Sep 2006 19:29:45 +0000 Subject: [PATCH] debugging CanonToGFCC --- src/GF/Canon/CanonToGFCC.hs | 69 ++++++++++++++++++++++++++----------- src/GF/Canon/GFCC/Test.gf | 41 +++++++++++++--------- 2 files changed, 73 insertions(+), 37 deletions(-) diff --git a/src/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs index a48a89fc5..b2b5148ff 100644 --- a/src/GF/Canon/CanonToGFCC.hs +++ b/src/GF/Canon/CanonToGFCC.hs @@ -129,17 +129,19 @@ canon2canon cg = tr $ M.MGrammar $ map c2c $ M.modules cg where GFC.CncFun x y tr z -> (f,GFC.CncFun x y (t2t tr) z) _ -> (f,j) t2t = term2term cg pv - pv@(labels,untyps,_) = paramValues cg + pv@(labels,untyps,typs) = paramValues cg tr = trace $ (unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i | ((c,l),i) <- Map.toList labels]) ++ (unlines [A.prt t +++ "=" +++ show i | - (t,i) <- Map.toList untyps]) + (t,i) <- Map.toList untyps]) ++ + (unlines [A.prt t | + (t,_) <- Map.toList typs]) type ParamEnv = - (Map.Map (Ident,[Label]) Integer, -- numbered labels - Map.Map Term Integer, -- untyped terms to values - Map.Map CType (Map.Map Term Integer)) -- types to their terms to values + (Map.Map (Ident,[Label]) (CType,Integer), -- numbered labels + Map.Map Term Integer, -- untyped terms to values + Map.Map CType (Map.Map Term Integer)) -- types to their terms to values --- gathers those param types that are actually used in lincats paramValues :: CanonGrammar -> ParamEnv @@ -154,17 +156,17 @@ paramValues cgr = (labels,untyps,typs) where (m,(ty,ResPar _)) <- jments ] typsFrom ty = case ty of - Table p t -> p : typsFrom t - RecType ls -> concat [typsFrom t | Lbg _ t <- ls] + Table p t -> typsFrom p ++ typsFrom t + RecType ls -> ty : concat [typsFrom t | Lbg _ t <- ls] _ -> [ty] jments = [(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo] typs = Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] untyps = Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] lincats = [(cat,ls) | (_,(cat,CncCat (RecType ls) _ _)) <- jments] labels = Map.fromList $ concat - [((cat,[lab]),i): - [((cat,[lab,lab2]),j) | - rs <- getRec typ, (Lbg lab2 _,j) <- zip rs [0..]] + [((cat,[lab]),(typ,i)): + [((cat,[lab,lab2]),(ty,j)) | + rs <- getRec typ, (Lbg lab2 ty,j) <- zip rs [0..]] | (cat,ls) <- lincats, (Lbg lab typ,i) <- zip ls [0..]] -- go to tables recursively @@ -177,8 +179,9 @@ paramValues cgr = (labels,untyps,typs) where term2term :: CanonGrammar -> ParamEnv -> Term -> Term term2term cgr env@(labels,untyps,typs) tr = case tr of - Par c ps | any isVar ps -> mkCase c ps - Par _ _ -> valNum tr + Par _ _ -> mkValCase tr +---- Par c ps | any isVar ps -> mkCase c ps +---- Par _ _ -> valNum tr R rs | any (isStr . trmAss) rs -> R [Ass (mkLab i) (t2t t) | (i,Ass l t) <- zip [0..] rs, not (isLock l t)] R rs -> valNum tr @@ -193,10 +196,10 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of -- Conj@0.s r2r tr = case tr of P x@(Arg (A cat i)) lab -> - P x . mkLab $ maybe (prtTrace tr $ 66664) id $ + P x . mkLab $ maybe (prtTrace tr $ 66664) snd $ Map.lookup (cat,[lab]) labels P p lab2 -> case getLab p of - Just (cat,lab1) -> P (r2r p) . mkLab $ maybe (prtTrace tr $ 66664) id $ + Ok (cat,lab1) -> P (r2r p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ Map.lookup (cat,[lab1,lab2]) labels _ -> P (t2t p) $ mkLab (prtTrace tr 66665) _ -> tr ---- @@ -205,7 +208,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of getLab tr = case tr of P (Arg (A cat i)) lab1 -> return (cat,lab1) S p _ -> getLab p - _ -> Nothing + _ -> Bad "getLab" mkLab k = L (IC ("_" ++ show k)) valNum tr = maybe (K (KS (A.prt tr +++ prtTrace tr "66667"))) EInt $ Map.lookup tr untyps @@ -220,12 +223,36 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of R [] -> True _ -> False trmAss (Ass _ t) = t - isVar p = case p of - Arg _ -> True - P q _ -> isVar q - _ -> False - mkCase c ps = EInt (prtTrace tr 66668) ---- TODO: expand param constr with var - + + mkValCase tr = case appSTM (doVar tr) [] of + Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st + _ -> valNum tr + + doVar :: Term -> STM [((CType,[Term]),(Term,Term))] Term +-- doVar tr = case tr of +-- P q@(Arg (A cat i)) lab -> do + doVar tr = case getLab tr of + Ok (cat, lab) -> do + k <- readSTM >>= return . length + let tr' = LI $ identC $ show k + let tyvs = case Map.lookup (cat,[lab]) labels of + Just (ty,_) -> case Map.lookup ty typs of + Just vs -> (ty,Map.keys vs) + _ -> error $ A.prt ty + _ -> error $ A.prt tr + updateSTM ((tyvs, (tr', tr)):) + return tr' + _ -> composOp doVar tr + + comp t = errVal t $ Look.ccompute cgr [] t + + mkCase ((ty,vs),(x,p)) tr = + S (V ty [mkBranch x v tr | v <- vs]) p + mkBranch x t tr = case tr of + _ | tr == x -> t + _ -> composSafeOp (mkBranch x t) tr + + prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n diff --git a/src/GF/Canon/GFCC/Test.gf b/src/GF/Canon/GFCC/Test.gf index cd52a6291..86f4adbdf 100644 --- a/src/GF/Canon/GFCC/Test.gf +++ b/src/GF/Canon/GFCC/Test.gf @@ -15,18 +15,27 @@ param Person = P1 | P2 | P3 ; param Number = Sg | Pl ; param Case = Nom | Part ; +param NForm = NF Number Case ; +param VForm = VF Number Person ; + +--lincat NP = {s : Case => Str ; n : Number ; p : Person} ; lincat NP = {s : Case => Str ; a : {n : Number ; p : Person}} ; lincat N = Noun ; lincat VP = Verb ; -oper Noun = {s : {n : Number ; c : Case} => Str} ; -oper Verb = {s : {n : Number ; p : Person} => Str} ; +oper Noun = {s : NForm => Str} ; +oper Verb = {s : VForm => Str} ; -lin Pred np vp = {s = np.s ! Nom ++ vp.s ! np.a} ; -lin Pred2 np vp ob = {s = np.s ! Nom ++ vp.s ! np.a ++ ob.s ! Part} ; -lin Det no = {s = \\c => no.s ! {n = Sg ; c = c} ; a = {n = Sg ; p = P3}} ; -lin Dets no = {s = \\c => no.s ! {n = Pl ; c = c} ; a = {n = Pl ; p = P3}} ; +--lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.n np.p} ; +lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p} ; +lin Pred2 np vp ob = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p ++ ob.s ! Part} ; +--lin Det no = {s = \\c => no.s ! NF Sg c ; n = Sg ; p = P3} ; +--lin Dets no = {s = \\c => no.s ! NF Pl c ; n = Pl ; p = P3} ; +lin Det no = {s = \\c => no.s ! NF Sg c ; a = {n = Sg ; p = P3}} ; +lin Dets no = {s = \\c => no.s ! NF Pl c ; a = {n = Pl ; p = P3}} ; +--lin Mina = {s = table Case ["minä" ; "minua"] ; n = Sg ; p = P1} ; +--lin Te = {s = table Case ["te" ; "teitä"] ; n = Pl ; p = P2} ; lin Mina = {s = table Case ["minä" ; "minua"] ; a = {n = Sg ; p = P1}} ; lin Te = {s = table Case ["te" ; "teitä"] ; a = {n = Pl ; p = P2}} ; @@ -39,21 +48,21 @@ lin Sanoa = mkV "sano" ; oper mkN : Str -> Noun = \raha -> { s = table { - {n = Sg ; c = Nom} => raha ; - {n = Sg ; c = Part} => raha + "a" ; - {n = Pl ; c = Nom} => raha + "t" ; - {n = Pl ; c = Part} => Predef.tk 1 raha + "oja" + NF Sg Nom => raha ; + NF Sg Part => raha + "a" ; + NF Pl Nom => raha + "t" ; + NF Pl Part => Predef.tk 1 raha + "oja" } } ; oper mkV : Str -> Verb = \puhu -> { s = table { - {n = Sg ; p = P1} => puhu + "n" ; - {n = Sg ; p = P2} => puhu + "t" ; - {n = Sg ; p = P3} => puhu + Predef.dp 1 puhu ; - {n = Pl ; p = P1} => puhu + "mme" ; - {n = Pl ; p = P2} => puhu + "tte" ; - {n = Pl ; p = P3} => puhu + "vat" + VF Sg P1 => puhu + "n" ; + VF Sg P2 => puhu + "t" ; + VF Sg P3 => puhu + Predef.dp 1 puhu ; + VF Pl P1 => puhu + "mme" ; + VF Pl P2 => puhu + "tte" ; + VF Pl P3 => puhu + "vat" } } ;