gfcc generation with HOAS: var fields appended to records

4 files changed, 27 insertions, 7 deletions

diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs
index 5b2f4ce17..4353eda03 100644
--- a/src/GF/Devel/GrammarToGFCC.hs
+++ b/src/GF/Devel/GrammarToGFCC.hs
@@ -134,6 +134,7 @@ mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]
 mkTerm :: Term -> C.Term
 mkTerm tr = case tr of
   Vr (IA (_,i)) -> C.V i
+  Vr (IAV (_,_,i)) -> C.V i
   Vr (IC s) | isDigit (last s) -> 
     C.V (read (reverse (takeWhile (/='_') (reverse s)))) 
     ---- from gf parser of gfc
@@ -362,10 +363,11 @@ paramValues cgr = (labels,untyps,typs) where
       [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments]
   labels = Map.fromList $ concat 
     [((cat,[lab]),(typ,i)): 
+      [((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars 
       [((cat,[lab,lab2]),(ty,j)) | 
         rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] 
       | 
-        (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..]]
+        (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..], let mx = length ls]
     -- go to tables recursively
     ---- TODO: even go to deeper records
    where
@@ -447,13 +449,15 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
    r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v
 
    r2r tr@(P p _) = case getLab tr of
-     Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ 
-          Map.lookup (cat,labs) labels
+     Ok (cat,labs) -> P (t2t p) . mkLab $ 
+          maybe (prtTrace tr $ 66664) snd $ 
+            Map.lookup (cat,labs) labels
      _ -> K ((A.prt tr +++ prtTrace tr "66665"))
 
    -- this goes recursively into tables (ignored) and records (accumulated)
    getLab 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
 ----     Vr _ -> error $ "getLab " ++ show tr
diff --git a/src/GF/GFCC/CheckGFCC.hs b/src/GF/GFCC/CheckGFCC.hs
index dfd9b2a0e..33302ab1b 100644
--- a/src/GF/GFCC/CheckGFCC.hs
+++ b/src/GF/GFCC/CheckGFCC.hs
@@ -138,10 +138,13 @@ str :: CType
 str = S []
 
 lintype :: GFCC -> CId -> CId -> LinType
-lintype gfcc lang fun = case catSkeleton (lookType gfcc fun) of
-  (cs,c) -> (map linc cs, linc c) ---- HOAS
+lintype gfcc lang fun = case typeSkeleton (lookType gfcc fun) of
+  (cs,c) -> (map vlinc cs, linc c) ---- HOAS
  where 
    linc = lookLincat gfcc lang
+   vlinc (0,c) = linc c
+   vlinc (i,c) = case linc c of
+     R ts -> R (ts ++ replicate i str)
 
 inline :: GFCC -> CId -> Term -> Term
 inline gfcc lang t = case t of
diff --git a/src/GF/GFCC/Linearize.hs b/src/GF/GFCC/Linearize.hs
index 7d5e6b010..b585385ea 100644
--- a/src/GF/GFCC/Linearize.hs
+++ b/src/GF/GFCC/Linearize.hs
@@ -27,19 +27,24 @@ realize trm = case trm of
   _ -> "ERROR " ++ show trm ---- debug
 
 linExp :: GFCC -> CId -> Exp -> Term
-linExp mcfg lang tree@(DTr _ at trees) =  ---- bindings TODO
+linExp mcfg lang tree@(DTr xs at trees) =  ---- bindings TODO
   case at of
-    AC fun -> comp (lmap lin trees) $ look fun
+    AC fun -> addB $ comp (lmap lin trees) $ look fun
     AS s   -> R [kks (show s)] -- quoted
     AI i   -> R [kks (show i)] 
                 --- [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
  where
    lin  = linExp mcfg lang
    comp = compute mcfg lang
    look = lookLin mcfg lang
+   addB t 
+     | Data.List.null xs = t
+     | otherwise = case t of
+         R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
 
 compute :: GFCC -> CId -> [Term] -> Term -> Term
 compute mcfg lang args = comp where
diff --git a/src/GF/GFCC/Macros.hs b/src/GF/GFCC/Macros.hs
index 383b77d34..d38ccb2e5 100644
--- a/src/GF/GFCC/Macros.hs
+++ b/src/GF/GFCC/Macros.hs
@@ -69,10 +69,18 @@ catSkeleton :: Type -> ([CId],CId)
 catSkeleton ty = case ty of
   DTyp hyps val _ -> ([valCat ty | Hyp _ ty <- hyps],val)
 
+typeSkeleton :: Type -> ([(Int,CId)],CId)
+typeSkeleton ty = case ty of
+  DTyp hyps val _ -> ([(contextLength ty, valCat ty) | Hyp _ ty <- hyps],val)
+
 valCat :: Type -> CId
 valCat ty = case ty of
   DTyp _ val _ -> val
 
+contextLength :: Type -> Int
+contextLength ty = case ty of
+  DTyp hyps _ _ -> length hyps
+
 cid :: String -> CId
 cid = CId