X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=d3c6ee785b677cbb3fea4f8f83b5fff08a3abb61;hb=d876992cf9b9fb07cb913b0c297d9a42b746c29a;hp=f44b7572d35cb06733dcad1b218191c488501261;hpb=cb51a09231da94d729bcd62177cbdec1a888a180;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index f44b757..d3c6ee7 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -11,15 +11,16 @@ module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where #ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) import HsSyn ( HsReify(..), ReifyFlavour(..) ) +import Id ( Id ) import TcType ( isTauTy ) -import TcEnv ( bracketOK, tcMetaTy, checkWellStaged, metaLevel ) -import Name ( isExternalName ) +import TcEnv ( tcMetaTy, checkWellStaged ) import qualified DsMeta #endif -import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields ) +import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields, + HsMatchContext(..) ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet, (<$>) ) +import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, (<$>) ) import TcRnMonad import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, unifyFunTy, zapToListTy, zapToPArrTy, zapToTupleTy ) @@ -30,34 +31,32 @@ import Inst ( InstOrigin(..), instToId, tcInstCall, tcInstDataCon ) import TcBinds ( tcBindsAndThen ) -import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl, - tcLookupTyCon, tcLookupDataCon, tcLookupId +import TcEnv ( tcLookup, tcLookupGlobalId, + tcLookupDataCon, tcLookupId, checkProcLevel ) -import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) +import TcArrows ( tcProc ) +import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( badFieldCon ) -import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, newTyVarTys, zonkTcType ) +import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, zonkTcType ) import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, isSigmaTy, mkFunTy, mkFunTys, - mkTyConApp, mkClassPred, - tyVarsOfTypes, isLinearPred, + mkTyConApp, tyVarsOfTypes, isLinearPred, liftedTypeKind, openTypeKind, tcSplitSigmaTy, tidyOpenType ) import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) -import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector ) -import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId ) +import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) +import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId ) import Name ( Name ) import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy ) -import PrelNames ( cCallableClassName, cReturnableClassName, - enumFromName, enumFromThenName, +import PrelNames ( enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, - enumFromToPName, enumFromThenToPName, - ioTyConName + enumFromToPName, enumFromThenToPName ) import ListSetOps ( minusList ) import CmdLineOpts @@ -257,13 +256,16 @@ tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty -- (x:xs) -> ... -- will report that map is applied to too few arguments - tcMatchesCase matches res_ty `thenM` \ (scrut_ty, matches') -> + tcMatchesCase match_ctxt matches res_ty `thenM` \ (scrut_ty, matches') -> addErrCtxt (caseScrutCtxt scrut) ( tcCheckRho scrut scrut_ty ) `thenM` \ scrut' -> returnM (HsCase scrut' matches' src_loc) + where + match_ctxt = MC { mc_what = CaseAlt, + mc_body = tcMonoExpr } tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty = addSrcLoc src_loc $ @@ -281,8 +283,8 @@ tcMonoExpr (HsDo do_or_lc stmts method_names _ src_loc) res_ty = addSrcLoc src_loc $ zapExpectedType res_ty `thenM` \ res_ty' -> -- All comprehensions yield a monotype - tcDoStmts do_or_lc stmts method_names res_ty' `thenM` \ (binds, stmts', methods') -> - returnM (mkHsLet binds (HsDo do_or_lc stmts' methods' res_ty' src_loc)) + tcDoStmts do_or_lc stmts method_names res_ty' `thenM` \ (stmts', methods') -> + returnM (HsDo do_or_lc stmts' methods' res_ty' src_loc) tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list = zapToListTy res_ty `thenM` \ elt_ty -> @@ -306,72 +308,13 @@ tcMonoExpr (ExplicitTuple exprs boxity) res_ty = zapToTupleTy boxity (length exprs) res_ty `thenM` \ arg_tys -> tcCheckRhos exprs arg_tys `thenM` \ exprs' -> returnM (ExplicitTuple exprs' boxity) -\end{code} - - -%************************************************************************ -%* * - Foreign calls -%* * -%************************************************************************ - -The interesting thing about @ccall@ is that it is just a template -which we instantiate by filling in details about the types of its -argument and result (ie minimal typechecking is performed). So, the -basic story is that we allocate a load of type variables (to hold the -arg/result types); unify them with the args/result; and store them for -later use. - -\begin{code} -tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty - - = getDOpts `thenM` \ dflags -> - - checkTc (not (is_casm && dopt_HscLang dflags /= HscC)) - (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).", - text "Either compile with -fvia-C, or, better, rewrite your code", - text "to use the foreign function interface. _casm_s are deprecated", - text "and support for them may one day disappear."]) - `thenM_` - -- Get the callable and returnable classes. - tcLookupClass cCallableClassName `thenM` \ cCallableClass -> - tcLookupClass cReturnableClassName `thenM` \ cReturnableClass -> - tcLookupTyCon ioTyConName `thenM` \ ioTyCon -> - let - new_arg_dict (arg, arg_ty) - = newDicts (CCallOrigin (unpackFS lbl) (Just arg)) - [mkClassPred cCallableClass [arg_ty]] `thenM` \ arg_dicts -> - returnM arg_dicts -- Actually a singleton bag - - result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -} - in - - -- Arguments - let tv_idxs | null args = [] - | otherwise = [1..length args] - in - newTyVarTys (length tv_idxs) openTypeKind `thenM` \ arg_tys -> - tcCheckRhos args arg_tys `thenM` \ args' -> - - -- The argument types can be unlifted or lifted; the result - -- type must, however, be lifted since it's an argument to the IO - -- type constructor. - newTyVarTy liftedTypeKind `thenM` \ result_ty -> - let - io_result_ty = mkTyConApp ioTyCon [result_ty] - in - zapExpectedTo res_ty io_result_ty `thenM_` - - -- Construct the extra insts, which encode the - -- constraints on the argument and result types. - mappM new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenM` \ ccarg_dicts_s -> - newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenM` \ ccres_dict -> - extendLIEs (ccres_dict ++ concat ccarg_dicts_s) `thenM_` - returnM (HsCCall lbl args' may_gc is_casm io_result_ty) +tcMonoExpr (HsProc pat cmd loc) res_ty + = addSrcLoc loc $ + tcProc pat cmd res_ty `thenM` \ (pat', cmd') -> + returnM (HsProc pat' cmd' loc) \end{code} - %************************************************************************ %* * Record construction and update @@ -443,14 +386,14 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty let field_names = recBindFields rbinds in - mappM tcLookupGlobal_maybe field_names `thenM` \ maybe_sel_ids -> + mappM tcLookupGlobalId field_names `thenM` \ sel_ids -> + -- The renamer has already checked that they + -- are all in scope let bad_guys = [ addErrTc (notSelector field_name) - | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids, - not (is_selector maybe_sel_id) + | (field_name, sel_id) <- field_names `zip` sel_ids, + not (isRecordSelector sel_id) -- Excludes class ops ] - is_selector (Just (AnId sel_id)) = isRecordSelector sel_id -- Excludes class ops - is_selector other = False in checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_` @@ -458,7 +401,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty -- Figure out the tycon and data cons from the first field name let -- It's OK to use the non-tc splitters here (for a selector) - (Just (AnId sel_id) : _) = maybe_sel_ids + sel_id : _ = sel_ids field_lbl = recordSelectorFieldLabel sel_id -- We've failed already if tycon = fieldLabelTyCon field_lbl -- it's not a field label data_cons = tyConDataCons tycon @@ -786,64 +729,65 @@ tcId name -- Look up the Id and instantiate its type = -- First check whether it's a DataCon -- Reason: we must not forget to chuck in the -- constraints from their "silly context" - tcLookupGlobal_maybe name `thenM` \ maybe_thing -> - case maybe_thing of { - Just (ADataCon data_con) -> inst_data_con data_con ; - other -> - - -- OK, so now look for ordinary Ids - tcLookupIdLvl name `thenM` \ (id, bind_lvl) -> + tcLookup name `thenM` \ thing -> + case thing of { + AGlobal (ADataCon data_con) -> inst_data_con data_con + ; AGlobal (AnId id) -> loop (HsVar id) (idType id) + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment + + ; ATcId id th_level proc_level -> tc_local_id id th_level proc_level + ; other -> pprPanic "tcId" (ppr name $$ ppr thing) + } + where #ifndef GHCI - loop (HsVar id) (idType id) -- Non-TH case + tc_local_id id th_bind_lvl proc_lvl -- Non-TH case + = checkProcLevel id proc_lvl `thenM_` + loop (HsVar id) (idType id) + +#else /* GHCI and TH is on */ + tc_local_id id th_bind_lvl proc_lvl -- TH case + = checkProcLevel id proc_lvl `thenM_` -#else /* GHCI is on */ -- Check for cross-stage lifting - getStage `thenM` \ use_stage -> - case use_stage of - Brack use_lvl ps_var lie_var - | use_lvl > bind_lvl && not (isExternalName name) - -> -- E.g. \x -> [| h x |] + getStage `thenM` \ use_stage -> + case use_stage of + Brack use_lvl ps_var lie_var + | use_lvl > th_bind_lvl + -> -- E.g. \x -> [| h x |] -- We must behave as if the reference to x was + -- h $(lift x) -- We use 'x' itself as the splice proxy, used by -- the desugarer to stitch it all back together. -- If 'x' occurs many times we may get many identical -- bindings of the same splice proxy, but that doesn't -- matter, although it's a mite untidy. - -- - -- NB: During type-checking, isExernalName is true of - -- top level things, and false of nested bindings - -- Top-level things don't need lifting. - - let - id_ty = idType id - in - checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_` + let + id_ty = idType id + in + checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_` -- If x is polymorphic, its occurrence sites might -- have different instantiations, so we can't use plain -- 'x' as the splice proxy name. I don't know how to -- solve this, and it's probably unimportant, so I'm -- just going to flag an error for now - setLIEVar lie_var ( - newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift -> - -- Put the 'lift' constraint into the right LIE + setLIEVar lie_var ( + newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift -> + -- Put the 'lift' constraint into the right LIE - -- Update the pending splices - readMutVar ps_var `thenM` \ ps -> - writeMutVar ps_var ((name, HsApp (HsVar lift) (HsVar id)) : ps) `thenM_` - - returnM (HsVar id, id_ty)) - - other -> - checkWellStaged (quotes (ppr id)) bind_lvl use_stage `thenM_` - loop (HsVar id) (idType id) -#endif - } + -- Update the pending splices + readMutVar ps_var `thenM` \ ps -> + writeMutVar ps_var ((name, HsApp (HsVar lift) (HsVar id)) : ps) `thenM_` + + returnM (HsVar id, id_ty)) - where - orig = OccurrenceOf name + other -> + checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_` + loop (HsVar id) (idType id) +#endif /* GHCI */ loop (HsVar fun_id) fun_ty | want_method_inst fun_ty @@ -885,6 +829,8 @@ tcId name -- Look up the Id and instantiate its type returnM (mkHsDictApp (mkHsTyApp (HsVar (dataConWrapId data_con)) ty_args) (map instToId ex_dicts), mkFunTys arg_tys result_ty) + + orig = OccurrenceOf name \end{code} %************************************************************************ @@ -983,10 +929,7 @@ checkMissingFields data_con rbinds field_labels field_strs - field_strs = dropList ex_theta (dataConStrictMarks data_con) - -- The 'drop' is because dataConStrictMarks - -- includes the existential dictionaries - (_, _, _, ex_theta, _, _) = dataConSig data_con + field_strs = dataConStrictMarks data_con \end{code} %************************************************************************ @@ -1016,14 +959,6 @@ Overloaded literals. \begin{code} tcLit :: HsLit -> Expected TcRhoType -> TcM TcExpr -tcLit (HsLitLit s _) res_ty - = zapExpectedType res_ty `thenM` \ res_ty' -> - tcLookupClass cCallableClassName `thenM` \ cCallableClass -> - newDicts (LitLitOrigin (unpackFS s)) - [mkClassPred cCallableClass [res_ty']] `thenM` \ dicts -> - extendLIEs dicts `thenM_` - returnM (HsLit (HsLitLit s res_ty')) - tcLit lit res_ty = zapExpectedTo res_ty (hsLitType lit) `thenM_` returnM (HsLit lit) @@ -1051,7 +986,7 @@ caseScrutCtxt expr = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr) exprSigCtxt expr - = hang (ptext SLIT("When checking the type signature of the expression:")) + = hang (ptext SLIT("In the type signature of the expression:")) 4 (ppr expr) exprCtxt expr @@ -1079,11 +1014,6 @@ appCtxt fun args where the_app = foldl HsApp fun args -- Used in error messages -lurkingRank2Err fun fun_ty - = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)]) - 4 (vcat [ptext SLIT("It is applied to too few arguments"), - ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty]) - badFieldsUpd rbinds = hang (ptext SLIT("No constructor has all these fields:")) 4 (pprQuotedList (recBindFields rbinds)) @@ -1110,10 +1040,6 @@ missingFields con fields = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:") <+> pprWithCommas ppr fields -polySpliceErr :: Id -> SDoc -polySpliceErr id - = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) - wrongArgsCtxt too_many_or_few fun args = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun) <+> ptext SLIT("is applied to") <+> text too_many_or_few @@ -1121,4 +1047,10 @@ wrongArgsCtxt too_many_or_few fun args 4 (parens (ppr the_app)) where the_app = foldl HsApp fun args -- Used in error messages + +#ifdef GHCI +polySpliceErr :: Id -> SDoc +polySpliceErr id + = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) +#endif \end{code}