{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
module GHC.Tc.Zonk.Monad
(
ZonkM(ZonkM,runZonkM)
, ZonkGblEnv(..), getZonkGblEnv, getZonkTcLevel
, traceZonk
)
where
import GHC.Prelude
import GHC.Driver.Flags ( DumpFlag(Opt_D_dump_tc_trace) )
import GHC.Types.SrcLoc ( SrcSpan )
import GHC.Tc.Types.BasicTypes ( TcBinderStack )
import GHC.Tc.Utils.TcType ( TcLevel )
import GHC.Utils.Logger
import GHC.Utils.Outputable
import Control.Monad ( when )
import Control.Monad.IO.Class ( MonadIO(..) )
import GHC.Exts ( oneShot )
data ZonkGblEnv
= ZonkGblEnv
{ ZonkGblEnv -> Logger
zge_logger :: Logger
, ZonkGblEnv -> NamePprCtx
zge_name_ppr_ctx :: NamePprCtx
, ZonkGblEnv -> SrcSpan
zge_src_span :: SrcSpan
, ZonkGblEnv -> TcLevel
zge_tc_level :: TcLevel
, ZonkGblEnv -> TcBinderStack
zge_binder_stack :: TcBinderStack
}
newtype ZonkM a = ZonkM' { forall a. ZonkM a -> ZonkGblEnv -> IO a
runZonkM :: ZonkGblEnv -> IO a }
{-# COMPLETE ZonkM #-}
pattern ZonkM :: forall a. (ZonkGblEnv -> IO a) -> ZonkM a
pattern $mZonkM :: forall {r} {a}.
ZonkM a -> ((ZonkGblEnv -> IO a) -> r) -> ((# #) -> r) -> r
$bZonkM :: forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM m <- ZonkM' m
where
ZonkM ZonkGblEnv -> IO a
m = (ZonkGblEnv -> IO a) -> ZonkM a
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM' ((ZonkGblEnv -> IO a) -> ZonkGblEnv -> IO a
forall a b. (a -> b) -> a -> b
oneShot ZonkGblEnv -> IO a
m)
instance Functor ZonkM where
fmap :: forall a b. (a -> b) -> ZonkM a -> ZonkM b
fmap a -> b
f (ZonkM ZonkGblEnv -> IO a
g) = (ZonkGblEnv -> IO b) -> ZonkM b
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM ((ZonkGblEnv -> IO b) -> ZonkM b)
-> (ZonkGblEnv -> IO b) -> ZonkM b
forall a b. (a -> b) -> a -> b
$ \ !ZonkGblEnv
env -> (a -> b) -> IO a -> IO b
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ZonkGblEnv -> IO a
g ZonkGblEnv
env)
a
a <$ :: forall a b. a -> ZonkM b -> ZonkM a
<$ ZonkM ZonkGblEnv -> IO b
g = (ZonkGblEnv -> IO a) -> ZonkM a
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM ((ZonkGblEnv -> IO a) -> ZonkM a)
-> (ZonkGblEnv -> IO a) -> ZonkM a
forall a b. (a -> b) -> a -> b
$ \ !ZonkGblEnv
env -> a
a a -> IO b -> IO a
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ZonkGblEnv -> IO b
g ZonkGblEnv
env
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative ZonkM where
pure :: forall a. a -> ZonkM a
pure a
a = (ZonkGblEnv -> IO a) -> ZonkM a
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM (\ !ZonkGblEnv
_ -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
ZonkM ZonkGblEnv -> IO (a -> b)
f <*> :: forall a b. ZonkM (a -> b) -> ZonkM a -> ZonkM b
<*> ZonkM ZonkGblEnv -> IO a
x = (ZonkGblEnv -> IO b) -> ZonkM b
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM (\ !ZonkGblEnv
env -> ZonkGblEnv -> IO (a -> b)
f ZonkGblEnv
env IO (a -> b) -> IO a -> IO b
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ZonkGblEnv -> IO a
x ZonkGblEnv
env )
ZonkM ZonkGblEnv -> IO a
m *> :: forall a b. ZonkM a -> ZonkM b -> ZonkM b
*> ZonkM b
f = (ZonkGblEnv -> IO b) -> ZonkM b
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM (\ !ZonkGblEnv
env -> ZonkGblEnv -> IO a
m ZonkGblEnv
env IO a -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ZonkM b -> ZonkGblEnv -> IO b
forall a. ZonkM a -> ZonkGblEnv -> IO a
runZonkM ZonkM b
f ZonkGblEnv
env)
{-# INLINE pure #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
instance Monad ZonkM where
ZonkM ZonkGblEnv -> IO a
m >>= :: forall a b. ZonkM a -> (a -> ZonkM b) -> ZonkM b
>>= a -> ZonkM b
f =
(ZonkGblEnv -> IO b) -> ZonkM b
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM (\ !ZonkGblEnv
env -> do { r <- ZonkGblEnv -> IO a
m ZonkGblEnv
env
; runZonkM (f r) env })
>> :: forall a b. ZonkM a -> ZonkM b -> ZonkM b
(>>) = ZonkM a -> ZonkM b -> ZonkM b
forall a b. ZonkM a -> ZonkM b -> ZonkM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
{-# INLINE (>>=) #-}
{-# INLINE (>>) #-}
instance MonadIO ZonkM where
liftIO :: forall a. IO a -> ZonkM a
liftIO IO a
f = (ZonkGblEnv -> IO a) -> ZonkM a
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM (\ !ZonkGblEnv
_ -> IO a
f)
{-# INLINE liftIO #-}
getZonkGblEnv :: ZonkM ZonkGblEnv
getZonkGblEnv :: ZonkM ZonkGblEnv
getZonkGblEnv = (ZonkGblEnv -> IO ZonkGblEnv) -> ZonkM ZonkGblEnv
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM ZonkGblEnv -> IO ZonkGblEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE getZonkGblEnv #-}
getZonkTcLevel :: ZonkM TcLevel
getZonkTcLevel :: ZonkM TcLevel
getZonkTcLevel = (ZonkGblEnv -> IO TcLevel) -> ZonkM TcLevel
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM (\ZonkGblEnv
env -> TcLevel -> IO TcLevel
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonkGblEnv -> TcLevel
zge_tc_level ZonkGblEnv
env))
traceZonk :: String -> SDoc -> ZonkM ()
traceZonk :: String -> SDoc -> ZonkM ()
traceZonk String
herald SDoc
doc = (ZonkGblEnv -> IO ()) -> ZonkM ()
forall a. (ZonkGblEnv -> IO a) -> ZonkM a
ZonkM ((ZonkGblEnv -> IO ()) -> ZonkM ())
-> (ZonkGblEnv -> IO ()) -> ZonkM ()
forall a b. (a -> b) -> a -> b
$
\ ( ZonkGblEnv { zge_logger :: ZonkGblEnv -> Logger
zge_logger = !Logger
logger, zge_name_ppr_ctx :: ZonkGblEnv -> NamePprCtx
zge_name_ppr_ctx = NamePprCtx
ppr_ctx }) ->
do { let sty :: PprStyle
sty = NamePprCtx -> PprStyle
mkDumpStyle NamePprCtx
ppr_ctx
flag :: DumpFlag
flag = DumpFlag
Opt_D_dump_tc_trace
title :: String
title = String
""
msg :: SDoc
msg = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
herald) Int
2 SDoc
doc
; Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
flag) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Logger
-> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger PprStyle
sty DumpFlag
flag String
title DumpFormat
FormatText SDoc
msg
}
{-# INLINE traceZonk #-}