TcRnTypes.lhs 47.8 KB
Newer Older
1

2
% (c) The University of Glasgow 2006
3
4
% (c) The GRASP Project, Glasgow University, 1992-2002
%
5
6
7
8
9
10
11
12
13
14
15
16
17

Various types used during typechecking, please see TcRnMonad as well for
operations on these types. You probably want to import it, instead of this
module.

All the monads exported here are built on top of the same IOEnv monad. The
monad functions like a Reader monad in the way it passes the environment
around. This is done to allow the environment to be manipulated in a stack
like fashion when entering expressions... ect.

For state that is global and should be returned at the end (e.g not part
of the stack mechanism), you should use an TcRef (= IORef) to store them.

18
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
19
20
21
22
23
24
25
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

26
module TcRnTypes(
27
28
	TcRnIf, TcRn, TcM, RnM,	IfM, IfL, IfG, -- The monad is opaque outside this module
	TcRef,
29
30

	-- The environment types
31
32
	Env(..), 
	TcGblEnv(..), TcLclEnv(..), 
33
	IfGblEnv(..), IfLclEnv(..), 
34
35

	-- Ranamer types
36
	ErrCtxt, RecFieldEnv(..),
37
	ImportAvails(..), emptyImportAvails, plusImportAvails, 
38
	WhereFrom(..), mkModDeps,
39
40

	-- Typechecker types
41
	TcTypeEnv, TcTyThing(..), pprTcTyThingCategory, 
42
43

	-- Template Haskell
44
	ThStage(..), topStage, topAnnStage, topSpliceStage,
45
	ThLevel, impLevel, outerLevel, thLevel,
46

ross's avatar
ross committed
47
	-- Arrows
ross's avatar
ross committed
48
	ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
ross's avatar
ross committed
49

50
	-- Constraints
51
        Untouchables(..), inTouchableRange, isNoUntouchables,
52

53
54
55
56
57
58
59
60
        WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
        andWC, addFlats, addImplics, mkFlatWC,

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

        Implication(..),
61
62
        CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
	CtOrigin(..), EqOrigin(..), 
dimitris's avatar
dimitris committed
63
        WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
64

65
	SkolemInfo(..),
66

dimitris's avatar
dimitris committed
67
68
69
        CtFlavor(..), pprFlavorArising, isWanted, 
        isGivenOrSolved, isGiven_maybe,
        isDerived,
70
        FlavoredEvVar,
71
72

	-- Pretty printing
73
        pprEvVarTheta, pprWantedEvVar, pprWantedsWithLocs,
74
	pprEvVars, pprEvVarWithType,
75
        pprArising, pprArisingAt,
76
77

	-- Misc other types
78
	TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds
79
	
80
81
82
83
  ) where

#include "HsVersions.h"

84
import HsSyn
85
86
import HscTypes
import Type
87
import Class    ( Class )
88
import TyCon    ( TyCon )
89
import DataCon  ( DataCon, dataConUserType )
90
import TcType
91
import Annotations
92
93
import InstEnv
import FamInstEnv
94
import IOEnv
95
96
import RdrName
import Name
97
import NameEnv
98
import NameSet
99
import Avail
100
101
import Var
import VarEnv
102
import Module
103
104
105
import SrcLoc
import VarSet
import ErrUtils
106
import UniqFM
107
import UniqSupply
108
import Unique
109
import BasicTypes
110
111
import Bag
import Outputable
112
import ListSetOps
113
import FastString
114

115
import Data.Set (Set)
116
117
118
119
120
121
122
123
124
125
\end{code}


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

126
The monad itself has to be defined here, because it is mentioned by ErrCtxt
127
128

\begin{code}
129
type TcRef a 	 = IORef a
130
type TcId    	 = Id 			-- Type may be a TcType  DV: WHAT??????????
131
type TcIdSet 	 = IdSet
132

133

134
135
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
136

137
138
139
140
141
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
142
143
\end{code}

144
145
146
147
148
149
150
151
152
153
154
155
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}

156
157

%************************************************************************
158
159
160
%*                                                                      *
                The main environment types
%*                                                                      *
161
162
163
%************************************************************************

