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