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: