-- (c) The University of Glasgow 2006

{-# LANGUAGE CPP, DeriveDataTypeable #-}

module TcEvidence (

  -- HsWrapper
  HsWrapper(..),
  (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpLams, mkWpLet, mkWpCast,
  mkWpFun, idHsWrapper, isIdHsWrapper, pprHsWrapper,

  -- Evidence bindings
  TcEvBinds(..), EvBindsVar(..),
  EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds,
  EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds,
  EvTerm(..), mkEvCast, evVarsOfTerm, mkEvTupleSelectors, mkEvScSelectors,
  EvLit(..), evTermCoercion,
  EvTypeable(..),
  EvCallStack(..),

  -- TcCoercion
  TcCoercion(..), LeftOrRight(..), pickLR,
  mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo,
  mkTcTyConAppCo, mkTcAppCo, mkTcAppCos, mkTcFunCo,
  mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos,
  mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo,
  tcDowngradeRole, mkTcTransAppCo,
  mkTcAxiomRuleCo, mkTcPhantomCo,
  tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo,
  isTcReflCo, getTcCoVar_maybe,
  tcCoercionRole, eqVarRole,
  unwrapIP, wrapIP
  ) where
#include "HsVersions.h"

import Var
import Coercion
import PprCore ()   -- Instance OutputableBndr TyVar
import TypeRep      -- Knows type representation
import TcType
import Type
import TyCon
import Class( Class )
import CoAxiom
import PrelNames
import VarEnv
import VarSet
import Name

import Util
import Bag
import Pair
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
import Data.Traversable (traverse, sequenceA)
#endif
import qualified Data.Data as Data
import Outputable
import FastString
import SrcLoc
import Data.IORef( IORef )

{-
Note [TcCoercions]
~~~~~~~~~~~~~~~~~~
| TcCoercions are a hack used by the typechecker. Normally,
Coercions have free variables of type (a ~# b): we call these
CoVars. However, the type checker passes around equality evidence
(boxed up) at type (a ~ b).

An TcCoercion is simply a Coercion whose free variables have the
boxed type (a ~ b). After we are done with typechecking the
desugarer finds the free variables, unboxes them, and creates a
resulting real Coercion with kosher free variables.

We can use most of the Coercion "smart constructors" to build TcCoercions.
However, mkCoVarCo will not work! The equivalent is mkTcCoVarCo.

The data type is similar to Coercion.Coercion, with the following
differences
  * Most important, TcLetCo adds let-bindings for coercions.
    This is what lets us unify two for-all types and generate
    equality constraints underneath

  * The kind of a TcCoercion is  t1 ~  t2  (resp. Coercible t1 t2)
             of a Coercion   is  t1 ~# t2  (resp. t1 ~#R t2)

  * UnsafeCo aren't required, but we do have TcPhantomCo

  * Representation invariants are weaker:
     - we are allowed to have type synonyms in TcTyConAppCo
     - the first arg of a TcAppCo can be a TcTyConAppCo
     - TcSubCo is not applied as deep as done with mkSubCo
    Reason: they'll get established when we desugar to Coercion

  * TcAxiomInstCo has a [TcCoercion] parameter, and not a [Type] parameter.
    This differs from the formalism, but corresponds to AxiomInstCo (see
    [Coercion axioms applied to coercions]).

Note [mkTcTransAppCo]
~~~~~~~~~~~~~~~~~~~~~
Suppose we have

  co1 :: a ~R Maybe
  co2 :: b ~R Int

and we want

  co3 :: a b ~R Maybe Int

This seems sensible enough. But, we can't let (co3 = co1 co2), because
that's ill-roled! Note that mkTcAppCo requires a *nominal* second coercion.

The way around this is to use transitivity:

  co3 = (co1 <b>_N) ; (Maybe co2) :: a b ~R Maybe Int

Or, it's possible everything is the other way around:

  co1' :: Maybe ~R a
  co2' :: Int   ~R b

and we want

  co3' :: Maybe Int ~R a b

then

  co3' = (Maybe co2') ; (co1' <b>_N)

This is exactly what `mkTcTransAppCo` builds for us. Information for all
the arguments tends to be to hand at call sites, so it's quicker than
using, say, tcCoercionKind.
-}

data TcCoercion
  = TcRefl Role TcType
  | TcTyConAppCo Role TyCon [TcCoercion]
  | TcAppCo TcCoercion TcCoercion
  | TcForAllCo TyVar TcCoercion
  | TcCoVarCo EqVar
  | TcAxiomInstCo (CoAxiom Branched) Int [TcCoercion] -- Int specifies branch number
                                                      -- See [CoAxiom Index] in Coercion.lhs
  -- This is number of types and coercions are expected to match to CoAxiomRule
  -- (i.e., the CoAxiomRules are always fully saturated)
  | TcAxiomRuleCo CoAxiomRule [TcType] [TcCoercion]
  | TcPhantomCo TcType TcType
  | TcSymCo TcCoercion
  | TcTransCo TcCoercion TcCoercion
  | TcNthCo Int TcCoercion
  | TcLRCo LeftOrRight TcCoercion
  | TcSubCo TcCoercion
  | TcCastCo TcCoercion TcCoercion     -- co1 |> co2
  | TcLetCo TcEvBinds TcCoercion
  | TcCoercion Coercion            -- embed a Core Coercion
  deriving (Data.Data, Data.Typeable)

isEqVar :: Var -> Bool
-- Is lifted coercion variable (only!)
isEqVar v = case tyConAppTyCon_maybe (varType v) of
               Just tc -> tc `hasKey` eqTyConKey
               Nothing -> False

isTcReflCo_maybe :: TcCoercion -> Maybe TcType
isTcReflCo_maybe (TcRefl _ ty) = Just ty
isTcReflCo_maybe _             = Nothing

isTcReflCo :: TcCoercion -> Bool
isTcReflCo (TcRefl {}) = True
isTcReflCo _           = False

getTcCoVar_maybe :: TcCoercion -> Maybe CoVar
getTcCoVar_maybe (TcCoVarCo v) = Just v
getTcCoVar_maybe _             = Nothing

mkTcReflCo :: Role -> TcType -> TcCoercion
mkTcReflCo = TcRefl

mkTcNomReflCo :: TcType -> TcCoercion
mkTcNomReflCo = TcRefl Nominal

mkTcRepReflCo :: TcType -> TcCoercion
mkTcRepReflCo = TcRefl Representational

mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion
mkTcFunCo role co1 co2 = mkTcTyConAppCo role funTyCon [co1, co2]

mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion
mkTcTyConAppCo role tc cos -- No need to expand type synonyms
                           -- See Note [TcCoercions]
  | Just tys <- traverse isTcReflCo_maybe cos
  = TcRefl role (mkTyConApp tc tys)  -- See Note [Refl invariant]

  | otherwise = TcTyConAppCo role tc cos

-- input coercion is Nominal
-- mkSubCo will do some normalisation. We do not do it for TcCoercions, but
-- defer that to desugaring; just to reduce the code duplication a little bit
mkTcSubCo :: TcCoercion -> TcCoercion
mkTcSubCo co = ASSERT2( tcCoercionRole co == Nominal, ppr co)
               TcSubCo co

-- See Note [Role twiddling functions] in Coercion
-- | Change the role of a 'TcCoercion'. Returns 'Nothing' if this isn't
-- a downgrade.
tcDowngradeRole_maybe :: Role   -- desired role
                      -> Role   -- current role
                      -> TcCoercion -> Maybe TcCoercion
tcDowngradeRole_maybe Representational Nominal = Just . mkTcSubCo
tcDowngradeRole_maybe Nominal Representational = const Nothing
tcDowngradeRole_maybe Phantom _
  = panic "tcDowngradeRole_maybe Phantom"
    -- not supported (not needed at the moment)
tcDowngradeRole_maybe _ Phantom                = const Nothing
tcDowngradeRole_maybe _ _                      = Just

-- See Note [Role twiddling functions] in Coercion
-- | Change the role of a 'TcCoercion'. Panics if this isn't a downgrade.
tcDowngradeRole :: Role  -- ^ desired role
                -> Role  -- ^ current role
                -> TcCoercion -> TcCoercion
tcDowngradeRole r1 r2 co
  = case tcDowngradeRole_maybe r1 r2 co of
      Just co' -> co'
      Nothing  -> pprPanic "tcDowngradeRole" (ppr r1 <+> ppr r2 <+> ppr co)

-- | If the EqRel is ReprEq, makes a TcSubCo; otherwise, does nothing.
-- Note that the input coercion should always be nominal.
maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion
maybeTcSubCo NomEq  = id
maybeTcSubCo ReprEq = mkTcSubCo

mkTcAxInstCo :: Role -> CoAxiom br -> Int -> [TcType] -> TcCoercion
mkTcAxInstCo role ax index tys
  | ASSERT2( not (role == Nominal && ax_role == Representational) , ppr (ax, tys) )
    arity == n_tys = tcDowngradeRole role ax_role $
                     TcAxiomInstCo ax_br index rtys
  | otherwise      = ASSERT( arity < n_tys )
                     tcDowngradeRole role ax_role $
                     foldl TcAppCo (TcAxiomInstCo ax_br index (take arity rtys))
                                   (drop arity rtys)
  where
    n_tys     = length tys
    ax_br     = toBranchedAxiom ax
    branch    = coAxiomNthBranch ax_br index
    arity     = length $ coAxBranchTyVars branch
    ax_role   = coAxiomRole ax
    arg_roles = coAxBranchRoles branch
    rtys      = zipWith mkTcReflCo (arg_roles ++ repeat Nominal) tys

mkTcAxiomRuleCo :: CoAxiomRule -> [TcType] -> [TcCoercion] -> TcCoercion
mkTcAxiomRuleCo = TcAxiomRuleCo

mkTcUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [TcType] -> TcCoercion
mkTcUnbranchedAxInstCo role ax tys
  = mkTcAxInstCo role ax 0 tys

mkTcAppCo :: TcCoercion -> TcCoercion -> TcCoercion
-- No need to deal with TyConApp on the left; see Note [TcCoercions]
-- Second coercion *must* be nominal
mkTcAppCo (TcRefl r ty1) (TcRefl _ ty2) = TcRefl r (mkAppTy ty1 ty2)
mkTcAppCo co1 co2                       = TcAppCo co1 co2

-- | Like `mkTcAppCo`, but allows the second coercion to be other than
-- nominal. See Note [mkTcTransAppCo]. Role r3 cannot be more stringent
-- than either r1 or r2.
mkTcTransAppCo :: Role           -- ^ r1
               -> TcCoercion     -- ^ co1 :: ty1a ~r1 ty1b
               -> TcType         -- ^ ty1a
               -> TcType         -- ^ ty1b
               -> Role           -- ^ r2
               -> TcCoercion     -- ^ co2 :: ty2a ~r2 ty2b
               -> TcType         -- ^ ty2a
               -> TcType         -- ^ ty2b
               -> Role           -- ^ r3
               -> TcCoercion     -- ^ :: ty1a ty2a ~r3 ty1b ty2b
mkTcTransAppCo r1 co1 ty1a ty1b r2 co2 ty2a ty2b r3
-- How incredibly fiddly! Is there a better way??
  = case (r1, r2, r3) of
      (_,                _,                Phantom)
        -> mkTcPhantomCo (mkAppTy ty1a ty2a) (mkAppTy ty1b ty2b)
      (_,                _,                Nominal)
        -> ASSERT( r1 == Nominal && r2 == Nominal )
           mkTcAppCo co1 co2
      (Nominal,          Nominal,          Representational)
        -> mkTcSubCo (mkTcAppCo co1 co2)
      (_,                Nominal,          Representational)
        -> ASSERT( r1 == Representational )
           mkTcAppCo co1 co2
      (Nominal,          Representational, Representational)
        -> go (mkTcSubCo co1)
      (_               , _,                Representational)
        -> ASSERT( r1 == Representational && r2 == Representational )
           go co1
  where
    go co1_repr
      | Just (tc1b, tys1b) <- tcSplitTyConApp_maybe ty1b
      , nextRole ty1b == r2
      = (co1_repr `mkTcAppCo` mkTcNomReflCo ty2a) `mkTcTransCo`
        (mkTcTyConAppCo Representational tc1b
           (zipWith mkTcReflCo (tyConRolesX Representational tc1b) tys1b
            ++ [co2]))

      | Just (tc1a, tys1a) <- tcSplitTyConApp_maybe ty1a
      , nextRole ty1a == r2
      = (mkTcTyConAppCo Representational tc1a
           (zipWith mkTcReflCo (tyConRolesX Representational tc1a) tys1a
            ++ [co2]))
        `mkTcTransCo`
        (co1_repr `mkTcAppCo` mkTcNomReflCo ty2b)

      | otherwise
      = pprPanic "mkTcTransAppCo" (vcat [ ppr r1, ppr co1, ppr ty1a, ppr ty1b
                                        , ppr r2, ppr co2, ppr ty2a, ppr ty2b
                                        , ppr r3 ])

mkTcSymCo :: TcCoercion -> TcCoercion
mkTcSymCo co@(TcRefl {})  = co
mkTcSymCo    (TcSymCo co) = co
mkTcSymCo co              = TcSymCo co

mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion
mkTcTransCo (TcRefl {}) co = co
mkTcTransCo co (TcRefl {}) = co
mkTcTransCo co1 co2        = TcTransCo co1 co2

mkTcNthCo :: Int -> TcCoercion -> TcCoercion
mkTcNthCo n (TcRefl r ty) = TcRefl r (tyConAppArgN n ty)
mkTcNthCo n co            = TcNthCo n co

mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion
mkTcLRCo lr (TcRefl r ty) = TcRefl r (pickLR lr (tcSplitAppTy ty))
mkTcLRCo lr co            = TcLRCo lr co

mkTcPhantomCo :: TcType -> TcType -> TcCoercion
mkTcPhantomCo = TcPhantomCo

mkTcAppCos :: TcCoercion -> [TcCoercion] -> TcCoercion
mkTcAppCos co1 tys = foldl mkTcAppCo co1 tys

mkTcForAllCo :: Var -> TcCoercion -> TcCoercion
-- note that a TyVar should be used here, not a CoVar (nor a TcTyVar)
mkTcForAllCo tv (TcRefl r ty) = ASSERT( isTyVar tv ) TcRefl r (mkForAllTy tv ty)
mkTcForAllCo tv  co           = ASSERT( isTyVar tv ) TcForAllCo tv co

mkTcForAllCos :: [Var] -> TcCoercion -> TcCoercion
mkTcForAllCos tvs (TcRefl r ty) = ASSERT( all isTyVar tvs ) TcRefl r (mkForAllTys tvs ty)
mkTcForAllCos tvs co            = ASSERT( all isTyVar tvs ) foldr TcForAllCo co tvs

mkTcCoVarCo :: EqVar -> TcCoercion
-- ipv :: s ~ t  (the boxed equality type) or Coercible s t (the boxed representational equality type)
mkTcCoVarCo ipv = TcCoVarCo ipv
  -- Previously I checked for (ty ~ ty) and generated Refl,
  -- but in fact ipv may not even (visibly) have a (t1 ~ t2) type, because
  -- the constraint solver does not substitute in the types of
  -- evidence variables as it goes.  In any case, the optimisation
  -- will be done in the later zonking phase

tcCoercionKind :: TcCoercion -> Pair Type
tcCoercionKind co = go co
  where
    go (TcRefl _ ty)          = Pair ty ty
    go (TcLetCo _ co)         = go co
    go (TcCastCo _ co)        = case getEqPredTys (pSnd (go co)) of
                                   (ty1,ty2) -> Pair ty1 ty2
    go (TcTyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos)
    go (TcAppCo co1 co2)      = mkAppTy <$> go co1 <*> go co2
    go (TcForAllCo tv co)     = mkForAllTy tv <$> go co
    go (TcCoVarCo cv)         = eqVarKind cv
    go (TcAxiomInstCo ax ind cos)
      = let branch = coAxiomNthBranch ax ind
            tvs = coAxBranchTyVars branch
            Pair tys1 tys2 = sequenceA (map go cos)
        in ASSERT( cos `equalLength` tvs )
           Pair (substTyWith tvs tys1 (coAxNthLHS ax ind))
                (substTyWith tvs tys2 (coAxBranchRHS branch))
    go (TcPhantomCo ty1 ty2)  = Pair ty1 ty2
    go (TcSymCo co)           = swap (go co)
    go (TcTransCo co1 co2)    = Pair (pFst (go co1)) (pSnd (go co2))
    go (TcNthCo d co)         = tyConAppArgN d <$> go co
    go (TcLRCo lr co)         = (pickLR lr . tcSplitAppTy) <$> go co
    go (TcSubCo co)           = go co
    go (TcAxiomRuleCo ax ts cs) =
       case coaxrProves ax ts (map tcCoercionKind cs) of
         Just res -> res
         Nothing -> panic "tcCoercionKind: malformed TcAxiomRuleCo"
    go (TcCoercion co)        = coercionKind co

eqVarRole :: EqVar -> Role
eqVarRole cv = getEqPredRole (varType cv)

eqVarKind :: EqVar -> Pair Type
eqVarKind cv
 | Just (tc, [_kind,ty1,ty2]) <- tcSplitTyConApp_maybe (varType cv)
 = ASSERT(tc `hasKey` eqTyConKey)
   Pair ty1 ty2
 | otherwise = pprPanic "eqVarKind, non coercion variable" (ppr cv <+> dcolon <+> ppr (varType cv))

tcCoercionRole :: TcCoercion -> Role
tcCoercionRole = go
  where
    go (TcRefl r _)           = r
    go (TcTyConAppCo r _ _)   = r
    go (TcAppCo co _)         = go co
    go (TcForAllCo _ co)      = go co
    go (TcCoVarCo cv)         = eqVarRole cv
    go (TcAxiomInstCo ax _ _) = coAxiomRole ax
    go (TcPhantomCo _ _)      = Phantom
    go (TcSymCo co)           = go co
    go (TcTransCo co1 _)      = go co1 -- same as go co2
    go (TcNthCo n co)         = let Pair ty1 _ = tcCoercionKind co
                                    (tc, _) = tcSplitTyConApp ty1
                                in nthRole (go co) tc n
    go (TcLRCo _ _)           = Nominal
    go (TcSubCo _)            = Representational
    go (TcAxiomRuleCo c _ _)  = coaxrRole c
    go (TcCastCo c _)         = go c
    go (TcLetCo _ c)          = go c
    go (TcCoercion co)        = coercionRole co


coVarsOfTcCo :: TcCoercion -> VarSet
-- Only works on *zonked* coercions, because of TcLetCo
coVarsOfTcCo tc_co
  = go tc_co
  where
    go (TcRefl _ _)              = emptyVarSet
    go (TcTyConAppCo _ _ cos)    = mapUnionVarSet go cos
    go (TcAppCo co1 co2)         = go co1 `unionVarSet` go co2
    go (TcCastCo co1 co2)        = go co1 `unionVarSet` go co2
    go (TcForAllCo _ co)         = go co
    go (TcCoVarCo v)             = unitVarSet v
    go (TcAxiomInstCo _ _ cos)   = mapUnionVarSet go cos
    go (TcPhantomCo _ _)         = emptyVarSet
    go (TcSymCo co)              = go co
    go (TcTransCo co1 co2)       = go co1 `unionVarSet` go co2
    go (TcNthCo _ co)            = go co
    go (TcLRCo  _ co)            = go co
    go (TcSubCo co)              = go co
    go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs
                                   `minusVarSet` get_bndrs bs
    go (TcLetCo {}) = emptyVarSet    -- Harumph. This does legitimately happen in the call
                                     -- to evVarsOfTerm in the DEBUG check of setEvBind
    go (TcAxiomRuleCo _ _ cos)   = mapUnionVarSet go cos
    go (TcCoercion co)           = -- the use of coVarsOfTcCo in dsTcCoercion will
                                   -- fail if there are any proper, unlifted covars
                                   ASSERT( isEmptyVarSet (coVarsOfCo co) )
                                   emptyVarSet

    -- We expect only coercion bindings, so use evTermCoercion
    go_bind :: EvBind -> VarSet
    go_bind (EvBind _ tm) = go (evTermCoercion tm)

    get_bndrs :: Bag EvBind -> VarSet
    get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet

-- Pretty printing

instance Outputable TcCoercion where
  ppr = pprTcCo

pprTcCo, pprParendTcCo :: TcCoercion -> SDoc
pprTcCo       co = ppr_co TopPrec   co
pprParendTcCo co = ppr_co TyConPrec co

ppr_co :: TyPrec -> TcCoercion -> SDoc
ppr_co _ (TcRefl r ty) = angleBrackets (ppr ty) <> ppr_role r

ppr_co p co@(TcTyConAppCo _ tc [_,_])
  | tc `hasKey` funTyConKey = ppr_fun_co p co

ppr_co p (TcTyConAppCo r tc cos) = pprTcApp   p ppr_co tc cos <> ppr_role r
ppr_co p (TcLetCo bs co)         = maybeParen p TopPrec $
                                   sep [ptext (sLit "let") <+> braces (ppr bs), ppr co]
ppr_co p (TcAppCo co1 co2)       = maybeParen p TyConPrec $
                                   pprTcCo co1 <+> ppr_co TyConPrec co2
ppr_co p (TcCastCo co1 co2)      = maybeParen p FunPrec $
                                   ppr_co FunPrec co1 <+> ptext (sLit "|>") <+> ppr_co FunPrec co2
ppr_co p co@(TcForAllCo {})      = ppr_forall_co p co

ppr_co _ (TcCoVarCo cv)          = parenSymOcc (getOccName cv) (ppr cv)

ppr_co p (TcAxiomInstCo con ind cos)
  = pprPrefixApp p (ppr (getName con) <> brackets (ppr ind)) (map pprParendTcCo cos)

ppr_co p (TcTransCo co1 co2) = maybeParen p FunPrec $
                               ppr_co FunPrec co1
                               <+> ptext (sLit ";")
                               <+> ppr_co FunPrec co2
ppr_co p (TcPhantomCo t1 t2)  = pprPrefixApp p (ptext (sLit "PhantomCo")) [pprParendType t1, pprParendType t2]
ppr_co p (TcSymCo co)         = pprPrefixApp p (ptext (sLit "Sym")) [pprParendTcCo co]
ppr_co p (TcNthCo n co)       = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendTcCo co]
ppr_co p (TcLRCo lr co)       = pprPrefixApp p (ppr lr) [pprParendTcCo co]
ppr_co p (TcSubCo co)         = pprPrefixApp p (ptext (sLit "Sub")) [pprParendTcCo co]
ppr_co p (TcAxiomRuleCo co ts ps) = maybeParen p TopPrec
                                  $ ppr_tc_axiom_rule_co co ts ps
ppr_co p (TcCoercion co)      = pprPrefixApp p (text "Core co:") [ppr co]

ppr_tc_axiom_rule_co :: CoAxiomRule -> [TcType] -> [TcCoercion] -> SDoc
ppr_tc_axiom_rule_co co ts ps = ppr (coaxrName co) <> ppTs ts $$ nest 2 (ppPs ps)
  where
  ppTs []   = Outputable.empty
  ppTs [t]  = ptext (sLit "@") <> ppr_type TopPrec t
  ppTs ts   = ptext (sLit "@") <>
                parens (hsep $ punctuate comma $ map pprType ts)

  ppPs []   = Outputable.empty
  ppPs [p]  = pprParendTcCo p
  ppPs (p : ps) = ptext (sLit "(") <+> pprTcCo p $$
                  vcat [ ptext (sLit ",") <+> pprTcCo q | q <- ps ] $$
                  ptext (sLit ")")

ppr_role :: Role -> SDoc
ppr_role r = underscore <> pp_role
  where pp_role = case r of
                    Nominal          -> char 'N'
                    Representational -> char 'R'
                    Phantom          -> char 'P'

ppr_fun_co :: TyPrec -> TcCoercion -> SDoc
ppr_fun_co p co = pprArrowChain p (split co)
  where
    split :: TcCoercion -> [SDoc]
    split (TcTyConAppCo _ f [arg,res])
      | f `hasKey` funTyConKey
      = ppr_co FunPrec arg : split res
    split co = [ppr_co TopPrec co]

ppr_forall_co :: TyPrec -> TcCoercion -> SDoc
ppr_forall_co p ty
  = maybeParen p FunPrec $
    sep [pprForAll tvs, ppr_co TopPrec rho]
  where
    (tvs,  rho) = split1 [] ty
    split1 tvs (TcForAllCo tv ty) = split1 (tv:tvs) ty
    split1 tvs ty                 = (reverse tvs, ty)

{-
************************************************************************
*                                                                      *
                  HsWrapper
*                                                                      *
************************************************************************
-}

data HsWrapper
  = WpHole                      -- The identity coercion

  | WpCompose HsWrapper HsWrapper
       -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]]
       --
       -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])
       -- But    ([] a)   `WpCompose` ([] b)   = ([] b a)

  | WpFun HsWrapper HsWrapper TcType TcType
       -- (WpFun wrap1 wrap2 t1 t2)[e] = \(x:t1). wrap2[ e wrap1[x] ] :: t2
       -- So note that if  wrap1 :: exp_arg <= act_arg
       --                  wrap2 :: act_res <= exp_res
       --           then   WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res)
       -- This isn't the same as for mkTcFunCo, but it has to be this way
       -- because we can't use 'sym' to flip around these HsWrappers

  | WpCast TcCoercion         -- A cast:  [] `cast` co
                              -- Guaranteed not the identity coercion
                              -- At role Representational

        -- Evidence abstraction and application
        -- (both dictionaries and coercions)
  | WpEvLam  EvVar               -- \d. []       the 'd' is an evidence variable
  | WpEvApp  EvTerm              -- [] d         the 'd' is evidence for a constraint

        -- Kind and Type abstraction and application
  | WpTyLam TyVar       -- \a. []  the 'a' is a type/kind variable (not coercion var)
  | WpTyApp KindOrType  -- [] t    the 't' is a type (not coercion)


  | WpLet TcEvBinds             -- Non-empty (or possibly non-empty) evidence bindings,
                                -- so that the identity coercion is always exactly WpHole
  deriving (Data.Data, Data.Typeable)


