{-
(c) The University of Glasgow 2006
-}

{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns,
             ScopedTypeVariables #-}

-- | Module for (a) type kinds and (b) type coercions,
-- as used in System FC. See 'CoreSyn.Expr' for
-- more on System FC and how coercions fit into it.
--
module Coercion (
        -- * Main data type
        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR,
        UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
        LeftOrRight(..),
        Var, CoVar, TyCoVar,
        Role(..), ltRole,

        -- ** Functions over coercions
        coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole,
        coercionType, coercionKind, coercionKinds,
        mkCoercionType,
        coercionRole, coercionKindRole,

        -- ** Constructing coercions
        mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo,
        mkCoVarCo, mkCoVarCos,
        mkAxInstCo, mkUnbranchedAxInstCo,
        mkAxInstRHS, mkUnbranchedAxInstRHS,
        mkAxInstLHS, mkUnbranchedAxInstLHS,
        mkPiCo, mkPiCos, mkCoCast,
        mkSymCo, mkTransCo, mkTransMCo,
        mkNthCo, nthCoRole, mkLRCo,
        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo,
        mkForAllCo, mkForAllCos, mkHomoForAllCos,
        mkPhantomCo,
        mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo,
        mkAxiomInstCo, mkProofIrrelCo,
        downgradeRole, mkAxiomRuleCo,
        mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,
        mkKindCo, castCoercionKind, castCoercionKindI,

        mkHeteroCoercionType,
        mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,
        mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,

        -- ** Decomposition
        instNewTyCon_maybe,

        NormaliseStepper, NormaliseStepResult(..), composeSteppers,
        mapStepResult, unwrapNewTypeStepper,
        topNormaliseNewType_maybe, topNormaliseTypeX,

        decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,
        splitTyConAppCo_maybe,
        splitAppCo_maybe,
        splitFunCo_maybe,
        splitForAllCo_maybe,
        splitForAllCo_ty_maybe, splitForAllCo_co_maybe,

        nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,

        pickLR,

        isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,
        isReflCoVar_maybe, isGReflMCo, coToMCo,

        -- ** Coercion variables
        mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,
        isCoVar_maybe,

        -- ** Free variables
        tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,
        tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,
        coercionSize,

        -- ** Substitution
        CvSubstEnv, emptyCvSubstEnv,
        lookupCoVar,
        substCo, substCos, substCoVar, substCoVars, substCoWith,
        substCoVarBndr,
        extendTvSubstAndInScope, getCvSubstEnv,

        -- ** Lifting
        liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,
        emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,
        liftCoSubstVarBndrUsing, isMappedByLC,

        mkSubstLiftingContext, zapLiftingContext,
        substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet,

        LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,
        substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,

        -- ** Comparison
        eqCoercion, eqCoercionX,

        -- ** Forcing evaluation of coercions
        seqCo,

        -- * Pretty-printing
        pprCo, pprParendCo,
        pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS,
        pprCoAxBranchUser, tidyCoAxBndrsForUser,
        etaExpandCoAxBranch,

        -- * Tidying
        tidyCo, tidyCos,

        -- * Other
        promoteCoercion, buildCoercion,

        simplifyArgsWorker
       ) where

#include "HsVersions.h"

import {-# SOURCE #-} ToIface (toIfaceTyCon, tidyToIfaceTcArgs)

import GhcPrelude

import IfaceType
import TyCoRep
import TyCoFVs
import TyCoPpr
import TyCoSubst
import TyCoTidy
import Type
import TyCon
import CoAxiom
import Var
import VarEnv
import VarSet
import Name hiding ( varName )
import Util
import BasicTypes
import Outputable
import Unique
import Pair
import SrcLoc
import PrelNames
import TysPrim
import ListSetOps
import Maybes
import UniqFM

import Control.Monad (foldM, zipWithM)
import Data.Function ( on )
import Data.Char( isDigit )

{-
%************************************************************************
%*                                                                      *
     -- The coercion arguments always *precisely* saturate
     -- arity of (that branch of) the CoAxiom.  If there are
     -- any left over, we use AppCo.  See
     -- See [Coercion axioms applied to coercions] in TyCoRep

\subsection{Coercion variables}
%*                                                                      *
%************************************************************************
-}

coVarName :: CoVar -> Name
coVarName :: CoVar -> Name
coVarName = CoVar -> Name
varName

setCoVarUnique :: CoVar -> Unique -> CoVar
setCoVarUnique :: CoVar -> Unique -> CoVar
setCoVarUnique = CoVar -> Unique -> CoVar
setVarUnique

setCoVarName :: CoVar -> Name -> CoVar
setCoVarName :: CoVar -> Name -> CoVar
setCoVarName   = CoVar -> Name -> CoVar
setVarName

{-
%************************************************************************
%*                                                                      *
                   Pretty-printing CoAxioms
%*                                                                      *
%************************************************************************

Defined here to avoid module loops. CoAxiom is loaded very early on.

-}

etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type)
-- Return the (tvs,lhs,rhs) after eta-expanding,
-- to the way in which the axiom was originally written
-- See Note [Eta reduction for data families] in CoAxiom
etaExpandCoAxBranch :: CoAxBranch -> ([CoVar], [Type], Type)
etaExpandCoAxBranch (CoAxBranch { cab_tvs :: CoAxBranch -> [CoVar]
cab_tvs = [CoVar]
tvs
                                , cab_eta_tvs :: CoAxBranch -> [CoVar]
cab_eta_tvs = [CoVar]
eta_tvs
                                , cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs
                                , cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs })
  -- ToDo: what about eta_cvs?
  = ([CoVar]
tvs [CoVar] -> [CoVar] -> [CoVar]
forall a. [a] -> [a] -> [a]
++ [CoVar]
eta_tvs, [Type]
lhs [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
eta_tys, Type -> [Type] -> Type
mkAppTys Type
rhs [Type]
eta_tys)
 where
    eta_tys :: [Type]
eta_tys = [CoVar] -> [Type]
mkTyVarTys [CoVar]
eta_tvs

pprCoAxiom :: CoAxiom br -> SDoc
-- Used in debug-printing only
pprCoAxiom :: CoAxiom br -> SDoc
pprCoAxiom ax :: CoAxiom br
ax@(CoAxiom { co_ax_tc :: forall (br :: BranchFlag). CoAxiom br -> TyCon
co_ax_tc = TyCon
tc, co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches = Branches br
branches })
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"axiom" SDoc -> SDoc -> SDoc
<+> CoAxiom br -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoAxiom br
ax SDoc -> SDoc -> SDoc
<+> SDoc
dcolon)
       Int
2 ([SDoc] -> SDoc
vcat ((CoAxBranch -> SDoc) -> [CoAxBranch] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (TyCon -> CoAxBranch -> SDoc
pprCoAxBranchUser TyCon
tc) (Branches br -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches Branches br
branches)))

pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc
-- Used when printing injectivity errors (FamInst.reportInjectivityErrors)
-- and inaccessible branches (TcValidity.inaccessibleCoAxBranch)
-- This happens in error messages: don't print the RHS of a data
--   family axiom, which is meaningless to a user
pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc
pprCoAxBranchUser TyCon
tc CoAxBranch
br
  | TyCon -> Bool
isDataFamilyTyCon TyCon
tc = TyCon -> CoAxBranch -> SDoc
pprCoAxBranchLHS TyCon
tc CoAxBranch
br
  | Bool
otherwise            = TyCon -> CoAxBranch -> SDoc
pprCoAxBranch    TyCon
tc CoAxBranch
br

pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc
-- Print the family-instance equation when reporting
--   a conflict between equations (FamInst.conflictInstErr)
-- For type families the RHS is important; for data families not so.
--   Indeed for data families the RHS is a mysterious internal
--   type constructor, so we suppress it (#14179)
-- See FamInstEnv Note [Family instance overlap conflicts]
pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc
pprCoAxBranchLHS = (TidyEnv -> Type -> SDoc) -> TyCon -> CoAxBranch -> SDoc
ppr_co_ax_branch TidyEnv -> Type -> SDoc
forall p p. p -> p -> SDoc
pp_rhs
  where
    pp_rhs :: p -> p -> SDoc
pp_rhs p
_ p
_ = SDoc
empty

pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc
pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc
pprCoAxBranch = (TidyEnv -> Type -> SDoc) -> TyCon -> CoAxBranch -> SDoc
ppr_co_ax_branch TidyEnv -> Type -> SDoc
ppr_rhs
  where
    ppr_rhs :: TidyEnv -> Type -> SDoc
ppr_rhs TidyEnv
env Type
rhs = SDoc
equals SDoc -> SDoc -> SDoc
<+> TidyEnv -> PprPrec -> Type -> SDoc
pprPrecTypeX TidyEnv
env PprPrec
topPrec Type
rhs

ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc)
                 -> TyCon -> CoAxBranch -> SDoc
ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) -> TyCon -> CoAxBranch -> SDoc
ppr_co_ax_branch TidyEnv -> Type -> SDoc
ppr_rhs TyCon
fam_tc CoAxBranch
branch
  = (SDoc -> SDoc -> SDoc) -> [SDoc] -> SDoc
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ((SDoc -> Int -> SDoc -> SDoc) -> Int -> SDoc -> SDoc -> SDoc
forall a b c. (a -> b -> c) -> b -> a -> c
flip SDoc -> Int -> SDoc -> SDoc
hangNotEmpty Int
2)
    [ [TyCoVarBinder] -> SDoc
pprUserForAll (ArgFlag -> [CoVar] -> [TyCoVarBinder]
mkTyCoVarBinders ArgFlag
Inferred [CoVar]
bndrs')
         -- See Note [Printing foralls in type family instances] in IfaceType
    , SDoc
pp_lhs SDoc -> SDoc -> SDoc
<+> TidyEnv -> Type -> SDoc
ppr_rhs TidyEnv
tidy_env Type
ee_rhs
    , String -> SDoc
text String
"-- Defined" SDoc -> SDoc -> SDoc
<+> SDoc
pp_loc ]
  where
    loc :: SrcSpan
loc = CoAxBranch -> SrcSpan
coAxBranchSpan CoAxBranch
branch
    pp_loc :: SDoc
pp_loc | SrcSpan -> Bool
isGoodSrcSpan SrcSpan
loc = String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
loc)
           | Bool
otherwise         = String -> SDoc
text String
"in" SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc

    -- Eta-expand LHS and RHS types, because sometimes data family
    -- instances are eta-reduced.
    -- See Note [Eta reduction for data families] in FamInstEnv.
    ([CoVar]
ee_tvs, [Type]
ee_lhs, Type
ee_rhs) = CoAxBranch -> ([CoVar], [Type], Type)
etaExpandCoAxBranch CoAxBranch
branch

    pp_lhs :: SDoc
pp_lhs = PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprIfaceTypeApp PprPrec
topPrec (TyCon -> IfaceTyCon
toIfaceTyCon TyCon
fam_tc)
                             (TidyEnv -> TyCon -> [Type] -> IfaceAppArgs
tidyToIfaceTcArgs TidyEnv
tidy_env TyCon
fam_tc [Type]
ee_lhs)

    (TidyEnv
tidy_env, [CoVar]
bndrs') = TidyEnv -> [CoVar] -> (TidyEnv, [CoVar])
tidyCoAxBndrsForUser TidyEnv
emptyTidyEnv [CoVar]
ee_tvs

tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var])
-- Tidy wildcards "_1", "_2" to "_", and do not return them
-- in the list of binders to be printed
-- This is so that in error messages we see
--     forall a. F _ [a] _ = ...
-- rather than
--     forall a _1 _2. F _1 [a] _2 = ...
--
-- This is a rather disgusting function
tidyCoAxBndrsForUser :: TidyEnv -> [CoVar] -> (TidyEnv, [CoVar])
tidyCoAxBndrsForUser TidyEnv
init_env [CoVar]
tcvs
  = (TidyEnv
tidy_env, [CoVar] -> [CoVar]
forall a. [a] -> [a]
reverse [CoVar]
tidy_bndrs)
  where
    (TidyEnv
tidy_env, [CoVar]
tidy_bndrs) = ((TidyEnv, [CoVar]) -> CoVar -> (TidyEnv, [CoVar]))
-> (TidyEnv, [CoVar]) -> [CoVar] -> (TidyEnv, [CoVar])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (TidyEnv, [CoVar]) -> CoVar -> (TidyEnv, [CoVar])
tidy_one (TidyEnv
init_env, []) [CoVar]
tcvs

    tidy_one :: (TidyEnv, [CoVar]) -> CoVar -> (TidyEnv, [CoVar])
tidy_one (env :: TidyEnv
env@(TidyOccEnv
occ_env, VarEnv CoVar
subst), [CoVar]
rev_bndrs') CoVar
bndr
      | CoVar -> Bool
is_wildcard CoVar
bndr = (TidyEnv
env_wild, [CoVar]
rev_bndrs')
      | Bool
otherwise        = (TidyEnv
env',     CoVar
bndr' CoVar -> [CoVar] -> [CoVar]
forall a. a -> [a] -> [a]
: [CoVar]
rev_bndrs')
      where
        (TidyEnv
env', CoVar
bndr') = TidyEnv -> CoVar -> (TidyEnv, CoVar)
tidyVarBndr TidyEnv
env CoVar
bndr
        env_wild :: TidyEnv
env_wild = (TidyOccEnv
occ_env, VarEnv CoVar -> CoVar -> CoVar -> VarEnv CoVar
forall a. VarEnv a -> CoVar -> a -> VarEnv a
extendVarEnv VarEnv CoVar
subst CoVar
bndr CoVar
wild_bndr)
        wild_bndr :: CoVar
wild_bndr = CoVar -> Name -> CoVar
setVarName CoVar
bndr (Name -> CoVar) -> Name -> CoVar
forall a b. (a -> b) -> a -> b
$
                    Name -> OccName -> Name
tidyNameOcc (CoVar -> Name
varName CoVar
bndr) (String -> OccName
mkTyVarOcc String
"_")
                    -- Tidy the binder to "_"

    is_wildcard :: Var -> Bool
    is_wildcard :: CoVar -> Bool
is_wildcard CoVar
tv = case OccName -> String
occNameString (CoVar -> OccName
forall a. NamedThing a => a -> OccName
getOccName CoVar
tv) of
                       (Char
'_' : String
rest) -> (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
rest
                       String
_            -> Bool
False

{-
%************************************************************************
%*                                                                      *
        Destructing coercions
%*                                                                      *
%************************************************************************

Note [Function coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~
Remember that
  (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep

Hence
  FunCo r co1 co2 :: (s1->t1) ~r (s2->t2)
is short for
  TyConAppCo (->) co_rep1 co_rep2 co1 co2
where co_rep1, co_rep2 are the coercions on the representations.
-}


-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into
-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:
--
-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]
decomposeCo :: Arity -> Coercion
            -> [Role]  -- the roles of the output coercions
                       -- this must have at least as many
                       -- entries as the Arity provided
            -> [Coercion]
decomposeCo :: Int -> Coercion -> [Role] -> [Coercion]
decomposeCo Int
arity Coercion
co [Role]
rs
  = [HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
r Int
n Coercion
co | (Int
n,Role
r) <- [Int
0..(Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] [Int] -> [Role] -> [(Int, Role)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Role]
rs ]
           -- Remember, Nth is zero-indexed

decomposeFunCo :: HasDebugCallStack
               => Role      -- Role of the input coercion
               -> Coercion  -- Input coercion
               -> (Coercion, Coercion)
-- Expects co :: (s1 -> t1) ~ (s2 -> t2)
-- Returns (co1 :: s1~s2, co2 :: t1~t2)
-- See Note [Function coercions] for the "2" and "3"
decomposeFunCo :: Role -> Coercion -> (Coercion, Coercion)
decomposeFunCo Role
r Coercion
co = ASSERT2( all_ok, ppr co )
                      (HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
r Int
2 Coercion
co, HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
r Int
3 Coercion
co)
  where
    Pair Type
s1t1 Type
s2t2 = Coercion -> Pair Type
coercionKind Coercion
co
    all_ok :: Bool
all_ok = Type -> Bool
isFunTy Type
s1t1 Bool -> Bool -> Bool
&& Type -> Bool
isFunTy Type
s2t2

{- Note [Pushing a coercion into a pi-type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have this:
    (f |> co) t1 .. tn
Then we want to push the coercion into the arguments, so as to make
progress. For example of why you might want to do so, see Note
[Respecting definitional equality] in TyCoRep.

This is done by decomposePiCos.  Specifically, if
    decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor)
then
    (f |> co) t1 .. tn   =   (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn

Notes:

* k can be smaller than n! That is decomposePiCos can return *fewer*
  coercions than there are arguments (ie k < n), if the kind provided
  doesn't have enough binders.

* If there is a type error, we might see
       (f |> co) t1
  where co :: (forall a. ty) ~ (ty1 -> ty2)
  Here 'co' is insoluble, but we don't want to crash in decoposePiCos.
  So decomposePiCos carefully tests both sides of the coercion to check
  they are both foralls or both arrows.  Not doing this caused #15343.
-}

decomposePiCos :: HasDebugCallStack
               => CoercionN -> Pair Type  -- Coercion and its kind
               -> [Type]
               -> ([CoercionN], CoercionN)
-- See Note [Pushing a coercion into a pi-type]
decomposePiCos :: Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion)
decomposePiCos Coercion
orig_co (Pair Type
orig_k1 Type
orig_k2) [Type]
orig_args
  = [Coercion]
-> (TCvSubst, Type)
-> Coercion
-> (TCvSubst, Type)
-> [Type]
-> ([Coercion], Coercion)
go [] (TCvSubst
orig_subst,Type
orig_k1) Coercion
orig_co (TCvSubst
orig_subst,Type
orig_k2) [Type]
orig_args
  where
    orig_subst :: TCvSubst
orig_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (InScopeSet -> TCvSubst) -> InScopeSet -> TCvSubst
forall a b. (a -> b) -> a -> b
$ VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$
                 [Type] -> VarSet
tyCoVarsOfTypes [Type]
orig_args VarSet -> VarSet -> VarSet
`unionVarSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
orig_co

    go :: [CoercionN]      -- accumulator for argument coercions, reversed
       -> (TCvSubst,Kind)  -- Lhs kind of coercion
       -> CoercionN        -- coercion originally applied to the function
       -> (TCvSubst,Kind)  -- Rhs kind of coercion
       -> [Type]           -- Arguments to that function
       -> ([CoercionN], Coercion)
    -- Invariant:  co :: subst1(k2) ~ subst2(k2)

    go :: [Coercion]
-> (TCvSubst, Type)
-> Coercion
-> (TCvSubst, Type)
-> [Type]
-> ([Coercion], Coercion)
go [Coercion]
acc_arg_cos (TCvSubst
subst1,Type
k1) Coercion
co (TCvSubst
subst2,Type
k2) (Type
ty:[Type]
tys)
      | Just (CoVar
a, Type
t1) <- Type -> Maybe (CoVar, Type)
splitForAllTy_maybe Type
k1
      , Just (CoVar
b, Type
t2) <- Type -> Maybe (CoVar, Type)
splitForAllTy_maybe Type
k2
        -- know     co :: (forall a:s1.t1) ~ (forall b:s2.t2)
        --    function :: forall a:s1.t1   (the function is not passed to decomposePiCos)
        --           a :: s1
        --           b :: s2
        --          ty :: s2
        -- need arg_co :: s2 ~ s1
        --      res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]
      = let arg_co :: Coercion
arg_co  = HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
Nominal Int
0 (Coercion -> Coercion
mkSymCo Coercion
co)
            res_co :: Coercion
res_co  = Coercion -> Coercion -> Coercion
mkInstCo Coercion
co (Role -> Type -> Coercion -> Coercion
mkGReflLeftCo Role
Nominal Type
ty Coercion
arg_co)
            subst1' :: TCvSubst
subst1' = TCvSubst -> CoVar -> Type -> TCvSubst
extendTCvSubst TCvSubst
subst1 CoVar
a (Type
ty Type -> Coercion -> Type
`CastTy` Coercion
arg_co)
            subst2' :: TCvSubst
subst2' = TCvSubst -> CoVar -> Type -> TCvSubst
extendTCvSubst TCvSubst
subst2 CoVar
b Type
ty
        in
        [Coercion]
-> (TCvSubst, Type)
-> Coercion
-> (TCvSubst, Type)
-> [Type]
-> ([Coercion], Coercion)
go (Coercion
arg_co Coercion -> [Coercion] -> [Coercion]
forall a. a -> [a] -> [a]
: [Coercion]
acc_arg_cos) (TCvSubst
subst1', Type
t1) Coercion
res_co (TCvSubst
subst2', Type
t2) [Type]
tys

      | Just (Type
_s1, Type
t1) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
k1
      , Just (Type
_s2, Type
t2) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
k2
        -- know     co :: (s1 -> t1) ~ (s2 -> t2)
        --    function :: s1 -> t1
        --          ty :: s2
        -- need arg_co :: s2 ~ s1
        --      res_co :: t1 ~ t2
      = let (Coercion
sym_arg_co, Coercion
res_co) = HasDebugCallStack => Role -> Coercion -> (Coercion, Coercion)
Role -> Coercion -> (Coercion, Coercion)
decomposeFunCo Role
Nominal Coercion
co
            arg_co :: Coercion
arg_co               = Coercion -> Coercion
mkSymCo Coercion
sym_arg_co
        in
        [Coercion]
-> (TCvSubst, Type)
-> Coercion
-> (TCvSubst, Type)
-> [Type]
-> ([Coercion], Coercion)
go (Coercion
arg_co Coercion -> [Coercion] -> [Coercion]
forall a. a -> [a] -> [a]
: [Coercion]
acc_arg_cos) (TCvSubst
subst1,Type
t1) Coercion
res_co (TCvSubst
subst2,Type
t2) [Type]
tys

      | Bool -> Bool
not (TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst1) Bool -> Bool -> Bool
|| Bool -> Bool
not (TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst2)
      = [Coercion]
-> (TCvSubst, Type)
-> Coercion
-> (TCvSubst, Type)
-> [Type]
-> ([Coercion], Coercion)
go [Coercion]
acc_arg_cos (TCvSubst -> TCvSubst
zapTCvSubst TCvSubst
subst1, HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst1 Type
k1)
                       Coercion
co
                       (TCvSubst -> TCvSubst
zapTCvSubst TCvSubst
subst2, HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst1 Type
k2)
                       (Type
tyType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
tys)

      -- tys might not be empty, if the left-hand type of the original coercion
      -- didn't have enough binders
    go [Coercion]
acc_arg_cos (TCvSubst, Type)
_ki1 Coercion
co (TCvSubst, Type)
_ki2 [Type]
_tys = ([Coercion] -> [Coercion]
forall a. [a] -> [a]
reverse [Coercion]
acc_arg_cos, Coercion
co)

-- | Attempts to obtain the type variable underlying a 'Coercion'
getCoVar_maybe :: Coercion -> Maybe CoVar
getCoVar_maybe :: Coercion -> Maybe CoVar
getCoVar_maybe (CoVarCo CoVar
cv) = CoVar -> Maybe CoVar
forall a. a -> Maybe a
Just CoVar
cv
getCoVar_maybe Coercion
_            = Maybe CoVar
forall a. Maybe a
Nothing

-- | Attempts to tease a coercion apart into a type constructor and the application
-- of a number of coercion arguments to that constructor
splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])
splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])
splitTyConAppCo_maybe Coercion
co
  | Just (Type
ty, Role
r) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
  = do { (TyCon
tc, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
       ; let args :: [Coercion]
args = (Role -> Type -> Coercion) -> [Role] -> [Type] -> [Coercion]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Role -> Type -> Coercion
mkReflCo (Role -> TyCon -> [Role]
tyConRolesX Role
r TyCon
tc) [Type]
tys
       ; (TyCon, [Coercion]) -> Maybe (TyCon, [Coercion])
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, [Coercion]
args) }
splitTyConAppCo_maybe (TyConAppCo Role
_ TyCon
tc [Coercion]
cos) = (TyCon, [Coercion]) -> Maybe (TyCon, [Coercion])
forall a. a -> Maybe a
Just (TyCon
tc, [Coercion]
cos)
splitTyConAppCo_maybe (FunCo Role
_ Coercion
arg Coercion
res)     = (TyCon, [Coercion]) -> Maybe (TyCon, [Coercion])
forall a. a -> Maybe a
Just (TyCon
funTyCon, [Coercion]
cos)
  where cos :: [Coercion]
cos = [HasDebugCallStack => Coercion -> Coercion
Coercion -> Coercion
mkRuntimeRepCo Coercion
arg, HasDebugCallStack => Coercion -> Coercion
Coercion -> Coercion
mkRuntimeRepCo Coercion
res, Coercion
arg, Coercion
res]
splitTyConAppCo_maybe Coercion
_                     = Maybe (TyCon, [Coercion])
forall a. Maybe a
Nothing

-- first result has role equal to input; third result is Nominal
splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
-- ^ Attempt to take a coercion application apart.
splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
splitAppCo_maybe (AppCo Coercion
co Coercion
arg) = (Coercion, Coercion) -> Maybe (Coercion, Coercion)
forall a. a -> Maybe a
Just (Coercion
co, Coercion
arg)
splitAppCo_maybe (TyConAppCo Role
r TyCon
tc [Coercion]
args)
  | [Coercion]
args [Coercion] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` TyCon -> Int
tyConArity TyCon
tc
  , Just ([Coercion]
args', Coercion
arg') <- [Coercion] -> Maybe ([Coercion], Coercion)
forall a. [a] -> Maybe ([a], a)
snocView [Coercion]
args
  = (Coercion, Coercion) -> Maybe (Coercion, Coercion)
forall a. a -> Maybe a
Just ( HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
r TyCon
tc [Coercion]
args', Coercion
arg' )

  | Bool -> Bool
not (TyCon -> Bool
mustBeSaturated TyCon
tc)
    -- Never create unsaturated type family apps!
  , Just ([Coercion]
args', Coercion
arg') <- [Coercion] -> Maybe ([Coercion], Coercion)
forall a. [a] -> Maybe ([a], a)
snocView [Coercion]
args
  , Just Coercion
arg'' <- Role -> Coercion -> Maybe Coercion
setNominalRole_maybe (Role -> TyCon -> Int -> Role
nthRole Role
r TyCon
tc ([Coercion] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Coercion]
args')) Coercion
arg'
  = (Coercion, Coercion) -> Maybe (Coercion, Coercion)
forall a. a -> Maybe a
Just ( HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
r TyCon
tc [Coercion]
args', Coercion
arg'' )
       -- Use mkTyConAppCo to preserve the invariant
       --  that identity coercions are always represented by Refl

splitAppCo_maybe Coercion
co
  | Just (Type
ty, Role
r) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
  , Just (Type
ty1, Type
ty2) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ty
  = (Coercion, Coercion) -> Maybe (Coercion, Coercion)
forall a. a -> Maybe a
Just (Role -> Type -> Coercion
mkReflCo Role
r Type
ty1, Type -> Coercion
mkNomReflCo Type
ty2)
splitAppCo_maybe Coercion
_ = Maybe (Coercion, Coercion)
forall a. Maybe a
Nothing

splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
splitFunCo_maybe (FunCo Role
_ Coercion
arg Coercion
res) = (Coercion, Coercion) -> Maybe (Coercion, Coercion)
forall a. a -> Maybe a
Just (Coercion
arg, Coercion
res)
splitFunCo_maybe Coercion
_ = Maybe (Coercion, Coercion)
forall a. Maybe a
Nothing

splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion)
splitForAllCo_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)
splitForAllCo_maybe (ForAllCo CoVar
tv Coercion
k_co Coercion
co) = (CoVar, Coercion, Coercion) -> Maybe (CoVar, Coercion, Coercion)
forall a. a -> Maybe a
Just (CoVar
tv, Coercion
k_co, Coercion
co)
splitForAllCo_maybe Coercion
_                     = Maybe (CoVar, Coercion, Coercion)
forall a. Maybe a
Nothing

-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder
splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)
splitForAllCo_ty_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)
splitForAllCo_ty_maybe (ForAllCo CoVar
tv Coercion
k_co Coercion
co)
  | CoVar -> Bool
isTyVar CoVar
tv = (CoVar, Coercion, Coercion) -> Maybe (CoVar, Coercion, Coercion)
forall a. a -> Maybe a
Just (CoVar
tv, Coercion
k_co, Coercion
co)
splitForAllCo_ty_maybe Coercion
_ = Maybe (CoVar, Coercion, Coercion)
forall a. Maybe a
Nothing

-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder
splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)
splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)
splitForAllCo_co_maybe (ForAllCo CoVar
cv Coercion
k_co Coercion
co)
  | CoVar -> Bool
isCoVar CoVar
cv = (CoVar, Coercion, Coercion) -> Maybe (CoVar, Coercion, Coercion)
forall a. a -> Maybe a
Just (CoVar
cv, Coercion
k_co, Coercion
co)
splitForAllCo_co_maybe Coercion
_ = Maybe (CoVar, Coercion, Coercion)
forall a. Maybe a
Nothing

-------------------------------------------------------
-- and some coercion kind stuff

coVarTypes :: HasDebugCallStack => CoVar -> Pair Type
coVarTypes :: CoVar -> Pair Type
coVarTypes CoVar
cv
  | (Type
_, Type
_, Type
ty1, Type
ty2, Role
_) <- HasDebugCallStack => CoVar -> (Type, Type, Type, Type, Role)
CoVar -> (Type, Type, Type, Type, Role)
coVarKindsTypesRole CoVar
cv
  = Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair Type
ty1 Type
ty2

coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role)
coVarKindsTypesRole :: CoVar -> (Type, Type, Type, Type, Role)
coVarKindsTypesRole CoVar
cv
 | Just (TyCon
tc, [Type
k1,Type
k2,Type
ty1,Type
ty2]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe (CoVar -> Type
varType CoVar
cv)
 = let role :: Role
role
         | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqPrimTyConKey     = Role
Nominal
         | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqReprPrimTyConKey = Role
Representational
         | Bool
otherwise                      = String -> Role
forall a. String -> a
panic String
"coVarKindsTypesRole"
   in (Type
k1,Type
k2,Type
ty1,Type
ty2,Role
role)
 | Bool
otherwise = String -> SDoc -> (Type, Type, Type, Type, Role)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coVarKindsTypesRole, non coercion variable"
                        (CoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoVar
cv SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoVar -> Type
varType CoVar
cv))

coVarKind :: CoVar -> Type
coVarKind :: CoVar -> Type
coVarKind CoVar
cv
  = ASSERT( isCoVar cv )
    CoVar -> Type
varType CoVar
cv

coVarRole :: CoVar -> Role
coVarRole :: CoVar -> Role
coVarRole CoVar
cv
  | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqPrimTyConKey
  = Role
Nominal
  | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqReprPrimTyConKey
  = Role
Representational
  | Bool
otherwise
  = String -> SDoc -> Role
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coVarRole: unknown tycon" (CoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoVar
cv SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoVar -> Type
varType CoVar
cv))

  where
    tc :: TyCon
tc = case Type -> Maybe TyCon
tyConAppTyCon_maybe (CoVar -> Type
varType CoVar
cv) of
           Just TyCon
tc0 -> TyCon
tc0
           Maybe TyCon
Nothing  -> String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coVarRole: not tyconapp" (CoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoVar
cv)

-- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@,
-- produce a coercion @rep_co :: r1 ~ r2@.
mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion
mkRuntimeRepCo :: Coercion -> Coercion
mkRuntimeRepCo Coercion
co
  = HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
Nominal Int
0 Coercion
kind_co
  where
    kind_co :: Coercion
kind_co = Coercion -> Coercion
mkKindCo Coercion
co  -- kind_co :: TYPE r1 ~ TYPE r2
                           -- (up to silliness with Constraint)

isReflCoVar_maybe :: Var -> Maybe Coercion
-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)
-- Works on all kinds of Vars, not just CoVars
isReflCoVar_maybe :: CoVar -> Maybe Coercion
isReflCoVar_maybe CoVar
cv
  | CoVar -> Bool
isCoVar CoVar
cv
  , Pair Type
ty1 Type
ty2 <- HasDebugCallStack => CoVar -> Pair Type
CoVar -> Pair Type
coVarTypes CoVar
cv
  , Type
ty1 Type -> Type -> Bool
`eqType` Type
ty2
  = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just (Role -> Type -> Coercion
mkReflCo (CoVar -> Role
coVarRole CoVar
cv) Type
ty1)
  | Bool
otherwise
  = Maybe Coercion
forall a. Maybe a
Nothing

-- | Tests if this coercion is obviously a generalized reflexive coercion.
-- Guaranteed to work very quickly.
isGReflCo :: Coercion -> Bool
isGReflCo :: Coercion -> Bool
isGReflCo (GRefl{}) = Bool
True
isGReflCo (Refl{})  = Bool
True -- Refl ty == GRefl N ty MRefl
isGReflCo Coercion
_         = Bool
False

-- | Tests if this MCoercion is obviously generalized reflexive
-- Guaranteed to work very quickly.
isGReflMCo :: MCoercion -> Bool
isGReflMCo :: MCoercion -> Bool
isGReflMCo MCoercion
MRefl = Bool
True
isGReflMCo (MCo Coercion
co) | Coercion -> Bool
isGReflCo Coercion
co = Bool
True
isGReflMCo MCoercion
_ = Bool
False

-- | Tests if this coercion is obviously reflexive. Guaranteed to work
-- very quickly. Sometimes a coercion can be reflexive, but not obviously
-- so. c.f. 'isReflexiveCo'
isReflCo :: Coercion -> Bool
isReflCo :: Coercion -> Bool
isReflCo (Refl{}) = Bool
True
isReflCo (GRefl Role
_ Type
_ MCoercion
mco) | MCoercion -> Bool
isGReflMCo MCoercion
mco = Bool
True
isReflCo Coercion
_ = Bool
False

-- | Returns the type coerced if this coercion is a generalized reflexive
-- coercion. Guaranteed to work very quickly.
isGReflCo_maybe :: Coercion -> Maybe (Type, Role)
isGReflCo_maybe :: Coercion -> Maybe (Type, Role)
isGReflCo_maybe (GRefl Role
r Type
ty MCoercion
_) = (Type, Role) -> Maybe (Type, Role)
forall a. a -> Maybe a
Just (Type
ty, Role
r)
isGReflCo_maybe (Refl Type
ty)      = (Type, Role) -> Maybe (Type, Role)
forall a. a -> Maybe a
Just (Type
ty, Role
Nominal)
isGReflCo_maybe Coercion
_ = Maybe (Type, Role)
forall a. Maybe a
Nothing

-- | Returns the type coerced if this coercion is reflexive. Guaranteed
-- to work very quickly. Sometimes a coercion can be reflexive, but not
-- obviously so. c.f. 'isReflexiveCo_maybe'
isReflCo_maybe :: Coercion -> Maybe (Type, Role)
isReflCo_maybe :: Coercion -> Maybe (Type, Role)
isReflCo_maybe (Refl Type
ty) = (Type, Role) -> Maybe (Type, Role)
forall a. a -> Maybe a
Just (Type
ty, Role
Nominal)
isReflCo_maybe (GRefl Role
r Type
ty MCoercion
mco) | MCoercion -> Bool
isGReflMCo MCoercion
mco = (Type, Role) -> Maybe (Type, Role)
forall a. a -> Maybe a
Just (Type
ty, Role
r)
isReflCo_maybe Coercion
_ = Maybe (Type, Role)
forall a. Maybe a
Nothing

-- | Slowly checks if the coercion is reflexive. Don't call this in a loop,
-- as it walks over the entire coercion.
isReflexiveCo :: Coercion -> Bool
isReflexiveCo :: Coercion -> Bool
isReflexiveCo = Maybe (Type, Role) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Type, Role) -> Bool)
-> (Coercion -> Maybe (Type, Role)) -> Coercion -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coercion -> Maybe (Type, Role)
isReflexiveCo_maybe

-- | Extracts the coerced type from a reflexive coercion. This potentially
-- walks over the entire coercion, so avoid doing this in a loop.
isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)
isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)
isReflexiveCo_maybe (Refl Type
ty) = (Type, Role) -> Maybe (Type, Role)
forall a. a -> Maybe a
Just (Type
ty, Role
Nominal)
isReflexiveCo_maybe (GRefl Role
r Type
ty MCoercion
mco) | MCoercion -> Bool
isGReflMCo MCoercion
mco = (Type, Role) -> Maybe (Type, Role)
forall a. a -> Maybe a
Just (Type
ty, Role
r)
isReflexiveCo_maybe Coercion
co
  | Type
ty1 Type -> Type -> Bool
`eqType` Type
ty2
  = (Type, Role) -> Maybe (Type, Role)
forall a. a -> Maybe a
Just (Type
ty1, Role
r)
  | Bool
otherwise
  = Maybe (Type, Role)
forall a. Maybe a
Nothing
  where (Pair Type
ty1 Type
ty2, Role
r) = Coercion -> (Pair Type, Role)
coercionKindRole Coercion
co

coToMCo :: Coercion -> MCoercion
coToMCo :: Coercion -> MCoercion
coToMCo Coercion
c = if Coercion -> Bool
isReflCo Coercion
c
  then MCoercion
MRefl
  else Coercion -> MCoercion
MCo Coercion
c

{-
%************************************************************************
%*                                                                      *
            Building coercions
%*                                                                      *
%************************************************************************

These "smart constructors" maintain the invariants listed in the definition
of Coercion, and they perform very basic optimizations.

Note [Role twiddling functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

There are a plethora of functions for twiddling roles:

mkSubCo: Requires a nominal input coercion and always produces a
representational output. This is used when you (the programmer) are sure you
know exactly that role you have and what you want.

downgradeRole_maybe: This function takes both the input role and the output role
as parameters. (The *output* role comes first!) It can only *downgrade* a
role -- that is, change it from N to R or P, or from R to P. This one-way
behavior is why there is the "_maybe". If an upgrade is requested, this
function produces Nothing. This is used when you need to change the role of a
coercion, but you're not sure (as you're writing the code) of which roles are
involved.

This function could have been written using coercionRole to ascertain the role
of the input. But, that function is recursive, and the caller of downgradeRole_maybe
often knows the input role. So, this is more efficient.

downgradeRole: This is just like downgradeRole_maybe, but it panics if the
conversion isn't a downgrade.

setNominalRole_maybe: This is the only function that can *upgrade* a coercion.
The result (if it exists) is always Nominal. The input can be at any role. It
works on a "best effort" basis, as it should never be strictly necessary to
upgrade a coercion during compilation. It is currently only used within GHC in
splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second
coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable
that splitAppCo_maybe is operating over a TyConAppCo that uses a
representational coercion. Hence the need for setNominalRole_maybe.
splitAppCo_maybe, in turn, is used only within coercion optimization -- thus,
it is not absolutely critical that setNominalRole_maybe be complete.

Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom
UnivCos are perfectly type-safe, whereas representational and nominal ones are
not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo.
(Nominal ones are no worse than representational ones, so this function *will*
change a UnivCo Representational to a UnivCo Nominal.)

Conal Elliott also came across a need for this function while working with the
GHC API, as he was decomposing Core casts. The Core casts use representational
coercions, as they must, but his use case required nominal coercions (he was
building a GADT). So, that's why this function is exported from this module.

One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as
appropriate? I (Richard E.) have decided not to do this, because upgrading a
role is bizarre and a caller should have to ask for this behavior explicitly.

-}

-- | Make a generalized reflexive coercion
mkGReflCo :: Role -> Type -> MCoercionN -> Coercion
mkGReflCo :: Role -> Type -> MCoercion -> Coercion
mkGReflCo Role
r Type
ty MCoercion
mco
  | MCoercion -> Bool
isGReflMCo MCoercion
mco = if Role
r Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal then Type -> Coercion
Refl Type
ty
                     else Role -> Type -> MCoercion -> Coercion
GRefl Role
r Type
ty MCoercion
MRefl
  | Bool
otherwise    = Role -> Type -> MCoercion -> Coercion
GRefl Role
r Type
ty MCoercion
mco

-- | Make a reflexive coercion
mkReflCo :: Role -> Type -> Coercion
mkReflCo :: Role -> Type -> Coercion
mkReflCo Role
Nominal Type
ty = Type -> Coercion
Refl Type
ty
mkReflCo Role
r       Type
ty = Role -> Type -> MCoercion -> Coercion
GRefl Role
r Type
ty MCoercion
MRefl

-- | Make a representational reflexive coercion
mkRepReflCo :: Type -> Coercion
mkRepReflCo :: Type -> Coercion
mkRepReflCo Type
ty = Role -> Type -> MCoercion -> Coercion
GRefl Role
Representational Type
ty MCoercion
MRefl

-- | Make a nominal reflexive coercion
mkNomReflCo :: Type -> Coercion
mkNomReflCo :: Type -> Coercion
mkNomReflCo = Type -> Coercion
Refl

-- | Apply a type constructor to a list of coercions. It is the
-- caller's responsibility to get the roles correct on argument coercions.
mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo :: Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
r TyCon
tc [Coercion]
cos
  | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funTyConKey
  , [Coercion
_rep1, Coercion
_rep2, Coercion
co1, Coercion
co2] <- [Coercion]
cos   -- See Note [Function coercions]
  = -- (a :: TYPE ra) -> (b :: TYPE rb)  ~  (c :: TYPE rc) -> (d :: TYPE rd)
    -- rep1 :: ra  ~  rc        rep2 :: rb  ~  rd
    -- co1  :: a   ~  c         co2  :: b   ~  d
    Role -> Coercion -> Coercion -> Coercion
mkFunCo Role
r Coercion
co1 Coercion
co2

               -- Expand type synonyms
  | Just ([(CoVar, Coercion)]
tv_co_prs, Type
rhs_ty, [Coercion]
leftover_cos) <- TyCon
-> [Coercion] -> Maybe ([(CoVar, Coercion)], Type, [Coercion])
forall tyco.
TyCon -> [tyco] -> Maybe ([(CoVar, tyco)], Type, [tyco])
expandSynTyCon_maybe TyCon
tc [Coercion]
cos
  = Coercion -> [Coercion] -> Coercion
mkAppCos (HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
Role -> LiftingContext -> Type -> Coercion
liftCoSubst Role
r ([(CoVar, Coercion)] -> LiftingContext
mkLiftingContext [(CoVar, Coercion)]
tv_co_prs) Type
rhs_ty) [Coercion]
leftover_cos

  | Just [(Type, Role)]
tys_roles <- (Coercion -> Maybe (Type, Role))
-> [Coercion] -> Maybe [(Type, Role)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Coercion -> Maybe (Type, Role)
isReflCo_maybe [Coercion]
cos
  = Role -> Type -> Coercion
mkReflCo Role
r (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc (((Type, Role) -> Type) -> [(Type, Role)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Role) -> Type
forall a b. (a, b) -> a
fst [(Type, Role)]
tys_roles))
  -- See Note [Refl invariant]

  | Bool
otherwise = Role -> TyCon -> [Coercion] -> Coercion
TyConAppCo Role
r TyCon
tc [Coercion]
cos

-- | Build a function 'Coercion' from two other 'Coercion's. That is,
-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@.
mkFunCo :: Role -> Coercion -> Coercion -> Coercion
mkFunCo :: Role -> Coercion -> Coercion -> Coercion
mkFunCo Role
r Coercion
co1 Coercion
co2
    -- See Note [Refl invariant]
  | Just (Type
ty1, Role
_) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co1
  , Just (Type
ty2, Role
_) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co2
  = Role -> Type -> Coercion
mkReflCo Role
r (Type -> Type -> Type
mkVisFunTy Type
ty1 Type
ty2)
  | Bool
otherwise = Role -> Coercion -> Coercion -> Coercion
FunCo Role
r Coercion
co1 Coercion
co2

-- | Apply a 'Coercion' to another 'Coercion'.
-- The second coercion must be Nominal, unless the first is Phantom.
-- If the first is Phantom, then the second can be either Phantom or Nominal.
mkAppCo :: Coercion     -- ^ :: t1 ~r t2
        -> Coercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2
        -> Coercion     -- ^ :: t1 s1 ~r t2 s2
mkAppCo :: Coercion -> Coercion -> Coercion
mkAppCo Coercion
co Coercion
arg
  | Just (Type
ty1, Role
r) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
  , Just (Type
ty2, Role
_) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
arg
  = Role -> Type -> Coercion
mkReflCo Role
r (Type -> Type -> Type
mkAppTy Type
ty1 Type
ty2)

  | Just (Type
ty1, Role
r) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
  , Just (TyCon
tc, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty1
    -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)
  = HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
r TyCon
tc ([Role] -> [Type] -> [Coercion]
zip_roles (Role -> TyCon -> [Role]
tyConRolesX Role
r TyCon
tc) [Type]
tys)
  where
    zip_roles :: [Role] -> [Type] -> [Coercion]
zip_roles (Role
r1:[Role]
_)  []            = [Role -> Role -> Coercion -> Coercion
downgradeRole Role
r1 Role
Nominal Coercion
arg]
    zip_roles (Role
r1:[Role]
rs) (Type
ty1:[Type]
tys)     = Role -> Type -> Coercion
mkReflCo Role
r1 Type
ty1 Coercion -> [Coercion] -> [Coercion]
forall a. a -> [a] -> [a]
: [Role] -> [Type] -> [Coercion]
zip_roles [Role]
rs [Type]
tys
    zip_roles [Role]
_       [Type]
_             = String -> [Coercion]
forall a. String -> a
panic String
"zip_roles" -- but the roles are infinite...

mkAppCo (TyConAppCo Role
r TyCon
tc [Coercion]
args) Coercion
arg
  = case Role
r of
      Role
Nominal          -> HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
Nominal TyCon
tc ([Coercion]
args [Coercion] -> [Coercion] -> [Coercion]
forall a. [a] -> [a] -> [a]
++ [Coercion
arg])
      Role
Representational -> HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
Representational TyCon
tc ([Coercion]
args [Coercion] -> [Coercion] -> [Coercion]
forall a. [a] -> [a] -> [a]
++ [Coercion
arg'])
        where new_role :: Role
new_role = (TyCon -> [Role]
tyConRolesRepresentational TyCon
tc) [Role] -> Int -> Role
forall a. [a] -> Int -> a
!! ([Coercion] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Coercion]
args)
              arg' :: Coercion
arg'     = Role -> Role -> Coercion -> Coercion
downgradeRole Role
new_role Role
Nominal Coercion
arg
      Role
Phantom          -> HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
Phantom TyCon
tc ([Coercion]
args [Coercion] -> [Coercion] -> [Coercion]
forall a. [a] -> [a] -> [a]
++ [Coercion -> Coercion
toPhantomCo Coercion
arg])
mkAppCo Coercion
co Coercion
arg = Coercion -> Coercion -> Coercion
AppCo Coercion
co  Coercion
arg
-- Note, mkAppCo is careful to maintain invariants regarding
-- where Refl constructors appear; see the comments in the definition
-- of Coercion and the Note [Refl invariant] in TyCoRep.

-- | Applies multiple 'Coercion's to another 'Coercion', from left to right.
-- See also 'mkAppCo'.
mkAppCos :: Coercion
         -> [Coercion]
         -> Coercion
mkAppCos :: Coercion -> [Coercion] -> Coercion
mkAppCos Coercion
co1 [Coercion]
cos = (Coercion -> Coercion -> Coercion)
-> Coercion -> [Coercion] -> Coercion
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Coercion -> Coercion -> Coercion
mkAppCo Coercion
co1 [Coercion]
cos

{- Note [Unused coercion variable in ForAllCo]

See Note [Unused coercion variable in ForAllTy] in TyCoRep for the motivation for
checking coercion variable in types.
To lift the design choice to (ForAllCo cv kind_co body_co), we have two options:

(1) In mkForAllCo, we check whether cv is a coercion variable
    and whether it is not used in body_co. If so we construct a FunCo.
(2) We don't do this check in mkForAllCo.
    In coercionKind, we use mkTyCoForAllTy to perform the check and construct
    a FunTy when necessary.

We chose (2) for two reasons:

* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not
  make a difference.
* even if cv occurs in body_co, it is possible that cv does not occur in the kind
  of body_co. Therefore the check in coercionKind is inevitable.

The last wrinkle is that there are restrictions around the use of the cv in the
coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that
we cannot prove that the type system is consistent with unrestricted use of this
cv; the consistency proof uses an untyped rewrite relation that works over types
with all coercions and casts removed. So, we can allow the cv to appear only in
positions that are erased. As an approximation of this (and keeping close to the
published theory), we currently allow the cv only within the type in a Refl node
and under a GRefl node (including in the Coercion stored in a GRefl). It's
possible other places are OK, too, but this is a safe approximation.

Sadly, with heterogeneous equality, this restriction might be able to be violated;
Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst
function might create an invalid coercion. Because a violation of the
restriction might lead to a program that "goes wrong", it is checked all the time,
even in a production compiler and without -dcore-list. We *have* proved that the
problem does not occur with homogeneous equality, so this check can be dropped
once ~# is made to be homogeneous.
-}


-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.
-- The kind of the tycovar should be the left-hand kind of the kind coercion.
-- See Note [Unused coercion variable in ForAllCo]
mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion
mkForAllCo :: CoVar -> Coercion -> Coercion -> Coercion
mkForAllCo CoVar
v Coercion
kind_co Coercion
co
  | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True
  , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True
  , Just (Type
ty, Role
r) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
  , Coercion -> Bool
isGReflCo Coercion
kind_co
  = Role -> Type -> Coercion
mkReflCo Role
r (CoVar -> Type -> Type
mkTyCoInvForAllTy CoVar
v Type
ty)
  | Bool
otherwise
  = CoVar -> Coercion -> Coercion -> Coercion
ForAllCo CoVar
v Coercion
kind_co Coercion
co

-- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious
-- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'.
-- The kind of the tycovar should be the left-hand kind of the kind coercion.
mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion
mkForAllCo_NoRefl :: CoVar -> Coercion -> Coercion -> Coercion
mkForAllCo_NoRefl CoVar
v Coercion
kind_co Coercion
co
  | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True
  , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True
  , ASSERT( not (isReflCo co)) True
  , CoVar -> Bool
isCoVar CoVar
v
  , Bool -> Bool
not (CoVar
v CoVar -> VarSet -> Bool
`elemVarSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
co)
  = Role -> Coercion -> Coercion -> Coercion
FunCo (Coercion -> Role
coercionRole Coercion
co) Coercion
kind_co Coercion
co
  | Bool
otherwise
  = CoVar -> Coercion -> Coercion -> Coercion
ForAllCo CoVar
v Coercion
kind_co Coercion
co

-- | Make nested ForAllCos
mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion
mkForAllCos :: [(CoVar, Coercion)] -> Coercion -> Coercion
mkForAllCos [(CoVar, Coercion)]
bndrs Coercion
co
  | Just (Type
ty, Role
r ) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
  = let ([(CoVar, Coercion)]
refls_rev'd, [(CoVar, Coercion)]
non_refls_rev'd) = ((CoVar, Coercion) -> Bool)
-> [(CoVar, Coercion)]
-> ([(CoVar, Coercion)], [(CoVar, Coercion)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Coercion -> Bool
isReflCo (Coercion -> Bool)
-> ((CoVar, Coercion) -> Coercion) -> (CoVar, Coercion) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoVar, Coercion) -> Coercion
forall a b. (a, b) -> b
snd) ([(CoVar, Coercion)] -> [(CoVar, Coercion)]
forall a. [a] -> [a]
reverse [(CoVar, Coercion)]
bndrs) in
    (Coercion -> (CoVar, Coercion) -> Coercion)
-> Coercion -> [(CoVar, Coercion)] -> Coercion
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((CoVar, Coercion) -> Coercion -> Coercion)
-> Coercion -> (CoVar, Coercion) -> Coercion
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((CoVar, Coercion) -> Coercion -> Coercion)
 -> Coercion -> (CoVar, Coercion) -> Coercion)
-> ((CoVar, Coercion) -> Coercion -> Coercion)
-> Coercion
-> (CoVar, Coercion)
-> Coercion
forall a b. (a -> b) -> a -> b
$ (CoVar -> Coercion -> Coercion -> Coercion)
-> (CoVar, Coercion) -> Coercion -> Coercion
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CoVar -> Coercion -> Coercion -> Coercion
mkForAllCo_NoRefl)
           (Role -> Type -> Coercion
mkReflCo Role
r ([CoVar] -> Type -> Type
mkTyCoInvForAllTys ([CoVar] -> [CoVar]
forall a. [a] -> [a]
reverse (((CoVar, Coercion) -> CoVar) -> [(CoVar, Coercion)] -> [CoVar]
forall a b. (a -> b) -> [a] -> [b]
map (CoVar, Coercion) -> CoVar
forall a b. (a, b) -> a
fst [(CoVar, Coercion)]
refls_rev'd)) Type
ty))
           [(CoVar, Coercion)]
non_refls_rev'd
  | Bool
otherwise
  = ((CoVar, Coercion) -> Coercion -> Coercion)
-> Coercion -> [(CoVar, Coercion)] -> Coercion
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((CoVar -> Coercion -> Coercion -> Coercion)
-> (CoVar, Coercion) -> Coercion -> Coercion
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CoVar -> Coercion -> Coercion -> Coercion
mkForAllCo_NoRefl) Coercion
co [(CoVar, Coercion)]
bndrs

-- | Make a Coercion quantified over a type/coercion variable;
-- the variable has the same type in both sides of the coercion
mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion
mkHomoForAllCos :: [CoVar] -> Coercion -> Coercion
mkHomoForAllCos [CoVar]
vs Coercion
co
  | Just (Type
ty, Role
r) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
  = Role -> Type -> Coercion
mkReflCo Role
r ([CoVar] -> Type -> Type
mkTyCoInvForAllTys [CoVar]
vs Type
ty)
  | Bool
otherwise
  = [CoVar] -> Coercion -> Coercion
mkHomoForAllCos_NoRefl [CoVar]
vs Coercion
co

-- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious
-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'.
mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion
mkHomoForAllCos_NoRefl :: [CoVar] -> Coercion -> Coercion
mkHomoForAllCos_NoRefl [CoVar]
vs Coercion
orig_co
  = ASSERT( not (isReflCo orig_co))
    (CoVar -> Coercion -> Coercion) -> Coercion -> [CoVar] -> Coercion
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoVar -> Coercion -> Coercion
go Coercion
orig_co [CoVar]
vs
  where
    go :: CoVar -> Coercion -> Coercion
go CoVar
v Coercion
co = CoVar -> Coercion -> Coercion -> Coercion
mkForAllCo_NoRefl CoVar
v (Type -> Coercion
mkNomReflCo (CoVar -> Type
varType CoVar
v)) Coercion
co

mkCoVarCo :: CoVar -> Coercion
-- cv :: s ~# t
-- See Note [mkCoVarCo]
mkCoVarCo :: CoVar -> Coercion
mkCoVarCo CoVar
cv = CoVar -> Coercion
CoVarCo CoVar
cv

mkCoVarCos :: [CoVar] -> [Coercion]
mkCoVarCos :: [CoVar] -> [Coercion]
mkCoVarCos = (CoVar -> Coercion) -> [CoVar] -> [Coercion]
forall a b. (a -> b) -> [a] -> [b]
map CoVar -> Coercion
mkCoVarCo

{- Note [mkCoVarCo]
~~~~~~~~~~~~~~~~~~~
In the past, mkCoVarCo optimised (c :: t~t) to (Refl t).  That is
valid (although see Note [Unbound RULE binders] in Rules), but
it's a relatively expensive test and perhaps better done in
optCoercion.  Not a big deal either way.
-}

-- | Extract a covar, if possible. This check is dirty. Be ashamed
-- of yourself. (It's dirty because it cares about the structure of
-- a coercion, which is morally reprehensible.)
isCoVar_maybe :: Coercion -> Maybe CoVar
isCoVar_maybe :: Coercion -> Maybe CoVar
isCoVar_maybe (CoVarCo CoVar
cv) = CoVar -> Maybe CoVar
forall a. a -> Maybe a
Just CoVar
cv
isCoVar_maybe Coercion
_            = Maybe CoVar
forall a. Maybe a
Nothing

mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion]
           -> Coercion
-- mkAxInstCo can legitimately be called over-staturated;
-- i.e. with more type arguments than the coercion requires
mkAxInstCo :: Role -> CoAxiom br -> Int -> [Type] -> [Coercion] -> Coercion
mkAxInstCo Role
role CoAxiom br
ax Int
index [Type]
tys [Coercion]
cos
  | Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n_tys = Role -> Role -> Coercion -> Coercion
downgradeRole Role
role Role
ax_role (Coercion -> Coercion) -> Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$
                     CoAxiom Branched -> Int -> [Coercion] -> Coercion
mkAxiomInstCo CoAxiom Branched
ax_br Int
index ([Coercion]
rtys [Coercion] -> [Coercion] -> [Coercion]
forall a. [a] -> [a] -> [a]
`chkAppend` [Coercion]
cos)
  | Bool
otherwise      = ASSERT( arity < n_tys )
                     Role -> Role -> Coercion -> Coercion
downgradeRole Role
role Role
ax_role (Coercion -> Coercion) -> Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$
                     Coercion -> [Coercion] -> Coercion
mkAppCos (CoAxiom Branched -> Int -> [Coercion] -> Coercion
mkAxiomInstCo CoAxiom Branched
ax_br Int
index
                                             ([Coercion]
ax_args [Coercion] -> [Coercion] -> [Coercion]
forall a. [a] -> [a] -> [a]
`chkAppend` [Coercion]
cos))
                              [Coercion]
leftover_args
  where
    n_tys :: Int
n_tys         = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys
    ax_br :: CoAxiom Branched
ax_br         = CoAxiom br -> CoAxiom Branched
forall (br :: BranchFlag). CoAxiom br -> CoAxiom Branched
toBranchedAxiom CoAxiom br
ax
    branch :: CoAxBranch
branch        = CoAxiom Branched -> Int -> CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> Int -> CoAxBranch
coAxiomNthBranch CoAxiom Branched
ax_br Int
index
    tvs :: [CoVar]
tvs           = CoAxBranch -> [CoVar]
coAxBranchTyVars CoAxBranch
branch
    arity :: Int
arity         = [CoVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoVar]
tvs
    arg_roles :: [Role]
arg_roles     = CoAxBranch -> [Role]
coAxBranchRoles CoAxBranch
branch
    rtys :: [Coercion]
rtys          = (Role -> Type -> Coercion) -> [Role] -> [Type] -> [Coercion]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Role -> Type -> Coercion
mkReflCo ([Role]
arg_roles [Role] -> [Role] -> [Role]
forall a. [a] -> [a] -> [a]
++ Role -> [Role]
forall a. a -> [a]
repeat Role
Nominal) [Type]
tys
    ([Coercion]
ax_args, [Coercion]
leftover_args)
                  = Int -> [Coercion] -> ([Coercion], [Coercion])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
arity [Coercion]
rtys
    ax_role :: Role
ax_role       = CoAxiom br -> Role
forall (br :: BranchFlag). CoAxiom br -> Role
coAxiomRole CoAxiom br
ax

-- worker function
mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion
mkAxiomInstCo :: CoAxiom Branched -> Int -> [Coercion] -> Coercion
mkAxiomInstCo CoAxiom Branched
ax Int
index [Coercion]
args
  = ASSERT( args `lengthIs` coAxiomArity ax index )
    CoAxiom Branched -> Int -> [Coercion] -> Coercion
AxiomInstCo CoAxiom Branched
ax Int
index [Coercion]
args

-- to be used only with unbranched axioms
mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched
                     -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
role CoAxiom Unbranched
ax [Type]
tys [Coercion]
cos
  = Role
-> CoAxiom Unbranched -> Int -> [Type] -> [Coercion] -> Coercion
forall (br :: BranchFlag).
Role -> CoAxiom br -> Int -> [Type] -> [Coercion] -> Coercion
mkAxInstCo Role
role CoAxiom Unbranched
ax Int
0 [Type]
tys [Coercion]
cos

mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type
-- Instantiate the axiom with specified types,
-- returning the instantiated RHS
-- A companion to mkAxInstCo:
--    mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys))
mkAxInstRHS :: CoAxiom br -> Int -> [Type] -> [Coercion] -> Type
mkAxInstRHS CoAxiom br
ax Int
index [Type]
tys [Coercion]
cos
  = ASSERT( tvs `equalLength` tys1 )
    Type -> [Type] -> Type
mkAppTys Type
rhs' [Type]
tys2
  where
    branch :: CoAxBranch
branch       = CoAxiom br -> Int -> CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> Int -> CoAxBranch
coAxiomNthBranch CoAxiom br
ax Int
index
    tvs :: [CoVar]
tvs          = CoAxBranch -> [CoVar]
coAxBranchTyVars CoAxBranch
branch
    cvs :: [CoVar]
cvs          = CoAxBranch -> [CoVar]
coAxBranchCoVars CoAxBranch
branch
    ([Type]
tys1, [Type]
tys2) = [CoVar] -> [Type] -> ([Type], [Type])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [CoVar]
tvs [Type]
tys
    rhs' :: Type
rhs'         = HasCallStack => [CoVar] -> [Type] -> Type -> Type
[CoVar] -> [Type] -> Type -> Type
substTyWith [CoVar]
tvs [Type]
tys1 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                   [CoVar] -> [Coercion] -> Type -> Type
substTyWithCoVars [CoVar]
cvs [Coercion]
cos (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                   CoAxBranch -> Type
coAxBranchRHS CoAxBranch
branch

mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type
mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type
mkUnbranchedAxInstRHS CoAxiom Unbranched
ax = CoAxiom Unbranched -> Int -> [Type] -> [Coercion] -> Type
forall (br :: BranchFlag).
CoAxiom br -> Int -> [Type] -> [Coercion] -> Type
mkAxInstRHS CoAxiom Unbranched
ax Int
0

-- | Return the left-hand type of the axiom, when the axiom is instantiated
-- at the types given.
mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type
mkAxInstLHS :: CoAxiom br -> Int -> [Type] -> [Coercion] -> Type
mkAxInstLHS CoAxiom br
ax Int
index [Type]
tys [Coercion]
cos
  = ASSERT( tvs `equalLength` tys1 )
    TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc ([Type]
lhs_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
`chkAppend` [Type]
tys2)
  where
    branch :: CoAxBranch
branch       = CoAxiom br -> Int -> CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> Int -> CoAxBranch
coAxiomNthBranch CoAxiom br
ax Int
index
    tvs :: [CoVar]
tvs          = CoAxBranch -> [CoVar]
coAxBranchTyVars CoAxBranch
branch
    cvs :: [CoVar]
cvs          = CoAxBranch -> [CoVar]
coAxBranchCoVars CoAxBranch
branch
    ([Type]
tys1, [Type]
tys2) = [CoVar] -> [Type] -> ([Type], [Type])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [CoVar]
tvs [Type]
tys
    lhs_tys :: [Type]
lhs_tys      = [CoVar] -> [Type] -> [Type] -> [Type]
substTysWith [CoVar]
tvs [Type]
tys1 ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$
                   [CoVar] -> [Coercion] -> [Type] -> [Type]
substTysWithCoVars [CoVar]
cvs [Coercion]
cos ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$
                   CoAxBranch -> [Type]
coAxBranchLHS CoAxBranch
branch
    fam_tc :: TyCon
fam_tc       = CoAxiom br -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom br
ax

-- | Instantiate the left-hand side of an unbranched axiom
mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type
mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type
mkUnbranchedAxInstLHS CoAxiom Unbranched
ax = CoAxiom Unbranched -> Int -> [Type] -> [Coercion] -> Type
forall (br :: BranchFlag).
CoAxiom br -> Int -> [Type] -> [Coercion] -> Type
mkAxInstLHS CoAxiom Unbranched
ax Int
0

-- | Manufacture an unsafe coercion from thin air.
--   Currently (May 14) this is used only to implement the
--   @unsafeCoerce#@ primitive.  Optimise by pushing
--   down through type constructors.
mkUnsafeCo :: Role -> Type -> Type -> Coercion
mkUnsafeCo :: Role -> Type -> Type -> Coercion
mkUnsafeCo Role
role Type
ty1 Type
ty2
  = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkUnivCo UnivCoProvenance
UnsafeCoerceProv Role
role Type
ty1 Type
ty2

-- | Make a coercion from a coercion hole
mkHoleCo :: CoercionHole -> Coercion
mkHoleCo :: CoercionHole -> Coercion
mkHoleCo CoercionHole
h = CoercionHole -> Coercion
HoleCo CoercionHole
h

-- | Make a universal coercion between two arbitrary types.
mkUnivCo :: UnivCoProvenance
         -> Role       -- ^ role of the built coercion, "r"
         -> Type       -- ^ t1 :: k1
         -> Type       -- ^ t2 :: k2
         -> Coercion   -- ^ :: t1 ~r t2
mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkUnivCo UnivCoProvenance
prov Role
role Type
ty1 Type
ty2
  | Type
ty1 Type -> Type -> Bool
`eqType` Type
ty2 = Role -> Type -> Coercion
mkReflCo Role
role Type
ty1
  | Bool
otherwise        = UnivCoProvenance -> Role -> Type -> Type -> Coercion
UnivCo UnivCoProvenance
prov Role
role Type
ty1 Type
ty2

-- | Create a symmetric version of the given 'Coercion' that asserts
--   equality between the same types but in the other "direction", so
--   a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.
mkSymCo :: Coercion -> Coercion

-- Do a few simple optimizations, but don't bother pushing occurrences
-- of symmetry to the leaves; the optimizer will take care of that.
mkSymCo :: Coercion -> Coercion
mkSymCo Coercion
co | Coercion -> Bool
isReflCo Coercion
co          = Coercion
co
mkSymCo    (SymCo Coercion
co)             = Coercion
co
mkSymCo    (SubCo (SymCo Coercion
co))     = Coercion -> Coercion
SubCo Coercion
co
mkSymCo Coercion
co                        = Coercion -> Coercion
SymCo Coercion
co

-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.
--   (co1 ; co2)
mkTransCo :: Coercion -> Coercion -> Coercion
mkTransCo :: Coercion -> Coercion -> Coercion
mkTransCo Coercion
co1 Coercion
co2 | Coercion -> Bool
isReflCo Coercion
co1 = Coercion
co2
                  | Coercion -> Bool
isReflCo Coercion
co2 = Coercion
co1
mkTransCo (GRefl Role
r Type
t1 (MCo Coercion
co1)) (GRefl Role
_ Type
_ (MCo Coercion
co2))
  = Role -> Type -> MCoercion -> Coercion
GRefl Role
r Type
t1 (Coercion -> MCoercion
MCo (Coercion -> MCoercion) -> Coercion -> MCoercion
forall a b. (a -> b) -> a -> b
$ Coercion -> Coercion -> Coercion
mkTransCo Coercion
co1 Coercion
co2)
mkTransCo Coercion
co1 Coercion
co2                 = Coercion -> Coercion -> Coercion
TransCo Coercion
co1 Coercion
co2

-- | Compose two MCoercions via transitivity
mkTransMCo :: MCoercion -> MCoercion -> MCoercion
mkTransMCo :: MCoercion -> MCoercion -> MCoercion
mkTransMCo MCoercion
MRefl     MCoercion
co2       = MCoercion
co2
mkTransMCo MCoercion
co1       MCoercion
MRefl     = MCoercion
co1
mkTransMCo (MCo Coercion
co1) (MCo Coercion
co2) = Coercion -> MCoercion
MCo (Coercion -> Coercion -> Coercion
mkTransCo Coercion
co1 Coercion
co2)

mkNthCo :: HasDebugCallStack
        => Role  -- The role of the coercion you're creating
        -> Int   -- Zero-indexed
        -> Coercion
        -> Coercion
mkNthCo :: Role -> Int -> Coercion -> Coercion
mkNthCo Role
r Int
n Coercion
co
  = ASSERT2( good_call, bad_call_msg )
    Role -> Int -> Coercion -> Coercion
go Role
r Int
n Coercion
co
  where
    Pair Type
ty1 Type
ty2 = Coercion -> Pair Type
coercionKind Coercion
co

    go :: Role -> Int -> Coercion -> Coercion
go Role
r Int
0 Coercion
co
      | Just (Type
ty, Role
_) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
      , Just (CoVar
tv, Type
_) <- Type -> Maybe (CoVar, Type)
splitForAllTy_maybe Type
ty
      = -- works for both tyvar and covar
        ASSERT( r == Nominal )
        Type -> Coercion
mkNomReflCo (CoVar -> Type
varType CoVar
tv)

    go Role
r Int
n Coercion
co
      | Just (Type
ty, Role
r0) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
      , let tc :: TyCon
tc = Type -> TyCon
tyConAppTyCon Type
ty
      = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty )
        ASSERT( nthRole r0 tc n == r )
        Role -> Type -> Coercion
mkReflCo Role
r (Int -> Type -> Type
tyConAppArgN Int
n Type
ty)
      where ok_tc_app :: Type -> Int -> Bool
            ok_tc_app :: Type -> Int -> Bool
ok_tc_app Type
ty Int
n
              | Just (TyCon
_, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
              = [Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
n
              | Type -> Bool
isForAllTy Type
ty  -- nth:0 pulls out a kind coercion from a hetero forall
              = Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
              | Bool
otherwise
              = Bool
False

    go Role
r Int
0 (ForAllCo CoVar
_ Coercion
kind_co Coercion
_)
      = ASSERT( r == Nominal )
        Coercion
kind_co
      -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)
      -- then (nth 0 co :: k1 ~N k2)
      -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)
      -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4))

    go Role
r Int
n co :: Coercion
co@(FunCo Role
r0 Coercion
arg Coercion
res)
      -- See Note [Function coercions]
      -- If FunCo _ arg_co res_co ::   (s1:TYPE sk1 -> s2:TYPE sk2)
      --                             ~ (t1:TYPE tk1 -> t2:TYPE tk2)
      -- Then we want to behave as if co was
      --    TyConAppCo argk_co resk_co arg_co res_co
      -- where
      --    argk_co :: sk1 ~ tk1  =  mkNthCo 0 (mkKindCo arg_co)
      --    resk_co :: sk2 ~ tk2  =  mkNthCo 0 (mkKindCo res_co)
      --                             i.e. mkRuntimeRepCo
      = case Int
n of
          Int
0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg
          Int
1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res
          Int
2 -> ASSERT( r == r0 )      arg
          Int
3 -> ASSERT( r == r0 )      res
          Int
_ -> String -> SDoc -> Coercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkNthCo(FunCo)" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n SDoc -> SDoc -> SDoc
$$ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)

    go Role
r Int
n (TyConAppCo Role
r0 TyCon
tc [Coercion]
arg_cos) = ASSERT2( r == nthRole r0 tc n
                                                    , (vcat [ ppr tc
                                                            , ppr arg_cos
                                                            , ppr r0
                                                            , ppr n
                                                            , ppr r ]) )
                                             [Coercion]
arg_cos [Coercion] -> Int -> Coercion
forall a. Outputable a => [a] -> Int -> a
`getNth` Int
n

    go Role
r Int
n Coercion
co =
      Role -> Int -> Coercion -> Coercion
NthCo Role
r Int
n Coercion
co

    -- Assertion checking
    bad_call_msg :: SDoc
bad_call_msg = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Coercion =" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
                        , String -> SDoc
text String
"LHS ty =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty1
                        , String -> SDoc
text String
"RHS ty =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2
                        , String -> SDoc
text String
"n =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n, String -> SDoc
text String
"r =" SDoc -> SDoc -> SDoc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr Role
r
                        , String -> SDoc
text String
"coercion role =" SDoc -> SDoc -> SDoc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Role
coercionRole Coercion
co) ]
    good_call :: Bool
good_call
      -- If the Coercion passed in is between forall-types, then the Int must
      -- be 0 and the role must be Nominal.
      | Just (CoVar
_tv1, Type
_) <- Type -> Maybe (CoVar, Type)
splitForAllTy_maybe Type
ty1
      , Just (CoVar
_tv2, Type
_) <- Type -> Maybe (CoVar, Type)
splitForAllTy_maybe Type
ty2
      = Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Role
r Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal

      -- If the Coercion passed in is between T tys and T tys', then the Int
      -- must be less than the length of tys/tys' (which must be the same
      -- lengths).
      --
      -- If the role of the Coercion is nominal, then the role passed in must
      -- be nominal. If the role of the Coercion is representational, then the
      -- role passed in must be tyConRolesRepresentational T !! n. If the role
      -- of the Coercion is Phantom, then the role passed in must be Phantom.
      --
      -- See also Note [NthCo Cached Roles] if you're wondering why it's
      -- blaringly obvious that we should be *computing* this role instead of
      -- passing it in.
      | Just (TyCon
tc1, [Type]
tys1) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty1
      , Just (TyCon
tc2, [Type]
tys2) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty2
      , TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
      = let len1 :: Int
len1 = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys1
            len2 :: Int
len2 = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys2
            good_role :: Bool
good_role = case Coercion -> Role
coercionRole Coercion
co of
                          Role
Nominal -> Role
r Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal
                          Role
Representational -> Role
r Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== (TyCon -> [Role]
tyConRolesRepresentational TyCon
tc1 [Role] -> Int -> Role
forall a. [a] -> Int -> a
!! Int
n)
                          Role
Phantom -> Role
r Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Phantom
        in Int
len1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len2 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len1 Bool -> Bool -> Bool
&& Bool
good_role

      | Bool
otherwise
      = Bool
True



-- | If you're about to call @mkNthCo r n co@, then @r@ should be
-- whatever @nthCoRole n co@ returns.
nthCoRole :: Int -> Coercion -> Role
nthCoRole :: Int -> Coercion -> Role
nthCoRole Int
n Coercion
co
  | Just (TyCon
tc, [Type]
_) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
lty
  = Role -> TyCon -> Int -> Role
nthRole Role
r TyCon
tc Int
n

  | Just (CoVar, Type)
_ <- Type -> Maybe (CoVar, Type)
splitForAllTy_maybe Type
lty
  = Role
Nominal

  | Bool
otherwise
  = String -> SDoc -> Role
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"nthCoRole" (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)

  where
    (Pair Type
lty Type
_, Role
r) = Coercion -> (Pair Type, Role)
coercionKindRole Coercion
co

mkLRCo :: LeftOrRight -> Coercion -> Coercion
mkLRCo :: LeftOrRight -> Coercion -> Coercion
mkLRCo LeftOrRight
lr Coercion
co
  | Just (Type
ty, Role
eq) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
  = Role -> Type -> Coercion
mkReflCo Role
eq (LeftOrRight -> (Type, Type) -> Type
forall a. LeftOrRight -> (a, a) -> a
pickLR LeftOrRight
lr (Type -> (Type, Type)
splitAppTy Type
ty))
  | Bool
otherwise
  = LeftOrRight -> Coercion -> Coercion
LRCo LeftOrRight
lr Coercion
co

-- | Instantiates a 'Coercion'.
mkInstCo :: Coercion -> Coercion -> Coercion
mkInstCo :: Coercion -> Coercion -> Coercion
mkInstCo (ForAllCo CoVar
tcv Coercion
_kind_co Coercion
body_co) Coercion
co
  | Just (Type
arg, Role
_) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co
      -- works for both tyvar and covar
  = TCvSubst -> Coercion -> Coercion
substCoUnchecked ([CoVar] -> [Type] -> TCvSubst
HasDebugCallStack => [CoVar] -> [Type] -> TCvSubst
zipTCvSubst [CoVar
tcv] [Type
arg]) Coercion
body_co
mkInstCo Coercion
co Coercion
arg = Coercion -> Coercion -> Coercion
InstCo Coercion
co Coercion
arg

-- | Given @ty :: k1@, @co :: k1 ~ k2@,
-- produces @co' :: ty ~r (ty |> co)@
mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion
mkGReflRightCo :: Role -> Type -> Coercion -> Coercion
mkGReflRightCo Role
r Type
ty Coercion
co
  | Coercion -> Bool
isGReflCo Coercion
co = Role -> Type -> Coercion
mkReflCo Role
r Type
ty
    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@
    -- instead of @isReflCo@
  | Bool
otherwise = Role -> Type -> MCoercion -> Coercion
GRefl Role
r Type
ty (Coercion -> MCoercion
MCo Coercion
co)

-- | Given @ty :: k1@, @co :: k1 ~ k2@,
-- produces @co' :: (ty |> co) ~r ty@
mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion
mkGReflLeftCo :: Role -> Type -> Coercion -> Coercion
mkGReflLeftCo Role
r Type
ty Coercion
co
  | Coercion -> Bool
isGReflCo Coercion
co = Role -> Type -> Coercion
mkReflCo Role
r Type
ty
    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@
    -- instead of @isReflCo@
  | Bool
otherwise    = Coercion -> Coercion
mkSymCo (Coercion -> Coercion) -> Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$ Role -> Type -> MCoercion -> Coercion
GRefl Role
r Type
ty (Coercion -> MCoercion
MCo Coercion
co)

-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@,
-- produces @co' :: (ty |> co) ~r ty'
-- It is not only a utility function, but it saves allocation when co
-- is a GRefl coercion.
mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion
mkCoherenceLeftCo :: Role -> Type -> Coercion -> Coercion -> Coercion
mkCoherenceLeftCo Role
r Type
ty Coercion
co Coercion
co2
  | Coercion -> Bool
isGReflCo Coercion
co = Coercion
co2
  | Bool
otherwise = (Coercion -> Coercion
mkSymCo (Coercion -> Coercion) -> Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$ Role -> Type -> MCoercion -> Coercion
GRefl Role
r Type
ty (Coercion -> MCoercion
MCo Coercion
co)) Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2

-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,
-- produces @co' :: ty' ~r (ty |> co)
-- It is not only a utility function, but it saves allocation when co
-- is a GRefl coercion.
mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion
mkCoherenceRightCo :: Role -> Type -> Coercion -> Coercion -> Coercion
mkCoherenceRightCo Role
r Type
ty Coercion
co Coercion
co2
  | Coercion -> Bool
isGReflCo Coercion
co = Coercion
co2
  | Bool
otherwise = Coercion
co2 Coercion -> Coercion -> Coercion
`mkTransCo` Role -> Type -> MCoercion -> Coercion
GRefl Role
r Type
ty (Coercion -> MCoercion
MCo Coercion
co)

-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.
mkKindCo :: Coercion -> Coercion
mkKindCo :: Coercion -> Coercion
mkKindCo Coercion
co | Just (Type
ty, Role
_) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co = Type -> Coercion
Refl (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)
mkKindCo (GRefl Role
_ Type
_ (MCo Coercion
co)) = Coercion
co
mkKindCo (UnivCo (PhantomProv Coercion
h) Role
_ Type
_ Type
_)    = Coercion
h
mkKindCo (UnivCo (ProofIrrelProv Coercion
h) Role
_ Type
_ Type
_) = Coercion
h
mkKindCo Coercion
co
  | Pair Type
ty1 Type
ty2 <- Coercion -> Pair Type
coercionKind Coercion
co
       -- generally, calling coercionKind during coercion creation is a bad idea,
       -- as it can lead to exponential behavior. But, we don't have nested mkKindCos,
       -- so it's OK here.
  , let tk1 :: Type
tk1 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty1
        tk2 :: Type
tk2 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty2
  , Type
tk1 Type -> Type -> Bool
`eqType` Type
tk2
  = Type -> Coercion
Refl Type
tk1
  | Bool
otherwise
  = Coercion -> Coercion
KindCo Coercion
co

mkSubCo :: Coercion -> Coercion
-- Input coercion is Nominal, result is Representational
-- see also Note [Role twiddling functions]
mkSubCo :: Coercion -> Coercion
mkSubCo (Refl Type
ty) = Role -> Type -> MCoercion -> Coercion
GRefl Role
Representational Type
ty MCoercion
MRefl
mkSubCo (GRefl Role
Nominal Type
ty MCoercion
co) = Role -> Type -> MCoercion -> Coercion
GRefl Role
Representational Type
ty MCoercion
co
mkSubCo (TyConAppCo Role
Nominal TyCon
tc [Coercion]
cos)
  = Role -> TyCon -> [Coercion] -> Coercion
TyConAppCo Role
Representational TyCon
tc (TyCon -> [Coercion] -> [Coercion]
applyRoles TyCon
tc [Coercion]
cos)
mkSubCo (FunCo Role
Nominal Coercion
arg Coercion
res)
  = Role -> Coercion -> Coercion -> Coercion
FunCo Role
Representational
          (Role -> Role -> Coercion -> Coercion
downgradeRole Role
Representational Role
Nominal Coercion
arg)
          (Role -> Role -> Coercion -> Coercion
downgradeRole Role
Representational Role
Nominal Coercion
res)
mkSubCo Coercion
co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) )
             Coercion -> Coercion
SubCo Coercion
co

-- | Changes a role, but only a downgrade. See Note [Role twiddling functions]
downgradeRole_maybe :: Role   -- ^ desired role
                    -> Role   -- ^ current role
                    -> Coercion -> Maybe Coercion
-- In (downgradeRole_maybe dr cr co) it's a precondition that
--                                   cr = coercionRole co

downgradeRole_maybe :: Role -> Role -> Coercion -> Maybe Coercion
downgradeRole_maybe Role
Nominal          Role
Nominal          Coercion
co = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just Coercion
co
downgradeRole_maybe Role
Nominal          Role
_                Coercion
_  = Maybe Coercion
forall a. Maybe a
Nothing

downgradeRole_maybe Role
Representational Role
Nominal          Coercion
co = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just (Coercion -> Coercion
mkSubCo Coercion
co)
downgradeRole_maybe Role
Representational Role
Representational Coercion
co = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just Coercion
co
downgradeRole_maybe Role
Representational Role
Phantom          Coercion
_  = Maybe Coercion
forall a. Maybe a
Nothing

downgradeRole_maybe Role
Phantom          Role
Phantom          Coercion
co = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just Coercion
co
downgradeRole_maybe Role
Phantom          Role
_                Coercion
co = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just (Coercion -> Coercion
toPhantomCo Coercion
co)

-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade.
-- See Note [Role twiddling functions]
downgradeRole :: Role  -- desired role
              -> Role  -- current role
              -> Coercion -> Coercion
downgradeRole :: Role -> Role -> Coercion -> Coercion
downgradeRole Role
r1 Role
r2 Coercion
co
  = case Role -> Role -> Coercion -> Maybe Coercion
downgradeRole_maybe Role
r1 Role
r2 Coercion
co of
      Just Coercion
co' -> Coercion
co'
      Maybe Coercion
Nothing  -> String -> SDoc -> Coercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"downgradeRole" (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)

mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
mkAxiomRuleCo = CoAxiomRule -> [Coercion] -> Coercion
AxiomRuleCo

-- | Make a "coercion between coercions".
mkProofIrrelCo :: Role       -- ^ role of the created coercion, "r"
               -> Coercion   -- ^ :: phi1 ~N phi2
               -> Coercion   -- ^ g1 :: phi1
               -> Coercion   -- ^ g2 :: phi2
               -> Coercion   -- ^ :: g1 ~r g2

-- if the two coercion prove the same fact, I just don't care what
-- the individual coercions are.
mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion
mkProofIrrelCo Role
r Coercion
co Coercion
g  Coercion
_ | Coercion -> Bool
isGReflCo Coercion
co  = Role -> Type -> Coercion
mkReflCo Role
r (Coercion -> Type
mkCoercionTy Coercion
g)
  -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@
mkProofIrrelCo Role
r Coercion
kco        Coercion
g1 Coercion
g2 = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkUnivCo (Coercion -> UnivCoProvenance
ProofIrrelProv Coercion
kco) Role
r
                                             (Coercion -> Type
mkCoercionTy Coercion
g1) (Coercion -> Type
mkCoercionTy Coercion
g2)

{-
%************************************************************************
%*                                                                      *
   Roles
%*                                                                      *
%************************************************************************
-}

-- | Converts a coercion to be nominal, if possible.
-- See Note [Role twiddling functions]
setNominalRole_maybe :: Role -- of input coercion
                     -> Coercion -> Maybe Coercion
setNominalRole_maybe :: Role -> Coercion -> Maybe Coercion
setNominalRole_maybe Role
r Coercion
co
  | Role
r Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just Coercion
co
  | Bool
otherwise = Coercion -> Maybe Coercion
setNominalRole_maybe_helper Coercion
co
  where
    setNominalRole_maybe_helper :: Coercion -> Maybe Coercion
setNominalRole_maybe_helper (SubCo Coercion
co)  = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just Coercion
co
    setNominalRole_maybe_helper co :: Coercion
co@(Refl Type
_) = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just Coercion
co
    setNominalRole_maybe_helper (GRefl Role
_ Type
ty MCoercion
co) = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just (Coercion -> Maybe Coercion) -> Coercion -> Maybe Coercion
forall a b. (a -> b) -> a -> b
$ Role -> Type -> MCoercion -> Coercion
GRefl Role
Nominal Type
ty MCoercion
co
    setNominalRole_maybe_helper (TyConAppCo Role
Representational TyCon
tc [Coercion]
cos)
      = do { [Coercion]
cos' <- (Role -> Coercion -> Maybe Coercion)
-> [Role] -> [Coercion] -> Maybe [Coercion]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Role -> Coercion -> Maybe Coercion
setNominalRole_maybe (Role -> TyCon -> [Role]
tyConRolesX Role
Representational TyCon
tc) [Coercion]
cos
           ; Coercion -> Maybe Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Maybe Coercion) -> Coercion -> Maybe Coercion
forall a b. (a -> b) -> a -> b
$ Role -> TyCon -> [Coercion] -> Coercion
TyConAppCo Role
Nominal TyCon
tc [Coercion]
cos' }
    setNominalRole_maybe_helper (FunCo Role
Representational Coercion
co1 Coercion
co2)
      = do { Coercion
co1' <- Role -> Coercion -> Maybe Coercion
setNominalRole_maybe Role
Representational Coercion
co1
           ; Coercion
co2' <- Role -> Coercion -> Maybe Coercion
setNominalRole_maybe Role
Representational Coercion
co2
           ; Coercion -> Maybe Coercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Maybe Coercion) -> Coercion -> Maybe Coercion
forall a b. (a -> b) -> a -> b
$ Role -> Coercion -> Coercion -> Coercion
FunCo Role
Nominal Coercion
co1' Coercion
co2'
           }
    setNominalRole_maybe_helper (SymCo Coercion
co)
      = Coercion -> Coercion
SymCo (Coercion -> Coercion) -> Maybe Coercion -> Maybe Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Maybe Coercion
setNominalRole_maybe_helper Coercion
co
    setNominalRole_maybe_helper (TransCo Coercion
co1 Coercion
co2)
      = Coercion -> Coercion -> Coercion
TransCo (Coercion -> Coercion -> Coercion)
-> Maybe Coercion -> Maybe (Coercion -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Maybe Coercion
setNominalRole_maybe_helper Coercion
co1 Maybe (Coercion -> Coercion) -> Maybe Coercion -> Maybe Coercion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Coercion -> Maybe Coercion
setNominalRole_maybe_helper Coercion
co2
    setNominalRole_maybe_helper (AppCo Coercion
co1 Coercion
co2)
      = Coercion -> Coercion -> Coercion
AppCo (Coercion -> Coercion -> Coercion)
-> Maybe Coercion -> Maybe (Coercion -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Maybe Coercion
setNominalRole_maybe_helper Coercion
co1 Maybe (Coercion -> Coercion) -> Maybe Coercion -> Maybe Coercion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Coercion -> Maybe Coercion
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coercion
co2
    setNominalRole_maybe_helper (ForAllCo CoVar
tv Coercion
kind_co Coercion
co)
      = CoVar -> Coercion -> Coercion -> Coercion
ForAllCo CoVar
tv Coercion
kind_co (Coercion -> Coercion) -> Maybe Coercion -> Maybe Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Maybe Coercion
setNominalRole_maybe_helper Coercion
co
    setNominalRole_maybe_helper (NthCo Role
_r Int
n Coercion
co)
      -- NB, this case recurses via setNominalRole_maybe, not
      -- setNominalRole_maybe_helper!
      = Role -> Int -> Coercion -> Coercion
NthCo Role
Nominal Int
n (Coercion -> Coercion) -> Maybe Coercion -> Maybe Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Role -> Coercion -> Maybe Coercion
setNominalRole_maybe (Coercion -> Role
coercionRole Coercion
co) Coercion
co
    setNominalRole_maybe_helper (InstCo Coercion
co Coercion
arg)
      = Coercion -> Coercion -> Coercion
InstCo (Coercion -> Coercion -> Coercion)
-> Maybe Coercion -> Maybe (Coercion -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Maybe Coercion
setNominalRole_maybe_helper Coercion
co Maybe (Coercion -> Coercion) -> Maybe Coercion -> Maybe Coercion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Coercion -> Maybe Coercion
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coercion
arg
    setNominalRole_maybe_helper (UnivCo UnivCoProvenance
prov Role
_ Type
co1 Type
co2)
      | case UnivCoProvenance
prov of UnivCoProvenance
UnsafeCoerceProv -> Bool
True   -- it's always unsafe
                     PhantomProv Coercion
_    -> Bool
False  -- should always be phantom
                     ProofIrrelProv Coercion
_ -> Bool
True   -- it's always safe
                     PluginProv String
_     -> Bool
False  -- who knows? This choice is conservative.
      = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just (Coercion -> Maybe Coercion) -> Coercion -> Maybe Coercion
forall a b. (a -> b) -> a -> b
$ UnivCoProvenance -> Role -> Type -> Type -> Coercion
UnivCo UnivCoProvenance
prov Role
Nominal Type
co1 Type
co2
    setNominalRole_maybe_helper Coercion
_ = Maybe Coercion
forall a. Maybe a
Nothing

-- | Make a phantom coercion between two types. The coercion passed
-- in must be a nominal coercion between the kinds of the
-- types.
mkPhantomCo :: Coercion -> Type -> Type -> Coercion
mkPhantomCo :: Coercion -> Type -> Type -> Coercion
mkPhantomCo Coercion
h Type
t1 Type
t2
  = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkUnivCo (Coercion -> UnivCoProvenance
PhantomProv Coercion
h) Role
Phantom Type
t1 Type
t2

-- takes any coercion and turns it into a Phantom coercion
toPhantomCo :: Coercion -> Coercion
toPhantomCo :: Coercion -> Coercion
toPhantomCo Coercion
co
  = Coercion -> Type -> Type -> Coercion
mkPhantomCo (Coercion -> Coercion
mkKindCo Coercion
co) Type
ty1 Type
ty2
  where Pair Type
ty1 Type
ty2 = Coercion -> Pair Type
coercionKind Coercion
co

-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational
applyRoles :: TyCon -> [Coercion] -> [Coercion]
applyRoles :: TyCon -> [Coercion] -> [Coercion]
applyRoles TyCon
tc [Coercion]
cos
  = (Role -> Coercion -> Coercion)
-> [Role] -> [Coercion] -> [Coercion]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Role
r -> Role -> Role -> Coercion -> Coercion
downgradeRole Role
r Role
Nominal) (TyCon -> [Role]
tyConRolesRepresentational TyCon
tc) [Coercion]
cos

-- the Role parameter is the Role of the TyConAppCo
-- defined here because this is intimately concerned with the implementation
-- of TyConAppCo
-- Always returns an infinite list (with a infinite tail of Nominal)
tyConRolesX :: Role -> TyCon -> [Role]
tyConRolesX :: Role -> TyCon -> [Role]
tyConRolesX Role
Representational TyCon
tc = TyCon -> [Role]
tyConRolesRepresentational TyCon
tc
tyConRolesX Role
role             TyCon
_  = Role -> [Role]
forall a. a -> [a]
repeat Role
role

-- Returns the roles of the parameters of a tycon, with an infinite tail
-- of Nominal
tyConRolesRepresentational :: TyCon -> [Role]
tyConRolesRepresentational :: TyCon -> [Role]
tyConRolesRepresentational TyCon
tc = TyCon -> [Role]
tyConRoles TyCon
tc [Role] -> [Role] -> [Role]
forall a. [a] -> [a] -> [a]
++ Role -> [Role]
forall a. a -> [a]
repeat Role
Nominal

nthRole :: Role -> TyCon -> Int -> Role
nthRole :: Role -> TyCon -> Int -> Role
nthRole Role
Nominal TyCon
_ Int
_ = Role
Nominal
nthRole Role
Phantom TyCon
_ Int
_ = Role
Phantom
nthRole Role
Representational TyCon
tc Int
n
  = (TyCon -> [Role]
tyConRolesRepresentational TyCon
tc) [Role] -> Int -> Role
forall a. Outputable a => [a] -> Int -> a
`getNth` Int
n

ltRole :: Role -> Role -> Bool
-- Is one role "less" than another?
--     Nominal < Representational < Phantom
ltRole :: Role -> Role -> Bool
ltRole Role
Phantom          Role
_       = Bool
False
ltRole Role
Representational Role
Phantom = Bool
True
ltRole Role
Representational Role
_       = Bool
False
ltRole Role
Nominal          Role
Nominal = Bool
False
ltRole Role
Nominal          Role
_       = Bool
True

-------------------------------

-- | like mkKindCo, but aggressively & recursively optimizes to avoid using
-- a KindCo constructor. The output role is nominal.
promoteCoercion :: Coercion -> CoercionN

-- First cases handles anything that should yield refl.
promoteCoercion :: Coercion -> Coercion
promoteCoercion Coercion
co = case Coercion
co of

    Coercion
_ | Type
ki1 Type -> Type -> Bool
`eqType` Type
ki2
      -> Type -> Coercion
mkNomReflCo (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty1)
     -- no later branch should return refl
     --    The ASSERT( False )s throughout
     -- are these cases explicitly, but they should never fire.

    Refl Type
_ -> ASSERT( False )
              Type -> Coercion
mkNomReflCo Type
ki1

    GRefl Role
_ Type
_ MCoercion
MRefl -> ASSERT( False )
                       Type -> Coercion
mkNomReflCo Type
ki1

    GRefl Role
_ Type
_ (MCo Coercion
co) -> Coercion
co

    TyConAppCo Role
_ TyCon
tc [Coercion]
args
      | Just Coercion
co' <- Coercion -> [Coercion] -> Maybe Coercion
instCoercions (Type -> Coercion
mkNomReflCo (TyCon -> Type
tyConKind TyCon
tc)) [Coercion]
args
      -> Coercion
co'
      | Bool
otherwise
      -> Coercion -> Coercion
mkKindCo Coercion
co

    AppCo Coercion
co1 Coercion
arg
      | Just Coercion
co' <- Pair Type -> Coercion -> Coercion -> Maybe Coercion
instCoercion (Coercion -> Pair Type
coercionKind (Coercion -> Coercion
mkKindCo Coercion
co1))
                                 (Coercion -> Coercion
promoteCoercion Coercion
co1) Coercion
arg
      -> Coercion
co'
      | Bool
otherwise
      -> Coercion -> Coercion
mkKindCo Coercion
co

    ForAllCo CoVar
tv Coercion
_ Coercion
g
      | CoVar -> Bool
isTyVar CoVar
tv
      -> Coercion -> Coercion
promoteCoercion Coercion
g

    ForAllCo CoVar
_ Coercion
_ Coercion
_
      -> ASSERT( False )
         Type -> Coercion
mkNomReflCo Type
liftedTypeKind
      -- See Note [Weird typing rule for ForAllTy] in Type

    FunCo Role
_ Coercion
_ Coercion
_
      -> ASSERT( False )
         Type -> Coercion
mkNomReflCo Type
liftedTypeKind

    CoVarCo {}     -> Coercion -> Coercion
mkKindCo Coercion
co
    HoleCo {}      -> Coercion -> Coercion
mkKindCo Coercion
co
    AxiomInstCo {} -> Coercion -> Coercion
mkKindCo Coercion
co
    AxiomRuleCo {} -> Coercion -> Coercion
mkKindCo Coercion
co

    UnivCo UnivCoProvenance
UnsafeCoerceProv Role
_ Type
t1 Type
t2   -> Role -> Type -> Type -> Coercion
mkUnsafeCo Role
Nominal (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
t1) (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
t2)
    UnivCo (PhantomProv Coercion
kco) Role
_ Type
_ Type
_    -> Coercion
kco
    UnivCo (ProofIrrelProv Coercion
kco) Role
_ Type
_ Type
_ -> Coercion
kco
    UnivCo (PluginProv String
_) Role
_ Type
_ Type
_       -> Coercion -> Coercion
mkKindCo Coercion
co

    SymCo Coercion
g
      -> Coercion -> Coercion
mkSymCo (Coercion -> Coercion
promoteCoercion Coercion
g)

    TransCo Coercion
co1 Coercion
co2
      -> Coercion -> Coercion -> Coercion
mkTransCo (Coercion -> Coercion
promoteCoercion Coercion
co1) (Coercion -> Coercion
promoteCoercion Coercion
co2)

    NthCo Role
_ Int
n Coercion
co1
      | Just (TyCon
_, [Coercion]
args) <- Coercion -> Maybe (TyCon, [Coercion])
splitTyConAppCo_maybe Coercion
co1
      , [Coercion]
args [Coercion] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
n
      -> Coercion -> Coercion
promoteCoercion ([Coercion]
args [Coercion] -> Int -> Coercion
forall a. [a] -> Int -> a
!! Int
n)

      | Just (CoVar, Coercion, Coercion)
_ <- Coercion -> Maybe (CoVar, Coercion, Coercion)
splitForAllCo_maybe Coercion
co
      , Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      -> ASSERT( False ) mkNomReflCo liftedTypeKind

      | Bool
otherwise
      -> Coercion -> Coercion
mkKindCo Coercion
co

    LRCo LeftOrRight
lr Coercion
co1
      | Just (Coercion
lco, Coercion
rco) <- Coercion -> Maybe (Coercion, Coercion)
splitAppCo_maybe Coercion
co1
      -> case LeftOrRight
lr of
           LeftOrRight
CLeft  -> Coercion -> Coercion
promoteCoercion Coercion
lco
           LeftOrRight
CRight -> Coercion -> Coercion
promoteCoercion Coercion
rco

      | Bool
otherwise
      -> Coercion -> Coercion
mkKindCo Coercion
co

    InstCo Coercion
g Coercion
_
      | Type -> Bool
isForAllTy_ty Type
ty1
      -> ASSERT( isForAllTy_ty ty2 )
         Coercion -> Coercion
promoteCoercion Coercion
g
      | Bool
otherwise
      -> ASSERT( False)
         Type -> Coercion
mkNomReflCo Type
liftedTypeKind
           -- See Note [Weird typing rule for ForAllTy] in Type

    KindCo Coercion
_
      -> ASSERT( False )
         Type -> Coercion
mkNomReflCo Type
liftedTypeKind

    SubCo Coercion
g
      -> Coercion -> Coercion
promoteCoercion Coercion
g

  where
    Pair Type
ty1 Type
ty2 = Coercion -> Pair Type
coercionKind Coercion
co
    ki1 :: Type
ki1 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty1
    ki2 :: Type
ki2 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty2

-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@,
-- where @g' = promoteCoercion (h w)@.
-- fails if this is not possible, if @g@ coerces between a forall and an ->
-- or if second parameter has a representational role and can't be used
-- with an InstCo.
instCoercion :: Pair Type -- g :: lty ~ rty
             -> CoercionN  -- ^  must be nominal
             -> Coercion
             -> Maybe CoercionN
instCoercion :: Pair Type -> Coercion -> Coercion -> Maybe Coercion
instCoercion (Pair Type
lty Type
rty) Coercion
g Coercion
w
  | (Type -> Bool
isForAllTy_ty Type
lty Bool -> Bool -> Bool
&& Type -> Bool
isForAllTy_ty Type
rty)
  Bool -> Bool -> Bool
|| (Type -> Bool
isForAllTy_co Type
lty Bool -> Bool -> Bool
&& Type -> Bool
isForAllTy_co Type
rty)
  , Just Coercion
w' <- Role -> Coercion -> Maybe Coercion
setNominalRole_maybe (Coercion -> Role
coercionRole Coercion
w) Coercion
w
    -- g :: (forall t1. t2) ~ (forall t1. t3)
    -- w :: s1 ~ s2
    -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2]
  = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just (Coercion -> Maybe Coercion) -> Coercion -> Maybe Coercion
forall a b. (a -> b) -> a -> b
$ Coercion -> Coercion -> Coercion
mkInstCo Coercion
g Coercion
w'
  | Type -> Bool
isFunTy Type
lty Bool -> Bool -> Bool
&& Type -> Bool
isFunTy Type
rty
    -- g :: (t1 -> t2) ~ (t3 -> t4)
    -- returns t2 ~ t4
  = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just (Coercion -> Maybe Coercion) -> Coercion -> Maybe Coercion
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
Nominal Int
3 Coercion
g -- extract result type, which is the 4th argument to (->)
  | Bool
otherwise -- one forall, one funty...
  = Maybe Coercion
forall a. Maybe a
Nothing

-- | Repeated use of 'instCoercion'
instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN
instCoercions :: Coercion -> [Coercion] -> Maybe Coercion
instCoercions Coercion
g [Coercion]
ws
  = let arg_ty_pairs :: [Pair Type]
arg_ty_pairs = (Coercion -> Pair Type) -> [Coercion] -> [Pair Type]
forall a b. (a -> b) -> [a] -> [b]
map Coercion -> Pair Type
coercionKind [Coercion]
ws in
    (Pair Type, Coercion) -> Coercion
forall a b. (a, b) -> b
snd ((Pair Type, Coercion) -> Coercion)
-> Maybe (Pair Type, Coercion) -> Maybe Coercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Pair Type, Coercion)
 -> (Pair Type, Coercion) -> Maybe (Pair Type, Coercion))
-> (Pair Type, Coercion)
-> [(Pair Type, Coercion)]
-> Maybe (Pair Type, Coercion)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Pair Type, Coercion)
-> (Pair Type, Coercion) -> Maybe (Pair Type, Coercion)
go (Coercion -> Pair Type
coercionKind Coercion
g, Coercion
g) ([Pair Type] -> [Coercion] -> [(Pair Type, Coercion)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pair Type]
arg_ty_pairs [Coercion]
ws)
  where
    go :: (Pair Type, Coercion) -> (Pair Type, Coercion)
       -> Maybe (Pair Type, Coercion)
    go :: (Pair Type, Coercion)
-> (Pair Type, Coercion) -> Maybe (Pair Type, Coercion)
go (Pair Type
g_tys, Coercion
g) (Pair Type
w_tys, Coercion
w)
      = do { Coercion
g' <- Pair Type -> Coercion -> Coercion -> Maybe Coercion
instCoercion Pair Type
g_tys Coercion
g Coercion
w
           ; (Pair Type, Coercion) -> Maybe (Pair Type, Coercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
piResultTy (Type -> Type -> Type) -> Pair Type -> Pair (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pair Type
g_tys Pair (Type -> Type) -> Pair Type -> Pair Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pair Type
w_tys, Coercion
g') }

-- | Creates a new coercion with both of its types casted by different casts
-- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,
-- has type @(t1 |> h1) ~r (t2 |> h2)@.
-- @h1@ and @h2@ must be nominal.
castCoercionKind :: Coercion -> Role -> Type -> Type
                 -> CoercionN -> CoercionN -> Coercion
castCoercionKind :: Coercion
-> Role -> Type -> Type -> Coercion -> Coercion -> Coercion
castCoercionKind Coercion
g Role
r Type
t1 Type
t2 Coercion
h1 Coercion
h2
  = Role -> Type -> Coercion -> Coercion -> Coercion
mkCoherenceRightCo Role
r Type
t2 Coercion
h2 (Role -> Type -> Coercion -> Coercion -> Coercion
mkCoherenceLeftCo Role
r Type
t1 Coercion
h1 Coercion
g)

-- | Creates a new coercion with both of its types casted by different casts
-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@,
-- has type @(t1 |> h1) ~r (t2 |> h2)@.
-- @h1@ and @h2@ must be nominal.
-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for)
-- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand.
castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion
castCoercionKindI :: Coercion -> Coercion -> Coercion -> Coercion
castCoercionKindI Coercion
g Coercion
h1 Coercion
h2
  = Role -> Type -> Coercion -> Coercion -> Coercion
mkCoherenceRightCo Role
r Type
t2 Coercion
h2 (Role -> Type -> Coercion -> Coercion -> Coercion
mkCoherenceLeftCo Role
r Type
t1 Coercion
h1 Coercion
g)
  where (Pair Type
t1 Type
t2, Role
r) = Coercion -> (Pair Type, Role)
coercionKindRole Coercion
g

-- See note [Newtype coercions] in TyCon

mkPiCos :: Role -> [Var] -> Coercion -> Coercion
mkPiCos :: Role -> [CoVar] -> Coercion -> Coercion
mkPiCos Role
r [CoVar]
vs Coercion
co = (CoVar -> Coercion -> Coercion) -> Coercion -> [CoVar] -> Coercion
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Role -> CoVar -> Coercion -> Coercion
mkPiCo Role
r) Coercion
co [CoVar]
vs

-- | Make a forall 'Coercion', where both types related by the coercion
-- are quantified over the same variable.
mkPiCo  :: Role -> Var -> Coercion -> Coercion
mkPiCo :: Role -> CoVar -> Coercion -> Coercion
mkPiCo Role
r CoVar
v Coercion
co | CoVar -> Bool
isTyVar CoVar
v = [CoVar] -> Coercion -> Coercion
mkHomoForAllCos [CoVar
v] Coercion
co
              | CoVar -> Bool
isCoVar CoVar
v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) )
                  -- We didn't call mkForAllCo here because if v does not appear
                  -- in co, the argement coercion will be nominal. But here we
                  -- want it to be r. It is only called in 'mkPiCos', which is
                  -- only used in SimplUtils, where we are sure for
                  -- now (Aug 2018) v won't occur in co.
                            Role -> Coercion -> Coercion -> Coercion
mkFunCo Role
r (Role -> Type -> Coercion
mkReflCo Role
r (CoVar -> Type
varType CoVar
v)) Coercion
co
              | Bool
otherwise = Role -> Coercion -> Coercion -> Coercion
mkFunCo Role
r (Role -> Type -> Coercion
mkReflCo Role
r (CoVar -> Type
varType CoVar
v)) Coercion
co

-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2
-- The first coercion might be lifted or unlifted; thus the ~? above
-- Lifted and unlifted equalities take different numbers of arguments,
-- so we have to make sure to supply the right parameter to decomposeCo.
-- Also, note that the role of the first coercion is the same as the role of
-- the equalities related by the second coercion. The second coercion is
-- itself always representational.
mkCoCast :: Coercion -> CoercionR -> Coercion
mkCoCast :: Coercion -> Coercion -> Coercion
mkCoCast Coercion
c Coercion
g
  | (Coercion
g2:Coercion
g1:[Coercion]
_) <- [Coercion] -> [Coercion]
forall a. [a] -> [a]
reverse [Coercion]
co_list
  = Coercion -> Coercion
mkSymCo Coercion
g1 Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
c Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
g2

  | Bool
otherwise
  = String -> SDoc -> Coercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkCoCast" (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
g SDoc -> SDoc -> SDoc
$$ Pair Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Pair Type
coercionKind Coercion
g))
  where
    -- g  :: (s1 ~# t1) ~# (s2 ~# t2)
    -- g1 :: s1 ~# s2
    -- g2 :: t1 ~# t2
    (TyCon
tc, [Type]
_) = Type -> (TyCon, [Type])
splitTyConApp (Pair Type -> Type
forall a. Pair a -> a
pFst (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
g)
    co_list :: [Coercion]
co_list = Int -> Coercion -> [Role] -> [Coercion]
decomposeCo (TyCon -> Int
tyConArity TyCon
tc) Coercion
g (TyCon -> [Role]
tyConRolesRepresentational TyCon
tc)

{-
%************************************************************************
%*                                                                      *
            Newtypes
%*                                                                      *
%************************************************************************
-}

-- | If @co :: T ts ~ rep_ty@ then:
--
-- > instNewTyCon_maybe T ts = Just (rep_ty, co)
--
-- Checks for a newtype, and for being saturated
instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)
instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)
instNewTyCon_maybe TyCon
tc [Type]
tys
  | Just ([CoVar]
tvs, Type
ty, CoAxiom Unbranched
co_tc) <- TyCon -> Maybe ([CoVar], Type, CoAxiom Unbranched)
unwrapNewTyConEtad_maybe TyCon
tc  -- Check for newtype
  , [CoVar]
tvs [CoVar] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
`leLength` [Type]
tys                                    -- Check saturated enough
  = (Type, Coercion) -> Maybe (Type, Coercion)
forall a. a -> Maybe a
Just ([CoVar] -> Type -> [Type] -> Type
applyTysX [CoVar]
tvs Type
ty [Type]
tys, Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational CoAxiom Unbranched
co_tc [Type]
tys [])
  | Bool
otherwise
  = Maybe (Type, Coercion)
forall a. Maybe a
Nothing

{-
************************************************************************
*                                                                      *
         Type normalisation
*                                                                      *
************************************************************************
-}

-- | A function to check if we can reduce a type by one step. Used
-- with 'topNormaliseTypeX'.
type NormaliseStepper ev = RecTcChecker
                         -> TyCon     -- tc
                         -> [Type]    -- tys
                         -> NormaliseStepResult ev

-- | The result of stepping in a normalisation function.
-- See 'topNormaliseTypeX'.
data NormaliseStepResult ev
  = NS_Done   -- ^ Nothing more to do
  | NS_Abort  -- ^ Utter failure. The outer function should fail too.
  | NS_Step RecTcChecker Type ev    -- ^ We stepped, yielding new bits;
                                    -- ^ ev is evidence;
                                    -- Usually a co :: old type ~ new type

mapStepResult :: (ev1 -> ev2)
              -> NormaliseStepResult ev1 -> NormaliseStepResult ev2
mapStepResult :: (ev1 -> ev2) -> NormaliseStepResult ev1 -> NormaliseStepResult ev2
mapStepResult ev1 -> ev2
f (NS_Step RecTcChecker
rec_nts Type
ty ev1
ev) = RecTcChecker -> Type -> ev2 -> NormaliseStepResult ev2
forall ev. RecTcChecker -> Type -> ev -> NormaliseStepResult ev
NS_Step RecTcChecker
rec_nts Type
ty (ev1 -> ev2
f ev1
ev)
mapStepResult ev1 -> ev2
_ NormaliseStepResult ev1
NS_Done                 = NormaliseStepResult ev2
forall ev. NormaliseStepResult ev
NS_Done
mapStepResult ev1 -> ev2
_ NormaliseStepResult ev1
NS_Abort                = NormaliseStepResult ev2
forall ev. NormaliseStepResult ev
NS_Abort

-- | Try one stepper and then try the next, if the first doesn't make
-- progress.
-- So if it returns NS_Done, it means that both steppers are satisfied
composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev
                -> NormaliseStepper ev
composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev -> NormaliseStepper ev
composeSteppers NormaliseStepper ev
step1 NormaliseStepper ev
step2 RecTcChecker
rec_nts TyCon
tc [Type]
tys
  = case NormaliseStepper ev
step1 RecTcChecker
rec_nts TyCon
tc [Type]
tys of
      success :: NormaliseStepResult ev
success@(NS_Step {}) -> NormaliseStepResult ev
success
      NormaliseStepResult ev
NS_Done              -> NormaliseStepper ev
step2 RecTcChecker
rec_nts TyCon
tc [Type]
tys
      NormaliseStepResult ev
NS_Abort             -> NormaliseStepResult ev
forall ev. NormaliseStepResult ev
NS_Abort

-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into
-- a loop. If it would fall into a loop, it produces 'NS_Abort'.
unwrapNewTypeStepper :: NormaliseStepper Coercion
unwrapNewTypeStepper :: NormaliseStepper Coercion
unwrapNewTypeStepper RecTcChecker
rec_nts TyCon
tc [Type]
tys
  | Just (Type
ty', Coercion
co) <- TyCon -> [Type] -> Maybe (Type, Coercion)
instNewTyCon_maybe TyCon
tc [Type]
tys
  = case RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_nts TyCon
tc of
      Just RecTcChecker
rec_nts' -> RecTcChecker -> Type -> Coercion -> NormaliseStepResult Coercion
forall ev. RecTcChecker -> Type -> ev -> NormaliseStepResult ev
NS_Step RecTcChecker
rec_nts' Type
ty' Coercion
co
      Maybe RecTcChecker
Nothing       -> NormaliseStepResult Coercion
forall ev. NormaliseStepResult ev
NS_Abort

  | Bool
otherwise
  = NormaliseStepResult Coercion
forall ev. NormaliseStepResult ev
NS_Done

-- | A general function for normalising the top-level of a type. It continues
-- to use the provided 'NormaliseStepper' until that function fails, and then
-- this function returns. The roles of the coercions produced by the
-- 'NormaliseStepper' must all be the same, which is the role returned from
-- the call to 'topNormaliseTypeX'.
--
-- Typically ev is Coercion.
--
-- If topNormaliseTypeX step plus ty = Just (ev, ty')
-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty'
-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn
-- If it returns Nothing then no newtype unwrapping could happen
topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev)
                  -> Type -> Maybe (ev, Type)
topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev) -> Type -> Maybe (ev, Type)
topNormaliseTypeX NormaliseStepper ev
stepper ev -> ev -> ev
plus Type
ty
 | Just (TyCon
tc, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
 , NS_Step RecTcChecker
rec_nts Type
ty' ev
ev <- NormaliseStepper ev
stepper RecTcChecker
initRecTc TyCon
tc [Type]
tys
 = RecTcChecker -> ev -> Type -> Maybe (ev, Type)
go RecTcChecker
rec_nts ev
ev Type
ty'
 | Bool
otherwise
 = Maybe (ev, Type)
forall a. Maybe a
Nothing
 where
    go :: RecTcChecker -> ev -> Type -> Maybe (ev, Type)
go RecTcChecker
rec_nts ev
ev Type
ty
      | Just (TyCon
tc, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
      = case NormaliseStepper ev
stepper RecTcChecker
rec_nts TyCon
tc [Type]
tys of
          NS_Step RecTcChecker
rec_nts' Type
ty' ev
ev' -> RecTcChecker -> ev -> Type -> Maybe (ev, Type)
go RecTcChecker
rec_nts' (ev
ev ev -> ev -> ev
`plus` ev
ev') Type
ty'
          NormaliseStepResult ev
NS_Done  -> (ev, Type) -> Maybe (ev, Type)
forall a. a -> Maybe a
Just (ev
ev, Type
ty)
          NormaliseStepResult ev
NS_Abort -> Maybe (ev, Type)
forall a. Maybe a
Nothing

      | Bool
otherwise
      = (ev, Type) -> Maybe (ev, Type)
forall a. a -> Maybe a
Just (ev
ev, Type
ty)

topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)
-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion.
-- This function strips off @newtype@ layers enough to reveal something that isn't
-- a @newtype@.  Specifically, here's the invariant:
--
-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty')
--
-- then (a)  @co : ty0 ~ ty'@.
--      (b)  ty' is not a newtype.
--
-- The function returns @Nothing@ for non-@newtypes@,
-- or unsaturated applications
--
-- This function does *not* look through type families, because it has no access to
-- the type family environment. If you do have that at hand, consider to use
-- topNormaliseType_maybe, which should be a drop-in replacement for
-- topNormaliseNewType_maybe
-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty'
topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
ty
  = NormaliseStepper Coercion
-> (Coercion -> Coercion -> Coercion)
-> Type
-> Maybe (Coercion, Type)
forall ev.
NormaliseStepper ev -> (ev -> ev -> ev) -> Type -> Maybe (ev, Type)
topNormaliseTypeX NormaliseStepper Coercion
unwrapNewTypeStepper Coercion -> Coercion -> Coercion
mkTransCo Type
ty

{-
%************************************************************************
%*                                                                      *
                   Comparison of coercions
%*                                                                      *
%************************************************************************
-}

-- | Syntactic equality of coercions
eqCoercion :: Coercion -> Coercion -> Bool
eqCoercion :: Coercion -> Coercion -> Bool
eqCoercion = Type -> Type -> Bool
eqType (Type -> Type -> Bool)
-> (Coercion -> Type) -> Coercion -> Coercion -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Coercion -> Type
coercionType

-- | Compare two 'Coercion's, with respect to an RnEnv2
eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env = RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env (Type -> Type -> Bool)
-> (Coercion -> Type) -> Coercion -> Coercion -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Coercion -> Type
coercionType

{-
%************************************************************************
%*                                                                      *
                   "Lifting" substitution
           [(TyCoVar,Coercion)] -> Type -> Coercion
%*                                                                      *
%************************************************************************

Note [Lifting coercions over types: liftCoSubst]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The KPUSH rule deals with this situation
   data T a = K (a -> Maybe a)
   g :: T t1 ~ T t2
   x :: t1 -> Maybe t1

   case (K @t1 x) |> g of
     K (y:t2 -> Maybe t2) -> rhs

We want to push the coercion inside the constructor application.
So we do this

   g' :: t1~t2  =  Nth 0 g

   case K @t2 (x |> g' -> Maybe g') of
     K (y:t2 -> Maybe t2) -> rhs

The crucial operation is that we
  * take the type of K's argument: a -> Maybe a
  * and substitute g' for a
thus giving *coercion*.  This is what liftCoSubst does.

In the presence of kind coercions, this is a bit
of a hairy operation. So, we refer you to the paper introducing kind coercions,
available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf

Note [extendLiftingContextEx]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider we have datatype
  K :: \/k. \/a::k. P -> T k  -- P be some type
  g :: T k1 ~ T k2

  case (K @k1 @t1 x) |> g of
    K y -> rhs

We want to push the coercion inside the constructor application.
We first get the coercion mapped by the universal type variable k:
   lc = k |-> Nth 0 g :: k1~k2

Here, the important point is that the kind of a is coerced, and P might be
dependent on the existential type variable a.
Thus we first get the coercion of a's kind
   g2 = liftCoSubst lc k :: k1 ~ k2

Then we store a new mapping into the lifting context
   lc2 = a |-> (t1 ~ t1 |> g2), lc

So later when we can correctly deal with the argument type P
   liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)]

This is exactly what extendLiftingContextEx does.
* For each (tyvar:k, ty) pair, we product the mapping
    tyvar |-> (ty ~ ty |> (liftCoSubst lc k))
* For each (covar:s1~s2, ty) pair, we produce the mapping
    covar |-> (co ~ co')
    co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2'

This follows the lifting context extension definition in the
"FC with Explicit Kind Equality" paper.
-}

-- ----------------------------------------------------
-- See Note [Lifting coercions over types: liftCoSubst]
-- ----------------------------------------------------

data LiftingContext = LC TCvSubst LiftCoEnv
  -- in optCoercion, we need to lift when optimizing InstCo.
  -- See Note [Optimising InstCo] in OptCoercion
  -- We thus propagate the substitution from OptCoercion here.

instance Outputable LiftingContext where
  ppr :: LiftingContext -> SDoc
ppr (LC TCvSubst
_ LiftCoEnv
env) = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"LiftingContext:") Int
2 (LiftCoEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr LiftCoEnv
env)

type LiftCoEnv = VarEnv Coercion
     -- Maps *type variables* to *coercions*.
     -- That's the whole point of this function!
     -- Also maps coercion variables to ProofIrrelCos.

-- like liftCoSubstWith, but allows for existentially-bound types as well
liftCoSubstWithEx :: Role          -- desired role for output coercion
                  -> [TyVar]       -- universally quantified tyvars
                  -> [Coercion]    -- coercions to substitute for those
                  -> [TyCoVar]     -- existentially quantified tycovars
                  -> [Type]        -- types and coercions to be bound to ex vars
                  -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args)
liftCoSubstWithEx :: Role
-> [CoVar]
-> [Coercion]
-> [CoVar]
-> [Type]
-> (Type -> Coercion, [Type])
liftCoSubstWithEx Role
role [CoVar]
univs [Coercion]
omegas [CoVar]
exs [Type]
rhos
  = let theta :: LiftingContext
theta = [(CoVar, Coercion)] -> LiftingContext
mkLiftingContext (String -> [CoVar] -> [Coercion] -> [(CoVar, Coercion)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"liftCoSubstWithExU" [CoVar]
univs [Coercion]
omegas)
        psi :: LiftingContext
psi   = LiftingContext -> [(CoVar, Type)] -> LiftingContext
extendLiftingContextEx LiftingContext
theta (String -> [CoVar] -> [Type] -> [(CoVar, Type)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"liftCoSubstWithExX" [CoVar]
exs [Type]
rhos)
    in (LiftingContext -> Role -> Type -> Coercion
ty_co_subst LiftingContext
psi Role
role, HasCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys (LiftingContext -> TCvSubst
lcSubstRight LiftingContext
psi) ([CoVar] -> [Type]
mkTyCoVarTys [CoVar]
exs))

liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion
liftCoSubstWith :: Role -> [CoVar] -> [Coercion] -> Type -> Coercion
liftCoSubstWith Role
r [CoVar]
tvs [Coercion]
cos Type
ty
  = HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
Role -> LiftingContext -> Type -> Coercion
liftCoSubst Role
r ([(CoVar, Coercion)] -> LiftingContext
mkLiftingContext ([(CoVar, Coercion)] -> LiftingContext)
-> [(CoVar, Coercion)] -> LiftingContext
forall a b. (a -> b) -> a -> b
$ String -> [CoVar] -> [Coercion] -> [(CoVar, Coercion)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"liftCoSubstWith" [CoVar]
tvs [Coercion]
cos) Type
ty

-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@)
-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where
-- @lc_left@ is a substitution mapping type variables to the left-hand
-- types of the mapped coercions in @lc@, and similar for @lc_right@.
liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
liftCoSubst :: Role -> LiftingContext -> Type -> Coercion
liftCoSubst Role
r lc :: LiftingContext
lc@(LC TCvSubst
subst LiftCoEnv
env) Type
ty
  | LiftCoEnv -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv LiftCoEnv
env = Role -> Type -> Coercion
mkReflCo Role
r (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
ty)
  | Bool
otherwise         = LiftingContext -> Role -> Type -> Coercion
ty_co_subst LiftingContext
lc Role
r Type
ty

emptyLiftingContext :: InScopeSet -> LiftingContext
emptyLiftingContext :: InScopeSet -> LiftingContext
emptyLiftingContext InScopeSet
in_scope = TCvSubst -> LiftCoEnv -> LiftingContext
LC (InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope) LiftCoEnv
forall a. VarEnv a
emptyVarEnv

mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext
mkLiftingContext :: [(CoVar, Coercion)] -> LiftingContext
mkLiftingContext [(CoVar, Coercion)]
pairs
  = TCvSubst -> LiftCoEnv -> LiftingContext
LC (InScopeSet -> TCvSubst
mkEmptyTCvSubst (InScopeSet -> TCvSubst) -> InScopeSet -> TCvSubst
forall a b. (a -> b) -> a -> b
$ VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [Coercion] -> VarSet
tyCoVarsOfCos (((CoVar, Coercion) -> Coercion)
-> [(CoVar, Coercion)] -> [Coercion]
forall a b. (a -> b) -> [a] -> [b]
map (CoVar, Coercion) -> Coercion
forall a b. (a, b) -> b
snd [(CoVar, Coercion)]
pairs))
       ([(CoVar, Coercion)] -> LiftCoEnv
forall a. [(CoVar, a)] -> VarEnv a
mkVarEnv [(CoVar, Coercion)]
pairs)

mkSubstLiftingContext :: TCvSubst -> LiftingContext
mkSubstLiftingContext :: TCvSubst -> LiftingContext
mkSubstLiftingContext TCvSubst
subst = TCvSubst -> LiftCoEnv -> LiftingContext
LC TCvSubst
subst LiftCoEnv
forall a. VarEnv a
emptyVarEnv

-- | Extend a lifting context with a new mapping.
extendLiftingContext :: LiftingContext  -- ^ original LC
                     -> TyCoVar         -- ^ new variable to map...
                     -> Coercion        -- ^ ...to this lifted version
                     -> LiftingContext
    -- mappings to reflexive coercions are just substitutions
extendLiftingContext :: LiftingContext -> CoVar -> Coercion -> LiftingContext
extendLiftingContext (LC TCvSubst
subst LiftCoEnv
env) CoVar
tv Coercion
arg
  | Just (Type
ty, Role
_) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
arg
  = TCvSubst -> LiftCoEnv -> LiftingContext
LC (TCvSubst -> CoVar -> Type -> TCvSubst
extendTCvSubst TCvSubst
subst CoVar
tv Type
ty) LiftCoEnv
env
  | Bool
otherwise
  = TCvSubst -> LiftCoEnv -> LiftingContext
LC TCvSubst
subst (LiftCoEnv -> CoVar -> Coercion -> LiftCoEnv
forall a. VarEnv a -> CoVar -> a -> VarEnv a
extendVarEnv LiftCoEnv
env CoVar
tv Coercion
arg)

-- | Extend a lifting context with a new mapping, and extend the in-scope set
extendLiftingContextAndInScope :: LiftingContext  -- ^ Original LC
                               -> TyCoVar         -- ^ new variable to map...
                               -> Coercion        -- ^ to this coercion
                               -> LiftingContext
extendLiftingContextAndInScope :: LiftingContext -> CoVar -> Coercion -> LiftingContext
extendLiftingContextAndInScope (LC TCvSubst
subst LiftCoEnv
env) CoVar
tv Coercion
co
  = LiftingContext -> CoVar -> Coercion -> LiftingContext
extendLiftingContext (TCvSubst -> LiftCoEnv -> LiftingContext
LC (TCvSubst -> VarSet -> TCvSubst
extendTCvInScopeSet TCvSubst
subst (Coercion -> VarSet
tyCoVarsOfCo Coercion
co)) LiftCoEnv
env) CoVar
tv Coercion
co

-- | Extend a lifting context with existential-variable bindings.
-- See Note [extendLiftingContextEx]
extendLiftingContextEx :: LiftingContext    -- ^ original lifting context
                       -> [(TyCoVar,Type)]  -- ^ ex. var / value pairs
                       -> LiftingContext
-- Note that this is more involved than extendLiftingContext. That function
-- takes a coercion to extend with, so it's assumed that the caller has taken
-- into account any of the kind-changing stuff worried about here.
extendLiftingContextEx :: LiftingContext -> [(CoVar, Type)] -> LiftingContext
extendLiftingContextEx LiftingContext
lc [] = LiftingContext
lc
extendLiftingContextEx lc :: LiftingContext
lc@(LC TCvSubst
subst LiftCoEnv
env) ((CoVar
v,Type
ty):[(CoVar, Type)]
rest)
-- This function adds bindings for *Nominal* coercions. Why? Because it
-- works with existentially bound variables, which are considered to have
-- nominal roles.
  | CoVar -> Bool
isTyVar CoVar
v
  = let lc' :: LiftingContext
lc' = TCvSubst -> LiftCoEnv -> LiftingContext
LC (TCvSubst
subst TCvSubst -> VarSet -> TCvSubst
`extendTCvInScopeSet` Type -> VarSet
tyCoVarsOfType Type
ty)
                 (LiftCoEnv -> CoVar -> Coercion -> LiftCoEnv
forall a. VarEnv a -> CoVar -> a -> VarEnv a
extendVarEnv LiftCoEnv
env CoVar
v (Coercion -> LiftCoEnv) -> Coercion -> LiftCoEnv
forall a b. (a -> b) -> a -> b
$
                  Role -> Type -> Coercion -> Coercion
mkGReflRightCo Role
Nominal
                                 Type
ty
                                 (LiftingContext -> Role -> Type -> Coercion
ty_co_subst LiftingContext
lc Role
Nominal (CoVar -> Type
tyVarKind CoVar
v)))
    in LiftingContext -> [(CoVar, Type)] -> LiftingContext
extendLiftingContextEx LiftingContext
lc' [(CoVar, Type)]
rest
  | CoercionTy Coercion
co <- Type
ty
  = -- co      :: s1 ~r s2
    -- lift_s1 :: s1 ~r s1'
    -- lift_s2 :: s2 ~r s2'
    -- kco     :: (s1 ~r s2) ~N (s1' ~r s2')
    ASSERT( isCoVar v )
    let (Type
_, Type
_, Type
s1, Type
s2, Role
r) = HasDebugCallStack => CoVar -> (Type, Type, Type, Type, Role)
CoVar -> (Type, Type, Type, Type, Role)
coVarKindsTypesRole CoVar
v
        lift_s1 :: Coercion
lift_s1 = LiftingContext -> Role -> Type -> Coercion
ty_co_subst LiftingContext
lc Role
r Type
s1
        lift_s2 :: Coercion
lift_s2 = LiftingContext -> Role -> Type -> Coercion
ty_co_subst LiftingContext
lc Role
r Type
s2
        kco :: Coercion
kco     = HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
Nominal (Role -> TyCon
equalityTyCon Role
r)
                               [ Coercion -> Coercion
mkKindCo Coercion
lift_s1, Coercion -> Coercion
mkKindCo Coercion
lift_s2
                               , Coercion
lift_s1         , Coercion
lift_s2          ]
        lc' :: LiftingContext
lc'     = TCvSubst -> LiftCoEnv -> LiftingContext
LC (TCvSubst
subst TCvSubst -> VarSet -> TCvSubst
`extendTCvInScopeSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
co)
                     (LiftCoEnv -> CoVar -> Coercion -> LiftCoEnv
forall a. VarEnv a -> CoVar -> a -> VarEnv a
extendVarEnv LiftCoEnv
env CoVar
v
                        (Role -> Coercion -> Coercion -> Coercion -> Coercion
mkProofIrrelCo Role
Nominal Coercion
kco Coercion
co (Coercion -> Coercion) -> Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$
                          (Coercion -> Coercion
mkSymCo Coercion
lift_s1) Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
lift_s2))
    in LiftingContext -> [(CoVar, Type)] -> LiftingContext
extendLiftingContextEx LiftingContext
lc' [(CoVar, Type)]
rest
  | Bool
otherwise
  = String -> SDoc -> LiftingContext
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"extendLiftingContextEx" (CoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoVar
v SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"|->" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)


-- | Erase the environments in a lifting context
zapLiftingContext :: LiftingContext -> LiftingContext
zapLiftingContext :: LiftingContext -> LiftingContext
zapLiftingContext (LC TCvSubst
subst LiftCoEnv
_) = TCvSubst -> LiftCoEnv -> LiftingContext
LC (TCvSubst -> TCvSubst
zapTCvSubst TCvSubst
subst) LiftCoEnv
forall a. VarEnv a
emptyVarEnv

-- | Like 'substForAllCoBndr', but works on a lifting context
substForAllCoBndrUsingLC :: Bool
                            -> (Coercion -> Coercion)
                            -> LiftingContext -> TyCoVar -> Coercion
                            -> (LiftingContext, TyCoVar, Coercion)
substForAllCoBndrUsingLC :: Bool
-> (Coercion -> Coercion)
-> LiftingContext
-> CoVar
-> Coercion
-> (LiftingContext, CoVar, Coercion)
substForAllCoBndrUsingLC Bool
sym Coercion -> Coercion
sco (LC TCvSubst
subst LiftCoEnv
lc_env) CoVar
tv Coercion
co
  = (TCvSubst -> LiftCoEnv -> LiftingContext
LC TCvSubst
subst' LiftCoEnv
lc_env, CoVar
tv', Coercion
co')
  where
    (TCvSubst
subst', CoVar
tv', Coercion
co') = Bool
-> (Coercion -> Coercion)
-> TCvSubst
-> CoVar
-> Coercion
-> (TCvSubst, CoVar, Coercion)
substForAllCoBndrUsing Bool
sym Coercion -> Coercion
sco TCvSubst
subst CoVar
tv Coercion
co

-- | The \"lifting\" operation which substitutes coercions for type
--   variables in a type to produce a coercion.
--
--   For the inverse operation, see 'liftCoMatch'
ty_co_subst :: LiftingContext -> Role -> Type -> Coercion
ty_co_subst :: LiftingContext -> Role -> Type -> Coercion
ty_co_subst LiftingContext
lc Role
role Type
ty
  = Role -> Type -> Coercion
go Role
role Type
ty
  where
    go :: Role -> Type -> Coercion
    go :: Role -> Type -> Coercion
go Role
r Type
ty                | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
                           = Role -> Type -> Coercion
go Role
r Type
ty'
    go Role
Phantom Type
ty          = Type -> Coercion
lift_phantom Type
ty
    go Role
r (TyVarTy CoVar
tv)      = String -> Maybe Coercion -> Coercion
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"ty_co_subst bad roles" (Maybe Coercion -> Coercion) -> Maybe Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$
                             LiftingContext -> Role -> CoVar -> Maybe Coercion
liftCoSubstTyVar LiftingContext
lc Role
r CoVar
tv
    go Role
r (AppTy Type
ty1 Type
ty2)   = Coercion -> Coercion -> Coercion
mkAppCo (Role -> Type -> Coercion
go Role
r Type
ty1) (Role -> Type -> Coercion
go Role
Nominal Type
ty2)
    go Role
r (TyConApp TyCon
tc [Type]
tys) = HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
r TyCon
tc ((Role -> Type -> Coercion) -> [Role] -> [Type] -> [Coercion]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Role -> Type -> Coercion
go (Role -> TyCon -> [Role]
tyConRolesX Role
r TyCon
tc) [Type]
tys)
    go Role
r (FunTy AnonArgFlag
_ Type
ty1 Type
ty2) = Role -> Coercion -> Coercion -> Coercion
mkFunCo Role
r (Role -> Type -> Coercion
go Role
r Type
ty1) (Role -> Type -> Coercion
go Role
r Type
ty2)
    go Role
r t :: Type
t@(ForAllTy (Bndr CoVar
v ArgFlag
_) Type
ty)
       = let (LiftingContext
lc', CoVar
v', Coercion
h) = LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion)
liftCoSubstVarBndr LiftingContext
lc CoVar
v
             body_co :: Coercion
body_co = LiftingContext -> Role -> Type -> Coercion
ty_co_subst LiftingContext
lc' Role
r Type
ty in
         if CoVar -> Bool
isTyVar CoVar
v' Bool -> Bool -> Bool
|| CoVar -> Coercion -> Bool
almostDevoidCoVarOfCo CoVar
v' Coercion
body_co
           -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo
           -- imposes an extra restriction on where a covar can appear. See last
           -- wrinkle in Note [Unused coercion variable in ForAllCo].
           -- We specifically check for this and panic because we know that
           -- there's a hole in the type system here, and we'd rather panic than
           -- fall into it.
         then CoVar -> Coercion -> Coercion -> Coercion
mkForAllCo CoVar
v' Coercion
h Coercion
body_co
         else String -> SDoc -> Coercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"ty_co_subst: covar is not almost devoid" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t)
    go Role
r ty :: Type
ty@(LitTy {})     = ASSERT( r == Nominal )
                             Type -> Coercion
mkNomReflCo Type
ty
    go Role
r (CastTy Type
ty Coercion
co)    = Coercion -> Coercion -> Coercion -> Coercion
castCoercionKindI (Role -> Type -> Coercion
go Role
r Type
ty) (LiftingContext -> Coercion -> Coercion
substLeftCo LiftingContext
lc Coercion
co)
                                                         (LiftingContext -> Coercion -> Coercion
substRightCo LiftingContext
lc Coercion
co)
    go Role
r (CoercionTy Coercion
co)   = Role -> Coercion -> Coercion -> Coercion -> Coercion
mkProofIrrelCo Role
r Coercion
kco (LiftingContext -> Coercion -> Coercion
substLeftCo LiftingContext
lc Coercion
co)
                                                  (LiftingContext -> Coercion -> Coercion
substRightCo LiftingContext
lc Coercion
co)
      where kco :: Coercion
kco = Role -> Type -> Coercion
go Role
Nominal (Coercion -> Type
coercionType Coercion
co)

    lift_phantom :: Type -> Coercion
lift_phantom Type
ty = Coercion -> Type -> Type -> Coercion
mkPhantomCo (Role -> Type -> Coercion
go Role
Nominal (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty))
                                  (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy (LiftingContext -> TCvSubst
lcSubstLeft  LiftingContext
lc) Type
ty)
                                  (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy (LiftingContext -> TCvSubst
lcSubstRight LiftingContext
lc) Type
ty)

{-
Note [liftCoSubstTyVar]
~~~~~~~~~~~~~~~~~~~~~~~~~
This function can fail if a coercion in the environment is of too low a role.

liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and
also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting
lemma guarantees that the roles work out. If we fail in this
case, we really should panic -- something is deeply wrong. But, in matchAxiom,
failing is fine. matchAxiom is trying to find a set of coercions
that match, but it may fail, and this is healthy behavior.
-}

-- See Note [liftCoSubstTyVar]
liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion
liftCoSubstTyVar :: LiftingContext -> Role -> CoVar -> Maybe Coercion
liftCoSubstTyVar (LC TCvSubst
subst LiftCoEnv
env) Role
r CoVar
v
  | Just Coercion
co_arg <- LiftCoEnv -> CoVar -> Maybe Coercion
forall a. VarEnv a -> CoVar -> Maybe a
lookupVarEnv LiftCoEnv
env CoVar
v
  = Role -> Role -> Coercion -> Maybe Coercion
downgradeRole_maybe Role
r (Coercion -> Role
coercionRole Coercion
co_arg) Coercion
co_arg

  | Bool
otherwise
  = Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just (Coercion -> Maybe Coercion) -> Coercion -> Maybe Coercion
forall a b. (a -> b) -> a -> b
$ Role -> Type -> Coercion
mkReflCo Role
r (TCvSubst -> CoVar -> Type
substTyVar TCvSubst
subst CoVar
v)

{- Note [liftCoSubstVarBndr]

callback:
  We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in
  FamInstEnv, therefore the input arg 'fun' returns a pair with polymophic type
  in snd.
  However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and
  ignore the fourth component of the return value.

liftCoSubstTyVarBndrUsing:
  Given
    forall tv:k. t
  We want to get
    forall (tv:k1) (kind_co :: k1 ~ k2) body_co

  We lift the kind k to get the kind_co
    kind_co = ty_co_subst k :: k1 ~ k2

  Now in the LiftingContext, we add the new mapping
    tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2)

liftCoSubstCoVarBndrUsing:
  Given
    forall cv:(s1 ~ s2). t
  We want to get
    forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co

  We lift s1 and s2 respectively to get
    eta1 :: s1' ~ t1
    eta2 :: s2' ~ t2
  And
    kind_co = TyConAppCo Nominal (~#) eta1 eta2

  Now in the liftingContext, we add the new mapping
    cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2)
-}

-- See Note [liftCoSubstVarBndr]
liftCoSubstVarBndr :: LiftingContext -> TyCoVar
                   -> (LiftingContext, TyCoVar, Coercion)
liftCoSubstVarBndr :: LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion)
liftCoSubstVarBndr LiftingContext
lc CoVar
tv
  = let (LiftingContext
lc', CoVar
tv', Coercion
h, ()
_) = (LiftingContext -> Type -> (Coercion, ()))
-> LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion, ())
forall a.
(LiftingContext -> Type -> (Coercion, a))
-> LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion, a)
liftCoSubstVarBndrUsing LiftingContext -> Type -> (Coercion, ())
callback LiftingContext
lc CoVar
tv in
    (LiftingContext
lc', CoVar
tv', Coercion
h)
  where
    callback :: LiftingContext -> Type -> (Coercion, ())
