diff options
| author | Adam Sandberg Eriksson <adam@sandbergericsson.se> | 2019-10-31 07:28:21 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-11-01 15:49:16 -0400 |
| commit | c9236384e5aaa50e188f2b8549d61c0a20d1af86 (patch) | |
| tree | bf3aa196cd8cac2b6534ee67f02b1fbc374482b7 | |
| parent | dab12c8780fe1e6e3c2adb1c9565e2a43aa207db (diff) | |
| download | haskell-c9236384e5aaa50e188f2b8549d61c0a20d1af86.tar.gz | |
template-haskell: require at least 1 GADT constructor name (#17379)
| -rw-r--r-- | compiler/GHC/ThToHs.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/th/T17379a.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/th/T17379a.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/th/T17379b.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/th/T17379b.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 2 |
6 files changed, 32 insertions, 0 deletions
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 29f7b1e139..7df5aee397 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -600,6 +600,9 @@ cvtConstr (ForallC tvs ctxt con) add_forall _ _ (XConDecl nec) = noExtCon nec +cvtConstr (GadtC [] _strtys _ty) + = failWith (text "GadtC must have at least one constructor name") + cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys @@ -607,6 +610,9 @@ cvtConstr (GadtC c strtys ty) ; c_ty <- mk_arr_apps args ty' ; returnL $ fst $ mkGadtDecl c' c_ty} +cvtConstr (RecGadtC [] _varstrtys _ty) + = failWith (text "RecGadtC must have at least one constructor name") + cvtConstr (RecGadtC c varstrtys ty) = do { c' <- mapM cNameL c ; ty' <- cvtType ty diff --git a/testsuite/tests/th/T17379a.hs b/testsuite/tests/th/T17379a.hs new file mode 100644 index 0000000000..66702bb9b8 --- /dev/null +++ b/testsuite/tests/th/T17379a.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTSyntax #-} + +module T17379a where + +import Language.Haskell.TH + +$(let typ = mkName "T" in pure [ DataD [] typ [] Nothing [GadtC [] [] (ConT typ)] [] ]) diff --git a/testsuite/tests/th/T17379a.stderr b/testsuite/tests/th/T17379a.stderr new file mode 100644 index 0000000000..ec98c5fb54 --- /dev/null +++ b/testsuite/tests/th/T17379a.stderr @@ -0,0 +1,4 @@ + +T17379a.hs:8:3: + GadtC must have at least one constructor name + When splicing a TH declaration: data T where :: T diff --git a/testsuite/tests/th/T17379b.hs b/testsuite/tests/th/T17379b.hs new file mode 100644 index 0000000000..c83d180d18 --- /dev/null +++ b/testsuite/tests/th/T17379b.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTSyntax #-} + +module T17379b where + +import Language.Haskell.TH + +$(let typ = mkName "T" in pure [ DataD [] typ [] Nothing [RecGadtC [] [] (ConT typ)] [] ]) diff --git a/testsuite/tests/th/T17379b.stderr b/testsuite/tests/th/T17379b.stderr new file mode 100644 index 0000000000..47410ecdd0 --- /dev/null +++ b/testsuite/tests/th/T17379b.stderr @@ -0,0 +1,4 @@ + +T17379b.hs:8:3: + RecGadtC must have at least one constructor name + When splicing a TH declaration: data T where :: {} -> T diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 986be55ba1..2a54cc9956 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -487,3 +487,5 @@ test('T16980', normal, compile, ['']) test('T16980a', normal, compile_fail, ['']) test('T17296', normal, compile, ['-v0']) test('T17394', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) +test('T17379a', normal, compile_fail, ['']) +test('T17379b', normal, compile_fail, ['']) |