(<.>) :: HsWrapper -> HsWrapper -> HsWrapper
WpHole <.> c = c
c <.> WpHole = c
c1 <.> c2    = c1 `WpCompose` c2

mkWpFun :: HsWrapper -> HsWrapper -> TcType -> TcType -> HsWrapper
mkWpFun WpHole       WpHole       _  _  = WpHole
mkWpFun WpHole       (WpCast co2) t1 _  = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2)
mkWpFun (WpCast co1) WpHole       _  t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2))
mkWpFun (WpCast co1) (WpCast co2) _  _  = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2)
mkWpFun co1          co2          t1 t2 = WpFun co1 co2 t1 t2

mkWpCast :: TcCoercion -> HsWrapper
mkWpCast co
  | isTcReflCo co = WpHole
  | otherwise     = ASSERT2(tcCoercionRole co == Representational, ppr co)
                    WpCast co

mkWpTyApps :: [Type] -> HsWrapper
mkWpTyApps tys = mk_co_app_fn WpTyApp tys

mkWpEvApps :: [EvTerm] -> HsWrapper
mkWpEvApps args = mk_co_app_fn WpEvApp args

mkWpEvVarApps :: [EvVar] -> HsWrapper
mkWpEvVarApps vs = mkWpEvApps (map EvId vs)

