Commit 27fde9af authored by Shayne Fletcher's avatar Shayne Fletcher 🥝

C2a compliant. Final version.

parent 853efbfb
......@@ -995,7 +995,7 @@ cvtl e = wrapL (cvt e)
; flds'
<- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
flds
; return $ mkRdrRecordUpd e' flds' }
; return $ mkRdrRecordUpd False e' flds' }
cvt (StaticE e) = fmap (HsStatic noExtField) $ cvtl e
cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is
-- important, because UnboundVarE may contain
......
......@@ -2834,9 +2834,10 @@ aexp :: { ECP }
aexp1 :: { ECP }
: aexp1 '{' fbinds '}' { ECP $
getBit RecordDotSyntaxBit >>= \ dot ->
runECP_PV $1 >>= \ $1 ->
$3 >>= \ $3 ->
amms (mkHsRecordPV (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3))
amms (mkHsRecordPV dot (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3))
(moc $2:mcc $4:(fst $3)) }
| aexp1 '{' pbinds '}' {% runECP_P $1 >>= \ $1 -> fmap ecpFromExp $ applyFieldUpdates $1 $3 }
| aexp2 { $1 }
......@@ -4205,85 +4206,4 @@ asl :: [Located a] -> Located b -> Located a -> P ()
asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls
asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
-----------------------------------------
-- Bits and pieces for RecordDotSyntax.
mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs
mkParen = noLoc . HsPar noExtField
mkVar :: String -> LHsExpr GhcPs
mkVar = noLoc . HsVar noExtField . noLoc . mkRdrUnqual . mkVarOcc
mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkApp x = noLoc . HsApp noExtField x
mkOpApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkOpApp x op = noLoc . OpApp noExtField x op
mkAppType :: LHsExpr GhcPs -> GenLocated SrcSpan (HsType (NoGhcTc GhcPs)) -> LHsExpr GhcPs
mkAppType expr = noLoc . HsAppType noExtField expr . HsWC noExtField
mkSelector :: FastString -> LHsType GhcPs
mkSelector = noLoc . HsTyLit noExtField . HsStrTy NoSourceText
get_field, set_field :: LHsExpr GhcPs
get_field = mkVar "getField"
set_field = mkVar "setField"
-- Test if the expression is a 'getField @"..."' expression.
isGet :: LHsExpr GhcPs -> Bool
isGet (L _ (HsAppType _ (L _ (HsVar _ (L _ name))) _)) = occNameString (rdrNameOcc name) == "getField"
isGet _ = False
zPat :: LPat GhcPs
zVar, circ :: LHsExpr GhcPs
zPat = noLoc $ VarPat noExtField (noLoc $ mkRdrUnqual (mkVarOcc "z"))
zVar = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc "z"))
circ = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc "."))
-- mkProj rhs fIELD calculates a projection.
-- e.g. .x = mkProj Nothing x = \z -> z.x = \z -> (getField @fIELD x)
-- .x.y = mkProj Just(.x) y = (.y) . (.x) = (\z -> z.y) . (\z -> z.x)
mkProj :: Maybe (LHsExpr GhcPs) -> FastString -> LHsExpr GhcPs
mkProj rhs fIELD =
let body = mkGet zVar fIELD
grhs = noLoc $ GRHS noExtField [] body
ghrss = GRHSs noExtField [grhs] (noLoc (EmptyLocalBinds noExtField))
m = noLoc $ Match {m_ext=noExtField, m_ctxt=LambdaExpr, m_pats=[zPat], m_grhss=ghrss}
lhs = mkParen (noLoc $ HsLam noExtField MG {mg_ext=noExtField, mg_alts=noLoc [m], mg_origin=Generated}) in
maybe lhs (mkParen . mkOpApp lhs circ) rhs
-- mkGet arg fIELD calcuates a getField @fIELD arg expression.
-- e.g. z.x = mkGet z x = get_field @x z
mkGet :: LHsExpr GhcPs -> FastString -> LHsExpr GhcPs
mkGet arg fIELD = head $ mkGet' [arg] fIELD
mkGet' :: [LHsExpr GhcPs] -> FastString -> [LHsExpr GhcPs]
mkGet' l@(r : _) fIELD = get_field `mkAppType` mkSelector fIELD `mkApp` mkParen r : l
-- mkSet acc (fIELD, g) calcuates a setField @fIELD arg expression.
-- e.g. mkSet a (foo, g) = setField@"foo" (g a).
mkSet :: LHsExpr GhcPs -> (FastString, LHsExpr GhcPs) -> LHsExpr GhcPs
mkSet acc (fIELD, g) = set_field `mkAppType` mkSelector fIELD `mkApp` mkParen g `mkApp` mkParen acc
-- mkFieldUpdater calculates functions representing dot notation record updates.
mkFieldUpdater :: [FastString] -> LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs)
mkFieldUpdater -- e.g {foo.bar.baz.quux = 43}
fIELDS -- [foo, bar, baz, quux]
arg -- This is 'texp' (43 in the example).
= let {
; final = last fIELDS -- quux
; fields = init fIELDS -- [foo, bar, baz]
; getters = \a -> foldl' mkGet' [a] fields -- Ordered from deep to shallow.
-- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a]
; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow.
-- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)]
}
in \a -> foldl' mkSet arg (zips a)
-- setField@"foo" (a) (setField@"bar" (getField @"foo" (a))(setField@"baz" (getField @"bar" (getField @"foo" (a)))(setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" (a))))(quux))))
applyFieldUpdates :: LHsExpr GhcPs -> [LHsExpr GhcPs -> LHsExpr GhcPs] -> P (LHsExpr GhcPs)
applyFieldUpdates a updates = return $ foldl' apply a updates
where apply r update = update r
-----------------------------------------
}
......@@ -16,8 +16,9 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module RdrHsSyn (
mkHsRecordUp',
module RdrHsSyn (
mkApp, mkGet, mkVar, mkFieldUpdater, mkProj, isGet, applyFieldUpdates, -- RecordDot
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkSpliceDecl,
......@@ -30,7 +31,7 @@ module RdrHsSyn (
mkFamDecl, mkLHsSigType,
mkInlinePragma,
mkPatSynMatchGroup,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
mkRecConstrOrUpdate,
mkTyClD, mkInstD,
mkRdrRecordCon, mkRdrRecordUpd,
setRdrNameSpace,
......@@ -1788,6 +1789,7 @@ class b ~ (Body b) GhcPs => DisambECP b where
mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b)
-- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)
mkHsRecordPV ::
Bool -> -- Is RecordDotSyntax in effect?
SrcSpan ->
SrcSpan ->
Located b ->
......@@ -1885,7 +1887,7 @@ instance DisambECP (HsCmd GhcPs) where
mkHsExplicitListPV l xs = cmdFail l $
brackets (fsep (punctuate comma (map ppr xs)))
mkHsSplicePV (L l sp) = cmdFail l (ppr sp)
mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $
mkHsRecordPV _ l _ a (fbinds, ddLoc) = cmdFail l $
ppr a <+> ppr (mk_rec_fields fbinds ddLoc)
mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a)
mkHsSectionR_PV l op c = cmdFail l $
......@@ -1940,8 +1942,8 @@ instance DisambECP (HsExpr GhcPs) where
mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig))
mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs)
mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp
mkHsRecordPV l lrec a (fbinds, ddLoc) = do
r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc)
mkHsRecordPV dot l lrec a (fbinds, ddLoc) = do
r <- mkRecConstrOrUpdate dot a lrec (fbinds, ddLoc)
checkRecordSyntax (L l r)
mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr)
mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e)
......@@ -1962,12 +1964,6 @@ instance DisambECP (HsExpr GhcPs) where
hang (text "A pragma is not allowed in this position:") 2 (ppr prag)
rejectPragmaPV _ = return ()
mkHsRecordUp' :: SrcSpan -> SrcSpan -> LHsExpr GhcPs -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) -> LHsExpr GhcPs
mkHsRecordUp' l lrec a (fbinds, ddLoc) =
L l (mkRecUpdate' a lrec (fbinds, ddLoc))
mkRecUpdate' exp _ (fs,dd) =
mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)
patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
patSynErr item l e explanation =
do { addError l $
......@@ -2031,7 +2027,7 @@ instance DisambECP (PatBuilder GhcPs) where
ps <- traverse checkLPat xs
return (L l (PatBuilderPat (ListPat noExtField ps)))
mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))
mkHsRecordPV l _ a (fbinds, ddLoc) = do
mkHsRecordPV _ l _ a (fbinds, ddLoc) = do
r <- mkPatRec a (mk_rec_fields fbinds ddLoc)
checkRecordSyntax (L l r)
mkHsNegAppPV l (L lp p) = do
......@@ -2516,23 +2512,26 @@ checkPrecP (L l (_,i)) (L _ ol)
, getRdrName funTyCon ]
mkRecConstrOrUpdate
:: LHsExpr GhcPs
:: Bool
-> LHsExpr GhcPs
-> SrcSpan
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> PV (HsExpr GhcPs)
mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
mkRecConstrOrUpdate _ (L l (HsVar _ (L _ c))) _ (fs,dd)
| isRdrDataCon c
= return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp _ (fs,dd)
mkRecConstrOrUpdate dot exp _ (fs,dd)
| Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")
| otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
| otherwise = return (mkRdrRecordUpd dot exp (map (fmap mk_rec_upd_field) fs))
mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd exp flds
= RecordUpd { rupd_ext = noExtField
, rupd_expr = exp
, rupd_flds = flds }
mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd dot exp flds
-- If RecordDotSyntax is in effect produce a set_field expression.
| dot = unLoc $ foldl' mkSetField exp flds
| otherwise = RecordUpd { rupd_ext = noExtField
, rupd_expr = exp
, rupd_flds = flds }
mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon con flds
......@@ -3096,3 +3095,105 @@ starSym False = "*"
forallSym :: Bool -> String
forallSym True = "∀"
forallSym False = "forall"
-----------------------------------------
-- Bits and pieces for RecordDotSyntax.
mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs
mkParen = noLoc . HsPar noExtField
mkVar :: String -> LHsExpr GhcPs
mkVar = noLoc . HsVar noExtField . noLoc . mkRdrUnqual . mkVarOcc
mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkApp x = noLoc . HsApp noExtField x
mkOpApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkOpApp x op = noLoc . OpApp noExtField x op
mkAppType :: LHsExpr GhcPs -> GenLocated SrcSpan (HsType (NoGhcTc GhcPs)) -> LHsExpr GhcPs
mkAppType expr = noLoc . HsAppType noExtField expr . HsWC noExtField
mkSelector :: FastString -> LHsType GhcPs
mkSelector = noLoc . HsTyLit noExtField . HsStrTy NoSourceText
get_field, set_field :: LHsExpr GhcPs
get_field = mkVar "getField"
set_field = mkVar "setField"
-- Test if the expression is a 'getField @"..."' expression.
isGet :: LHsExpr GhcPs -> Bool
isGet (L _ (HsAppType _ (L _ (HsVar _ (L _ name))) _)) = occNameString (rdrNameOcc name) == "getField"
isGet _ = False
zPat :: LPat GhcPs
zVar, circ :: LHsExpr GhcPs
zPat = noLoc $ VarPat noExtField (noLoc $ mkRdrUnqual (mkVarOcc "z"))
zVar = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc "z"))
circ = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc "."))
-- mkProj rhs fIELD calculates a projection.
-- e.g. .x = mkProj Nothing x = \z -> z.x = \z -> (getField @fIELD x)
-- .x.y = mkProj Just(.x) y = (.y) . (.x) = (\z -> z.y) . (\z -> z.x)
mkProj :: Maybe (LHsExpr GhcPs) -> FastString -> LHsExpr GhcPs
mkProj rhs fIELD =
let body = mkGet zVar fIELD
grhs = noLoc $ GRHS noExtField [] body
ghrss = GRHSs noExtField [grhs] (noLoc (EmptyLocalBinds noExtField))
m = noLoc $ Match {m_ext=noExtField, m_ctxt=LambdaExpr, m_pats=[zPat], m_grhss=ghrss}
lhs = mkParen (noLoc $ HsLam noExtField MG {mg_ext=noExtField, mg_alts=noLoc [m], mg_origin=Generated}) in
maybe lhs (mkParen . mkOpApp lhs circ) rhs
-- mkGet arg fIELD calcuates a get_field @fIELD arg expression.
-- e.g. z.x = mkGet z x = get_field @x z
mkGet :: LHsExpr GhcPs -> FastString -> LHsExpr GhcPs
mkGet arg fIELD = head $ mkGet' [arg] fIELD
mkGet' :: [LHsExpr GhcPs] -> FastString -> [LHsExpr GhcPs]
mkGet' l@(r : _) fIELD = get_field `mkAppType` mkSelector fIELD `mkApp` mkParen r : l
mkGet' [] _ = panic "mkGet' : The impossible has happened!"
-- mkSet a fIELD b calculates a set_field @fIELD expression.
-- e.g mkSet a fIELD b = set_field @"fIELD" a b (read as "set field 'fIELD' on a to b").
mkSet :: LHsExpr GhcPs -> FastString -> LHsExpr GhcPs -> LHsExpr GhcPs
mkSet a fIELD b = set_field `mkAppType` mkSelector fIELD `mkApp` a `mkApp` b
-- mkFieldUpdater calculates functions representing dot notation record updates.
mkFieldUpdater :: [FastString] -> LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs)
mkFieldUpdater -- e.g {foo.bar.baz.quux = 43}
fIELDS -- [foo, bar, baz, quux]
arg -- This is 'texp' (43 in the example).
= let {
; final = last fIELDS -- quux
; fields = init fIELDS -- [foo, bar, baz]
; getters = \a -> foldl' mkGet' [a] fields -- Ordered from deep to shallow.
-- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a]
; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow.
-- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)]
}
in \a -> foldl' mkSet' arg (zips a)
-- setField@"foo" (a) (setField@"bar" (getField @"foo" (a))(setField@"baz" (getField @"bar" (getField @"foo" (a)))(setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" (a))))(quux))))
where
mkSet' :: LHsExpr GhcPs -> (FastString, LHsExpr GhcPs) -> LHsExpr GhcPs
mkSet' acc (fIELD, g) = mkSet (mkParen g) fIELD (mkParen acc)
-- Called from mkRdrRecordUpd.
mkSetField :: LHsExpr GhcPs -> LHsRecUpdField GhcPs -> LHsExpr GhcPs
mkSetField e (L _ (HsRecField occ arg _)) = mkSet e (fsLit $ field occ) (val arg)
where
val :: LHsExpr GhcPs -> LHsExpr GhcPs
val arg = if isPun arg then mkVar $ field occ else arg
isPun :: LHsExpr GhcPs -> Bool
isPun = \case
L _ (HsVar _ (L _ p)) -> p == pun_RDR
_ -> False
field :: Located (AmbiguousFieldOcc GhcPs) -> String
field = \case
L _ (Ambiguous _ (L _ lbl)) -> occNameString . rdrNameOcc $ lbl
L _ (Unambiguous _ (L _ lbl)) -> occNameString . rdrNameOcc $ lbl
_ -> "" -- Extension ctor.
applyFieldUpdates :: LHsExpr GhcPs -> [LHsExpr GhcPs -> LHsExpr GhcPs] -> P (LHsExpr GhcPs)
applyFieldUpdates a updates = return $ foldl' apply a updates
where apply r update = update r
{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecordDotSyntax #-}
-- Choice (C2a).
......@@ -10,44 +11,44 @@ class HasField x r a | x r -> a where
hasField :: r -> (a -> r, a)
getField :: forall x r a . HasField x r a => r -> a
getField = snd . hasField @x
getField = snd . hasField @x -- Note: a.x = is getField @"x" a.
setField :: forall x r a . HasField x r a => r -> a -> r
setField = fst . hasField @x
setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
-- 'Foo' has 'foo' field of type 'Bar'
data Foo = Foo {foo :: Bar} deriving (Show, Eq)
instance HasField "foo" Foo Bar where
hasField r = (\x -> r{foo = x}, foo r)
hasField r = (\x -> case r of Foo{..} -> Foo {foo = x, ..}, foo r)
-- 'Bar' has a 'bar' field of type 'Baz'
data Bar = Bar {bar :: Baz} deriving (Show, Eq)
instance HasField "bar" Bar Baz where
hasField r = (\x -> r{bar = x}, bar r)
hasField r = (\x -> case r of Bar{..} -> Bar {bar = x, ..}, bar r)
-- 'Baz' has a 'baz' field of type 'Quux'
data Baz = Baz {baz :: Quux} deriving (Show, Eq)
instance HasField "baz" Baz Quux where
hasField r = (\x -> r{baz = x}, baz r)
hasField r = (\x -> case r of Baz{..} -> Baz {baz = x, ..}, baz r)
-- 'Quux' has a 'quux' field of type 'Int'
data Quux = Quux {quux :: Int} deriving (Show, Eq)
instance HasField "quux" Quux Int where
hasField r = (\x -> r{quux = x}, quux r)
hasField r = (\x -> case r of Quux{..} -> Quux {quux = x, ..}, quux r)
-- 'Corge' has a '&&&' field of type 'Int'
data Corge = Corge {(&&&) :: Int} deriving (Show, Eq)
instance HasField "&&&" Corge Int where
hasField r = (\x -> r{(&&&) = x}, (&&&) r)
hasField r = (\x -> case r of Corge{..} -> Corge {(&&&) = x, ..}, (&&&) r)
-- Note : Dot notation is not available for fields with operator
-- names.
-- 'Grault' has two fields 'f' and 'g' of type 'Foo'.
data Grault = Grault {f :: Foo, g :: Foo} deriving (Show, Eq)
instance HasField "f" Grault Foo where
hasField r = (\x -> r{f = x}, f r)
hasField r = (\x -> case r of Grault{..} -> Grault {f = x, ..}, f r)
instance HasField "g" Grault Foo where
hasField r = (\x -> r{g = x}, g r)
hasField r = (\x -> case r of Grault{..} -> Grault {g = x, ..}, g r)
main = do
let a = Foo {foo = Bar{bar = Baz {baz = Quux {quux = 42}}}}
......@@ -57,7 +58,7 @@ main = do
, g = Foo {foo = Bar{bar = Baz {baz = Quux {quux = 1}}}}
}
-- A "selectors" is an expression like '(.a)' or '(.a.b)'.
-- A "selector" is an expression like '(.a)' or '(.a.b)'.
putStrLn "-- selectors:"
print $ (.foo) a -- Bar {bar = Baz {baz = Quux {quux = 42}}}
print $ (.foo.bar) a -- Baz {baz = Quux {quux = 42}}
......@@ -77,38 +78,38 @@ main = do
-- print $ f a .foo -- f r .x is illegal
print $ (const "hello") (id a).foo -- f (g r).x means f ((g r).x)
-- print $ f (g a) .foo -- f (g r) .x is illegal
print $ (a.foo.bar.baz) {quux = 2} -- Quux {quux = 2}
print $ a.foo
& (.bar.baz.quux) -- 42
add <- return (\x y -> x + y)
print $ add a.foo.bar.baz.quux 1 -- 43
print $ add (id a).foo.bar.baz.quux 1 -- 43
print $ add ((id a).foo.bar & (.baz.quux)) 1 -- 43
print $ (\b -> b{bar=Baz{baz=Quux{quux=1}}}) a.foo -- 1
-- An "update" is an expression like 'r{a.b = 12}'.
putStrLn "-- updates:"
print $ a{foo = Bar {bar = Baz {baz = Quux {quux = 44}}}} -- Top level update : Can NOT be a set_field expression!
print $ a{foo.bar = Baz {baz = Quux {quux = 44}}}
print $ a{foo.bar.baz = Quux {quux = 45}}
print $ a{foo.bar.baz.quux = 46}
print $ c{f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4}
print $ (a.foo.bar.baz) {quux = 2} -- Quux {quux = 2}
print $ (\b -> b{bar=Baz{baz=Quux{quux=1}}}) a.foo -- Bar {bar = Baz {baz = Quux {quux = 1}}}
let bar = Bar {bar = Baz {baz = Quux {quux = 44}}}
print $ a{foo.bar = Baz {baz = Quux {quux = 44}}} -- Foo {foo = Bar {bar = Baz {baz = Quux {quux = 44}}}}
print $ a{foo.bar.baz = Quux {quux = 45}} -- Foo {foo = Bar {bar = Baz {baz = Quux {quux = 45}}}}
print $ a{foo.bar.baz.quux = 46} -- Foo {foo = Bar {bar = Baz {baz = Quux {quux = 46}}}}
print $ c{f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4} -- Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 3}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 4}}}}}
-- A "punned update" is an expression like 'r{a.b}' (where it is
-- understood that 'b' is a variable binding in the environment of
-- the field update - enabled only when the extension
-- 'NamedFieldPuns' is in effect).
putStrLn "-- punned updates:"
let quux = 102; baz = Quux {quux}; bar = Baz {baz}; foo = Bar {bar}
print $ a{foo.bar.baz.quux}
print $ a{foo.bar.baz}
print $ a{foo.bar}
print $ a{foo} -- Top level update : Cannot be a set_field expression!
print $ a
print $ c{f.foo, g.foo.bar.baz.quux = 4} -- Mix punned and explicit.
let quux = 102; baz = Quux {quux}; bar = Baz {baz}; foo = Bar {bar} -- Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}
print $ a{foo.bar.baz.quux} -- Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}
print $ a{foo.bar.baz} -- Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}
print $ a{foo.bar} -- Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}
print $ a{foo} -- Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}
print $ a -- Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}
print $ c{f.foo, g.foo.bar.baz.quux = 4} -- Mix punned and explicit; 102, 4
f <- return a
g <- return a
print $ c{f} -- Ok
print $ c{f, g} -- Ok
-- print $ c{f, g.foo.bar.baz.quux = 4} -- illegal : Can't mix top-level and nested updates.
print $ c{f}{g.foo.bar.baz.quux = 4} -- Workaround
print $ c{f} -- 42, 1
print $ c{f, g} -- 42, 42
-- print $ c{f, g.foo.bar.baz.quux = 4} -- Can't mix top-level and nested updates (at least, not with this prototype).
print $ c{f}{g.foo.bar.baz.quux = 4} -- Workaround; 42, 4
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment