2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[TcExpr]{Typecheck an expression}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
15 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcInferRhoNC, tcSyntaxOp ) where
17 #include "HsVersions.h"
19 #ifdef GHCI /* Only if bootstrapped */
20 import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
21 import qualified DsMeta
38 import TcIface ( checkWiredInTyCon )
64 %************************************************************************
66 \subsection{Main wrappers}
68 %************************************************************************
71 tcPolyExpr, tcPolyExprNC
72 :: LHsExpr Name -- Expession to type check
73 -> BoxySigmaType -- Expected type (could be a polytpye)
74 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
76 -- tcPolyExpr is a convenient place (frequent but not too frequent) place
77 -- to add context information.
78 -- The NC version does not do so, usually because the caller wants
81 tcPolyExpr expr res_ty
82 = addErrCtxt (exprCtxt expr) $
83 (do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
85 tcPolyExprNC expr res_ty
87 = do { traceTc (text "tcPolyExprNC" <+> ppr res_ty)
88 ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing $ \ _ res_ty ->
89 tcPolyExprNC expr res_ty
90 -- Note the recursive call to tcPolyExpr, because the
91 -- type may have multiple layers of for-alls
92 -- E.g. forall a. Eq a => forall b. Ord b => ....
93 ; return (mkLHsWrap gen_fn expr') }
96 = tcMonoExprNC expr res_ty
99 tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
100 tcPolyExprs [] [] = return []
101 tcPolyExprs (expr:exprs) (ty:tys)
102 = do { expr' <- tcPolyExpr expr ty
103 ; exprs' <- tcPolyExprs exprs tys
104 ; return (expr':exprs') }
105 tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
108 tcMonoExpr, tcMonoExprNC
109 :: LHsExpr Name -- Expression to type check
110 -> BoxyRhoType -- Expected type (could be a type variable)
111 -- Definitely no foralls at the top
112 -- Can contain boxes, which will be filled in
113 -> TcM (LHsExpr TcId)
115 tcMonoExpr expr res_ty
116 = addErrCtxt (exprCtxt expr) $
117 tcMonoExprNC expr res_ty
119 tcMonoExprNC (L loc expr) res_ty
120 = ASSERT( not (isSigmaTy res_ty) )
122 do { expr' <- tcExpr expr res_ty
123 ; return (L loc expr') }
126 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
127 tcInferRho expr = tcInfer (tcMonoExpr expr)
128 tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
132 %************************************************************************
134 tcExpr: the main expression typechecker
136 %************************************************************************
139 tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
140 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
141 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
143 tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty
145 tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
146 ; coi <- boxyUnify lit_ty res_ty
147 ; return $ mkHsWrapCoI coi (HsLit lit)
150 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
151 ; return (HsPar expr') }
153 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
154 ; return (HsSCC lbl expr') }
155 tcExpr (HsTickPragma info expr) res_ty
156 = do { expr' <- tcMonoExpr expr res_ty
157 ; return (HsTickPragma info expr') }
159 tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
160 = do { expr' <- tcMonoExpr expr res_ty
161 ; return (HsCoreAnn lbl expr') }
163 tcExpr (HsOverLit lit) res_ty
164 = do { lit' <- tcOverloadedLit (LiteralOrigin lit) lit res_ty
165 ; return (HsOverLit lit') }
167 tcExpr (NegApp expr neg_expr) res_ty
168 = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
169 (mkFunTy res_ty res_ty)
170 ; expr' <- tcMonoExpr expr res_ty
171 ; return (NegApp expr' neg_expr') }
173 tcExpr (HsIPVar ip) res_ty
174 = do { let origin = IPOccOrigin ip
175 -- Implicit parameters must have a *tau-type* not a
176 -- type scheme. We enforce this by creating a fresh
177 -- type variable as its type. (Because res_ty may not
179 ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
180 ; co_fn <- tcSubExp origin ip_ty res_ty
181 ; (ip', inst) <- newIPDict origin ip ip_ty
183 ; return (mkHsWrap co_fn (HsIPVar ip')) }
185 tcExpr (HsApp e1 e2) res_ty
188 go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
189 go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
190 go lfun@(L loc fun) args
191 = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
192 tcApp fun (length args) (tcArgs lfun args) res_ty
193 ; traceTc (text "tcExpr args': " <+> ppr args')
194 ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
196 tcExpr (HsLam match) res_ty
197 = do { (co_fn, match') <- tcMatchLambda match res_ty
198 ; return (mkHsWrap co_fn (HsLam match')) }
200 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
201 = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
203 -- Remember to extend the lexical type-variable environment
204 ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ \ skol_tvs res_ty ->
205 tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
206 -- See Note [More instantiated than scoped] in TcBinds
207 tcMonoExprNC expr res_ty
209 ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
210 ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
212 tcExpr (HsType ty) res_ty
213 = failWithTc (text "Can't handle type argument:" <+> ppr ty)
214 -- This is the syntax for type applications that I was planning
215 -- but there are difficulties (e.g. what order for type args)
216 -- so it's not enabled yet.
217 -- Can't eliminate it altogether from the parser, because the
218 -- same parser parses *patterns*.
222 %************************************************************************
224 Infix operators and sections
226 %************************************************************************
229 tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
230 = do { (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty
231 ; return (OpApp arg1' (L loc op') fix arg2') }
233 -- Left sections, equivalent to
237 -- or, if PostfixOperators is enabled, just
240 -- With PostfixOperators we don't
241 -- actually require the function to take two arguments
242 -- at all. For example, (x `not`) means (not x);
243 -- you get postfix operators! Not Haskell 98,
244 -- but it's less work and kind of useful.
246 tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
247 = do dflags <- getDOpts
248 if dopt Opt_PostfixOperators dflags
249 then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
250 return (SectionL arg1' (L loc op'))
251 else do (co_fn, (op', arg1'))
252 <- subFunTys doc 1 res_ty Nothing
253 $ \ [arg2_ty'] res_ty' ->
254 tcApp op 2 (tc_args arg2_ty') res_ty'
255 return (mkHsWrap co_fn (SectionL arg1' (L loc op')))
257 doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
258 <+> ptext (sLit "takes one argument")
259 tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty]
260 = do { boxyUnify arg2_ty' (substTyWith qtvs qtys arg2_ty)
261 ; arg1' <- tcArg lop 2 arg1 qtvs qtys arg1_ty
262 ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
263 ; return (qtys', arg1') }
264 tc_args _ _ _ _ = panic "tcExpr SectionL"
266 -- Right sections, equivalent to \ x -> x `op` expr, or
269 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
270 = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
271 tcApp op 2 (tc_args arg1_ty') res_ty'
272 ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
274 doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
275 <+> ptext (sLit "takes one argument")
276 tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty]
277 = do { boxyUnify arg1_ty' (substTyWith qtvs qtys arg1_ty)
278 ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty
279 ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
280 ; return (qtys', arg2') }
281 tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
285 tcExpr (HsLet binds expr) res_ty
286 = do { (binds', expr') <- tcLocalBinds binds $
287 tcMonoExpr expr res_ty
288 ; return (HsLet binds' expr') }
290 tcExpr (HsCase scrut matches) exp_ty
291 = do { -- We used to typecheck the case alternatives first.
292 -- The case patterns tend to give good type info to use
293 -- when typechecking the scrutinee. For example
296 -- will report that map is applied to too few arguments
298 -- But now, in the GADT world, we need to typecheck the scrutinee
299 -- first, to get type info that may be refined in the case alternatives
300 (scrut', scrut_ty) <- tcInferRho scrut
302 ; traceTc (text "HsCase" <+> ppr scrut_ty)
303 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
304 ; return (HsCase scrut' matches') }
306 match_ctxt = MC { mc_what = CaseAlt,
309 tcExpr (HsIf pred b1 b2) res_ty
310 = do { pred' <- tcMonoExpr pred boolTy
311 ; b1' <- tcMonoExpr b1 res_ty
312 ; b2' <- tcMonoExpr b2 res_ty
313 ; return (HsIf pred' b1' b2') }
315 tcExpr (HsDo do_or_lc stmts body _) res_ty
316 = tcDoStmts do_or_lc stmts body res_ty
318 tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
319 = do { (elt_ty, coi) <- boxySplitListTy res_ty
320 ; exprs' <- mapM (tc_elt elt_ty) exprs
321 ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
323 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
325 tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
326 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
327 ; exprs' <- mapM (tc_elt elt_ty) exprs
328 ; when (null exprs) (zapToMonotype elt_ty >> return ())
329 -- If there are no expressions in the comprehension
330 -- we must still fill in the box
331 -- (Not needed for [] and () becuase they happen
332 -- to parse as data constructors.)
333 ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
335 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
337 -- For tuples, take care to preserve rigidity
338 -- E.g. case (x,y) of ....
339 -- The scrutinee should have a rigid type if x,y do
340 -- The general scheme is the same as in tcIdApp
341 tcExpr (ExplicitTuple exprs boxity) res_ty
342 = do { let kind = case boxity of { Boxed -> liftedTypeKind
343 ; Unboxed -> argTypeKind }
344 ; tvs <- newBoxyTyVars [kind | e <- exprs]
345 ; let tup_tc = tupleTyCon boxity (length exprs)
346 tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
347 ; checkWiredInTyCon tup_tc -- Ensure instances are available
348 ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
349 ; exprs' <- tcPolyExprs exprs arg_tys
350 ; arg_tys' <- mapM refineBox arg_tys
351 ; co_fn <- tcSubExp TupleOrigin (mkTyConApp tup_tc arg_tys') res_ty
352 ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
354 tcExpr (HsProc pat cmd) res_ty
355 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
356 ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
358 tcExpr e@(HsArrApp _ _ _ _ _) _
359 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
360 ptext (sLit "was found where an expression was expected")])
362 tcExpr e@(HsArrForm _ _ _) _
363 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
364 ptext (sLit "was found where an expression was expected")])
367 %************************************************************************
369 Record construction and update
371 %************************************************************************
374 tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
375 = do { data_con <- tcLookupDataCon con_name
377 -- Check for missing fields
378 ; checkMissingFields data_con rbinds
380 ; let arity = dataConSourceArity data_con
381 check_fields qtvs qtys arg_tys
382 = do { let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys
383 ; rbinds' <- tcRecordBinds data_con arg_tys' rbinds
384 ; qtys' <- mapM refineBoxToTau qtys
385 ; return (qtys', rbinds') }
386 -- The refineBoxToTau ensures that all the boxes in arg_tys are indeed
387 -- filled, which is the invariant expected by tcIdApp
388 -- How could this not be the case? Consider a record construction
389 -- that does not mention all the fields.
391 ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
393 ; return (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
395 -- The main complication with RecordUpd is that we need to explicitly
396 -- handle the *non-updated* fields. Consider:
398 -- data T a b = MkT1 { fa :: a, fb :: b }
399 -- | MkT2 { fa :: a, fc :: Int -> Int }
400 -- | MkT3 { fd :: a }
402 -- upd :: T a b -> c -> T a c
403 -- upd t x = t { fb = x}
405 -- The type signature on upd is correct (i.e. the result should not be (T a b))
406 -- because upd should be equivalent to:
408 -- upd t x = case t of
409 -- MkT1 p q -> MkT1 p x
410 -- MkT2 a b -> MkT2 p b
411 -- MkT3 d -> error ...
413 -- So we need to give a completely fresh type to the result record,
414 -- and then constrain it by the fields that are *not* updated ("p" above).
416 -- Note that because MkT3 doesn't contain all the fields being updated,
417 -- its RHS is simply an error, so it doesn't impose any type constraints
419 -- All this is done in STEP 4 below.
423 -- For record update we require that every constructor involved in the
424 -- update (i.e. that has all the specified fields) is "vanilla". I
425 -- don't know how to do the update otherwise.
428 tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty = do
430 -- Check that the field names are really field names
432 field_names = hsRecFields rbinds
434 MASSERT( notNull field_names )
435 sel_ids <- mapM tcLookupField field_names
436 -- The renamer has already checked that they
439 bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
440 | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
441 not (isRecordSelector sel_id), -- Excludes class ops
442 let L loc field_name = hsRecFieldId fld
445 unless (null bad_guys) (sequence bad_guys >> failM)
448 -- Figure out the tycon and data cons from the first field name
450 -- It's OK to use the non-tc splitters here (for a selector)
452 (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
453 data_cons = tyConDataCons tycon -- it's not a field label
454 -- NB: for a data type family, the tycon is the instance tycon
456 relevant_cons = filter is_relevant data_cons
457 is_relevant con = all (`elem` dataConFieldLabels con) field_names
460 -- Check that at least one constructor has all the named fields
461 -- i.e. has an empty set of bad fields returned by badFields
462 checkTc (not (null relevant_cons))
463 (badFieldsUpd rbinds)
465 -- Check that all relevant data cons are vanilla. Doing record updates on
466 -- GADTs and/or existentials is more than my tiny brain can cope with today
467 checkTc (all isVanillaDataCon relevant_cons)
468 (nonVanillaUpd tycon)
471 -- Use the un-updated fields to find a vector of booleans saying
472 -- which type arguments must be the same in updatee and result.
474 -- WARNING: this code assumes that all data_cons in a common tycon
475 -- have FieldLabels abstracted over the same tyvars.
477 -- A constructor is only relevant to this process if
478 -- it contains *all* the fields that are being updated
479 con1 = ASSERT( not (null relevant_cons) ) head relevant_cons -- A representative constructor
480 (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1
481 con1_flds = dataConFieldLabels con1
482 common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
483 , not (fld `elem` field_names) ]
485 is_common_tv tv = tv `elemVarSet` common_tyvars
487 mk_inst_ty tv result_inst_ty
488 | is_common_tv tv = return result_inst_ty -- Same as result type
489 | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
491 MASSERT( null theta ) -- Vanilla datacon
492 (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tyvars
493 scrut_inst_tys <- zipWithM mk_inst_ty con1_tyvars result_inst_tys
495 -- STEP 3: Typecheck the update bindings.
496 -- Do this after checking for bad fields in case
497 -- there's a field that doesn't match the constructor.
499 result_ty = substTy result_inst_env con1_res_ty
500 con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
501 origin = RecordUpdOrigin
503 co_fn <- tcSubExp origin result_ty res_ty
504 rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
506 -- STEP 5: Typecheck the expression to be updated
508 scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys
509 scrut_ty = substTy scrut_inst_env con1_res_ty
510 -- This is one place where the isVanilla check is important
511 -- So that inst_tys matches the con1_tyvars
513 record_expr' <- tcMonoExpr record_expr scrut_ty
515 -- STEP 6: Figure out the LIE we need.
516 -- We have to generate some dictionaries for the data type context,
517 -- since we are going to do pattern matching over the data cons.
519 -- What dictionaries do we need? The dataConStupidTheta tells us.
521 theta' = substTheta scrut_inst_env (dataConStupidTheta con1)
523 instStupidTheta origin theta'
525 -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
526 let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
527 = WpCast $ mkTyConApp co_con scrut_inst_tys
532 return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
533 relevant_cons scrut_inst_tys result_inst_tys))
537 %************************************************************************
539 Arithmetic sequences e.g. [a,b..]
540 and their parallel-array counterparts e.g. [: a,b.. :]
543 %************************************************************************
546 tcExpr (ArithSeq _ seq@(From expr)) res_ty
547 = do { (elt_ty, coi) <- boxySplitListTy res_ty
548 ; expr' <- tcPolyExpr expr elt_ty
549 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
551 ; return $ mkHsWrapCoI coi (ArithSeq (HsVar enum_from) (From expr')) }
553 tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
554 = do { (elt_ty, coi) <- boxySplitListTy res_ty
555 ; expr1' <- tcPolyExpr expr1 elt_ty
556 ; expr2' <- tcPolyExpr expr2 elt_ty
557 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
558 elt_ty enumFromThenName
559 ; return $ mkHsWrapCoI coi
560 (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
562 tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
563 = do { (elt_ty, coi) <- boxySplitListTy res_ty
564 ; expr1' <- tcPolyExpr expr1 elt_ty
565 ; expr2' <- tcPolyExpr expr2 elt_ty
566 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
567 elt_ty enumFromToName
568 ; return $ mkHsWrapCoI coi
569 (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
571 tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
572 = do { (elt_ty, coi) <- boxySplitListTy res_ty
573 ; expr1' <- tcPolyExpr expr1 elt_ty
574 ; expr2' <- tcPolyExpr expr2 elt_ty
575 ; expr3' <- tcPolyExpr expr3 elt_ty
576 ; eft <- newMethodFromName (ArithSeqOrigin seq)
577 elt_ty enumFromThenToName
578 ; return $ mkHsWrapCoI coi
579 (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
581 tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
582 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
583 ; expr1' <- tcPolyExpr expr1 elt_ty
584 ; expr2' <- tcPolyExpr expr2 elt_ty
585 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
586 elt_ty enumFromToPName
587 ; return $ mkHsWrapCoI coi
588 (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
590 tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
591 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
592 ; expr1' <- tcPolyExpr expr1 elt_ty
593 ; expr2' <- tcPolyExpr expr2 elt_ty
594 ; expr3' <- tcPolyExpr expr3 elt_ty
595 ; eft <- newMethodFromName (PArrSeqOrigin seq)
596 elt_ty enumFromThenToPName
597 ; return $ mkHsWrapCoI coi
598 (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
600 tcExpr (PArrSeq _ _) _
601 = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
602 -- the parser shouldn't have generated it and the renamer shouldn't have
607 %************************************************************************
611 %************************************************************************
614 #ifdef GHCI /* Only if bootstrapped */
615 -- Rename excludes these cases otherwise
616 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
617 tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
619 tcExpr e@(HsQuasiQuoteE _) res_ty =
620 pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
625 %************************************************************************
629 %************************************************************************
632 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
636 %************************************************************************
640 %************************************************************************
643 ---------------------------
644 tcApp :: HsExpr Name -- Function
645 -> Arity -- Number of args reqd
646 -> ArgChecker results
647 -> BoxyRhoType -- Result type
648 -> TcM (HsExpr TcId, results)
650 -- (tcFun fun n_args arg_checker res_ty)
651 -- The argument type checker, arg_checker, will be passed exactly n_args types
653 tcApp (HsVar fun_name) n_args arg_checker res_ty
654 = tcIdApp fun_name n_args arg_checker res_ty
656 tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP)
657 = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
658 ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
659 ; arg_tys' <- mapM readFilledBox arg_boxes
660 ; (_, args') <- arg_checker [] [] arg_tys' -- Yuk
661 ; return (fun', args') }
663 ---------------------------
664 tcIdApp :: Name -- Function
665 -> Arity -- Number of args reqd
666 -> ArgChecker results -- The arg-checker guarantees to fill all boxes in the arg types
667 -> BoxyRhoType -- Result type
668 -> TcM (HsExpr TcId, results)
670 -- Call (f e1 ... en) :: res_ty
671 -- Type f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
672 -- (where k <= n; fres has the rest)
673 -- NB: if k < n then the function doesn't have enough args, and
674 -- presumably fres is a type variable that we are going to
675 -- instantiate with a function type
677 -- Then fres <= bx_(k+1) -> ... -> bx_n -> res_ty
679 tcIdApp fun_name n_args arg_checker res_ty
680 = do { let orig = OccurrenceOf fun_name
681 ; (fun, fun_ty) <- lookupFun orig fun_name
683 -- Split up the function type
684 ; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty
685 (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
687 qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
688 arg_qtvs = exactTyVarsOfTypes fun_arg_tys
689 res_qtvs = exactTyVarsOfType fun_res_ty
690 -- NB: exactTyVarsOfType. See Note [Silly type synonyms in smart-app]
691 tau_qtvs = arg_qtvs `unionVarSet` res_qtvs
692 k = length fun_arg_tys -- k <= n_args
693 n_missing_args = n_args - k -- Always >= 0
695 -- Match the result type of the function with the
696 -- result type of the context, to get an inital substitution
697 ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
698 ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
699 res_ty' = mkFunTys extra_arg_tys' res_ty
700 ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
702 -- Typecheck the arguments!
703 -- Doing so will fill arg_qtvs and extra_arg_tys'
704 ; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys')
706 -- Strip boxes from the qtvs that have been filled in by the arg checking
707 ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
709 -- Result subsumption
710 -- This fills in res_qtvs
711 ; let res_subst = zipOpenTvSubst qtvs qtys''
712 fun_res_ty'' = substTy res_subst fun_res_ty
713 res_ty'' = mkFunTys extra_arg_tys'' res_ty
714 ; co_fn <- tcSubExp orig fun_res_ty'' res_ty''
716 -- And pack up the results
717 -- By applying the coercion just to the *function* we can make
718 -- tcFun work nicely for OpApp and Sections too
719 ; fun' <- instFun orig fun res_subst tv_theta_prs
720 ; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn
721 ; traceTc (text "tcIdApp: " <+> ppr (mkHsWrap co_fn' fun') <+> ppr tv_theta_prs <+> ppr co_fn' <+> ppr fun')
722 ; return (mkHsWrap co_fn' fun', args') }
725 Note [Silly type synonyms in smart-app]
726 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
727 When we call sripBoxyType, all of the boxes should be filled
728 in. But we need to be careful about type synonyms:
732 In the call (f x) we'll typecheck x, expecting it to have type
733 (T box). Usually that would fill in the box, but in this case not;
734 because 'a' is discarded by the silly type synonym T. So we must
735 use exactTyVarsOfType to figure out which type variables are free
736 in the argument type.
739 -- tcId is a specialisation of tcIdApp when there are no arguments
740 -- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty
745 -> BoxyRhoType -- Result type
747 tcId orig fun_name res_ty
748 = do { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
749 ; (fun, fun_ty) <- lookupFun orig fun_name
751 -- Split up the function type
752 ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
753 qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
754 tau_qtvs = exactTyVarsOfType fun_tau -- Mentioned in the tau part
755 ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
757 -- Do the subsumption check wrt the result type
758 ; let res_subst = zipTopTvSubst qtvs qtv_tys
759 fun_tau' = substTy res_subst fun_tau
761 ; co_fn <- tcSubExp orig fun_tau' res_ty
763 -- And pack up the results
764 ; fun' <- instFun orig fun res_subst tv_theta_prs
765 ; traceTc (text "tcId yields" <+> ppr (mkHsWrap co_fn fun'))
766 ; return (mkHsWrap co_fn fun') }
768 -- Note [Push result type in]
770 -- Unify with expected result before (was: after) type-checking the args
771 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
772 -- This is when we might detect a too-few args situation.
773 -- (One can think of cases when the opposite order would give
774 -- a better error message.)
775 -- [March 2003: I'm experimenting with putting this first. Here's an
776 -- example where it actually makes a real difference
777 -- class C t a b | t a -> b
778 -- instance C Char a Bool
780 -- data P t a = forall b. (C t a b) => MkP b
781 -- data Q t = MkQ (forall a. P t a)
784 -- f1 = MkQ (MkP True)
785 -- f2 = MkQ (MkP True :: forall a. P Char a)
787 -- With the change, f1 will type-check, because the 'Char' info from
788 -- the signature is propagated into MkQ's argument. With the check
789 -- in the other order, the extra signature in f2 is reqd.]
791 ---------------------------
792 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
793 -- Typecheck a syntax operator, checking that it has the specified type
794 -- The operator is always a variable at this stage (i.e. renamer output)
795 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
796 tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
798 ---------------------------
799 instFun :: InstOrigin
801 -> TvSubst -- The instantiating substitution
802 -> [([TyVar], ThetaType)] -- Stuff to instantiate
805 instFun orig fun subst []
806 = return fun -- Common short cut
808 instFun orig fun subst tv_theta_prs
809 = do { let ty_theta_prs' = map subst_pr tv_theta_prs
810 ; traceTc (text "instFun" <+> ppr ty_theta_prs')
811 -- Make two ad-hoc checks
812 ; doStupidChecks fun ty_theta_prs'
814 -- Now do normal instantiation
815 ; method_sharing <- doptM Opt_MethodSharing
816 ; result <- go method_sharing True fun ty_theta_prs'
817 ; traceTc (text "instFun result" <+> ppr result)
821 subst_pr (tvs, theta)
822 = (substTyVars subst tvs, substTheta subst theta)
824 go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun }
826 go method_sharing True (HsVar fun_id) ((tys,theta) : prs)
827 | want_method_inst method_sharing theta
828 = do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta")
829 ; meth_id <- newMethodWithGivenTy orig fun_id tys
830 ; go method_sharing False (HsVar meth_id) prs }
831 -- Go round with 'False' to prevent further use
832 -- of newMethod: see Note [Multiple instantiation]
834 go method_sharing _ fun ((tys, theta) : prs)
835 = do { co_fn <- instCall orig tys theta
836 ; traceTc (text "go yields co_fn" <+> ppr co_fn)
837 ; go method_sharing False (HsWrap co_fn fun) prs }
839 -- See Note [No method sharing]
840 want_method_inst method_sharing theta = not (null theta) -- Overloaded
844 Note [Multiple instantiation]
845 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
846 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
847 For example, consider
848 f :: forall a. Eq a => forall b. Ord b => a -> b
849 At a call to f, at say [Int, Bool], it's tempting to translate the call to
853 f_m1 :: forall b. Ord b => Int -> b
857 f_m2 = f_m1 Bool dOrdBool
859 But notice that f_m2 has f_m1 as its meth_id. Now the danger is that if we do
860 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
862 But it's entirely possible that f_m2 will continue to float out, because it
863 mentions no type variables. Result, f_m1 isn't in scope.
865 Here's a concrete example that does this (test tc200):
868 f :: Eq b => b -> a -> Int
869 baz :: Eq a => Int -> a -> Int
874 Current solution: only do the "method sharing" thing for the first type/dict
875 application, not for the iterated ones. A horribly subtle point.
877 Note [No method sharing]
878 ~~~~~~~~~~~~~~~~~~~~~~~~
879 The -fno-method-sharing flag controls what happens so far as the LIE
880 is concerned. The default case is that for an overloaded function we
881 generate a "method" Id, and add the Method Inst to the LIE. So you get
884 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
885 If you specify -fno-method-sharing, the dictionary application
886 isn't shared, so we get
888 f = /\a (d:Num a) (x:a) -> (+) a d x x
889 This gets a bit less sharing, but
890 a) it's better for RULEs involving overloaded functions
891 b) perhaps fewer separated lambdas
895 tcArgs implements a left-to-right order, which goes beyond what is described in the
896 impredicative type inference paper. In particular, it allows
898 where runST :: (forall s. ST s a) -> a
899 When typechecking the application of ($)::(a->b) -> a -> b, we first check that
900 runST has type (a->b), thereby filling in a=forall s. ST s a. Then we un-box this type
901 before checking foo. The left-to-right order really helps here.
904 tcArgs :: LHsExpr Name -- The function (for error messages)
905 -> [LHsExpr Name] -- Actual args
906 -> ArgChecker [LHsExpr TcId]
908 type ArgChecker results
909 = [TyVar] -> [TcSigmaType] -- Current instantiation
910 -> [TcSigmaType] -- Expected arg types (**before** applying the instantiation)
911 -> TcM ([TcSigmaType], results) -- Resulting instaniation and args
913 tcArgs fun args qtvs qtys arg_tys
914 = go 1 qtys args arg_tys
916 go n qtys [] [] = return (qtys, [])
917 go n qtys (arg:args) (arg_ty:arg_tys)
918 = do { arg' <- tcArg fun n arg qtvs qtys arg_ty
919 ; qtys' <- mapM refineBox qtys -- Exploit new info
920 ; (qtys'', args') <- go (n+1) qtys' args arg_tys
921 ; return (qtys'', arg':args') }
922 go n qtys args arg_tys = panic "tcArgs"
924 tcArg :: LHsExpr Name -- The function
925 -> Int -- and arg number (for error messages)
927 -> [TyVar] -> [TcSigmaType] -- Instantiate the arg type like this
929 -> TcM (LHsExpr TcId) -- Resulting argument
930 tcArg fun arg_no arg qtvs qtys ty
931 = addErrCtxt (funAppCtxt fun arg arg_no) $
932 tcPolyExprNC arg (substTyWith qtvs qtys ty)
938 Nasty check to ensure that tagToEnum# is applied to a type that is an
939 enumeration TyCon. Unification may refine the type later, but this
940 check won't see that, alas. It's crude but it works.
942 Here's are two cases that should fail
944 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
947 g = tagToEnum# 0 -- Int is not an enumeration
951 doStupidChecks :: HsExpr TcId
952 -> [([TcType], ThetaType)]
954 -- Check two tiresome and ad-hoc cases
955 -- (a) the "stupid theta" for a data con; add the constraints
956 -- from the "stupid theta" of a data constructor (sigh)
957 -- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
959 doStupidChecks (HsVar fun_id) ((tys,_):_)
960 | Just con <- isDataConId_maybe fun_id -- (a)
961 = addDataConStupidTheta con tys
963 | fun_id `hasKey` tagToEnumKey -- (b)
964 = do { tys' <- zonkTcTypes tys
965 ; checkTc (ok tys') (tagToEnumError tys')
969 ok (ty:tys) = case tcSplitTyConApp_maybe ty of
970 Just (tc,_) -> isEnumerationTyCon tc
973 doStupidChecks fun tv_theta_prs
974 = return () -- The common case
978 = hang (ptext (sLit "Bad call to tagToEnum#") <+> at_type)
979 2 (vcat [ptext (sLit "Specify the type by giving a type signature"),
980 ptext (sLit "e.g. (tagToEnum# x) :: Bool")])
982 at_type | null tys = empty -- Probably never happens
983 | otherwise = ptext (sLit "at type") <+> ppr (head tys)
986 %************************************************************************
988 \subsection{@tcId@ typechecks an identifier occurrence}
990 %************************************************************************
993 lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType)
994 lookupFun orig id_name
995 = do { thing <- tcLookup id_name
997 AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id)
999 wrap_id = dataConWrapId con
1002 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
1003 | otherwise -> return (HsVar id, idType id)
1004 -- A global cannot possibly be ill-staged
1005 -- nor does it need the 'lifting' treatment
1007 ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
1008 -> do { thLocalId orig id ty lvl
1010 Unrefineable -> return (HsVar id, ty)
1011 Rigid co -> return (mkHsWrap co (HsVar id), ty)
1012 Wobbly -> traceTc (text "lookupFun" <+> ppr id) >> return (HsVar id, ty) -- Wobbly, or no free vars
1013 WobblyInvisible -> failWithTc (ppr id_name <+> ptext (sLit " not in scope because it has a wobbly type (solution: add a type annotation)"))
1016 other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected"))
1019 #ifndef GHCI /* GHCI and TH is off */
1020 --------------------------------------
1021 -- thLocalId : Check for cross-stage lifting
1022 thLocalId orig id id_ty th_bind_lvl
1025 #else /* GHCI and TH is on */
1026 thLocalId orig id id_ty th_bind_lvl
1027 = do { use_stage <- getStage -- TH case
1029 Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
1030 -> thBrackId orig id ps_var lie_var
1031 other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
1035 --------------------------------------
1036 thBrackId orig id ps_var lie_var
1038 = -- Top-level identifiers in this module,
1039 -- (which have External Names)
1040 -- are just like the imported case:
1041 -- no need for the 'lifting' treatment
1042 -- E.g. this is fine:
1045 -- But we do need to put f into the keep-alive
1046 -- set, because after desugaring the code will
1047 -- only mention f's *name*, not f itself.
1048 do { keepAliveTc id; return id }
1051 = -- Nested identifiers, such as 'x' in
1052 -- E.g. \x -> [| h x |]
1053 -- We must behave as if the reference to x was
1055 -- We use 'x' itself as the splice proxy, used by
1056 -- the desugarer to stitch it all back together.
1057 -- If 'x' occurs many times we may get many identical
1058 -- bindings of the same splice proxy, but that doesn't
1059 -- matter, although it's a mite untidy.
1060 do { let id_ty = idType id
1061 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1062 -- If x is polymorphic, its occurrence sites might
1063 -- have different instantiations, so we can't use plain
1064 -- 'x' as the splice proxy name. I don't know how to
1065 -- solve this, and it's probably unimportant, so I'm
1066 -- just going to flag an error for now
1068 ; id_ty' <- zapToMonotype id_ty
1069 -- The id_ty might have an OpenTypeKind, but we
1070 -- can't instantiate the Lift class at that kind,
1071 -- so we zap it to a LiftedTypeKind monotype
1072 -- C.f. the call in TcPat.newLitInst
1074 ; setLIEVar lie_var $ do
1075 { lift <- newMethodFromName orig id_ty' DsMeta.liftName
1076 -- Put the 'lift' constraint into the right LIE
1078 -- Update the pending splices
1079 ; ps <- readMutVar ps_var
1080 ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
1087 %************************************************************************
1089 \subsection{Record bindings}
1091 %************************************************************************
1093 Game plan for record bindings
1094 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1095 1. Find the TyCon for the bindings, from the first field label.
1097 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1099 For each binding field = value
1101 3. Instantiate the field type (from the field label) using the type
1104 4 Type check the value using tcArg, passing the field type as
1105 the expected argument type.
1107 This extends OK when the field types are universally quantified.
1113 -> [TcType] -- Expected type for each field
1114 -> HsRecordBinds Name
1115 -> TcM (HsRecordBinds TcId)
1117 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1118 = do { mb_binds <- mapM do_bind rbinds
1119 ; return (HsRecFields (catMaybes mb_binds) dd) }
1121 flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1122 do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
1123 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1124 = addErrCtxt (fieldCtxt field_lbl) $
1125 do { rhs' <- tcPolyExprNC rhs field_ty
1126 ; sel_id <- tcLookupField field_lbl
1127 ; ASSERT( isRecordSelector sel_id )
1128 return (Just (fld { hsRecFieldId = L loc sel_id, hsRecFieldArg = rhs' })) }
1130 = do { addErrTc (badFieldCon data_con field_lbl)
1133 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1134 checkMissingFields data_con rbinds
1135 | null field_labels -- Not declared as a record;
1136 -- But C{} is still valid if no strict fields
1137 = if any isMarkedStrict field_strs then
1138 -- Illegal if any arg is strict
1139 addErrTc (missingStrictFields data_con [])
1143 | otherwise = do -- A record
1144 unless (null missing_s_fields)
1145 (addErrTc (missingStrictFields data_con missing_s_fields))
1147 warn <- doptM Opt_WarnMissingFields
1148 unless (not (warn && notNull missing_ns_fields))
1149 (warnTc True (missingFields data_con missing_ns_fields))
1153 = [ fl | (fl, str) <- field_info,
1155 not (fl `elem` field_names_used)
1158 = [ fl | (fl, str) <- field_info,
1159 not (isMarkedStrict str),
1160 not (fl `elem` field_names_used)
1163 field_names_used = hsRecFields rbinds
1164 field_labels = dataConFieldLabels data_con
1166 field_info = zipEqual "missingFields"
1170 field_strs = dataConStrictMarks data_con
1173 %************************************************************************
1175 \subsection{Errors and contexts}
1177 %************************************************************************
1179 Boring and alphabetical:
1182 = hang (ptext (sLit "In the expression:")) 4 (ppr expr)
1184 fieldCtxt field_name
1185 = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1187 funAppCtxt fun arg arg_no
1188 = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1189 quotes (ppr fun) <> text ", namely"])
1190 4 (quotes (ppr arg))
1193 = vcat [ptext (sLit "Record update for the non-Haskell-98 data type")
1194 <+> quotes (pprSourceTyCon tycon)
1195 <+> ptext (sLit "is not (yet) supported"),
1196 ptext (sLit "Use pattern-matching instead")]
1198 = hang (ptext (sLit "No constructor has all these fields:"))
1199 4 (pprQuotedList (hsRecFields rbinds))
1201 naughtyRecordSel sel_id
1202 = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1203 ptext (sLit "as a function due to escaped type variables") $$
1204 ptext (sLit "Probably fix: use pattern-matching syntax instead")
1207 = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1209 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1210 missingStrictFields con fields
1213 rest | null fields = empty -- Happens for non-record constructors
1214 -- with strict fields
1215 | otherwise = colon <+> pprWithCommas ppr fields
1217 header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1218 ptext (sLit "does not have the required strict field(s)")
1220 missingFields :: DataCon -> [FieldLabel] -> SDoc
1221 missingFields con fields
1222 = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1223 <+> pprWithCommas ppr fields
1225 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1228 polySpliceErr :: Id -> SDoc
1230 = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)