[Git][ghc/ghc][wip/T18599] improve error reporting
Shayne Fletcher
gitlab at gitlab.haskell.org
Sun Sep 20 15:50:34 UTC 2020
Shayne Fletcher pushed to branch wip/T18599 at Glasgow Haskell Compiler / GHC
Commits:
f134aaa3 by Shayne Fletcher at 2020-09-20T11:50:20-04:00
improve error reporting
- - - - -
12 changed files:
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs
- + testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr
- testsuite/tests/parser/should_fail/all.T
- testsuite/tests/parser/should_run/RecordDotSyntax.hs
Changes:
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -138,6 +138,7 @@ import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Parser.Annotation
+import Data.Either
import Data.List
import Data.Foldable
import GHC.Driver.Session ( WarningFlag(..), DynFlags )
@@ -153,11 +154,14 @@ import Data.Kind ( Type )
#include "HsVersions.h"
data Fbind b =
- Fbind (LHsRecField GhcPs (Located b)) | Pbind (Located b -> Located b)
+ Fbind (LHsRecField GhcPs (Located b)) | Pbind (Located (Located b -> Located b))
-fbindToRecField :: Fbind b -> LHsRecField GhcPs (Located b)
-fbindToRecField (Fbind f) = f
-fbindToRecField _ = panic "fbindToRecField: The impossible happened"
+fbindsToEithers :: [Fbind b] -> [Either (LHsRecField GhcPs (Located b)) (Located (Located b -> Located b))]
+fbindsToEithers = fmap fbindToEither
+ where
+ fbindToEither :: Fbind b -> Either (LHsRecField GhcPs (Located b)) (Located (Located b -> Located b))
+ fbindToEither (Fbind x) = Left x
+ fbindToEither (Pbind x) = Right x
{- **********************************************************************
@@ -1393,7 +1397,7 @@ class b ~ (Body b) GhcPs => DisambECP b where
-- | Return an expression without ambiguity, or fail in a non-expression context.
ecpFromExp' :: LHsExpr GhcPs -> PV (Located b)
-- | This can only be satified by expressions.
- mkHsFieldUpdaterPV :: SrcSpan -> [Located FastString] -> Located b -> PV (Located b -> Located b)
+ mkHsFieldUpdaterPV :: SrcSpan -> [Located FastString] -> Located b -> PV (Located (Located b -> Located b))
-- | Disambiguate "\... -> ..." (lambda)
mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)
-- | Disambiguate "let ... in ..."
@@ -1521,9 +1525,7 @@ instance DisambECP (HsCmd GhcPs) where
type Body (HsCmd GhcPs) = HsCmd
ecpFromCmd' = return
ecpFromExp' (L l e) = cmdFail l (ppr e)
- mkHsFieldUpdaterPV l _ _ =
- cmdFail l $
- text "Field selector syntax is not supported in commands."
+ mkHsFieldUpdaterPV l _ _ = cmdFail l (text "Use of RecordDotSyntax `.' not valid.")
mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg)
mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e)
type InfixOp (HsCmd GhcPs) = HsExpr GhcPs
@@ -1557,8 +1559,12 @@ 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 $
- ppr a <+> ppr (mk_rec_fields fbinds ddLoc)
+ mkHsRecordPV _ l _ a (fbinds, ddLoc) = do
+ let (fs, ps) = partitionEithers $ fbindsToEithers fbinds
+ if not (null ps)
+ then addFatalError (getLoc (head ps))
+ (text "Use of RecordDotSyntax `.' not valid.")
+ else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc)
mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a)
mkHsSectionR_PV l op c = cmdFail l $
let pp_op = fromMaybe (panic "cannot print infix operator")
@@ -1587,7 +1593,7 @@ instance DisambECP (HsExpr GhcPs) where
nest 2 (ppr c) ]
return (L l hsHoleExpr)
ecpFromExp' = return
- mkHsFieldUpdaterPV _ fields arg = return $ mkFieldUpdater fields arg
+ mkHsFieldUpdaterPV l fields arg = return $ mkFieldUpdater l fields arg
mkHsLamPV l mg = return $ L l (HsLam noExtField mg)
mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c)
type InfixOp (HsExpr GhcPs) = HsExpr GhcPs
@@ -1677,7 +1683,7 @@ instance DisambECP (PatBuilder GhcPs) where
text "Expression syntax in pattern:" <+> ppr e
mkHsFieldUpdaterPV l _ _ =
addFatalError l $
- text "Field selector syntax is not supported in patterns."
+ text "Use of RecordDotSyntax `.' not valid."
mkHsLamPV l _ = addFatalError l $
text "Lambda-syntax in pattern." $$
text "Pattern matching on functions is not possible."
@@ -1709,8 +1715,13 @@ instance DisambECP (PatBuilder GhcPs) where
return (L l (PatBuilderPat (ListPat noExtField ps)))
mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))
mkHsRecordPV _ l _ a (fbinds, ddLoc) = do
- r <- mkPatRec a (mk_rec_fields fbinds ddLoc)
- checkRecordSyntax (L l r)
+ let (fs, ps) = partitionEithers $ fbindsToEithers fbinds
+ if not (null ps)
+ then addFatalError (getLoc (head ps))
+ (text " Use of RecordDotSyntax `.' not valid.")
+ else do
+ r <- mkPatRec a (mk_rec_fields fs ddLoc)
+ checkRecordSyntax (L l r)
mkHsNegAppPV l (L lp p) = do
lit <- case p of
PatBuilderOverLit pos_lit -> return (L lp pos_lit)
@@ -2352,20 +2363,31 @@ mkRecConstrOrUpdate
-> SrcSpan
-> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)
-> PV (HsExpr GhcPs)
-mkRecConstrOrUpdate _ (L l (HsVar _ (L _ c))) _ (fs,dd)
+mkRecConstrOrUpdate _ (L l (HsVar _ (L _ c))) _ (fbinds,dd)
| isRdrDataCon c
- = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
+ = do
+ let (fs, ps) = partitionEithers $ fbindsToEithers fbinds
+ if not (null ps)
+ then addFatalError (getLoc (head ps))
+ (text "Use of RecordDotSyntax `.' not valid.")
+ else return (mkRdrRecordCon (L l c) (mk_rec_fields 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' dot exp fs)
+ | otherwise = mkRdrRecordUpd' dot exp fs
-mkRdrRecordUpd' :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> HsExpr GhcPs
-mkRdrRecordUpd' dot exp fbinds =
+mkRdrRecordUpd' :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> PV (HsExpr GhcPs)
+mkRdrRecordUpd' dot exp@(L lexp _) fbinds =
if not dot
- then
- mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) $ map fbindToRecField fbinds)
- else
- foldl' fieldUpdate (unLoc exp) fbinds
+ then do
+ let (fs, ps) = partitionEithers $ fbindsToEithers fbinds
+ if not (null ps)
+ -- If RecordDotSyntax is not enabled (as indicated by the
+ -- value of 'dot'), then the lexer will never an ITproj token
+ -- and so this case is refuted.
+ panic "mkRdrRecordUpd': The impossible happened!"
+ else return $ mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)
+ else
+ return $ foldl' fieldUpdate (unLoc exp) fbinds
where
fieldUpdate :: HsExpr GhcPs -> Fbind (HsExpr GhcPs) -> HsExpr GhcPs
fieldUpdate acc f =
@@ -2374,7 +2396,7 @@ mkRdrRecordUpd' dot exp fbinds =
Fbind field ->
let updField = fmap mk_rec_upd_field field
in unLoc $ foldl' mkSetField (noLoc acc) [updField]
- Pbind fieldUpdater -> unLoc (fieldUpdater (noLoc acc))
+ Pbind (L _ fieldUpdater) -> unLoc (fieldUpdater (noLoc acc))
mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd exp flds
@@ -2386,12 +2408,9 @@ mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon con flds
= RecordCon { rcon_ext = noExtField, rcon_con_name = con, rcon_flds = flds }
-
-
-mk_rec_fields :: [Fbind b] -> Maybe SrcSpan -> HsRecFields GhcPs (Located b)
-mk_rec_fields fs Nothing = HsRecFields { rec_flds = map fbindToRecField fs, rec_dotdot = Nothing }
-mk_rec_fields fs (Just s) = HsRecFields { rec_flds = map fbindToRecField fs
- , rec_dotdot = Just (L s (length fs)) }
+mk_rec_fields :: [LHsRecField GhcPs (Located b)] -> Maybe SrcSpan -> HsRecFields GhcPs (Located b)
+mk_rec_fields flds Nothing = HsRecFields { rec_flds = flds, rec_dotdot = Nothing }
+mk_rec_fields flds (Just s) = HsRecFields { rec_flds = flds, rec_dotdot = Just (L s (length flds)) }
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
@@ -2983,8 +3002,9 @@ mkSet :: LHsExpr GhcPs -> Located FastString -> LHsExpr GhcPs -> LHsExpr GhcPs
mkSet a (L _ fIELD) b = set_field `mkAppType` mkSelector fIELD `mkApp` a `mkApp` b
-- mkFieldUpdater calculates functions representing dot notation record updates.
-mkFieldUpdater :: [Located FastString] -> LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+mkFieldUpdater :: SrcSpan -> [Located FastString] -> LHsExpr GhcPs -> Located (LHsExpr GhcPs -> LHsExpr GhcPs)
mkFieldUpdater -- e.g {foo.bar.baz.quux = 43}
+ l
fIELDS -- [foo, bar, baz, quux]
arg -- This is 'texp' (43 in the example).
= let {
@@ -2995,7 +3015,7 @@ mkFieldUpdater -- e.g {foo.bar.baz.quux = 43}
; 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)
+ in L l $ \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 -> (Located FastString, LHsExpr GhcPs) -> LHsExpr GhcPs
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr
=====================================
@@ -1,5 +1,2 @@
-ghc: panic! (the 'impossible' happened)
- (GHC version 8.11.0.20200909:
- fbindToRecField: The impossible happened
-
-Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug
+ RecordDotSyntaxFail0.hs:3:12:
+ Use of RecordDotSyntax `.' not valid.
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE RecordDotSyntax #-}
no Foo { bar.baz = x } = undefined
- -- Syntax error: "Field selector syntax is not supported in
- -- patterns."
+ -- Syntax error: Field selector syntax doesn't participate
+ -- in patterns
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr
=====================================
@@ -1,2 +1,2 @@
RecordDotSyntaxFail1.hs:3:10:
- Field selector syntax is not supported in patterns.
+ Use of RecordDotSyntax `.' not valid.
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE NoRecordDotSyntax #-}
+
+data Foo = Foo { foo :: Bar }
+data Bar = Bar { bar :: Baz }
+data Baz = Baz { baz :: Quux }
+data Quux = Quux { quux :: Int }
+
+no :: Foo -> Foo
+no = Foo { bar.baz = Quux {quux = 42}}} }
+ -- Syntax error: RecordDotSyntax is not enabled
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr
=====================================
@@ -0,0 +1 @@
+RecordDotSyntaxFail2.hs:9:15: parse error on input ‘.’
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs
=====================================
@@ -0,0 +1,24 @@
+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordDotSyntax #-}
+
+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 -- Note: a.x = is getField @"x" a.
+
+setField :: forall x r a . HasField x r a => r -> a -> r
+setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.
+
+-- 'Corge' has a '&&&' field of type 'Int'
+data Corge = Corge { (&&&) :: Int } deriving (Show, Eq)
+instance HasField "&&&" Corge Int where
+ hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r)
+
+main = do
+ let b = Corge{ (&&&) = 12 };
+ print $ (b.(&&&))
+ -- Syntax error: Dot notation is not available for fields with
+ -- operator names
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr
=====================================
@@ -0,0 +1 @@
+RecordDotSyntaxFail3.hs:22:14: parse error on input ‘(’
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE RecordDotSyntax #-}
+
+data Foo = Foo { foo :: Int }
+
+main = do
+ let a = Foo { foo = 1 }
+ print $ (const "hello") a .foo
+ -- Syntax error: f r .x is illegal.
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr
=====================================
@@ -0,0 +1,2 @@
+RecordDotSyntaxFail4.hs:7:29: error:
+ parse error on input ‘.’
=====================================
testsuite/tests/parser/should_fail/all.T
=====================================
@@ -175,3 +175,6 @@ test('T18251e', normal, compile_fail, [''])
test('T18251f', normal, compile_fail, [''])
test('RecordDotSyntaxFail0', normal, compile_fail, [''])
test('RecordDotSyntaxFail1', normal, compile_fail, [''])
+test('RecordDotSyntaxFail2', normal, compile_fail, [''])
+test('RecordDotSyntaxFail3', normal, compile_fail, [''])
+test('RecordDotSyntaxFail4', normal, compile_fail, [''])
=====================================
testsuite/tests/parser/should_run/RecordDotSyntax.hs
=====================================
@@ -17,52 +17,52 @@ setField :: forall x r a . HasField x r a => r -> a -> r
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)
+data Foo = Foo { foo :: Bar } deriving (Show, Eq)
instance HasField "foo" Foo Bar where
- hasField r = (\x -> case r of Foo{..} -> Foo {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)
+data Bar = Bar { bar :: Baz } deriving (Show, Eq)
instance HasField "bar" Bar Baz where
- hasField r = (\x -> case r of Bar{..} -> Bar {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)
+data Baz = Baz { baz :: Quux } deriving (Show, Eq)
instance HasField "baz" Baz Quux where
- hasField r = (\x -> case r of Baz{..} -> Baz {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)
+data Quux = Quux { quux :: Int } deriving (Show, Eq)
instance HasField "quux" Quux Int where
- hasField r = (\x -> case r of Quux{..} -> Quux {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)
+data Corge = Corge { (&&&) :: Int } deriving (Show, Eq)
instance HasField "&&&" Corge Int where
- hasField r = (\x -> case r of Corge{..} -> Corge {(&&&) = 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 -> case r of Grault{..} -> Grault {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 -> case r of Grault{..} -> Grault {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}}}}
- let b = Corge{(&&&) = 12};
+ let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
+ let b = Corge{ (&&&) = 12 };
let c = Grault {
- f = Foo {foo = Bar{bar = Baz {baz = Quux {quux = 1}}}}
- , g = Foo {foo = Bar{bar = Baz {baz = Quux {quux = 1}}}}
- }
+ f = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
+ , g = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
+ }
-- 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}}
- print $ (.foo.bar.baz) a -- Quux {quux = 42}
+ print $ (.foo) a -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
+ print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } }
+ print $ (.foo.bar.baz) a -- Quux { quux = 42 }
print $ (.foo.bar.baz.quux) a -- 42
print $ ((&&&) b) -- 12
-- print $ (b.(&&&)) -- illegal : parse error on input ‘(’
@@ -71,9 +71,9 @@ main = do
-- A "selection" is an expression like 'r.a' or '(f r).a.b'.
putStrLn "-- selections:"
print $ a.foo.bar.baz.quux -- 42
- print $ a.foo.bar.baz -- Quux {quux = 42}
- print $ a.foo.bar -- Baz {baz = Quux {quux = 42}}
- print $ a.foo -- Bar {bar = Baz {baz = Quux {quux = 42}}}
+ print $ a.foo.bar.baz -- Quux { quux = 42 }
+ print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } }
+ print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
print $ (const "hello") a.foo -- f r.x means f (r.x)
-- print $ f a .foo -- f r .x is illegal
print $ (const "hello") (id a).foo -- f (g r).x means f ((g r).x)
@@ -86,30 +86,30 @@ main = do
print $ (+) (id a).foo.bar.baz.quux 1 -- 43
print $ (+) ((id a).foo.bar & (.baz.quux)) 1 -- 43
- -- An "update" is an expression like 'r{a.b = 12}'.
+ -- An "update" is an expression like 'r{ a.b = 12 }'.
putStrLn "-- updates:"
- 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
+ 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} -- 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
+ 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 <- pure a
g <- pure a
- print $ c{f} -- 42, 1
- print $ c{f, g} -- 42, 42
- print $ c{f, g.foo.bar.baz.quux = 4} -- Mix top-level and nested updates; 42, 4
+ print $ c{ f } -- 42, 1
+ print $ c{ f, g } -- 42, 42
+ print $ c{ f, g.foo.bar.baz.quux = 4 } -- Mix top-level and nested updates; 42, 4
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f134aaa3b4b856d8ee2df61a2262c2c7b4e0d3cd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f134aaa3b4b856d8ee2df61a2262c2c7b4e0d3cd
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200920/9b4b15e2/attachment-0001.html>
More information about the ghc-commits
mailing list