\begin{code}
164
165
166
167
-- We 'stack' these envs through the Reader like monad infastructure
-- as we move into an expression (although the change is focused in
-- the lcl type).
data Env gbl lcl
168
  = Env {
169
170
        env_top  :: HscEnv,  -- Top-level stuff that never changes
                             -- Includes all info about imported things
171

172
173
        env_us   :: {-# UNPACK #-} !(IORef UniqSupply),
                             -- Unique supply for local varibles
174

175
176
        env_gbl  :: gbl,     -- Info about things defined at the top level
                             -- of the module being compiled
177

178
        env_lcl  :: lcl      -- Nested stuff; changes as we go into 
179
    }
180
181
182
183

-- 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
184
185
-- For state that needs to be updated during the typechecking
-- phase and returned at end, use a TcRef (= IORef).
186
187
188

data TcGblEnv
  = TcGblEnv {
189
190
191
	tcg_mod     :: Module,         -- ^ Module being compiled
	tcg_src     :: HscSource,
          -- ^ What kind of module (regular Haskell, hs-boot, ext-core)
192

193
194
195
	tcg_rdr_env :: GlobalRdrEnv,   -- ^ Top level envt; used during renaming
	tcg_default :: Maybe [Type],
          -- ^ Types used for defaulting. @Nothing@ => no @default@ decl
196

197
198
	tcg_fix_env   :: FixityEnv,	-- ^ Just for things in this module
	tcg_field_env :: RecFieldEnv,	-- ^ Just for things in this module
199

200
201
202
203
204
205
206
	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)
207

208
	tcg_type_env_var :: TcRef TypeEnv,
209
210
211
212
		-- 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)
213
	
214
215
216
217
	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
218

219
220
221
222
		-- 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.
223
224
225
	tcg_exports :: [AvailInfo],	-- ^ What is exported
	tcg_imports :: ImportAvails,
          -- ^ Information about what was imported from where, including
226
227
	  -- things bound in this module. Also store Safe Haskell info
          -- here about transative trusted packaage requirements.
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256

	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

257
        tcg_th_used :: TcRef Bool,
258
259
          -- ^ @True@ <=> Template Haskell syntax used.
          --
260
261
262
263
          -- 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
264
265
          -- mutable variable.

266
267
268
269
270
        tcg_th_splice_used :: TcRef Bool,
          -- ^ @True@ <=> A Template Haskell splice was used.
          --
          -- Splices disable recompilation avoidance (see #481)

271
272
	tcg_dfun_n  :: TcRef OccSet,
          -- ^ Allows us to choose unique DFun names.
273
274
275
276

	-- 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
277

278
        tcg_rn_exports :: Maybe [Located (IE Name)],
279
280
281
        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
282

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

287
288
289
	tcg_rn_decls :: Maybe (HsGroup Name),
          -- ^ Renamed decls, maybe.  @Nothing@ <=> Don't retain renamed
          -- decls.
290

GregWeber's avatar
GregWeber committed
291
292
    tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile

293
        tcg_ev_binds  :: Bag EvBind,	    -- Top-level evidence bindings
294
	tcg_binds     :: LHsBinds Id,	    -- Value bindings in this module
295
        tcg_sigs      :: NameSet, 	    -- ...Top-level names that *lack* a signature
296
        tcg_imp_specs :: [LTcSpecPrag],     -- ...SPECIALISE prags for imported Ids
Ian Lynagh's avatar
Ian Lynagh committed
297
	tcg_warns     :: Warnings,	    -- ...Warnings and deprecations
298
	tcg_anns      :: [Annotation],      -- ...Annotations
dreixel's avatar
dreixel committed
299
        tcg_tcs       :: [TyCon],           -- ...TyCons and Classes
300
	tcg_insts     :: [Instance],	    -- ...Instances
301
302
303
304
        tcg_fam_insts :: [FamInst],         -- ...Family instances
        tcg_rules     :: [LRuleDecl Id],    -- ...Rules
        tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
        tcg_vects     :: [LVectDecl Id],    -- ...Vectorisation declarations
305

306
	tcg_doc_hdr   :: Maybe LHsDocString, -- ^ Maybe Haddock header docs
307
308
309
        tcg_hpc       :: AnyHpcUsage,        -- ^ @True@ if any part of the
                                             --  prog uses hpc instrumentation.

310
        tcg_main      :: Maybe Name,         -- ^ The Name of the main
311
312
                                             -- function, if this module is
                                             -- the main module.
313
314
        tcg_safeInfer :: TcRef Bool          -- Has the typechecker infered this
                                             -- module as -XSafe (Safe Haskell)
315
    }
