Implement nested record updates.

README.md

@@ -228,6 +228,8 @@ MicroHs implements the record dot extensions.
 So accessing a field `a` in record `r` is written `r.a`.
 Updating a field has the usual Haskell syntax `r{ a = e }`, but the type is overloaded so this can update the `a` field in any record.
 The typeclass `HasField` captures this.  `HasField "name" rec ty` expresses that the record type `rec` has a field `name` with type `ty`.
+Record updates can also update nested fields, e.g., `r{ a.b.c = e }`.  Note that this will not work in GHC, since GHC does not
+fully implement `OverloadedRecordUpdate` has not been fully implemented in GHC.
 
 ### Features
 The runtime system can serialize and deserialize any expression

lib/Data/Records.hs

@@ -23,6 +23,11 @@ composeGetSet gs1 gs2 a =
       case gs2 b of
         (c, c_to_b) -> (c, b_to_a . c_to_b)
 
+composeSet :: forall a b c . GetSet a b -> (b -> c -> b) -> (a -> c -> a)
+composeSet gs1 b_to_c_to_b a c =
+  case gs1 a of
+    (b, b_to_a) -> b_to_a (b_to_c_to_b b c)
+
 -----------------------------------
 -- Virtual fields for tuples.
 

src/MicroHs/Expr.hs

@@ -98,7 +98,7 @@ data Expr
   | EIf Expr Expr Expr
   | ESign Expr EType
   | ENegApp Expr
-  | EUpdate Expr [(Ident, Expr)]
+  | EUpdate Expr [([Ident], Expr)]
   | ESelect [Ident]
   -- only in patterns
   | EAt Ident Expr
@@ -630,7 +630,7 @@ ppExpr ae =
     EListish l -> ppListish l
     ESign e t -> parens $ ppExpr e <+> text "::" <+> ppEType t
     ENegApp e -> text "-" <+> ppExpr e
-    EUpdate ee ies -> ppExpr ee <> text "{" <+> hsep (punctuate (text ",") (map (\ (i, e) -> ppIdent i <+> text "=" <+> ppExpr e) ies)) <+> text "}"
+    EUpdate ee ies -> ppExpr ee <> text "{" <+> hsep (punctuate (text ",") (map (\ (is, e) -> hcat (punctuate (text ".") (map ppIdent is)) <+> text "=" <+> ppExpr e) ies)) <+> text "}"
     ESelect is -> parens $ hcat $ map (\ i -> text "." <> ppIdent i) is
     EAt i e -> ppIdent i <> text "@" <> ppExpr e
     EViewPat e p -> parens $ ppExpr e <+> text "->" <+> ppExpr p

src/MicroHs/Parse.hs

@@ -546,8 +546,8 @@ pAExpr = do
             | otherwise = EApp (ESelect ss) e
   pure $ sel (foldl EUpdate ee us)
 
-pUpdate :: P [(Ident, Expr)]
-pUpdate = pSpec '{' *> esepBy ((,) <$> (pLIdentSym <* pSymbol "=") <*> pExpr) (pSpec ',') <* pSpec '}'
+pUpdate :: P [([Ident], Expr)]
+pUpdate = pSpec '{' *> esepBy ((,) <$> (((:) <$> pLIdentSym <*> many pSelect) <* pSymbol "=") <*> pExpr) (pSpec ',') <* pSpec '}'
 
 pSelect :: P Ident
 pSelect = do

src/MicroHs/TypeCheck.hs

@@ -1563,29 +1563,47 @@ tcExprR mt ae =
       withVks vks $ \ vks' -> do
         tt <- tcExpr mt t
         return (EForall vks' tt)
-    EUpdate e ies -> do
+    EUpdate e ises -> do
       (e', _) <- tInferExpr e
       case e' of
         ECon c -> do
           let fs = conFields c
+              ies = map (first head) ises
               is = map fst ies
               as = map field fs
               field i = fromMaybe (unsetField i) $ lookup i ies
+          case filter ((> 1) . length . fst) ises of
+            (i:_, _):_ -> tcError (getSLoc i) "Nested construction not allowed"
+            _ -> return ()
           case is \\ fs of
             vs@(v:_) -> tcError (getSLoc v) $ "extra field(s) " ++ unwords (map unIdent vs)
             _ -> return ()
           tcExpr mt (foldl EApp e as)
         _ -> do
-          let set = foldr eSetField e ies
+          let set = foldr eSetFields e ises
           tcExpr mt set
     ESelect is -> do
         let x = eVarI loc "$x"
         tcExpr mt $ eLam [x] $ foldl (\ e i -> EApp (eGetField i) e) x is
     _ -> error $ "tcExpr: cannot handle: " ++ show (getSLoc ae) ++ " " ++ show ae
       -- impossible
 
-eSetField :: (Ident, Expr) -> Expr -> Expr
-eSetField (i, e) r = EApp (EApp (EApp (EVar iset) (eProxy i)) r) e
+eSetFields :: ([Ident], Expr) -> Expr -> Expr
+--eSetFields ([i], e) r = eSetField (i, e) r
+eSetFields (is, e) r =
+  let loc = getSLoc is
+      eCompose = EVar $ mkIdentSLoc loc "composeSet"
+      has = map eHasField $ init is
+      set1 = eSetField (last is)
+      set = foldr (EApp . EApp eCompose) set1 has
+  in  EApp (EApp set r) e
+
+eHasField :: Ident -> Expr
+eHasField i = EApp (EVar ihas) (eProxy i)
+  where ihas = mkIdentSLoc (getSLoc i) "hasField"
+
+eSetField :: Ident -> Expr
+eSetField i = EApp (EVar iset) (eProxy i)
   where iset = mkIdentSLoc (getSLoc i) "setField"
 
 eGetField :: Ident -> Expr

tests/Record.hs

@@ -6,10 +6,13 @@ import Prelude
 data R = CR { a :: Int, b :: Bool }
 
 instance Show R where
-  show (CR a b) = "R{a=" ++ show a ++ ",b=" ++ show b ++ "}"
+  show (CR a b) = "CR{a=" ++ show a ++ ",b=" ++ show b ++ "}"
 
 data RR = CRR { r :: R, a :: Bool }
 
+instance Show RR where
+  show (CRR r a) = "CRR{r=" ++ show r ++ ",a=" ++ show a ++ "}"
+
 r1 :: R
 r1 = CR { a=1, b=True }
 
@@ -31,6 +34,9 @@ r6 = r1 { a = (10::Int), b=False }
 rr1 :: RR
 rr1 = CRR { r = r1, a = True }
 
+r7 :: RR
+r7 = rr1{ r.a = 999 }
+
 sel_a :: forall r t . HasField "a" r t => r -> t
 sel_a = (.a)
 
@@ -53,6 +59,7 @@ main = do
 --  print r3
   print r5
   print r6
+  print r7
   print $ r2.a
   print $ r2.b
   print $ rr1.r.a

tests/Record.ref

@@ -1,7 +1,8 @@
-R{a=1,b=True}
-R{a=2,b=True}
-R{a=10,b=True}
-R{a=10,b=False}
+CR{a=1,b=True}
+CR{a=2,b=True}
+CR{a=10,b=True}
+CR{a=10,b=False}
+CRR{r=CR{a=999,b=True},a=True}
 2
 True
 1