mkWpTyLams :: [TyVar] -> HsWrapper
mkWpTyLams ids = mk_co_lam_fn WpTyLam ids

mkWpLams :: [Var] -> HsWrapper
mkWpLams ids = mk_co_lam_fn WpEvLam ids

mkWpLet :: TcEvBinds -> HsWrapper
-- This no-op is a quite a common case
mkWpLet (EvBinds b) | isEmptyBag b = WpHole
mkWpLet ev_binds                   = WpLet ev_binds

mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as

mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
-- For applications, the *first* argument must
-- come *last* in the composition sequence
mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as

idHsWrapper :: HsWrapper
idHsWrapper = WpHole

isIdHsWrapper :: HsWrapper -> Bool
isIdHsWrapper WpHole = True
isIdHsWrapper _      = False

{-
************************************************************************
*                                                                      *
                  Evidence bindings
*                                                                      *
************************************************************************
-}

data TcEvBinds
  = TcEvBinds           -- Mutable evidence bindings
       EvBindsVar       -- Mutable because they are updated "later"
                        --    when an implication constraint is solved

  | EvBinds             -- Immutable after zonking
       (Bag EvBind)

  deriving( Data.Typeable )

data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
     -- The Unique is only for debug printing

instance Data.Data TcEvBinds where
  -- Placeholder; we can't travers into TcEvBinds
  toConstr _   = abstractConstr "TcEvBinds"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = Data.mkNoRepType "TcEvBinds"

