import TcHsSyn ( hsLitType )
import TcRnMonad
import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
- boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType,
+ boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
unBox )
import BasicTypes ( Arity, isMarkedStrict )
import Inst ( newMethodFromName, newIPDict, instToId,
newDicts, newMethodWithGivenTy, tcInstStupidTheta )
import TcBinds ( tcLocalBinds )
-import TcEnv ( tcLookup, tcLookupId,
- tcLookupDataCon, tcLookupGlobalId
- )
+import TcEnv ( tcLookup, tcLookupId, tcLookupDataCon, tcLookupField )
import TcArrows ( tcProc )
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, TcMatchCtxt(..) )
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( tcOverloadedLit, badFieldCon )
-import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox,
- tcInstBoxyTyVar, tcInstTyVar )
+import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox, zonkTcTypes )
import TcType ( TcType, TcSigmaType, TcRhoType,
BoxySigmaType, BoxyRhoType, ThetaType,
- mkTyVarTys, mkFunTys, tcMultiSplitSigmaTy, tcSplitFunTysN,
+ mkTyVarTys, mkFunTys,
+ tcMultiSplitSigmaTy, tcSplitFunTysN, tcSplitTyConApp_maybe,
isSigmaTy, mkFunTy, mkTyConApp, isLinearPred,
- exactTyVarsOfType, exactTyVarsOfTypes, mkTyVarTy,
- zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar, lookupTyVar
+ exactTyVarsOfType, exactTyVarsOfTypes,
+ zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
)
import Kind ( argTypeKind )
-import Id ( idType, idName, recordSelectorFieldLabel, isRecordSelector,
- isNaughtyRecordSelector, isDataConId_maybe )
+import Id ( Id, idType, idName, recordSelectorFieldLabel,
+ isRecordSelector, isNaughtyRecordSelector, isDataConId_maybe )
import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConSourceArity,
dataConWrapId, isVanillaDataCon, dataConTyVars, dataConOrigArgTys )
import Name ( Name )
-import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons )
+import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons, isEnumerationTyCon )
import Type ( substTheta, substTy )
import Var ( TyVar, tyVarKind )
import VarSet ( emptyVarSet, elemVarSet, unionVarSet )
import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
import PrelNames ( enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
- enumFromToPName, enumFromThenToPName, negateName
+ enumFromToPName, enumFromThenToPName, negateName,
+ hasKey
)
+import PrimOp ( tagToEnumKey )
+
import DynFlags
import StaticFlags ( opt_NoMethodSharing )
import HscTypes ( TyThing(..) )
go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
go lfun@(L loc fun) args
- = do { (fun', args') <- addErrCtxt (callCtxt lfun args) $
+ = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
tcApp fun (length args) (tcArgs lfun args) res_ty
; return (unLoc (foldl mkHsApp (L loc fun') args')) }
tc_args arg1_ty' [arg1_ty, arg2_ty]
= do { boxyUnify arg1_ty' arg1_ty
; tcArg lop (arg2, arg2_ty, 2) }
+ tc_args arg1_ty' other = panic "tcExpr SectionR"
\end{code}
\begin{code}
let
field_names = map fst rbinds
in
- mappM (tcLookupGlobalId.unLoc) field_names `thenM` \ sel_ids ->
+ mappM (tcLookupField . unLoc) field_names `thenM` \ sel_ids ->
-- The renamer has already checked that they
-- are all in scope
let
; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
res_ty' = mkFunTys extra_arg_tys' res_ty
- subst = boxySubMatchType arg_qtvs fun_res_ty res_ty'
- -- Only bind arg_qtvs, since only they will be
- -- *definitely* be filled in by arg_checker
- -- E.g. error :: forall a. String -> a
- -- (error "foo") :: bx5
- -- Don't make subst [a |-> bx5]
- -- because then the result subsumption becomes
- -- bx5 ~ bx5
- -- and the unifer doesn't expect the
- -- same box on both sides
- inst_qtv tv | Just boxy_ty <- lookupTyVar subst tv = return boxy_ty
- | tv `elemVarSet` tau_qtvs = do { tv' <- tcInstBoxyTyVar tv
- ; return (mkTyVarTy tv') }
- | otherwise = do { tv' <- tcInstTyVar tv
- ; return (mkTyVarTy tv') }
- -- The 'otherwise' case handles type variables that are
- -- mentioned only in the constraints, not in argument or
- -- result types. We'll make them tau-types
-
- ; qtys' <- mapM inst_qtv qtvs
+ ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
; let arg_subst = zipOpenTvSubst qtvs qtys'
fun_arg_tys' = substTys arg_subst fun_arg_tys
-- Doing so will fill arg_qtvs and extra_arg_tys'
; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys')
+ -- Strip boxes from the qtvs that have been filled in by the arg checking
+ -- AND any variables that are mentioned in neither arg nor result
+ -- the latter are mentioned only in constraints; stripBoxyType will
+ -- fill them with a monotype
; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty'
- | otherwise = return qty'
+ | otherwise = return qty'
; qtys'' <- zipWithM strip qtvs qtys'
; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
-- Split up the function type
; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy (idType fun_id)
- qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
- tau_qtvs = exactTyVarsOfType fun_tau -- Mentiond in the tau part
- inst_qtv tv | tv `elemVarSet` tau_qtvs = do { tv' <- tcInstBoxyTyVar tv
- ; return (mkTyVarTy tv') }
- | otherwise = do { tv' <- tcInstTyVar tv
- ; return (mkTyVarTy tv') }
+ qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
+ tau_qtvs = exactTyVarsOfType fun_tau -- Mentioned in the tau part
+ ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
-- Do the subsumption check wrt the result type
- ; qtv_tys <- mapM inst_qtv qtvs
- ; let res_subst = zipTopTvSubst qtvs qtv_tys
- fun_tau' = substTy res_subst fun_tau
+ ; let res_subst = zipTopTvSubst qtvs qtv_tys
+ fun_tau' = substTy res_subst fun_tau
; co_fn <- tcFunResTy fun_name fun_tau' res_ty
= return (HsVar fun_id) -- Common short cut
instFun fun_id qtvs qtv_tys tv_theta_prs
- = do { let subst = zipOpenTvSubst qtvs qtv_tys
+ = do { -- Horrid check for tagToEnum; see Note [tagToEnum#]
+ checkBadTagToEnumCall fun_id qtv_tys
+
+ ; let subst = zipOpenTvSubst qtvs qtv_tys
ty_theta_prs' = map subst_pr tv_theta_prs
subst_pr (tvs, theta) = (map (substTyVar subst) tvs,
substTheta subst theta)
\end{code}
+Note [tagToEnum#]
+~~~~~~~~~~~~~~~~~
+Nasty check to ensure that tagToEnum# is applied to a type that is an
+enumeration TyCon. Unification may refine the type later, but this
+check won't see that, alas. It's crude but it works.
+
+Here's are two cases that should fail
+ f :: forall a. a
+ f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
+
+ g :: Int
+ g = tagToEnum# 0 -- Int is not an enumeration
+
+
+\begin{code}
+checkBadTagToEnumCall :: Id -> [TcType] -> TcM ()
+checkBadTagToEnumCall fun_id tys
+ | fun_id `hasKey` tagToEnumKey
+ = 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
+
+tagToEnumError tys
+ = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type)
+ 2 (vcat [ptext SLIT("Specify the type by giving a type signature"),
+ ptext SLIT("e.g. (tagToEnum# x) :: Bool")])
+ where
+ at_type | null tys = empty -- Probably never happens
+ | otherwise = ptext SLIT("at type") <+> ppr (head tys)
+\end{code}
+
%************************************************************************
%* *
\subsection{@tcId@ typchecks an identifier occurrence}
projects / ghc-hetmet.git / blobdiff