callback LiftingContext
lc' Type
ty' = (LiftingContext -> Role -> Type -> Coercion
ty_co_subst LiftingContext
lc' Role
Nominal Type
ty', ())

-- the callback must produce a nominal coercion
liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))
                           -> LiftingContext -> TyCoVar
                           -> (LiftingContext, TyCoVar, CoercionN, a)
liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (Coercion, a))
-> LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion, a)
liftCoSubstVarBndrUsing LiftingContext -> Type -> (Coercion, a)
fun LiftingContext
lc CoVar
old_var
  | CoVar -> Bool
isTyVar CoVar
old_var
  = (LiftingContext -> Type -> (Coercion, a))
-> LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion, a)
forall a.
(LiftingContext -> Type -> (Coercion, a))
-> LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion, a)
liftCoSubstTyVarBndrUsing LiftingContext -> Type -> (Coercion, a)
fun LiftingContext
lc CoVar
old_var
  | Bool
otherwise
  = (LiftingContext -> Type -> (Coercion, a))
-> LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion, a)
forall a.
(LiftingContext -> Type -> (Coercion, a))
-> LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion, a)
liftCoSubstCoVarBndrUsing LiftingContext -> Type -> (Coercion, a)
fun LiftingContext
lc CoVar
old_var

