diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs index 9b6f16176..55494815f 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete.hs @@ -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)) diff --git a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs index 03da6ac83..1a7cb52e5 100644 --- a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs @@ -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) diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs index a9777c06d..7ce0377f6 100644 --- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs @@ -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)) diff --git a/src/compiler/api/GF/Compile/GrammarToCanonical.hs b/src/compiler/api/GF/Compile/GrammarToCanonical.hs index 7b859b1d1..ced7d309a 100644 --- a/src/compiler/api/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/api/GF/Compile/GrammarToCanonical.hs @@ -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 diff --git a/src/compiler/api/GF/Compile/Rename.hs b/src/compiler/api/GF/Compile/Rename.hs index 6015f3a7a..b6233b8f7 100644 --- a/src/compiler/api/GF/Compile/Rename.hs +++ b/src/compiler/api/GF/Compile/Rename.hs @@ -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 = diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs index 733b8eb23..3594927ae 100644 --- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs @@ -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 diff --git a/src/compiler/api/GF/Compile/TypeCheck/TC.hs b/src/compiler/api/GF/Compile/TypeCheck/TC.hs index e06c5b5a9..fb9049aaa 100644 --- a/src/compiler/api/GF/Compile/TypeCheck/TC.hs +++ b/src/compiler/api/GF/Compile/TypeCheck/TC.hs @@ -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) diff --git a/src/compiler/api/GF/Grammar/Analyse.hs b/src/compiler/api/GF/Grammar/Analyse.hs index 64a7fa4d4..4277f9aeb 100644 --- a/src/compiler/api/GF/Grammar/Analyse.hs +++ b/src/compiler/api/GF/Grammar/Analyse.hs @@ -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] diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs index c113fe8d3..642b696e3 100644 --- a/src/compiler/api/GF/Grammar/Grammar.hs +++ b/src/compiler/api/GF/Grammar/Grammar.hs @@ -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) diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs index 7cb76054c..65a48e213 100644 --- a/src/compiler/api/GF/Grammar/JSON.hs +++ b/src/compiler/api/GF/Grammar/JSON.hs @@ -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)) diff --git a/src/compiler/api/GF/Grammar/Lockfield.hs b/src/compiler/api/GF/Grammar/Lockfield.hs index cab066811..da2056d67 100644 --- a/src/compiler/api/GF/Grammar/Lockfield.hs +++ b/src/compiler/api/GF/Grammar/Lockfield.hs @@ -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) diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs index 6d427fc5d..6c133e085 100644 --- a/src/compiler/api/GF/Grammar/Lookup.hs +++ b/src/compiler/api/GF/Grammar/Lookup.hs @@ -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 diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs index 004fcdd59..952ac069b 100644 --- a/src/compiler/api/GF/Grammar/Macros.hs +++ b/src/compiler/api/GF/Grammar/Macros.hs @@ -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 diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y index 54381807d..9ffc2b30a 100644 --- a/src/compiler/api/GF/Grammar/Parser.y +++ b/src/compiler/api/GF/Grammar/Parser.y @@ -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 diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs index ff6817f5c..33442db89 100644 --- a/src/compiler/api/GF/Grammar/Printer.hs +++ b/src/compiler/api/GF/Grammar/Printer.hs @@ -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) diff --git a/src/compiler/api/GF/Grammar/Unify.hs b/src/compiler/api/GF/Grammar/Unify.hs index 3a7f0edef..4446cfb32 100644 --- a/src/compiler/api/GF/Grammar/Unify.hs +++ b/src/compiler/api/GF/Grammar/Unify.hs @@ -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