Commit a346683b authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fix origin for addDataConStupidTheta

parent 4a8a81e4
......@@ -775,7 +775,7 @@ instFun orig fun subst tv_theta_prs
= do { let ty_theta_prs' = map subst_pr tv_theta_prs
-- Make two ad-hoc checks
; doStupidChecks orig fun ty_theta_prs'
; doStupidChecks fun ty_theta_prs'
-- Now do normal instantiation
; go True fun ty_theta_prs' }
......@@ -891,8 +891,7 @@ Here's are two cases that should fail
\begin{code}
doStupidChecks :: InstOrigin
-> HsExpr TcId
doStupidChecks :: HsExpr TcId
-> [([TcType], ThetaType)]
-> TcM ()
-- Check two tiresome and ad-hoc cases
......@@ -900,9 +899,9 @@ doStupidChecks :: InstOrigin
-- from the "stupid theta" of a data constructor (sigh)
-- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
doStupidChecks orig (HsVar fun_id) ((tys,_):_)
doStupidChecks (HsVar fun_id) ((tys,_):_)
| Just con <- isDataConId_maybe fun_id -- (a)
= addDataConStupidTheta orig con tys
= addDataConStupidTheta con tys
| fun_id `hasKey` tagToEnumKey -- (b)
= do { tys' <- zonkTcTypes tys
......@@ -914,7 +913,7 @@ doStupidChecks orig (HsVar fun_id) ((tys,_):_)
Just (tc,_) -> isEnumerationTyCon tc
Nothing -> False
doStupidChecks orig fun tv_theta_prs
doStupidChecks fun tv_theta_prs
= return () -- The common case
......
......@@ -51,7 +51,7 @@ import Type ( Type, mkTyConApp, substTys, substTheta )
import StaticFlags ( opt_IrrefutableTuples )
import TyCon ( TyCon, FieldLabel, tyConFamInst_maybe,
tyConFamilyCoercion_maybe, tyConTyVars )
import DataCon ( DataCon, dataConTyCon, dataConFullSig,
import DataCon ( DataCon, dataConTyCon, dataConFullSig, dataConName,
dataConFieldLabels, dataConSourceArity,
dataConStupidTheta, dataConUnivTyVars )
import PrelNames ( integralClassName, fromIntegerName, integerTyConName,
......@@ -571,7 +571,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
; dicts <- newDictBndrs loc theta'
; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req
; addDataConStupidTheta origin data_con ctxt_res_tys
; addDataConStupidTheta data_con ctxt_res_tys
; return
(unwrapFamInstScrutinee tycon ctxt_res_tys $
......@@ -697,13 +697,16 @@ tcConArg (arg_pat, arg_ty) pstate thing_inside
\end{code}
\begin{code}
addDataConStupidTheta :: InstOrigin -> DataCon -> [TcType] -> TcM ()
addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
-- Instantiate the "stupid theta" of the data con, and throw
-- the constraints into the constraint set
addDataConStupidTheta origin data_con inst_tys
addDataConStupidTheta data_con inst_tys
| null stupid_theta = return ()
| otherwise = instStupidTheta origin inst_theta
where
origin = OccurrenceOf (dataConName data_con)
-- The origin should always report "occurrence of C"
-- even when C occurs in a pattern
stupid_theta = dataConStupidTheta data_con
tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
inst_theta = substTheta tenv stupid_theta
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment