summaryrefslogtreecommitdiff
path: root/src/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF')
-rw-r--r--src/GF/Devel/GFCCtoJS.hs2
-rw-r--r--src/GF/Devel/GrammarToGFCC.hs3
-rw-r--r--src/GF/GFCC/CheckGFCC.hs4
-rw-r--r--src/GF/GFCC/DataGFCC.hs2
-rw-r--r--src/GF/GFCC/Linearize.hs14
-rw-r--r--src/GF/GFCC/Macros.hs13
-rw-r--r--src/GF/GFCC/Raw/ConvertGFCC.hs4
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 ----
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 10:24:21 +0000