Skip to content

HEAD-only Core Lint error with bifunctors-5.5.7 (Type of case alternatives not the same as the annotation on case)

Originally observed on a head.hackage build here.

The following code, reduced from the bifunctors-5.5.7 library, will produce a Core Lint error when compiled with HEAD + -O:

module Bug where

f :: p b d -> (a -> b) -> (c -> d) -> p a c -> p b d
f = const . const . const
{-# INLINE f #-}
$ ~/Software/ghc5/inplace/bin/ghc-stage2 -O -fforce-recomp -dcore-lint Bug.hs
[1 of 1] Compiling Bug              ( Bug.hs, Bug.o )
*** Core Lint errors : in result of Simplifier ***
Bug.hs:3:1: warning:
    The type of this binder doesn't match the type of its RHS: x_av5
    Binder's type: (c_agU -> d_agS)
                   -> p_agQ a_agT c_agU -> p_agQ b_agR d_agS
    Rhs type: (c_agU -> d_agS)
              -> (c_agU -> d_agS) -> p_agQ a_agT c_agU -> p_agQ b_agR d_agS
    In the RHS of f :: forall (p :: * -> * -> *) b d a c.
                       p b d -> (a -> b) -> (c -> d) -> p a c -> p b d
    In the unfolding of f :: forall (p :: * -> * -> *) b d a c.
                             p b d -> (a -> b) -> (c -> d) -> p a c -> p b d
    In the body of lambda with binder p_agQ :: * -> * -> *
    In the body of lambda with binder b_agR :: *
    In the body of lambda with binder d_agS :: *
    In the body of lambda with binder a_agT :: *
    In the body of lambda with binder c_agU :: *
    In the body of lambda with binder x_av2 :: p_agQ b_agR d_agS
    In the body of lambda with binder eta_B3 :: a_agT -> b_agR
    In the body of lambda with binder eta_B2 :: c_agU -> d_agS
    In the body of lambda with binder eta_B1 :: p_agQ a_agT c_agU
    In the body of letrec with binders x_X2 :: p_agQ a_agT c_agU
                                               -> p_agQ b_agR d_agS
    Substitution: [TCvSubst
                     In scope: InScope {p_agQ b_agR d_agS a_agT c_agU}
                     Type env: [agQ :-> p_agQ, agR :-> b_agR, agS :-> d_agS,
                                agT :-> a_agT, agU :-> c_agU]
                     Co env: []]
*** Offending Program ***
g_sv8
  :: forall {d} {b} {p :: * -> * -> *} {c} {a}.
     p b d -> (c -> d) -> p a c -> p b d
[LclId,
 Arity=3,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=True)}]
g_sv8
  = \ (@d_agS)
      (@b_agR)
      (@(p_agQ :: * -> * -> *))
      (@c_agU)
      (@a_agT)
      (x_X1 :: p_agQ b_agR d_agS)
      (eta_B2 :: c_agU -> d_agS)
      (eta_B1 :: p_agQ a_agT c_agU) ->
      let {
        x_av5 :: p_agQ a_agT c_agU -> p_agQ b_agR d_agS
        [LclId, Arity=1]
        x_av5 = \ _ [Occ=Dead] -> x_X1 } in
      x_av5 eta_B1

f [InlPrag=INLINE (sat-args=0)]
  :: forall (p :: * -> * -> *) b d a c.
     p b d -> (a -> b) -> (c -> d) -> p a c -> p b d
[LclIdX,
 Arity=4,
 Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=0,unsat_ok=False,boring_ok=True)
         Tmpl= \ (@(p_agQ :: * -> * -> *))
                 (@b_agR)
                 (@d_agS)
                 (@a_agT)
                 (@c_agU)
                 (x_av2 [Occ=OnceL] :: p_agQ b_agR d_agS)
                 _ [Occ=Dead]
                 (eta_B2 [Occ=Once] :: c_agU -> d_agS)
                 (eta_B1 [Occ=Once] :: p_agQ a_agT c_agU) ->
                 let {
                   x_X2 [Occ=Once] :: p_agQ a_agT c_agU -> p_agQ b_agR d_agS
                   [LclId, Arity=1]
                   x_X2 = \ _ [Occ=Dead] -> x_av2 } in
                 let {
                   x_av5 [Occ=Once!T[2]]
                     :: (c_agU -> d_agS) -> p_agQ a_agT c_agU -> p_agQ b_agR d_agS
                   [LclId, Arity=2]
                   x_av5 = \ _ [Occ=Dead, OS=OneShot] -> x_X2 } in
                 x_av5 eta_B2 eta_B1}]
f = \ (@(p_agQ :: * -> * -> *))
      (@b_agR)
      (@d_agS)
      (@a_agT)
      (@c_agU)
      (x_X1 :: p_agQ b_agR d_agS)
      (eta_B3 :: a_agT -> b_agR)
      (eta_B2 :: c_agU -> d_agS)
      (eta_B1 :: p_agQ a_agT c_agU) ->
      let {
        x_av5 :: (c_agU -> d_agS) -> p_agQ a_agT c_agU -> p_agQ b_agR d_agS
        [LclId, Arity=2]
        x_av5 = \ _ [Occ=Dead] (eta_B1 :: p_agQ a_agT c_agU) -> x_X1 } in
      x_av5 eta_B2 eta_B1

$trModule_sv9 :: Addr#
[LclId,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
$trModule_sv9 = "main"#

$trModule_sva :: TrName
[LclId,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
$trModule_sva = TrNameS $trModule_sv9

$trModule_svb :: Addr#
[LclId,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
$trModule_svb = "Bug"#

$trModule_svc :: TrName
[LclId,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
$trModule_svc = TrNameS $trModule_svb

$trModule :: Module
[LclIdX,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
$trModule = Module $trModule_sva $trModule_svc

*** End of Offense ***

GHC 8.10.1 passes Core Lint.

To upload designs, you'll need to enable LFS and have an admin enable hashed storage. More information