-----------------
newtype EvBindMap
  = EvBindMap {
       ev_bind_varenv :: VarEnv EvBind
    }       -- Map from evidence variables to evidence terms

emptyEvBindMap :: EvBindMap
emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv }

extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
extendEvBinds bs v t
  = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) }

lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs)

evBindMapBinds :: EvBindMap -> Bag EvBind
evBindMapBinds bs
  = foldVarEnv consBag emptyBag (ev_bind_varenv bs)

-----------------
-- All evidence is bound by EvBinds; no side effects
data EvBind = EvBind EvVar EvTerm

data EvTerm
  = EvId EvId                    -- Any sort of evidence Id, including coercions

  | EvCoercion TcCoercion        -- (Boxed) coercion bindings
                                 -- See Note [Coercion evidence terms]

  | EvCast EvTerm TcCoercion     -- d |> co, the coercion being at role representational

  | EvDFunApp DFunId             -- Dictionary instance application
       [Type] [EvTerm]

  | EvTupleSel EvTerm  Int       -- n'th component of the tuple, 0-indexed

  | EvTupleMk [EvTerm]           -- tuple built from this stuff

  | EvDelayedError Type FastString  -- Used with Opt_DeferTypeErrors
                               -- See Note [Deferring coercion errors to runtime]
                               -- in TcSimplify

  | EvSuperClass EvTerm Int      -- n'th superclass. Used for both equalities and
                                 -- dictionaries, even though the former have no
                                 -- selector Id.  We count up from _0_

  | EvLit EvLit       -- Dictionary for KnownNat and KnownSymbol classes.
                      -- Note [KnownNat & KnownSymbol and EvLit]

  | EvTypeable EvTypeable   -- Dictionary for `Typeable`

  | EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters

  deriving( Data.Data, Data.Typeable )

