diff options
Diffstat (limited to 'testsuite/tests')
3 files changed, 47 insertions, 0 deletions
diff --git a/testsuite/tests/overloadedrecflds/should_compile/T23220.hs b/testsuite/tests/overloadedrecflds/should_compile/T23220.hs new file mode 100644 index 0000000000..1b472daf77 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T23220.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +module T23220 where + +import Language.Haskell.TH + +import T23220_aux ( makeExtendingDatatype ) + +type Uri = String + +data TextDocumentIdentifier = + TextDocumentIdentifier + { _uri :: Uri + } + +type TextDocumentVersion = Maybe Int + +makeExtendingDatatype "VersionedTextDocumentIdentifier" [''TextDocumentIdentifier] + [ ("_version", [t| TextDocumentVersion |])] diff --git a/testsuite/tests/overloadedrecflds/should_compile/T23220_aux.hs b/testsuite/tests/overloadedrecflds/should_compile/T23220_aux.hs new file mode 100644 index 0000000000..ed55d7d261 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T23220_aux.hs @@ -0,0 +1,24 @@ +module T23220_aux ( makeExtendingDatatype ) where + +import Control.Monad ( forM ) +import Language.Haskell.TH + +-- | @makeExtendingDatatype name extends fields@ generates a record datatype +-- that contains all the fields of @extends@, plus the additional fields in +-- @fields@. +-- e.g. +-- data Foo = { a :: Int } +-- makeExtendingDatatype "bar" [''Foo] [("b", [t| String |])] +-- Will generate +-- data Bar = { a :: Int, b :: String } +makeExtendingDatatype :: String -> [Name] -> [(String, TypeQ)] -> DecsQ +makeExtendingDatatype datatypeNameStr extends fields = do + extendFields <- fmap concat $ forM extends $ \e -> do + TyConI (DataD _ _ _ _ [RecC _ eFields] _) <- reify e + return eFields + let datatypeName = mkName datatypeNameStr + constructor = recC datatypeName combinedFields + userFields = flip map fields $ \(s, typ) -> do + varBangType (mkName s) (bangType (bang noSourceUnpackedness noSourceStrictness) typ) + combinedFields = (map pure extendFields) <> userFields + (\a -> [a]) <$> dataD (cxt []) datatypeName [] Nothing [constructor] [] diff --git a/testsuite/tests/overloadedrecflds/should_compile/all.T b/testsuite/tests/overloadedrecflds/should_compile/all.T index 000fd696e4..485aa3f51c 100644 --- a/testsuite/tests/overloadedrecflds/should_compile/all.T +++ b/testsuite/tests/overloadedrecflds/should_compile/all.T @@ -47,3 +47,6 @@ test('BootFldReexport' # Should either pass or give an ambiguity error when compiling # the final module (BootFldReexport), but not fail earlier. , ['BootFldReexport', '-v0']) +test('T23220' + , [req_th, extra_files(['T23220_aux.hs'])] + , multimod_compile, ['T23220_aux.hs T23220.hs', '-v0']) |