316

317
318
319
320
321
322
323
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 {..}
324
325
	-- This is used when dealing with ".." notation in record 
	-- construction and pattern matching.
326
	-- The FieldEnv deals *only* with constructors defined in *this*
Thomas Schilling's avatar
Thomas Schilling committed
327
328
	-- module.  For imported modules, we get the same info from the
	-- TypeEnv
329
330
\end{code}

331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
%************************************************************************
%*									*
		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.
346
	if_rec_types :: Maybe (Module, IfG TypeEnv)
347
348
349
350
351
352
353
354
355
356
		-- 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
357
	if_mod :: Module,
358

359
360
361
362
363
364
365
	-- 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

366
	if_tv_env  :: UniqFM TyVar,	-- Nested tyvar bindings
367
		      	     		-- (and coercions)
368
	if_id_env  :: UniqFM Id		-- Nested id binding
369
370
371
    }
\end{code}

372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394

%************************************************************************
%*									*
		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}
395
396
data TcLclEnv		-- Changes as we move inside an expression
			-- Discarded after typecheck/rename; not passed on to desugarer
397
  = TcLclEnv {
398
	tcl_loc  :: SrcSpan,		-- Source span
399
	tcl_ctxt :: [ErrCtxt],		-- Error context, innermost on top
400
	tcl_errs :: TcRef Messages,	-- Place to accumulate errors
401

402
403
	tcl_th_ctxt    :: ThStage,	      -- Template Haskell context
	tcl_arrow_ctxt :: ArrowCtxt,	      -- Arrow-notation context
404

405
	tcl_rdr :: LocalRdrEnv,		-- Local name envt
406
407
408
409
		-- 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.
		-- 
410
411
412
413
		--   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)
414
415
416
		-- We still need the unsullied global name env so that
    		--   we can look up record field names

417
418
	tcl_env  :: TcTypeEnv,    -- The local type environment: Ids and
			          -- TyVars defined in this module
419
420
					
	tcl_tyvars :: TcRef TcTyVarSet,	-- The "global tyvars"
421
			-- Namely, the in-scope TyVars bound in tcl_env, 
422
423
424
425
			-- plus the tyvars mentioned in the types of Ids bound
			-- in tcl_lenv. 
                        -- Why mutable? see notes with tcGetGlobalTyVars

426
	tcl_lie   :: TcRef WantedConstraints,    -- Place to accumulate type constraints
427
428
429
430
431
432
433

	-- 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
434
435
    }

436
437
type TcTypeEnv = NameEnv TcTyThing

438

439
440
441
442
443
444
445
446
447
448
449
450
451
{- 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.

-}
452

453
---------------------------
454
-- Template Haskell stages and levels 
455
456
---------------------------

457
458
459
460
461
462
463
464
465
466
467
468
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
469
      (TcRef WantedConstraints)	--     and type constraints here
470
471
472
473
474
475
476
477
478
479
480

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)

481
type ThLevel = Int	
482
        -- See Note [Template Haskell levels] in TcSplice
483
484
	-- Incremented when going inside a bracket,
	-- decremented when going inside a splice
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
485
	-- NB: ThLevel is one greater than the 'n' in Fig 2 of the
486
	--     original "Template meta-programming for Haskell" paper
487

488
impLevel, outerLevel :: ThLevel
489
impLevel = 0	-- Imported things; they can be used inside a top level splice
490
491
492
outerLevel = 1	-- Things defined outside brackets
-- NB: Things at level 0 are not *necessarily* imported.
--	eg  $( \b -> ... )   here b is bound at level 0
493
494
495
496
497
498
--
-- For example: 
--	f = ...
--	g1 = $(map ...)		is OK
--	g2 = $(f ...)		is not OK; because we havn't compiled f yet

499
500
501
502
thLevel :: ThStage -> ThLevel
thLevel Splice        = 0
thLevel Comp          = 1
thLevel (Brack s _ _) = thLevel s + 1
503

ross's avatar
ross committed
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
---------------------------
-- 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
527
528
529
data ArrowCtxt
  = NoArrowCtxt
  | ArrowCtxt (Env TcGblEnv TcLclEnv)
ross's avatar
ross committed
530
531
532
533
534
535
536
537
538

-- 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
539
540
541
542
escapeArrowScope
  = updEnv $ \ env -> case tcl_arrow_ctxt (env_lcl env) of
	NoArrowCtxt -> env
	ArrowCtxt env' -> env'
543

544
545
546
547
---------------------------
-- TcTyThing
---------------------------

548
data TcTyThing
549
  = AGlobal TyThing		-- Used only in the return type of a lookup
550

551
  | ATcId   {		-- Ids defined in this module; may not be fully zonked
552
553
554
	tct_id     :: TcId,		
	tct_closed :: TopLevelFlag,   -- See Note [Bindings with closed types]
	tct_level  :: ThLevel }
555

556
557
  | ATyVar  Name TcType		-- The type to which the lexically scoped type vaiable
				-- is currently refined. We only need the Name
558
559
				-- for error-message purposes; it is the corresponding
				-- Name in the domain of the envt
560

dreixel's avatar
dreixel committed
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
  | AThing  TcKind   -- Used temporarily, during kind checking, for the
		     --	tycons and clases in this recursive group
                     -- Can be a mono-kind or a poly-kind; in TcTyClsDcls see
                     -- Note [Type checking recursive type and class declarations]

  | ANothing                    -- see Note [ANothing]

{-
Note [ANothing]
~~~~~~~~~~~~~~~

We don't want to allow promotion in a strongly connected component
when kind checking.

Consider:
  data T f = K (f (K Any))

When kind checking the `data T' declaration the local env contains the
mappings:
  T -> AThing <some initial kind>
  K -> ANothing

ANothing is only used for DataCons, and only used during type checking
in tcTyClGroup.
-}

587
588

instance Outputable TcTyThing where	-- Debugging only
589
   ppr (AGlobal g)      = pprTyThing g
590
   ppr elt@(ATcId {})   = text "Identifier" <> 
591
592
			  brackets (ppr (tct_id elt) <> dcolon 
                                 <> ppr (varType (tct_id elt)) <> comma
593
				 <+> ppr (tct_closed elt) <> comma
594
				 <+> ppr (tct_level elt))
595
   ppr (ATyVar tv _)    = text "Type variable" <+> quotes (ppr tv)
596
   ppr (AThing k)       = text "AThing" <+> ppr k
dreixel's avatar
dreixel committed
597
   ppr ANothing         = text "ANothing"
598
599
600

pprTcTyThingCategory :: TcTyThing -> SDoc
pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing
Ian Lynagh's avatar
Ian Lynagh committed
601
602
603
pprTcTyThingCategory (ATyVar {})     = ptext (sLit "Type variable")
pprTcTyThingCategory (ATcId {})      = ptext (sLit "Local identifier")
pprTcTyThingCategory (AThing {})     = ptext (sLit "Kinded thing")
dreixel's avatar
dreixel committed
604
pprTcTyThingCategory ANothing        = ptext (sLit "Opaque thing")
605
606
\end{code}

607
608
Note [Bindings with closed types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
609
610
611
612
613
614
Consider

  f x = let g ys = map not ys
        in ...

Can we generalise 'g' under the OutsideIn algorithm?  Yes, 
dreixel's avatar
dreixel committed
615
because all g's free variables are top-level; that is they themselves
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
have no free type variables, and it is the type variables in the
environment that makes things tricky for OutsideIn generalisation.

Definition:

   A variable is "closed", and has tct_closed set to TopLevel,
      iff 
   a) all its free variables are imported, or are themselves closed
   b) generalisation is not restricted by the monomorphism restriction

Under OutsideIn we are free to generalise a closed let-binding.
This is an extension compared to the JFP paper on OutsideIn, which
used "top-level" as a proxy for "closed".  (It's not a good proxy 
anyway -- the MR can make a top-level binding with a free type
variable.)

Note that:
  * A top-level binding may not be closed, if it suffer from the MR

  * A nested binding may be closed (eg 'g' in the example we started with)
    Indeed, that's the point; whether a function is defined at top level
    or nested is orthogonal to the question of whether or not it is closed 

  * A binding may be non-closed because it mentions a lexically scoped
    *type variable*  Eg
        f :: forall a. blah
        f x = let g y = ...(y::a)...

644

645
\begin{code}
646
647
648
649
650
651
652
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
653
654
655
656
657
658
659
660
661
662
\end{code}


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

\begin{code}
663
664
665
666
667
668
669
670
671
672
673
674
-- | '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
--
675
676
data ImportAvails 
   = ImportAvails {
677
678
	imp_mods :: ImportedMods,
	  --      = ModuleEnv [(ModuleName, Bool, SrcSpan, Bool)],
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
          -- ^ 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).
704

705
706
707
708
709
710
711
712
713
714
715
        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],
716
717
718
          -- ^ Packages needed by the module being compiled, whether directly,
          -- or via other modules in this package, or via modules imported
          -- from other packages.
719
720
721
722
723
724
725
726
727
728
        
        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.
729
          -- See Note [RnNames . Tracking Trust Transitively]
730

731
732
733
734
735
736
737
        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],
738
739
          -- ^ Orphan modules below us in the import tree (and maybe including
          -- us for imported modules)
740

741
        imp_finsts :: [Module]
742
743
          -- ^ Family instance modules below us in the import tree (and maybe
          -- including us for imported modules)
744
745
      }

Simon Marlow's avatar
Simon Marlow committed
746
747
748
mkModDeps :: [(ModuleName, IsBootInterface)]
	  -> ModuleNameEnv (ModuleName, IsBootInterface)
mkModDeps deps = foldl add emptyUFM deps
749
	       where
Simon Marlow's avatar
Simon Marlow committed
750
		 add env elt@(m,_) = addToUFM env m elt
751

752
emptyImportAvails :: ImportAvails
753
754
755
756
757
758
759
760
761
762
763
764
765
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.
766
767
plusImportAvails ::  ImportAvails ->  ImportAvails ->  ImportAvails
plusImportAvails
768
  (ImportAvails { imp_mods = mods1,
769
770
                  imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,
                  imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1,
771
772
                  imp_orphs = orphs1, imp_finsts = finsts1 })
  (ImportAvails { imp_mods = mods2,
773
774
                  imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
                  imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2,
775
                  imp_orphs = orphs2, imp_finsts = finsts2 })
776
777
778
779
780
781
782
  = 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 }
783
  where
784
    plus_mod_dep (m1, boot1) (m2, boot2) 
785
786
787
        = 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
788
789
790
791
792
793
794
795
796
797
798
799
800
\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 #-})
801
  | ImportBySystem			-- Non user import.
802
803

instance Outputable WhereFrom where
Ian Lynagh's avatar
Ian Lynagh committed
804
  ppr (ImportByUser is_boot) | is_boot     = ptext (sLit "{- SOURCE -}")
805
			     | otherwise   = empty
Ian Lynagh's avatar
Ian Lynagh committed
806
  ppr ImportBySystem     		   = ptext (sLit "{- SYSTEM -}")
807
808
809
810
811
\end{code}


%************************************************************************
%*									*
812
813
814
815
816
817
		Wanted constraints
     These are forced to be in TcRnTypes because
     	   TcLclEnv mentions WantedConstraints
	   WantedConstraint mentions CtLoc
	   CtLoc mentions ErrCtxt
	   ErrCtxt mentions TcM
818
819
820
%*									*
v%************************************************************************

821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
\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
853
addFlats wc wevs = wc { wc_flat = wc_flat wc `unionBags` wevs }
854
855

addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints
856
addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872

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}
 

873
\begin{code}
874
875
876
877
878
879
880
881
882
883
884
885
886
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

887
888
889
890
isNoUntouchables :: Untouchables -> Bool
isNoUntouchables NoUntouchables      = True
isNoUntouchables (TouchableRange {}) = False

891
892
893
894
895
896
inTouchableRange :: Untouchables -> TcTyVar -> Bool
inTouchableRange NoUntouchables _ = True
inTouchableRange (TouchableRange low high) tv 
  = uniq >= low && uniq < high
  where
    uniq = varUnique tv
897

898
-- EvVar defined in module Var.lhs:
899
900
901
902
-- Evidence variables include all *quantifiable* constraints
--   dictionaries
--   implicit parameters
--   coercion variables
903
\end{code}
904

905
906
907
908
909
%************************************************************************
%*									*
                Implication constraints
%*                                                                      *
%************************************************************************
910

911
\begin{code}
912
913
data Implication
  = Implic {  
914
      ic_untch :: Untouchables, -- Untouchables: unification variables
915
                                -- free in the environment
916
      ic_env   :: TcTypeEnv,    -- The type environment
917
                                -- Used only when generating error messages
918
	  -- Generally, ic_untch is a superset of tvsof(ic_env)
919
920
	  -- However, we don't zonk ic_env when zonking the Implication
	  -- Instead we do that when generating a skolem-escape error message
921

922
923
      ic_skols  :: TcTyVarSet,   -- Introduced skolems 
      		   	         -- See Note [Skolems in an implication]
924

925
926
      ic_given  :: [EvVar],      -- Given evidence variables
      		   		 --   (order does not matter)
927
928
929
      ic_loc   :: GivenLoc,      -- Binding location of the implication,
                                 --   which is also the location of all the
                                 --   given evidence variables
930

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
931
      ic_wanted :: WantedConstraints,  -- The wanted
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
932
      ic_insol  :: Bool,               -- True iff insolubleWC ic_wanted is true
933

934
935
936
      ic_binds  :: EvBindsVar   -- Points to the place to fill in the
                                -- abstraction and bindings
    }
937

938
939
940
941
942
943
944
945
946
947
948
949
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) ])
950
951
\end{code}

952
953
954
955
956
957
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.
958

959
960
961
Instead, ic_skols is used only when considering floating a constraint
outside the implication in TcSimplify.floatEqualities or 
TcSimplify.approximateImplications
962

963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
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
986

987
988
989
990
991
%************************************************************************
%*									*
            EvVarX, WantedEvVar, FlavoredEvVar
%*									*
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
992

993
\begin{code}
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
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
1007

1008
1009
evVarOf :: EvVarX a -> EvVar
evVarOf (EvVarX ev _) = ev
Ian Lynagh's avatar
Ian Lynagh committed
1010

1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
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
1022
1023
  = foldrBag keep_wanted emptyBag flevs
    -- Important: use fold*r*Bag to preserve the order of the evidence variables.
1024
  where
1025
1026
1027
    keep_wanted :: FlavoredEvVar -> Bag WantedEvVar -> Bag WantedEvVar
    keep_wanted (EvVarX ev (Wanted wloc)) r = consBag (EvVarX ev wloc) r
    keep_wanted _                         r = r
1028
\end{code}
1029
1030


1031
1032
1033
1034
1035
1036
1037
1038
\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
batterseapower's avatar
batterseapower committed
1039
pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v)
1040

1041
1042
1043
1044
1045
pprWantedsWithLocs :: WantedConstraints -> SDoc
pprWantedsWithLocs wcs
  =  vcat [ pprBag pprWantedEvVarWithLoc (wc_flat wcs)
          , pprBag ppr (wc_impl wcs)
          , pprBag ppr (wc_insol wcs) ]
1046
1047

pprWantedEvVarWithLoc, pprWantedEvVar :: WantedEvVar -> SDoc
1048
1049
1050
1051
pprWantedEvVarWithLoc (EvVarX v loc) = hang (pprEvVarWithType v)
                                          2 (pprArisingAt loc)
pprWantedEvVar        (EvVarX v _)   = pprEvVarWithType v
\end{code}
1052

1053
1054
1055
1056
1057
1058
1059
1060
%************************************************************************
%*									*
            CtLoc
%*									*
%************************************************************************

\begin{code}
data CtFlavor
dimitris's avatar
dimitris committed
1061
1062
1063
1064
1065
1066
1067
1068
  = 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. 
1069
1070

instance Outputable CtFlavor where
dimitris's avatar
dimitris committed
1071
1072
1073
1074
1075
  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]") 

1076
pprFlavorArising :: CtFlavor -> SDoc
dimitris's avatar
dimitris committed
1077
pprFlavorArising (Derived wl)   = pprArisingAt wl
1078
pprFlavorArising (Wanted  wl)   = pprArisingAt wl
dimitris's avatar
dimitris committed
1079
pprFlavorArising (Given gl _)   = pprArisingAt gl
1080
1081
1082
1083
1084

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

dimitris's avatar
dimitris committed
1085
1086
1087
1088
1089
1090
1091
isGivenOrSolved :: CtFlavor -> Bool
isGivenOrSolved (Given {}) = True
isGivenOrSolved _ = False

isGiven_maybe :: CtFlavor -> Maybe GivenKind 
isGiven_maybe (Given _ gk) = Just gk
isGiven_maybe _            = Nothing
1092
1093
1094
1095

isDerived :: CtFlavor -> Bool 
isDerived (Derived {}) = True
isDerived _            = False
1096
1097
1098
1099
\end{code}

%************************************************************************
%*									*
1100
            CtLoc
1101
1102
1103
%*									*
%************************************************************************

1104
1105
1106
1107
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...
1108
1109

\begin{code}
1110
data CtLoc orig = CtLoc orig SrcSpan [ErrCtxt]
1111

1112
1113
1114
type WantedLoc = CtLoc CtOrigin      -- Instantiation for wanted constraints
type GivenLoc  = CtLoc SkolemInfo    -- Instantiation for given constraints

1115
1116
ctLocSpan :: CtLoc o -> SrcSpan
ctLocSpan (CtLoc _ s _) = s
1117

1118
1119
ctLocOrigin :: CtLoc o -> o
ctLocOrigin (CtLoc o _ _) = o
1120

1121
1122
setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
1123

1124
1125
1126
pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig
pushErrCtxt o err (CtLoc _ s errs) = CtLoc o s (err:errs)

1127
pprArising :: CtOrigin -> SDoc
1128
1129
-- Used for the main, top-level error message
-- We've done special processing for TypeEq and FunDep origins
1130
pprArising (TypeEqOrigin {}) = empty
1131
pprArising FunDepOrigin      = empty
1132
pprArising orig              = text "arising from" <+> ppr orig
1133

1134
1135
1136
pprArisingAt :: Outputable o => CtLoc o -> SDoc
pprArisingAt (CtLoc o s _) = sep [ text "arising from" <+> ppr o
                                 , text "at" <+> ppr s]
1137
\end{code}
1138

1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
%************************************************************************
%*                                                                      *
                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
1212
pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol")
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
\end{code}


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

\begin{code}
1223
1224
1225
1226
-- CtOrigin gives the origin of *wanted* constraints
data CtOrigin
  = OccurrenceOf Name		-- Occurrence of an overloaded identifier
  | AppOrigin	 		-- An application of some kind
1227

1228
  | SpecPragOrigin Name		-- Specialisation pragma for identifier
1229

1230
  | TypeEqOrigin EqOrigin
1231

1232
  | IPOccOrigin  (IPName Name)	-- Occurrence of an implicit parameter
1233

1234
  | LiteralOrigin (HsOverLit Name)	-- Occurrence of a literal
1235
  | NegateOrigin			-- Occurrence of syntactic negation
1236

1237
1238
  | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc
  | PArrSeqOrigin  (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:]
1239
  | SectionOrigin
1240
  | TupleOrigin			       -- (..,..)
1241
  | AmbigOrigin Name	-- f :: ty
1242
  | ExprSigOrigin	-- e :: ty
1243
1244
  | PatSigOrigin	-- p :: ty
  | PatOrigin	        -- Instantiating a polytyped pattern at a constructor
1245
  | RecordUpdOrigin
1246
  | ViewPatOrigin
1247

1248
  | ScOrigin	        -- Typechecking superclasses of an instance declaration
1249
  | DerivOrigin		-- Typechecking deriving
1250
  | StandAloneDerivOrigin -- Typechecking stand-alone deriving
1251
1252
  | DefaultOrigin	-- Typechecking a default decl
  | DoOrigin		-- Arising from a do expression
1253
  | MCompOrigin         -- Arising from a monad comprehension
1254
  | IfOrigin            -- Arising from an if statement
1255
  | ProcOrigin		-- Arising from a proc expression
1256
  | AnnOrigin           -- An annotation
1257
  | FunDepOrigin
1258

1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
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")
1273
pprO (AmbigOrigin name)    = ptext (sLit "the ambiguity check for") <+> quotes (ppr name)
1274
1275
1276
1277
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")
1278
pprO IfOrigin              = ptext (sLit "an if statement")
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
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")
1290
pprO MCompOrigin           = ptext (sLit "a statement in a monad comprehension")
1291
pprO ProcOrigin	           = ptext (sLit "a proc expression")
1292
pprO (TypeEqOrigin eq)     = ptext (sLit "an equality") <+> ppr eq
1293
pprO AnnOrigin             = ptext (sLit "an annotation")
1294
pprO FunDepOrigin          = ptext (sLit "a functional dependency")
1295
1296
1297

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