From 3addf256bcfaaa7748b0159a3dd6f6ce8fcd8b7c Mon Sep 17 00:00:00 2001 From: aarne Date: Thu, 31 Jan 2008 20:56:42 +0000 Subject: [PATCH] GFCC: TM with argument; fixed labels from bindings in gfc --- src/GF/Devel/GFCCtoJS.hs | 2 +- src/GF/Devel/GrammarToGFCC.hs | 3 ++- src/GF/GFCC/CheckGFCC.hs | 4 ++-- src/GF/GFCC/DataGFCC.hs | 2 +- src/GF/GFCC/Linearize.hs | 14 +++++++------- src/GF/GFCC/Macros.hs | 13 ++++++++----- src/GF/GFCC/Raw/ConvertGFCC.hs | 4 ++-- 7 files changed, 23 insertions(+), 19 deletions(-) diff --git a/src/GF/Devel/GFCCtoJS.hs b/src/GF/Devel/GFCCtoJS.hs index ca2cfa183..1d0c863f2 100644 --- a/src/GF/Devel/GFCCtoJS.hs +++ b/src/GF/Devel/GFCCtoJS.hs @@ -63,7 +63,7 @@ term2js l t = f t D.FV xs -> new "Variants" (map f xs) D.W str x -> new "Suffix" [JS.EStr str, f x] D.RP x y -> new "Rp" [f x, f y] - D.TM -> new "Meta" [] + D.TM _ -> new "Meta" [] tokn2js :: D.Tokn -> JS.Expr tokn2js (D.KS s) = mkStr s diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index 4353eda03..0d24113dd 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -459,7 +459,8 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of Vr (IA (cat, _)) -> return (identC cat,[]) Vr (IAV (cat,_,_)) -> return (identC cat,[]) Vr (IC s) -> return (identC cat,[]) where - cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser + cat = takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated + ---- init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser ---- Vr _ -> error $ "getLab " ++ show tr P p lab2 -> do (cat,labs) <- getLab p diff --git a/src/GF/GFCC/CheckGFCC.hs b/src/GF/GFCC/CheckGFCC.hs index 33302ab1b..d59dba1a9 100644 --- a/src/GF/GFCC/CheckGFCC.hs +++ b/src/GF/GFCC/CheckGFCC.hs @@ -91,7 +91,7 @@ inferTerm args trm = case trm of testErr (all (==typ) tys) ("different types in table " ++ show trm) return (P t' u', typ) -- table: types must be same _ -> Bad $ "projection from " ++ show t ++ " : " ++ show tt - FV [] -> returnt TM ---- + FV [] -> returnt tm0 ---- FV (t:ts) -> do (t',ty) <- infer t (ts',tys) <- mapM infer ts >>= return . unzip @@ -120,7 +120,7 @@ eqType :: CType -> CType -> Bool eqType inf exp = case (inf,exp) of (C k, C n) -> k <= n -- only run-time corr. (R rs,R ts) -> length rs == length ts && and [eqType r t | (r,t) <- zip rs ts] - (TM, _) -> True ---- for variants [] ; not safe + (TM _, _) -> True ---- for variants [] ; not safe _ -> inf == exp -- should be in a generic module, but not in the run-time DataGFCC diff --git a/src/GF/GFCC/DataGFCC.hs b/src/GF/GFCC/DataGFCC.hs index 89ab28170..077d62b19 100644 --- a/src/GF/GFCC/DataGFCC.hs +++ b/src/GF/GFCC/DataGFCC.hs @@ -65,7 +65,7 @@ data Term = | F CId | FV [Term] | W String Term - | TM + | TM String | RP Term Term deriving (Eq,Ord,Show) diff --git a/src/GF/GFCC/Linearize.hs b/src/GF/GFCC/Linearize.hs index b585385ea..03dc864d5 100644 --- a/src/GF/GFCC/Linearize.hs +++ b/src/GF/GFCC/Linearize.hs @@ -23,11 +23,11 @@ realize trm = case trm of W s t -> s ++ realize t FV ts -> realize (ts !! 0) ---- other variants TODO RP _ r -> realize r ---- DEPREC - TM -> "?" + TM s -> s _ -> "ERROR " ++ show trm ---- debug linExp :: GFCC -> CId -> Exp -> Term -linExp mcfg lang tree@(DTr xs at trees) = ---- bindings TODO +linExp mcfg lang tree@(DTr xs at trees) = case at of AC fun -> addB $ comp (lmap lin trees) $ look fun AS s -> R [kks (show s)] -- quoted @@ -35,8 +35,8 @@ linExp mcfg lang tree@(DTr xs at trees) = ---- bindings TODO --- [C lst, kks (show i), C size] where --- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1 AF d -> R [kks (show d)] - AV x -> addB $ R [kks (prCId x)] ---- lindef of cat - AM _ -> TM + AV x -> addB $ TM (prCId x) + AM i -> TM (show i) where lin = linExp mcfg lang comp = compute mcfg lang @@ -63,7 +63,7 @@ compute mcfg lang args = comp where idx xs i = if i > length xs - 1 then trace - ("too large " ++ show i ++ " for\n" ++ unlines (lmap show xs) ++ "\n") TM + ("too large " ++ show i ++ " for\n" ++ unlines (lmap show xs) ++ "\n") tm0 else xs !! i proj r p = case (r,p) of @@ -79,12 +79,12 @@ compute mcfg lang args = comp where getIndex t = case t of C i -> i RP p _ -> getIndex p ---- DEPREC - TM -> 0 -- default value for parameter + TM _ -> 0 -- default value for parameter _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 666 getField t i = case t of R rs -> idx rs i RP _ r -> getField r i ---- DEPREC - TM -> TM + TM s -> TM s _ -> error ("ERROR in grammar compiler: field from " ++ show t) t diff --git a/src/GF/GFCC/Macros.hs b/src/GF/GFCC/Macros.hs index d38ccb2e5..b9acd9fc5 100644 --- a/src/GF/GFCC/Macros.hs +++ b/src/GF/GFCC/Macros.hs @@ -12,19 +12,19 @@ import Data.List lookLin :: GFCC -> CId -> CId -> Term lookLin gfcc lang fun = - lookMap TM fun $ lins $ lookMap (error "no lang") lang $ concretes gfcc + lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes gfcc lookOper :: GFCC -> CId -> CId -> Term lookOper gfcc lang fun = - lookMap TM fun $ opers $ lookMap (error "no lang") lang $ concretes gfcc + lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes gfcc lookLincat :: GFCC -> CId -> CId -> Term lookLincat gfcc lang fun = - lookMap TM fun $ lincats $ lookMap (error "no lang") lang $ concretes gfcc + lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes gfcc lookParamLincat :: GFCC -> CId -> CId -> Term lookParamLincat gfcc lang fun = - lookMap TM fun $ paramlincats $ lookMap (error "no lang") lang $ concretes gfcc + lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes gfcc lookType :: GFCC -> CId -> Type lookType gfcc f = @@ -94,7 +94,10 @@ primNotion :: Exp primNotion = EEq [] term0 :: CId -> Term -term0 _ = TM +term0 = TM . prCId + +tm0 :: Term +tm0 = TM "?" kks :: String -> Term kks = K . KS diff --git a/src/GF/GFCC/Raw/ConvertGFCC.hs b/src/GF/GFCC/Raw/ConvertGFCC.hs index 437478bb6..1631a128f 100644 --- a/src/GF/GFCC/Raw/ConvertGFCC.hs +++ b/src/GF/GFCC/Raw/ConvertGFCC.hs @@ -137,7 +137,7 @@ toTerm e = case e of App (CId "A") [AInt i] -> V (fromInteger i) App f [] -> F f AInt i -> C (fromInteger i) - AMet -> TM + AMet -> TM "?" AStr s -> K (KS s) ---- _ -> error $ "term " ++ show e @@ -202,7 +202,7 @@ fromTerm e = case e of RP e v -> app "RP" [fromTerm e, fromTerm v] ---- W s v -> app "W" [AStr s, fromTerm v] C i -> AInt (toInteger i) - TM -> AMet + TM _ -> AMet F f -> App f [] V i -> App (CId "A") [AInt (toInteger i)] K (KS s) -> AStr s ----