    {-# 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) } } )