TcRnTypes.lhs 43.7 KB
Newer Older
1

2
% (c) The University of Glasgow 2006
3
4
5
6
% (c) The GRASP Project, Glasgow University, 1992-2002
%
\begin{code}
module TcRnTypes(
7
8
	TcRnIf, TcRn, TcM, RnM,	IfM, IfL, IfG, -- The monad is opaque outside this module
	TcRef,
9
10

	-- The environment types
11
12
	Env(..), 
	TcGblEnv(..), TcLclEnv(..), 
13
	IfGblEnv(..), IfLclEnv(..), 
14
15

	-- Ranamer types
16
	ErrCtxt, RecFieldEnv(..),
17
	ImportAvails(..), emptyImportAvails, plusImportAvails, 
18
	WhereFrom(..), mkModDeps,
19
20

	-- Typechecker types
21
	TcTypeEnv, TcTyThing(..), pprTcTyThingCategory, 
22
23

	-- Template Haskell
24
	ThStage(..), topStage, topAnnStage, topSpliceStage,
25
	ThLevel, impLevel, outerLevel, thLevel,
26

ross's avatar
ross committed
27
	-- Arrows
ross's avatar
ross committed
28
	ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
ross's avatar
ross committed
29

30
	-- Constraints
31
        Untouchables(..), inTouchableRange, isNoUntouchables,
32

33
34
35
36
37
38
39
40
        WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
        andWC, addFlats, addImplics, mkFlatWC,

        EvVarX(..), mkEvVarX, evVarOf, evVarX, evVarOfPred,
        WantedEvVar, wantedToFlavored,
        keepWanted,

        Implication(..),
41
42
        CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
	CtOrigin(..), EqOrigin(..), 
dimitris's avatar
dimitris committed
43
        WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
44

45
	SkolemInfo(..),
46

dimitris's avatar
dimitris committed
47
48
49
        CtFlavor(..), pprFlavorArising, isWanted, 
        isGivenOrSolved, isGiven_maybe,
        isDerived,
50
        FlavoredEvVar,
51
52

	-- Pretty printing
53
        pprEvVarTheta, pprWantedEvVar, pprWantedsWithLocs,
54
	pprEvVars, pprEvVarWithType,
55
        pprArising, pprArisingAt,
56
57

	-- Misc other types
58
	TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds
59
	
60
61
62
63
  ) where

#include "HsVersions.h"

64
import HsSyn
65
66
import HscTypes
import Type
67
68
import Class    ( Class )
import DataCon  ( DataCon, dataConUserType )
69
import TcType
70
import Annotations
71
72
import InstEnv
import FamInstEnv
73
import IOEnv
74
75
import RdrName
import Name
76
import NameEnv
77
78
79
import NameSet
import Var
import VarEnv
80
import Module
81
82
83
import SrcLoc
import VarSet
import ErrUtils
84
import UniqFM
85
import UniqSupply
86
import Unique
87
import BasicTypes
88
89
import Bag
import Outputable
90
import ListSetOps
91
import FastString
92

93
import Data.Set (Set)
94
95
96
97
98
99
100
101
102
103
\end{code}


%************************************************************************
%*									*
	       Standard monad definition for TcRn
    All the combinators for the monad can be found in TcRnMonad
%*									*
%************************************************************************

104
The monad itself has to be defined here, because it is mentioned by ErrCtxt
105
106

\begin{code}
107
type TcRef a 	 = IORef a
108
type TcId    	 = Id 			-- Type may be a TcType  DV: WHAT??????????
109
type TcIdSet 	 = IdSet
110

111

112
113
type TcRnIf a b c = IOEnv (Env a b) c
type IfM lcl a  = TcRnIf IfGblEnv lcl a		-- Iface stuff
Simon Marlow's avatar
Simon Marlow committed
114

115
116
117
118
119
type IfG a  = IfM () a				-- Top level
type IfL a  = IfM IfLclEnv a			-- Nested
type TcRn a = TcRnIf TcGblEnv TcLclEnv a
type RnM  a = TcRn a		-- Historical
type TcM  a = TcRn a		-- Historical
120
121
\end{code}

122
123
124
125
126
127
128
129
130
131
132
133
Representation of type bindings to uninstantiated meta variables used during
constraint solving.

\begin{code}
data TcTyVarBind = TcTyVarBind TcTyVar TcType

type TcTyVarBinds = Bag TcTyVarBind

instance Outputable TcTyVarBind where
  ppr (TcTyVarBind tv ty) = ppr tv <+> text ":=" <+> ppr ty
\end{code}

134
135
136
137
138
139
140
141

%************************************************************************
%*									*
		The main environment types
%*									*
%************************************************************************

\begin{code}
142
data Env gbl lcl	-- Changes as we move into an expression
143
  = Env {
144
	env_top	 :: HscEnv,	-- Top-level stuff that never changes
145
				-- Includes all info about imported things
146

Simon Marlow's avatar
Simon Marlow committed
147
148
	env_us   :: {-# UNPACK #-} !(IORef UniqSupply),	
				-- Unique supply for local varibles
149

150
	env_gbl  :: gbl,	-- Info about things defined at the top level
151
				-- of the module being compiled
152

153
	env_lcl  :: lcl	 	-- Nested stuff; changes as we go into 
154
    }
155
156
157
158
159
160
161

-- TcGblEnv describes the top-level of the module at the 
-- point at which the typechecker is finished work.
-- It is this structure that is handed on to the desugarer

data TcGblEnv
  = TcGblEnv {
162
163
164
	tcg_mod     :: Module,         -- ^ Module being compiled
	tcg_src     :: HscSource,
          -- ^ What kind of module (regular Haskell, hs-boot, ext-core)
165

166
167
168
	tcg_rdr_env :: GlobalRdrEnv,   -- ^ Top level envt; used during renaming
	tcg_default :: Maybe [Type],
          -- ^ Types used for defaulting. @Nothing@ => no @default@ decl
169

170
171
	tcg_fix_env   :: FixityEnv,	-- ^ Just for things in this module
	tcg_field_env :: RecFieldEnv,	-- ^ Just for things in this module
172

173
174
175
176
177
178
179
	tcg_type_env :: TypeEnv,
          -- ^ Global type env for the module we are compiling now.  All
	  -- TyCons and Classes (for this module) end up in here right away,
	  -- along with their derived constructors, selectors.
	  --
	  -- (Ids defined in this module start in the local envt, though they
	  --  move to the global envt during zonking)
180

181
	tcg_type_env_var :: TcRef TypeEnv,
182
183
184
185
		-- Used only to initialise the interface-file
		-- typechecker in initIfaceTcRn, so that it can see stuff
		-- bound in this module when dealing with hi-boot recursions
		-- Updated at intervals (e.g. after dealing with types and classes)
186
	
187
188
189
190
	tcg_inst_env     :: InstEnv,
          -- ^ Instance envt for /home-package/ modules; Includes the dfuns in
	  -- tcg_insts
	tcg_fam_inst_env :: FamInstEnv,	-- ^ Ditto for family instances
191

192
193
194
195
		-- Now a bunch of things about this module that are simply 
		-- accumulated, but never consulted until the end.  
		-- Nevertheless, it's convenient to accumulate them along 
		-- with the rest of the info from this module.
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
	tcg_exports :: [AvailInfo],	-- ^ What is exported
	tcg_imports :: ImportAvails,
          -- ^ Information about what was imported from where, including
	  -- things bound in this module.

	tcg_dus :: DefUses,
          -- ^ What is defined in this module and what is used.
          -- The latter is used to generate
          --
          --  (a) version tracking; no need to recompile if these things have
          --      not changed version stamp
          --
          --  (b) unused-import info

	tcg_keep :: TcRef NameSet,
          -- ^ Locally-defined top-level names to keep alive.
          --
          -- "Keep alive" means give them an Exported flag, so that the
          -- simplifier does not discard them as dead code, and so that they
          -- are exposed in the interface file (but not to export to the
          -- user).
          --
          -- Some things, like dict-fun Ids and default-method Ids are "born"
          -- with the Exported flag on, for exactly the above reason, but some
          -- we only discover as we go.  Specifically:
          --
          --   * The to/from functions for generic data types
          --
          --   * Top-level variables appearing free in the RHS of an orphan
          --     rule
          --
          --   * Top-level variables appearing free in a TH bracket

229
        tcg_th_used :: TcRef Bool,
230
231
          -- ^ @True@ <=> Template Haskell syntax used.
          --
232
233
234
235
          -- We need this so that we can generate a dependency on the
          -- Template Haskell package, becuase the desugarer is going
          -- to emit loads of references to TH symbols.  The reference
          -- is implicit rather than explicit, so we have to zap a
236
237
          -- mutable variable.

238
239
240
241
242
        tcg_th_splice_used :: TcRef Bool,
          -- ^ @True@ <=> A Template Haskell splice was used.
          --
          -- Splices disable recompilation avoidance (see #481)

243
244
	tcg_dfun_n  :: TcRef OccSet,
          -- ^ Allows us to choose unique DFun names.
245
246
247
248

	-- The next fields accumulate the payload of the module
	-- The binds, rules and foreign-decl fiels are collected
	-- initially in un-zonked form and are finally zonked in tcRnSrcDecls
249

250
        tcg_rn_exports :: Maybe [Located (IE Name)],
251
252
253
        tcg_rn_imports :: [LImportDecl Name],
		-- Keep the renamed imports regardless.  They are not 
		-- voluminous and are needed if you want to report unused imports
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
254

255
        tcg_used_rdrnames :: TcRef (Set RdrName),
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
256
257
258
		-- The set of used *imported* (not locally-defined) RdrNames
		-- Used only to report unused import declarations

259
260
261
	tcg_rn_decls :: Maybe (HsGroup Name),
          -- ^ Renamed decls, maybe.  @Nothing@ <=> Don't retain renamed
          -- decls.
262

263
        tcg_ev_binds  :: Bag EvBind,	    -- Top-level evidence bindings
264
	tcg_binds     :: LHsBinds Id,	    -- Value bindings in this module
265
        tcg_sigs      :: NameSet, 	    -- ...Top-level names that *lack* a signature
266
        tcg_imp_specs :: [LTcSpecPrag],     -- ...SPECIALISE prags for imported Ids
Ian Lynagh's avatar
Ian Lynagh committed
267
	tcg_warns     :: Warnings,	    -- ...Warnings and deprecations
268
	tcg_anns      :: [Annotation],      -- ...Annotations
269
	tcg_insts     :: [Instance],	    -- ...Instances
270
271
272
273
        tcg_fam_insts :: [FamInst],         -- ...Family instances
        tcg_rules     :: [LRuleDecl Id],    -- ...Rules
        tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
        tcg_vects     :: [LVectDecl Id],    -- ...Vectorisation declarations
274

275
	tcg_doc_hdr   :: Maybe LHsDocString, -- ^ Maybe Haddock header docs
276
277
278
279
280
281
        tcg_hpc       :: AnyHpcUsage,        -- ^ @True@ if any part of the
                                             --  prog uses hpc instrumentation.

        tcg_main      :: Maybe Name          -- ^ The Name of the main
                                             -- function, if this module is
                                             -- the main module.
282
    }
283

284
285
286
287
288
289
290
data RecFieldEnv 
  = RecFields (NameEnv [Name])	-- Maps a constructor name *in this module*
				-- to the fields for that constructor
	      NameSet		-- Set of all fields declared *in this module*;
				-- used to suppress name-shadowing complaints
				-- when using record wild cards
				-- E.g.  let fld = e in C {..}
291
292
	-- This is used when dealing with ".." notation in record 
	-- construction and pattern matching.
293
	-- The FieldEnv deals *only* with constructors defined in *this*
Thomas Schilling's avatar
Thomas Schilling committed
294
295
	-- module.  For imported modules, we get the same info from the
	-- TypeEnv
296
297
\end{code}

298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
%************************************************************************
%*									*
		The interface environments
  	      Used when dealing with IfaceDecls
%*									*
%************************************************************************

\begin{code}
data IfGblEnv 
  = IfGblEnv {
	-- The type environment for the module being compiled,
	-- in case the interface refers back to it via a reference that
	-- was originally a hi-boot file.
	-- We need the module name so we can test when it's appropriate
	-- to look in this env.
313
	if_rec_types :: Maybe (Module, IfG TypeEnv)
314
315
316
317
318
319
320
321
322
323
		-- Allows a read effect, so it can be in a mutable
		-- variable; c.f. handling the external package type env
		-- Nothing => interactive stuff, no loops possible
    }

data IfLclEnv
  = IfLclEnv {
	-- The module for the current IfaceDecl
	-- So if we see   f = \x -> x
	-- it means M.f = \x -> x, where M is the if_mod
324
	if_mod :: Module,
325

326
327
328
329
330
331
332
	-- The field is used only for error reporting
	-- if (say) there's a Lint error in it
	if_loc :: SDoc,
		-- Where the interface came from:
		--	.hi file, or GHCi state, or ext core
		-- plus which bit is currently being examined

333
	if_tv_env  :: UniqFM TyVar,	-- Nested tyvar bindings
334
		      	     		-- (and coercions)
335
	if_id_env  :: UniqFM Id		-- Nested id binding
336
337
338
    }
\end{code}

339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361

%************************************************************************
%*									*
		The local typechecker environment
%*									*
%************************************************************************

The Global-Env/Local-Env story
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
During type checking, we keep in the tcg_type_env
	* All types and classes
	* All Ids derived from types and classes (constructors, selectors)

At the end of type checking, we zonk the local bindings,
and as we do so we add to the tcg_type_env
	* Locally defined top-level Ids

Why?  Because they are now Ids not TcIds.  This final GlobalEnv is
	a) fed back (via the knot) to typechecking the 
	   unfoldings of interface signatures
	b) used in the ModDetails of this module

\begin{code}
362
363
data TcLclEnv		-- Changes as we move inside an expression
			-- Discarded after typecheck/rename; not passed on to desugarer
364
  = TcLclEnv {
365
	tcl_loc  :: SrcSpan,		-- Source span
366
	tcl_ctxt :: [ErrCtxt],		-- Error context, innermost on top
367
	tcl_errs :: TcRef Messages,	-- Place to accumulate errors
368

369
370
	tcl_th_ctxt    :: ThStage,	      -- Template Haskell context
	tcl_arrow_ctxt :: ArrowCtxt,	      -- Arrow-notation context
371

372
	tcl_rdr :: LocalRdrEnv,		-- Local name envt
373
374
375
376
		-- Maintained during renaming, of course, but also during
		-- type checking, solely so that when renaming a Template-Haskell
		-- splice we have the right environment for the renamer.
		-- 
377
378
379
380
		--   Does *not* include global name envt; may shadow it
		--   Includes both ordinary variables and type variables;
		--   they are kept distinct because tyvar have a different
		--   occurrence contructor (Name.TvOcc)
381
382
383
		-- We still need the unsullied global name env so that
    		--   we can look up record field names

384
385
	tcl_env  :: TcTypeEnv,    -- The local type environment: Ids and
			          -- TyVars defined in this module
386
387
					
	tcl_tyvars :: TcRef TcTyVarSet,	-- The "global tyvars"
388
			-- Namely, the in-scope TyVars bound in tcl_env, 
389
390
391
392
			-- plus the tyvars mentioned in the types of Ids bound
			-- in tcl_lenv. 
                        -- Why mutable? see notes with tcGetGlobalTyVars

393
	tcl_lie   :: TcRef WantedConstraints,    -- Place to accumulate type constraints
394
395
396
397
398
399
400

	-- TcMetaTyVars have 
	tcl_meta  :: TcRef Unique,  -- The next free unique for TcMetaTyVars
		     		    -- Guaranteed to be allocated linearly
	tcl_untch :: Unique	    -- Any TcMetaTyVar with 
		     		    --     unique >= tcl_untch is touchable
		     		    --     unique <  tcl_untch is untouchable
401
402
    }

403
404
type TcTypeEnv = NameEnv TcTyThing

405

406
407
408
409
410
411
412
413
414
415
416
417
418
{- Note [Given Insts]
   ~~~~~~~~~~~~~~~~~~
Because of GADTs, we have to pass inwards the Insts provided by type signatures 
and existential contexts. Consider
	data T a where { T1 :: b -> b -> T [b] }
	f :: Eq a => T a -> Bool
	f (T1 x y) = [x]==[y]

The constructor T1 binds an existential variable 'b', and we need Eq [b].
Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we 
pass it inwards.

-}
419

420
---------------------------
421
-- Template Haskell stages and levels 
422
423
---------------------------

424
425
426
427
428
429
430
431
432
433
434
435
data ThStage	-- See Note [Template Haskell state diagram] in TcSplice
  = Splice	-- Top-level splicing
		-- This code will be run *at compile time*;
		--   the result replaces the splice
		-- Binding level = 0
 
  | Comp   	-- Ordinary Haskell code
		-- Binding level = 1

  | Brack  			-- Inside brackets 
      ThStage 			--   Binding level = level(stage) + 1
      (TcRef [PendingSplice])	--   Accumulate pending splices here
436
      (TcRef WantedConstraints)	--     and type constraints here
437
438
439
440
441
442
443
444
445
446
447

topStage, topAnnStage, topSpliceStage :: ThStage
topStage       = Comp
topAnnStage    = Splice
topSpliceStage = Splice

instance Outputable ThStage where
   ppr Splice        = text "Splice"
   ppr Comp	     = text "Comp"
   ppr (Brack s _ _) = text "Brack" <> parens (ppr s)

448
type ThLevel = Int	
449
        -- See Note [Template Haskell levels] in TcSplice
450
451
	-- Incremented when going inside a bracket,
	-- decremented when going inside a splice
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
452
	-- NB: ThLevel is one greater than the 'n' in Fig 2 of the
453
	--     original "Template meta-programming for Haskell" paper
454

455
impLevel, outerLevel :: ThLevel
456
impLevel = 0	-- Imported things; they can be used inside a top level splice
457
458
459
outerLevel = 1	-- Things defined outside brackets
-- NB: Things at level 0 are not *necessarily* imported.
--	eg  $( \b -> ... )   here b is bound at level 0
460
461
462
463
464
465
--
-- For example: 
--	f = ...
--	g1 = $(map ...)		is OK
--	g2 = $(f ...)		is not OK; because we havn't compiled f yet

466
467
468
469
thLevel :: ThStage -> ThLevel
thLevel Splice        = 0
thLevel Comp          = 1
thLevel (Brack s _ _) = thLevel s + 1
470

ross's avatar
ross committed
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
---------------------------
-- Arrow-notation context
---------------------------

{-
In arrow notation, a variable bound by a proc (or enclosed let/kappa)
is not in scope to the left of an arrow tail (-<) or the head of (|..|).
For example

	proc x -> (e1 -< e2)

Here, x is not in scope in e1, but it is in scope in e2.  This can get
a bit complicated:

	let x = 3 in
	proc y -> (proc z -> e1) -< e2

Here, x and z are in scope in e1, but y is not.  We implement this by
recording the environment when passing a proc (using newArrowScope),
and returning to that (using escapeArrowScope) on the left of -< and the
head of (|..|).
-}

ross's avatar
ross committed
494
495
496
data ArrowCtxt
  = NoArrowCtxt
  | ArrowCtxt (Env TcGblEnv TcLclEnv)
ross's avatar
ross committed
497
498
499
500
501
502
503
504
505

-- Record the current environment (outside a proc)
newArrowScope :: TcM a -> TcM a
newArrowScope
  = updEnv $ \env ->
	env { env_lcl = (env_lcl env) { tcl_arrow_ctxt = ArrowCtxt env } }

-- Return to the stored environment (from the enclosing proc)
escapeArrowScope :: TcM a -> TcM a
ross's avatar
ross committed
506
507
508
509
escapeArrowScope
  = updEnv $ \ env -> case tcl_arrow_ctxt (env_lcl env) of
	NoArrowCtxt -> env
	ArrowCtxt env' -> env'
510

511
512
513
514
---------------------------
-- TcTyThing
---------------------------

515
data TcTyThing
516
  = AGlobal TyThing		-- Used only in the return type of a lookup
517

518
  | ATcId   {		-- Ids defined in this module; may not be fully zonked
519
	tct_id    :: TcId,		
520
	tct_level :: ThLevel }
521

522
523
  | ATyVar  Name TcType		-- The type to which the lexically scoped type vaiable
				-- is currently refined. We only need the Name
524
525
				-- for error-message purposes; it is the corresponding
				-- Name in the domain of the envt
526

527
528
  | AThing  TcKind 		-- Used temporarily, during kind checking, for the
				--	tycons and clases in this recursive group
529
530

instance Outputable TcTyThing where	-- Debugging only
531
   ppr (AGlobal g)      = pprTyThing g
532
   ppr elt@(ATcId {})   = text "Identifier" <> 
533
534
535
			  brackets (ppr (tct_id elt) <> dcolon 
                                 <> ppr (varType (tct_id elt)) <> comma
				 <+> ppr (tct_level elt))
536
   ppr (ATyVar tv _)    = text "Type variable" <+> quotes (ppr tv)
537
   ppr (AThing k)       = text "AThing" <+> ppr k
538
539
540

pprTcTyThingCategory :: TcTyThing -> SDoc
pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing
Ian Lynagh's avatar
Ian Lynagh committed
541
542
543
pprTcTyThingCategory (ATyVar {})     = ptext (sLit "Type variable")
pprTcTyThingCategory (ATcId {})      = ptext (sLit "Local identifier")
pprTcTyThingCategory (AThing {})     = ptext (sLit "Kinded thing")
544
545
546
\end{code}

\begin{code}
547
548
549
550
551
552
553
type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message))
	-- Monadic so that we have a chance
	-- to deal with bound type variables just before error
	-- message construction

	-- Bool:  True <=> this is a landmark context; do not
	--		   discard it when trimming for display
554
555
556
557
558
559
560
561
562
563
\end{code}


%************************************************************************
%*									*
	Operations over ImportAvails
%*									*
%************************************************************************

\begin{code}
564
565
566
567
568
569
570
571
572
573
574
575
-- | 'ImportAvails' summarises what was imported from where, irrespective of
-- whether the imported things are actually used or not.  It is used:
--
--  * when processing the export list,
--
--  * when constructing usage info for the interface file,
--
--  * to identify the list of directly imported modules for initialisation
--    purposes and for optimised overlap checking of family instances,
--
--  * when figuring out what things are really unused
--
576
577
data ImportAvails 
   = ImportAvails {
578
579
	imp_mods :: ImportedMods,
	  --      = ModuleEnv [(ModuleName, Bool, SrcSpan, Bool)],
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
          -- ^ Domain is all directly-imported modules
          -- The 'ModuleName' is what the module was imported as, e.g. in
          -- @
          --     import Foo as Bar
          -- @
          -- it is @Bar@.
          --
          -- The 'Bool' means:
          --
          --  - @True@ => import was @import Foo ()@
          --
          --  - @False@ => import was some other form
          --
          -- Used
          --
          --   (a) to help construct the usage information in the interface
          --       file; if we import somethign we need to recompile if the
          --       export version changes
          --
          --   (b) to specify what child modules to initialise
          --
          -- We need a full ModuleEnv rather than a ModuleNameEnv here,
          -- because we might be importing modules of the same name from
          -- different packages. (currently not the case, but might be in the
          -- future).
605

606
607
608
609
610
611
612
613
614
615
616
        imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface),
          -- ^ Home-package modules needed by the module being compiled
          --
          -- It doesn't matter whether any of these dependencies
          -- are actually /used/ when compiling the module; they
          -- are listed if they are below it at all.  For
          -- example, suppose M imports A which imports X.  Then
          -- compiling M might not need to consult X.hi, but X
          -- is still listed in M's dependencies.

        imp_dep_pkgs :: [PackageId],
617
618
619
          -- ^ Packages needed by the module being compiled, whether directly,
          -- or via other modules in this package, or via modules imported
          -- from other packages.
620
621
622
623
624
625
626
627
628
629
        
        imp_trust_pkgs :: [PackageId],
          -- ^ This is strictly a subset of imp_dep_pkgs and records the
          -- packages the current module needs to trust for Safe Haskell
          -- compilation to succeed. A package is required to be trusted if
          -- we are dependent on a trustworthy module in that package.
          -- While perhaps making imp_dep_pkgs a tuple of (PackageId, Bool)
          -- where True for the bool indicates the package is required to be
          -- trusted is the more logical  design, doing so complicates a lot
          -- of code not concerned with Safe Haskell.
630
          -- See Note [RnNames . Tracking Trust Transitively]
631

632
633
634
635
636
637
638
        imp_trust_own_pkg :: Bool,
          -- ^ Do we require that our own package is trusted?
          -- This is to handle efficiently the case where a Safe module imports
          -- a Trustworthy module that resides in the same package as it.
          -- See Note [RnNames . Trust Own Package]

        imp_orphs :: [Module],
639
640
          -- ^ Orphan modules below us in the import tree (and maybe including
          -- us for imported modules)
641

642
        imp_finsts :: [Module]
643
644
          -- ^ Family instance modules below us in the import tree (and maybe
          -- including us for imported modules)
645
646
      }

Simon Marlow's avatar
Simon Marlow committed
647
648
649
mkModDeps :: [(ModuleName, IsBootInterface)]
	  -> ModuleNameEnv (ModuleName, IsBootInterface)
mkModDeps deps = foldl add emptyUFM deps
650
	       where
Simon Marlow's avatar
Simon Marlow committed
651
		 add env elt@(m,_) = addToUFM env m elt
652

653
emptyImportAvails :: ImportAvails
654
655
656
657
658
659
660
661
662
663
664
665
666
emptyImportAvails = ImportAvails { imp_mods          = emptyModuleEnv,
                                   imp_dep_mods      = emptyUFM,
                                   imp_dep_pkgs      = [],
                                   imp_trust_pkgs    = [],
                                   imp_trust_own_pkg = False,
                                   imp_orphs         = [],
                                   imp_finsts        = [] }

-- | Union two ImportAvails
--
-- This function is a key part of Import handling, basically
-- for each import we create a seperate ImportAvails structure
-- and then union them all together with this function.
667
668
plusImportAvails ::  ImportAvails ->  ImportAvails ->  ImportAvails
plusImportAvails
669
  (ImportAvails { imp_mods = mods1,
670
671
                  imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,
                  imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1,
672
673
                  imp_orphs = orphs1, imp_finsts = finsts1 })
  (ImportAvails { imp_mods = mods2,
674
675
                  imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
                  imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2,
676
                  imp_orphs = orphs2, imp_finsts = finsts2 })
677
678
679
680
681
682
683
  = ImportAvails { imp_mods          = plusModuleEnv_C (++) mods1 mods2,
                   imp_dep_mods      = plusUFM_C plus_mod_dep dmods1 dmods2,
                   imp_dep_pkgs      = dpkgs1 `unionLists` dpkgs2,
                   imp_trust_pkgs    = tpkgs1 `unionLists` tpkgs2,
                   imp_trust_own_pkg = tself1 || tself2,
                   imp_orphs         = orphs1 `unionLists` orphs2,
                   imp_finsts        = finsts1 `unionLists` finsts2 }
684
  where
685
    plus_mod_dep (m1, boot1) (m2, boot2) 
686
687
688
        = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
                -- Check mod-names match
          (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that
689
690
691
692
693
694
695
696
697
698
699
700
701
\end{code}

%************************************************************************
%*									*
\subsection{Where from}
%*									*
%************************************************************************

The @WhereFrom@ type controls where the renamer looks for an interface file

\begin{code}
data WhereFrom 
  = ImportByUser IsBootInterface	-- Ordinary user import (perhaps {-# SOURCE #-})
702
  | ImportBySystem			-- Non user import.
703
704

instance Outputable WhereFrom where
Ian Lynagh's avatar
Ian Lynagh committed
705
  ppr (ImportByUser is_boot) | is_boot     = ptext (sLit "{- SOURCE -}")
706
			     | otherwise   = empty
Ian Lynagh's avatar
Ian Lynagh committed
707
  ppr ImportBySystem     		   = ptext (sLit "{- SYSTEM -}")
708
709
710
711
712
\end{code}


%************************************************************************
%*									*
713
714
715
716
717
718
		Wanted constraints
     These are forced to be in TcRnTypes because
     	   TcLclEnv mentions WantedConstraints
	   WantedConstraint mentions CtLoc
	   CtLoc mentions ErrCtxt
	   ErrCtxt mentions TcM
719
720
721
%*									*
v%************************************************************************

722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
\begin{code}
data WantedConstraints
  = WC { wc_flat  :: Bag WantedEvVar   -- Unsolved constraints, all wanted
       , wc_impl  :: Bag Implication
       , wc_insol :: Bag FlavoredEvVar -- Insoluble constraints, can be
                                       -- wanted, given, or derived
                                       -- See Note [Insoluble constraints]
    }

emptyWC :: WantedConstraints
emptyWC = WC { wc_flat = emptyBag, wc_impl = emptyBag, wc_insol = emptyBag }

mkFlatWC :: Bag WantedEvVar -> WantedConstraints
mkFlatWC wevs = WC { wc_flat = wevs, wc_impl = emptyBag, wc_insol = emptyBag }

isEmptyWC :: WantedConstraints -> Bool
isEmptyWC (WC { wc_flat = f, wc_impl = i, wc_insol = n })
  = isEmptyBag f && isEmptyBag i && isEmptyBag n

insolubleWC :: WantedConstraints -> Bool
-- True if there are any insoluble constraints in the wanted bag
insolubleWC wc = not (isEmptyBag (wc_insol wc))
               || anyBag ic_insol (wc_impl wc)

andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints
andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 })
      (WC { wc_flat = f2, wc_impl = i2, wc_insol = n2 })
  = WC { wc_flat  = f1 `unionBags` f2
       , wc_impl  = i1 `unionBags` i2
       , wc_insol = n1 `unionBags` n2 }

addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints
754
addFlats wc wevs = wc { wc_flat = wc_flat wc `unionBags` wevs }
755
756

addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints
757
addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773

instance Outputable WantedConstraints where
  ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n})
   = ptext (sLit "WC") <+> braces (vcat
        [ if isEmptyBag f then empty else
          ptext (sLit "wc_flat =")  <+> pprBag pprWantedEvVar f
        , if isEmptyBag i then empty else
          ptext (sLit "wc_impl =")  <+> pprBag ppr i
        , if isEmptyBag n then empty else
          ptext (sLit "wc_insol =") <+> pprBag ppr n ])

pprBag :: (a -> SDoc) -> Bag a -> SDoc
pprBag pp b = foldrBag (($$) . pp) empty b
\end{code}
 

774
\begin{code}
775
776
777
778
779
780
781
782
783
784
785
786
787
data Untouchables = NoUntouchables
                  | TouchableRange
                          Unique  -- Low end
                          Unique  -- High end
 -- A TcMetaTyvar is *touchable* iff its unique u satisfies
 --   u >= low
 --   u < high

instance Outputable Untouchables where
  ppr NoUntouchables = ptext (sLit "No untouchables")
  ppr (TouchableRange low high) = ptext (sLit "Touchable range:") <+> 
                                  ppr low <+> char '-' <+> ppr high

788
789
790
791
isNoUntouchables :: Untouchables -> Bool
isNoUntouchables NoUntouchables      = True
isNoUntouchables (TouchableRange {}) = False

792
793
794
795
796
797
inTouchableRange :: Untouchables -> TcTyVar -> Bool
inTouchableRange NoUntouchables _ = True
inTouchableRange (TouchableRange low high) tv 
  = uniq >= low && uniq < high
  where
    uniq = varUnique tv
798

799
-- EvVar defined in module Var.lhs:
800
801
802
803
-- Evidence variables include all *quantifiable* constraints
--   dictionaries
--   implicit parameters
--   coercion variables
804
\end{code}
805

806
807
808
809
810
%************************************************************************
%*									*
                Implication constraints
%*                                                                      *
%************************************************************************
811

812
\begin{code}
813
814
data Implication
  = Implic {  
815
      ic_untch :: Untouchables, -- Untouchables: unification variables
816
                                -- free in the environment
817
      ic_env   :: TcTypeEnv,    -- The type environment
818
                                -- Used only when generating error messages
819
	  -- Generally, ic_untch is a superset of tvsof(ic_env)
820
821
	  -- However, we don't zonk ic_env when zonking the Implication
	  -- Instead we do that when generating a skolem-escape error message
822

823
824
      ic_skols  :: TcTyVarSet,   -- Introduced skolems 
      		   	         -- See Note [Skolems in an implication]
825

826
827
      ic_given  :: [EvVar],      -- Given evidence variables
      		   		 --   (order does not matter)
828
829
830
      ic_loc   :: GivenLoc,      -- Binding location of the implication,
                                 --   which is also the location of all the
                                 --   given evidence variables
831

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
832
      ic_wanted :: WantedConstraints,  -- The wanted
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
833
      ic_insol  :: Bool,               -- True iff insolubleWC ic_wanted is true
834

835
836
837
      ic_binds  :: EvBindsVar   -- Points to the place to fill in the
                                -- abstraction and bindings
    }
838

839
840
841
842
843
844
845
846
847
848
849
850
instance Outputable Implication where
  ppr (Implic { ic_untch = untch, ic_skols = skols, ic_given = given
              , ic_wanted = wanted
              , ic_binds = binds, ic_loc = loc })
   = ptext (sLit "Implic") <+> braces 
     (sep [ ptext (sLit "Untouchables = ") <+> ppr untch
          , ptext (sLit "Skolems = ") <+> ppr skols
          , ptext (sLit "Given = ") <+> pprEvVars given
          , ptext (sLit "Wanted = ") <+> ppr wanted
          , ptext (sLit "Binds = ") <+> ppr binds
          , pprSkolInfo (ctLocOrigin loc)
          , ppr (ctLocSpan loc) ])
851
852
\end{code}

853
854
855
856
857
858
Note [Skolems in an implication]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The skolems in an implication are not there to perform a skolem escape
check.  That happens because all the environment variables are in the
untouchables, and therefore cannot be unified with anything at all,
let alone the skolems.
859

860
861
862
Instead, ic_skols is used only when considering floating a constraint
outside the implication in TcSimplify.floatEqualities or 
TcSimplify.approximateImplications
863

864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
Note [Insoluble constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some of the errors that we get during canonicalization are best
reported when all constraints have been simplified as much as
possible. For instance, assume that during simplification the
following constraints arise:
   
 [Wanted]   F alpha ~  uf1 
 [Wanted]   beta ~ uf1 beta 

When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail
we will simply see a message:
    'Can't construct the infinite type  beta ~ uf1 beta' 
and the user has no idea what the uf1 variable is.

Instead our plan is that we will NOT fail immediately, but:
    (1) Record the "frozen" error in the ic_insols field
    (2) Isolate the offending constraint from the rest of the inerts 
    (3) Keep on simplifying/canonicalizing

At the end, we will hopefully have substituted uf1 := F alpha, and we
will be able to report a more informative error:
    'Can't construct the infinite type beta ~ F alpha beta'
Ian Lynagh's avatar
Ian Lynagh committed
887

888
889
890
891
892
%************************************************************************
%*									*
            EvVarX, WantedEvVar, FlavoredEvVar
%*									*
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
893

894
\begin{code}
895
896
897
898
899
900
901
902
903
904
905
906
907
data EvVarX a = EvVarX EvVar a
     -- An evidence variable with accompanying info

type WantedEvVar   = EvVarX WantedLoc     -- The location where it arose
type FlavoredEvVar = EvVarX CtFlavor

instance Outputable (EvVarX a) where
  ppr (EvVarX ev _) = pprEvVarWithType ev
  -- If you want to see the associated info,
  -- use a more specific printing function

mkEvVarX :: EvVar -> a -> EvVarX a
mkEvVarX = EvVarX
Ian Lynagh's avatar
Ian Lynagh committed
908

909
910
evVarOf :: EvVarX a -> EvVar
evVarOf (EvVarX ev _) = ev
Ian Lynagh's avatar
Ian Lynagh committed
911

912
913
914
915
916
917
918
919
920
921
922
evVarX :: EvVarX a -> a
evVarX (EvVarX _ a) = a

evVarOfPred :: EvVarX a -> PredType
evVarOfPred wev = evVarPred (evVarOf wev)

wantedToFlavored :: WantedEvVar -> FlavoredEvVar
wantedToFlavored (EvVarX v wl) = EvVarX v (Wanted wl)

keepWanted :: Bag FlavoredEvVar -> Bag WantedEvVar
keepWanted flevs
923
924
  = foldrBag keep_wanted emptyBag flevs
    -- Important: use fold*r*Bag to preserve the order of the evidence variables.
925
  where
926
927
928
    keep_wanted :: FlavoredEvVar -> Bag WantedEvVar -> Bag WantedEvVar
    keep_wanted (EvVarX ev (Wanted wloc)) r = consBag (EvVarX ev wloc) r
    keep_wanted _                         r = r
929
\end{code}
930
931


932
933
934
935
936
937
938
939
\begin{code}
pprEvVars :: [EvVar] -> SDoc	-- Print with their types
pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars)

