{-# LANGUAGE RecordWildCards #-}

module Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) where

import GhcApi.GhcPlugins
import GhcApi.Constraint
  (Ct(..), CtEvidence(..), CanEqLHS(..), CtLoc, ctLoc, ctEvId, mkNonCanonical)

import GHC.Tc.Utils.TcType (TcType)
import GHC.Tc.Types.Constraint (DictCt(..), IrredCt(..), EqCt(..), QCInst(..))
import GHC.Tc.Types.Evidence (EvTerm(..), EvBindsVar)
import GHC.Tc.Plugin (TcPluginM)
import qualified GHC.Tc.Plugin as TcPlugin (newGiven)

-- | Create a new [G]iven constraint, with the supplied evidence. This must not

-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic.

newGiven :: EvBindsVar -> CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence
newGiven :: EvBindsVar -> CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence
newGiven EvBindsVar
tcEvbinds CtLoc
loc PredType
pty (EvExpr EvExpr
ev) = EvBindsVar -> CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
TcPlugin.newGiven EvBindsVar
tcEvbinds CtLoc
loc PredType
pty EvExpr
ev
newGiven EvBindsVar
_ CtLoc
_ PredType
_ EvTerm
ev = String -> SDoc -> TcPluginM CtEvidence
forall a. String -> SDoc -> a
panicDoc String
"newGiven: not an EvExpr: " (EvTerm -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvTerm
ev)

flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct
flatToCt :: [((TcTyVar, PredType), Ct)] -> Maybe Ct
flatToCt [((TcTyVar
_,PredType
lhs),Ct
ct),((TcTyVar
_,PredType
rhs),Ct
_)]
    = Ct -> Maybe Ct
forall a. a -> Maybe a
Just
    (Ct -> Maybe Ct) -> Ct -> Maybe Ct
forall a b. (a -> b) -> a -> b
$ CtEvidence -> Ct
mkNonCanonical
    (CtEvidence -> Ct) -> CtEvidence -> Ct
forall a b. (a -> b) -> a -> b
$ PredType -> TcTyVar -> CtLoc -> CtEvidence
CtGiven (PredType -> PredType -> PredType
mkPrimEqPred PredType
lhs PredType
rhs)
              (HasDebugCallStack => Ct -> TcTyVar
Ct -> TcTyVar
ctEvId Ct
ct)
              (Ct -> CtLoc
ctLoc Ct
ct)

flatToCt [((TcTyVar, PredType), Ct)]
_ = Maybe Ct
forall a. Maybe a
Nothing

-- | Create simple substitution from type equalities

mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct)
mkSubst :: Ct -> Maybe ((TcTyVar, PredType), Ct)
mkSubst ct :: Ct
ct@(CEqCan (EqCt {PredType
EqRel
CtEvidence
CanEqLHS
eq_ev :: CtEvidence
eq_lhs :: CanEqLHS
eq_rhs :: PredType
eq_eq_rel :: EqRel
eq_eq_rel :: EqCt -> EqRel
eq_rhs :: EqCt -> PredType
eq_lhs :: EqCt -> CanEqLHS
eq_ev :: EqCt -> CtEvidence
..}))
  | TyVarLHS TcTyVar
tyvar <- CanEqLHS
eq_lhs
  = ((TcTyVar, PredType), Ct) -> Maybe ((TcTyVar, PredType), Ct)
forall a. a -> Maybe a
Just ((TcTyVar
tyvar,PredType
eq_rhs),Ct
ct)
mkSubst Ct
_ = Maybe ((TcTyVar, PredType), Ct)
forall a. Maybe a
Nothing

-- | Modify the predicate type of the evidence term of a constraint

overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct
overEvidencePredType :: (PredType -> PredType) -> Ct -> Ct
overEvidencePredType PredType -> PredType
f (CDictCan DictCt
di) =
  let
    ev :: CtEvidence
    ev :: CtEvidence
ev = DictCt -> CtEvidence
di_ev DictCt
di
  in DictCt -> Ct
CDictCan ( DictCt
di { di_ev = ev { ctev_pred = f (ctev_pred ev) } } )
overEvidencePredType PredType -> PredType
f (CIrredCan IrredCt
ir) =
  let
    ev :: CtEvidence
    ev :: CtEvidence
ev = IrredCt -> CtEvidence
ir_ev IrredCt
ir
  in IrredCt -> Ct
CIrredCan ( IrredCt
ir { ir_ev = ev { ctev_pred = f (ctev_pred ev) } } )
overEvidencePredType PredType -> PredType
f (CEqCan EqCt
eq) =
  let
    ev :: CtEvidence
    ev :: CtEvidence
ev = EqCt -> CtEvidence
eq_ev EqCt
eq
  in EqCt -> Ct
CEqCan ( EqCt
eq { eq_ev = ev { ctev_pred = f (ctev_pred ev) } } )
overEvidencePredType PredType -> PredType
f (CNonCanonical CtEvidence
ct) =
  let
    ev :: CtEvidence
    ev :: CtEvidence
ev = CtEvidence
ct
  in CtEvidence -> Ct
CNonCanonical ( CtEvidence
ev { ctev_pred = f (ctev_pred ev) } )
overEvidencePredType PredType -> PredType
f (CQuantCan QCInst
qci) =
  let
    ev :: CtEvidence
    ev :: CtEvidence
ev = QCInst -> CtEvidence
qci_ev QCInst
qci
  in QCInst -> Ct
CQuantCan ( QCInst
qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } )