GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-08-19 10:46:22 -06:00
Code Issues Packages Projects Releases Wiki Activity

partial implementation for dependently typed records

Browse Source
This commit is contained in:
Krasimir Angelov
2026-01-03 16:14:51 +01:00
parent 0a33204ee4
commit d42614afad
16 changed files with 174 additions and 126 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/compiler/api/GF/Compile/Compute/Concrete.hs
+22 -8
View File
@@ -186,7 +186,14 @@ eval g env s (Prod b x t1 t2)[]
| otherwise = let (s1,s2) = split s
in VProd b x (eval g env s1 t1 []) (VClosure env s2 t2)
eval g env s (Typed t ty) vs = eval g env s t vs
eval g env s (RecType lbls) [] = VRecType (mapC (\s (lbl,ty) -> (lbl, True, eval g env s ty [])) s lbls) False
eval g env c (RecType rs) [] = VRecType
(mapC (\c (lbl,deps,ty) ->
let v = case deps of
[] -> eval g env c ty []
xs -> VClosure env c (foldr (Abs Explicit) ty deps)
in (lbl,True,v))
c rs)
False
eval g env s (R as) [] = VR (mapC (\s (lbl,(ty,t)) -> (lbl, eval g env s t [])) s as)
eval g env s (P t lbl) vs = let project (VR as) = case lookup lbl as of
Nothing -> VError ("Missing value for label" <+> pp lbl $$
@@ -289,7 +296,7 @@ eval g env s (EPatt min max p) [] = VPatt min max p
eval g env s (EPattType t) [] = VPattType (eval g env s t [])
eval g env s (ELincat c ty) [] = let lbl = lockLabel c
lty = RecType []
in eval g env s (ExtR ty (RecType [(lbl,lty)])) []
in eval g env s (ExtR ty (RecType [(lbl,[],lty)])) []
eval g env s (ELin c t) [] = let lbl = lockLabel c
lt = R []
in eval g env s (ExtR t (R [(lbl,(Nothing,lt))])) []
@@ -315,7 +322,7 @@ eval g env c t@(Opts n cs) vs = if null cs
in VFV c3 (VarOpts vn vcs)
where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs)
evalOpt c' (Nothing,t) = let v = eval g env c' t vs in (v, v)
eval g env c t vs = VError ("Cannot reduce term" <+> pp t)
eval g env c t vs = VError ("Cannot reduce term" <+> pp t)
evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
evalPredef g@(Gl gr pds) c n args =
@@ -356,7 +363,7 @@ apply g (VSusp i k vs0) vs = VSusp i k (vs0++vs)
apply g (VApp c f@(m,n) vs0) vs
| m == cPredef = evalPredef g c n (vs0++vs)
| otherwise = VApp c f (vs0++vs)
apply g (VGen i vs0) vs = VGen i (vs0++vs)
apply g (VGen i vs0) vs = VGen i (vs0++vs)
apply g (VFV i fvs) vs = VFV i (fmap (\v -> apply g v vs) fvs)
apply g (VS v1 v2 vs') vs = VS v1 v2 (vs'++vs)
apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs
@@ -837,9 +844,16 @@ value2termM flat xs (VProd b x v1 v2) = do
t1 <- value2termM flat xs v1
t2 <- value2termM flat xs v2
return (Prod b x t1 t2)
value2termM flat xs (VRecType lbls _) = do
lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
value2termM flat xs (VRecType lbls ext) = do
g <- globals
lbls <- mapM (\(lbl,_,v) -> uncover g lbl xs v) lbls
return (RecType lbls)
where
uncover g lbl xs (VClosure env c (Abs b x t)) = do (lbl,deps,t) <- uncover g lbl (x:xs) (VClosure ((x,VGen (length xs) []):env) c t)
return (lbl,x:deps,t)
uncover g lbl xs (VClosure env c t) = fmap ((,,) lbl []) (value2termM flat xs (eval g env c t []))
uncover g lbl xs v = fmap ((,,) lbl []) (value2termM flat xs v)
value2termM flat xs (VR as) = do
as <- mapM (\(lbl,v) -> fmap (\t -> (lbl,(Nothing,t))) (value2termM flat xs v)) as
return (R as)
@@ -1048,7 +1062,7 @@ pattVars st _ = st
ppValue q d (VApp c f vs) = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
ppValue q d (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
ppValue q d (VSusp i k vs) = prec d 4 (hsep (pp "#susp" : (if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
ppValue q d (VGen _ _) = pp "VGen"
ppValue q d (VGen i vs) = prec d 4 (hsep (pp "#gen" : pp i : map (ppValue q 5) vs))
ppValue q d (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]"
ppValue q d (VProd bt x a b) =
if x == identW && bt == Explicit
@@ -1060,7 +1074,7 @@ ppValue q d (VRecType xs ext)
_ -> doc
| otherwise = doc
where
doc = braces (fsep (punctuate ';' ([l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext])))
doc = braces (fsep (punctuate ';' ([l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext])))
ppValue q d (VR []) = pp "<>" -- to distinguish from {} empty RecType
ppValue q d (VR xs) = braces (fsep (punctuate ';' [l <+> '=' <+> ppValue q 0 v | (l,v) <- xs]))
ppValue q d (VP v l vs) = prec d 5 (hsep (ppValue q 5 v <> '.' <> l : map (ppValue q 5) vs))
src/compiler/api/GF/Compile/ConcreteToHaskell.hs
+1 -1
View File
@@ -93,7 +93,7 @@ concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) =
| s == cStr = tcon0 (identS "Str")
convLinType (QC (_,p)) = tcon0 (gId p)
convLinType (RecType lbls) = tcon (rcon' ls) (map convLinType ts)
where (ls,ts) = unzip $ sortOn fst lbls
where (ls,_,ts) = unzip3 $ sortOn (\(l,_,_)->l) lbls
convLinType (Table pt lt) = Fun (convLinType pt) (convLinType lt)
lincatDef c ty = tsyn0 (lincatName c) (convLinType ty)
src/compiler/api/GF/Compile/GeneratePMCFG.hs
+17 -17
View File
@@ -106,7 +106,7 @@ type2fields gr = map show . type2fields PP.empty
where
type2fields d (Sort s) | s == cStr = [show d]
type2fields d (RecType lbls) =
concatMap (\(lbl,ty) -> type2fields (d <+> pp lbl) ty) lbls
concatMap (\(lbl,_,ty) -> type2fields (d <+> pp lbl) ty) lbls
type2fields d (Table p q) =
let Ok ts = allParamValues gr p
in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts
@@ -127,7 +127,7 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
Ok (v:_) -> return v
Bad msg -> fail msg
RecType r -> do
let (ls,ts) = unzip r
let (ls,_,ts) = unzip3 r
ts <- mapM mkDefField ts
return $ R (zipWith assign ls ts)
_ | Just _ <- isTypeInts ty -> return $ EInt 0 -- exists in all as first val
@@ -150,21 +150,21 @@ mkLinReference gr typ = do
_ | Just _ <- isTypeInts ty -> return Nothing
_ -> fail (render ("a field in a linearization type cannot be" <+> typ))
traverse [] trm = return Nothing
traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l)
case res of
Just trm -> return (Just trm)
Nothing -> traverse rs trm
traverse [] trm = return Nothing
traverse ((l,_,ty):rs) trm = do res <- mkRefField ty (P trm l)
case res of
Just trm -> return (Just trm)
Nothing -> traverse rs trm
type2metaTerm :: SourceGrammar -> Int -> MetaVars -> Choice -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> [(Value,Type)] -> (MetaVars,Choice,Int,Term,[(Value,Type)])
type2metaTerm gr d ms s r rs (Sort srt) params | srt == cStr = (ms,s,r+1,TSymCat d r rs,params)
type2metaTerm gr d ms s r rs (RecType lbls) params =
let ((ms',s',r',params'),ass) =
mapAccumL (\(ms,s,r,params) (lbl,ty) -> case lbl of
LVar j -> ((ms,s,r,params),(lbl,(Just ty,TSymVar d j)))
lbl -> let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs ty params
in ((ms',s',r',params'),(lbl,(Just ty,t))))
mapAccumL (\(ms,s,r,params) (lbl,_,ty) -> case lbl of
LVar j -> ((ms,s,r,params),(lbl,(Just ty,TSymVar d j)))
lbl -> let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs ty params
in ((ms',s',r',params'),(lbl,(Just ty,t))))
(ms,s,r,params) lbls
in (ms',s',r',R ass,params')
type2metaTerm gr d ms s r rs (Table p q) params
@@ -199,9 +199,9 @@ breakDown g ms s r rs v (Sort sort) fn0 fn
in return (ms,r+1,fn0,fn')
breakDown g ms s r rs v (RecType lbls) fn0 fn = traverse ms r rs lbls fn0 fn
where
traverse ms r rs [] fn0 fn = return (ms,r,fn0,fn)
traverse ms r rs ((lbl,ty):lbls) fn0 fn = do (ms,r,fn0,fn) <- breakDown g ms s r rs (project v) ty fn0 fn
traverse ms r rs lbls fn0 fn
traverse ms r rs [] fn0 fn = return (ms,r,fn0,fn)
traverse ms r rs ((lbl,_,ty):lbls) fn0 fn = do (ms,r,fn0,fn) <- breakDown g ms s r rs (project v) ty fn0 fn
traverse ms r rs lbls fn0 fn
where
project (VR as) = case lookup lbl as of
Nothing -> error (render ("Missing value for label" <+> pp lbl $$
@@ -373,8 +373,8 @@ params2int' r0 rs = do
param2int (VR as) (RecType lbls) = compute lbls
where
compute [] = return (0,[],1)
compute ((lbl,ty):lbls) = do
compute [] = return (0,[],1)
compute ((lbl,_,ty):lbls) = do
case lookup lbl as of
Just v -> do (r, rs ,cnt ) <- param2int v ty
(r',rs',cnt') <- compute lbls
@@ -513,7 +513,7 @@ chooseMetaValue s ptyp = GenM $ \g@(Gl gr _) k svs ms r ->
(ms',args) = mkVars (Map.insert i (Narrowing c1 ty) ms) c2 ctxt
in (ms',VMeta i []:args)
mkField c (l,ty) = do
mkField c (l,_,ty) = do
let (c1,c2) = split c
v <- chooseMetaValue c1 ty
return (c2,(l,v))
src/compiler/api/GF/Compile/GrammarToCanonical.hs
+1 -1
View File
@@ -111,7 +111,7 @@ concrete2canonical gr absname cncname modinfo = do
eta_expand t ((Explicit,x,_):ctx) = Abs Explicit x (eta_expand (App t (Vr x)) ctx)
paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
paramTypes (RecType fs) = Set.unions (map (\(_,_,t)->paramTypes t) fs)
paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
paramTypes (Sort _) = Set.empty
src/compiler/api/GF/Compile/Rename.hs
+12
View File
@@ -218,6 +218,13 @@ renameTerm env vars = ren vars where
_ -> return i
liftM (T i') $ mapM (renCase vs) cs
RecType rs -> do
rs <- forM rs $ \(l,deps,t) -> do
t <- renameTerm env (deps++vs) t
let deps' = L.intersect deps (freeVars vs t)
return (l,deps',t)
return (RecType rs)
Let (x,(m,a)) b -> do
m' <- case m of
Just ty -> liftM Just $ ren vs ty
@@ -255,6 +262,11 @@ renameTerm env vars = ren vars where
return (p',t')
renpatt = renamePattern env
freeVars xs (Abs _ x e) = freeVars (x:xs) e
freeVars xs (Vr x)
| not (elem x xs) = [x]
freeVars xs e = collectOp (freeVars xs) e
-- | vars not needed in env, since patterns always overshadow old vars
renamePattern :: Status -> Patt -> Check (Patt,[Ident])
renamePattern env patt =
src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+70 -47
View File
@@ -201,7 +201,7 @@ tcRho scope c (FV ts) mb_ty = do
tcRho scope s t@(Sort _) mb_ty = do
instSigma scope s t vtypeType mb_ty
tcRho scope c t@(RecType rs) Nothing = do
(rs,mb_ty) <- tcRecTypeFields scope c [] rs Nothing
(rs,mb_ty) <- tcRecTypeFields scope c rs Nothing
return (RecType rs,fromMaybe vtypePType mb_ty)
tcRho scope c t@(RecType rs) (Just ty) = do
(scope,f,ty') <- skolemise scope ty
@@ -215,7 +215,7 @@ tcRho scope c t@(RecType rs) (Just ty) = do
ty -> do ty <- value2termM False (scopeVars scope) ty
evalError ("The record type" <+> ppTerm Unqualified 0 t $$
"cannot be of type" <+> ppTerm Unqualified 0 ty)
(rs,mb_ty) <- tcRecTypeFields scope c [] rs (Just ty')
(rs,mb_ty) <- tcRecTypeFields scope c rs (Just ty')
return (f (RecType rs),ty)
tcRho scope s t@(Table p res) mb_ty = do
let (s1,s23) = split s
@@ -298,7 +298,7 @@ tcRho scope c (R rs) Nothing = do
tcRho scope c (R rs) (Just ty) = do
(scope,f,ty') <- skolemise scope ty
case ty' of
(VRecType ltys _)->do lttys <- checkRecFields scope c [] rs ltys
(VRecType ltys _)->do lttys <- checkRecFields scope c rs [] ltys
rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
return ((f . R) rs,
VRecType [(l,True,ty) | (l,t,ty) <- lttys] False
@@ -334,7 +334,7 @@ tcRho scope c t@(ExtR t1 t2) mb_ty =
(t1,ty1@(VRecType ltys1 ext)) <- tcRho scope c1 t1 (Just (VRecType [field | field@(l,_,_) <- ltys, not (elem l ll2)] ext))
let (scope',proj1,wrap) = access scope t1 ty1
lttys2 <- checkRecFields scope' c2 [] rs [field | field@(l,_,_) <- ltys, elem l ll2]
lttys2 <- checkRecFields scope' c2 rs [] [field | field@(l,_,_) <- ltys, elem l ll2]
let proj2 l =
case [(Nothing,t) | (l',t,_) <- lttys2, l'==l] of
[] -> Nothing
@@ -366,7 +366,7 @@ tcRho scope c t@(ExtR t1 t2) mb_ty =
)
access scope (RecType rs) ty
= (scope
,\l -> fmap ((,) Nothing) (lookup l rs)
,\l -> fmap ((,) Nothing) (lookup3 l rs)
,id
)
access scope t@(Vr x) ty
@@ -416,7 +416,7 @@ tcRho scope c t@(ExtR t1 t2) mb_ty =
tcRho scope c (ELin cat t) mb_ty = do -- this could be done earlier, i.e. in the parser
tcRho scope c (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty
tcRho scope c (ELincat cat t) mb_ty = do -- this could be done earlier, i.e. in the parser
tcRho scope c (ExtR t (RecType [(lockLabel cat,RecType [])])) mb_ty
tcRho scope c (ExtR t (RecType [(lockLabel cat,[],RecType [])])) mb_ty
tcRho scope c (Alts t ss) mb_ty = do
let (c1,c2,c3,c4) = split4 c
(t,_) <- tcRho scope c1 t (Just vtypeStr)
@@ -906,26 +906,35 @@ inferRecFields scope c ls ((l,t):lts)
lts <- inferRecFields scope c2 (l:ls) lts
return (lt:lts)
checkRecFields scope c ls [] ltys
| null ltys = return []
| otherwise = evalError ("Missing fields:" <+> hsep [l | (l,_,_) <- ltys])
checkRecFields scope c ls ((l,t):lts) ltys
| elem l ls = evalError ("Repeated definition for field" <+> l)
| otherwise =
case takeIt l ltys of
(Just ty,ltys) -> do let (c1,c2) = split c
ltty <- tcRecField scope c1 l t (Just ty)
lttys <- checkRecFields scope c2 ls lts ltys
return (ltty : lttys)
(Nothing,ltys) -> do evalWarn ("Discarded field:" <+> l)
lttys <- checkRecFields scope c ls lts ltys
return lttys -- ignore the field
checkRecFields scope c lts env [] = do
unless (null lts) $
evalWarn ("Discarded fields:" <+> hsep [l | (l,_) <- lts])
return []
checkRecFields scope c lts env ((l,_,ty):ltys) =
case takeIt l lts of
([], lts) -> evalError ("Missing field" <+> l)
([t],lts) -> do g <- globals
let (c1,c23) = split c
(c2,c3) = split c23
env' = (label2ident l,eval g (scopeEnv scope) c3 (snd t) []):env
ltty <- tcRecField scope c1 l t (Just (uncover g env ty))
lttys <- checkRecFields scope c2 lts env' ltys
return (ltty : lttys)
(_, lts) -> evalError ("Multiple definitions for field" <+> l)
where
takeIt l1 [] = (Nothing, [])
takeIt l1 (lty@(l2,_,ty):ltys)
| l1 == l2 = (Just ty,ltys)
| otherwise = let (mb_ty,ltys') = takeIt l1 ltys
in (mb_ty,lty:ltys')
takeIt l1 [] = ([],[])
takeIt l1 (lt@(l2,t):lts)
| l1 == l2 = let (ts,lts') = takeIt l1 lts
in (t:ts,lts')
| otherwise = let (ts,lts') = takeIt l1 lts
in (ts,lt:lts')
uncover g env' (VClosure env c (Abs b x ty)) = case lookup x env' of
Just v -> uncover g env' (VClosure ((x,v):env) c ty)
Nothing -> error "Missing field"
uncover g env' (VClosure env c ty) = eval g env c ty []
uncover g _ v = v
tcRecField scope c l (mb_ann_ty,t) mb_ty = do
(t,ty) <- case mb_ann_ty of
@@ -938,22 +947,28 @@ tcRecField scope c l (mb_ann_ty,t) mb_ty = do
Nothing -> tcRho scope c t mb_ty
return (l,t,ty)
tcRecTypeFields scope c ls [] mb_ty = return ([],mb_ty)
tcRecTypeFields scope c ls ((l,ty):rs) mb_ty
| elem l ls = evalError ("Repeated definition for field" <+> l)
| otherwise = do
let (c1,c2) = split c
(ty,sort) <- tcRho scope c1 ty mb_ty
mb_ty <- case sort of
VSort s
| s == cType -> return (Just sort)
| s == cPType -> return mb_ty
VMeta _ _ -> return mb_ty
_ -> do sort <- value2termM False (scopeVars scope) sort
evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
"cannot be of type" <+> ppTerm Unqualified 0 sort)
(rs,mb_ty) <- tcRecTypeFields scope c2 (l:ls) rs mb_ty
return ((l,ty):rs,mb_ty)
tcRecTypeFields scope c rs mb_ty = go c [] rs [] mb_ty
where
go c ls [] env mb_ty = return ([],mb_ty)
go c ls ((l,deps,ty):rs) env mb_ty
| elem l ls = evalError ("Multiple definitions for field" <+> l)
| otherwise = do
let (c1,c23) = split c
(c2,c3) = split c23
let scope' = [x | x@(l,vty) <- env, l `elem` deps]++scope
(ty,sort) <- tcRho scope' c1 ty mb_ty
mb_ty <- case sort of
VSort s
| s == cType -> return (Just sort)
| s == cPType -> return mb_ty
VMeta _ _ -> return mb_ty
_ -> do sort <- value2termM False (scopeVars scope) sort
evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
"cannot be of type" <+> ppTerm Unqualified 0 sort)
g <- globals
(rs,mb_ty) <- go c2 (l:ls) rs ((label2ident l, eval g (scopeEnv scope) c3 ty []):scope) mb_ty
return ((l,deps,ty):rs,mb_ty)
-- | Invariant: if the third argument is (Just rho),
-- then rho is in weak-prenex form
@@ -1085,13 +1100,21 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do -
is_selection _ = False
is_trivial x _ = False
mkField scope l (mb_ty,t) (Just ty1) ty2 = do
(t,ty1,ty2) <- subsCheckRho scope t ty1 ty2
return ((l, (mb_ty,t)), (l, True, ty1))
mkField scope l (mb_ty,t) Nothing ty2 =
mkField scope l (mb_ty,t_proj) (Just ty1) ty2 = do
g <- globals
(t,ty1,ty2) <- subsCheckRho scope t_proj (uncover g ty1) ty2
return ((l, (mb_ty,t_proj)), (l, True, ty1))
where
uncover g (VClosure env c (Abs b x ty)) = let (c1,c2) = split c
v = eval g (scopeEnv scope) c2 (P t (ident2label x)) []
in uncover g (VClosure ((x,v):env) c1 ty)
uncover g (VClosure env c ty) = eval g env c ty []
uncover g v = v
mkField scope l (mb_ty,t_proj) Nothing ty2 =
case isLockLabel l of
Just _ -> return ((l, (Just (RecType []),R [])), (l, True, ty2))
Nothing -> return ((l, (mb_ty,t)), (l, True, ty2))
Nothing -> return ((l, (mb_ty,t_proj)), (l, True, ty2))
(scope,mkProj,wrap) <- mkAccess scope t
@@ -1105,7 +1128,7 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do -
Nothing -> empty)
missing -> evalError ("In the term" <+> pp t $$
"there are no values for fields:" <+> hsep missing)
rs <- sequence [mkField scope l t mb_ty1 ty2 | (l,_,ty2,mb_ty1) <- fields, Just t <- [mkProj l]]
rs <- sequence [mkField scope l t_proj mb_ty1 ty2 | (l,_,ty2,mb_ty1) <- fields, Just t_proj <- [mkProj l]]
return (wrap (R (map fst rs)),VRecType (foldl (\rs (_,(l,o,ty)) -> update3 l o ty rs) rs1 rs) ext2,ty2)
subsCheckRho scope t ty1 (VFV c (VarFree vs)) = do
ty2 <- variants c vs
src/compiler/api/GF/Compile/TypeCheck/TC.hs
+2 -2
View File
@@ -91,7 +91,7 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
QC c -> return $ VCn c ---- == Q ?
Sort c -> return $ VType --- the only sort is Type
App f a -> join $ liftM2 app (eval env f) (eval env a)
RecType xs -> do xs <- mapM (\(l,e) -> eval env e >>= \e -> return (l,e)) xs
RecType xs -> do xs <- mapM (\(l,_,e) -> eval env e >>= \e -> return (l,e)) xs
return (VRecType xs)
_ -> return $ VClos env e
@@ -212,7 +212,7 @@ inferExp th tenv@(k,rho,gamma) e = case e of
_ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
checkLabelling th tenv (lbl,typ) = do
checkLabelling th tenv (lbl,_,typ) = do
(atyp,cs) <- checkType th tenv typ
return ((lbl,atyp),cs)
src/compiler/api/GF/Grammar/Analyse.hs
+1 -1
View File
@@ -87,7 +87,7 @@ sizeTerm t = case t of
Table a c -> 1 + sizeTerm a + sizeTerm c
ExtR a c -> 1 + sizeTerm a + sizeTerm c
R r -> 1 + sum [1 + sizeTerm a | (_,(_,a)) <- r] -- label counts as 1, type ignored
RecType r -> 1 + sum [1 + sizeTerm a | (_,a) <- r] -- label counts as 1
RecType r -> 1 + sum [1 + sizeTerm a | (_,_,a) <- r] -- label counts as 1
P t i -> 2 + sizeTerm t
T _ cc -> 1 + sum [1 + sizeTerm (patt2term p) + sizeTerm v | (p,v) <- cc]
V ty cc -> 1 + sizeTerm ty + sum [1 + sizeTerm v | v <- cc]
src/compiler/api/GF/Grammar/Grammar.hs
+2 -2
View File
@@ -463,8 +463,8 @@ type Hypo = (BindType,Ident,Type) -- (x:A) (_:A) A ({x}:A)
type Context = [Hypo] -- (x:A)(y:B) (x,y:A) (_,_:A)
type Equation = ([Patt],Term)
type Labelling = (Label, Type)
type Assign = (Label, (Maybe Type, Term))
type Labelling = (Label, [Ident], Type)
type Assign = (Label, (Maybe Type, Term))
type Option = (Maybe Term, Term)
type Case = (Patt, Term)
--type Cases = ([Patt], Term)
src/compiler/api/GF/Grammar/JSON.hs
+2 -2
View File
@@ -102,7 +102,7 @@ term2json (Prod bt v t1 t2) = makeObj [("implicit", showJSON (bt==Implicit)), ("
term2json (Typed t ty) = makeObj [("term", term2json t), ("type", term2json ty)]
term2json (Example t s) = makeObj [("term", term2json t), ("example", showJSON s)]
term2json (RecType lbls) = makeObj [("rectype", makeObj (map toRow lbls))]
where toRow (l,t) = (showLabel l, term2json t)
where toRow (l,_,t) = (showLabel l, term2json t)
term2json (R lbls) = makeObj [("record", makeObj (map toRow lbls))]
where toRow (l,(_,t)) = (showLabel l, term2json t)
term2json (P t proj) = makeObj [("project", term2json t), ("label", showJSON (showLabel proj))]
@@ -184,7 +184,7 @@ json2term o = Vr <$> o!:"vr"
<|> Strs <$> (o!:"strs" >>= mapM json2term)
where
fromRow (lbl, jsvalue) = do value <- json2term jsvalue
return (readLabel lbl,value)
return (readLabel lbl,[],value)
fromRow' (lbl, jsvalue) = do value <- json2term jsvalue
return (readLabel lbl,(Nothing,value))
src/compiler/api/GF/Grammar/Lockfield.hs
+2 -2
View File
@@ -25,9 +25,9 @@ import GF.Data.Operations(ErrorMonad,Err(..))
lock :: Ident -> Term -> Term
lock c t@(RecType rs) =
let lbl = lockLabel c
in if elem lbl (map fst rs) || elem c [cString,cInt]
in if elem lbl [l | (l,_,_)<-rs] || elem c [cString,cInt]
then t --- don't add an extra copy of lock field, nor predef cats
else RecType (rs ++ [(lbl, RecType [])])
else RecType (rs ++ [(lbl, [], RecType [])])
lock c t@(R rs) =
let lbl = lockLabel c
in if elem lbl (map fst rs)
src/compiler/api/GF/Grammar/Lookup.hs
+2 -2
View File
@@ -194,7 +194,7 @@ allParamValues cnc ptyp =
QC c -> lookupParamValues cnc c
Q c -> lookupResDef cnc c >>= allParamValues cnc
RecType r -> do
let (ls,tys) = unzip $ sortByFst r
let (ls,lls,tys) = unzip3 $ sortByLbl r
tss <- mapM (allParamValues cnc) tys
return [R (zipAssign ls ts) | ts <- sequence tss]
Table pt vt -> do
@@ -204,7 +204,7 @@ allParamValues cnc ptyp =
_ -> raise (render ("cannot find parameter values for" <+> ptyp))
where
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2)
lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
src/compiler/api/GF/Grammar/Macros.hs
+11 -18
View File
@@ -29,7 +29,7 @@ import Control.Monad.Identity(Identity(..))
import qualified Data.Traversable as T(mapM)
import qualified Data.Map as Map
import Control.Monad (liftM, liftM2, liftM3, forM)
import Data.List (sortBy,nub)
import Data.List (nub)
import Data.Monoid
import Data.Graph
import GF.Text.Pretty(render,(<+>),($$),hsep,fsep,vcat,nest)
@@ -180,6 +180,9 @@ mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
mapLabellingM :: Monad m => (Term -> m c) -> [Labelling] -> m [(Label,[Ident],c)]
mapLabellingM f = mapM (\(l,deps,t) -> f t >>= \t -> return (l,deps,t))
mapAttrs :: Monad m => (Term -> m c) -> [(Ident,Term)] -> m [(Ident,c)]
mapAttrs f [] = return []
mapAttrs f ((id,t):as) = do t <- f t
@@ -194,7 +197,7 @@ mkRecord :: (Int -> Label) -> [Term] -> Term
mkRecord = mkRecordN 0
mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
mkRecTypeN int lab typs = RecType [(lab i, [], t) | (i,t) <- zip [int..] typs]
mkRecType :: (Int -> Label) -> [Type] -> Type
mkRecType = mkRecTypeN 0
@@ -261,7 +264,7 @@ tuple2record :: [Term] -> [Assign]
tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
tuple2recordType :: [Term] -> [Labelling]
tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
tuple2recordType ts = [(tupleLabel i,[],t) | (i,t) <- zip [1..] ts]
tuple2recordPatt :: [Patt] -> [(Label,Patt)]
tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
@@ -278,7 +281,7 @@ mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod
--plusRecType :: Type -> Type -> Err Type
plusRecType t1 t2 = case (t1, t2) of
(RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of
filter (`elem` [l | (l,_,_) <- r1]) [l | (l,_,_) <- r2] of
[] -> return (RecType (r1 ++ r2))
ls -> raise $ render ("clashing labels" <+> hsep ls)
_ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
@@ -294,7 +297,7 @@ plusRecord t1 t2 =
-- | default linearization type
defLinType :: Type
defLinType = RecType [(theLinLabel, typeStr)]
defLinType = RecType [(theLinLabel, [], typeStr)]
-- | refreshing variables
mkFreshVar :: [Ident] -> Ident -> Ident
@@ -402,7 +405,7 @@ composOp co trm =
S c a -> liftM2 S (co c) (co a)
Table a c -> liftM2 Table (co a) (co c)
R r -> liftM R (mapAssignM co r)
RecType r -> liftM RecType (mapPairsM co r)
RecType r -> liftM RecType (mapLabellingM co r)
P t i -> liftM2 P (co t) (return i)
ExtR a c -> liftM2 ExtR (co a) (co c)
Opts t os -> liftM2 Opts (co t) (mapM (\(t1,t2) -> liftM2 (,) (maybe (return Nothing) (liftM Just . co) t1) (co t2)) os)
@@ -453,8 +456,8 @@ collectOp co trm = case trm of
Table a c -> co a <> co c
ExtR a c -> co a <> co c
Opts t os -> co t <> mconcatMap (\(a,b) -> maybe mempty co a <> co b) os
R r -> mconcatMap (\ (_,(mt,a)) -> maybe mempty co mt <> co a) r
RecType r -> mconcatMap (co . snd) r
R r -> mconcatMap (\(_,(mt,a)) -> maybe mempty co mt <> co a) r
RecType r -> mconcatMap (\(_,_,t) -> co t) r
P t i -> co t
T _ cc -> mconcatMap (co . snd) cc -- not from patterns --- nor from type annot
V _ cc -> mconcatMap co cc --- nor from type annot
@@ -525,16 +528,6 @@ changeTableType co i = case i of
TWild ty -> co ty >>= return . TWild
_ -> return i
-- | normalize records and record types; put s first
sortRec :: [(Label,a)] -> [(Label,a)]
sortRec = sortBy ordLabel where
ordLabel (r1,_) (r2,_) =
case (showIdent (label2ident r1), showIdent (label2ident r2)) of
("s",_) -> LT
(_,"s") -> GT
(s1,s2) -> compare s1 s2
-- *** Dependencies
-- | dependency check, detecting circularities and returning topo-sorted list
src/compiler/api/GF/Grammar/Parser.y
+24 -19
View File
@@ -381,18 +381,20 @@ LhsNames
: LhsName { [$1] }
| LhsName ',' LhsNames { $1 : $3 }
LocDef :: { [(Ident, Maybe Type, Maybe Term)] }
LocDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] }
LocDef
: ListIdent ':' Exp { [(lab,Just $3,Nothing) | lab <- $1] }
| ListIdent '=' Exp { [(lab,Nothing,Just $3) | lab <- $1] }
| ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] }
: '$' Ident ':' Exp { [($2,True,Just $4,Nothing)] }
| ListIdent ':' Exp { [(lab,False,Just $3,Nothing) | lab <- $1] }
| ListIdent '=' Exp { [(lab,False,Nothing,Just $3) | lab <- $1] }
| ListIdent ':' Exp '=' Exp { [(lab,False,Just $3,Just $5) | lab <- $1] }
LocMarkupDef :: { [(Ident, Maybe Type, Maybe Term)] }
LocMarkupDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] }
LocMarkupDef
: ListIdent '=' Tag { [(lab,Nothing,Just $3) | lab <- $1] }
| ListIdent ':' Exp '=' Tag { [(lab,Just $3,Just $5) | lab <- $1] }
: '$' Ident '=' Tag { [($2,False,Nothing,Just $4)] }
| ListIdent '=' Tag { [(lab,False,Nothing,Just $3) | lab <- $1] }
| ListIdent ':' Exp '=' Tag { [(lab,False,Just $3,Just $5) | lab <- $1] }
ListLocDef :: { [(Ident, Maybe Type, Maybe Term)] }
ListLocDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] }
ListLocDef
: {- empty -} { [] }
| LocDef { $1 }
@@ -443,8 +445,8 @@ Exp3
| 'table' Exp6 '{' ListCase '}' { T (TTyped $2) $4 }
| 'table' Exp6 '[' ListExp ']' { V $2 $4 }
| Exp3 '*' Exp4 { case $1 of
RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)])
t -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)] }
RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),[],$3)])
t -> RecType [(tupleLabel 1,[],$1), (tupleLabel 2,[],$3)] }
| Exp3 '**' Exp4 { ExtR $1 $3 }
| Exp4 { $1 }
@@ -479,7 +481,7 @@ Exp5
Exp6 :: { Term }
Exp6
: Ident { Vr $1 }
: Ident { Vr $1 }
| Sort { Sort $1 }
| String { words2term (words $1) }
| Integer { EInt $1 }
@@ -805,20 +807,23 @@ listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]
mkId x i = if x == identW then (varX i) else x
tryLoc (c,mty,Just e) = return (c,(mty,e))
tryLoc (c,_ ,_ ) = fail ("local definition of" +++ showIdent c +++ "without value")
tryLoc (c,False,mty,Just e) = return (c,(mty,e))
tryLoc (c,True ,_ ,_ ) = fail ("Scoped record label " +++ showIdent c +++ "outside of a record")
tryLoc (c,_ ,_ ,_ ) = fail ("local definition of" +++ showIdent c +++ "without value")
mkR [] = return $ RecType [] --- empty record always interpreted as record type
mkR fs@(f:_) =
case f of
(lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType
_ -> mapM tryR fs >>= return . R
(lab,_,Just ty,Nothing) -> tryRT [] fs >>= return . RecType
_ -> mapM tryR fs >>= return . R
where
tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty)
tryRT (lab,_ ,_ ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
tryRT deps [] = return []
tryRT deps ((lab,scoped,Just ty,Nothing):fs) = do fs <- tryRT (if scoped then lab:deps else deps) fs
return ((ident2label lab,deps,ty):fs)
tryRT deps ((lab,_ ,_ ,_ ):fs) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
tryR (lab,mty,Just t) = return (ident2label lab,(mty,t))
tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab
tryR (lab,False,mty,Just t) = return (ident2label lab,(mty,t))
tryR (lab,_ ,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab
mkOverload pdt pdf@(Just (L loc df)) =
case appForm df of
src/compiler/api/GF/Grammar/Printer.hs
+4 -3
View File
@@ -35,7 +35,7 @@ import GF.Grammar.Grammar
import GF.Text.Pretty
import Data.Maybe (isNothing)
import Data.List (intersperse)
import Data.List (intersperse, nub)
import Data.Foldable (toList)
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
@@ -245,12 +245,13 @@ ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+>
fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
'=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
ppTerm q d (RecType xs)
| q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
| q == Terse = case [cat | (l,_,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
[cat] -> pp cat
_ -> doc
| otherwise = doc
where
doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
deps = nub [ident2label dep | (_,deps,_) <- xs, dep <- deps]
doc = braces (fsep (punctuate ';' [(if l `elem` deps then pp '$' else empty) <> l <+> ':' <+> ppTerm q 0 t | (l,bound,t) <- xs]))
ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
src/compiler/api/GF/Grammar/Unify.hs
+1 -1
View File
@@ -111,5 +111,5 @@ val2term v = case v of
VApp f c -> App (val2term f) (val2term c)
VCn c -> Q c
VGen i x -> Vr x
VRecType xs -> RecType (map (\(l,v) -> (l,val2term v)) xs)
VRecType xs -> RecType (map (\(l,v) -> (l,[],val2term v)) xs)
VType -> typeType