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
setIdInfo id info = info `seq` (lazySetIdInfo id info)
-- 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))
-- maybeModifyIdInfo tries to avoid unnecessary thrashing
......
......@@ -53,7 +53,7 @@ import Name
import VarSet
import Rules
import VarEnv
import Var( EvVar )
import Var( EvVar, varType )
import Outputable
import Module
import SrcLoc
......@@ -64,6 +64,7 @@ import BasicTypes
import DynFlags
import FastString
import Util
import UniqSet( nonDetEltsUniqSet )
import MonadUtils
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
......@@ -1144,15 +1145,39 @@ dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = dsEvBinds bs
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
ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r}))
= liftM (NonRec v) (dsEvTerm r)
ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs)
edges :: [ Node EvVar (EvVar,CoreExpr) ]
edges = foldrBag ((:) . mk_node) [] ds_binds
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 { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
{-**********************************************************************
* *
Desugaring EvTerms
......@@ -1162,6 +1187,13 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvExpr e) = return e
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 = [
flagSpec "PatternSynonyms" LangExt.PatternSynonyms,
flagSpec "PolyKinds" LangExt.PolyKinds,
flagSpec "PolymorphicComponents" LangExt.RankNTypes,
flagSpec "QuantifiedConstraints" LangExt.QuantifiedConstraints,
flagSpec "PostfixOperators" LangExt.PostfixOperators,
flagSpec "QuasiQuotes" LangExt.QuasiQuotes,
flagSpec "Rank2Types" LangExt.RankNTypes,
......@@ -4309,6 +4310,7 @@ impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]
impliedXFlags
-- See Note [Updating flag description in the User's Guide]
= [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll)
, (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll)
, (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll)
, (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll)
, (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)
......
......@@ -2011,6 +2011,7 @@ mkCallUDs' env f args
EqPred {} -> True
IrredPred {} -> True -- Things like (D []) where D is a
-- Constraint-ranged family; Trac #7785
ForAllPred {} -> True
{-
Note [Type determines value]
......
......@@ -55,6 +55,7 @@ import TcType
import HscTypes
import Class( Class )
import MkId( mkDictFunId )
import CoreSyn( Expr(..) ) -- For the Coercion constructor
import Id
import Name
import Var ( EvVar, mkTyVar, tyVarName, TyVarBndr(..) )
......@@ -352,6 +353,7 @@ instCallConstraints orig preds
; traceTc "instCallConstraints" (ppr evs)
; return (mkWpEvApps evs) }
where
go :: TcPredType -> TcM EvTerm
go pred
| Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
= do { co <- unifyType Nothing ty1 ty2
......@@ -361,7 +363,7 @@ instCallConstraints orig preds
| Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
, tc `hasKey` heqTyConKey
= do { co <- unifyType Nothing ty1 ty2
; return (evDFunApp (dataConWrapId heqDataCon) args [evCoercion co]) }
; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
| otherwise
= emitWanted orig pred
......@@ -371,10 +373,14 @@ instDFunType :: DFunId -> [DFunInstType]
, TcThetaType ) -- instantiated constraint
-- See Note [DFunInstType: instantiating types] in InstEnv
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) }
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 subst [] [] = return (subst, [])
......
This diff is collapsed.
......@@ -864,11 +864,11 @@ addDeferredBinding ctxt err ct
; case dest of
EvVarDest evar
-> addTcEvBind ev_binds_var $ mkWantedEvBind evar (EvExpr err_tm)
-> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
HoleDest hole
-> do { -- See Note [Deferred errors for coercion holes]
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) }}
| otherwise -- Do not set any evidence for Given/Derived
......
......@@ -23,9 +23,10 @@ import SrcLoc
-- Used with Opt_DeferTypeErrors
-- See Note [Deferring coercion errors to runtime]
-- in TcSimplify
evDelayedError :: Type -> FastString -> EvExpr
evDelayedError :: Type -> FastString -> EvTerm
evDelayedError ty msg
= Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
= EvExpr $
Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
......
......@@ -16,14 +16,14 @@ module TcEvidence (
lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap,
isEmptyEvBindMap,
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
sccEvBinds, evBindVar, isNoEvBindsVar,
evBindVar, isNoEvBindsVar,
-- EvTerm (already a CoreExpr)
EvTerm(..), EvExpr,
evId, evCoercion, evCast, evDFunApp, evSelector,
mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars,
evTermCoercion,
evTermCoercion, evTermCoercion_maybe,
EvCallStack(..),
EvTypeable(..),
......@@ -69,7 +69,6 @@ import CoreFVs ( exprSomeFreeVars )
import Util
import Bag
import Digraph
import qualified Data.Data as Data
import Outputable
import SrcLoc
......@@ -315,8 +314,8 @@ mkWpCastN co
mkWpTyApps :: [Type] -> HsWrapper
mkWpTyApps tys = mk_co_app_fn WpTyApp tys
mkWpEvApps :: [EvExpr] -> HsWrapper
mkWpEvApps args = mk_co_app_fn WpEvApp (map EvExpr args)
mkWpEvApps :: [EvTerm] -> HsWrapper
mkWpEvApps args = mk_co_app_fn WpEvApp args
mkWpEvVarApps :: [EvVar] -> HsWrapper
mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs)
......@@ -416,7 +415,6 @@ instance Data.Data TcEvBinds where
{- Note [No evidence bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
use NoEvBindsVar (see newNoTcEvBinds) to signal that no term-level
......@@ -501,8 +499,8 @@ mkWantedEvBind :: EvVar -> EvTerm -> EvBind
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
mkGivenEvBind :: EvVar -> EvExpr -> EvBind
mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = EvExpr tm }
mkGivenEvBind :: EvVar -> EvTerm -> EvBind
mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm }
-- 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
-- type EvTerm = CoreExpr
-- Because of staging problems issues around EvTypeable
data EvTerm
= EvExpr EvExpr
| EvTypeable Type EvTypeable -- Dictionary for (Typeable ty)
= EvExpr EvExpr
| 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
type EvExpr = CoreExpr
......@@ -525,17 +532,17 @@ evId = Var
-- coercion bindings
-- See Note [Coercion evidence terms]
evCoercion :: TcCoercion -> EvExpr
evCoercion = Coercion
evCoercion :: TcCoercion -> EvTerm
evCoercion co = EvExpr (Coercion co)
-- | d |> co
evCast :: EvExpr -> TcCoercion -> EvExpr
evCast et tc | isReflCo tc = et
| otherwise = Cast et tc
evCast :: EvExpr -> TcCoercion -> EvTerm
evCast et tc | isReflCo tc = EvExpr et
| otherwise = EvExpr (Cast et tc)
-- Dictionary instance application
evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvExpr
evDFunApp df tys ets = Var df `mkTyApps` tys `mkApps` ets
evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm
evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets
-- Selector id plus the types at which it
-- should be instantiated, used for HasField
......@@ -544,7 +551,6 @@ evDFunApp df tys ets = Var df `mkTyApps` tys `mkApps` ets
evSelector :: Id -> [Type] -> [EvExpr] -> EvExpr
evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms
-- Dictionary for (Typeable ty)
evTypeable :: Type -> EvTypeable -> EvTerm
evTypeable = EvTypeable
......@@ -762,17 +768,23 @@ Important Details:
-}
mkEvCast :: EvExpr -> TcCoercion -> EvExpr
mkEvCast :: EvExpr -> TcCoercion -> EvTerm
mkEvCast ev lco
| ASSERT2(tcCoercionRole lco == Representational, (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]))
isTcReflCo lco = ev
| ASSERT2( tcCoercionRole lco == Representational
, (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]))
isTcReflCo lco = EvExpr ev
| 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..]
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
sc_sel_id = classSCSelId cls i -- Zero-indexed
......@@ -783,17 +795,31 @@ isEmptyTcEvBinds :: TcEvBinds -> Bool
isEmptyTcEvBinds (EvBinds b) = isEmptyBag b
isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
evTermCoercion :: EvTerm -> TcCoercion
evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion
-- Applied only to EvTerms of type (s~t)
-- 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
* *
************************************************************************
-}
********************************************************************* -}
findNeededEvVars :: EvBindMap -> VarSet -> VarSet
findNeededEvVars ev_binds seeds
......@@ -813,14 +839,10 @@ findNeededEvVars ev_binds seeds
| otherwise
= 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 (EvExpr e) = exprSomeFreeVars isEvVar e
evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev
evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun]
evVarsOfTerms :: [EvTerm] -> VarSet
evVarsOfTerms = mapUnionVarSet evVarsOfTerm
......@@ -833,22 +855,20 @@ evVarsOfTypeable ev =
EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2]
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
mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
= DigraphNode b var (nonDetEltsUniqSet (evVarsOfTerm term `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.
{- Note [Free vars of EvFun]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Finding the free vars of an EvFun is made tricky by the fact the
bindings et_binds may be a mutable variable. Fortunately, we
can just squeeze by. Here's how.
* 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
......@@ -881,11 +901,12 @@ pprHsWrapper wrap pp_thing_inside
<+> pprParendCo co)]
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 (WpEvLam id) = add_parens $ sep [ text "\\" <> pp_bndr id, it False]
help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pp_bndr tv, it False]
help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, 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]
pp_bndr v = pprBndr LambdaBind v <> dot
pprLamBndr :: Id -> SDoc
pprLamBndr v = pprBndr LambdaBind v
add_parens, no_parens :: SDoc -> Bool -> SDoc
add_parens d True = parens d
......@@ -916,6 +937,9 @@ instance Outputable EvBind where
instance Outputable EvTerm where
ppr (EvExpr e) = ppr e
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
ppr EvCsEmpty
......
......@@ -346,6 +346,15 @@ zonkEvVarOcc env v
= return (EvId $ zonkIdOcc env v)
-}
zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
zonkCoreBndrX env v
| isId v = do { v' <- zonkIdBndr env v
; return (extendIdZonkEnv1 env v', v') }
| otherwise = zonkTyBndrX env v
zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
zonkCoreBndrsX = mapAccumLM zonkCoreBndrX
zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX = mapAccumLM zonkTyBndrX
......@@ -1437,10 +1446,18 @@ zonkRule _ (XRuleDecl _) = panic "zonkRule"
-}
zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm env (EvExpr e) =
EvExpr <$> zonkCoreExpr env e
zonkEvTerm env (EvTypeable ty ev) =
EvTypeable <$> zonkTcTypeToType env ty <*> zonkEvTypeable env ev
zonkEvTerm env (EvExpr e)
= EvExpr <$> zonkCoreExpr env e
zonkEvTerm env (EvTypeable ty ev)
= EvTypeable <$> zonkTcTypeToType env ty <*> zonkEvTypeable env ev
zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs
, et_binds = ev_binds, et_body = body_id })
= do { (env0, new_tvs) <- zonkTyBndrsX env tvs
; (env1, new_evs) <- zonkEvBndrsX env0 evs
; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
; let new_body_id = zonkIdOcc env2 body_id
; return (EvFun { et_tvs = new_tvs, et_given = new_evs
, et_binds = new_ev_binds, et_body = new_body_id }) }
zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
zonkCoreExpr env (Var v)
......@@ -1463,9 +1480,8 @@ zonkCoreExpr env (Tick t e)
zonkCoreExpr env (App e1 e2)
= App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2
zonkCoreExpr env (Lam v e)
= do v' <- zonkIdBndr env v
let env1 = extendIdZonkEnv1 env v'
Lam v' <$> zonkCoreExpr env1 e
= do { (env1, v') <- zonkCoreBndrX env v
; Lam v' <$> zonkCoreExpr env1 e }
zonkCoreExpr env (Let bind e)
= do (env1, bind') <- zonkCoreBind env bind
Let bind'<$> zonkCoreExpr env1 e
......@@ -1478,11 +1494,10 @@ zonkCoreExpr env (Case scrut b ty alts)
return $ Case scrut' b' ty' alts'
zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt
zonkCoreAlt env (dc, pats, rhs)
= do pats' <- mapM (zonkIdBndr env) pats
let env1 = extendZonkEnv env pats'
zonkCoreAlt env (dc, bndrs, rhs)
= do (env1, bndrs') <- zonkCoreBndrsX env bndrs
rhs' <- zonkCoreExpr env1 rhs
return $ (dc, pats', rhs')
return $ (dc, bndrs', rhs')
zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
zonkCoreBind env (NonRec v e)
......@@ -1558,7 +1573,7 @@ zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
; term' <- case getEqPredTys_maybe (idType var') of
Just (r, ty1, ty2) | ty1 `eqType` ty2
-> return (EvExpr (evCoercion (mkTcReflCo r ty1)))
-> return (evCoercion (mkTcReflCo r ty1))
_other -> zonkEvTerm env term
; return (bind { eb_lhs = var', eb_rhs = term' }) }
......
......@@ -1052,7 +1052,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
; sc_ev_id <- newEvVar sc_pred
; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id (EvExpr sc_ev_tm)
; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm
; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred)
sc_top_id = mkLocalId sc_top_name sc_top_ty
export = ABE { abe_ext = noExt
......
This diff is collapsed.
......@@ -205,11 +205,11 @@ cloneWC wc@(WC { wc_simple = simples, wc_impl = implics })
; return (implic { ic_wanted = inner_wanted' }) }
-- | Emits a new Wanted. Deals with both equalities and non-equalities.
emitWanted :: CtOrigin -> TcPredType -> TcM EvExpr
emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm
emitWanted origin pty
= do { ev <- newWanted origin Nothing pty
; emitSimple $ mkNonCanonical ev
; return $ ctEvExpr ev }
; return $ ctEvTerm ev }
-- | Emits a new equality constraint
emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
......@@ -247,8 +247,9 @@ newDict cls tys
predTypeOccName :: PredType -> OccName
predTypeOccName ty = case classifyPredType ty of
ClassPred cls _ -> mkDictOcc (getOccName cls)
EqPred _ _ _ -> mkVarOccFS (fsLit "co")
IrredPred _ -> mkVarOccFS (fsLit "irred")
EqPred {} -> mkVarOccFS (fsLit "co")
IrredPred {} -> mkVarOccFS (fsLit "irred")
ForAllPred {} -> mkVarOccFS (fsLit "df")
{-
************************************************************************
......@@ -1477,7 +1478,7 @@ zonkCt ct
= ASSERT( not (isCFunEqCan ct) )
-- We do not expect to see any CFunEqCans, because zonkCt is only called on
-- unflattened constraints.
do { fl' <- zonkCtEvidence (cc_ev ct)
do { fl' <- zonkCtEvidence (ctEvidence ct)
; return (mkNonCanonical fl') }
zonkCtEvidence :: CtEvidence -> TcM CtEvidence
......
......@@ -116,7 +116,8 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
(mkTyVarBinders Inferred univ_tvs
, req_theta, ev_binds, req_dicts)
(mkTyVarBinders Inferred ex_tvs
, mkTyVarTys ex_tvs, prov_theta, map evId filtered_prov_dicts)
, mkTyVarTys ex_tvs, prov_theta
, map (EvExpr . evId) filtered_prov_dicts)
(map nlHsVar args, map idType args)
pat_ty rec_fields }
tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"
......@@ -539,7 +540,7 @@ tc_patsyn_finish :: Located Name -- ^ PatSyn Name
-> Bool -- ^ Whether infix
-> LPat GhcTc -- ^ Pattern of the PatSyn
-> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
-> ([TcTyVarBinder], [TcType], [PredType], [EvExpr])
-> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])
-> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and
-- types
-> TcType -- ^ Pattern type
......@@ -625,7 +626,7 @@ tc_patsyn_finish lname dir is_infix lpat'
tcPatSynMatcher :: Located Name
-> LPat GhcTc
-> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
-> ([TcTyVar], [TcType], ThetaType, [EvExpr])
-> ([TcTyVar], [TcType], ThetaType, [EvTerm])
-> ([LHsExpr GhcTcId], [TcType])
-> TcType
-> TcM ((Id, Bool), LHsBinds GhcTc)
......
......@@ -69,7 +69,7 @@ import TcRnMonad ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM
, liftIO, traceTc )
import TcMType ( TcTyVar, TcType )
import TcEnv ( TcTyThing )
import TcEvidence ( TcCoercion, CoercionHole
import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)
, EvExpr, EvBind, mkGivenEvBind )
import TcRnTypes ( CtEvidence(..) )
import Var ( EvVar )
......@@ -173,7 +173,7 @@ newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }
newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
newGiven loc pty evtm = do
new_ev <- newEvVar pty
setEvBind $ mkGivenEvBind new_ev evtm
setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)
return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
-- | Create a fresh evidence variable.
......
......@@ -64,6 +64,9 @@ module TcRnTypes(
TcIdSigInst(..), TcPatSynInfo(..),
isPartialSig, hasCompleteSig,
-- QCInst
QCInst(..), isPendingScInst,
-- Canonical constraints
Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts,
singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
......@@ -78,7 +81,7 @@ module TcRnTypes(
mkNonCanonical, mkNonCanonicalCt, mkGivens,
mkIrredCt, mkInsolubleCt,
ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,
ctEvExpr, ctEvCoercion, ctEvEvId,
ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,
tyCoVarsOfCt, tyCoVarsOfCts,
tyCoVarsOfCtList, tyCoVarsOfCtsList,
......@@ -1699,6 +1702,26 @@ data Ct
cc_hole :: Hole
}
| CQuantCan QCInst -- A quantified constraint
-- NB: I expect to make more of the cases in Ct
-- look like this, with the payload in an
-- auxiliary type
------------
data QCInst -- A much simplified version of ClsInst
-- See Note [Quantified constraints] in TcCanonical
= QCI { qci_ev :: CtEvidence -- Always of type forall tvs. context => ty
-- Always Given
, qci_tvs :: [TcTyVar] -- The tvs
, qci_pred :: TcPredType -- The ty
, qci_pend_sc :: Bool -- Same as cc_pend_sc flag in CDictCan
-- Invariant: True => qci_pred is a ClassPred
}
instance Outputable QCInst where
ppr (QCI { qci_ev = ev }) = ppr ev
------------
-- | An expression or type hole
data Hole = ExprHole UnboundVar
-- ^ Either an out-of-scope variable or a "true" hole in an
......@@ -1785,7 +1808,8 @@ mkGivens loc ev_ids
, ctev_loc = loc })
ctEvidence :: Ct -> CtEvidence
ctEvidence = cc_ev
ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev
ctEvidence ct = cc_ev ct
ctLoc :: Ct -> CtLoc
ctLoc = ctEvLoc . ctEvidence
......@@ -1798,7 +1822,7 @@ ctOrigin = ctLocOrigin . ctLoc
ctPred :: Ct -> PredType
-- See Note [Ct/evidence invariant]
ctPred ct = ctEvPred (cc_ev ct)
ctPred ct = ctEvPred (ctEvidence ct)
ctEvId :: Ct -> EvVar
-- The evidence Id for this Ct
......@@ -1823,7 +1847,7 @@ ctEqRel :: Ct -> EqRel
ctEqRel = ctEvEqRel . ctEvidence
instance Outputable Ct where
ppr ct = ppr (cc_ev ct) <+> parens pp_sort
ppr ct = ppr (ctEvidence ct) <+> parens pp_sort
where
pp_sort = case ct of
CTyEqCan {} -> text "CTyEqCan"
......@@ -1836,6 +1860,9 @@ instance Outputable Ct where
| insol -> text "CIrredCan(insol)"
| otherwise -> text "CIrredCan(sol)"
CHoleCan { cc_hole = hole } -> text "CHoleCan:" <+> ppr hole
CQuantCan (QCI { qci_pend_sc = pend_sc })
| pend_sc -> text "CQuantCan(psc)"
| otherwise -> text "CQuantCan"
{-
************************************************************************
......@@ -1866,9 +1893,7 @@ tyCoFVsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk })
= tyCoFVsOfTypes tys `unionFV` FV.unitFV fsk
`unionFV` tyCoFVsOfType (tyVarKind fsk)
tyCoFVsOfCt (CDictCan { cc_tyargs = tys }) = tyCoFVsOfTypes tys
tyCoFVsOfCt (CIrredCan { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev)
tyCoFVsOfCt (CHoleCan { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev)
tyCoFVsOfCt (CNonCanonical { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev)