GitLab

The following program panics on GHC 8.10.1-alpha1:

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Bug where

import Data.Kind
import Language.Haskell.TH hiding (Type)

data TyFun :: Type -> Type -> Type
type a ~> b = TyFun a b -> Type
infixr 0 ~>
type family Apply (f :: a ~> b) (x :: a) :: b
type SameKind (a :: k) (b :: k) = (() :: Constraint)

$(do let pc       = mkName "PC"
         m1       = mkName "M1"
         m2       = mkName "M2"
         m1Sym0   = mkName "M1Sym0"
         m2Sym0   = mkName "M2Sym0"
         m2Sym1   = mkName "M2Sym1"
         m1Sym0KI = mkName "M1Sym0KindInference"
         m2Sym0KI = mkName "M2Sym0KindInference"
         m2Sym1KI = mkName "M2Sym1KindInference"

     f      <- newName "f"
     a      <- newName "a"
     b      <- newName "b"
     c      <- newName "c"
     d      <- newName "d"
     -- d      <- pure $ mkName "d"
     e      <- newName "e"
     -- e      <- pure $ mkName "e"
     argx   <- newName "argx"
     argy   <- newName "argy"
     argz   <- newName "argz"
     extra1 <- newName "extra1"
     extra2 <- newName "extra2"

     let m1Sym0_sak = ForallT [PlainTV a, PlainTV f] [] $
                      ConT ''(~>) `AppT` VarT a `AppT` (VarT f `AppT` VarT a)
         mk_m2Sym_sak t
                    = ForallT [PlainTV f, PlainTV a, PlainTV b] [] $
                      t `AppT` (VarT f `AppT` VarT a) `AppT`
                        (ConT ''(~>) `AppT` (VarT f `AppT` VarT b)
                                     `AppT` (VarT f `AppT` VarT a))

         m2Sym0_sak = mk_m2Sym_sak (ConT ''(~>))
         m2Sym1_sak = mk_m2Sym_sak ArrowT

         m1Sym0_sak_dec = KiSigD m1Sym0 m1Sym0_sak
         m2Sym0_sak_dec = KiSigD m2Sym0 m2Sym0_sak
         m2Sym1_sak_dec = KiSigD m2Sym1 m2Sym1_sak

         mk_same_kind t1 t2 = ConT ''SameKind `AppT` t1
                                              `AppT` t2

         apply rator rand = ConT ''Apply `AppT` rator `AppT` rand

         m1Sym0_body_dec = DataD [] m1Sym0 [PlainTV c] Nothing
                            [ ForallC [PlainTV c, PlainTV extra1]
                                      [ mk_same_kind (apply (ConT m1Sym0) (VarT extra1))
                                                     (ConT m1 `AppT` VarT extra1)
                                      ]
                                      (GadtC [m1Sym0KI] [] (ConT m1Sym0 `AppT` VarT c))
                            ] []
         m2Sym0_body_dec = DataD [] m2Sym0 [PlainTV d] Nothing
                            [ ForallC [PlainTV d, PlainTV extra2]
                                      [ mk_same_kind (apply (ConT m2Sym0) (VarT extra2))
                                                     (ConT m2Sym1 `AppT` VarT extra2)
                                      ]
                                      (GadtC [m2Sym0KI] [] (ConT m2Sym0 `AppT` VarT d))
                            ] []
         m2Sym1_body_dec = DataD [] m2Sym1 [PlainTV d, PlainTV e] Nothing
                            [ ForallC [PlainTV d, PlainTV e, PlainTV extra2]
                                      [ mk_same_kind (apply (ConT m2Sym1 `AppT` VarT d)
                                                            (VarT extra2))
                                                     (ConT m2 `AppT` VarT d
                                                              `AppT` VarT extra2)
                                      ]
                                      (GadtC [m2Sym1KI] [] (ConT m2Sym1 `AppT` VarT d
                                                                        `AppT` VarT e))
                            ] []

         pc_dec = ClassD [] pc [PlainTV f] []
                    [ OpenTypeFamilyD $
                        TypeFamilyHead m1 [ KindedTV argx (VarT a)
                                          ]
                                       (KindSig (VarT f `AppT` VarT a)) Nothing
                    , OpenTypeFamilyD $
                        TypeFamilyHead m2 [ KindedTV argy (VarT f `AppT` VarT a)
                                          , KindedTV argz (VarT f `AppT` VarT b)
                                          ]
                                       (KindSig (VarT f `AppT` VarT a)) Nothing
                    ]
     pure [ m1Sym0_sak_dec
          , m1Sym0_body_dec
          , m2Sym0_sak_dec
          , m2Sym0_body_dec
          , m2Sym1_sak_dec
          , m2Sym1_body_dec
          , pc_dec
          ])

$ /opt/ghc/8.10.1/bin/ghc Bug.hs
[1 of 1] Compiling Bug              ( Bug.hs, Bug.o, Bug.dyn_o )
ghc: panic! (the 'impossible' happened)
  (GHC version 8.10.0.20191122:
        updateRole
  M2Sym1
  a_a32O
  [a31l :-> 1, a31m :-> 2, a31n :-> 3, a31p :-> 4, a31q :-> 5,
   a32k :-> 0]
  Call stack:
      CallStack (from HasCallStack):
        callStackDoc, called at compiler/utils/Outputable.hs:1179:37 in ghc:Outputable
        pprPanic, called at compiler/typecheck/TcTyDecls.hs:664:23 in ghc:TcTyDecls

Notes:

• The use of m2Sym1_sak_dec (i.e., type M2Sym1 :: forall f_a35o a_a35p b_a35q. f_a35o a_a35p -> (~>) (f_a35o b_a35q) (f_a35o a_a35p)) is essential to triggering the panic, as removing it will make the panic go away.
• If you create d and e with pure . mkName instead of newName, then the panic will also go away. This suggests that reusing NameUs is to blame.

There is a chance that this is related to #11812, but since this requires StandaloneKindSignatures, I figured I would file a new issue just to be safe.