Commit 7df58960 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari

Implement QuantifiedConstraints

We have wanted quantified constraints for ages and, as I hoped,
they proved remarkably simple to implement.   All the machinery was
already in place.

The main ticket is Trac #2893, but also relevant are
  #5927
  #8516
  #9123 (especially!  higher kinded roles)
  #14070
  #14317

The wiki page is
  https://ghc.haskell.org/trac/ghc/wiki/QuantifiedConstraints
which in turn contains a link to the GHC Proposal where the change
is specified.

Here is the relevant Note:

Note [Quantified constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The -XQuantifiedConstraints extension allows type-class contexts like
this:

  data Rose f x = Rose x (f (Rose f x))

  instance (Eq a, forall b. Eq b => Eq (f b))
        => Eq (Rose f a)  where
    (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 >= rs2

Note the (forall b. Eq b => Eq (f b)) in the instance contexts.
This quantified constraint is needed to solve the
 [W] (Eq (f (Rose f x)))
constraint which arises form the (==) definition.

Here are the moving parts
  * Language extension {-# LANGUAGE QuantifiedConstraints #-}
    and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension

  * A new form of evidence, EvDFun, that is used to discharge
    such wanted constraints

  * checkValidType gets some changes to accept forall-constraints
    only in the right places.

  * Type.PredTree gets a new constructor ForAllPred, and
    and classifyPredType analyses a PredType to decompose
    the new forall-constraints

  * Define a type TcRnTypes.QCInst, which holds a given
    quantified constraint in the inert set

  * TcSMonad.InertCans gets an extra field, inert_insts :: [QCInst],
    which holds all the Given forall-constraints.  In effect,
    such Given constraints are like local instance decls.

  * When trying to solve a class constraint, via
    TcInteract.matchInstEnv, use the InstEnv from inert_insts
    so that we include the local Given forall-constraints
    in the lookup.  (See TcSMonad.getInstEnvs.)

  * topReactionsStage calls doTopReactOther for CIrredCan and
    CTyEqCan, so they can try to react with any given
    quantified constraints (TcInteract.matchLocalInst)

  * TcCanonical.canForAll deals with solving a
    forall-constraint.  See
       Note [Solving a Wanted forall-constraint]
       Note [Solving a Wanted forall-constraint]

  * We augment the kick-out code to kick out an inert
    forall constraint if it can be rewritten by a new
    type equality; see TcSMonad.kick_out_rewritable

Some other related refactoring
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

* Move SCC on evidence bindings to post-desugaring, which fixed
  #14735, and is generally nicer anyway because we can use
  existing CoreSyn free-var functions.  (Quantified constraints
  made the free-vars of an ev-term a bit more complicated.)

* In LookupInstResult, replace GenInst with OneInst and NotSure,
  using the latter for multiple matches and/or one or more
  unifiers
parent 36091ec9
...@@ -221,7 +221,7 @@ setIdInfo :: Id -> IdInfo -> Id ...@@ -221,7 +221,7 @@ setIdInfo :: Id -> IdInfo -> Id
setIdInfo id info = info `seq` (lazySetIdInfo id info) setIdInfo id info = info `seq` (lazySetIdInfo id info)
-- Try to avoid spack leaks by seq'ing -- Try to avoid spack leaks by seq'ing
modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) modifyIdInfo fn id = setIdInfo id (fn (idInfo id))
-- maybeModifyIdInfo tries to avoid unnecessary thrashing -- maybeModifyIdInfo tries to avoid unnecessary thrashing
......
...@@ -53,7 +53,7 @@ import Name ...@@ -53,7 +53,7 @@ import Name
import VarSet import VarSet
import Rules import Rules
import VarEnv import VarEnv
import Var( EvVar ) import Var( EvVar, varType )
import Outputable import Outputable
import Module import Module
import SrcLoc import SrcLoc
...@@ -64,6 +64,7 @@ import BasicTypes ...@@ -64,6 +64,7 @@ import BasicTypes
import DynFlags import DynFlags
import FastString import FastString
import Util import Util
import UniqSet( nonDetEltsUniqSet )
import MonadUtils import MonadUtils
import qualified GHC.LanguageExtensions as LangExt import qualified GHC.LanguageExtensions as LangExt
import Control.Monad import Control.Monad
...@@ -1144,15 +1145,39 @@ dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this ...@@ -1144,15 +1145,39 @@ dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = dsEvBinds bs dsTcEvBinds (EvBinds bs) = dsEvBinds bs
dsEvBinds :: Bag EvBind -> DsM [CoreBind] dsEvBinds :: Bag EvBind -> DsM [CoreBind]
dsEvBinds bs = mapM ds_scc (sccEvBinds bs) dsEvBinds bs
= do { ds_bs <- mapBagM dsEvBind bs
; return (mk_ev_binds ds_bs) }
mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
-- We do SCC analysis of the evidence bindings, /after/ desugaring
-- them. This is convenient: it means we can use the CoreSyn
-- free-variable functions rather than having to do accurate free vars
-- for EvTerm.
mk_ev_binds ds_binds
= map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
where where
ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r})) edges :: [ Node EvVar (EvVar,CoreExpr) ]
= liftM (NonRec v) (dsEvTerm r) edges = foldrBag ((:) . mk_node) [] ds_binds
ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs)
mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
mk_node b@(var, rhs)
= DigraphNode { node_payload = b
, node_key = var
, node_dependencies = nonDetEltsUniqSet $
exprFreeVars rhs `unionVarSet`
coVarsOfType (varType var) }
-- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
-- is still deterministic even if the edges are in nondeterministic order
-- as explained in Note [Deterministic SCC] in Digraph.
ds_scc (AcyclicSCC (v,r)) = NonRec v r
ds_scc (CyclicSCC prs) = Rec prs
dsEvBind :: EvBind -> DsM (Id, CoreExpr) dsEvBind :: EvBind -> DsM (Id, CoreExpr)
dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
{-********************************************************************** {-**********************************************************************
* * * *
Desugaring EvTerms Desugaring EvTerms
...@@ -1162,6 +1187,13 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) ...@@ -1162,6 +1187,13 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
dsEvTerm :: EvTerm -> DsM CoreExpr dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvExpr e) = return e dsEvTerm (EvExpr e) = return e
dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
dsEvTerm (EvFun { et_tvs = tvs, et_given = given
, et_binds = ev_binds, et_body = wanted_id })
= do { ds_ev_binds <- dsTcEvBinds ev_binds
; return $ (mkLams (tvs ++ given) $
mkCoreLets ds_ev_binds $
Var wanted_id) }
{-********************************************************************** {-**********************************************************************
* * * *
......
...@@ -4186,6 +4186,7 @@ xFlagsDeps = [ ...@@ -4186,6 +4186,7 @@ xFlagsDeps = [
flagSpec "PatternSynonyms" LangExt.PatternSynonyms, flagSpec "PatternSynonyms" LangExt.PatternSynonyms,
flagSpec "PolyKinds" LangExt.PolyKinds, flagSpec "PolyKinds" LangExt.PolyKinds,
flagSpec "PolymorphicComponents" LangExt.RankNTypes, flagSpec "PolymorphicComponents" LangExt.RankNTypes,
flagSpec "QuantifiedConstraints" LangExt.QuantifiedConstraints,
flagSpec "PostfixOperators" LangExt.PostfixOperators, flagSpec "PostfixOperators" LangExt.PostfixOperators,
flagSpec "QuasiQuotes" LangExt.QuasiQuotes, flagSpec "QuasiQuotes" LangExt.QuasiQuotes,
flagSpec "Rank2Types" LangExt.RankNTypes, flagSpec "Rank2Types" LangExt.RankNTypes,
...@@ -4309,6 +4310,7 @@ impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] ...@@ -4309,6 +4310,7 @@ impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]
impliedXFlags impliedXFlags
-- See Note [Updating flag description in the User's Guide] -- See Note [Updating flag description in the User's Guide]
= [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll)
, (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll)
, (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll)
, (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll)
, (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)
......
...@@ -2011,6 +2011,7 @@ mkCallUDs' env f args ...@@ -2011,6 +2011,7 @@ mkCallUDs' env f args
EqPred {} -> True EqPred {} -> True
IrredPred {} -> True -- Things like (D []) where D is a IrredPred {} -> True -- Things like (D []) where D is a
-- Constraint-ranged family; Trac #7785 -- Constraint-ranged family; Trac #7785
ForAllPred {} -> True
{- {-
Note [Type determines value] Note [Type determines value]
......
...@@ -55,6 +55,7 @@ import TcType ...@@ -55,6 +55,7 @@ import TcType
import HscTypes import HscTypes
import Class( Class ) import Class( Class )
import MkId( mkDictFunId ) import MkId( mkDictFunId )
import CoreSyn( Expr(..) ) -- For the Coercion constructor
import Id import Id
import Name import Name
import Var ( EvVar, mkTyVar, tyVarName, TyVarBndr(..) ) import Var ( EvVar, mkTyVar, tyVarName, TyVarBndr(..) )
...@@ -352,6 +353,7 @@ instCallConstraints orig preds ...@@ -352,6 +353,7 @@ instCallConstraints orig preds
; traceTc "instCallConstraints" (ppr evs) ; traceTc "instCallConstraints" (ppr evs)
; return (mkWpEvApps evs) } ; return (mkWpEvApps evs) }
where where
go :: TcPredType -> TcM EvTerm
go pred go pred
| Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1 | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
= do { co <- unifyType Nothing ty1 ty2 = do { co <- unifyType Nothing ty1 ty2
...@@ -361,7 +363,7 @@ instCallConstraints orig preds ...@@ -361,7 +363,7 @@ instCallConstraints orig preds
| Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
, tc `hasKey` heqTyConKey , tc `hasKey` heqTyConKey
= do { co <- unifyType Nothing ty1 ty2 = do { co <- unifyType Nothing ty1 ty2
; return (evDFunApp (dataConWrapId heqDataCon) args [evCoercion co]) } ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
| otherwise | otherwise
= emitWanted orig pred = emitWanted orig pred
...@@ -371,10 +373,14 @@ instDFunType :: DFunId -> [DFunInstType] ...@@ -371,10 +373,14 @@ instDFunType :: DFunId -> [DFunInstType]
, TcThetaType ) -- instantiated constraint , TcThetaType ) -- instantiated constraint
-- See Note [DFunInstType: instantiating types] in InstEnv -- See Note [DFunInstType: instantiating types] in InstEnv
instDFunType dfun_id dfun_inst_tys instDFunType dfun_id dfun_inst_tys
= do { (subst, inst_tys) <- go emptyTCvSubst dfun_tvs dfun_inst_tys = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
; return (inst_tys, substTheta subst dfun_theta) } ; return (inst_tys, substTheta subst dfun_theta) }
where where
(dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id) dfun_ty = idType dfun_id
(dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
-- With quantified constraints, the
-- type of a dfun may not be closed
go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType]) go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
go subst [] [] = return (subst, []) go subst [] [] = return (subst, [])
......
This diff is collapsed.
...@@ -864,11 +864,11 @@ addDeferredBinding ctxt err ct ...@@ -864,11 +864,11 @@ addDeferredBinding ctxt err ct
; case dest of ; case dest of
EvVarDest evar EvVarDest evar
-> addTcEvBind ev_binds_var $ mkWantedEvBind evar (EvExpr err_tm) -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
HoleDest hole HoleDest hole
-> do { -- See Note [Deferred errors for coercion holes] -> do { -- See Note [Deferred errors for coercion holes]
let co_var = coHoleCoVar hole let co_var = coHoleCoVar hole
; addTcEvBind ev_binds_var $ mkWantedEvBind co_var (EvExpr err_tm) ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm
; fillCoercionHole hole (mkTcCoVarCo co_var) }} ; fillCoercionHole hole (mkTcCoVarCo co_var) }}
| otherwise -- Do not set any evidence for Given/Derived | otherwise -- Do not set any evidence for Given/Derived
......
...@@ -23,9 +23,10 @@ import SrcLoc ...@@ -23,9 +23,10 @@ import SrcLoc
-- Used with Opt_DeferTypeErrors -- Used with Opt_DeferTypeErrors
-- See Note [Deferring coercion errors to runtime] -- See Note [Deferring coercion errors to runtime]
-- in TcSimplify -- in TcSimplify
evDelayedError :: Type -> FastString -> EvExpr evDelayedError :: Type -> FastString -> EvTerm
evDelayedError ty msg evDelayedError ty msg
= Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg] = EvExpr $
Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
where where
errorId = tYPE_ERROR_ID errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg)) litMsg = Lit (MachStr (fastStringToByteString msg))
......
...@@ -16,14 +16,14 @@ module TcEvidence ( ...@@ -16,14 +16,14 @@ module TcEvidence (
lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap, lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap,
isEmptyEvBindMap, isEmptyEvBindMap,
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
sccEvBinds, evBindVar, isNoEvBindsVar, evBindVar, isNoEvBindsVar,
-- EvTerm (already a CoreExpr) -- EvTerm (already a CoreExpr)
EvTerm(..), EvExpr, EvTerm(..), EvExpr,
evId, evCoercion, evCast, evDFunApp, evSelector, evId, evCoercion, evCast, evDFunApp, evSelector,
mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars, mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars,
evTermCoercion, evTermCoercion, evTermCoercion_maybe,
EvCallStack(..), EvCallStack(..),
EvTypeable(..), EvTypeable(..),
...@@ -69,7 +69,6 @@ import CoreFVs ( exprSomeFreeVars ) ...@@ -69,7 +69,6 @@ import CoreFVs ( exprSomeFreeVars )
import Util import Util
import Bag import Bag
import Digraph
import qualified Data.Data as Data import qualified Data.Data as Data
import Outputable import Outputable
import SrcLoc import SrcLoc
...@@ -315,8 +314,8 @@ mkWpCastN co ...@@ -315,8 +314,8 @@ mkWpCastN co
mkWpTyApps :: [Type] -> HsWrapper mkWpTyApps :: [Type] -> HsWrapper
mkWpTyApps tys = mk_co_app_fn WpTyApp tys mkWpTyApps tys = mk_co_app_fn WpTyApp tys
mkWpEvApps :: [EvExpr] -> HsWrapper mkWpEvApps :: [EvTerm] -> HsWrapper
mkWpEvApps args = mk_co_app_fn WpEvApp (map EvExpr args) mkWpEvApps args = mk_co_app_fn WpEvApp args
mkWpEvVarApps :: [EvVar] -> HsWrapper mkWpEvVarApps :: [EvVar] -> HsWrapper
mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs) mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs)
...@@ -416,7 +415,6 @@ instance Data.Data TcEvBinds where ...@@ -416,7 +415,6 @@ instance Data.Data TcEvBinds where
{- Note [No evidence bindings] {- Note [No evidence bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Class constraints etc give rise to /term/ bindings for evidence, and Class constraints etc give rise to /term/ bindings for evidence, and
we have nowhere to put term bindings in /types/. So in some places we we have nowhere to put term bindings in /types/. So in some places we
use NoEvBindsVar (see newNoTcEvBinds) to signal that no term-level use NoEvBindsVar (see newNoTcEvBinds) to signal that no term-level
...@@ -501,8 +499,8 @@ mkWantedEvBind :: EvVar -> EvTerm -> EvBind ...@@ -501,8 +499,8 @@ mkWantedEvBind :: EvVar -> EvTerm -> EvBind
mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm }
-- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm -- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm
mkGivenEvBind :: EvVar -> EvExpr -> EvBind mkGivenEvBind :: EvVar -> EvTerm -> EvBind
mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = EvExpr tm } mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm }
-- An EvTerm is, conceptually, a CoreExpr that implements the constraint. -- An EvTerm is, conceptually, a CoreExpr that implements the constraint.
...@@ -510,8 +508,17 @@ mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = EvExpr ...@@ -510,8 +508,17 @@ mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = EvExpr
-- type EvTerm = CoreExpr -- type EvTerm = CoreExpr
-- Because of staging problems issues around EvTypeable -- Because of staging problems issues around EvTypeable
data EvTerm data EvTerm
= EvExpr EvExpr = EvExpr EvExpr
| EvTypeable Type EvTypeable -- Dictionary for (Typeable ty)
| EvTypeable Type EvTypeable -- Dictionary for (Typeable ty)
| EvFun -- /\as \ds. let binds in v
{ et_tvs :: [TyVar]
, et_given :: [EvVar]
, et_binds :: TcEvBinds -- This field is why we need an EvFun
-- constructor, and can't just use EvExpr
, et_body :: EvVar }
deriving Data.Data deriving Data.Data
type EvExpr = CoreExpr type EvExpr = CoreExpr
...@@ -525,17 +532,17 @@ evId = Var ...@@ -525,17 +532,17 @@ evId = Var
-- coercion bindings -- coercion bindings
-- See Note [Coercion evidence terms] -- See Note [Coercion evidence terms]
evCoercion :: TcCoercion -> EvExpr evCoercion :: TcCoercion -> EvTerm
evCoercion = Coercion evCoercion co = EvExpr (Coercion co)
-- | d |> co -- | d |> co
evCast :: EvExpr -> TcCoercion -> EvExpr evCast :: EvExpr -> TcCoercion -> EvTerm
evCast et tc | isReflCo tc = et evCast et tc | isReflCo tc = EvExpr et
| otherwise = Cast et tc | otherwise = EvExpr (Cast et tc)
-- Dictionary instance application -- Dictionary instance application
evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvExpr evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm
evDFunApp df tys ets = Var df `mkTyApps` tys `mkApps` ets evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets
-- Selector id plus the types at which it -- Selector id plus the types at which it
-- should be instantiated, used for HasField -- should be instantiated, used for HasField
...@@ -544,7 +551,6 @@ evDFunApp df tys ets = Var df `mkTyApps` tys `mkApps` ets ...@@ -544,7 +551,6 @@ evDFunApp df tys ets = Var df `mkTyApps` tys `mkApps` ets
evSelector :: Id -> [Type] -> [EvExpr] -> EvExpr evSelector :: Id -> [Type] -> [EvExpr] -> EvExpr
evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms
-- Dictionary for (Typeable ty) -- Dictionary for (Typeable ty)
evTypeable :: Type -> EvTypeable -> EvTerm evTypeable :: Type -> EvTypeable -> EvTerm
evTypeable = EvTypeable evTypeable = EvTypeable
...@@ -762,17 +768,23 @@ Important Details: ...@@ -762,17 +768,23 @@ Important Details:
-} -}
mkEvCast :: EvExpr -> TcCoercion -> EvExpr mkEvCast :: EvExpr -> TcCoercion -> EvTerm
mkEvCast ev lco mkEvCast ev lco
| ASSERT2(tcCoercionRole lco == Representational, (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco])) | ASSERT2( tcCoercionRole lco == Representational
isTcReflCo lco = ev , (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]))
isTcReflCo lco = EvExpr ev
| otherwise = evCast ev lco | otherwise = evCast ev lco
mkEvScSelectors :: EvExpr -> Class -> [TcType] -> [(TcPredType, EvExpr)]
mkEvScSelectors ev cls tys mkEvScSelectors -- Assume class (..., D ty, ...) => C a b
:: Class -> [TcType] -- C ty1 ty2
-> [(TcPredType, -- D ty[ty1/a,ty2/b]
EvExpr) -- :: C ty1 ty2 -> D ty[ty1/a,ty2/b]
]
mkEvScSelectors cls tys
= zipWith mk_pr (immSuperClasses cls tys) [0..] = zipWith mk_pr (immSuperClasses cls tys) [0..]
where where
mk_pr pred i = (pred, Var sc_sel_id `mkTyApps` tys `App` ev) mk_pr pred i = (pred, Var sc_sel_id `mkTyApps` tys)
where where
sc_sel_id = classSCSelId cls i -- Zero-indexed sc_sel_id = classSCSelId cls i -- Zero-indexed
...@@ -783,17 +795,31 @@ isEmptyTcEvBinds :: TcEvBinds -> Bool ...@@ -783,17 +795,31 @@ isEmptyTcEvBinds :: TcEvBinds -> Bool
isEmptyTcEvBinds (EvBinds b) = isEmptyBag b isEmptyTcEvBinds (EvBinds b) = isEmptyBag b
isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
evTermCoercion :: EvTerm -> TcCoercion evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion
-- Applied only to EvTerms of type (s~t) -- Applied only to EvTerms of type (s~t)
-- See Note [Coercion evidence terms] -- See Note [Coercion evidence terms]
evTermCoercion_maybe ev_term
| EvExpr e <- ev_term = go e
| otherwise = Nothing
where
go :: EvExpr -> Maybe TcCoercion
go (Var v) = return (mkCoVarCo v)
go (Coercion co) = return co
go (Cast tm co) = do { co' <- go tm
; return (mkCoCast co' co) }
go _ = Nothing
{- evTermCoercion :: EvTerm -> TcCoercion
************************************************************************ evTermCoercion tm = case evTermCoercion_maybe tm of
Just co -> co
Nothing -> pprPanic "evTermCoercion" (ppr tm)
{- *********************************************************************
* * * *
Free variables Free variables
* * * *
************************************************************************ ********************************************************************* -}
-}
findNeededEvVars :: EvBindMap -> VarSet -> VarSet findNeededEvVars :: EvBindMap -> VarSet -> VarSet
findNeededEvVars ev_binds seeds findNeededEvVars ev_binds seeds
...@@ -813,14 +839,10 @@ findNeededEvVars ev_binds seeds ...@@ -813,14 +839,10 @@ findNeededEvVars ev_binds seeds
| otherwise | otherwise
= needs = needs
evTermCoercion (EvExpr (Var v)) = mkCoVarCo v
evTermCoercion (EvExpr (Coercion co)) = co
evTermCoercion (EvExpr (Cast tm co)) = mkCoCast (evTermCoercion (EvExpr tm)) co
evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm)
evVarsOfTerm :: EvTerm -> VarSet evVarsOfTerm :: EvTerm -> VarSet
evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e
evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev
evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun]
evVarsOfTerms :: [EvTerm] -> VarSet evVarsOfTerms :: [EvTerm] -> VarSet
evVarsOfTerms = mapUnionVarSet evVarsOfTerm evVarsOfTerms = mapUnionVarSet evVarsOfTerm
...@@ -833,22 +855,20 @@ evVarsOfTypeable ev = ...@@ -833,22 +855,20 @@ evVarsOfTypeable ev =
EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2] EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2]
EvTypeableTyLit e -> evVarsOfTerm e EvTypeableTyLit e -> evVarsOfTerm e
-- | Do SCC analysis on a bag of 'EvBind's.
sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges
where
edges :: [ Node EvVar EvBind ]
edges = foldrBag ((:) . mk_node) [] bs
mk_node :: EvBind -> Node EvVar EvBind {- Note [Free vars of EvFun]
mk_node b@(EvBind { eb_lhs = var, eb_rhs = term }) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
= DigraphNode b var (nonDetEltsUniqSet (evVarsOfTerm term `unionVarSet` Finding the free vars of an EvFun is made tricky by the fact the
coVarsOfType (varType var))) bindings et_binds may be a mutable variable. Fortunately, we
-- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices can just squeeze by. Here's how.
-- is still deterministic even if the edges are in nondeterministic order
-- as explained in Note [Deterministic SCC] in Digraph. * evVarsOfTerm is used only by TcSimplify.neededEvVars.
* Each EvBindsVar in an et_binds field of an EvFun is /also/ in the
ic_binds field of an Implication
* So we can track usage via the processing for that implication,
(see Note [Tracking redundant constraints] in TcSimplify).
We can ignore usage from the EvFun altogether.
{-
************************************************************************ ************************************************************************
* * * *
Pretty printing Pretty printing
...@@ -881,11 +901,12 @@ pprHsWrapper wrap pp_thing_inside ...@@ -881,11 +901,12 @@ pprHsWrapper wrap pp_thing_inside
<+> pprParendCo co)] <+> pprParendCo co)]
help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)]
help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty]
help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pp_bndr id, it False] help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False]
help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pp_bndr tv, it False] help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False]
help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False]
pp_bndr v = pprBndr LambdaBind v <> dot pprLamBndr :: Id -> SDoc
pprLamBndr v = pprBndr LambdaBind v
add_parens, no_parens :: SDoc -> Bool -> SDoc add_parens, no_parens :: SDoc -> Bool -> SDoc
add_parens d True = parens d add_parens d True = parens d
...@@ -916,6 +937,9 @@ instance Outputable EvBind where ...@@ -916,6 +937,9 @@ instance Outputable EvBind where
instance Outputable EvTerm where instance Outputable EvTerm where
ppr (EvExpr e) = ppr e ppr (EvExpr e) = ppr e
ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty
ppr (EvFun { et_tvs = tvs, et_given = gs, et_binds = bs, et_body = w })
= hang (text "\\" <+> sep (map pprLamBndr (tvs ++ gs)) <+> arrow)
2 (ppr bs $$ ppr w) -- Not very pretty
instance Outputable EvCallStack where instance Outputable EvCallStack where