#ifdef GHCI /* Only if bootstrapped */
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
-import TcEnv ( bracketOK )
-import TcSimplify ( tcSimplifyBracket )
-import DsMeta ( liftName )
+import HsSyn ( HsReify(..), ReifyFlavour(..) )
+import TcType ( isTauTy )
+import TcEnv ( bracketOK, tcMetaTy, checkWellStaged, metaLevel )
+import Name ( isExternalName )
+import qualified DsMeta
#endif
-import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- mkMonoBind, recBindFields
- )
+import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields )
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet )
+import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet, (<$>) )
import TcRnMonad
-import TcUnify ( tcSubExp, tcGen, (<$>),
- unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy,
- unifyTupleTy )
-import BasicTypes ( RecFlag(..), isMarkedStrict )
+import TcUnify ( tcSubExp, tcGen,
+ unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy )
+import BasicTypes ( isMarkedStrict )
import Inst ( InstOrigin(..),
newOverloadedLit, newMethodFromName, newIPDict,
newDicts, newMethodWithGivenTy,
)
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
- tcLookupTyCon, tcLookupDataCon, tcLookupId,
- wellStaged, metaLevel
+ tcLookupTyCon, tcLookupDataCon, tcLookupId
)
-import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts )
+import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( badFieldCon )
-import TcSimplify ( tcSimplifyIPs )
import TcMType ( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType,
newTyVarTy, newTyVarTys, zonkTcType, readHoleResult )
import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
- isSigmaTy, isTauTy, mkFunTy, mkFunTys,
- mkTyConApp, mkClassPred, tcFunArgTy,
+ isSigmaTy, mkFunTy, mkFunTys,
+ mkTyConApp, mkClassPred,
tyVarsOfTypes, isLinearPred,
liftedTypeKind, openTypeKind,
- tcSplitSigmaTy, tcTyConAppTyCon,
- tidyOpenType
+ tcSplitSigmaTy, tidyOpenType
)
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
-import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe )
-import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks )
-import Name ( Name, isExternalName )
+import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector )
+import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId )
+import Name ( Name )
import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
\begin{code}
tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
- = addErrCtxt (exprSigCtxt in_expr) $
- tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty ->
- tcExpr expr sig_tc_ty `thenM` \ expr' ->
-
- -- Must instantiate the outer for-alls of sig_tc_ty
- -- else we risk instantiating a ? res_ty to a forall-type
- -- which breaks the invariant that tcMonoExpr only returns phi-types
- tcInstCall SignatureOrigin sig_tc_ty `thenM` \ (inst_fn, inst_sig_ty) ->
- tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
-
- returnM (co_fn <$> inst_fn expr')
+ = addErrCtxt (exprSigCtxt in_expr) $
+ tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty ->
+ tcThingWithSig sig_tc_ty (tcMonoExpr expr) res_ty `thenM` \ (co_fn, expr') ->
+ returnM (co_fn <$> expr')
tcMonoExpr (HsType ty) res_ty
= failWithTc (text "Can't handle type argument:" <+> ppr ty)
tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->
returnM (HsSCC lbl expr')
-
+tcMonoExpr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> -- hdaume: core annotation
+ returnM (HsCoreAnn lbl expr')
tcMonoExpr (NegApp expr neg_name) res_ty
= tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty
-- ToDo: use tcSyntaxName
\begin{code}
tcMonoExpr (HsLet binds expr) res_ty
= tcBindsAndThen
- combiner
+ HsLet
binds -- Bindings to check
(tcMonoExpr expr res_ty)
- where
- combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr
tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
= addSrcLoc src_loc $
let
bad_guys = [ addErrTc (notSelector field_name)
| (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
- case maybe_sel_id of
- Just (AnId sel_id) -> not (isRecordSelector sel_id)
- other -> True
+ not (is_selector maybe_sel_id)
]
+ 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_`
let
-- It's OK to use the non-tc splitters here (for a selector)
(Just (AnId sel_id) : _) = maybe_sel_ids
-
- (_, _, tau) = tcSplitSigmaTy (idType sel_id) -- Selectors can be overloaded
- -- when the data type has a context
- data_ty = tcFunArgTy tau -- Must succeed since sel_id is a selector
- tycon = tcTyConAppTyCon data_ty
+ field_lbl = recordSelectorFieldLabel sel_id -- We've failed already if
+ tycon = fieldLabelTyCon field_lbl -- it's not a field label
data_cons = tyConDataCons tycon
tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars
in
-- Rename excludes these cases otherwise
tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty)
-
-tcMonoExpr (HsBracket brack loc) res_ty
- = addSrcLoc loc $
- getStage `thenM` \ level ->
- case bracketOK level of {
- Nothing -> failWithTc (illegalBracket level) ;
- Just next_level ->
-
- -- Typecheck expr to make sure it is valid,
- -- but throw away the results. We'll type check
- -- it again when we actually use it.
- newMutVar [] `thenM` \ pending_splices ->
- getLIEVar `thenM` \ lie_var ->
-
- setStage (Brack next_level pending_splices lie_var) (
- getLIE (tcBracket brack)
- ) `thenM` \ (meta_ty, lie) ->
- tcSimplifyBracket lie `thenM_`
-
- unifyTauTy res_ty meta_ty `thenM_`
-
- -- Return the original expression, not the type-decorated one
- readMutVar pending_splices `thenM` \ pendings ->
- returnM (HsBracketOut brack pendings)
- }
-#endif GHCI
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Implicit Parameter bindings}
-%* *
-%************************************************************************
-
-\begin{code}
-tcMonoExpr (HsWith expr binds is_with) res_ty
- = getLIE (tcMonoExpr expr res_ty) `thenM` \ (expr', expr_lie) ->
- mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, binds') ->
+tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack res_ty)
- -- If the binding binds ?x = E, we must now
- -- discharge any ?x constraints in expr_lie
- tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds ->
- let
- expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr'
- in
- returnM (HsWith expr'' binds' is_with)
+tcMonoExpr (HsReify (Reify flavour name)) res_ty
+ = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $
+ tcMetaTy tycon_name `thenM` \ reify_ty ->
+ unifyTauTy res_ty reify_ty `thenM_`
+ returnM (HsReify (ReifyOut flavour name))
where
- tc_ip_bind (ip, expr)
- = newTyVarTy openTypeKind `thenM` \ ty ->
- getSrcLocM `thenM` \ loc ->
- newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) ->
- tcMonoExpr expr ty `thenM` \ expr' ->
- returnM (ip_inst, (ip', expr'))
+ tycon_name = case flavour of
+ ReifyDecl -> DsMeta.declTyConName
+ ReifyType -> DsMeta.typeTyConName
+ ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
+#endif GHCI
\end{code}
split_fun_ty fun_ty (length args)
) `thenM` \ (expected_arg_tys, actual_result_ty) ->
- -- Now typecheck the args
- mappM (tcArg fun)
- (zip3 args expected_arg_tys [1..]) `thenM` \ args' ->
-
- -- Unify with expected result after type-checking the args
- -- so that the info from args percolates to actual_result_ty.
+ -- Unify with expected result before (was: after) type-checking the args
+ -- so that the info from res_ty (was: args) percolates to args (was actual_result_ty).
-- This is when we might detect a too-few args situation.
-- (One can think of cases when the opposite order would give
-- a better error message.)
+ -- [March 2003: I'm experimenting with putting this first. Here's an
+ -- example where it actually makes a real difference
+ -- class C t a b | t a -> b
+ -- instance C Char a Bool
+ --
+ -- data P t a = forall b. (C t a b) => MkP b
+ -- data Q t = MkQ (forall a. P t a)
+
+ -- f1, f2 :: Q Char;
+ -- f1 = MkQ (MkP True)
+ -- f2 = MkQ (MkP True :: forall a. P Char a)
+ --
+ -- With the change, f1 will type-check, because the 'Char' info from
+ -- the signature is propagated into MkQ's argument. With the check
+ -- in the other order, the extra signature in f2 is reqd.]
+
addErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
- (tcSubExp res_ty actual_result_ty) `thenM` \ co_fn ->
+ (tcSubExp res_ty actual_result_ty) `thenM` \ co_fn ->
+
+ -- Now typecheck the args
+ mappM (tcArg fun)
+ (zip3 args expected_arg_tys [1..]) `thenM` \ args' ->
returnM (co_fn <$> foldl HsApp fun' args')
\begin{code}
tcId :: Name -> TcM (TcExpr, TcType)
tcId name -- Look up the Id and instantiate its type
- = tcLookupIdLvl name `thenM` \ (id, bind_lvl) ->
+ = -- 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) ->
+
+#ifndef GHCI
+ loop (HsVar id) (idType id) -- Non-TH case
+#else /* GHCI is on */
-- Check for cross-stage lifting
-#ifdef GHCI
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 |]
- -- 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
- -- NB: isExernalName is true of top level things,
- -- and false of nested bindings
+ -- 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
-- just going to flag an error for now
setLIEVar lie_var (
- newMethodFromName orig id_ty liftName `thenM` \ lift ->
+ newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
-- Put the 'lift' constraint into the right LIE
-- Update the pending splices
returnM (HsVar id, id_ty))
other ->
- let
- use_lvl = metaLevel use_stage
- in
- checkTc (wellStaged bind_lvl use_lvl)
- (badStageErr id bind_lvl use_lvl) `thenM_`
+ checkWellStaged (quotes (ppr id)) bind_lvl use_stage `thenM_`
+ loop (HsVar id) (idType id)
#endif
- -- This is the bit that handles the no-Template-Haskell case
- case isDataConWrapId_maybe id of
- Nothing -> loop (HsVar id) (idType id)
- Just data_con -> inst_data_con id data_con
+ }
where
orig = OccurrenceOf name
| want_method_inst fun_ty
= tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
newMethodWithGivenTy orig fun_id
- (mkTyVarTys tyvars) theta tau `thenM` \ meth ->
- loop (HsVar (instToId meth)) tau
+ (mkTyVarTys tyvars) theta tau `thenM` \ meth_id ->
+ loop (HsVar meth_id) tau
loop fun fun_ty
| isSigmaTy fun_ty
= tcInstCall orig fun_ty `thenM` \ (inst_fn, tau) ->
- loop (inst_fn fun) tau
+ loop (inst_fn <$> fun) tau
| otherwise
= returnM (fun, fun_ty)
- want_method_inst fun_ty
- | opt_NoMethodSharing = False
- | otherwise = case tcSplitSigmaTy fun_ty of
- (_,[],_) -> False -- Not overloaded
- (_,theta,_) -> not (any isLinearPred theta)
- -- This is a slight hack.
+ -- Hack Alert (want_method_inst)!
-- 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:
-- 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 fun_ty
+ | opt_NoMethodSharing = False
+ | otherwise = case tcSplitSigmaTy fun_ty of
+ (_,[],_) -> False -- Not overloaded
+ (_,theta,_) -> not (any isLinearPred theta)
+
-- 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
- inst_data_con id data_con
+ 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 id) ty_args) (map instToId ex_dicts),
+ returnM (mkHsDictApp (mkHsTyApp (HsVar (dataConWrapId data_con)) ty_args)
+ (map instToId ex_dicts),
mkFunTys arg_tys result_ty)
\end{code}
arithSeqCtxt expr
= hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
-
-badStageErr id bind_lvl use_lvl
- = ptext SLIT("Stage error:") <+> quotes (ppr id) <+>
- hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
- ptext SLIT("but used at stage") <+> ppr use_lvl]
-
parrSeqCtxt expr
= hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
predCtxt expr
= hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
-illegalBracket level
- = ptext SLIT("Illegal bracket at level") <+> ppr level
-
appCtxt fun args
= ptext SLIT("In the application") <+> quotes (ppr the_app)
where
header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
ptext SLIT("does not have the required strict field(s)")
-
missingFields :: DataCon -> [FieldLabel] -> SDoc
missingFields con fields
= ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
projects / ghc-hetmet.git / blobdiff