X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=0da370bd4e31ede37ddafeaccf561491e2f89e11;hb=1525a5819aa3a6eae8d8b05cfe348a2384da0c84;hp=a044f43ef2f80e00aa7e8f3fde330de1b59b5b5a;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index a044f43..0da370b 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -26,44 +26,45 @@ import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields, 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(..) ) @@ -189,7 +190,7 @@ tcExpr (HsApp e1 e2) res_ty 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')) } @@ -254,6 +255,7 @@ tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty 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} @@ -394,7 +396,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty 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 @@ -650,26 +652,7 @@ tcIdApp fun_name n_args arg_checker res_ty ; 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 @@ -677,8 +660,12 @@ tcIdApp fun_name n_args arg_checker res_ty -- 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 @@ -724,17 +711,13 @@ tcId orig fun_name res_ty -- 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 @@ -782,7 +765,10 @@ instFun fun_id qtvs qtv_tys [] = 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) @@ -894,6 +880,44 @@ tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $ \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}