partial implementation for dependently typed records

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
+value2termM flat xs (VRecType lbls ext) = do
-  lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
+  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

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

@@ -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 []            trm = return Nothing
-    traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l)
+    traverse ((l,_,ty):rs) trm = do res <- mkRefField ty (P trm l)
-                                  case res of
+                                    case res of
-                                    Just trm -> return (Just trm)
+                                      Just trm -> return (Just trm)
-                                    Nothing  -> traverse rs 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
+          mapAccumL (\(ms,s,r,params) (lbl,_,ty) -> case lbl of
-                                                    LVar j -> ((ms,s,r,params),(lbl,(Just ty,TSymVar d j)))
+                                                      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
+                                                      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))))
+                                                                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 []                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 ((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 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 []                = return (0,[],1)
-    compute ((lbl,ty):lbls) = do
+    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

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

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

@@ -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
+checkRecFields scope c lts env [] = do
-  | null ltys                            = return []
+  unless (null lts) $
-  | otherwise                            = evalError ("Missing fields:" <+> hsep [l | (l,_,_) <- ltys])
+    evalWarn ("Discarded fields:" <+> hsep [l | (l,_) <- lts])
-checkRecFields scope c ls ((l,t):lts) ltys
+  return []
-  | elem l ls = evalError ("Repeated definition for field" <+> l)
+checkRecFields scope c lts env ((l,_,ty):ltys) =
-  | otherwise =
+  case takeIt l lts of
-      case takeIt l ltys of
+    ([], lts) -> evalError ("Missing field" <+> l)
-        (Just ty,ltys) -> do let (c1,c2) = split c
+    ([t],lts) -> do g <- globals
-                             ltty  <- tcRecField scope c1 l t (Just ty)
+                    let (c1,c23) = split c
-                             lttys <- checkRecFields scope c2 ls lts ltys
+                        (c2,c3)  = split c23
-                             return (ltty : lttys)
+                        env' = (label2ident l,eval g (scopeEnv scope) c3 (snd t) []):env
-        (Nothing,ltys) -> do evalWarn ("Discarded field:" <+> l)
+                    ltty  <- tcRecField scope c1 l t (Just (uncover g env ty))
-                             lttys <- checkRecFields scope c ls lts ltys
+                    lttys <- checkRecFields scope c2 lts env' ltys
-                             return lttys     -- ignore the field
+                    return (ltty : lttys)
+    (_,  lts) -> evalError ("Multiple definitions for field" <+> l)
   where
-    takeIt l1 []  = (Nothing, [])
+    takeIt l1 []  = ([],[])
-    takeIt l1 (lty@(l2,_,ty):ltys)
+    takeIt l1 (lt@(l2,t):lts)
-      | l1 == l2  = (Just ty,ltys)
+      | l1 == l2  = let (ts,lts') = takeIt l1 lts
-      | otherwise = let (mb_ty,ltys') = takeIt l1 ltys
+                    in (t:ts,lts')
-                    in (mb_ty,lty:ltys')
+      | 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 rs mb_ty = go c [] rs [] mb_ty
-tcRecTypeFields scope c ls ((l,ty):rs) mb_ty
+  where
-  | elem l ls = evalError ("Repeated definition for field" <+> l)
+    go c ls []               env mb_ty = return ([],mb_ty)
-  | otherwise = do
+    go c ls ((l,deps,ty):rs) env mb_ty
-      let (c1,c2) = split c
+      | elem l ls = evalError ("Multiple definitions for field" <+> l)
-      (ty,sort) <- tcRho scope c1 ty mb_ty
+      | otherwise = do
-      mb_ty <- case sort of
+          let (c1,c23) = split c
-                 VSort s
+              (c2,c3)  = split c23
-                    | s == cType  -> return (Just sort)
+
-                    | s == cPType -> return mb_ty
+          let scope' = [x | x@(l,vty) <- env, l `elem` deps]++scope
-                 VMeta _ _       -> return mb_ty
+          (ty,sort) <- tcRho scope' c1 ty mb_ty
-                 _               -> do sort <- value2termM False (scopeVars scope) sort
+          mb_ty <- case sort of
-                                       evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
+                     VSort s
-                                                  "cannot be of type" <+> ppTerm Unqualified 0 sort)
+                       | s == cType  -> return (Just sort)
-      (rs,mb_ty) <- tcRecTypeFields scope c2 (l:ls) rs mb_ty
+                       | s == cPType -> return mb_ty
-      return ((l,ty):rs,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
+      mkField scope l (mb_ty,t_proj) (Just ty1) ty2 = do
-        (t,ty1,ty2) <- subsCheckRho scope t ty1 ty2
+        g <- globals
-        return ((l, (mb_ty,t)), (l, True, ty1))
+        (t,ty1,ty2) <- subsCheckRho scope t_proj (uncover g ty1) ty2
-      mkField scope l (mb_ty,t) Nothing    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

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

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

@@ -463,7 +463,7 @@ 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 Labelling = (Label, [Ident], Type)
 type Assign = (Label, (Maybe Type, Term))
 type Option = (Maybe Term, Term)
 type Case = (Patt, Term) 

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

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)

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

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
+  R r          -> mconcatMap (\(_,(mt,a)) -> maybe mempty co mt <> co a) r
-  RecType r    -> mconcatMap (co . snd) 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

@@ -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] } 
+  : '$' Ident ':' Exp         { [($2,True,Just $4,Nothing)] }
-  | ListIdent '=' Exp         { [(lab,Nothing,Just $3) | lab <- $1] }
+  | ListIdent ':' Exp         { [(lab,False,Just $3,Nothing) | lab <- $1] } 
-  | ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | 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] }
+  : '$' Ident '=' Tag         { [($2,False,Nothing,Just $4)] }
-  | ListIdent ':' Exp '=' Tag { [(lab,Just $3,Just $5) | lab <- $1] }
+  | 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)])
+                                         RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),[],$3)])
-                                         t          -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$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,False,mty,Just e) = return (c,(mty,e))
-tryLoc (c,_  ,_     ) = fail ("local definition of" +++ showIdent c +++ "without value")
+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
+    (lab,_,Just ty,Nothing) ->   tryRT [] fs >>= return . RecType
-    _                     -> mapM tryR  fs >>= return . R
+    _                       -> mapM tryR  fs >>= return . R
   where
-    tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty)
+    tryRT deps []                                = return []
-    tryRT (lab,_      ,_      ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
+    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,False,mty,Just t) = return (ident2label lab,(mty,t))
-    tryR (lab,_  ,_     ) = fail $ "illegal record field" +++ showIdent lab
+    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

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

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