diff options
Diffstat (limited to 'compiler/GHC/Core')
| -rw-r--r-- | compiler/GHC/Core/Coercion.hs | 45 | ||||
| -rw-r--r-- | compiler/GHC/Core/TyCo/Rep.hs | 15 |
2 files changed, 55 insertions, 5 deletions
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 626b1bbc78..317ca00906 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -12,7 +12,8 @@ module GHC.Core.Coercion ( -- * Main data type Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR, - UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar, + UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..), + coHoleCoVar, setCoHoleCoVar, LeftOrRight(..), Var, CoVar, TyCoVar, Role(..), ltRole, @@ -111,7 +112,9 @@ module GHC.Core.Coercion ( -- * Other promoteCoercion, buildCoercion, - simplifyArgsWorker + simplifyArgsWorker, + + badCoercionHole, badCoercionHoleCo ) where #include "HsVersions.h" @@ -148,6 +151,7 @@ import UniqFM import Control.Monad (foldM, zipWithM) import Data.Function ( on ) import Data.Char( isDigit ) +import qualified Data.Monoid as Monoid {- %************************************************************************ @@ -2904,3 +2908,40 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs ppr (take 10 orig_roles), -- often infinite! ppr orig_tys]) -} + +{- +%************************************************************************ +%* * + Coercion holes +%* * +%************************************************************************ +-} + +bad_co_hole_ty :: Type -> Monoid.Any +bad_co_hole_co :: Coercion -> Monoid.Any +(bad_co_hole_ty, _, bad_co_hole_co, _) + = foldTyCo folder () + where + folder = TyCoFolder { tcf_view = const Nothing + , tcf_tyvar = const2 (Monoid.Any False) + , tcf_covar = const2 (Monoid.Any False) + , tcf_hole = const hole + , tcf_tycobinder = const2 + } + + const2 :: a -> b -> c -> a + const2 x _ _ = x + + hole :: CoercionHole -> Monoid.Any + hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True + hole _ = Monoid.Any False + +-- | Is there a blocking coercion hole in this type? See +-- TcCanonical Note [Equalities with incompatible kinds] +badCoercionHole :: Type -> Bool +badCoercionHole = Monoid.getAny . bad_co_hole_ty + +-- | Is there a blocking coercion hole in this coercion? See +-- TcCanonical Note [Equalities with incompatible kinds] +badCoercionHoleCo :: Coercion -> Bool +badCoercionHoleCo = Monoid.getAny . bad_co_hole_co diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 26c01ebcb8..c1ca32fc3c 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -39,7 +39,7 @@ module GHC.Core.TyCo.Rep ( -- * Coercions Coercion(..), UnivCoProvenance(..), - CoercionHole(..), coHoleCoVar, setCoHoleCoVar, + CoercionHole(..), BlockSubstFlag(..), coHoleCoVar, setCoHoleCoVar, CoercionN, CoercionR, CoercionP, KindCoercion, MCoercion(..), MCoercionR, MCoercionN, @@ -1487,12 +1487,18 @@ instance Outputable UnivCoProvenance where -- | A coercion to be filled in by the type-checker. See Note [Coercion holes] data CoercionHole - = CoercionHole { ch_co_var :: CoVar + = CoercionHole { ch_co_var :: CoVar -- See Note [CoercionHoles and coercion free variables] - , ch_ref :: IORef (Maybe Coercion) + , ch_blocker :: BlockSubstFlag -- should this hole block substitution? + -- See (2a) in TcCanonical + -- Note [Equalities with incompatible kinds] + , ch_ref :: IORef (Maybe Coercion) } +data BlockSubstFlag = YesBlockSubst + | NoBlockSubst + coHoleCoVar :: CoercionHole -> CoVar coHoleCoVar = ch_co_var @@ -1508,6 +1514,9 @@ instance Data.Data CoercionHole where instance Outputable CoercionHole where ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) +instance Outputable BlockSubstFlag where + ppr YesBlockSubst = text "YesBlockSubst" + ppr NoBlockSubst = text "NoBlockSubst" {- Note [Phantom coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ |