#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 )
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
-- (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 $
= 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 ->
= 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
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_`
-- 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
tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty)
tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack res_ty)
-
-tcMonoExpr (HsReify (Reify flavour name)) res_ty
- = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $
- tcMetaTy tycon_name `thenM` \ reify_ty ->
- zapExpectedTo res_ty reify_ty `thenM_`
- returnM (HsReify (ReifyOut flavour name))
- where
- tycon_name = case flavour of
- ReifyDecl -> DsMeta.declTyConName
- ReifyType -> DsMeta.typeTyConName
- ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
-#endif GHCI
+#endif /* GHCI */
\end{code}
= -- 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
-- We treat data constructors differently, because we have to generate
-- constraints for their silly theta, which no longer appears in
- -- the type of dataConWrapId. It's dual to TcPat.tcConstructor
+ -- the type of dataConWrapId (see note on "stupid context" in DataCon.lhs
+ -- It's dual to TcPat.tcConstructor
inst_data_con data_con
= tcInstDataCon orig data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) ->
extendLIEs ex_dicts `thenM_`
returnM (mkHsDictApp (mkHsTyApp (HsVar (dataConWrapId data_con)) ty_args)
(map instToId ex_dicts),
mkFunTys arg_tys result_ty)
+
+ orig = OccurrenceOf name
\end{code}
%************************************************************************
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}
%************************************************************************
\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)
= 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
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))
= 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
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}
projects / ghc-hetmet.git / blobdiff