{-# LANGUAGE OverloadedStrings #-}
module Graph.Trace.Internal.Solver
  ( tcPlugin
  ) where

import qualified Graph.Trace.Internal.GhcFacade as Ghc

tcPlugin :: Ghc.TcPlugin
tcPlugin :: TcPlugin
tcPlugin =
  TcPlugin :: forall s.
TcPluginM s
-> (s -> TcPluginSolver) -> (s -> TcPluginM ()) -> TcPlugin
Ghc.TcPlugin
    { tcPluginInit :: TcPluginM ()
Ghc.tcPluginInit = () -> TcPluginM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , tcPluginStop :: () -> TcPluginM ()
Ghc.tcPluginStop = \()
_ -> () -> TcPluginM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , tcPluginSolve :: () -> TcPluginSolver
Ghc.tcPluginSolve = TcPluginSolver -> () -> TcPluginSolver
forall a b. a -> b -> a
const TcPluginSolver
tcPluginSolver
    }

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) Name -> Name -> Bool
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 FastString -> FastString -> Bool
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 (Ct -> Bool) -> [Ct] -> [Ct]
forall a. (a -> Bool) -> [a] -> [a]
filter Ct -> Bool
isDebuggerIpCt [Ct]
wanted of
    [Ct
w]
      | Ghc.IPOccOrigin HsIPName
_ <- CtLoc -> CtOrigin
Ghc.ctl_origin (CtLoc -> CtOrigin)
-> (CtEvidence -> CtLoc) -> CtEvidence -> CtOrigin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CtEvidence -> CtLoc
Ghc.ctev_loc (CtEvidence -> CtOrigin) -> CtEvidence -> CtOrigin
forall a b. (a -> b) -> a -> b
$ Ct -> CtEvidence
Ghc.cc_ev Ct
w
      -> do
        -- This occurs when the IP constraint is satisfied but a wanted still
        -- gets emitted for the a use site of the IP variable (why?).
        -- We don't want to touch this constraint because the value for the IP
        -- should be inherited from the context.
        TcPluginResult -> TcPluginM TcPluginResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcPluginResult -> TcPluginM TcPluginResult)
-> TcPluginResult -> TcPluginM TcPluginResult
forall a b. (a -> b) -> a -> b
$ [(EvTerm, Ct)] -> [Ct] -> TcPluginResult
Ghc.TcPluginOk [] []
      | Bool
otherwise
      -> do
           -- This occurs when the IP constraint is not satisfiable by the context.
           -- Here we want to manually construct a value with which to satisfy it.
           let expr :: CoreExpr
expr = Xi -> CoreExpr
Ghc.mkNothingExpr Xi
Ghc.anyTy
           TcPluginResult -> TcPluginM TcPluginResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcPluginResult -> TcPluginM TcPluginResult)
-> TcPluginResult -> TcPluginM TcPluginResult
forall a b. (a -> b) -> a -> b
$ [(EvTerm, Ct)] -> [Ct] -> TcPluginResult
Ghc.TcPluginOk [(CoreExpr -> EvTerm
Ghc.EvExpr CoreExpr
expr, Ct
w)] []
    [Ct]
_ -> TcPluginResult -> TcPluginM TcPluginResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcPluginResult -> TcPluginM TcPluginResult)
-> TcPluginResult -> TcPluginM TcPluginResult
forall a b. (a -> b) -> a -> b
$ [(EvTerm, Ct)] -> [Ct] -> TcPluginResult
Ghc.TcPluginOk [] []
tcPluginSolver [Ct]
_ [Ct]
_ [Ct]
_ = TcPluginResult -> TcPluginM TcPluginResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcPluginResult -> TcPluginM TcPluginResult)
-> TcPluginResult -> TcPluginM TcPluginResult
forall a b. (a -> b) -> a -> b
$ [(EvTerm, Ct)] -> [Ct] -> TcPluginResult
Ghc.TcPluginOk [] []