-- Works for tyvar binder
liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))
                           -> LiftingContext -> TyVar
                           -> (LiftingContext, TyVar, CoercionN, a)
liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (Coercion, a))
-> LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion, a)
liftCoSubstTyVarBndrUsing LiftingContext -> Type -> (Coercion, a)
fun lc :: LiftingContext
lc@(LC TCvSubst
subst LiftCoEnv
cenv) CoVar
old_var
  = ASSERT( isTyVar old_var )
    ( TCvSubst -> LiftCoEnv -> LiftingContext
LC (TCvSubst
subst TCvSubst -> CoVar -> TCvSubst
`extendTCvInScope` CoVar
new_var) LiftCoEnv
new_cenv
    , CoVar
new_var, Coercion
eta, a
stuff )
  where
    old_kind :: Type
old_kind     = CoVar -> Type
tyVarKind CoVar
old_var
    (Coercion
eta, a
stuff) = LiftingContext -> Type -> (Coercion, a)
fun LiftingContext
lc Type
old_kind
    Pair Type
k1 Type
_    = Coercion -> Pair Type
coercionKind Coercion
eta
    new_var :: CoVar
new_var      = InScopeSet -> CoVar -> CoVar
uniqAway (TCvSubst -> InScopeSet
getTCvInScope TCvSubst
subst) (CoVar -> Type -> CoVar
setVarType CoVar
old_var Type
k1)

    lifted :: Coercion
lifted   = Role -> Type -> Coercion -> Coercion
mkGReflRightCo Role
Nominal (CoVar -> Type
TyVarTy CoVar
new_var) Coercion
eta
               -- :: new_var ~ new_var |> eta
    new_cenv :: LiftCoEnv
new_cenv = LiftCoEnv -> CoVar -> Coercion -> LiftCoEnv
forall a. VarEnv a -> CoVar -> a -> VarEnv a
extendVarEnv LiftCoEnv
cenv CoVar
old_var Coercion
lifted

-- Works for covar binder
liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))
                           -> LiftingContext -> CoVar
                           -> (LiftingContext, CoVar, CoercionN, a)
liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (Coercion, a))
-> LiftingContext -> CoVar -> (LiftingContext, CoVar, Coercion, a)
liftCoSubstCoVarBndrUsing LiftingContext -> Type -> (Coercion, a)
fun lc :: LiftingContext
lc@(LC TCvSubst
subst LiftCoEnv
cenv) CoVar
old_var
  = ASSERT( isCoVar old_var )
    ( TCvSubst -> LiftCoEnv -> LiftingContext
LC (TCvSubst
subst TCvSubst -> CoVar -> TCvSubst
`extendTCvInScope` CoVar
new_var) LiftCoEnv
new_cenv
    , CoVar
new_var, Coercion
kind_co, a
stuff )
  where
    old_kind :: Type
old_kind     = CoVar -> Type
coVarKind CoVar
old_var
    (Coercion
eta, a
stuff) = LiftingContext -> Type -> (Coercion, a)
fun LiftingContext
lc Type
old_kind
    Pair Type
k1 Type
_    = Coercion -> Pair Type
coercionKind Coercion
eta
    new_var :: CoVar
new_var      = InScopeSet -> CoVar -> CoVar
uniqAway (TCvSubst -> InScopeSet
getTCvInScope TCvSubst
subst) (CoVar -> Type -> CoVar
setVarType CoVar
old_var Type
k1)

    -- old_var :: s1  ~r s2
    -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)
    -- eta1    :: s1' ~r t1
    -- eta2    :: s2' ~r t2
    -- co1     :: s1' ~r s2'
    -- co2     :: t1  ~r t2
    -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2)
    -- lifted  :: co1 ~N co2

    role :: Role
role   = CoVar -> Role
coVarRole CoVar
old_var
    eta' :: Coercion
eta'   = Role -> Role -> Coercion -> Coercion
downgradeRole Role
role Role
Nominal Coercion
eta
    eta1 :: Coercion
eta1   = HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
role Int
2 Coercion
eta'
    eta2 :: Coercion
eta2   = HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
role Int
3 Coercion
eta'

    co1 :: Coercion
co1     = CoVar -> Coercion
mkCoVarCo CoVar
new_var
    co2 :: Coercion
co2     = Coercion -> Coercion
mkSymCo Coercion
eta1 Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co1 Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
eta2
    kind_co :: Coercion
kind_co = HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
Nominal (Role -> TyCon
equalityTyCon Role
role)
                           [ Coercion -> Coercion
mkKindCo Coercion
co1, Coercion -> Coercion
mkKindCo Coercion
co2
                           , Coercion
co1         , Coercion
co2          ]
    lifted :: Coercion
lifted  = Role -> Coercion -> Coercion -> Coercion -> Coercion
mkProofIrrelCo Role
Nominal Coercion
kind_co Coercion
co1 Coercion
co2

    new_cenv :: LiftCoEnv
new_cenv = LiftCoEnv -> CoVar -> Coercion -> LiftCoEnv
forall a. VarEnv a -> CoVar -> a -> VarEnv a
extendVarEnv LiftCoEnv
cenv CoVar
old_var Coercion
lifted

-- | Is a var in the domain of a lifting context?
isMappedByLC :: TyCoVar -> LiftingContext -> Bool
isMappedByLC :: CoVar -> LiftingContext -> Bool
isMappedByLC CoVar
tv (LC TCvSubst
_ LiftCoEnv
env) = CoVar
tv CoVar -> LiftCoEnv -> Bool
forall a. CoVar -> VarEnv a -> Bool
`elemVarEnv` LiftCoEnv
env

-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1
-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1
substLeftCo :: LiftingContext -> Coercion -> Coercion
substLeftCo :: LiftingContext -> Coercion -> Coercion
substLeftCo LiftingContext
lc Coercion
co
  = HasCallStack => TCvSubst -> Coercion -> Coercion
TCvSubst -> Coercion -> Coercion
substCo (LiftingContext -> TCvSubst
lcSubstLeft LiftingContext
lc) Coercion
co

-- Ditto, but for t2 and g2
substRightCo :: LiftingContext -> Coercion -> Coercion
substRightCo :: LiftingContext -> Coercion -> Coercion
substRightCo LiftingContext
lc Coercion
co
  = HasCallStack => TCvSubst -> Coercion -> Coercion
TCvSubst -> Coercion -> Coercion
substCo (LiftingContext -> TCvSubst
lcSubstRight LiftingContext
lc) Coercion
co

-- | Apply "sym" to all coercions in a 'LiftCoEnv'
swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv
swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv
swapLiftCoEnv = (Coercion -> Coercion) -> LiftCoEnv -> LiftCoEnv
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv Coercion -> Coercion
mkSymCo

lcSubstLeft :: LiftingContext -> TCvSubst
lcSubstLeft :: LiftingContext -> TCvSubst
lcSubstLeft (LC TCvSubst
subst LiftCoEnv
lc_env) = TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubstLeft TCvSubst
subst LiftCoEnv
lc_env

lcSubstRight :: LiftingContext -> TCvSubst
lcSubstRight :: LiftingContext -> TCvSubst
lcSubstRight (LC TCvSubst
subst LiftCoEnv
lc_env) = TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubstRight TCvSubst
subst LiftCoEnv
lc_env

liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubstLeft = (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubst forall a. Pair a -> a
pFst

liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubstRight = (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubst forall a. Pair a -> a
pSnd

liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubst forall a. Pair a -> a
selector TCvSubst
subst LiftCoEnv
lc_env
  = TCvSubst -> TCvSubst -> TCvSubst
composeTCvSubst (InScopeSet -> TvSubstEnv -> LiftCoEnv -> TCvSubst
TCvSubst InScopeSet
emptyInScopeSet TvSubstEnv
tenv LiftCoEnv
cenv) TCvSubst
subst
  where
    pairs :: [(Unique, Coercion)]
pairs            = LiftCoEnv -> [(Unique, Coercion)]
forall elt. UniqFM elt -> [(Unique, elt)]
nonDetUFMToList LiftCoEnv
lc_env
                       -- It's OK to use nonDetUFMToList here because we
                       -- immediately forget the ordering by creating
                       -- a VarEnv
    ([(Unique, Type)]
tpairs, [(Unique, Coercion)]
cpairs) = ((Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion))
-> [(Unique, Coercion)] -> ([(Unique, Type)], [(Unique, Coercion)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)
ty_or_co [(Unique, Coercion)]
pairs
    tenv :: TvSubstEnv
tenv             = [(Unique, Type)] -> TvSubstEnv
forall a. [(Unique, a)] -> VarEnv a
mkVarEnv_Directly [(Unique, Type)]
tpairs
    cenv :: LiftCoEnv
cenv             = [(Unique, Coercion)] -> LiftCoEnv
forall a. [(Unique, a)] -> VarEnv a
mkVarEnv_Directly [(Unique, Coercion)]
cpairs

    ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)
    ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)
ty_or_co (Unique
u, Coercion
co)
      | Just Coercion
equality_co <- Type -> Maybe Coercion
isCoercionTy_maybe Type
equality_ty
      = (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)
forall a b. b -> Either a b
Right (Unique
u, Coercion
equality_co)
      | Bool
otherwise
      = (Unique, Type) -> Either (Unique, Type) (Unique, Coercion)
forall a b. a -> Either a b
Left (Unique
u, Type
equality_ty)
      where
        equality_ty :: Type
equality_ty = Pair Type -> Type
forall a. Pair a -> a
selector (Coercion -> Pair Type
coercionKind Coercion
co)

-- | Extract the underlying substitution from the LiftingContext
lcTCvSubst :: LiftingContext -> TCvSubst
lcTCvSubst :: LiftingContext -> TCvSubst
lcTCvSubst (LC TCvSubst
subst LiftCoEnv
_) = TCvSubst
subst

-- | Get the 'InScopeSet' from a 'LiftingContext'
lcInScopeSet :: LiftingContext -> InScopeSet
lcInScopeSet :: LiftingContext -> InScopeSet
lcInScopeSet (LC TCvSubst
subst LiftCoEnv
_) = TCvSubst -> InScopeSet
getTCvInScope TCvSubst
subst

{-
%************************************************************************
%*                                                                      *
            Sequencing on coercions
%*                                                                      *
%************************************************************************
-}

seqMCo :: MCoercion -> ()
seqMCo :: MCoercion -> ()
seqMCo MCoercion
MRefl    = ()
seqMCo (MCo Coercion
co) = Coercion -> ()
seqCo Coercion
co

seqCo :: Coercion -> ()
seqCo :: Coercion -> ()
seqCo (Refl Type
ty)                 = Type -> ()
seqType Type
ty
seqCo (GRefl Role
r Type
ty MCoercion
mco)          = Role
r Role -> () -> ()
`seq` Type -> ()
seqType Type
ty () -> () -> ()
`seq` MCoercion -> ()
seqMCo MCoercion
mco
seqCo (TyConAppCo Role
r TyCon
tc [Coercion]
cos)     = Role
r Role -> () -> ()
`seq` TyCon
tc TyCon -> () -> ()
`seq` [Coercion] -> ()
seqCos [Coercion]
cos
seqCo (AppCo Coercion
co1 Coercion
co2)           = Coercion -> ()
seqCo Coercion
co1 () -> () -> ()
`seq` Coercion -> ()
seqCo Coercion
co2
seqCo (ForAllCo CoVar
tv Coercion
k Coercion
co)        = Type -> ()
seqType (CoVar -> Type
varType CoVar
tv) () -> () -> ()
`seq` Coercion -> ()
seqCo Coercion
k
                                                       () -> () -> ()
`seq` Coercion -> ()
seqCo Coercion
co
seqCo (FunCo Role
r Coercion
co1 Coercion
co2)         = Role
r Role -> () -> ()
`seq` Coercion -> ()
seqCo Coercion
co1 () -> () -> ()
`seq` Coercion -> ()
seqCo Coercion
co2
seqCo (CoVarCo CoVar
cv)              = CoVar
cv CoVar -> () -> ()
`seq` ()
seqCo (HoleCo CoercionHole
h)                = CoercionHole -> CoVar
coHoleCoVar CoercionHole
h CoVar -> () -> ()
`seq` ()
seqCo (AxiomInstCo CoAxiom Branched
con Int
ind [Coercion]
cos) = CoAxiom Branched
con CoAxiom Branched -> () -> ()
`seq` Int
ind Int -> () -> ()
`seq` [Coercion] -> ()
seqCos [Coercion]
cos
seqCo (UnivCo UnivCoProvenance
p Role
r Type
t1 Type
t2)
  = UnivCoProvenance -> ()
seqProv UnivCoProvenance
p () -> () -> ()
`seq` Role
r Role -> () -> ()
`seq` Type -> ()
seqType Type
t1 () -> () -> ()
`seq` Type -> ()
seqType Type
t2
seqCo (SymCo Coercion
co)                = Coercion -> ()
seqCo Coercion
co
seqCo (TransCo Coercion
co1 Coercion
co2)         = Coercion -> ()
seqCo Coercion
co1 () -> () -> ()
`seq` Coercion -> ()
seqCo Coercion
co2
seqCo (NthCo Role
r Int
n Coercion
co)            = Role
r Role -> () -> ()
`seq` Int
n Int -> () -> ()
`seq` Coercion -> ()
seqCo Coercion
co
seqCo (LRCo LeftOrRight
lr Coercion
co)              = LeftOrRight
lr LeftOrRight -> () -> ()
`seq` Coercion -> ()
seqCo Coercion
co
seqCo (InstCo Coercion
co Coercion
arg)           = Coercion -> ()
seqCo Coercion
co () -> () -> ()
`seq` Coercion -> ()
seqCo Coercion
arg
seqCo (KindCo Coercion
co)               = Coercion -> ()
seqCo Coercion
co
seqCo (SubCo Coercion
co)                = Coercion -> ()
seqCo Coercion
co
seqCo (AxiomRuleCo CoAxiomRule
_ [Coercion]
cs)        = [Coercion] -> ()
seqCos [Coercion]
cs

seqProv :: UnivCoProvenance -> ()
seqProv :: UnivCoProvenance -> ()
seqProv UnivCoProvenance
UnsafeCoerceProv    = ()
seqProv (PhantomProv Coercion
co)    = Coercion -> ()
seqCo Coercion
co
seqProv (ProofIrrelProv Coercion
co) = Coercion -> ()
seqCo Coercion
co
seqProv (PluginProv String
_)      = ()

seqCos :: [Coercion] -> ()
seqCos :: [Coercion] -> ()
seqCos []       = ()
seqCos (Coercion
co:[Coercion]
cos) = Coercion -> ()
seqCo Coercion
co () -> () -> ()
`seq` [Coercion] -> ()
seqCos [Coercion]
cos

{-
%************************************************************************
%*                                                                      *
             The kind of a type, and of a coercion
%*                                                                      *
%************************************************************************
-}

coercionType :: Coercion -> Type
coercionType :: Coercion -> Type
coercionType Coercion
co = case Coercion -> (Pair Type, Role)
coercionKindRole Coercion
co of
  (Pair Type
ty1 Type
ty2, Role
r) -> Role -> Type -> Type -> Type
mkCoercionType Role
r Type
ty1 Type
ty2

------------------
-- | If it is the case that
--
-- > c :: (t1 ~ t2)
--
-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.

coercionKind :: Coercion -> Pair Type
coercionKind :: Coercion -> Pair Type
coercionKind Coercion
co =
  Coercion -> Pair Type
go Coercion
co
  where
    go :: Coercion -> Pair Type
go (Refl Type
ty) = Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair Type
ty Type
ty
    go (GRefl Role
_ Type
ty MCoercion
MRefl) = Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair Type
ty Type
ty
    go (GRefl Role
_ Type
ty (MCo Coercion
co1)) = Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair Type
ty (Type -> Coercion -> Type
mkCastTy Type
ty Coercion
co1)
    go (TyConAppCo Role
_ TyCon
tc [Coercion]
cos)= TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Type] -> Type) -> Pair [Type] -> Pair Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Pair Type] -> Pair [Type]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([Pair Type] -> Pair [Type]) -> [Pair Type] -> Pair [Type]
forall a b. (a -> b) -> a -> b
$ (Coercion -> Pair Type) -> [Coercion] -> [Pair Type]
forall a b. (a -> b) -> [a] -> [b]
map Coercion -> Pair Type
go [Coercion]
cos)
    go (AppCo Coercion
co1 Coercion
co2)      = Type -> Type -> Type
mkAppTy (Type -> Type -> Type) -> Pair Type -> Pair (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Pair Type
go Coercion
co1 Pair (Type -> Type) -> Pair Type -> Pair Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Coercion -> Pair Type
go Coercion
co2
    go co :: Coercion
co@(ForAllCo CoVar
tv1 Coercion
k_co Coercion
co1) -- works for both tyvar and covar
       | Coercion -> Bool
isGReflCo Coercion
k_co           = CoVar -> Type -> Type
mkTyCoInvForAllTy CoVar
tv1 (Type -> Type) -> Pair Type -> Pair Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Pair Type
go Coercion
co1
         -- kind_co always has kind @Type@, thus @isGReflCo@
       | Bool
otherwise                = TCvSubst -> Coercion -> Pair Type
go_forall TCvSubst
empty_subst Coercion
co
       where
         empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ Coercion -> VarSet
tyCoVarsOfCo Coercion
co)
    go (FunCo Role
_ Coercion
co1 Coercion
co2)    = Type -> Type -> Type
mkVisFunTy (Type -> Type -> Type) -> Pair Type -> Pair (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Pair Type
go Coercion
co1 Pair (Type -> Type) -> Pair Type -> Pair Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Coercion -> Pair Type
go Coercion
co2
    go (CoVarCo CoVar
cv)         = HasDebugCallStack => CoVar -> Pair Type
CoVar -> Pair Type
coVarTypes CoVar
cv
    go (HoleCo CoercionHole
h)           = HasDebugCallStack => CoVar -> Pair Type
CoVar -> Pair Type
coVarTypes (CoercionHole -> CoVar
coHoleCoVar CoercionHole
h)
    go (AxiomInstCo CoAxiom Branched
ax Int
ind [Coercion]
cos)
      | CoAxBranch { cab_tvs :: CoAxBranch -> [CoVar]
cab_tvs = [CoVar]
tvs, cab_cvs :: CoAxBranch -> [CoVar]
cab_cvs = [CoVar]
cvs
                   , cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs } <- CoAxiom Branched -> Int -> CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> Int -> CoAxBranch
coAxiomNthBranch CoAxiom Branched
ax Int
ind
      , let Pair [Type]
tycos1 [Type]
tycos2 = [Pair Type] -> Pair [Type]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((Coercion -> Pair Type) -> [Coercion] -> [Pair Type]
forall a b. (a -> b) -> [a] -> [b]
map Coercion -> Pair Type
go [Coercion]
cos)
            ([Type]
tys1, [Type]
cotys1) = [CoVar] -> [Type] -> ([Type], [Type])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [CoVar]
tvs [Type]
tycos1
            ([Type]
tys2, [Type]
cotys2) = [CoVar] -> [Type] -> ([Type], [Type])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [CoVar]
tvs [Type]
tycos2
            cos1 :: [Coercion]
cos1           = (Type -> Coercion) -> [Type] -> [Coercion]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Coercion
stripCoercionTy [Type]
cotys1
            cos2 :: [Coercion]
cos2           = (Type -> Coercion) -> [Type] -> [Coercion]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Coercion
stripCoercionTy [Type]
cotys2
      = ASSERT( cos `equalLength` (tvs ++ cvs) )
                  -- Invariant of AxiomInstCo: cos should
                  -- exactly saturate the axiom branch
        Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair (HasCallStack => [CoVar] -> [Type] -> Type -> Type
[CoVar] -> [Type] -> Type -> Type
substTyWith [CoVar]
tvs [Type]
tys1 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
              [CoVar] -> [Coercion] -> Type -> Type
substTyWithCoVars [CoVar]
cvs [Coercion]
cos1 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
              TyCon -> [Type] -> Type
mkTyConApp (CoAxiom Branched -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom Branched
ax) [Type]
lhs)
             (HasCallStack => [CoVar] -> [Type] -> Type -> Type
[CoVar] -> [Type] -> Type -> Type
substTyWith [CoVar]
tvs [Type]
tys2 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
              [CoVar] -> [Coercion] -> Type -> Type
substTyWithCoVars [CoVar]
cvs [Coercion]
cos2 Type
rhs)
    go (UnivCo UnivCoProvenance
_ Role
_ Type
ty1 Type
ty2)   = Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair Type
ty1 Type
ty2
    go (SymCo Coercion
co)             = Pair Type -> Pair Type
forall a. Pair a -> Pair a
swap (Pair Type -> Pair Type) -> Pair Type -> Pair Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
go Coercion
co
    go (TransCo Coercion
co1 Coercion
co2)      = Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair (Pair Type -> Type
forall a. Pair a -> a
pFst (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
go Coercion
co1) (Pair Type -> Type
forall a. Pair a -> a
pSnd (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
go Coercion
co2)
    go g :: Coercion
g@(NthCo Role
_ Int
d Coercion
co)
      | Just Pair [Type]
argss <- (Type -> Maybe [Type]) -> Pair Type -> Maybe (Pair [Type])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Maybe [Type]
tyConAppArgs_maybe Pair Type
tys
      = ASSERT( and $ (`lengthExceeds` d) <$> argss )
        ([Type] -> Int -> Type
forall a. Outputable a => [a] -> Int -> a
`getNth` Int
d) ([Type] -> Type) -> Pair [Type] -> Pair Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pair [Type]
argss

      | Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      , Just Pair (CoVar, Type)
splits <- (Type -> Maybe (CoVar, Type))
-> Pair Type -> Maybe (Pair (CoVar, Type))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Maybe (CoVar, Type)
splitForAllTy_maybe Pair Type
tys
      = (CoVar -> Type
tyVarKind (CoVar -> Type)
-> ((CoVar, Type) -> CoVar) -> (CoVar, Type) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoVar, Type) -> CoVar
forall a b. (a, b) -> a
fst) ((CoVar, Type) -> Type) -> Pair (CoVar, Type) -> Pair Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pair (CoVar, Type)
splits

      | Bool
otherwise
      = String -> SDoc -> Pair Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coercionKind" (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
g)
      where
        tys :: Pair Type
tys = Coercion -> Pair Type
go Coercion
co
    go (LRCo LeftOrRight
lr Coercion
co)         = (LeftOrRight -> (Type, Type) -> Type
forall a. LeftOrRight -> (a, a) -> a
pickLR LeftOrRight
lr ((Type, Type) -> Type) -> (Type -> (Type, Type)) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> (Type, Type)
splitAppTy) (Type -> Type) -> Pair Type -> Pair Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Pair Type
go Coercion
co
    go (InstCo Coercion
aco Coercion
arg)     = Coercion -> [Coercion] -> Pair Type
go_app Coercion
aco [Coercion
arg]
    go (KindCo Coercion
co)          = HasDebugCallStack => Type -> Type
Type -> Type
typeKind (Type -> Type) -> Pair Type -> Pair Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Pair Type
go Coercion
co
    go (SubCo Coercion
co)           = Coercion -> Pair Type
go Coercion
co
    go (AxiomRuleCo CoAxiomRule
ax [Coercion]
cos) = String -> Maybe (Pair Type) -> Pair Type
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"coercionKind" (Maybe (Pair Type) -> Pair Type) -> Maybe (Pair Type) -> Pair Type
forall a b. (a -> b) -> a -> b
$
                              CoAxiomRule -> [Pair Type] -> Maybe (Pair Type)
coaxrProves CoAxiomRule
ax ((Coercion -> Pair Type) -> [Coercion] -> [Pair Type]
forall a b. (a -> b) -> [a] -> [b]
map Coercion -> Pair Type
go [Coercion]
cos)

    go_app :: Coercion -> [Coercion] -> Pair Type
    -- Collect up all the arguments and apply all at once
    -- See Note [Nested InstCos]
    go_app :: Coercion -> [Coercion] -> Pair Type
go_app (InstCo Coercion
co Coercion
arg) [Coercion]
args = Coercion -> [Coercion] -> Pair Type
go_app Coercion
co (Coercion
argCoercion -> [Coercion] -> [Coercion]
forall a. a -> [a] -> [a]
:[Coercion]
args)
    go_app Coercion
co              [Coercion]
args = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys (Type -> [Type] -> Type) -> Pair Type -> Pair ([Type] -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coercion -> Pair Type
go Coercion
co Pair ([Type] -> Type) -> Pair [Type] -> Pair Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Pair Type] -> Pair [Type]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([Pair Type] -> Pair [Type]) -> [Pair Type] -> Pair [Type]
forall a b. (a -> b) -> a -> b
$ (Coercion -> Pair Type) -> [Coercion] -> [Pair Type]
forall a b. (a -> b) -> [a] -> [b]
map Coercion -> Pair Type
go [Coercion]
args)

    go_forall :: TCvSubst -> Coercion -> Pair Type
go_forall TCvSubst
subst (ForAllCo CoVar
tv1 Coercion
k_co Coercion
co)
      -- See Note [Nested ForAllCos]
      | CoVar -> Bool
isTyVar CoVar
tv1
      = CoVar -> Type -> Type
mkInvForAllTy (CoVar -> Type -> Type) -> Pair CoVar -> Pair (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoVar -> CoVar -> Pair CoVar
forall a. a -> a -> Pair a
Pair CoVar
tv1 CoVar
tv2 Pair (Type -> Type) -> Pair Type -> Pair Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TCvSubst -> Coercion -> Pair Type
go_forall TCvSubst
subst' Coercion
co
      where
        Pair Type
_ Type
k2 = Coercion -> Pair Type
go Coercion
k_co
        tv2 :: CoVar
tv2       = CoVar -> Type -> CoVar
setTyVarKind CoVar
tv1 (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
k2)
        subst' :: TCvSubst
subst' | Coercion -> Bool
isGReflCo Coercion
k_co = TCvSubst -> CoVar -> TCvSubst
extendTCvInScope TCvSubst
subst CoVar
tv1
                 -- kind_co always has kind @Type@, thus @isGReflCo@
               | Bool
otherwise      = TCvSubst -> CoVar -> Type -> TCvSubst
extendTvSubst (TCvSubst -> CoVar -> TCvSubst
extendTCvInScope TCvSubst
subst CoVar
tv2) CoVar
tv1 (Type -> TCvSubst) -> Type -> TCvSubst
forall a b. (a -> b) -> a -> b
$
                                  CoVar -> Type
TyVarTy CoVar
tv2 Type -> Coercion -> Type
`mkCastTy` Coercion -> Coercion
mkSymCo Coercion
k_co
    go_forall TCvSubst
subst (ForAllCo CoVar
cv1 Coercion
k_co Coercion
co)
      | CoVar -> Bool
isCoVar CoVar
cv1
      = CoVar -> Type -> Type
mkTyCoInvForAllTy (CoVar -> Type -> Type) -> Pair CoVar -> Pair (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoVar -> CoVar -> Pair CoVar
forall a. a -> a -> Pair a
Pair CoVar
cv1 CoVar
cv2 Pair (Type -> Type) -> Pair Type -> Pair Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TCvSubst -> Coercion -> Pair Type
go_forall TCvSubst
subst' Coercion
co
      where
        Pair Type
_ Type
k2 = Coercion -> Pair Type
go Coercion
k_co
        r :: Role
r         = CoVar -> Role
coVarRole CoVar
cv1
        eta1 :: Coercion
eta1      = HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
r Int
2 (Role -> Role -> Coercion -> Coercion
downgradeRole Role
r Role
Nominal Coercion
k_co)
        eta2 :: Coercion
eta2      = HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
r Int
3 (Role -> Role -> Coercion -> Coercion
downgradeRole Role
r Role
Nominal Coercion
k_co)

        -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)
        -- k1    = t1 ~r t2
        -- k2    = s1 ~r s2
        -- cv1  :: t1 ~r t2
        -- cv2  :: s1 ~r s2
        -- eta1 :: t1 ~r s1
        -- eta2 :: t2 ~r s2
        -- n_subst  = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2

        cv2 :: CoVar
cv2     = CoVar -> Type -> CoVar
setVarType CoVar
cv1 (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
k2)
        n_subst :: Coercion
n_subst = Coercion
eta1 Coercion -> Coercion -> Coercion
`mkTransCo` (CoVar -> Coercion
mkCoVarCo CoVar
cv2) Coercion -> Coercion -> Coercion
`mkTransCo` (Coercion -> Coercion
mkSymCo Coercion
eta2)
        subst' :: TCvSubst
subst'  | Coercion -> Bool
isReflCo Coercion
k_co = TCvSubst -> CoVar -> TCvSubst
extendTCvInScope TCvSubst
subst CoVar
cv1
                | Bool
otherwise     = TCvSubst -> CoVar -> Coercion -> TCvSubst
extendCvSubst (TCvSubst -> CoVar -> TCvSubst
extendTCvInScope TCvSubst
subst CoVar
cv2)
                                                CoVar
cv1 Coercion
n_subst

    go_forall TCvSubst
subst Coercion
other_co
      -- when other_co is not a ForAllCo
      = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst (Type -> Type) -> Pair Type -> Pair Type
forall a. (a -> a) -> Pair a -> Pair a
`pLiftSnd` Coercion -> Pair Type
go Coercion
other_co

{-

Note [Nested ForAllCos]
~~~~~~~~~~~~~~~~~~~~~~~

Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an
co)...) )`.   We do not want to perform `n` single-type-variable
substitutions over the kind of `co`; rather we want to do one substitution
which substitutes for all of `a1`, `a2` ... simultaneously.  If we do one
at a time we get the performance hole reported in #11735.

Solution: gather up the type variables for nested `ForAllCos`, and
substitute for them all at once.  Remarkably, for #11735 this single
change reduces /total/ compile time by a factor of more than ten.

-}

-- | Apply 'coercionKind' to multiple 'Coercion's
coercionKinds :: [Coercion] -> Pair [Type]
coercionKinds :: [Coercion] -> Pair [Type]
coercionKinds [Coercion]
tys = [Pair Type] -> Pair [Type]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([Pair Type] -> Pair [Type]) -> [Pair Type] -> Pair [Type]
forall a b. (a -> b) -> a -> b
$ (Coercion -> Pair Type) -> [Coercion] -> [Pair Type]
forall a b. (a -> b) -> [a] -> [b]
map Coercion -> Pair Type
coercionKind [Coercion]
tys

-- | Get a coercion's kind and role.
coercionKindRole :: Coercion -> (Pair Type, Role)
coercionKindRole :: Coercion -> (Pair Type, Role)
coercionKindRole Coercion
co = (Coercion -> Pair Type
coercionKind Coercion
co, Coercion -> Role
coercionRole Coercion
co)

-- | Retrieve the role from a coercion.
coercionRole :: Coercion -> Role
coercionRole :: Coercion -> Role
coercionRole = Coercion -> Role
go
  where
    go :: Coercion -> Role
go (Refl Type
_) = Role
Nominal
    go (GRefl Role
r Type
_ MCoercion
_) = Role
r
    go (TyConAppCo Role
r TyCon
_ [Coercion]
_) = Role
r
    go (AppCo Coercion
co1 Coercion
_) = Coercion -> Role
go Coercion
co1
    go (ForAllCo CoVar
_ Coercion
_ Coercion
co) = Coercion -> Role
go Coercion
co
    go (FunCo Role
r Coercion
_ Coercion
_) = Role
r
    go (CoVarCo CoVar
cv) = CoVar -> Role
coVarRole CoVar
cv
    go (HoleCo CoercionHole
h)   = CoVar -> Role
coVarRole (CoercionHole -> CoVar
coHoleCoVar CoercionHole
h)
    go (AxiomInstCo CoAxiom Branched
ax Int
_ [Coercion]
_) = CoAxiom Branched -> Role
forall (br :: BranchFlag). CoAxiom br -> Role
coAxiomRole CoAxiom Branched
ax
    go (UnivCo UnivCoProvenance
_ Role
r Type
_ Type
_)  = Role
r
    go (SymCo Coercion
co) = Coercion -> Role
go Coercion
co
    go (TransCo Coercion
co1 Coercion
_co2) = Coercion -> Role
go Coercion
co1
    go (NthCo Role
r Int
_d Coercion
_co) = Role
r
    go (LRCo {}) = Role
Nominal
    go (InstCo Coercion
co Coercion
_) = Coercion -> Role
go Coercion
co
    go (KindCo {}) = Role
Nominal
    go (SubCo Coercion
_) = Role
Representational
    go (AxiomRuleCo CoAxiomRule
ax [Coercion]
_) = CoAxiomRule -> Role
coaxrRole CoAxiomRule
ax

{-
Note [Nested InstCos]
~~~~~~~~~~~~~~~~~~~~~
In #5631 we found that 70% of the entire compilation time was
being spent in coercionKind!  The reason was that we had
   (g @ ty1 @ ty2 .. @ ty100)    -- The "@s" are InstCos
where
   g :: forall a1 a2 .. a100. phi
If we deal with the InstCos one at a time, we'll do this:
   1.  Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi'
   2.  Substitute phi'[ ty100/a100 ], a single tyvar->type subst
But this is a *quadratic* algorithm, and the blew up #5631.
So it's very important to do the substitution simultaneously;
cf Type.piResultTys (which in fact we call here).

-}

-- | Makes a coercion type from two types: the types whose equality
-- is proven by the relevant 'Coercion'
mkCoercionType :: Role -> Type -> Type -> Type
mkCoercionType :: Role -> Type -> Type -> Type
mkCoercionType Role
Nominal          = Type -> Type -> Type
mkPrimEqPred
mkCoercionType Role
Representational = Type -> Type -> Type
mkReprPrimEqPred
mkCoercionType Role
Phantom          = \Type
ty1 Type
ty2 ->
  let ki1 :: Type
ki1 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty1
      ki2 :: Type
ki2 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty2
  in
  TyCon -> [Type] -> Type
TyConApp TyCon
eqPhantPrimTyCon [Type
ki1, Type
ki2, Type
ty1, Type
ty2]

mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type
mkHeteroCoercionType :: Role -> Type -> Type -> Type -> Type -> Type
mkHeteroCoercionType Role
Nominal          = Type -> Type -> Type -> Type -> Type
mkHeteroPrimEqPred
mkHeteroCoercionType Role
Representational = Type -> Type -> Type -> Type -> Type
mkHeteroReprPrimEqPred
mkHeteroCoercionType Role
Phantom          = String -> Type -> Type -> Type -> Type -> Type
forall a. String -> a
panic String
"mkHeteroCoercionType"

-- | Creates a primitive type equality predicate.
-- Invariant: the types are not Coercions
mkPrimEqPred :: Type -> Type -> Type
mkPrimEqPred :: Type -> Type -> Type
mkPrimEqPred Type
ty1 Type
ty2
  = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqPrimTyCon [Type
k1, Type
k2, Type
ty1, Type
ty2]
  where
    k1 :: Type
k1 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty1
    k2 :: Type
k2 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty2

-- | Makes a lifted equality predicate at the given role
mkPrimEqPredRole :: Role -> Type -> Type -> PredType
mkPrimEqPredRole :: Role -> Type -> Type -> Type
mkPrimEqPredRole Role
Nominal          = Type -> Type -> Type
mkPrimEqPred
mkPrimEqPredRole Role
Representational = Type -> Type -> Type
mkReprPrimEqPred
mkPrimEqPredRole Role
Phantom          = String -> Type -> Type -> Type
forall a. String -> a
panic String
"mkPrimEqPredRole phantom"

-- | Creates a primite type equality predicate with explicit kinds
mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type
mkHeteroPrimEqPred :: Type -> Type -> Type -> Type -> Type
mkHeteroPrimEqPred Type
k1 Type
k2 Type
ty1 Type
ty2 = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqPrimTyCon [Type
k1, Type
k2, Type
ty1, Type
ty2]

-- | Creates a primitive representational type equality predicate
-- with explicit kinds
mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type
mkHeteroReprPrimEqPred :: Type -> Type -> Type -> Type -> Type
mkHeteroReprPrimEqPred Type
k1 Type
k2 Type
ty1 Type
ty2
  = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [Type
k1, Type
k2, Type
ty1, Type
ty2]

mkReprPrimEqPred :: Type -> Type -> Type
mkReprPrimEqPred :: Type -> Type -> Type
mkReprPrimEqPred Type
ty1  Type
ty2
  = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [Type
k1, Type
k2, Type
ty1, Type
ty2]
  where
    k1 :: Type
k1 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty1
    k2 :: Type
k2 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty2

-- | Assuming that two types are the same, ignoring coercions, find
-- a nominal coercion between the types. This is useful when optimizing
-- transitivity over coercion applications, where splitting two
-- AppCos might yield different kinds. See Note [EtaAppCo] in OptCoercion.
buildCoercion :: Type -> Type -> CoercionN
buildCoercion :: Type -> Type -> Coercion
buildCoercion Type
orig_ty1 Type
orig_ty2 = Type -> Type -> Coercion
go Type
orig_ty1 Type
orig_ty2
  where
    go :: Type -> Type -> Coercion
go Type
ty1 Type
ty2 | Just Type
ty1' <- Type -> Maybe Type
coreView Type
ty1 = Type -> Type -> Coercion
go Type
ty1' Type
ty2
               | Just Type
ty2' <- Type -> Maybe Type
coreView Type
ty2 = Type -> Type -> Coercion
go Type
ty1 Type
ty2'

    go (CastTy Type
ty1 Coercion
co) Type
ty2
      = let co' :: Coercion
co' = Type -> Type -> Coercion
go Type
ty1 Type
ty2
            r :: Role
r = Coercion -> Role
coercionRole Coercion
co'
        in  Role -> Type -> Coercion -> Coercion -> Coercion
mkCoherenceLeftCo Role
r Type
ty1 Coercion
co Coercion
co'

    go Type
ty1 (CastTy Type
ty2 Coercion
co)
      = let co' :: Coercion
co' = Type -> Type -> Coercion
go Type
ty1 Type
ty2
            r :: Role
r = Coercion -> Role
coercionRole Coercion
co'
        in  Role -> Type -> Coercion -> Coercion -> Coercion
mkCoherenceRightCo Role
r Type
ty2 Coercion
co Coercion
co'

    go ty1 :: Type
ty1@(TyVarTy CoVar
tv1) Type
_tyvarty
      = ASSERT( case _tyvarty of
                  { TyVarTy tv2 -> tv1 == tv2
                  ; _           -> False      } )
        Type -> Coercion
mkNomReflCo Type
ty1

    go (FunTy { ft_arg :: Type -> Type
ft_arg = Type
arg1, ft_res :: Type -> Type
ft_res = Type
res1 })
       (FunTy { ft_arg :: Type -> Type
ft_arg = Type
arg2, ft_res :: Type -> Type
ft_res = Type
res2 })
      = Role -> Coercion -> Coercion -> Coercion
mkFunCo Role
Nominal (Type -> Type -> Coercion
go Type
arg1 Type
arg2) (Type -> Type -> Coercion
go Type
res1 Type
res2)

    go (TyConApp TyCon
tc1 [Type]
args1) (TyConApp TyCon
tc2 [Type]
args2)
      = ASSERT( tc1 == tc2 )
        HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
Nominal TyCon
tc1 ((Type -> Type -> Coercion) -> [Type] -> [Type] -> [Coercion]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Type -> Coercion
go [Type]
args1 [Type]
args2)

    go (AppTy Type
ty1a Type
ty1b) Type
ty2
      | Just (Type
ty2a, Type
ty2b) <- HasDebugCallStack => Type -> Maybe (Type, Type)
Type -> Maybe (Type, Type)
repSplitAppTy_maybe Type
ty2
      = Coercion -> Coercion -> Coercion
mkAppCo (Type -> Type -> Coercion
go Type
ty1a Type
ty2a) (Type -> Type -> Coercion
go Type
ty1b Type
ty2b)

    go Type
ty1 (AppTy Type
ty2a Type
ty2b)
      | Just (Type
ty1a, Type
ty1b) <- HasDebugCallStack => Type -> Maybe (Type, Type)
Type -> Maybe (Type, Type)
repSplitAppTy_maybe Type
ty1
      = Coercion -> Coercion -> Coercion
mkAppCo (Type -> Type -> Coercion
go Type
ty1a Type
ty2a) (Type -> Type -> Coercion
go Type
ty1b Type
ty2b)

    go (ForAllTy (Bndr CoVar
tv1 ArgFlag
_flag1) Type
ty1) (ForAllTy (Bndr CoVar
tv2 ArgFlag
_flag2) Type
ty2)
      | CoVar -> Bool
isTyVar CoVar
tv1
      = ASSERT( isTyVar tv2 )
        CoVar -> Coercion -> Coercion -> Coercion
mkForAllCo CoVar
tv1 Coercion
kind_co (Type -> Type -> Coercion
go Type
ty1 Type
ty2')
      where kind_co :: Coercion
kind_co  = Type -> Type -> Coercion
go (CoVar -> Type
tyVarKind CoVar
tv1) (CoVar -> Type
tyVarKind CoVar
tv2)
            in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ Type -> VarSet
tyCoVarsOfType Type
ty2 VarSet -> VarSet -> VarSet
`unionVarSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
kind_co
            ty2' :: Type
ty2'     = InScopeSet -> [CoVar] -> [Type] -> Type -> Type
substTyWithInScope InScopeSet
in_scope [CoVar
tv2]
                         [CoVar -> Type
mkTyVarTy CoVar
tv1 Type -> Coercion -> Type
`mkCastTy` Coercion
kind_co]
                         Type
ty2

    go (ForAllTy (Bndr CoVar
cv1 ArgFlag
_flag1) Type
ty1) (ForAllTy (Bndr CoVar
cv2 ArgFlag
_flag2) Type
ty2)
      = ASSERT( isCoVar cv1 && isCoVar cv2 )
        CoVar -> Coercion -> Coercion -> Coercion
mkForAllCo CoVar
cv1 Coercion
kind_co (Type -> Type -> Coercion
go Type
ty1 Type
ty2')
      where s1 :: Type
s1 = CoVar -> Type
varType CoVar
cv1
            s2 :: Type
s2 = CoVar -> Type
varType CoVar
cv2
            kind_co :: Coercion
kind_co = Type -> Type -> Coercion
go Type
s1 Type
s2

            -- s1 = t1 ~r t2
            -- s2 = t3 ~r t4
            -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4)
            -- eta1 :: t1 ~r t3
            -- eta2 :: t2 ~r t4

            r :: Role
r    = CoVar -> Role
coVarRole CoVar
cv1
            kind_co' :: Coercion
kind_co' = Role -> Role -> Coercion -> Coercion
downgradeRole Role
r Role
Nominal Coercion
kind_co
            eta1 :: Coercion
eta1 = HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
r Int
2 Coercion
kind_co'
            eta2 :: Coercion
eta2 = HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
r Int
3 Coercion
kind_co'

            subst :: TCvSubst
subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (InScopeSet -> TCvSubst) -> InScopeSet -> TCvSubst
forall a b. (a -> b) -> a -> b
$ VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$
                      Type -> VarSet
tyCoVarsOfType Type
ty2 VarSet -> VarSet -> VarSet
`unionVarSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
kind_co
            ty2' :: Type
ty2'  = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy (TCvSubst -> CoVar -> Coercion -> TCvSubst
extendCvSubst TCvSubst
subst CoVar
cv2 (Coercion -> TCvSubst) -> Coercion -> TCvSubst
forall a b. (a -> b) -> a -> b
$ Coercion -> Coercion
mkSymCo Coercion
eta1 Coercion -> Coercion -> Coercion
`mkTransCo`
                                                       CoVar -> Coercion
mkCoVarCo CoVar
cv1 Coercion -> Coercion -> Coercion
`mkTransCo`
                                                       Coercion
eta2)
                            Type
ty2

    go ty1 :: Type
ty1@(LitTy TyLit
lit1) Type
_lit2
      = ASSERT( case _lit2 of
                  { LitTy lit2 -> lit1 == lit2
                  ; _          -> False        } )
        Type -> Coercion
mkNomReflCo Type
ty1

    go (CoercionTy Coercion
co1) (CoercionTy Coercion
co2)
      = Role -> Coercion -> Coercion -> Coercion -> Coercion
mkProofIrrelCo Role
Nominal Coercion
kind_co Coercion
co1 Coercion
co2
      where
        kind_co :: Coercion
kind_co = Type -> Type -> Coercion
go (Coercion -> Type
coercionType Coercion
co1) (Coercion -> Type
coercionType Coercion
co2)

    go Type
ty1 Type
ty2
      = String -> SDoc -> Coercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"buildKindCoercion" ([SDoc] -> SDoc
vcat [ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
orig_ty1, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
orig_ty2
                                           , Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty1, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2 ])

{-
%************************************************************************
%*                                                                      *
       Simplifying types
%*                                                                      *
%************************************************************************

The function below morally belongs in TcFlatten, but it is used also in
FamInstEnv, and so lives here.

Note [simplifyArgsWorker]
~~~~~~~~~~~~~~~~~~~~~~~~~
Invariant (F2) of Note [Flattening] says that flattening is homogeneous.
This causes some trouble when flattening a function applied to a telescope
of arguments, perhaps with dependency. For example, suppose

  type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k]

and we wish to flatten the args of (with kind applications explicit)

  F a b (Just a c) (Right a b d) False

where all variables are skolems and

  a :: Type
  b :: Type
  c :: a
  d :: k

  [G] aco :: a ~ fa
  [G] bco :: b ~ fb
  [G] cco :: c ~ fc
  [G] dco :: d ~ fd

The first step is to flatten all the arguments. This is done before calling
simplifyArgsWorker. We start from

  a
  b
  Just a c
  Right a b d
  False

and get

  (fa,                             co1 :: fa ~ a)
  (fb,                             co2 :: fb ~ b)
  (Just fa (fc |> aco) |> co6,     co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c))
  (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d))
  (False,                          co5 :: False ~ False)

where
  co6 :: Maybe fa ~ Maybe a
  co7 :: Either fa fb ~ Either a b

We now process the flattened args in left-to-right order. The first two args
need no further processing. But now consider the third argument. Let f3 = the flattened
result, Just fa (fc |> aco) |> co6.
This f3 flattened argument has kind (Maybe a), due to
(F2). And yet, when we build the application (F fa fb ...), we need this
argument to have kind (Maybe fa), not (Maybe a). We must cast this argument.
The coercion to use is
determined by the kind of F: we see in F's kind that the third argument has
kind Maybe j. Critically, we also know that the argument corresponding to j
(in our example, a) flattened with a coercion co1. We can thus know the
coercion needed for the 3rd argument is (Maybe (sym co1)), thus building
(f3 |> Maybe (sym co1))

More generally, we must use the Lifting Lemma, as implemented in
Coercion.liftCoSubst. As we work left-to-right, any variable that is a
dependent parameter (j and k, in our example) gets mapped in a lifting context
to the coercion that is output from flattening the corresponding argument (co1
and co2, in our example). Then, after flattening later arguments, we lift the
kind of these arguments in the lifting context that we've be building up.
This coercion is then used to keep the result of flattening well-kinded.

Working through our example, this is what happens:

  1. Extend the (empty) LC with [j |-> co1]. No new casting must be done,
     because the binder associated with the first argument has a closed type (no
     variables).

  2. Extend the LC with [k |-> co2]. No casting to do.

  3. Lifting the kind (Maybe j) with our LC
     yields co8 :: Maybe fa ~ Maybe a. Use (f3 |> sym co8) as the argument to
     F.

  4. Lifting the kind (Either j k) with our LC
     yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th
     argument to F, where f4 is the flattened form of argument 4, written above.

  5. We lift Bool with our LC, getting <Bool>;
     casting has no effect.

We're now almost done, but the new application (F fa fb (f3 |> sym co8) (f4 > sym co9) False)
has the wrong kind. Its kind is [fb], instead of the original [b].
So we must use our LC one last time to lift the result kind [k],
getting res_co :: [fb] ~ [b], and we cast our result.

Accordingly, the final result is

  F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco)))
          (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco)))
          False
            |> [sym bco]

The res_co (in this case, [sym bco])
is returned as the third return value from simplifyArgsWorker.

Note [Last case in simplifyArgsWorker]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In writing simplifyArgsWorker's `go`, we know here that args cannot be empty,
because that case is first. We've run out of
binders. But perhaps inner_ki is a tyvar that has been instantiated with a
Π-type.

Here is an example.

  a :: forall (k :: Type). k -> k
  type family Star
  Proxy :: forall j. j -> Type
  axStar :: Star ~ Type
  type family NoWay :: Bool
  axNoWay :: NoWay ~ False
  bo :: Type
  [G] bc :: bo ~ Bool   (in inert set)

  co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star)
  co = forall (j :: sym axStar). (<j> -> sym axStar)

  We are flattening:
  a (forall (j :: Star). (j |> axStar) -> Star)   -- 1
    (Proxy |> co)                                 -- 2
    (bo |> sym axStar)                            -- 3
    (NoWay |> sym bc)                             -- 4
      :: Star

First, we flatten all the arguments (before simplifyArgsWorker), like so:

    (forall j. j -> Type, co1 :: (forall j. j -> Type) ~
                                 (forall (j :: Star). (j |> axStar) -> Star))  -- 1
    (Proxy |> co,         co2 :: (Proxy |> co) ~ (Proxy |> co))                -- 2
    (Bool |> sym axStar,  co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar))    -- 3
    (False |> sym bc,     co4 :: (False |> sym bc) ~ (NoWay |> sym bc))        -- 4

Then we do the process described in Note [simplifyArgsWorker].

1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we
   don't use it. But we do build a lifting context [k -> co1] (where co1 is a
   result of flattening an argument, written above).

2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1).
   This is not a dependent argument, so we don't extend the lifting context.

Now we need to deal with argument (3).
The way we normally proceed is to lift the kind of the binder, to see whether
it's dependent.
But here, the remainder of the kind of `a` that we're left with
after processing two arguments is just `k`.

The way forward is look up k in the lifting context, getting co1. If we're at
all well-typed, co1 will be a coercion between Π-types, with at least one binder.
So, let's
decompose co1 with decomposePiCos. This decomposition needs arguments to use
to instantiate any kind parameters. Look at the type of co1. If we just
decomposed it, we would end up with coercions whose types include j, which is
out of scope here. Accordingly, decomposePiCos takes a list of types whose
kinds are the *right-hand* types in the decomposed coercion. (See comments on
decomposePiCos.) Because the flattened types have unflattened kinds (because
flattening is homogeneous), passing the list of flattened types to decomposePiCos
just won't do: later arguments' kinds won't be as expected. So we need to get
the *unflattened* types to pass to decomposePiCos. We can do this easily enough
by taking the kind of the argument coercions, passed in originally.

(Alternative 1: We could re-engineer decomposePiCos to deal with this situation.
But that function is already gnarly, and taking the right-hand types is correct
at its other call sites, which are much more common than this one.)

(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its
behavior into simplifyArgsWorker. This would work, I think, but then all of the
complication of decomposePiCos would end up layered on top of all the complication
here. Please, no.)

(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker
so that we don't have to recreate them. But that would complicate the interface
of this function to handle a very dark, dark corner case. Better to keep our
demons to ourselves here instead of exposing them to callers. This decision is
easily reversed if there is ever any performance trouble due to the call of
coercionKind.)

So we now call

  decomposePiCos co1
                 (Pair (forall j. j -> Type) (forall (j :: Star). (j |> axStar) -> Star))
                 [bo |> sym axStar, NoWay |> sym bc]

to get

  co5 :: Star ~ Type
  co6 :: (j |> axStar) ~ (j |> co5), substituted to
                              (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5)
                           == bo ~ bo
  res_co :: Type ~ Star

We then use these casts on (the flattened) (3) and (4) to get

  (Bool |> sym axStar |> co5 :: Type)   -- (C3)
  (False |> sym bc |> co6    :: bo)     -- (C4)

We can simplify to

  Bool                        -- (C3)
  (False |> sym bc :: bo)     -- (C4)

Of course, we still must do the processing in Note [simplifyArgsWorker] to finish
the job. We thus want to recur. Our new function kind is the left-hand type of
co1 (gotten, recall, by lifting the variable k that was the return kind of the
original function). Why the left-hand type (as opposed to the right-hand type)?
Because we have casted all the arguments according to decomposePiCos, which gets
us from the right-hand type to the left-hand one. We thus recur with that new
function kind, zapping our lifting context, because we have essentially applied
it.

This recursive call returns ([Bool, False], [...], Refl). The Bool and False
are the correct arguments we wish to return. But we must be careful about the
result coercion: our new, flattened application will have kind Type, but we
want to make sure that the result coercion casts this back to Star. (Why?
Because we started with an application of kind Star, and flattening is homogeneous.)

So, we have to twiddle the result coercion appropriately.

Let's check whether this is well-typed. We know

  a :: forall (k :: Type). k -> k

  a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type

  a (forall j. j -> Type)
    Proxy
      :: forall j. j -> Type

  a (forall j. j -> Type)
    Proxy
    Bool
      :: Bool -> Type

  a (forall j. j -> Type)
    Proxy
    Bool
    False
      :: Type

  a (forall j. j -> Type)
    Proxy
    Bool
    False
     |> res_co
     :: Star

as desired.

Whew.

Historical note: I (Richard E) once thought that the final part of the kind
had to be a variable k (as in the example above). But it might not be: it could
be an application of a variable. Here is the example:

  let f :: forall (a :: Type) (b :: a -> Type). b (Any @a)
      k :: Type
      x :: k

  flatten (f @Type @((->) k) x)

After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)`
is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded.

-}


-- This is shared between the flattener and the normaliser in FamInstEnv.
-- See Note [simplifyArgsWorker]
{-# INLINE simplifyArgsWorker #-}
simplifyArgsWorker :: [TyCoBinder] -> Kind
                       -- the binders & result kind (not a Π-type) of the function applied to the args
                       -- list of binders can be shorter or longer than the list of args
                   -> TyCoVarSet   -- free vars of the args
                   -> [Role]   -- list of roles, r
                   -> [(Type, Coercion)] -- flattened type arguments, arg
                                         -- each comes with the coercion used to flatten it,
                                         -- with co :: flattened_type ~ original_type
                   -> ([Type], [Coercion], CoercionN)
-- Returns (xis, cos, res_co), where each co :: xi ~ arg,
-- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args
-- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in),
-- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded.
-- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this
-- function is all about. That is, (f xis), where xis are the returned arguments, *is*
-- well kinded.
simplifyArgsWorker :: [TyCoBinder]
-> Type
-> VarSet
-> [Role]
-> [(Type, Coercion)]
-> ([Type], [Coercion], Coercion)
simplifyArgsWorker [TyCoBinder]
orig_ki_binders Type
orig_inner_ki VarSet
orig_fvs
                   [Role]
orig_roles [(Type, Coercion)]
orig_simplified_args
  = [Type]
-> [Coercion]
-> LiftingContext
-> [TyCoBinder]
-> Type
-> [Role]
-> [(Type, Coercion)]
-> ([Type], [Coercion], Coercion)
go [] [] LiftingContext
orig_lc [TyCoBinder]
orig_ki_binders Type
orig_inner_ki [Role]
orig_roles [(Type, Coercion)]
orig_simplified_args
  where
    orig_lc :: LiftingContext
orig_lc = InScopeSet -> LiftingContext
emptyLiftingContext (InScopeSet -> LiftingContext) -> InScopeSet -> LiftingContext
forall a b. (a -> b) -> a -> b
$ VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ VarSet
orig_fvs

    go :: [Type]      -- Xis accumulator, in reverse order
       -> [Coercion]  -- Coercions accumulator, in reverse order
                      -- These are in 1-to-1 correspondence
       -> LiftingContext  -- mapping from tyvars to flattening coercions
       -> [TyCoBinder]    -- Unsubsted binders of function's kind
       -> Kind        -- Unsubsted result kind of function (not a Pi-type)
       -> [Role]      -- Roles at which to flatten these ...
       -> [(Type, Coercion)]  -- flattened arguments, with their flattening coercions
       -> ([Type], [Coercion], CoercionN)
    go :: [Type]
-> [Coercion]
-> LiftingContext
-> [TyCoBinder]
-> Type
-> [Role]
-> [(Type, Coercion)]
-> ([Type], [Coercion], Coercion)
go [Type]
acc_xis [Coercion]
acc_cos LiftingContext
lc [TyCoBinder]
binders Type
inner_ki [Role]
_ []
      = ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
acc_xis, [Coercion] -> [Coercion]
forall a. [a] -> [a]
reverse [Coercion]
acc_cos, Coercion
kind_co)
      where
        final_kind :: Type
final_kind = [TyCoBinder] -> Type -> Type
mkPiTys [TyCoBinder]
binders Type
inner_ki
        kind_co :: Coercion
kind_co = HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
Role -> LiftingContext -> Type -> Coercion
liftCoSubst Role
Nominal LiftingContext
lc Type
final_kind

    go [Type]
acc_xis [Coercion]
acc_cos LiftingContext
lc (TyCoBinder
binder:[TyCoBinder]
binders) Type
inner_ki (Role
role:[Role]
roles) ((Type
xi,Coercion
co):[(Type, Coercion)]
args)
      = -- By Note [Flattening] in TcFlatten invariant (F2),
         -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be
         -- used as an argument to a function whose kind is different, if
         -- earlier arguments have been flattened to new types. We thus
         -- need a coercion (kind_co :: old_kind ~ new_kind).
         --
         -- The bangs here have been observed to improve performance
         -- significantly in optimized builds.
         let kind_co :: Coercion
kind_co = Coercion -> Coercion
mkSymCo (Coercion -> Coercion) -> Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$
               HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
Role -> LiftingContext -> Type -> Coercion
liftCoSubst Role
Nominal LiftingContext
lc (TyCoBinder -> Type
tyCoBinderType TyCoBinder
binder)
             !casted_xi :: Type
casted_xi = Type
xi Type -> Coercion -> Type
`mkCastTy` Coercion
kind_co
             casted_co :: Coercion
casted_co =  Role -> Type -> Coercion -> Coercion -> Coercion
mkCoherenceLeftCo Role
role Type
xi Coercion
kind_co Coercion
co

         -- now, extend the lifting context with the new binding
             !new_lc :: LiftingContext
new_lc | Just CoVar
tv <- TyCoBinder -> Maybe CoVar
tyCoBinderVar_maybe TyCoBinder
binder
                     = LiftingContext -> CoVar -> Coercion -> LiftingContext
extendLiftingContextAndInScope LiftingContext
lc CoVar
tv Coercion
casted_co
                     | Bool
otherwise
                     = LiftingContext
lc
         in
         [Type]
-> [Coercion]
-> LiftingContext
-> [TyCoBinder]
-> Type
-> [Role]
-> [(Type, Coercion)]
-> ([Type], [Coercion], Coercion)
go (Type
casted_xi Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
acc_xis)
            (Coercion
casted_co Coercion -> [Coercion] -> [Coercion]
forall a. a -> [a] -> [a]
: [Coercion]
acc_cos)
            LiftingContext
new_lc
            [TyCoBinder]
binders
            Type
inner_ki
            [Role]
roles
            [(Type, Coercion)]
args


      -- See Note [Last case in simplifyArgsWorker]
    go [Type]
acc_xis [Coercion]
acc_cos LiftingContext
lc [] Type
inner_ki [Role]
roles [(Type, Coercion)]
args
      = let co1 :: Coercion
co1 = HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
Role -> LiftingContext -> Type -> Coercion
liftCoSubst Role
Nominal LiftingContext
lc Type
inner_ki
            co1_kind :: Pair Type
co1_kind              = Coercion -> Pair Type
coercionKind Coercion
co1
            unflattened_tys :: [Type]
unflattened_tys       = ((Type, Coercion) -> Type) -> [(Type, Coercion)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Pair Type -> Type
forall a. Pair a -> a
pSnd (Pair Type -> Type)
-> ((Type, Coercion) -> Pair Type) -> (Type, Coercion) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coercion -> Pair Type
coercionKind (Coercion -> Pair Type)
-> ((Type, Coercion) -> Coercion) -> (Type, Coercion) -> Pair Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, Coercion) -> Coercion
forall a b. (a, b) -> b
snd) [(Type, Coercion)]
args
            ([Coercion]
arg_cos, Coercion
res_co)     = HasDebugCallStack =>
Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion)
Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion)
decomposePiCos Coercion
co1 Pair Type
co1_kind [Type]
unflattened_tys
            casted_args :: [(Type, Coercion)]
casted_args           = ASSERT2( equalLength args arg_cos
                                           , ppr args $$ ppr arg_cos )
                                    [ (Type
casted_xi, Coercion
casted_co)
                                    | ((Type
xi, Coercion
co), Coercion
arg_co, Role
role) <- [(Type, Coercion)]
-> [Coercion] -> [Role] -> [((Type, Coercion), Coercion, Role)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [(Type, Coercion)]
args [Coercion]
arg_cos [Role]
roles
                                    , let casted_xi :: Type
casted_xi = Type
xi Type -> Coercion -> Type
`mkCastTy` Coercion
arg_co
                                          casted_co :: Coercion
casted_co = Role -> Type -> Coercion -> Coercion -> Coercion
mkCoherenceLeftCo Role
role Type
xi Coercion
arg_co Coercion
co ]
               -- In general decomposePiCos can return fewer cos than tys,
               -- but not here; because we're well typed, there will be enough
               -- binders. Note that decomposePiCos does substitutions, so even
               -- if the original substitution results in something ending with
               -- ... -> k, that k will be substituted to perhaps reveal more
               -- binders.
            zapped_lc :: LiftingContext
zapped_lc             = LiftingContext -> LiftingContext
zapLiftingContext LiftingContext
lc
            Pair Type
flattened_kind Type
_ = Pair Type
co1_kind
            ([TyCoBinder]
bndrs, Type
new_inner)    = Type -> ([TyCoBinder], Type)
splitPiTys Type
flattened_kind

            ([Type]
xis_out, [Coercion]
cos_out, Coercion
res_co_out)
              = [Type]
-> [Coercion]
-> LiftingContext
-> [TyCoBinder]
-> Type
-> [Role]
-> [(Type, Coercion)]
-> ([Type], [Coercion], Coercion)
go [Type]
acc_xis [Coercion]
acc_cos LiftingContext
zapped_lc [TyCoBinder]
bndrs Type
new_inner [Role]
roles [(Type, Coercion)]
casted_args
        in
        ([Type]
xis_out, [Coercion]
cos_out, Coercion
res_co_out Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
res_co)

    go [Type]
_ [Coercion]
_ LiftingContext
_ [TyCoBinder]
_ Type
_ [Role]
_ [(Type, Coercion)]
_ = String -> ([Type], [Coercion], Coercion)
forall a. String -> a
panic
        String
"simplifyArgsWorker wandered into deeper water than usual"
           -- This debug information is commented out because leaving it in
           -- causes a ~2% increase in allocations in T9872d.
           -- That's independent of the analagous case in flatten_args_fast
           -- in TcFlatten:
           -- each of these causes a 2% increase on its own, so commenting them
           -- both out gives a 4% decrease in T9872d.
           {-

             (vcat [ppr orig_binders,
                    ppr orig_inner_ki,
                    ppr (take 10 orig_roles), -- often infinite!
                    ppr orig_tys])
           -}