[Git][ghc/ghc][master] Fix two ASSERT buglets in reifyDataCon

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
30a63e79 by Ryan Scott at 2020-04-02T01:50:36-04:00
Fix two ASSERT buglets in reifyDataCon

Two `ASSERT`s in `reifyDataCon` were always using `arg_tys`, but
`arg_tys` is not meaningful for GADT constructors. In fact, it's
worse than non-meaningful, since using `arg_tys` when reifying a
GADT constructor can lead to failed `ASSERT`ions, as #17305
demonstrates.

This patch applies the simplest possible fix to the immediate
problem. The `ASSERT`s now use `r_arg_tys` instead of `arg_tys`, as
the former makes sure to give something meaningful for GADT
constructors. This makes the panic go away at the very least. There
is still an underlying issue with the way the internals of
`reifyDataCon` work, as described in
https://gitlab.haskell.org/ghc/ghc/issues/17305#note_227023, but we
leave that as future work, since fixing the underlying issue is
much trickier (see
https://gitlab.haskell.org/ghc/ghc/issues/17305#note_227087).

- - - - -


4 changed files:

- compiler/typecheck/TcSplice.hs
- + testsuite/tests/th/T17305.hs
- + testsuite/tests/th/T17305.stderr
- testsuite/tests/th/all.T


Changes:

=====================================
compiler/typecheck/TcSplice.hs
=====================================
@@ -1769,7 +1769,7 @@ reifyDataCon isGadtDataCon tys dc
                 -- constructors can be declared infix.
                 -- See Note [Infix GADT constructors] in TcTyClsDecls.
               | dataConIsInfix dc && not isGadtDataCon ->
-                  ASSERT( arg_tys `lengthIs` 2 ) do
+                  ASSERT( r_arg_tys `lengthIs` 2 ) do
                   { let [r_a1, r_a2] = r_arg_tys
                         [s1,   s2]   = dcdBangs
                   ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
@@ -1788,7 +1788,7 @@ reifyDataCon isGadtDataCon tys dc
                          { cxt <- reifyCxt theta'
                          ; ex_tvs'' <- reifyTyVars ex_tvs'
                          ; return (TH.ForallC ex_tvs'' cxt main_con) }
-       ; ASSERT( arg_tys `equalLength` dcdBangs )
+       ; ASSERT( r_arg_tys `equalLength` dcdBangs )
          ret_con }
 
 {-


=====================================
testsuite/tests/th/T17305.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+module T17305 where
+
+import Data.Kind
+import Language.Haskell.TH hiding (Type)
+import System.IO
+
+data family Foo a
+data instance Foo :: Type -> Type where
+  MkFoo :: Foo a
+
+$(do i <- reify ''Foo
+     runIO $ hPutStrLn stderr $ pprint i
+     pure [])


=====================================
testsuite/tests/th/T17305.stderr
=====================================
@@ -0,0 +1,3 @@
+data family T17305.Foo (a_0 :: *) :: *
+data instance T17305.Foo where
+    T17305.MkFoo :: forall (a_1 :: *) . T17305.Foo a_1


=====================================
testsuite/tests/th/all.T
=====================================
@@ -492,6 +492,7 @@ test('T16980a', normal, compile_fail, [''])
 test('T17270a', extra_files(['T17270.hs']), multimod_compile, ['T17270', '-v0'])
 test('T17270b', extra_files(['T17270.hs']), multimod_compile, ['T17270', '-fenable-th-splice-warnings -v0'])
 test('T17296', normal, compile, ['-v0'])
+test('T17305', normal, compile, ['-v0'])
 test('T17380', normal, compile_fail, [''])
 test('T17394', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T17379a', normal, compile_fail, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/30a63e79c65b023497af4fe2347149382c71829d

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/30a63e79c65b023497af4fe2347149382c71829d
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/20200402/ce007c50/attachment-0001.html>