{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Graph.Trace.Internal.Solver
( tcPlugin
) where
import qualified Graph.Trace.Internal.GhcFacade as Ghc
tcPlugin :: Ghc.TcPlugin
tcPlugin :: TcPlugin
tcPlugin =
Ghc.TcPlugin
{ tcPluginInit :: TcPluginM ()
Ghc.tcPluginInit = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, tcPluginStop :: () -> TcPluginM ()
Ghc.tcPluginStop = \()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, tcPluginSolve :: () -> TcPluginSolver
Ghc.tcPluginSolve = forall a b. a -> b -> a
const TcPluginSolver
tcPluginSolver
#if MIN_VERSION_ghc(9,4,0)
, Ghc.tcPluginRewrite = mempty
#endif
}
debuggerIpKey :: Ghc.FastString
debuggerIpKey :: FastString
debuggerIpKey = FastString
"_debug_ip"
isDebuggerIpCt :: Ghc.Ct -> Bool
isDebuggerIpCt :: Ct -> Bool
isDebuggerIpCt ct :: Ct
ct@Ghc.CDictCan{}
| Class -> Name
Ghc.className (Ct -> Class
Ghc.cc_class Ct
ct) forall a. Eq a => a -> a -> Bool
== Name
Ghc.ipClassName
, Xi
ty : [Xi]
_ <- Ct -> [Xi]
Ghc.cc_tyargs Ct
ct
, Just FastString
ipKey <- Xi -> Maybe FastString
Ghc.isStrLitTy Xi
ty
, FastString
ipKey forall a. Eq a => a -> a -> Bool
== FastString
debuggerIpKey
= Bool
True
isDebuggerIpCt Ct
_ = Bool
False
tcPluginSolver :: Ghc.TcPluginSolver
tcPluginSolver :: TcPluginSolver
tcPluginSolver [Ct]
_ [] [Ct]
wanted = do
case forall a. (a -> Bool) -> [a] -> [a]
filter Ct -> Bool
isDebuggerIpCt [Ct]
wanted of
[Ct
w]
| Ghc.IPOccOrigin HsIPName
_ <- CtLoc -> CtOrigin
Ghc.ctl_origin forall b c a. (b -> c) -> (a -> b) -> a -> c
. CtEvidence -> CtLoc
Ghc.ctev_loc forall a b. (a -> b) -> a -> b
$ Ct -> CtEvidence
Ghc.cc_ev Ct
w
-> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(EvTerm, Ct)] -> [Ct] -> TcPluginResult
Ghc.TcPluginOk [] []
| Bool
otherwise
-> do
let expr :: CoreExpr
expr = Xi -> CoreExpr
Ghc.mkNothingExpr Xi
Ghc.anyTy
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(EvTerm, Ct)] -> [Ct] -> TcPluginResult
Ghc.TcPluginOk [(CoreExpr -> EvTerm
Ghc.EvExpr CoreExpr
expr, Ct
w)] []
[Ct]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(EvTerm, Ct)] -> [Ct] -> TcPluginResult
Ghc.TcPluginOk [] []
tcPluginSolver [Ct]
_ [Ct]
_ [Ct]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(EvTerm, Ct)] -> [Ct] -> TcPluginResult
Ghc.TcPluginOk [] []