-- | Instructions on how to make a 'Typeable' dictionary.
data EvTypeable
  = EvTypeableTyCon TyCon [Kind]
    -- ^ Dicitionary for concrete type constructors.

  | EvTypeableTyApp (EvTerm,Type) (EvTerm,Type)
    -- ^ Dictionary for type applications;  this is used when we have
    -- a type expression starting with a type variable (e.g., @Typeable (f a)@)

  | EvTypeableTyLit Type
    -- ^ Dictionary for a type literal.

  deriving ( Data.Data, Data.Typeable )

data EvLit
  = EvNum Integer
  | EvStr FastString
    deriving( Data.Data, Data.Typeable )

-- | Evidence for @CallStack@ implicit parameters.
data EvCallStack
  -- See Note [Overview of implicit CallStacks]
  = EvCsEmpty
  | EvCsPushCall Name RealSrcSpan EvTerm
    -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at
    -- @loc@, in a calling context @stk@.
  | EvCsTop FastString RealSrcSpan EvTerm
    -- ^ @EvCsTop name loc stk@ represents a use of an implicit parameter
    -- @?name@, occurring at @loc@, in a calling context @stk@.
  deriving( Data.Data, Data.Typeable )

{-
Note [Coercion evidence terms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A "coercion evidence term" takes one of these forms
   co_tm ::= EvId v           where v :: t1 ~ t2
           | EvCoercion co
           | EvCast co_tm co

We do quite often need to get a TcCoercion from an EvTerm; see
'evTermCoercion'.

INVARIANT: The evidence for any constraint with type (t1~t2) is
a coercion evidence term.  Consider for example
    [G] d :: F Int a
If we have
    ax7 a :: F Int a ~ (a ~ Bool)
then we do NOT generate the constraint
    [G] (d |> ax7 a) :: a ~ Bool
because that does not satisfy the invariant (d is not a coercion variable).
Instead we make a binding
    g1 :: a~Bool = g |> ax7 a
and the constraint
    [G] g1 :: a~Bool
See Trac [7238] and Note [Bind new Givens immediately] in TcSMonad

Note [EvBinds/EvTerm]
~~~~~~~~~~~~~~~~~~~~~
How evidence is created and updated. Bindings for dictionaries,
and coercions and implicit parameters are carried around in TcEvBinds
which during constraint generation and simplification is always of the
form (TcEvBinds ref). After constraint simplification is finished it
will be transformed to t an (EvBinds ev_bag).

Evidence for coercions *SHOULD* be filled in using the TcEvBinds
However, all EvVars that correspond to *wanted* coercion terms in
an EvBind must be mutable variables so that they can be readily
inlined (by zonking) after constraint simplification is finished.

Conclusion: a new wanted coercion variable should be made mutable.
[Notice though that evidence variables that bind coercion terms
 from super classes will be "given" and hence rigid]


Note [KnownNat & KnownSymbol and EvLit]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A part of the type-level literals implementation are the classes
"KnownNat" and "KnownSymbol", which provide a "smart" constructor for
defining singleton values.  Here is the key stuff from GHC.TypeLits

  class KnownNat (n :: Nat) where
    natSing :: SNat n

  newtype SNat (n :: Nat) = SNat Integer

Conceptually, this class has infinitely many instances:

  instance KnownNat 0       where natSing = SNat 0
  instance KnownNat 1       where natSing = SNat 1
  instance KnownNat 2       where natSing = SNat 2
  ...

In practice, we solve `KnownNat` predicates in the type-checker
(see typecheck/TcInteract.hs) because we can't have infinately many instances.
The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.

We make the following assumptions about dictionaries in GHC:
  1. The "dictionary" for classes with a single method---like `KnownNat`---is
     a newtype for the type of the method, so using a evidence amounts
     to a coercion, and
  2. Newtypes use the same representation as their definition types.

So, the evidence for `KnownNat` is just a value of the representation type,
wrapped in two newtype constructors: one to make it into a `SNat` value,
and another to make it into a `KnownNat` dictionary.

Also note that `natSing` and `SNat` are never actually exposed from the
library---they are just an implementation detail.  Instead, users see
a more convenient function, defined in terms of `natSing`:

  natVal :: KnownNat n => proxy n -> Integer

The reason we don't use this directly in the class is that it is simpler
and more efficient to pass around an integer rather than an entier function,
especialy when the `KnowNat` evidence is packaged up in an existential.

The story for kind `Symbol` is analogous:
  * class KnownSymbol
  * newtype SSymbol
  * Evidence: EvLit (EvStr n)


Note [Overview of implicit CallStacks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(See https://ghc.haskell.org/trac/ghc/wiki/ExplicitCallStack/ImplicitLocations)

The goal of CallStack evidence terms is to reify locations
in the program source as runtime values, without any support
from the RTS. We accomplish this by assigning a special meaning
to implicit parameters of type GHC.Stack.CallStack. A use of
a CallStack IP, e.g.

  head []    = error (show (?loc :: CallStack))
  head (x:_) = x

will be solved with the source location that gave rise to the IP
constraint (here, the use of ?loc). If there is already
a CallStack IP in scope, e.g. passed-in as an argument

  head :: (?loc :: CallStack) => [a] -> a
  head []    = error (show (?loc :: CallStack))
  head (x:_) = x

we will push the new location onto the CallStack that was passed
in. These two cases are reflected by the EvCallStack evidence
type. In the first case, we will create an evidence term

  EvCsTop "?loc" <?loc's location> EvCsEmpty

and in the second we'll have a given constraint

  [G] d :: IP "loc" CallStack

in scope, and will create an evidence term

  EvCsTop "?loc" <?loc's location> d

When we call a function that uses a CallStack IP, e.g.

  f = head xs

we create an evidence term

  EvCsPushCall "head" <head's location> EvCsEmpty

again pushing onto a given evidence term if one exists.

This provides a lightweight mechanism for building up call-stacks
explicitly, but is notably limited by the fact that the stack will
stop at the first function whose type does not include a CallStack IP.
For example, using the above definition of head:

  f :: [a] -> a
  f = head

  g = f []

the resulting CallStack will include use of ?loc inside head and
the call to head inside f, but NOT the call to f inside g, because f
did not explicitly request a CallStack.

Important Details:
- GHC should NEVER report an insoluble CallStack constraint.

- A CallStack (defined in GHC.Stack) is a [(String, SrcLoc)], where the String
  is the name of the binder that is used at the SrcLoc. SrcLoc is defined in
  GHC.SrcLoc and contains the package/module/file name, as well as the full
  source-span. Both CallStack and SrcLoc are kept abstract so only GHC can
  construct new values.

- Consider the use of ?stk in:

    head :: (?stk :: CallStack) => [a] -> a
    head [] = error (show ?stk)

  When solving the use of ?stk we'll have a given

   [G] d :: IP "stk" CallStack

  in scope. In the interaction phase, GHC would normally solve the use of ?stk
  directly from the given, i.e. re-using the dicionary. But this is NOT what we
  want! We want to generate a *new* CallStack with ?loc's SrcLoc pushed onto
  the given CallStack. So we must take care in TcInteract.interactDict to
  prioritize solving wanted CallStacks.

- We will automatically solve any wanted CallStack regardless of the name of the
  IP, i.e.

    f = show (?stk :: CallStack)
    g = show (?loc :: CallStack)

  are both valid. However, we will only push new SrcLocs onto existing
  CallStacks when the IP names match, e.g. in

    head :: (?loc :: CallStack) => [a] -> a
    head [] = error (show (?stk :: CallStack))

  the printed CallStack will NOT include head's call-site. This reflects the
  standard scoping rules of implicit-parameters. (See TcInteract.interactDict)

- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`.
  The desugarer will need to unwrap the IP newtype before pushing a new
  call-site onto a given stack (See DsBinds.dsEvCallStack)

- We only want to intercept constraints that arose due to the use of an IP or a
  function call. In particular, we do NOT want to intercept the

    (?stk :: CallStack) => [a] -> a
      ~
    (?stk :: CallStack) => [a] -> a

  constraint that arises from the ambiguity check on `head`s type signature.
  (See TcEvidence.isCallStackIP)
-}

mkEvCast :: EvTerm -> TcCoercion -> EvTerm
mkEvCast ev lco
  | ASSERT2(tcCoercionRole lco == Representational, (vcat [ptext (sLit "Coercion of wrong role passed to mkEvCast:"), ppr ev, ppr lco]))
    isTcReflCo lco = ev
  | otherwise      = EvCast ev lco

mkEvTupleSelectors :: EvTerm -> [TcPredType] -> [(TcPredType, EvTerm)]
mkEvTupleSelectors ev preds = zipWith mk_pr preds [0..]
  where
    mk_pr pred i = (pred, EvTupleSel ev i)

mkEvScSelectors :: EvTerm -> Class -> [TcType] -> [(TcPredType, EvTerm)]
mkEvScSelectors ev cls tys
   = zipWith mk_pr (immSuperClasses cls tys) [0..]
  where
    mk_pr pred i = (pred, EvSuperClass ev i)

emptyTcEvBinds :: TcEvBinds
emptyTcEvBinds = EvBinds emptyBag

isEmptyTcEvBinds :: TcEvBinds -> Bool
isEmptyTcEvBinds (EvBinds b)    = isEmptyBag b
isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"


evTermCoercion :: EvTerm -> TcCoercion
-- Applied only to EvTerms of type (s~t)
-- See Note [Coercion evidence terms]
evTermCoercion (EvId v)        = mkTcCoVarCo v
evTermCoercion (EvCoercion co) = co
evTermCoercion (EvCast tm co)  = TcCastCo (evTermCoercion tm) co
evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm)

evVarsOfTerm :: EvTerm -> VarSet
evVarsOfTerm (EvId v)             = unitVarSet v
evVarsOfTerm (EvCoercion co)      = coVarsOfTcCo co
evVarsOfTerm (EvDFunApp _ _ evs)  = evVarsOfTerms evs
evVarsOfTerm (EvTupleSel v _)     = evVarsOfTerm v
evVarsOfTerm (EvSuperClass v _)   = evVarsOfTerm v
evVarsOfTerm (EvCast tm co)       = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co
evVarsOfTerm (EvTupleMk evs)      = evVarsOfTerms evs
evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
evVarsOfTerm (EvLit _)            = emptyVarSet
evVarsOfTerm (EvTypeable ev)      = evVarsOfTypeable ev
evVarsOfTerm (EvCallStack cs)     = evVarsOfCallStack cs

evVarsOfTerms :: [EvTerm] -> VarSet
evVarsOfTerms = mapUnionVarSet evVarsOfTerm

evVarsOfTypeable :: EvTypeable -> VarSet
evVarsOfTypeable ev =
  case ev of
    EvTypeableTyCon _ _    -> emptyVarSet
    EvTypeableTyApp e1 e2  -> evVarsOfTerms (map fst [e1,e2])
    EvTypeableTyLit _      -> emptyVarSet

evVarsOfCallStack :: EvCallStack -> VarSet
evVarsOfCallStack cs = case cs of
  EvCsEmpty -> emptyVarSet
  EvCsTop _ _ tm -> evVarsOfTerm tm
  EvCsPushCall _ _ tm -> evVarsOfTerm tm

{-
************************************************************************
*                                                                      *
                  Pretty printing
*                                                                      *
************************************************************************
-}

instance Outputable HsWrapper where
  ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn

pprHsWrapper :: SDoc -> HsWrapper -> SDoc
-- In debug mode, print the wrapper
-- otherwise just print what's inside
pprHsWrapper doc wrap
  = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc)
  where
    help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
    -- True  <=> appears in function application position
    -- False <=> appears as body of let or lambda
    help it WpHole             = it
    help it (WpCompose f1 f2)  = help (help it f2) f1
    help it (WpFun f1 f2 t1 _) = add_parens $ ptext (sLit "\\(x") <> dcolon <> ppr t1 <> ptext (sLit ").") <+>
                                              help (\_ -> it True <+> help (\_ -> ptext (sLit "x")) f1 True) f2 False
    help it (WpCast co)   = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
                                              <+> pprParendTcCo co)]
    help it (WpEvApp id)    = no_parens  $ sep [it True, nest 2 (ppr id)]
    help it (WpTyApp ty)    = no_parens  $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
    help it (WpEvLam id)    = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
    help it (WpTyLam tv)    = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False]
    help it (WpLet binds)   = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False]

    pp_bndr v = pprBndr LambdaBind v <> dot

    add_parens, no_parens :: SDoc -> Bool -> SDoc
    add_parens d True  = parens d
    add_parens d False = d
    no_parens d _ = d

instance Outputable TcEvBinds where
  ppr (TcEvBinds v) = ppr v
  ppr (EvBinds bs)  = ptext (sLit "EvBinds") <> braces (vcat (map ppr (bagToList bs)))

instance Outputable EvBindsVar where
  ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)

instance Outputable EvBind where
  ppr (EvBind v e)   = sep [ ppr v, nest 2 $ equals <+> ppr e ]
   -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing

instance Outputable EvTerm where
  ppr (EvId v)           = ppr v
  ppr (EvCast v co)      = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
  ppr (EvCoercion co)    = ptext (sLit "CO") <+> ppr co
  ppr (EvTupleSel v n)   = ptext (sLit "tupsel") <> parens (ppr (v,n))
  ppr (EvTupleMk vs)     = ptext (sLit "tupmk") <+> ppr vs
  ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
  ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
  ppr (EvLit l)          = ppr l
  ppr (EvCallStack cs)   = ppr cs
  ppr (EvDelayedError ty msg) =     ptext (sLit "error")
                                <+> sep [ char '@' <> ppr ty, ppr msg ]
  ppr (EvTypeable ev)    = ppr ev

instance Outputable EvLit where
  ppr (EvNum n) = integer n
  ppr (EvStr s) = text (show s)

instance Outputable EvTypeable where
  ppr ev =
    case ev of
      EvTypeableTyCon tc ks    -> parens (ppr tc <+> sep (map ppr ks))
      EvTypeableTyApp t1 t2    -> parens (ppr (fst t1) <+> ppr (fst t2))
      EvTypeableTyLit x        -> ppr x

instance Outputable EvCallStack where
  ppr EvCsEmpty
    = ptext (sLit "[]")
  ppr (EvCsTop name loc tm)
    = angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm
  ppr (EvCsPushCall name loc tm)
    = angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm

----------------------------------------------------------------------
-- Helper functions for dealing with IP newtype-dictionaries
----------------------------------------------------------------------

-- | Create a 'Coercion' that unwraps an implicit-parameter dictionary
-- to expose the underlying value. We expect the 'Type' to have the form
-- `IP sym ty`, return a 'Coercion' `co :: IP sym ty ~ ty`.
unwrapIP :: Type -> Coercion
unwrapIP ty =
  case unwrapNewTyCon_maybe tc of
    Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys
    Nothing       -> pprPanic "unwrapIP" $
                       text "The dictionary for" <+> quotes (ppr tc)
                         <+> text "is not a newtype!"
  where
  (tc, tys) = splitTyConApp ty

-- | Create a 'Coercion' that wraps a value in an implicit-parameter
-- dictionary. See 'unwrapIP'.
wrapIP :: Type -> Coercion
wrapIP ty = mkSymCo (unwrapIP ty)