QualifiedDo is not working as expected.

Summary

QualifiedDo is not working as expected.

Steps to reproduce

example code:

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

module E where

import Data.Data (Typeable)
import Data.Kind (Type)

infixr 0 ~>
type f ~> g = forall x. f x -> g x

class IFunctor f where
    imap :: (a ~> b) -> f a ~> f b

class IFunctor f => IApplicative f where
    ireturn :: a ~> f a

class IApplicative m => IMonad m where
    ibind :: (a ~> m b) -> m a ~> m b

class IMonad m => IMonadFail m where
    fail :: String -> m a ix

data At :: Type -> k -> k -> Type where
    At :: a -> At a k k
    deriving (Typeable)

(>>=) :: IMonad (m :: (x -> Type) -> x -> Type) => m a ix -> (a ~> m b) -> m b ix
m >>= f = ibind f m

data FHState = FOpen | FClosed

data FHSTATE :: FHState -> Type where
    FOPEN :: FHSTATE FOpen
    FCLOSED :: FHSTATE FClosed

data FH :: (FHState -> Type) -> FHState -> Type where
    FHReturn :: q i -> FH q i
    FHOpen :: FilePath -> (FHSTATE ~> FH q) -> FH q FClosed
    FHClose :: FH q FClosed -> FH q FOpen
    FHRead :: (Maybe Char -> FH q FOpen) -> FH q FOpen
    FHIO :: IO () -> FH q i -> FH q i

instance IFunctor FH where
    imap f (FHReturn q) = FHReturn (f q)
    imap f (FHOpen s k) = FHOpen s (imap f . k)
    imap f (FHClose q) = FHClose (imap f q)
    imap f (FHRead k) = FHRead (imap f . k)
    imap f (FHIO io k) = FHIO io (imap f k)

instance IApplicative FH where
    ireturn = FHReturn

instance IMonad FH where
    ibind f (FHReturn q) = f q
    ibind f (FHOpen fp p) = FHOpen fp (ibind f . p)
    ibind f (FHClose q) = FHClose (ibind f q)
    ibind f (FHRead f') = FHRead (ibind f . f')
    ibind f (FHIO io f') = FHIO io (ibind f f')

fhOpen :: FilePath -> FH FHSTATE 'FClosed
fhOpen f = FHOpen f FHReturn

fhClose :: FH (At () 'FClosed) 'FOpen
fhClose = FHClose . FHReturn $ At ()

fhio :: IO () -> FH (At () i) i
fhio io = FHIO io . FHReturn $ At ()

----------------------right function -------------------------------
rightFun :: FilePath -> FH (At () FClosed) FClosed
rightFun fp =
    fhio (print fp)
        E.>>= ( \(At _) -> E.do
                    fhOpen fp E.>>= \case
                        FCLOSED -> FHReturn (At ())
                        FOPEN -> E.do
                            At _ <- fhClose
                            FHReturn (At ())
              )

----------------------bug function -------------------------------
errorFun :: FilePath -> FH (At () FClosed) FClosed
errorFun fp = E.do
    At _ <- fhio (print fp)
    foState <- fhOpen fp
    case foState of
        FCLOSED -> FHReturn (At ())
        FOPEN -> E.do
            At _ <- fhClose
            FHReturn (At ())

compile this file

get the result:

ghc: panic! (the 'impossible' happened)
  (GHC version 9.2.5:
	refineFromInScope
  InScope {wild_00 fp_a2ll $dShow_a2C0 $cibind_a2EN $cireturn_a2G9
           $cimap_a2Gk $krep_a2IO $krep_a2IP $krep_a2IQ $krep_a2IR $krep_a2IS
           $krep_a2IT $krep_a2IU $krep_a2IV $krep_a2IW $krep_a2IX $krep_a2IY
           $krep_a2IZ $krep_a2J0 $krep_a2J1 $krep_a2J2 $krep_a2J3 $krep_a2J4
           $krep_a2J5 $krep_a2J6 $krep_a2J7 $krep_a2J8 $krep_a2J9 $krep_a2Ja
           $krep_a2Jb $krep_a2Jc $krep_a2Jd $krep_a2Je $krep_a2Jf $krep_a2Jg
           $krep_a2Jh $krep_a2Ji $krep_a2Jj $krep_a2Jk $krep_a2Jl $krep_a2Jm
           $krep_a2Jn $krep_a2Jo >>= fhOpen fhClose fhio rightFun errorFun
           $tcIFunctor $tcIApplicative $tcIMonad $tcIMonadFail $tc'At $tcAt
           $tc'FOpen $tc'FClosed $tcFHState $tc'FOPEN $tc'FCLOSED $tcFHSTATE
           $tc'FHReturn $tc'FHClose $tc'FHRead $tc'FHIO $tcFH
           $fIMonadFHStateFH $fIApplicativeFHStateFH
           $fIFunctorFHStateFHStateFH $trModule $krep_s2Mg $krep_s2Mh
           $krep_s2Mi $krep_s2Mj $krep_s2Mk $krep_s2Ml $krep_s2Mm
           $trModule_s2Mn $trModule_s2Mo $trModule_s2Mp $trModule_s2Mq
           $tcIFunctor_s2Mr $tcIFunctor_s2Ms $tcIApplicative_s2Mt
           $tcIApplicative_s2Mu $tcIMonad_s2Mv $tcIMonad_s2Mw
           $tcIMonadFail_s2Mx $tcIMonadFail_s2My $tcAt_s2Mz $tcAt_s2MA
           $krep_s2MB $krep_s2MC $krep_s2MD $krep_s2ME $tc'At_s2MF $tc'At_s2MG
           $tcFHState_s2MH $tcFHState_s2MI $tc'FOpen_s2MJ $tc'FOpen_s2MK
           $tc'FClosed_s2ML $tc'FClosed_s2MM $tcFHSTATE_s2MN $tcFHSTATE_s2MO
           $krep_s2MP $krep_s2MQ $tc'FOPEN_s2MR $tc'FOPEN_s2MS
           $tc'FCLOSED_s2MT $tc'FCLOSED_s2MU $tcFH_s2MV $tcFH_s2MW $krep_s2MX
           $krep_s2MY $krep_s2MZ $krep_s2N0 $krep_s2N1 $krep_s2N2
           $tc'FHReturn_s2N3 $tc'FHReturn_s2N4 $tc'FHIO_s2N5 $tc'FHIO_s2N6
           $tc'FHClose_s2N7 $tc'FHClose_s2N8 $tc'FHRead_s2N9 $tc'FHRead_s2Na
           fhClose_s2Nb fhClose_s2Nc}
  $dShow_a2Dk
  Call stack:
      CallStack (from HasCallStack):
        callStackDoc, called at compiler/GHC/Utils/Panic.hs:181:37 in ghc:GHC.Utils.Panic
        pprPanic, called at compiler/GHC/Core/Opt/Simplify/Env.hs:706:30 in ghc:GHC.Core.Opt.Simplify.Env

Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug

Expected behavior

rightFun and errorFun have exactly the same meaning. errorFun should compile fine.

Environment

• GHC version used: 9.2.5

Optional:

• Operating System: ubunt20
• System Architecture: