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 (tcPolyExprNC expr)
89 -- Note the recursive call to tcPolyExpr, because the
90 -- type may have multiple layers of for-alls
91 -- E.g. forall a. Eq a => forall b. Ord b => ....
92 ; return (mkLHsWrap gen_fn expr') }
95 = tcMonoExprNC expr res_ty
98 tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
99 tcPolyExprs [] [] = return []
100 tcPolyExprs (expr:exprs) (ty:tys)
101 = do { expr' <- tcPolyExpr expr ty
102 ; exprs' <- tcPolyExprs exprs tys
103 ; return (expr':exprs') }
104 tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
107 tcMonoExpr, tcMonoExprNC
108 :: LHsExpr Name -- Expression to type check
109 -> BoxyRhoType -- Expected type (could be a type variable)
110 -- Definitely no foralls at the top
111 -- Can contain boxes, which will be filled in
112 -> TcM (LHsExpr TcId)
114 tcMonoExpr expr res_ty
115 = addErrCtxt (exprCtxt expr) $
116 tcMonoExprNC expr res_ty
118 tcMonoExprNC (L loc expr) res_ty
119 = ASSERT( not (isSigmaTy res_ty) )
121 do { expr' <- tcExpr expr res_ty
122 ; return (L loc expr') }
125 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
126 tcInferRho expr = tcInfer (tcMonoExpr expr)
127 tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
131 %************************************************************************
133 tcExpr: the main expression typechecker
135 %************************************************************************
138 tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
139 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
140 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
142 tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty
144 tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
145 ; coi <- boxyUnify lit_ty res_ty
146 ; return $ mkHsWrapCoI coi (HsLit lit)
149 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
150 ; return (HsPar expr') }
152 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
153 ; return (HsSCC lbl expr') }
154 tcExpr (HsTickPragma info expr) res_ty
155 = do { expr' <- tcMonoExpr expr res_ty
156 ; return (HsTickPragma info expr') }
158 tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
159 = do { expr' <- tcMonoExpr expr res_ty
160 ; return (HsCoreAnn lbl expr') }
162 tcExpr (HsOverLit lit) res_ty
163 = do { lit' <- tcOverloadedLit (LiteralOrigin lit) lit res_ty
164 ; return (HsOverLit lit') }
166 tcExpr (NegApp expr neg_expr) res_ty
167 = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
168 (mkFunTy res_ty res_ty)
169 ; expr' <- tcMonoExpr expr res_ty
170 ; return (NegApp expr' neg_expr') }
172 tcExpr (HsIPVar ip) res_ty
173 = do { let origin = IPOccOrigin ip
174 -- Implicit parameters must have a *tau-type* not a
175 -- type scheme. We enforce this by creating a fresh
176 -- type variable as its type. (Because res_ty may not
178 ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
179 ; co_fn <- tcSubExp origin ip_ty res_ty
180 ; (ip', inst) <- newIPDict origin ip ip_ty
182 ; return (mkHsWrap co_fn (HsIPVar ip')) }
184 tcExpr (HsApp e1 e2) res_ty
187 go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
188 go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
189 go lfun@(L loc fun) args
190 = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
191 tcApp fun (length args) (tcArgs lfun args) res_ty
192 ; traceTc (text "tcExpr args': " <+> ppr args')
193 ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
195 tcExpr (HsLam match) res_ty
196 = do { (co_fn, match') <- tcMatchLambda match res_ty
197 ; return (mkHsWrap co_fn (HsLam match')) }
199 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
200 = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
202 -- Remember to extend the lexical type-variable environment
203 ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $
206 ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
207 ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
209 tcExpr (HsType ty) res_ty
210 = failWithTc (text "Can't handle type argument:" <+> ppr ty)
211 -- This is the syntax for type applications that I was planning
212 -- but there are difficulties (e.g. what order for type args)
213 -- so it's not enabled yet.
214 -- Can't eliminate it altogether from the parser, because the
215 -- same parser parses *patterns*.
219 %************************************************************************
221 Infix operators and sections
223 %************************************************************************
226 tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
227 = do { (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty
228 ; return (OpApp arg1' (L loc op') fix arg2') }
230 -- Left sections, equivalent to
234 -- or, if PostfixOperators is enabled, just
237 -- With PostfixOperators we don't
238 -- actually require the function to take two arguments
239 -- at all. For example, (x `not`) means (not x);
240 -- you get postfix operators! Not Haskell 98,
241 -- but it's less work and kind of useful.
243 tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
244 = do dflags <- getDOpts
245 if dopt Opt_PostfixOperators dflags
246 then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
247 return (SectionL arg1' (L loc op'))
248 else do (co_fn, (op', arg1'))
249 <- subFunTys doc 1 res_ty Nothing
250 $ \ [arg2_ty'] res_ty' ->
251 tcApp op 2 (tc_args arg2_ty') res_ty'
252 return (mkHsWrap co_fn (SectionL arg1' (L loc op')))
254 doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
255 <+> ptext (sLit "takes one argument")
256 tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty]
257 = do { boxyUnify arg2_ty' (substTyWith qtvs qtys arg2_ty)
258 ; arg1' <- tcArg lop 2 arg1 qtvs qtys arg1_ty
259 ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
260 ; return (qtys', arg1') }
261 tc_args _ _ _ _ = panic "tcExpr SectionL"
263 -- Right sections, equivalent to \ x -> x `op` expr, or
266 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
267 = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
268 tcApp op 2 (tc_args arg1_ty') res_ty'
269 ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
271 doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
272 <+> ptext (sLit "takes one argument")
273 tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty]
274 = do { boxyUnify arg1_ty' (substTyWith qtvs qtys arg1_ty)
275 ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty
276 ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
277 ; return (qtys', arg2') }
278 tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
282 tcExpr (HsLet binds expr) res_ty
283 = do { (binds', expr') <- tcLocalBinds binds $
284 tcMonoExpr expr res_ty
285 ; return (HsLet binds' expr') }
287 tcExpr (HsCase scrut matches) exp_ty
288 = do { -- We used to typecheck the case alternatives first.
289 -- The case patterns tend to give good type info to use
290 -- when typechecking the scrutinee. For example
293 -- will report that map is applied to too few arguments
295 -- But now, in the GADT world, we need to typecheck the scrutinee
296 -- first, to get type info that may be refined in the case alternatives
297 (scrut', scrut_ty) <- tcInferRho scrut
299 ; traceTc (text "HsCase" <+> ppr scrut_ty)
300 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
301 ; return (HsCase scrut' matches') }
303 match_ctxt = MC { mc_what = CaseAlt,
306 tcExpr (HsIf pred b1 b2) res_ty
307 = do { pred' <- tcMonoExpr pred boolTy
308 ; b1' <- tcMonoExpr b1 res_ty
309 ; b2' <- tcMonoExpr b2 res_ty
310 ; return (HsIf pred' b1' b2') }
312 tcExpr (HsDo do_or_lc stmts body _) res_ty
313 = tcDoStmts do_or_lc stmts body res_ty
315 tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
316 = do { (elt_ty, coi) <- boxySplitListTy res_ty
317 ; exprs' <- mapM (tc_elt elt_ty) exprs
318 ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
320 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
322 tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
323 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
324 ; exprs' <- mapM (tc_elt elt_ty) exprs
325 ; when (null exprs) (zapToMonotype elt_ty >> return ())
326 -- If there are no expressions in the comprehension
327 -- we must still fill in the box
328 -- (Not needed for [] and () becuase they happen
329 -- to parse as data constructors.)
330 ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
332 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
334 -- For tuples, take care to preserve rigidity
335 -- E.g. case (x,y) of ....
336 -- The scrutinee should have a rigid type if x,y do
337 -- The general scheme is the same as in tcIdApp
338 tcExpr (ExplicitTuple exprs boxity) res_ty
339 = do { let kind = case boxity of { Boxed -> liftedTypeKind
340 ; Unboxed -> argTypeKind }
341 ; tvs <- newBoxyTyVars [kind | e <- exprs]
342 ; let tup_tc = tupleTyCon boxity (length exprs)
343 tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
344 ; checkWiredInTyCon tup_tc -- Ensure instances are available
345 ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
346 ; exprs' <- tcPolyExprs exprs arg_tys
347 ; arg_tys' <- mapM refineBox arg_tys
348 ; co_fn <- tcSubExp TupleOrigin (mkTyConApp tup_tc arg_tys') res_ty
349 ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
351 tcExpr (HsProc pat cmd) res_ty
352 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
353 ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
355 tcExpr e@(HsArrApp _ _ _ _ _) _
356 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
357 ptext (sLit "was found where an expression was expected")])
359 tcExpr e@(HsArrForm _ _ _) _
360 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
361 ptext (sLit "was found where an expression was expected")])
364 %************************************************************************
366 Record construction and update
368 %************************************************************************
371 tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
372 = do { data_con <- tcLookupDataCon con_name
374 -- Check for missing fields
375 ; checkMissingFields data_con rbinds
377 ; let arity = dataConSourceArity data_con
378 check_fields qtvs qtys arg_tys
379 = do { let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys
380 ; rbinds' <- tcRecordBinds data_con arg_tys' rbinds
381 ; qtys' <- mapM refineBoxToTau qtys
382 ; return (qtys', rbinds') }
383 -- The refineBoxToTau ensures that all the boxes in arg_tys are indeed
384 -- filled, which is the invariant expected by tcIdApp
385 -- How could this not be the case? Consider a record construction
386 -- that does not mention all the fields.
388 ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
390 ; return (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
392 -- The main complication with RecordUpd is that we need to explicitly
393 -- handle the *non-updated* fields. Consider:
395 -- data T a b = MkT1 { fa :: a, fb :: b }
396 -- | MkT2 { fa :: a, fc :: Int -> Int }
397 -- | MkT3 { fd :: a }
399 -- upd :: T a b -> c -> T a c
400 -- upd t x = t { fb = x}
402 -- The type signature on upd is correct (i.e. the result should not be (T a b))
403 -- because upd should be equivalent to:
405 -- upd t x = case t of
406 -- MkT1 p q -> MkT1 p x
407 -- MkT2 a b -> MkT2 p b
408 -- MkT3 d -> error ...
410 -- So we need to give a completely fresh type to the result record,
411 -- and then constrain it by the fields that are *not* updated ("p" above).
413 -- Note that because MkT3 doesn't contain all the fields being updated,
414 -- its RHS is simply an error, so it doesn't impose any type constraints
416 -- All this is done in STEP 4 below.
420 -- For record update we require that every constructor involved in the
421 -- update (i.e. that has all the specified fields) is "vanilla". I
422 -- don't know how to do the update otherwise.
425 tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty = do
427 -- Check that the field names are really field names
429 field_names = hsRecFields rbinds
431 MASSERT( notNull field_names )
432 sel_ids <- mapM tcLookupField field_names
433 -- The renamer has already checked that they
436 bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
437 | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
438 not (isRecordSelector sel_id), -- Excludes class ops
439 let L loc field_name = hsRecFieldId fld
442 unless (null bad_guys) (sequence bad_guys >> failM)
445 -- Figure out the tycon and data cons from the first field name
447 -- It's OK to use the non-tc splitters here (for a selector)
449 (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
450 data_cons = tyConDataCons tycon -- it's not a field label
451 -- NB: for a data type family, the tycon is the instance tycon
453 relevant_cons = filter is_relevant data_cons
454 is_relevant con = all (`elem` dataConFieldLabels con) field_names
457 -- Check that at least one constructor has all the named fields
458 -- i.e. has an empty set of bad fields returned by badFields
459 checkTc (not (null relevant_cons))
460 (badFieldsUpd rbinds)
462 -- Check that all relevant data cons are vanilla. Doing record updates on
463 -- GADTs and/or existentials is more than my tiny brain can cope with today
464 checkTc (all isVanillaDataCon relevant_cons)
465 (nonVanillaUpd tycon)
468 -- Use the un-updated fields to find a vector of booleans saying
469 -- which type arguments must be the same in updatee and result.
471 -- WARNING: this code assumes that all data_cons in a common tycon
472 -- have FieldLabels abstracted over the same tyvars.
474 -- A constructor is only relevant to this process if
475 -- it contains *all* the fields that are being updated
476 con1 = ASSERT( not (null relevant_cons) ) head relevant_cons -- A representative constructor
477 (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1
478 con1_flds = dataConFieldLabels con1
479 common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
480 , not (fld `elem` field_names) ]
482 is_common_tv tv = tv `elemVarSet` common_tyvars
484 mk_inst_ty tv result_inst_ty
485 | is_common_tv tv = return result_inst_ty -- Same as result type
486 | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
488 MASSERT( null theta ) -- Vanilla datacon
489 (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tyvars
490 scrut_inst_tys <- zipWithM mk_inst_ty con1_tyvars result_inst_tys
492 -- STEP 3: Typecheck the update bindings.
493 -- Do this after checking for bad fields in case
494 -- there's a field that doesn't match the constructor.
496 result_ty = substTy result_inst_env con1_res_ty
497 con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
498 origin = RecordUpdOrigin
500 co_fn <- tcSubExp origin result_ty res_ty
501 rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
503 -- STEP 5: Typecheck the expression to be updated
505 scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys
506 scrut_ty = substTy scrut_inst_env con1_res_ty
507 -- This is one place where the isVanilla check is important
508 -- So that inst_tys matches the con1_tyvars
510 record_expr' <- tcMonoExpr record_expr scrut_ty
512 -- STEP 6: Figure out the LIE we need.
513 -- We have to generate some dictionaries for the data type context,
514 -- since we are going to do pattern matching over the data cons.
516 -- What dictionaries do we need? The dataConStupidTheta tells us.
518 theta' = substTheta scrut_inst_env (dataConStupidTheta con1)
520 instStupidTheta origin theta'
522 -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
523 let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
524 = WpCast $ mkTyConApp co_con scrut_inst_tys
529 return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
530 relevant_cons scrut_inst_tys result_inst_tys))
534 %************************************************************************
536 Arithmetic sequences e.g. [a,b..]
537 and their parallel-array counterparts e.g. [: a,b.. :]
540 %************************************************************************
543 tcExpr (ArithSeq _ seq@(From expr)) res_ty
544 = do { (elt_ty, coi) <- boxySplitListTy res_ty
545 ; expr' <- tcPolyExpr expr elt_ty
546 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
548 ; return $ mkHsWrapCoI coi (ArithSeq (HsVar enum_from) (From expr')) }
550 tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
551 = do { (elt_ty, coi) <- boxySplitListTy res_ty
552 ; expr1' <- tcPolyExpr expr1 elt_ty
553 ; expr2' <- tcPolyExpr expr2 elt_ty
554 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
555 elt_ty enumFromThenName
556 ; return $ mkHsWrapCoI coi
557 (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
559 tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
560 = do { (elt_ty, coi) <- boxySplitListTy res_ty
561 ; expr1' <- tcPolyExpr expr1 elt_ty
562 ; expr2' <- tcPolyExpr expr2 elt_ty
563 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
564 elt_ty enumFromToName
565 ; return $ mkHsWrapCoI coi
566 (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
568 tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
569 = do { (elt_ty, coi) <- boxySplitListTy res_ty
570 ; expr1' <- tcPolyExpr expr1 elt_ty
571 ; expr2' <- tcPolyExpr expr2 elt_ty
572 ; expr3' <- tcPolyExpr expr3 elt_ty
573 ; eft <- newMethodFromName (ArithSeqOrigin seq)
574 elt_ty enumFromThenToName
575 ; return $ mkHsWrapCoI coi
576 (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
578 tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
579 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
580 ; expr1' <- tcPolyExpr expr1 elt_ty
581 ; expr2' <- tcPolyExpr expr2 elt_ty
582 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
583 elt_ty enumFromToPName
584 ; return $ mkHsWrapCoI coi
585 (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
587 tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
588 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
589 ; expr1' <- tcPolyExpr expr1 elt_ty
590 ; expr2' <- tcPolyExpr expr2 elt_ty
591 ; expr3' <- tcPolyExpr expr3 elt_ty
592 ; eft <- newMethodFromName (PArrSeqOrigin seq)
593 elt_ty enumFromThenToPName
594 ; return $ mkHsWrapCoI coi
595 (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
597 tcExpr (PArrSeq _ _) _
598 = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
599 -- the parser shouldn't have generated it and the renamer shouldn't have
604 %************************************************************************
608 %************************************************************************
611 #ifdef GHCI /* Only if bootstrapped */
612 -- Rename excludes these cases otherwise
613 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
614 tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
616 tcExpr e@(HsQuasiQuoteE _) res_ty =
617 pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
622 %************************************************************************
626 %************************************************************************
629 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
633 %************************************************************************
637 %************************************************************************
640 ---------------------------
641 tcApp :: HsExpr Name -- Function
642 -> Arity -- Number of args reqd
643 -> ArgChecker results
644 -> BoxyRhoType -- Result type
645 -> TcM (HsExpr TcId, results)
647 -- (tcFun fun n_args arg_checker res_ty)
648 -- The argument type checker, arg_checker, will be passed exactly n_args types
650 tcApp (HsVar fun_name) n_args arg_checker res_ty
651 = tcIdApp fun_name n_args arg_checker res_ty
653 tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP)
654 = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
655 ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
656 ; arg_tys' <- mapM readFilledBox arg_boxes
657 ; (_, args') <- arg_checker [] [] arg_tys' -- Yuk
658 ; return (fun', args') }
660 ---------------------------
661 tcIdApp :: Name -- Function
662 -> Arity -- Number of args reqd
663 -> ArgChecker results -- The arg-checker guarantees to fill all boxes in the arg types
664 -> BoxyRhoType -- Result type
665 -> TcM (HsExpr TcId, results)
667 -- Call (f e1 ... en) :: res_ty
668 -- Type f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
669 -- (where k <= n; fres has the rest)
670 -- NB: if k < n then the function doesn't have enough args, and
671 -- presumably fres is a type variable that we are going to
672 -- instantiate with a function type
674 -- Then fres <= bx_(k+1) -> ... -> bx_n -> res_ty
676 tcIdApp fun_name n_args arg_checker res_ty
677 = do { let orig = OccurrenceOf fun_name
678 ; (fun, fun_ty) <- lookupFun orig fun_name
680 -- Split up the function type
681 ; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty
682 (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
684 qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
685 arg_qtvs = exactTyVarsOfTypes fun_arg_tys
686 res_qtvs = exactTyVarsOfType fun_res_ty
687 -- NB: exactTyVarsOfType. See Note [Silly type synonyms in smart-app]
688 tau_qtvs = arg_qtvs `unionVarSet` res_qtvs
689 k = length fun_arg_tys -- k <= n_args
690 n_missing_args = n_args - k -- Always >= 0
692 -- Match the result type of the function with the
693 -- result type of the context, to get an inital substitution
694 ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
695 ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
696 res_ty' = mkFunTys extra_arg_tys' res_ty
697 ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
699 -- Typecheck the arguments!
700 -- Doing so will fill arg_qtvs and extra_arg_tys'
701 ; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys')
703 -- Strip boxes from the qtvs that have been filled in by the arg checking
704 ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
706 -- Result subsumption
707 -- This fills in res_qtvs
708 ; let res_subst = zipOpenTvSubst qtvs qtys''
709 fun_res_ty'' = substTy res_subst fun_res_ty
710 res_ty'' = mkFunTys extra_arg_tys'' res_ty
711 ; co_fn <- tcSubExp orig fun_res_ty'' res_ty''
713 -- And pack up the results
714 -- By applying the coercion just to the *function* we can make
715 -- tcFun work nicely for OpApp and Sections too
716 ; fun' <- instFun orig fun res_subst tv_theta_prs
717 ; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn
718 ; traceTc (text "tcIdApp: " <+> ppr (mkHsWrap co_fn' fun') <+> ppr tv_theta_prs <+> ppr co_fn' <+> ppr fun')
719 ; return (mkHsWrap co_fn' fun', args') }
722 Note [Silly type synonyms in smart-app]
723 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
724 When we call sripBoxyType, all of the boxes should be filled
725 in. But we need to be careful about type synonyms:
729 In the call (f x) we'll typecheck x, expecting it to have type
730 (T box). Usually that would fill in the box, but in this case not;
731 because 'a' is discarded by the silly type synonym T. So we must
732 use exactTyVarsOfType to figure out which type variables are free
733 in the argument type.
736 -- tcId is a specialisation of tcIdApp when there are no arguments
737 -- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty
742 -> BoxyRhoType -- Result type
744 tcId orig fun_name res_ty
745 = do { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
746 ; (fun, fun_ty) <- lookupFun orig fun_name
748 -- Split up the function type
749 ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
750 qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
751 tau_qtvs = exactTyVarsOfType fun_tau -- Mentioned in the tau part
752 ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
754 -- Do the subsumption check wrt the result type
755 ; let res_subst = zipTopTvSubst qtvs qtv_tys
756 fun_tau' = substTy res_subst fun_tau
758 ; co_fn <- tcSubExp orig fun_tau' res_ty
760 -- And pack up the results
761 ; fun' <- instFun orig fun res_subst tv_theta_prs
762 ; traceTc (text "tcId yields" <+> ppr (mkHsWrap co_fn fun'))
763 ; return (mkHsWrap co_fn fun') }
765 -- Note [Push result type in]
767 -- Unify with expected result before (was: after) type-checking the args
768 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
769 -- This is when we might detect a too-few args situation.
770 -- (One can think of cases when the opposite order would give
771 -- a better error message.)
772 -- [March 2003: I'm experimenting with putting this first. Here's an
773 -- example where it actually makes a real difference
774 -- class C t a b | t a -> b
775 -- instance C Char a Bool
777 -- data P t a = forall b. (C t a b) => MkP b
778 -- data Q t = MkQ (forall a. P t a)
781 -- f1 = MkQ (MkP True)
782 -- f2 = MkQ (MkP True :: forall a. P Char a)
784 -- With the change, f1 will type-check, because the 'Char' info from
785 -- the signature is propagated into MkQ's argument. With the check
786 -- in the other order, the extra signature in f2 is reqd.]
788 ---------------------------
789 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
790 -- Typecheck a syntax operator, checking that it has the specified type
791 -- The operator is always a variable at this stage (i.e. renamer output)
792 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
793 tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
795 ---------------------------
796 instFun :: InstOrigin
798 -> TvSubst -- The instantiating substitution
799 -> [([TyVar], ThetaType)] -- Stuff to instantiate
802 instFun orig fun subst []
803 = return fun -- Common short cut
805 instFun orig fun subst tv_theta_prs
806 = do { let ty_theta_prs' = map subst_pr tv_theta_prs
807 ; traceTc (text "instFun" <+> ppr ty_theta_prs')
808 -- Make two ad-hoc checks
809 ; doStupidChecks fun ty_theta_prs'
811 -- Now do normal instantiation
812 ; method_sharing <- doptM Opt_MethodSharing
813 ; result <- go method_sharing True fun ty_theta_prs'
814 ; traceTc (text "instFun result" <+> ppr result)
818 subst_pr (tvs, theta)
819 = (substTyVars subst tvs, substTheta subst theta)
821 go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun }
823 go method_sharing True (HsVar fun_id) ((tys,theta) : prs)
824 | want_method_inst method_sharing theta
825 = do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta")
826 ; meth_id <- newMethodWithGivenTy orig fun_id tys
827 ; go method_sharing False (HsVar meth_id) prs }
828 -- Go round with 'False' to prevent further use
829 -- of newMethod: see Note [Multiple instantiation]
831 go method_sharing _ fun ((tys, theta) : prs)
832 = do { co_fn <- instCall orig tys theta
833 ; traceTc (text "go yields co_fn" <+> ppr co_fn)
834 ; go method_sharing False (HsWrap co_fn fun) prs }
836 -- See Note [No method sharing]
837 want_method_inst method_sharing theta = not (null theta) -- Overloaded
841 Note [Multiple instantiation]
842 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
843 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
844 For example, consider
845 f :: forall a. Eq a => forall b. Ord b => a -> b
846 At a call to f, at say [Int, Bool], it's tempting to translate the call to
850 f_m1 :: forall b. Ord b => Int -> b
854 f_m2 = f_m1 Bool dOrdBool
856 But notice that f_m2 has f_m1 as its meth_id. Now the danger is that if we do
857 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
859 But it's entirely possible that f_m2 will continue to float out, because it
860 mentions no type variables. Result, f_m1 isn't in scope.
862 Here's a concrete example that does this (test tc200):
865 f :: Eq b => b -> a -> Int
866 baz :: Eq a => Int -> a -> Int
871 Current solution: only do the "method sharing" thing for the first type/dict
872 application, not for the iterated ones. A horribly subtle point.
874 Note [No method sharing]
875 ~~~~~~~~~~~~~~~~~~~~~~~~
876 The -fno-method-sharing flag controls what happens so far as the LIE
877 is concerned. The default case is that for an overloaded function we
878 generate a "method" Id, and add the Method Inst to the LIE. So you get
881 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
882 If you specify -fno-method-sharing, the dictionary application
883 isn't shared, so we get
885 f = /\a (d:Num a) (x:a) -> (+) a d x x
886 This gets a bit less sharing, but
887 a) it's better for RULEs involving overloaded functions
888 b) perhaps fewer separated lambdas
892 tcArgs implements a left-to-right order, which goes beyond what is described in the
893 impredicative type inference paper. In particular, it allows
895 where runST :: (forall s. ST s a) -> a
896 When typechecking the application of ($)::(a->b) -> a -> b, we first check that
897 runST has type (a->b), thereby filling in a=forall s. ST s a. Then we un-box this type
898 before checking foo. The left-to-right order really helps here.
901 tcArgs :: LHsExpr Name -- The function (for error messages)
902 -> [LHsExpr Name] -- Actual args
903 -> ArgChecker [LHsExpr TcId]
905 type ArgChecker results
906 = [TyVar] -> [TcSigmaType] -- Current instantiation
907 -> [TcSigmaType] -- Expected arg types (**before** applying the instantiation)
908 -> TcM ([TcSigmaType], results) -- Resulting instaniation and args
910 tcArgs fun args qtvs qtys arg_tys
911 = go 1 qtys args arg_tys
913 go n qtys [] [] = return (qtys, [])
914 go n qtys (arg:args) (arg_ty:arg_tys)
915 = do { arg' <- tcArg fun n arg qtvs qtys arg_ty
916 ; qtys' <- mapM refineBox qtys -- Exploit new info
917 ; (qtys'', args') <- go (n+1) qtys' args arg_tys
918 ; return (qtys'', arg':args') }
919 go n qtys args arg_tys = panic "tcArgs"
921 tcArg :: LHsExpr Name -- The function
922 -> Int -- and arg number (for error messages)
924 -> [TyVar] -> [TcSigmaType] -- Instantiate the arg type like this
926 -> TcM (LHsExpr TcId) -- Resulting argument
927 tcArg fun arg_no arg qtvs qtys ty
928 = addErrCtxt (funAppCtxt fun arg arg_no) $
929 tcPolyExprNC arg (substTyWith qtvs qtys ty)
935 Nasty check to ensure that tagToEnum# is applied to a type that is an
936 enumeration TyCon. Unification may refine the type later, but this
937 check won't see that, alas. It's crude but it works.
939 Here's are two cases that should fail
941 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
944 g = tagToEnum# 0 -- Int is not an enumeration
948 doStupidChecks :: HsExpr TcId
949 -> [([TcType], ThetaType)]
951 -- Check two tiresome and ad-hoc cases
952 -- (a) the "stupid theta" for a data con; add the constraints
953 -- from the "stupid theta" of a data constructor (sigh)
954 -- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
956 doStupidChecks (HsVar fun_id) ((tys,_):_)
957 | Just con <- isDataConId_maybe fun_id -- (a)
958 = addDataConStupidTheta con tys
960 | fun_id `hasKey` tagToEnumKey -- (b)
961 = do { tys' <- zonkTcTypes tys
962 ; checkTc (ok tys') (tagToEnumError tys')
966 ok (ty:tys) = case tcSplitTyConApp_maybe ty of
967 Just (tc,_) -> isEnumerationTyCon tc
970 doStupidChecks fun tv_theta_prs
971 = return () -- The common case
975 = hang (ptext (sLit "Bad call to tagToEnum#") <+> at_type)
976 2 (vcat [ptext (sLit "Specify the type by giving a type signature"),
977 ptext (sLit "e.g. (tagToEnum# x) :: Bool")])
979 at_type | null tys = empty -- Probably never happens
980 | otherwise = ptext (sLit "at type") <+> ppr (head tys)
983 %************************************************************************
985 \subsection{@tcId@ typechecks an identifier occurrence}
987 %************************************************************************
990 lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType)
991 lookupFun orig id_name
992 = do { thing <- tcLookup id_name
994 AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id)
996 wrap_id = dataConWrapId con
999 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
1000 | otherwise -> return (HsVar id, idType id)
1001 -- A global cannot possibly be ill-staged
1002 -- nor does it need the 'lifting' treatment
1004 ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
1005 -> do { thLocalId orig id ty lvl
1007 Unrefineable -> return (HsVar id, ty)
1008 Rigid co -> return (mkHsWrap co (HsVar id), ty)
1009 Wobbly -> traceTc (text "lookupFun" <+> ppr id) >> return (HsVar id, ty) -- Wobbly, or no free vars
1010 WobblyInvisible -> failWithTc (ppr id_name <+> ptext (sLit " not in scope because it has a wobbly type (solution: add a type annotation)"))
1013 other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected"))
1016 #ifndef GHCI /* GHCI and TH is off */
1017 --------------------------------------
1018 -- thLocalId : Check for cross-stage lifting
1019 thLocalId orig id id_ty th_bind_lvl
1022 #else /* GHCI and TH is on */
1023 thLocalId orig id id_ty th_bind_lvl
1024 = do { use_stage <- getStage -- TH case
1026 Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
1027 -> thBrackId orig id ps_var lie_var
1028 other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
1032 --------------------------------------
1033 thBrackId orig id ps_var lie_var
1035 = -- Top-level identifiers in this module,
1036 -- (which have External Names)
1037 -- are just like the imported case:
1038 -- no need for the 'lifting' treatment
1039 -- E.g. this is fine:
1042 -- But we do need to put f into the keep-alive
1043 -- set, because after desugaring the code will
1044 -- only mention f's *name*, not f itself.
1045 do { keepAliveTc id; return id }
1048 = -- Nested identifiers, such as 'x' in
1049 -- E.g. \x -> [| h x |]
1050 -- We must behave as if the reference to x was
1052 -- We use 'x' itself as the splice proxy, used by
1053 -- the desugarer to stitch it all back together.
1054 -- If 'x' occurs many times we may get many identical
1055 -- bindings of the same splice proxy, but that doesn't
1056 -- matter, although it's a mite untidy.
1057 do { let id_ty = idType id
1058 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1059 -- If x is polymorphic, its occurrence sites might
1060 -- have different instantiations, so we can't use plain
1061 -- 'x' as the splice proxy name. I don't know how to
1062 -- solve this, and it's probably unimportant, so I'm
1063 -- just going to flag an error for now
1065 ; id_ty' <- zapToMonotype id_ty
1066 -- The id_ty might have an OpenTypeKind, but we
1067 -- can't instantiate the Lift class at that kind,
1068 -- so we zap it to a LiftedTypeKind monotype
1069 -- C.f. the call in TcPat.newLitInst
1071 ; setLIEVar lie_var $ do
1072 { lift <- newMethodFromName orig id_ty' DsMeta.liftName
1073 -- Put the 'lift' constraint into the right LIE
1075 -- Update the pending splices
1076 ; ps <- readMutVar ps_var
1077 ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
1084 %************************************************************************
1086 \subsection{Record bindings}
1088 %************************************************************************
1090 Game plan for record bindings
1091 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1092 1. Find the TyCon for the bindings, from the first field label.
1094 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1096 For each binding field = value
1098 3. Instantiate the field type (from the field label) using the type
1101 4 Type check the value using tcArg, passing the field type as
1102 the expected argument type.
1104 This extends OK when the field types are universally quantified.
1110 -> [TcType] -- Expected type for each field
1111 -> HsRecordBinds Name
1112 -> TcM (HsRecordBinds TcId)
1114 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1115 = do { mb_binds <- mapM do_bind rbinds
1116 ; return (HsRecFields (catMaybes mb_binds) dd) }
1118 flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1119 do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
1120 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1121 = addErrCtxt (fieldCtxt field_lbl) $
1122 do { rhs' <- tcPolyExprNC rhs field_ty
1123 ; sel_id <- tcLookupField field_lbl
1124 ; ASSERT( isRecordSelector sel_id )
1125 return (Just (fld { hsRecFieldId = L loc sel_id, hsRecFieldArg = rhs' })) }
1127 = do { addErrTc (badFieldCon data_con field_lbl)
1130 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1131 checkMissingFields data_con rbinds
1132 | null field_labels -- Not declared as a record;
1133 -- But C{} is still valid if no strict fields
1134 = if any isMarkedStrict field_strs then
1135 -- Illegal if any arg is strict
1136 addErrTc (missingStrictFields data_con [])
1140 | otherwise = do -- A record
1141 unless (null missing_s_fields)
1142 (addErrTc (missingStrictFields data_con missing_s_fields))
1144 warn <- doptM Opt_WarnMissingFields
1145 unless (not (warn && notNull missing_ns_fields))
1146 (warnTc True (missingFields data_con missing_ns_fields))
1150 = [ fl | (fl, str) <- field_info,
1152 not (fl `elem` field_names_used)
1155 = [ fl | (fl, str) <- field_info,
1156 not (isMarkedStrict str),
1157 not (fl `elem` field_names_used)
1160 field_names_used = hsRecFields rbinds
1161 field_labels = dataConFieldLabels data_con
1163 field_info = zipEqual "missingFields"
1167 field_strs = dataConStrictMarks data_con
1170 %************************************************************************
1172 \subsection{Errors and contexts}
1174 %************************************************************************
1176 Boring and alphabetical:
1179 = hang (ptext (sLit "In the expression:")) 4 (ppr expr)
1181 fieldCtxt field_name
1182 = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1184 funAppCtxt fun arg arg_no
1185 = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1186 quotes (ppr fun) <> text ", namely"])
1187 4 (quotes (ppr arg))
1190 = vcat [ptext (sLit "Record update for the non-Haskell-98 data type")
1191 <+> quotes (pprSourceTyCon tycon)
1192 <+> ptext (sLit "is not (yet) supported"),
1193 ptext (sLit "Use pattern-matching instead")]
1195 = hang (ptext (sLit "No constructor has all these fields:"))
1196 4 (pprQuotedList (hsRecFields rbinds))
1198 naughtyRecordSel sel_id
1199 = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1200 ptext (sLit "as a function due to escaped type variables") $$
1201 ptext (sLit "Probably fix: use pattern-matching syntax instead")
1204 = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1206 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1207 missingStrictFields con fields
1210 rest | null fields = empty -- Happens for non-record constructors
1211 -- with strict fields
1212 | otherwise = colon <+> pprWithCommas ppr fields
1214 header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1215 ptext (sLit "does not have the required strict field(s)")
1217 missingFields :: DataCon -> [FieldLabel] -> SDoc
1218 missingFields con fields
1219 = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1220 <+> pprWithCommas ppr fields
1222 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1225 polySpliceErr :: Id -> SDoc
1227 = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)