#endif
import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
- HsMatchContext(..), HsRecordBinds, mkHsCoerce,
- mkHsApp )
+ HsMatchContext(..), HsRecordBinds, mkHsWrap, hsExplicitTvs,
+ mkHsApp, mkLHsWrap )
import TcHsSyn ( hsLitType )
import TcRnMonad
import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
import Inst ( newMethodFromName, newIPDict, instCall,
newMethodWithGivenTy, instStupidTheta )
import TcBinds ( tcLocalBinds )
-import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField )
+import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField, tcExtendTyVarEnv2 )
import TcArrows ( tcProc )
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody,
TcMatchCtxt(..) )
mkTyVarTys, mkFunTys,
tcMultiSplitSigmaTy, tcSplitFunTysN,
tcSplitTyConApp_maybe,
- isSigmaTy, mkFunTy, mkTyConApp, isLinearPred,
+ isSigmaTy, mkFunTy, mkTyConApp,
exactTyVarsOfType, exactTyVarsOfTypes,
zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
)
import {- Kind parts of -}
Type ( argTypeKind )
-import Id ( Id, idType, recordSelectorFieldLabel,
+import Id ( idType, recordSelectorFieldLabel,
isRecordSelector, isNaughtyRecordSelector,
isDataConId_maybe )
import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks,
import DynFlags
import StaticFlags ( opt_NoMethodSharing )
import HscTypes ( TyThing(..) )
-import SrcLoc ( Located(..), unLoc, getLoc )
+import SrcLoc ( Located(..), unLoc )
import Util
import ListSetOps ( assocMaybe )
import Maybes ( catMaybes )
tcPolyExprNC expr res_ty
| isSigmaTy res_ty
- = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr)
+ = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
-- Note the recursive call to tcPolyExpr, because the
-- type may have multiple layers of for-alls
- ; return (L (getLoc expr') (mkHsCoerce gen_fn (unLoc expr'))) }
+ ; return (mkLHsWrap gen_fn expr') }
| otherwise
= tcMonoExpr expr res_ty
; co_fn <- tcSubExp ip_ty res_ty
; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
; extendLIE inst
- ; return (mkHsCoerce co_fn (HsIPVar ip')) }
+ ; return (mkHsWrap co_fn (HsIPVar ip')) }
tcExpr (HsApp e1 e2) res_ty
= go e1 [e2]
tcExpr (HsLam match) res_ty
= do { (co_fn, match') <- tcMatchLambda match res_ty
- ; return (mkHsCoerce co_fn (HsLam match')) }
+ ; return (mkHsWrap co_fn (HsLam match')) }
tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
= do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
- ; expr' <- tcPolyExpr expr sig_tc_ty
+
+ -- Remember to extend the lexical type-variable environment
+ ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
+ tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
+ tcPolyExprNC expr res_ty)
+
; co_fn <- tcSubExp sig_tc_ty res_ty
- ; return (mkHsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) }
+ ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
tcExpr (HsType ty) res_ty
= failWithTc (text "Can't handle type argument:" <+> ppr ty)
tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
= do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
tcApp op 2 (tc_args arg1_ty') res_ty'
- ; return (mkHsCoerce co_fn (SectionR (L loc op') arg2')) }
+ ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
where
doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
<+> ptext SLIT("takes one argument")
instStupidTheta RecordUpdOrigin theta' `thenM_`
-- Phew!
- returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
+ returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
\end{code}
-- tcFun work nicely for OpApp and Sections too
; fun' <- instFun orig fun res_subst tv_theta_prs
; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
- ; return (mkHsCoerce co_fn' fun', args') }
+ ; return (mkHsWrap co_fn' fun', args') }
\end{code}
Note [Silly type synonyms in smart-app]
-- And pack up the results
; fun' <- instFun orig fun res_subst tv_theta_prs
- ; return (mkHsCoerce co_fn fun') }
+ ; return (mkHsWrap co_fn fun') }
-- Note [Push result type in]
--
= return fun -- Common short cut
instFun orig fun subst tv_theta_prs
- = do {-- !!!SPJ: -- Horrid check for tagToEnum; see Note [tagToEnum#]
- -- !!!SPJ: checkBadTagToEnumCall fun_id qtv_tys
-
- ; let ty_theta_prs' = map subst_pr tv_theta_prs
+ = do { let ty_theta_prs' = map subst_pr tv_theta_prs
- -- First, chuck in the constraints from
- -- the "stupid theta" of a data constructor (sigh)
- ; inst_stupid fun ty_theta_prs'
+ -- Make two ad-hoc checks
+ ; doStupidChecks fun ty_theta_prs'
-- Now do normal instantiation
; go True fun ty_theta_prs' }
subst_pr (tvs, theta)
= (map (substTyVar subst) tvs, substTheta subst theta)
- inst_stupid (HsVar fun_id) ((tys,_):_)
- | Just con <- isDataConId_maybe fun_id
- = addDataConStupidTheta orig con tys
- inst_stupid _ _ = return ()
-
go _ fun [] = return fun
go True (HsVar fun_id) ((tys,theta) : prs)
go _ fun ((tys, theta) : prs)
= do { co_fn <- instCall orig tys theta
- ; go False (HsCoerce co_fn fun) prs }
+ ; go False (HsWrap co_fn fun) prs }
- -- Hack Alert (want_method_inst)!
-- See Note [No method sharing]
- -- If f :: (%x :: T) => Int -> Int
- -- Then if we have two separate calls, (f 3, f 4), we cannot
- -- make a method constraint that then gets shared, thus:
- -- let m = f %x in (m 3, m 4)
- -- because that loses the linearity of the constraint.
- -- The simplest thing to do is never to construct a method constraint
- -- in the first place that has a linear implicit parameter in it.
- want_method_inst theta = not (null theta) -- Overloaded
- && not (any isLinearPred theta) -- Not linear
+ want_method_inst theta = not (null theta) -- Overloaded
&& not opt_NoMethodSharing
- -- See Note [No method sharing] below
\end{code}
Note [Multiple instantiation]
\begin{code}
-checkBadTagToEnumCall :: Id -> [TcType] -> TcM ()
-checkBadTagToEnumCall fun_id tys
- | fun_id `hasKey` tagToEnumKey
+doStupidChecks :: HsExpr TcId
+ -> [([TcType], ThetaType)]
+ -> TcM ()
+-- Check two tiresome and ad-hoc cases
+-- (a) the "stupid theta" for a data con; add the constraints
+-- from the "stupid theta" of a data constructor (sigh)
+-- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
+
+doStupidChecks (HsVar fun_id) ((tys,_):_)
+ | Just con <- isDataConId_maybe fun_id -- (a)
+ = addDataConStupidTheta con tys
+
+ | fun_id `hasKey` tagToEnumKey -- (b)
= do { tys' <- zonkTcTypes tys
; checkTc (ok tys') (tagToEnumError tys')
}
- | otherwise -- Vastly common case
- = return ()
where
ok [] = False
ok (ty:tys) = case tcSplitTyConApp_maybe ty of
Just (tc,_) -> isEnumerationTyCon tc
Nothing -> False
+doStupidChecks fun tv_theta_prs
+ = return () -- The common case
+
+
tagToEnumError tys
= hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type)
2 (vcat [ptext SLIT("Specify the type by giving a type signature"),
-> do { thLocalId orig id ty lvl
; case mb_co of
Nothing -> return (HsVar id, ty) -- Wobbly, or no free vars
- Just co -> return (mkHsCoerce co (HsVar id), ty) }
+ Just co -> return (mkHsWrap co (HsVar id), ty) }
other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
}