summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/GF/Canon/CanonToGFCC.hs69
-rw-r--r--src/GF/Canon/GFCC/Test.gf41
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"
}
} ;
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 20:18:54 +0000