TcExpr.lhs 38.1 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
%
4
\section[TcExpr]{Typecheck an expression}
5 6

\begin{code}
7
module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where
8

9
#include "HsVersions.h"
10

11
#ifdef GHCI 	/* Only if bootstrapped */
12
import {-# SOURCE #-}	TcSplice( tcSpliceExpr, tcBracket )
13
import HsSyn		( HsReify(..), ReifyFlavour(..) )
chak's avatar
chak committed
14
import TcType		( isTauTy )
15
import TcEnv		( bracketOK, tcMetaTy, checkWellStaged, metaLevel )
16
import Name		( isExternalName )
17
import qualified DsMeta
18 19
#endif

20
import HsSyn		( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields )
21
import RnHsSyn		( RenamedHsExpr, RenamedRecordBinds )
22 23
import TcHsSyn		( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet )
import TcRnMonad
24
import TcUnify		( tcSubExp, tcGen, (<$>),
chak's avatar
chak committed
25 26
			  unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy,
			  unifyTupleTy )
27
import BasicTypes	( isMarkedStrict )
28
import Inst		( InstOrigin(..), 
29
			  newOverloadedLit, newMethodFromName, newIPDict,
30
			  newDicts, newMethodWithGivenTy, 
31
			  instToId, tcInstCall, tcInstDataCon
32
			)
33
import TcBinds		( tcBindsAndThen )
34
import TcEnv		( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
35
			  tcLookupTyCon, tcLookupDataCon, tcLookupId
36
			)
37
import TcMatches	( tcMatchesCase, tcMatchLambda, tcDoStmts )
38 39
import TcMonoType	( tcHsSigType, UserTypeCtxt(..) )
import TcPat		( badFieldCon )
40 41 42
import TcMType		( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType,
			  newTyVarTy, newTyVarTys, zonkTcType, readHoleResult )
import TcType		( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
43
			  tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
44
			  isSigmaTy, mkFunTy, mkFunTys,
45
			  mkTyConApp, mkClassPred, tcFunArgTy,
46
			  tyVarsOfTypes, isLinearPred,
47
			  liftedTypeKind, openTypeKind, 
48 49 50
			  tcSplitSigmaTy, tcTyConAppTyCon,
			  tidyOpenType
			)
51
import FieldLabel	( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
52 53
import Id		( Id, idType, recordSelectorFieldLabel, isRecordSelector )
import DataCon		( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId )
54
import Name		( Name )
55
import TyCon		( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons, isClassTyCon )
56
import Subst		( mkTopTyVarSubst, substTheta, substTy )
57
import VarSet		( emptyVarSet, elemVarSet )
58
import TysWiredIn	( boolTy )
59
import PrelNames	( cCallableClassName, cReturnableClassName, 
60
			  enumFromName, enumFromThenName, 
61
			  enumFromToName, enumFromThenToName,
chak's avatar
chak committed
62
			  enumFromToPName, enumFromThenToPName,
63
			  ioTyConName
64
			)
sof's avatar
sof committed
65
import ListSetOps	( minusList )
66
import CmdLineOpts
67
import HscTypes		( TyThing(..) )
sof's avatar
sof committed
68

69 70 71
import Util
import Outputable
import FastString
72
\end{code}
73

sof's avatar
sof committed
74 75 76 77 78 79
%************************************************************************
%*									*
\subsection{Main wrappers}
%*									*
%************************************************************************

80
\begin{code}
81 82
tcExpr :: RenamedHsExpr		-- Expession to type check
	-> TcSigmaType 		-- Expected type (could be a polytpye)
83
	-> TcM TcExpr		-- Generalised expr with expected type
sof's avatar
sof committed
84

85
tcExpr expr expected_ty 
86
  = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_`
87 88 89
    tc_expr' expr expected_ty

tc_expr' expr expected_ty
90 91
  | not (isSigmaTy expected_ty)  -- Monomorphic case
  = tcMonoExpr expr expected_ty
sof's avatar
sof committed
92

93
  | otherwise
94 95
  = tcGen expected_ty emptyVarSet (
	tcMonoExpr expr
96 97
    )				`thenM` \ (gen_fn, expr') ->
    returnM (gen_fn <$> expr')
sof's avatar
sof committed
98 99 100 101 102
\end{code}


%************************************************************************
%*									*
103
\subsection{The TAUT rules for variables}
sof's avatar
sof committed
104 105 106 107
%*									*
%************************************************************************

\begin{code}
108
tcMonoExpr :: RenamedHsExpr		-- Expession to type check
109
	   -> TcRhoType 		-- Expected type (could be a type variable)
110 111
					-- Definitely no foralls at the top
					-- Can be a 'hole'.
112
	   -> TcM TcExpr
113

114
tcMonoExpr (HsVar name) res_ty
115 116 117
  = tcId name			`thenM` \ (expr', id_ty) ->
    tcSubExp res_ty id_ty 	`thenM` \ co_fn ->
    returnM (co_fn <$> expr')
118 119 120 121 122 123

tcMonoExpr (HsIPVar ip) res_ty
  = 	-- Implicit parameters must have a *tau-type* not a 
	-- type scheme.  We enforce this by creating a fresh
	-- type variable as its type.  (Because res_ty may not
	-- be a tau-type.)
124 125 126 127 128
    newTyVarTy openTypeKind		`thenM` \ ip_ty ->
    newIPDict (IPOcc ip) ip ip_ty 	`thenM` \ (ip', inst) ->
    extendLIE inst			`thenM_`
    tcSubExp res_ty ip_ty		`thenM` \ co_fn ->
    returnM (co_fn <$> HsIPVar ip')
129 130
\end{code}

131

132 133
%************************************************************************
%*									*
134
\subsection{Expressions type signatures}
135 136 137 138
%*									*
%************************************************************************

\begin{code}
139
tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
140 141 142
 = addErrCtxt (exprSigCtxt in_expr)	$
   tcHsSigType ExprSigCtxt poly_ty	`thenM` \ sig_tc_ty ->
   tcExpr expr sig_tc_ty		`thenM` \ expr' ->
143 144 145 146

	-- 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
147 148
   tcInstCall SignatureOrigin sig_tc_ty	`thenM` \ (inst_fn, inst_sig_ty) ->
   tcSubExp res_ty inst_sig_ty		`thenM` \ co_fn ->
149

150
   returnM (co_fn <$> inst_fn expr')
151 152 153 154 155 156 157 158

tcMonoExpr (HsType ty) res_ty
  = failWithTc (text "Can't handle type argument:" <+> ppr ty)
	-- This is the syntax for type applications that I was planning
	-- but there are difficulties (e.g. what order for type args)
	-- so it's not enabled yet.
	-- Can't eliminate it altogether from the parser, because the
	-- same parser parses *patterns*.
159 160
\end{code}

161

162 163 164 165 166 167 168
%************************************************************************
%*									*
\subsection{Other expression forms}
%*									*
%************************************************************************

\begin{code}
169 170 171 172 173 174 175
tcMonoExpr (HsLit lit)     res_ty  = tcLit lit res_ty
tcMonoExpr (HsOverLit lit) res_ty  = newOverloadedLit (LiteralOrigin lit) lit res_ty
tcMonoExpr (HsPar expr)    res_ty  = tcMonoExpr expr res_ty	`thenM` \ expr' -> 
				     returnM (HsPar expr')
tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty	`thenM` \ expr' ->
				     returnM (HsSCC lbl expr')

176 177
tcMonoExpr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->  -- hdaume: core annotation
                                         returnM (HsCoreAnn lbl expr')
178 179
tcMonoExpr (NegApp expr neg_name) res_ty
  = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty
180
	-- ToDo: use tcSyntaxName
181

sof's avatar
sof committed
182
tcMonoExpr (HsLam match) res_ty
183 184
  = tcMatchLambda match res_ty 		`thenM` \ match' ->
    returnM (HsLam match')
185

186 187
tcMonoExpr (HsApp e1 e2) res_ty 
  = tcApp e1 [e2] res_ty
188 189 190 191 192 193
\end{code}

Note that the operators in sections are expected to be binary, and
a type error will occur if they aren't.

\begin{code}
194 195
-- Left sections, equivalent to
--	\ x -> e op x,
196
-- or
197
--	\ x -> op e x,
198 199 200
-- or just
-- 	op e

201
tcMonoExpr in_expr@(SectionL arg1 op) res_ty
202 203 204 205 206 207
  = tcExpr_id op				`thenM` \ (op', op_ty) ->
    split_fun_ty op_ty 2 {- two args -}		`thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
    tcArg op (arg1, arg1_ty, 1)			`thenM` \ arg1' ->
    addErrCtxt (exprCtxt in_expr)		$
    tcSubExp res_ty (mkFunTy arg2_ty op_res_ty)	`thenM` \ co_fn ->
    returnM (co_fn <$> SectionL arg1' op')
208 209

-- Right sections, equivalent to \ x -> x op expr, or
210 211
--	\ x -> op x expr

212
tcMonoExpr in_expr@(SectionR op arg2) res_ty
213 214 215 216 217 218
  = tcExpr_id op				`thenM` \ (op', op_ty) ->
    split_fun_ty op_ty 2 {- two args -}		`thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
    tcArg op (arg2, arg2_ty, 2)			`thenM` \ arg2' ->
    addErrCtxt (exprCtxt in_expr)		$
    tcSubExp res_ty (mkFunTy arg1_ty op_res_ty)	`thenM` \ co_fn ->
    returnM (co_fn <$> SectionR op' arg2')
219 220 221 222

-- equivalent to (op e1) e2:

tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty
223 224 225 226 227 228 229
  = tcExpr_id op				`thenM` \ (op', op_ty) ->
    split_fun_ty op_ty 2 {- two args -}		`thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
    tcArg op (arg1, arg1_ty, 1)			`thenM` \ arg1' ->
    tcArg op (arg2, arg2_ty, 2)			`thenM` \ arg2' ->
    addErrCtxt (exprCtxt in_expr)		$
    tcSubExp res_ty op_res_ty			`thenM` \ co_fn ->
    returnM (OpApp arg1' op' fix arg2')
230 231 232
\end{code}

\begin{code}
sof's avatar
sof committed
233
tcMonoExpr (HsLet binds expr) res_ty
234
  = tcBindsAndThen
235
	HsLet
236
	binds 			-- Bindings to check
237
	(tcMonoExpr expr res_ty)
238

sof's avatar
sof committed
239
tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
240 241
  = addSrcLoc src_loc			$
    addErrCtxt (caseCtxt in_expr)	$
242 243 244 245 246 247 248

	-- Typecheck the case alternatives first.
	-- The case patterns tend to give good type info to use
	-- when typechecking the scrutinee.  For example
	--	case (map f) of
	--	  (x:xs) -> ...
	-- will report that map is applied to too few arguments
249 250 251 252 253 254 255 256
	--
	-- Not only that, but it's better to check the matches on their
	-- own, so that we get the expected results for scoped type variables.
	--	f x = case x of
	--		(p::a, q::b) -> (q,p)
	-- The above should work: the match (p,q) -> (q,p) is polymorphic as
	-- claimed by the pattern signatures.  But if we typechecked the
	-- match with x in scope and x's type as the expected type, we'd be hosed.
257

258
    tcMatchesCase matches res_ty	`thenM`    \ (scrut_ty, matches') ->
259

260
    addErrCtxt (caseScrutCtxt scrut)	(
sof's avatar
sof committed
261
      tcMonoExpr scrut scrut_ty
262
    )					`thenM`    \ scrut' ->
263

264
    returnM (HsCase scrut' matches' src_loc)
265

sof's avatar
sof committed
266
tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
267 268 269
  = addSrcLoc src_loc	$
    addErrCtxt (predCtxt pred) (
    tcMonoExpr pred boolTy	)	`thenM`    \ pred' ->
270

271
    zapToType res_ty			`thenM`    \ res_ty' ->
272 273
	-- C.f. the call to zapToType in TcMatches.tcMatches

274 275 276
    tcMonoExpr b1 res_ty'		`thenM`    \ b1' ->
    tcMonoExpr b2 res_ty'		`thenM`    \ b2' ->
    returnM (HsIf pred' b1' b2' src_loc)
277

278 279 280 281
tcMonoExpr (HsDo do_or_lc stmts method_names _ src_loc) res_ty
  = addSrcLoc src_loc		$
    tcDoStmts do_or_lc stmts method_names res_ty	`thenM` \ (binds, stmts', methods') ->
    returnM (mkHsLet binds (HsDo do_or_lc stmts' methods' res_ty src_loc))
282

283
tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty	-- Non-empty list
284 285 286
  = unifyListTy res_ty                `thenM` \ elt_ty ->  
    mappM (tc_elt elt_ty) exprs	      `thenM` \ exprs' ->
    returnM (ExplicitList elt_ty exprs')
sof's avatar
sof committed
287 288
  where
    tc_elt elt_ty expr
289
      = addErrCtxt (listCtxt expr) $
sof's avatar
sof committed
290
	tcMonoExpr expr elt_ty
sof's avatar
sof committed
291

chak's avatar
chak committed
292
tcMonoExpr in_expr@(ExplicitPArr _ exprs) res_ty	-- maybe empty
293 294 295
  = unifyPArrTy res_ty                `thenM` \ elt_ty ->  
    mappM (tc_elt elt_ty) exprs	      `thenM` \ exprs' ->
    returnM (ExplicitPArr elt_ty exprs')
chak's avatar
chak committed
296 297
  where
    tc_elt elt_ty expr
298
      = addErrCtxt (parrCtxt expr) $
chak's avatar
chak committed
299 300
	tcMonoExpr expr elt_ty

301
tcMonoExpr (ExplicitTuple exprs boxity) res_ty
302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
  = unifyTupleTy boxity (length exprs) res_ty	`thenM` \ arg_tys ->
    tcMonoExprs exprs arg_tys 			`thenM` \ exprs' ->
    returnM (ExplicitTuple exprs' boxity)
\end{code}


%************************************************************************
%*									*
		Foreign calls
%*									*
%************************************************************************

The interesting thing about @ccall@ is that it is just a template
which we instantiate by filling in details about the types of its
argument and result (ie minimal typechecking is performed).  So, the
basic story is that we allocate a load of type variables (to hold the
arg/result types); unify them with the args/result; and store them for
later use.

\begin{code}
tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty

  = getDOpts				`thenM` \ dflags ->
sof's avatar
sof committed
325

326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377
    checkTc (not (is_casm && dopt_HscLang dflags /= HscC)) 
        (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).",
               text "Either compile with -fvia-C, or, better, rewrite your code",
               text "to use the foreign function interface.  _casm_s are deprecated",
               text "and support for them may one day disappear."])
					`thenM_`

    -- Get the callable and returnable classes.
    tcLookupClass cCallableClassName	`thenM` \ cCallableClass ->
    tcLookupClass cReturnableClassName	`thenM` \ cReturnableClass ->
    tcLookupTyCon ioTyConName		`thenM` \ ioTyCon ->
    let
	new_arg_dict (arg, arg_ty)
	  = newDicts (CCallOrigin (unpackFS lbl) (Just arg))
		     [mkClassPred cCallableClass [arg_ty]]	`thenM` \ arg_dicts ->
	    returnM arg_dicts	-- Actually a singleton bag

	result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -}
    in

	-- Arguments
    let tv_idxs | null args  = []
		| otherwise  = [1..length args]
    in
    newTyVarTys (length tv_idxs) openTypeKind		`thenM` \ arg_tys ->
    tcMonoExprs args arg_tys		   		`thenM` \ args' ->

	-- The argument types can be unlifted or lifted; the result
	-- type must, however, be lifted since it's an argument to the IO
	-- type constructor.
    newTyVarTy liftedTypeKind  		`thenM` \ result_ty ->
    let
	io_result_ty = mkTyConApp ioTyCon [result_ty]
    in
    unifyTauTy res_ty io_result_ty		`thenM_`

	-- Construct the extra insts, which encode the
	-- constraints on the argument and result types.
    mappM new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys)	`thenM` \ ccarg_dicts_s ->
    newDicts result_origin [mkClassPred cReturnableClass [result_ty]]	`thenM` \ ccres_dict ->
    extendLIEs (ccres_dict ++ concat ccarg_dicts_s)			`thenM_`
    returnM (HsCCall lbl args' may_gc is_casm io_result_ty)
\end{code}


%************************************************************************
%*									*
		Record construction and update
%*									*
%************************************************************************

\begin{code}
378
tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
379 380
  = addErrCtxt (recordConCtxt expr)		$
    tcId con_name			`thenM` \ (con_expr, con_tau) ->
381
    let
382 383
	(_, record_ty)   = tcSplitFunTys con_tau
	(tycon, ty_args) = tcSplitTyConApp record_ty
384
    in
385
    ASSERT( isAlgTyCon tycon )
386
    unifyTauTy res_ty record_ty          `thenM_`
387

388
	-- Check that the record bindings match the constructor
389
	-- con_name is syntactically constrained to be a data constructor
390
    tcLookupDataCon con_name	`thenM` \ data_con ->
sof's avatar
sof committed
391
    let
392
	bad_fields = badFields rbinds data_con
sof's avatar
sof committed
393
    in
sof's avatar
sof committed
394
    if notNull bad_fields then
395 396
	mappM (addErrTc . badFieldCon data_con) bad_fields	`thenM_`
	failM	-- Fail now, because tcRecordBinds will crash on a bad field
397
    else
sof's avatar
sof committed
398 399

	-- Typecheck the record bindings
400
    tcRecordBinds tycon ty_args rbinds		`thenM` \ rbinds' ->
sof's avatar
sof committed
401
    
402 403
 	-- Check for missing fields
    checkMissingFields data_con rbinds		`thenM_` 
404

405
    returnM (RecordConOut data_con con_expr rbinds')
406

sof's avatar
sof committed
407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423
-- The main complication with RecordUpd is that we need to explicitly
-- handle the *non-updated* fields.  Consider:
--
--	data T a b = MkT1 { fa :: a, fb :: b }
--		   | MkT2 { fa :: a, fc :: Int -> Int }
--		   | MkT3 { fd :: a }
--	
--	upd :: T a b -> c -> T a c
--	upd t x = t { fb = x}
--
-- The type signature on upd is correct (i.e. the result should not be (T a b))
-- because upd should be equivalent to:
--
--	upd t x = case t of 
--			MkT1 p q -> MkT1 p x
--			MkT2 a b -> MkT2 p b
--			MkT3 d   -> error ...
424
--
sof's avatar
sof committed
425 426 427 428 429 430 431
-- So we need to give a completely fresh type to the result record,
-- and then constrain it by the fields that are *not* updated ("p" above).
--
-- Note that because MkT3 doesn't contain all the fields being updated,
-- its RHS is simply an error, so it doesn't impose any type constraints
--
-- All this is done in STEP 4 below.
432

433
tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
434
  = addErrCtxt (recordUpdCtxt	expr)		$
435

436 437
	-- STEP 0
	-- Check that the field names are really field names
sof's avatar
sof committed
438
    ASSERT( notNull rbinds )
sof's avatar
sof committed
439
    let 
440
	field_names = recBindFields rbinds
441
    in
442
    mappM tcLookupGlobal_maybe field_names		`thenM` \ maybe_sel_ids ->
443
    let
444 445
	bad_guys = [ addErrTc (notSelector field_name) 
		   | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
446
		     not (is_selector maybe_sel_id)
447
		   ]
448 449
	is_selector (Just (AnId sel_id)) = isRecordSelector sel_id	-- Excludes class ops
	is_selector other 		 = False	
sof's avatar
sof committed
450
    in
451
    checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM)	`thenM_`
452 453 454
    
	-- STEP 1
	-- Figure out the tycon and data cons from the first field name
455
    let
456
		-- It's OK to use the non-tc splitters here (for a selector)
457
	(Just (AnId sel_id) : _) = maybe_sel_ids
458 459
	field_lbl    = recordSelectorFieldLabel sel_id	-- We've failed already if
	tycon	     = fieldLabelTyCon field_lbl	-- it's not a field label
460 461
	data_cons    = tyConDataCons tycon
	tycon_tyvars = tyConTyVars tycon		-- The data cons use the same type vars
462
    in
463
    tcInstTyVars VanillaTv tycon_tyvars		`thenM` \ (_, result_inst_tys, inst_env) ->
sof's avatar
sof committed
464 465

	-- STEP 2
466 467
	-- Check that at least one constructor has all the named fields
	-- i.e. has an empty set of bad fields returned by badFields
sof's avatar
sof committed
468
    checkTc (any (null . badFields rbinds) data_cons)
469
	    (badFieldsUpd rbinds)		`thenM_`
470

sof's avatar
sof committed
471 472 473 474 475
	-- STEP 3
	-- Typecheck the update bindings.
	-- (Do this after checking for bad fields in case there's a field that
	--  doesn't match the constructor.)
    let
476
	result_record_ty = mkTyConApp tycon result_inst_tys
sof's avatar
sof committed
477
    in
478 479
    unifyTauTy res_ty result_record_ty          `thenM_`
    tcRecordBinds tycon result_inst_tys rbinds	`thenM` \ rbinds' ->
sof's avatar
sof committed
480 481 482 483 484 485 486 487

	-- STEP 4
	-- Use the un-updated fields to find a vector of booleans saying
	-- which type arguments must be the same in updatee and result.
	--
	-- WARNING: this code assumes that all data_cons in a common tycon
	-- have FieldLabels abstracted over the same tyvars.
    let
488
	upd_field_lbls      = map recordSelectorFieldLabel (recBindFields rbinds')
sof's avatar
sof committed
489 490 491 492 493 494 495 496 497 498 499
	con_field_lbls_s    = map dataConFieldLabels data_cons

		-- A constructor is only relevant to this process if
		-- it contains all the fields that are being updated
	relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
	is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls

	non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
	common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)

	mk_inst_ty (tyvar, result_inst_ty) 
500
	  | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty	-- Same as result type
501
	  | otherwise			     = newTyVarTy liftedTypeKind	-- Fresh type
sof's avatar
sof committed
502
    in
503
    mappM mk_inst_ty (zip tycon_tyvars result_inst_tys)	`thenM` \ inst_tys ->
sof's avatar
sof committed
504 505 506

	-- STEP 5
	-- Typecheck the expression to be updated
sof's avatar
sof committed
507
    let
508
	record_ty = mkTyConApp tycon inst_tys
sof's avatar
sof committed
509
    in
510
    tcMonoExpr record_expr record_ty		`thenM` \ record_expr' ->
sof's avatar
sof committed
511 512 513 514

	-- STEP 6
	-- Figure out the LIE we need.  We have to generate some 
	-- dictionaries for the data type context, since we are going to
515
	-- do pattern matching over the data cons.
sof's avatar
sof committed
516
	--
517 518
	-- What dictionaries do we need?  
	-- We just take the context of the type constructor
sof's avatar
sof committed
519
    let
520
	theta' = substTheta inst_env (tyConTheta tycon)
sof's avatar
sof committed
521
    in
522 523
    newDicts RecordUpdOrigin theta'	`thenM` \ dicts ->
    extendLIEs dicts			`thenM_`
sof's avatar
sof committed
524 525

	-- Phew!
526 527 528 529 530 531 532 533 534 535 536
    returnM (RecordUpdOut record_expr' record_ty result_record_ty rbinds') 
\end{code}


%************************************************************************
%*									*
	Arithmetic sequences			e.g. [a,b..]
	and their parallel-array counterparts	e.g. [: a,b.. :]
		
%*									*
%************************************************************************
sof's avatar
sof committed
537

538
\begin{code}
sof's avatar
sof committed
539
tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
540 541
  = unifyListTy res_ty 				`thenM` \ elt_ty ->  
    tcMonoExpr expr elt_ty		 	`thenM` \ expr' ->
542

543
    newMethodFromName (ArithSeqOrigin seq) 
544
		      elt_ty enumFromName	`thenM` \ enum_from ->
545

546
    returnM (ArithSeqOut (HsVar enum_from) (From expr'))
547

sof's avatar
sof committed
548
tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
549 550 551 552
  = addErrCtxt (arithSeqCtxt in_expr) $ 
    unifyListTy  res_ty         			`thenM`    \ elt_ty ->  
    tcMonoExpr expr1 elt_ty				`thenM`    \ expr1' ->
    tcMonoExpr expr2 elt_ty				`thenM`    \ expr2' ->
553
    newMethodFromName (ArithSeqOrigin seq) 
554 555 556
		      elt_ty enumFromThenName		`thenM` \ enum_from_then ->

    returnM (ArithSeqOut (HsVar enum_from_then) (FromThen expr1' expr2'))
557 558


sof's avatar
sof committed
559
tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
560 561 562 563
  = addErrCtxt (arithSeqCtxt in_expr) $
    unifyListTy  res_ty         			`thenM`    \ elt_ty ->  
    tcMonoExpr expr1 elt_ty				`thenM`    \ expr1' ->
    tcMonoExpr expr2 elt_ty				`thenM`    \ expr2' ->
564
    newMethodFromName (ArithSeqOrigin seq) 
565
	  	      elt_ty enumFromToName		`thenM` \ enum_from_to ->
566

567
    returnM (ArithSeqOut (HsVar enum_from_to) (FromTo expr1' expr2'))
sof's avatar
sof committed
568

sof's avatar
sof committed
569
tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
570 571 572 573 574
  = addErrCtxt  (arithSeqCtxt in_expr) $
    unifyListTy  res_ty         			`thenM`    \ elt_ty ->  
    tcMonoExpr expr1 elt_ty				`thenM`    \ expr1' ->
    tcMonoExpr expr2 elt_ty				`thenM`    \ expr2' ->
    tcMonoExpr expr3 elt_ty				`thenM`    \ expr3' ->
575
    newMethodFromName (ArithSeqOrigin seq) 
576
		      elt_ty enumFromThenToName		`thenM` \ eft ->
577

578
    returnM (ArithSeqOut (HsVar eft) (FromThenTo expr1' expr2' expr3'))
chak's avatar
chak committed
579 580

tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty
581 582 583 584
  = addErrCtxt (parrSeqCtxt in_expr) $
    unifyPArrTy  res_ty         			`thenM`    \ elt_ty ->  
    tcMonoExpr expr1 elt_ty				`thenM`    \ expr1' ->
    tcMonoExpr expr2 elt_ty				`thenM`    \ expr2' ->
585
    newMethodFromName (PArrSeqOrigin seq) 
586
		      elt_ty enumFromToPName 		`thenM` \ enum_from_to ->
chak's avatar
chak committed
587

588
    returnM (PArrSeqOut (HsVar enum_from_to) (FromTo expr1' expr2'))
chak's avatar
chak committed
589 590

tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
591 592 593 594 595
  = addErrCtxt  (parrSeqCtxt in_expr) $
    unifyPArrTy  res_ty         			`thenM`    \ elt_ty ->  
    tcMonoExpr expr1 elt_ty				`thenM`    \ expr1' ->
    tcMonoExpr expr2 elt_ty				`thenM`    \ expr2' ->
    tcMonoExpr expr3 elt_ty				`thenM`    \ expr3' ->
596
    newMethodFromName (PArrSeqOrigin seq)
597
		      elt_ty enumFromThenToPName	`thenM` \ eft ->
chak's avatar
chak committed
598

599
    returnM (PArrSeqOut (HsVar eft) (FromThenTo expr1' expr2' expr3'))
chak's avatar
chak committed
600 601 602 603 604

tcMonoExpr (PArrSeqIn _) _ 
  = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer shouldn't have
    -- let it through
605 606
\end{code}

607 608 609 610 611 612 613 614 615 616 617

%************************************************************************
%*									*
		Template Haskell
%*									*
%************************************************************************

\begin{code}
#ifdef GHCI	/* Only if bootstrapped */
	-- Rename excludes these cases otherwise

618
tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty)
619
tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack res_ty)
620 621 622 623 624

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_`
625
    returnM (HsReify (ReifyOut flavour name))
626 627
  where
    tycon_name = case flavour of
628 629
		   ReifyDecl -> DsMeta.declTyConName
		   ReifyType -> DsMeta.typeTyConName
630
		   ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
631 632 633 634 635 636 637 638 639 640 641 642 643 644 645
#endif GHCI
\end{code}


%************************************************************************
%*									*
		Catch-all
%*									*
%************************************************************************

\begin{code}
tcMonoExpr other _ = pprPanic "tcMonoExpr" (ppr other)
\end{code}


646 647
%************************************************************************
%*									*
648
\subsection{@tcApp@ typchecks an application}
649 650 651
%*									*
%************************************************************************

652
\begin{code}
sof's avatar
sof committed
653

654 655
tcApp :: RenamedHsExpr -> [RenamedHsExpr]   	-- Function and args
      -> TcType			    		-- Expected result type of application
656
      -> TcM TcExpr			    	-- Translated fun and args
657 658 659

tcApp (HsApp e1 e2) args res_ty 
  = tcApp e1 (e2:args) res_ty		-- Accumulate the arguments
660

sof's avatar
sof committed
661
tcApp fun args res_ty
662
  = 	-- First type-check the function
663
    tcExpr_id fun  				`thenM` \ (fun', fun_ty) ->
664

665 666
    addErrCtxt (wrongArgsCtxt "too many" fun args) (
	traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_ty)) 	`thenM_`
sof's avatar
sof committed
667
	split_fun_ty fun_ty (length args)
668
    )						`thenM` \ (expected_arg_tys, actual_result_ty) ->
sof's avatar
sof committed
669 670

	-- Now typecheck the args
671 672
    mappM (tcArg fun)
	  (zip3 args expected_arg_tys [1..])	`thenM` \ args' ->
673

674 675 676 677 678
	-- Unify with expected result after type-checking the args
	-- so that the info from args percolates to 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.)
679 680
    addErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
		  (tcSubExp res_ty actual_result_ty)	`thenM` \ co_fn ->
681

682
    returnM (co_fn <$> foldl HsApp fun' args') 
683 684


685 686 687
-- If an error happens we try to figure out whether the
-- function has been given too many or too few arguments,
-- and say so
688
checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
689 690
  = zonkTcType expected_res_ty	  `thenM` \ exp_ty' ->
    zonkTcType actual_res_ty	  `thenM` \ act_ty' ->
691
    let
692 693
      (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
      (env2, act_ty'') = tidyOpenType env1     act_ty'
694 695
      (exp_args, _)    = tcSplitFunTys exp_ty''
      (act_args, _)    = tcSplitFunTys act_ty''
696

sof's avatar
sof committed
697 698 699 700 701 702
      len_act_args     = length act_args
      len_exp_args     = length exp_args

      message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
              | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
	      | otherwise		    = appCtxt fun args
703
    in
704
    returnM (env2, message)
705 706


707
split_fun_ty :: TcType		-- The type of the function
708
	     -> Int		-- Number of arguments
709
	     -> TcM ([TcType],	-- Function argument types
710
		     TcType)	-- Function result types
711

sof's avatar
sof committed
712
split_fun_ty fun_ty 0 
713
  = returnM ([], fun_ty)
714

sof's avatar
sof committed
715
split_fun_ty fun_ty n
716
  = 	-- Expect the function to have type A->B
717 718 719
    unifyFunTy fun_ty		`thenM` \ (arg_ty, res_ty) ->
    split_fun_ty res_ty (n-1)	`thenM` \ (arg_tys, final_res_ty) ->
    returnM (arg_ty:arg_tys, final_res_ty)
720 721 722
\end{code}

\begin{code}
723 724
tcArg :: RenamedHsExpr				-- The function (for error messages)
      -> (RenamedHsExpr, TcSigmaType, Int)	-- Actual argument and expected arg type
725
      -> TcM TcExpr				-- Resulting argument and LIE
726

727
tcArg the_fun (arg, expected_arg_ty, arg_no)
728
  = addErrCtxt (funAppCtxt the_fun arg arg_no) $
sof's avatar
sof committed
729
    tcExpr arg expected_arg_ty
730 731
\end{code}

sof's avatar
sof committed
732

733 734 735 736 737 738
%************************************************************************
%*									*
\subsection{@tcId@ typchecks an identifier occurrence}
%*									*
%************************************************************************

739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760
tcId instantiates an occurrence of an Id.
The instantiate_it loop runs round instantiating the Id.
It has to be a loop because we are now prepared to entertain
types like
	f:: forall a. Eq a => forall b. Baz b => tau
We want to instantiate this to
	f2::tau		{f2 = f1 b (Baz b), f1 = f a (Eq a)}

The -fno-method-sharing flag controls what happens so far as the LIE
is concerned.  The default case is that for an overloaded function we 
generate a "method" Id, and add the Method Inst to the LIE.  So you get
something like
	f :: Num a => a -> a
	f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
If you specify -fno-method-sharing, the dictionary application 
isn't shared, so we get
	f :: Num a => a -> a
	f = /\a (d:Num a) (x:a) -> (+) a d x x
This gets a bit less sharing, but
	a) it's better for RULEs involving overloaded functions
	b) perhaps fewer separated lambdas

761
\begin{code}
762
tcId :: Name -> TcM (TcExpr, TcType)
763
tcId name	-- Look up the Id and instantiate its type
764 765 766 767 768 769 770 771 772 773
  = 	-- 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) ->
774

775 776 777 778
#ifndef GHCI
    loop (HsVar id) (idType id)		-- Non-TH case

#else /* GHCI is on */
779 780 781 782 783 784
	-- Check for cross-stage lifting
    getStage				`thenM` \ use_stage -> 
    case use_stage of
      Brack use_lvl ps_var lie_var
	| use_lvl > bind_lvl && not (isExternalName name)
	-> 	-- E.g. \x -> [| h x |]
785 786 787 788 789 790 791
		-- 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.
792 793 794 795
		--
		-- NB: During type-checking, isExernalName is true of 
		-- top level things, and false of nested bindings
		-- Top-level things don't need lifting.
796 797 798 799 800 801 802 803 804 805 806 807
	
	let
	    id_ty = idType id
	in
	checkTc (isTauTy id_ty)	(polySpliceErr id)	`thenM_` 
		    -- If x is polymorphic, its occurrence sites might
		    -- have different instantiations, so we can't use plain
		    -- 'x' as the splice proxy name.  I don't know how to 
		    -- solve this, and it's probably unimportant, so I'm
		    -- just going to flag an error for now

	setLIEVar lie_var	(
808
	newMethodFromName orig id_ty DsMeta.liftName	`thenM` \ lift ->
809 810 811 812 813 814 815 816 817
		-- Put the 'lift' constraint into the right LIE
	
	-- Update the pending splices
        readMutVar ps_var			`thenM` \ ps ->
        writeMutVar ps_var ((name, HsApp (HsVar lift) (HsVar id)) : ps)	`thenM_`

	returnM (HsVar id, id_ty))

      other -> 
818
	checkWellStaged (quotes (ppr id)) bind_lvl use_stage	`thenM_`
819
	loop (HsVar id) (idType id)
820
#endif
821
    }
822

823
  where
824 825
    orig = OccurrenceOf name

826
    loop (HsVar fun_id) fun_ty
827
	| want_method_inst fun_ty
828
	= tcInstType VanillaTv fun_ty		`thenM` \ (tyvars, theta, tau) ->
829
	  newMethodWithGivenTy orig fun_id 
830 831
		(mkTyVarTys tyvars) theta tau	`thenM` \ meth_id ->
	  loop (HsVar meth_id) tau
832

833
    loop fun fun_ty 
834
	| isSigmaTy fun_ty
835 836
	= tcInstCall orig fun_ty	`thenM` \ (inst_fn, tau) ->
	  loop (inst_fn fun) tau
837 838

	| otherwise
839
	= returnM (fun, fun_ty)
840

841
	-- 	Hack Alert (want_method_inst)!
842 843 844 845 846 847 848
	-- 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:
	--	let m = f %x in (m 3, m 4)
	-- 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.
849 850 851 852 853 854
    want_method_inst fun_ty 
	| opt_NoMethodSharing = False	
	| otherwise	      = case tcSplitSigmaTy fun_ty of
				  (_,[],_)    -> False 	-- Not overloaded
				  (_,theta,_) -> not (any isLinearPred theta)

855 856 857 858

	-- 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
859
    inst_data_con data_con
860 861
      = tcInstDataCon orig data_con	`thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) ->
	extendLIEs ex_dicts		`thenM_`
862 863
	returnM (mkHsDictApp (mkHsTyApp (HsVar (dataConWrapId data_con)) ty_args) 
			     (map instToId ex_dicts), 
864
		 mkFunTys arg_tys result_ty)
865 866 867
\end{code}

Typecheck expression which in most cases will be an Id.
868 869 870
The expression can return a higher-ranked type, such as
	(forall a. a->a) -> Int
so we must create a HoleTyVarTy to pass in as the expected tyvar.
871

872
\begin{code}
873
tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, TcType)
874
tcExpr_id (HsVar name) = tcId name
875 876 877 878
tcExpr_id expr         = newHoleTyVarTy			`thenM` \ id_ty ->
			 tcMonoExpr expr id_ty		`thenM` \ expr' ->
			 readHoleResult id_ty		`thenM` \ id_ty' ->
		         returnM (expr', id_ty') 
879
\end{code}
880

881

882 883 884 885 886 887
%************************************************************************
%*									*
\subsection{Record bindings}
%*									*
%************************************************************************

888 889
Game plan for record bindings
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
890 891 892
1. Find the TyCon for the bindings, from the first field label.

2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
893

894
For each binding field = value
895

896 897
3. Instantiate the field type (from the field label) using the type
   envt from step 2.
898

899 900
4  Type check the value using tcArg, passing the field type as 
   the expected argument type.
901 902 903 904 905 906

This extends OK when the field types are universally quantified.

	
\begin{code}
tcRecordBinds
907 908
	:: TyCon		-- Type constructor for the record
	-> [TcType]		-- Args of this type constructor
909
	-> RenamedRecordBinds
910
	-> TcM TcRecordBinds
911

912
tcRecordBinds tycon ty_args rbinds
913
  = mappM do_bind rbinds
914
  where
915
    tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
916

917 918 919
    do_bind (field_lbl_name, rhs)
      = addErrCtxt (fieldCtxt field_lbl_name)	$
           tcLookupId field_lbl_name		`thenM` \ sel_id ->