diff options
Diffstat (limited to 'testsuite/tests')
41 files changed, 785 insertions, 0 deletions
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 27be970d22..cbcbefc573 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -41,6 +41,8 @@ expectedGhcOnlyExtensions = , "AlternativeLayoutRule" , "AlternativeLayoutRuleTransitional" , "FieldSelectors" + , "OverloadedRecordDot" + , "OverloadedRecordUpdate" ] expectedCabalOnlyExtensions :: [String] diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxA.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxA.hs new file mode 100644 index 0000000000..22b5aed888 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxA.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE RecordWildCards, OverloadedRecordDot, OverloadedRecordUpdate #-} + +module RecordDotSyntaxA where + +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. + +data Foo = Foo {foo :: Int} +instance HasField "foo" Foo Int where + hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r) diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs new file mode 100644 index 0000000000..f7692ec778 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +no = Foo { bar.baz = 1 } + -- Syntax error: Can't use '.' in construction. diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr new file mode 100644 index 0000000000..6e4a3fbae6 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail0.stderr @@ -0,0 +1,2 @@ + RecordDotSyntaxFail0.hs:3:12: + Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns) diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs new file mode 100644 index 0000000000..78b4f1072c --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +no Foo { bar.baz = x } = undefined + -- Syntax error: Field selector syntax doesn't participate + -- in patterns diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr new file mode 100644 index 0000000000..f1ab2b9f95 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail1.stderr @@ -0,0 +1,2 @@ +RecordDotSyntaxFail1.hs:3:10: + Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns) diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.hs new file mode 100644 index 0000000000..cc76b469d5 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +{-# LANGUAGE RebindableSyntax #-} +import Prelude + +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. + +-- 'Foo' has 'foo' field of type 'Bar' +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) + +-- '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 -> 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 -> 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 -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r) + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + let quux = "Expecto patronum!" + print $ a{foo.bar.baz.quux} -- Type error. Does a{foo.bar.baz.quux} get underlined? diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr new file mode 100644 index 0000000000..38d9616489 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr @@ -0,0 +1,13 @@ +RecordDotSyntaxFail10.hs:40:11: + Couldn't match type ‘Int’ with ‘[Char]’ + arising from a functional dependency between: + constraint ‘HasField "quux" Quux String’ + arising from a use of ‘setField’ + instance ‘HasField "quux" Quux Int’ + at RecordDotSyntaxFail10.hs:34:10-33 + In the second argument of ‘($)’, namely ‘a {foo.bar.baz.quux}’ + In a stmt of a 'do' block: print $ a {foo.bar.baz.quux} + In the expression: + do let a = ... + let quux = "Expecto patronum!" + print $ a {foo.bar.baz.quux} diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.hs new file mode 100644 index 0000000000..62f9bd8f23 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Foo = Foo { foo :: Bar } +data Bar = Bar { bar :: Int } + +main = do + let a = Foo { foo = Bar { bar = 1 }} + print $ (.foo.bar.baz) a -- Oops, what is baz? diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr new file mode 100644 index 0000000000..4ca1005185 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr @@ -0,0 +1,25 @@ +RecordDotSyntaxFail11.hs:8:3: + Ambiguous type variable ‘a0’ arising from a use of ‘print’ + prevents the constraint ‘(Show a0)’ from being solved. + Probable fix: use a type annotation to specify what ‘a0’ should be. + These potential instances exist: + instance Show Ordering -- Defined in ‘GHC.Show’ + instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ + instance Show Integer -- Defined in ‘GHC.Show’ + ...plus 23 others + ...plus N instances involving out-of-scope types + (use -fprint-potential-instances to see them all) + In the first argument of ‘($)’, namely ‘print’ + In a stmt of a 'do' block: print $ (foo.bar.baz) a + In the expression: + do let a = ... + print $ (foo.bar.baz) a + +RecordDotSyntaxFail11.hs:8:11: + No instance for (GHC.Records.HasField "baz" Int a0) + arising from a use of ‘GHC.Records.getField’ + In the second argument of ‘($)’, namely ‘(foo.bar.baz) a’ + In a stmt of a 'do' block: print $ (foo.bar.baz) a + In the expression: + do let a = ... + print $ (foo.bar.baz) a diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.hs new file mode 100644 index 0000000000..ba7f7effed --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +-- For "higher kinded data" test. +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# LANGUAGE RebindableSyntax #-} +import Prelude + +-- Choice (C2a). + +import Data.Function -- for & +import Data.Functor.Identity + +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. + +-- 'Foo' has 'foo' field of type 'Bar' +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) + +-- '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 -> 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 -> 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 -> 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 -> 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) +instance HasField "g" Grault Foo where + hasField r = (\x -> case r of Grault { .. } -> Grault { g = x, .. }, g r) + +-- "Higher kinded data" +-- (see https://reasonablypolymorphic.com/blog/higher-kinded-data/) +type family H f a where + H Identity a = a + H f a = f a +data P f = P + { n :: H f String + } +-- See https://github.com/ndmitchell/record-dot-preprocessor/pull/34. +instance (a ~ H f String) => HasField "n" (P f) a where + hasField r = (\x -> case r of P { .. } -> P { n = x, .. }, n r) + +main = do + 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 } } } } + } + + -- 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.bar.baz.quux) a -- 42 + print $ ((&&&) b) -- 12 + -- print $ (b.(&&&)) -- illegal : parse error on input ‘(’ + print $ getField @"&&&" b -- 12 + + -- 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 $ (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) + -- print $ f (g a) .foo -- f (g r) .x is illegal + print $ a.foo + & (.bar.baz.quux) -- 42 + print $ (a.foo + ).bar.baz.quux -- 42 + print $ (+) a.foo.bar.baz.quux 1 -- 43 + 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 }'. + 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 + -- 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 + 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 + + putStrLn "-- misc:" + -- Higher kinded test. + let p = P { n = Just "me" } :: P Maybe + Just me <- pure p.n + putStrLn $ me diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr new file mode 100644 index 0000000000..6ef0a51754 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail12.stderr @@ -0,0 +1,36 @@ + +RecordDotSyntaxFail12.hs:123:25: + Illegal use of punning for field ‘quux’ + Use NamedFieldPuns to permit this + +RecordDotSyntaxFail12.hs:123:46: + Illegal use of punning for field ‘baz’ + Use NamedFieldPuns to permit this + +RecordDotSyntaxFail12.hs:123:65: + Illegal use of punning for field ‘bar’ + Use NamedFieldPuns to permit this + +RecordDotSyntaxFail12.hs:124:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:125:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:126:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:127:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:129:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:132:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:133:11: + For this to work enable NamedFieldPuns. + +RecordDotSyntaxFail12.hs:134:11: + For this to work enable NamedFieldPuns. diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.hs new file mode 100644 index 0000000000..7050145b9d --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RebindableSyntax #-} +import Prelude + +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. + +-- 'Foo' has 'foo' field of type 'Int' +data Foo = Foo { foo :: Int } deriving (Show, Eq) +instance HasField "foo" Foo Int where + hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r) +main = do + let a = Foo {foo = 12}; + -- let foo = 13; + print $ a {foo} diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr new file mode 100644 index 0000000000..8b5369731f --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr @@ -0,0 +1,15 @@ + +RecordDotSyntaxFail13.hs:26:11: + Couldn't match type ‘Int’ with ‘Foo -> Int’ + arising from a functional dependency between: + constraint ‘HasField "foo" Foo (Foo -> Int)’ + << This should not appear in error messages. If you see this + in an error message, please report a bug mentioning ‘record update’ at + https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >> + instance ‘HasField "foo" Foo Int’ + at RecordDotSyntaxFail13.hs:21:10-31 + In the second argument of ‘($)’, namely ‘a {foo}’ + In a stmt of a 'do' block: print $ a {foo} + In the expression: + do let a = ... + print $ a {foo} diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs new file mode 100644 index 0000000000..39a3e0256b --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedRecordDot #-} -- Enable '.' +{-# LANGUAGE NoOverloadedRecordUpdate #-} -- Definitely not enable overloaded updates. + +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 = foo { bar.baz = Quux { quux = 42 } } } } +-- For this to work, OverloadedRecordUpdate must be enabled diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr new file mode 100644 index 0000000000..5430e37bc9 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail2.stderr @@ -0,0 +1,2 @@ +RecordDotSyntaxFail2.hs:10:10: + OverloadedRecordUpdate needs to be enabled diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs new file mode 100644 index 0000000000..ae1a1fa797 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot #-} + +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 diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr new file mode 100644 index 0000000000..674b0c1e50 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail3.stderr @@ -0,0 +1 @@ +RecordDotSyntaxFail3.hs:22:14: parse error on input ‘(’ diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs new file mode 100644 index 0000000000..b921cbc4b2 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Foo = Foo { foo :: Int } + +main = do + let a = Foo { foo = 1 } + print $ (const "hello") a .foo + -- Syntax error: f r .x is illegal. diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr new file mode 100644 index 0000000000..4ffc9df51e --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail4.stderr @@ -0,0 +1,2 @@ +RecordDotSyntaxFail4.hs:7:29: error: + parse error on input ‘.’ diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.hs new file mode 100644 index 0000000000..c261a571b7 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +{-# LANGUAGE NoRebindableSyntax #-} + +data Foo = Foo { foo :: Bar } deriving (Show, Eq) +data Bar = Bar { bar :: Baz } deriving (Show, Eq) +data Baz = Baz { baz :: Quux } deriving (Show, Eq) +data Quux = Quux { quux :: Int } deriving (Show, Eq) + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + + -- An "update" is an expression like 'r{ a.b = 12 }'. + -- + -- We don't support these (in the case Rebindable Syntax is off) yet + -- (waiting on HasField support). + putStrLn "-- updates:" + print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 } diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.stderr new file mode 100644 index 0000000000..efe360222c --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail5.stderr @@ -0,0 +1,2 @@ +RecordDotSyntaxFail5.hs:17:11: + RebindableSyntax is required if OverloadedRecordUpdate is enabled. diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.hs new file mode 100644 index 0000000000..8265f56914 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate, RebindableSyntax #-} + +module Main where + +import qualified RecordDotSyntaxA as A + +main = do + let bar = A.Foo { A.foo =1 } -- A defn. Perfectly reasonable. + print $ A.foo bar -- Application of a selector. Also reasonable. + let baz = bar{A.foo = 2} -- An update with a qualified field; not supported! + print $ A.foo baz diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr new file mode 100644 index 0000000000..c53990475b --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr @@ -0,0 +1,5 @@ +[1 of 2] Compiling RecordDotSyntaxA ( RecordDotSyntaxA.hs, RecordDotSyntaxA.o ) + [2 of 2] Compiling Main ( RecordDotSyntaxFail6.hs, RecordDotSyntaxFail6.o ) + + RecordDotSyntaxFail6.hs:10:17: + Fields cannot be qualified when OverloadedRecordUpdate is enabled diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.hs new file mode 100644 index 0000000000..0d3d92b431 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Main where + +import qualified RecordDotSyntaxA as A + +main = do + let bar = A.Foo { A.foo =1 } -- A defn. Perfectly reasonable. + print $ (bar.A.foo) -- A field selection where the field is qualified; parse error on input ‘A.foo’. diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr new file mode 100644 index 0000000000..feee41589f --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr @@ -0,0 +1,4 @@ +[1 of 2] Compiling RecordDotSyntaxA ( RecordDotSyntaxA.hs, RecordDotSyntaxA.o ) +[2 of 2] Compiling Main ( RecordDotSyntaxFail7.hs, RecordDotSyntaxFail7.o ) + +RecordDotSyntaxFail7.hs:9:16: parse error on input ‘A.foo’ diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs new file mode 100644 index 0000000000..3b6fcc97e2 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate, RebindableSyntax#-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} + +import Prelude + +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. + +-- 'Foo' has 'foo' field of type 'Bar' +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) + +-- '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 -> 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 -> 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) +-- Forget to write this type's 'HasField' instance + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + print $ a.foo.bar.baz.quux diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr new file mode 100644 index 0000000000..8bf921b79f --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr @@ -0,0 +1,25 @@ +RecordDotSyntaxFail8.hs:37:3: + Ambiguous type variable ‘a0’ arising from a use of ‘print’ + prevents the constraint ‘(Show a0)’ from being solved. + Probable fix: use a type annotation to specify what ‘a0’ should be. + These potential instances exist: + instance Show Ordering -- Defined in ‘GHC.Show’ + instance Show Bar -- Defined at RecordDotSyntaxFail8.hs:22:41 + instance Show Baz -- Defined at RecordDotSyntaxFail8.hs:27:42 + ...plus 27 others + ...plus N instances involving out-of-scope types + (use -fprint-potential-instances to see them all) + In the first argument of ‘($)’, namely ‘print’ + In a stmt of a 'do' block: print $ ....baz.quux + In the expression: + do let a = ... + print $ ....quux + +RecordDotSyntaxFail8.hs:37:11: + No instance for (HasField "quux" Quux a0) + arising from selecting the field ‘quux’ + In the second argument of ‘($)’, namely ‘....baz.quux’ + In a stmt of a 'do' block: print $ ....baz.quux + In the expression: + do let a = ... + print $ ....quux diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.hs b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.hs new file mode 100644 index 0000000000..b262215215 --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +data Foo = Foo { foo :: Int } deriving Show + +main = do + let a = Foo { foo = 42 } + let _ = a.foo :: String -- Type error. Does a.foo get underlined? + undefined diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr new file mode 100644 index 0000000000..ee15f9fc6b --- /dev/null +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr @@ -0,0 +1,9 @@ +RecordDotSyntaxFail9.hs:7:11: + Couldn't match type ‘Int’ with ‘[Char]’ + arising from selecting the field ‘foo’ + In the expression: a.foo :: String + In a pattern binding: _ = a.foo :: String + In the expression: + do let a = ... + let _ = ... + undefined diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T index 88a37ec2ba..21d66337e9 100644 --- a/testsuite/tests/parser/should_fail/all.T +++ b/testsuite/tests/parser/should_fail/all.T @@ -175,3 +175,17 @@ test('T18251e', normal, compile_fail, ['']) test('T18251f', normal, compile_fail, ['']) test('T12446', normal, compile_fail, ['']) test('T17045', 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, ['']) +test('RecordDotSyntaxFail5', normal, compile_fail, ['']) +test('RecordDotSyntaxFail6', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_fail, ['RecordDotSyntaxFail6', '']) +test('RecordDotSyntaxFail7', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_fail, ['RecordDotSyntaxFail7', '']) +test('RecordDotSyntaxFail8', normal, compile_fail, ['']) +test('RecordDotSyntaxFail9', normal, compile_fail, ['']) +test('RecordDotSyntaxFail10', normal, compile_fail, ['']) +test('RecordDotSyntaxFail11', normal, compile_fail, ['']) +test('RecordDotSyntaxFail12', normal, compile_fail, ['']) +test('RecordDotSyntaxFail13', normal, compile_fail, ['']) diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax1.hs b/testsuite/tests/parser/should_run/RecordDotSyntax1.hs new file mode 100644 index 0000000000..2d14218f83 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax1.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +-- For "higher kinded data" test. +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# LANGUAGE RebindableSyntax #-} +import Prelude + +-- Choice (C2a). + +import Data.Function -- for & +import Data.Functor.Identity + +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. + +-- 'Foo' has 'foo' field of type 'Bar' +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) + +-- '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 -> 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 -> 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 -> 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 -> 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) +instance HasField "g" Grault Foo where + hasField r = (\x -> case r of Grault { .. } -> Grault { g = x, .. }, g r) + +-- "Higher kinded data" +-- (see https://reasonablypolymorphic.com/blog/higher-kinded-data/) +type family H f a where + H Identity a = a + H f a = f a +data P f = P + { n :: H f String + } +-- See https://github.com/ndmitchell/record-dot-preprocessor/pull/34. +instance (a ~ H f String) => HasField "n" (P f) a where + hasField r = (\x -> case r of P { .. } -> P { n = x, .. }, n r) + +main = do + 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 } } } } + } + + -- 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.bar.baz.quux) a -- 42 + print $ ((&&&) b) -- 12 + -- print $ (b.(&&&)) -- illegal : parse error on input ‘(’ + print $ getField @"&&&" b -- 12 + + -- 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 $ (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) + -- print $ f (g a) .foo -- f (g r) .x is illegal + print $ a.foo + & (.bar.baz.quux) -- 42 + print $ (a.foo + ).bar.baz.quux -- 42 + print $ (+) a.foo.bar.baz.quux 1 -- 43 + 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 }'. + 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 + -- 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 + 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 + + putStrLn "-- misc:" + -- Higher kinded test. + let p = P { n = Just "me" } :: P Maybe + Just me <- pure p.n + putStrLn $ me diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax1.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax1.stdout new file mode 100644 index 0000000000..9582e17da9 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax1.stdout @@ -0,0 +1,38 @@ +-- selectors: +Bar {bar = Baz {baz = Quux {quux = 42}}} +Baz {baz = Quux {quux = 42}} +Quux {quux = 42} +42 +12 +12 +-- selections: +42 +Quux {quux = 42} +Baz {baz = Quux {quux = 42}} +Bar {bar = Baz {baz = Quux {quux = 42}}} +"hello" +"hello" +42 +42 +43 +43 +43 +-- updates: +Quux {quux = 2} +Bar {bar = Baz {baz = Quux {quux = 1}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 44}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 45}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 46}}}} +Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 3}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 4}}}}} +-- punned updates: +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}} +Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 102}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 4}}}}} +Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 1}}}}} +Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}} +Grault {f = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 42}}}}, g = Foo {foo = Bar {bar = Baz {baz = Quux {quux = 4}}}}} +-- misc: +me diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax2.hs b/testsuite/tests/parser/should_run/RecordDotSyntax2.hs new file mode 100644 index 0000000000..89c520009f --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax2.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoRebindableSyntax #-} + +data Foo = Foo { foo :: Bar } deriving (Show, Eq) +data Bar = Bar { bar :: Baz } deriving (Show, Eq) +data Baz = Baz { baz :: Quux } deriving (Show, Eq) +data Quux = Quux { quux :: Int } deriving (Show, Eq) + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + + -- 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.bar.baz.quux) a -- 42 + + -- 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 } } } + + -- An "update" is an expression like 'r{ a.b = 12 }'. + -- + -- We don't support these (in the case Rebindable Syntax is off) yet + -- (waiting on HasField support). + -- + -- Regular updates are fine though! + print $ a{foo=(foo a){bar = (bar (foo a)){baz = (baz (bar (foo a))){quux = quux (baz (bar (foo a))) + 1}}}} + print $ a{foo=(a.foo){bar = (a.foo.bar){baz = (a.foo.bar.baz){quux = a.foo.bar.baz.quux + 1}}}} diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax2.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax2.stdout new file mode 100644 index 0000000000..6755663e6a --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax2.stdout @@ -0,0 +1,12 @@ +-- selectors: +Bar {bar = Baz {baz = Quux {quux = 42}}} +Baz {baz = Quux {quux = 42}} +Quux {quux = 42} +42 +-- selections: +42 +Quux {quux = 42} +Baz {baz = Quux {quux = 42}} +Bar {bar = Baz {baz = Quux {quux = 42}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 43}}}} +Foo {foo = Bar {bar = Baz {baz = Quux {quux = 43}}}} diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax3.hs b/testsuite/tests/parser/should_run/RecordDotSyntax3.hs new file mode 100644 index 0000000000..1ee7565573 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax3.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Main where + +import qualified RecordDotSyntaxA as A + + +main = do + print $ id A.n -- Foo {foo = 2}; f M.x means f (M.x) + print $ id A.n.foo -- 2; f M.n.x means f (M.n.x) + + let bar = A.Foo {A.foo = 1} + print $ bar.foo -- Ok; 1 + -- print $ bar.A.foo -- parse error on input 'A.foo' diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax3.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax3.stdout new file mode 100644 index 0000000000..0de59d2464 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax3.stdout @@ -0,0 +1,3 @@ +Foo {foo = 2} +2 +1 diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax4.hs b/testsuite/tests/parser/should_run/RecordDotSyntax4.hs new file mode 100644 index 0000000000..924ed03bde --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax4.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Main where + +import qualified RecordDotSyntaxA as A + +main = do + let bar = A.Foo {A.foo = 1} + print $ bar{A.foo = 2} -- Qualified labels ok in regular updates. diff --git a/testsuite/tests/parser/should_run/RecordDotSyntax4.stdout b/testsuite/tests/parser/should_run/RecordDotSyntax4.stdout new file mode 100644 index 0000000000..43c812f394 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntax4.stdout @@ -0,0 +1 @@ +Foo {foo = 2} diff --git a/testsuite/tests/parser/should_run/RecordDotSyntaxA.hs b/testsuite/tests/parser/should_run/RecordDotSyntaxA.hs new file mode 100644 index 0000000000..907d6a23f6 --- /dev/null +++ b/testsuite/tests/parser/should_run/RecordDotSyntaxA.hs @@ -0,0 +1,6 @@ +module RecordDotSyntaxA where + +data Foo = Foo { foo :: Int } deriving Show + +n :: Foo +n = Foo {foo = 2} diff --git a/testsuite/tests/parser/should_run/all.T b/testsuite/tests/parser/should_run/all.T index 064ef8fffd..caf0e2bc65 100644 --- a/testsuite/tests/parser/should_run/all.T +++ b/testsuite/tests/parser/should_run/all.T @@ -23,3 +23,7 @@ test('CountParserDeps', compile_and_run, ['-package ghc']) test('LexNegLit', normal, compile_and_run, ['']) +test('RecordDotSyntax1', normal, compile_and_run, ['']) +test('RecordDotSyntax2', normal, compile_and_run, ['']) +test('RecordDotSyntax3', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_and_run, ['RecordDotSyntax3', '']) +test('RecordDotSyntax4', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compile_and_run, ['RecordDotSyntax4', '']) |