GFCC: TM with argument; fixed labels from bindings in gfc

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

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

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

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)
 

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
 

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

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 ----