Commit eb21a979 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of ../HEAD

parents 9a0adc0b 2e6dcdf7
......@@ -122,14 +122,13 @@ Note [Evidence: EvIds and CoVars]
* An EvId (evidence Id) is a *boxed*, term-level evidence variable
(dictionary, implicit parameter, or equality).
* DictId, IpId, and EqVar are synonyms when we know what kind of
evidence we are talking about. For example, an EqVar has type (t1 ~ t2).
* A CoVar (coercion variable) is an *unboxed* term-level evidence variable
of type (t1 ~# t2). So it's the unboxed version of an EqVar.
* Only CoVars can occur in Coercions (but NB the LCoercion hack; see
Note [LCoercions] in Coercion).
* Only CoVars can occur in Coercions, EqVars appear in TcCoercions.
* DictId, IpId, and EqVar are synonyms when we know what kind of
evidence we are talking about. For example, an EqVar has type (t1 ~ t2).
Note [Kind and type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -14,7 +14,7 @@
{-# LANGUAGE TypeFamilies #-}
module TrieMap(
CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
TypeMap,
TypeMap, foldTypeMap,
CoercionMap,
MaybeMap,
ListMap,
......@@ -488,6 +488,12 @@ data TypeMap a
, tm_tc_app :: NameEnv (ListMap TypeMap a)
, tm_forall :: TypeMap (BndrMap a) }
instance Outputable a => Outputable (TypeMap a) where
ppr m = text "TypeMap elts" <+> ppr (foldTypeMap (:) [] m)
foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b
foldTypeMap k z m = fdT k m z
wrapEmptyTypeMap :: TypeMap a
wrapEmptyTypeMap = TM { tm_var = emptyTM
, tm_app = EmptyTM
......
......@@ -120,7 +120,7 @@ deSugar hsc_env
else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
do { ds_ev_binds <- dsEvBinds ev_binds
do { let ds_ev_binds = dsEvBinds ev_binds
; core_prs <- dsTopLHsBinds binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
; (ds_fords, foreign_prs) <- dsForeigns fords
......
......@@ -32,6 +32,7 @@ import TcHsSyn
import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
import TcType
import TcEvidence
import Type
import CoreSyn
import CoreFVs
......
......@@ -18,7 +18,7 @@ lower levels it is preserved with @let@/@letrec@s).
-- for details
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsEvBinds,
dsHsWrapper, dsTcEvBinds, dsEvBinds, dsTcCoercion
) where
#include "HsVersions.h"
......@@ -41,6 +41,7 @@ import CoreFVs
import Digraph
import TyCon ( isTupleTyCon, tyConDataCons_maybe )
import TcEvidence
import TcType
import Type
import Coercion hiding (substCo)
......@@ -107,8 +108,7 @@ dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
, fun_infix = inf })
= do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
; let body' = mkOptTickBox tick body
; wrap_fn' <- dsHsWrapper co_fn
; let rhs = wrap_fn' (mkLams args body')
rhs = dsHsWrapper co_fn (mkLams args body')
; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
return (unitOL (makeCorePair fun False 0 rhs)) }
......@@ -131,12 +131,10 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
| ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
= do { bind_prs <- ds_lhs_binds binds
; ds_ev_binds <- dsTcEvBinds ev_binds
; wrap_fn <- dsHsWrapper wrap
; let core_bind = Rec (fromOL bind_prs)
rhs = wrap_fn $ -- Usually the identity
rhs = dsHsWrapper wrap $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_ev_binds $
mkCoreLets (dsTcEvBinds ev_binds) $
Let core_bind $
Var local
......@@ -152,14 +150,13 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports, abs_ev_binds = ev_binds
, abs_binds = binds })
= do { bind_prs <- ds_lhs_binds binds
; ds_ev_binds <- dsTcEvBinds ev_binds
; let core_bind = Rec (fromOL bind_prs)
-- Monomorphic recursion possible, hence Rec
tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr
poly_tup_rhs = mkLams tyvars $ mkLams dicts $
mkCoreLets ds_ev_binds $
mkCoreLets (dsTcEvBinds ev_binds) $
Let core_bind $
tup_expr
locals = map abe_mono exports
......@@ -168,9 +165,9 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
= do { wrap_fn <- dsHsWrapper wrap
; tup_id <- newSysLocalDs tup_ty
; let rhs = wrap_fn $ mkLams tyvars $ mkLams dicts $
= do { tup_id <- newSysLocalDs tup_ty
; let rhs = dsHsWrapper wrap $
mkLams tyvars $ mkLams dicts $
mkTupleSelector locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
......@@ -183,104 +180,6 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; return ((poly_tup_id, poly_tup_rhs) `consOL`
concatOL export_binds_s) }
--------------------------------------
dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = -- pprTrace "EvBinds bs = " (ppr bs) $
dsEvBinds bs
dsEvBinds :: Bag EvBind -> DsM [CoreBind]
dsEvBinds bs = do { let core_binds = map dsEvSCC sccs
-- ; pprTrace "dsEvBinds, result = " (vcat (map ppr core_binds)) $
; return core_binds }
-- ; return (map dsEvGroup sccs)
where
sccs :: [SCC EvBind]
sccs = stronglyConnCompFromEdgedVertices edges
edges :: [(EvBind, EvVar, [EvVar])]
edges = foldrBag ((:) . mk_node) [] bs
mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
mk_node b@(EvBind var term) = (b, var, free_vars_of term)
free_vars_of :: EvTerm -> [EvVar]
free_vars_of (EvId v) = [v]
free_vars_of (EvCast v co) = v : varSetElems (coVarsOfCo co)
free_vars_of (EvCoercionBox co) = varSetElems (coVarsOfCo co)
free_vars_of (EvDFunApp _ _ vs) = vs
free_vars_of (EvTupleSel v _) = [v]
free_vars_of (EvTupleMk vs) = vs
free_vars_of (EvSuperClass d _) = [d]
dsEvSCC :: SCC EvBind -> CoreBind
dsEvSCC (AcyclicSCC (EvBind v r))
= NonRec v (dsEvTerm r)
dsEvSCC (CyclicSCC bs)
= Rec (map ds_pair bs)
where
ds_pair (EvBind v r) = (v, dsEvTerm r)
---------------------------------------
dsLCoercion :: LCoercion -> (Coercion -> CoreExpr) -> CoreExpr
-- This is the crucial function that moves
-- from LCoercions to Coercions; see Note [LCoercions] in Coercion
-- e.g. dsLCoercion (trans g1 g2) k
-- = case g1 of EqBox g1# ->
-- case g2 of EqBox g2# ->
-- k (trans g1# g2#)
dsLCoercion co k
= foldr wrap_in_case result_expr eqvs_covs
where
result_expr = k (substCo subst co)
result_ty = exprType result_expr
-- We use the same uniques for the EqVars and the CoVars, and just change
-- the type. So the CoVars shadow the EqVars
--
-- NB: DON'T try to cheat and not substitute into the LCoercion to change the
-- types of the free variables: -ddump-ds will panic if you do this since it
-- runs Lint before we substitute CoVar occurrences out for their binding sites.
eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2)
| eqv <- varSetElems (coVarsOfCo co)
, let (ty1, ty2) = getEqPredTys (evVarPred eqv)]
subst = extendCvSubstList (mkEmptySubst (mkInScopeSet (tyCoVarsOfCo co)))
[(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
wrap_in_case (eqv, cov) body
= Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
---------------------------------------
dsEvTerm :: EvTerm -> CoreExpr
dsEvTerm (EvId v) = Var v
dsEvTerm (EvCast v co)
= dsLCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
dsEvTerm (EvCoercionBox co) = dsLCoercion co mkEqBox
dsEvTerm (EvTupleSel v n)
= ASSERT( isTupleTyCon tc )
Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')]
where
(tc, tys) = splitTyConApp (evVarPred v)
Just [dc] = tyConDataCons_maybe tc
v' = v `setVarType` ty_want
xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after
(tys_before, ty_want:tys_after) = splitAt n tys
dsEvTerm (EvTupleMk vs) = Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
where dc = tupleCon ConstraintTuple (length vs)
tys = map varType vs
dsEvTerm (EvSuperClass d n)
= Var sc_sel_id `mkTyApps` tys `App` Var d
where
sc_sel_id = classSCSelId cls n -- Zero-indexed
(cls, tys) = getClassPredTys (evVarPred d)
------------------------
makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
makeCorePair gbl_id is_default_method dict_arity rhs
......@@ -500,14 +399,13 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
= putSrcSpanDs loc $
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
; wrap_fn <- dsHsWrapper spec_co
; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
; let (bndrs, ds_lhs) = collectBinders (dsHsWrapper spec_co (Var poly_id))
spec_ty = mkPiTypes bndrs (exprType ds_lhs)
; case decomposeRuleLhs bndrs ds_lhs of {
Left msg -> do { warnDs msg; return Nothing } ;
Right (final_bndrs, _fn, args) -> do
{ (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
{ (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id)
; let spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
......@@ -540,7 +438,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
final_bndrs args
(mkVarApps (Var spec_id) bndrs)
spec_rhs = wrap_fn poly_rhs
spec_rhs = dsHsWrapper spec_co poly_rhs
spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
; return (Just (spec_pair `consOL` unf_pairs, rule))
......@@ -557,7 +455,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
-- The type checker has checked that it *has* an unfolding
specUnfolding :: (CoreExpr -> CoreExpr) -> Type
specUnfolding :: HsWrapper -> Type
-> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
{- [Dec 10: TEMPORARILY commented out, until we can straighten out how to
generate unfoldings for specialised DFuns
......@@ -740,25 +638,138 @@ as the old one, but with an Internal name and no IdInfo.
%************************************************************************
%* *
Desugaring coercions
Desugaring evidence
%* *
%************************************************************************
\begin{code}
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper WpHole = return (\e -> e)
dsHsWrapper (WpTyApp ty) = return (\e -> App e (Type ty))
dsHsWrapper (WpLet ev_binds) = do { ds_ev_binds <- dsTcEvBinds ev_binds
-- ; pprTrace "Desugared core bindings = " (vcat (map ppr ds_ev_binds)) $
; return (mkCoreLets ds_ev_binds) }
dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1
; k2 <- dsHsWrapper c2
; return (k1 . k2) }
dsHsWrapper (WpCast co)
= return (\e -> dsLCoercion co (mkCast e))
dsHsWrapper (WpEvLam ev) = return (\e -> Lam ev e)
dsHsWrapper (WpTyLam tv) = return (\e -> Lam tv e)
dsHsWrapper (WpEvApp evtrm)
= return (\e -> App e (dsEvTerm evtrm))
dsHsWrapper :: HsWrapper -> CoreExpr -> CoreExpr
dsHsWrapper WpHole e = e
dsHsWrapper (WpTyApp ty) e = App e (Type ty)
dsHsWrapper (WpLet ev_binds) e = mkCoreLets (dsTcEvBinds ev_binds) e
dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 (dsHsWrapper c2 e)
dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e)
dsHsWrapper (WpEvLam ev) e = Lam ev e
dsHsWrapper (WpTyLam tv) e = Lam tv e
dsHsWrapper (WpEvApp evtrm) e = App e (dsEvTerm evtrm)
--------------------------------------
dsTcEvBinds :: TcEvBinds -> [CoreBind]
dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = dsEvBinds bs
dsEvBinds :: Bag EvBind -> [CoreBind]
dsEvBinds bs = map ds_scc (sccEvBinds bs)
where
ds_scc (AcyclicSCC (EvBind v r)) = NonRec v (dsEvTerm r)
ds_scc (CyclicSCC bs) = Rec (map ds_pair bs)
ds_pair (EvBind v r) = (v, dsEvTerm r)
sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
where
edges :: [(EvBind, EvVar, [EvVar])]
edges = foldrBag ((:) . mk_node) [] bs
mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
mk_node b@(EvBind var term) = (b, var, evVarsOfTerm term)
---------------------------------------
dsEvTerm :: EvTerm -> CoreExpr
dsEvTerm (EvId v) = Var v
dsEvTerm (EvCast v co)
= dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
dsEvTerm (EvTupleSel v n)
= ASSERT( isTupleTyCon tc )
Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')]
where
(tc, tys) = splitTyConApp (evVarPred v)
Just [dc] = tyConDataCons_maybe tc
v' = v `setVarType` ty_want
xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after
(tys_before, ty_want:tys_after) = splitAt n tys
dsEvTerm (EvTupleMk vs) = Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
where dc = tupleCon ConstraintTuple (length vs)
tys = map varType vs
dsEvTerm (EvSuperClass d n)
= Var sc_sel_id `mkTyApps` tys `App` Var d
where
sc_sel_id = classSCSelId cls n -- Zero-indexed
(cls, tys) = getClassPredTys (evVarPred d)
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
-- This is the crucial function that moves
-- from LCoercions to Coercions; see Note [TcCoercions] in Coercion
-- e.g. dsTcCoercion (trans g1 g2) k
-- = case g1 of EqBox g1# ->
-- case g2 of EqBox g2# ->
-- k (trans g1# g2#)
dsTcCoercion co thing_inside
= foldr wrap_in_case result_expr eqvs_covs
where
result_expr = thing_inside (ds_tc_coercion subst co)
result_ty = exprType result_expr
-- We use the same uniques for the EqVars and the CoVars, and just change
-- the type. So the CoVars shadow the EqVars
eqvs_covs :: [(EqVar,CoVar)]
eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2)
| eqv <- varSetElems (coVarsOfTcCo co)
, let (ty1, ty2) = getEqPredTys (evVarPred eqv)]
subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
wrap_in_case (eqv, cov) body
= Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
-- If the incoming TcCoercion if of type (a ~ b),
-- the result is of type (a ~# b)
-- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b)
-- No need for InScope set etc because the
ds_tc_coercion subst tc_co
= go tc_co
where
go (TcRefl ty) = Refl (Coercion.substTy subst ty)
go (TcTyConAppCo tc cos) = mkTyConAppCo tc (map go cos)
go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)
go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
where
(subst', tv') = Coercion.substTyVarBndr subst tv
go (TcAxiomInstCo ax tys) = mkAxInstCo ax (map (Coercion.substTy subst) tys)
go (TcSymCo co) = mkSymCo (go co)
go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2)
go (TcNthCo n co) = mkNthCo n (go co)
go (TcInstCo co ty) = mkInstCo (go co) ty
go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co
go (TcCoVarCo v) = ds_ev_id subst v
ds_co_binds :: TcEvBinds -> CvSubst
ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)
ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)
ds_scc :: CvSubst -> SCC EvBind -> CvSubst
ds_scc subst (AcyclicSCC (EvBind v ev_term))
= extendCvSubstAndInScope subst v (ds_ev_term subst ev_term)
ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
ds_ev_term :: CvSubst -> EvTerm -> Coercion
ds_ev_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
ds_ev_term subst (EvId v) = ds_ev_id subst v
ds_ev_term _ other = pprPanic "ds_ev_term" (ppr other $$ ppr tc_co)
ds_ev_id :: CvSubst -> EqVar -> Coercion
ds_ev_id subst v
| Just co <- Coercion.lookupCoVar subst v = co
| otherwise = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)
\end{code}
......@@ -31,8 +31,8 @@ import HsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types
import TcType
import TcEvidence
import Type
import Coercion
import CoreSyn
import CoreUtils
import CoreFVs
......@@ -79,8 +79,7 @@ dsValBinds (ValBindsIn _ _) _ = panic "dsValBinds ValBindsIn"
-------------------------
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
dsIPBinds (IPBinds ip_binds ev_binds) body
= do { ds_ev_binds <- dsTcEvBinds ev_binds
; let inner = mkCoreLets ds_ev_binds body
= do { let inner = mkCoreLets (dsTcEvBinds ev_binds) body
-- The dict bindings may not be in
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
......@@ -128,12 +127,11 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_exports = exports
, abs_ev_binds = ev_binds
, abs_binds = binds }) body
= do { ds_ev_binds <- dsTcEvBinds ev_binds
; let body1 = foldr bind_export body exports
= do { let body1 = foldr bind_export body exports
bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body)
body1 binds
; return (mkCoreLets ds_ev_binds body2) }
; return (mkCoreLets (dsTcEvBinds ev_binds) body2) }
dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
, fun_tick = tick, fun_infix = inf }) body
......@@ -217,11 +215,11 @@ dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
dsExpr (HsWrap co_fn e)
= do { co_fn' <- dsHsWrapper co_fn
; e' <- dsExpr e
= do { e' <- dsExpr e
; let wrapped_e = dsHsWrapper co_fn e'
; warn_id <- woptDs Opt_WarnIdentities
; when warn_id $ warnAboutIdentities e' co_fn'
; return (co_fn' e') }
; when warn_id $ warnAboutIdentities e' wrapped_e
; return wrapped_e }
dsExpr (NegApp expr neg_expr)
= App <$> dsExpr neg_expr <*> dsLExpr expr
......@@ -546,12 +544,12 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
-- Tediously wrap the application in a cast
-- Note [Update for GADTs]
wrap_co = mkTyConAppCo tycon
wrap_co = mkTcTyConAppCo tycon
[ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
Just co' -> co'
Nothing -> mkReflCo ty
wrap_subst = mkVarEnv [ (tv, mkSymCo (mkEqVarLCo eq_var))
Nothing -> mkTcReflCo ty
wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
| ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ]
pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
......@@ -806,14 +804,15 @@ mk_fail_msg pat = "Pattern match failure in do expression at " ++
%* *
%************************************************************************
Warn about functions that convert between one type and another
when the to- and from- types are the same. Then it's probably
(albeit not definitely) the identity
Warn about functions like toInteger, fromIntegral, that convert
between one type and another when the to- and from- types are the
same. Then it's probably (albeit not definitely) the identity
\begin{code}
warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM ()
warnAboutIdentities (Var v) co_fn
warnAboutIdentities :: CoreExpr -> CoreExpr -> DsM ()
warnAboutIdentities (Var v) wrapped_fun
| idName v `elem` conversionNames
, let fun_ty = exprType (co_fn (Var v))
, let fun_ty = exprType wrapped_fun
, Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
, arg_ty `eqType` res_ty -- So we are converting ty -> ty
= warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
......
......@@ -19,6 +19,7 @@ import TcHsSyn
import CoreSyn
import MkCore
import TcEvidence
import DsMonad -- the monadery used in the desugarer
import DsUtils
......
......@@ -22,6 +22,7 @@ import {-#SOURCE#-} DsExpr (dsLExpr)
import DynFlags
import HsSyn
import TcHsSyn
import TcEvidence
import Check
import CoreSyn
import Literal
......@@ -36,7 +37,6 @@ import DataCon
import MatchCon
import MatchLit
import Type
import Coercion
import TysWiredIn
import ListSetOps
import SrcLoc
......@@ -356,8 +356,7 @@ matchCoercion (var:vars) ty (eqns@(eqn1:_))
; var' <- newUniqueId var (hsPatType pat)
; match_result <- match (var':vars) ty $
map (decomposeFirstPat getCoPat) eqns
; co' <- dsHsWrapper co
; let rhs' = co' (Var var)
; let rhs' = dsHsWrapper co (Var var)
; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
matchCoercion _ _ _ = panic "matchCoercion"
......@@ -919,7 +918,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- equating different ways of writing a coercion)
wrap WpHole WpHole = True
wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
wrap (WpCast co) (WpCast co') = co `coreEqCoercion` co'
wrap (WpCast co) (WpCast co') = co `eq_co` co'
wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2
wrap (WpTyApp t) (WpTyApp t') = eqType t t'
-- Enhancement: could implement equality for more wrappers
......@@ -928,8 +927,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
---------
ev_term :: EvTerm -> EvTerm -> Bool
ev_term (EvId a) (EvId b) = a==b
ev_term (EvCoercionBox a) (EvCoercionBox b) = coreEqCoercion a b
ev_term (EvId a) (EvId b) = a==b
ev_term (EvCoercion a) (EvCoercion b) = a `eq_co` b
ev_term _ _ = False
---------
......@@ -939,6 +938,15 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
eq_list _ (_:_) [] = False
eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
---------
eq_co :: TcCoercion -> TcCoercion -> Bool
-- Just some simple cases
eq_co (TcRefl t1) (TcRefl t2) = eqType t1 t2
eq_co (TcCoVarCo v1) (TcCoVarCo v2) = v1==v2
eq_co (TcSymCo co1) (TcSymCo co2) = co1 `eq_co` co2
eq_co (TcTyConAppCo tc1 cos1) (TcTyConAppCo tc2 cos2) = tc1==tc2 && eq_list eq_co cos1 cos2
eq_co _ _ = False
patGroup :: Pat Id -> PatGroup
patGroup (WildPat {}) = PgAny
patGroup (BangPat {}) = PgBang
......
......@@ -131,19 +131,18 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
-- All members of the group have compatible ConArgPats
match_group arg_vars arg_eqn_prs
= do { (wraps, eqns') <- mapAndUnzipM shift arg_eqn_prs
; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
= do { let (wraps, eqns') = unzip (map shift arg_eqn_prs)
group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
; match_result <- match (group_arg_vars ++ vars) ty eqns'
; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
pat_binds = bind, pat_args = args
} : pats }))
= do { ds_ev_binds <- dsTcEvBinds bind
; return (wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_ev_binds,
eqn { eqn_pats = conArgPats arg_tys args ++ pats }) }
= ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets (dsTcEvBinds bind)
, eqn { eqn_pats = conArgPats arg_tys args ++ pats })
shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
-- Choose the right arg_vars in the right order for this group
......
......@@ -411,6 +411,7 @@ Library
TcTyClsDecls
TcTyDecls
TcType
TcEvidence
TcUnify
TcInteract
TcCanonical
......
......@@ -27,7 +27,7 @@ import HsLit
import HsTypes
import PprCore ()
import CoreSyn
import Coercion
import TcEvidence
import Type
import Name
import NameSet
......@@ -35,15 +35,11 @@ import BasicTypes
import Outputable
import SrcLoc
import Util
import VarEnv
import Var
import Bag
import Unique
import FastString
import Data.IORef( IORef )
import Data.Data hiding ( Fixity )
import Data.List ( intersect )
\end{code}
......@@ -438,227 +434,6 @@ instance (OutputableBndr id) => Outputable (IPBind id) where
\end{code}
%************************************************************************
%* *
\subsection{Coercion functions}
%* *