pprEvVarTheta :: [EvVar] -> SDoc
pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
                              
pprEvVarWithType :: EvVar -> SDoc
940
pprEvVarWithType v = ppr v <+> dcolon <+> pprPredTy (evVarPred v)
941

942
943
944
945
946
pprWantedsWithLocs :: WantedConstraints -> SDoc
pprWantedsWithLocs wcs
  =  vcat [ pprBag pprWantedEvVarWithLoc (wc_flat wcs)
          , pprBag ppr (wc_impl wcs)
          , pprBag ppr (wc_insol wcs) ]
947
948

pprWantedEvVarWithLoc, pprWantedEvVar :: WantedEvVar -> SDoc
949
950
951
952
pprWantedEvVarWithLoc (EvVarX v loc) = hang (pprEvVarWithType v)
                                          2 (pprArisingAt loc)
pprWantedEvVar        (EvVarX v _)   = pprEvVarWithType v
\end{code}
953

954
955
956
957
958
959
960
961
%************************************************************************
%*									*
            CtLoc
%*									*
%************************************************************************

\begin{code}
data CtFlavor
dimitris's avatar
dimitris committed
962
963
964
965
966
967
968
969
  = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds
  | Derived WantedLoc        -- Derived's are just hints for unifications 
  | Wanted WantedLoc         -- We have no evidence bindings for this constraint. 

data GivenKind
  = GivenOrig   -- Originates in some given, such as signature or pattern match
  | GivenSolved -- Is given as result of being solved, maybe provisionally on
                -- some other wanted constraints. 
970
971

instance Outputable CtFlavor where
dimitris's avatar
dimitris committed
972
973
974
975
976
  ppr (Given _ GivenOrig)   = ptext (sLit "[G]")
  ppr (Given _ GivenSolved) = ptext (sLit "[S]") -- Print [S] for Given/Solved's
  ppr (Wanted {})           = ptext (sLit "[W]")
  ppr (Derived {})          = ptext (sLit "[D]") 

977
pprFlavorArising :: CtFlavor -> SDoc
dimitris's avatar
dimitris committed
978
pprFlavorArising (Derived wl)   = pprArisingAt wl
979
pprFlavorArising (Wanted  wl)   = pprArisingAt wl
dimitris's avatar
dimitris committed
980
pprFlavorArising (Given gl _)   = pprArisingAt gl
981
982
983
984
985

isWanted :: CtFlavor -> Bool
isWanted (Wanted {}) = True
isWanted _           = False

dimitris's avatar
dimitris committed
986
987
988
989
990
991
992
isGivenOrSolved :: CtFlavor -> Bool
isGivenOrSolved (Given {}) = True
isGivenOrSolved _ = False

isGiven_maybe :: CtFlavor -> Maybe GivenKind 
isGiven_maybe (Given _ gk) = Just gk
isGiven_maybe _            = Nothing
993
994
995
996

isDerived :: CtFlavor -> Bool 
isDerived (Derived {}) = True
isDerived _            = False
997
998
999
1000
\end{code}

%************************************************************************
%*									*
1001
            CtLoc
1002
1003
1004
%*									*
%************************************************************************

1005
1006
1007
1008
The 'CtLoc' gives information about where a constraint came from.
This is important for decent error message reporting because
dictionaries don't appear in the original source code.
type will evolve...
1009
1010

\begin{code}
1011
data CtLoc orig = CtLoc orig SrcSpan [ErrCtxt]
1012

1013
1014
1015
type WantedLoc = CtLoc CtOrigin      -- Instantiation for wanted constraints
type GivenLoc  = CtLoc SkolemInfo    -- Instantiation for given constraints

1016
1017
ctLocSpan :: CtLoc o -> SrcSpan
ctLocSpan (CtLoc _ s _) = s
1018

1019
1020
ctLocOrigin :: CtLoc o -> o
ctLocOrigin (CtLoc o _ _) = o
1021

1022
1023
setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
1024

1025
1026
1027
pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig
pushErrCtxt o err (CtLoc _ s errs) = CtLoc o s (err:errs)

1028
pprArising :: CtOrigin -> SDoc
1029
1030
-- Used for the main, top-level error message
-- We've done special processing for TypeEq and FunDep origins
1031
pprArising (TypeEqOrigin {}) = empty
1032
pprArising FunDepOrigin      = empty
1033
pprArising orig              = text "arising from" <+> ppr orig
1034

1035
1036
1037
pprArisingAt :: Outputable o => CtLoc o -> SDoc
pprArisingAt (CtLoc o s _) = sep [ text "arising from" <+> ppr o
                                 , text "at" <+> ppr s]
1038
\end{code}
1039

1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
%************************************************************************
%*                                                                      *
                SkolemInfo
%*                                                                      *
%************************************************************************

\begin{code}
-- SkolemInfo gives the origin of *given* constraints
--   a) type variables are skolemised
--   b) an implication constraint is generated
data SkolemInfo
  = SigSkol UserTypeCtxt	-- A skolem that is created by instantiating
            Type                -- a programmer-supplied type signature
				-- Location of the binding site is on the TyVar

	-- The rest are for non-scoped skolems
  | ClsSkol Class	-- Bound at a class decl
  | InstSkol 		-- Bound at an instance decl
  | DataSkol            -- Bound at a data type declaration
  | FamInstSkol         -- Bound at a family instance decl
  | PatSkol 	        -- An existential type variable bound by a pattern for
      DataCon           -- a data constructor with an existential type.
      (HsMatchContext Name)	
	     --	e.g.   data T = forall a. Eq a => MkT a
	     --        f (MkT x) = ...
	     -- The pattern MkT x will allocate an existential type
	     -- variable for 'a'.  

  | ArrowSkol 	  	-- An arrow form (see TcArrows)

  | IPSkol [IPName Name]  -- Binding site of an implicit parameter

  | RuleSkol RuleName	-- The LHS of a RULE

  | InferSkol [(Name,TcType)]
                        -- We have inferred a type for these (mutually-recursivive)
                        -- polymorphic Ids, and are now checking that their RHS
                        -- constraints are satisfied.

  | BracketSkol         -- Template Haskell bracket

  | UnkSkol             -- Unhelpful info (until I improve it)

instance Outputable SkolemInfo where
  ppr = pprSkolInfo

pprSkolInfo :: SkolemInfo -> SDoc
-- Complete the sentence "is a rigid type variable bound by..."
pprSkolInfo (SigSkol (FunSigCtxt f) ty)
                            = hang (ptext (sLit "the type signature for"))
                                 2 (ppr f <+> dcolon <+> ppr ty)
pprSkolInfo (SigSkol cx ty) = hang (pprUserTypeCtxt cx <> colon)
                                 2 (ppr ty)
pprSkolInfo (IPSkol ips)    = ptext (sLit "the implicit-parameter bindings for")
                              <+> pprWithCommas ppr ips
pprSkolInfo (ClsSkol cls)   = ptext (sLit "the class declaration for") <+> quotes (ppr cls)
pprSkolInfo InstSkol        = ptext (sLit "the instance declaration")
pprSkolInfo DataSkol        = ptext (sLit "the data type declaration")
pprSkolInfo FamInstSkol     = ptext (sLit "the family instance declaration")
pprSkolInfo BracketSkol     = ptext (sLit "a Template Haskell bracket")
pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name)
pprSkolInfo ArrowSkol       = ptext (sLit "the arrow form")
pprSkolInfo (PatSkol dc mc)  = sep [ ptext (sLit "a pattern with constructor")
                                   , nest 2 $ ppr dc <+> dcolon
                                              <+> ppr (dataConUserType dc) <> comma
                                  , ptext (sLit "in") <+> pprMatchContext mc ]
pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of")
                                  , vcat [ ppr name <+> dcolon <+> ppr ty
                                         | (name,ty) <- ids ]]

-- UnkSkol
-- For type variables the others are dealt with by pprSkolTvBinding.  
-- For Insts, these cases should not happen
Simon Peyton Jones's avatar
Simon Peyton Jones committed
1113
pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol")
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
\end{code}


%************************************************************************
%*									*
            CtOrigin
%*									*
%************************************************************************

\begin{code}
1124
1125
1126
1127
-- CtOrigin gives the origin of *wanted* constraints
data CtOrigin
  = OccurrenceOf Name		-- Occurrence of an overloaded identifier
  | AppOrigin	 		-- An application of some kind
1128

1129
  | SpecPragOrigin Name		-- Specialisation pragma for identifier
1130

1131
  | TypeEqOrigin EqOrigin
1132

1133
  | IPOccOrigin  (IPName Name)	-- Occurrence of an implicit parameter
1134

1135
  | LiteralOrigin (HsOverLit Name)	-- Occurrence of a literal
1136
  | NegateOrigin			-- Occurrence of syntactic negation
1137

1138
1139
  | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc
  | PArrSeqOrigin  (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:]
1140
  | SectionOrigin
1141
1142
  | TupleOrigin			       -- (..,..)
  | ExprSigOrigin	-- e :: ty
1143
1144
  | PatSigOrigin	-- p :: ty
  | PatOrigin	        -- Instantiating a polytyped pattern at a constructor
1145
  | RecordUpdOrigin
1146
  | ViewPatOrigin
1147

1148
  | ScOrigin	        -- Typechecking superclasses of an instance declaration
1149
  | DerivOrigin		-- Typechecking deriving
1150
  | StandAloneDerivOrigin -- Typechecking stand-alone deriving
1151
1152
  | DefaultOrigin	-- Typechecking a default decl
  | DoOrigin		-- Arising from a do expression
1153
  | MCompOrigin         -- Arising from a monad comprehension
1154
  | IfOrigin            -- Arising from an if statement
1155
  | ProcOrigin		-- Arising from a proc expression
1156
  | AnnOrigin           -- An annotation
1157
  | FunDepOrigin
1158

1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
data EqOrigin 
  = UnifyOrigin 
       { uo_actual   :: TcType
       , uo_expected :: TcType }

instance Outputable CtOrigin where
  ppr orig = pprO orig

pprO :: CtOrigin -> SDoc
pprO (OccurrenceOf name)   = hsep [ptext (sLit "a use of"), quotes (ppr name)]
pprO AppOrigin             = ptext (sLit "an application")
pprO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)]
pprO (IPOccOrigin name)    = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
pprO RecordUpdOrigin       = ptext (sLit "a record update")
pprO ExprSigOrigin         = ptext (sLit "an expression type signature")
pprO PatSigOrigin          = ptext (sLit "a pattern type signature")
pprO PatOrigin             = ptext (sLit "a pattern")
pprO ViewPatOrigin         = ptext (sLit "a view pattern")
1177
pprO IfOrigin              = ptext (sLit "an if statement")
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
pprO (LiteralOrigin lit)   = hsep [ptext (sLit "the literal"), quotes (ppr lit)]
pprO (ArithSeqOrigin seq)  = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)]
pprO (PArrSeqOrigin seq)   = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)]
pprO SectionOrigin	   = ptext (sLit "an operator section")
pprO TupleOrigin	   = ptext (sLit "a tuple")
pprO NegateOrigin	   = ptext (sLit "a use of syntactic negation")
pprO ScOrigin	           = ptext (sLit "the superclasses of an instance declaration")
pprO DerivOrigin	   = ptext (sLit "the 'deriving' clause of a data type declaration")
pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
pprO DefaultOrigin	   = ptext (sLit "a 'default' declaration")
pprO DoOrigin	           = ptext (sLit "a do statement")
1189
pprO MCompOrigin           = ptext (sLit "a statement in a monad comprehension")
1190
pprO ProcOrigin	           = ptext (sLit "a proc expression")
1191
pprO (TypeEqOrigin eq)     = ptext (sLit "an equality") <+> ppr eq
1192
pprO AnnOrigin             = ptext (sLit "an annotation")
1193
pprO FunDepOrigin          = ptext (sLit "a functional dependency")
1194
1195
1196

instance Outputable EqOrigin where
  ppr (UnifyOrigin t1 t2) = ppr t1 <+> char '~' <+> ppr t2
1197
\end{code}
1198