Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
[ghc.git] / compiler / hsSyn / HsBinds.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
6
7 Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
8
9 \begin{code}
10 {-# OPTIONS -fno-warn-tabs #-}
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and
13 -- detab the module (please do the detabbing in a separate patch). See
14 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
15 -- for details
16
17 {-# LANGUAGE DeriveDataTypeable #-}
18
19 module HsBinds where
20
21 import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, 
22                                MatchGroup, pprFunBind,
23                                GRHSs, pprPatBind )
24 import {-# SOURCE #-} HsPat  ( LPat )
25
26 import HsLit
27 import HsTypes
28 import PprCore ()
29 import CoreSyn
30 import TcEvidence
31 import Type
32 import Name
33 import NameSet
34 import BasicTypes
35 import Outputable       
36 import SrcLoc
37 import Var
38 import Bag
39 import FastString
40
41 import Data.Data hiding ( Fixity )
42 import Data.List
43 import Data.Ord
44 \end{code}
45
46 %************************************************************************
47 %*                                                                      *
48 \subsection{Bindings: @BindGroup@}
49 %*                                                                      *
50 %************************************************************************
51
52 Global bindings (where clauses)
53
54 \begin{code}
55 -- During renaming, we need bindings where the left-hand sides
56 -- have been renamed but the the right-hand sides have not.
57 -- the ...LR datatypes are parametrized by two id types,
58 -- one for the left and one for the right.
59 -- Other than during renaming, these will be the same.
60
61 type HsLocalBinds id = HsLocalBindsLR id id
62
63 data HsLocalBindsLR idL idR    -- Bindings in a 'let' expression
64                                -- or a 'where' clause
65   = HsValBinds (HsValBindsLR idL idR)
66   | HsIPBinds  (HsIPBinds idR)
67   | EmptyLocalBinds
68   deriving (Data, Typeable)
69
70 type HsValBinds id = HsValBindsLR id id
71
72 data HsValBindsLR idL idR  -- Value bindings (not implicit parameters)
73   = ValBindsIn             -- Before renaming RHS; idR is always RdrName
74         (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
75                                         -- Recursive by default
76
77   | ValBindsOut            -- After renaming RHS; idR can be Name or Id
78         [(RecFlag, LHsBinds idL)]       -- Dependency analysed, later bindings
79                                         -- in the list may depend on earlier
80                                         -- ones.
81         [LSig Name]
82   deriving (Data, Typeable)
83
84 type LHsBind  id = LHsBindLR  id id
85 type LHsBinds id = LHsBindsLR id id
86 type HsBind   id = HsBindLR   id id
87
88 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
89 type LHsBindLR  idL idR = Located (HsBindLR idL idR)
90
91 data HsBindLR idL idR
92   = -- | FunBind is used for both functions   @f x = e@
93     -- and variables                          @f = \x -> e@
94     --
95     -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
96     --
97     -- Reason 2: Instance decls can only have FunBinds, which is convenient.
98     --           If you change this, you'll need to change e.g. rnMethodBinds
99     --
100     -- But note that the form                 @f :: a->a = ...@
101     -- parses as a pattern binding, just like
102     --                                        @(f :: a -> a) = ... @
103     FunBind {
104
105         fun_id :: Located idL,
106
107         fun_infix :: Bool,      -- ^ True => infix declaration
108
109         fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload
110
111         fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
112                                 -- the Id.  Example:
113                                 -- @
114                                 --      f :: Int -> forall a. a -> a
115                                 --      f x y = y
116                                 -- @
117                                 -- Then the MatchGroup will have type (Int -> a' -> a')
118                                 -- (with a free type variable a').  The coercion will take
119                                 -- a CoreExpr of this type and convert it to a CoreExpr of
120                                 -- type         Int -> forall a'. a' -> a'
121                                 -- Notice that the coercion captures the free a'.
122
123         bind_fvs :: NameSet,    -- ^ After the renamer, this contains the locally-bound
124                                 -- free variables of this defn.
125                                 -- See Note [Bind free vars]
126
127
128         fun_tick :: Maybe (Tickish Id)  -- ^ Tick to put on the rhs, if any
129     }
130
131   | PatBind {   -- The pattern is never a simple variable;
132                 -- That case is done by FunBind
133         pat_lhs    :: LPat idL,
134         pat_rhs    :: GRHSs idR (LHsExpr idR),
135         pat_rhs_ty :: PostTcType,       -- Type of the GRHSs
136         bind_fvs   :: NameSet,          -- See Note [Bind free vars]
137         pat_ticks  :: (Maybe (Tickish Id), [Maybe (Tickish Id)])
138                -- ^ Tick to put on the rhs, if any, and ticks to put on
139                -- the bound variables.
140     }
141
142   | VarBind {   -- Dictionary binding and suchlike
143         var_id     :: idL,           -- All VarBinds are introduced by the type checker
144         var_rhs    :: LHsExpr idR,   -- Located only for consistency
145         var_inline :: Bool           -- True <=> inline this binding regardless
146                                      -- (used for implication constraints only)
147     }
148
149   | AbsBinds {                          -- Binds abstraction; TRANSLATION
150         abs_tvs     :: [TyVar],
151         abs_ev_vars :: [EvVar],  -- Includes equality constraints
152
153        -- AbsBinds only gets used when idL = idR after renaming,
154        -- but these need to be idL's for the collect... code in HsUtil
155        -- to have the right type
156         abs_exports :: [ABExport idL],
157
158         abs_ev_binds :: TcEvBinds,     -- Evidence bindings
159         abs_binds    :: LHsBinds idL   -- Typechecked user bindings
160     }
161
162   deriving (Data, Typeable)
163         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
164         --
165         -- Creates bindings for (polymorphic, overloaded) poly_f
166         -- in terms of monomorphic, non-overloaded mono_f
167         --
168         -- Invariants:
169         --      1. 'binds' binds mono_f
170         --      2. ftvs is a subset of tvs
171         --      3. ftvs includes all tyvars free in ds
172         --
173         -- See section 9 of static semantics paper for more details.
174         -- (You can get a PhD for explaining the True Meaning
175         --  of this last construct.)
176
177 data ABExport id
178   = ABE { abe_poly  :: id           -- Any INLINE pragmas is attached to this Id
179         , abe_mono  :: id
180         , abe_wrap  :: HsWrapper    -- See Note [AbsBinds wrappers]
181              -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
182         , abe_prags :: TcSpecPrags  -- SPECIALISE pragmas
183   } deriving (Data, Typeable)
184
185 placeHolderNames :: NameSet
186 -- Used for the NameSet in FunBind and PatBind prior to the renamer
187 placeHolderNames = panic "placeHolderNames"
188 \end{code}
189
190 Note [AbsBinds wrappers]
191 ~~~~~~~~~~~~~~~~~~~~~~~~
192 Consdider
193    (f,g) = (\x.x, \y.y)
194 This ultimately desugars to something like this:
195    tup :: forall a b. (a->a, b->b)
196    tup = /\a b. (\x:a.x, \y:b.y)
197    f :: forall a. a -> a
198    f = /\a. case tup a Any of
199                (fm::a->a,gm:Any->Any) -> fm
200    ...similarly for g...
201
202 The abe_wrap field deals with impedence-matching between
203     (/\a b. case tup a b of { (f,g) -> f })
204 and the thing we really want, which may have fewer type
205 variables.  The action happens in TcBinds.mkExport.
206
207 Note [Bind free vars]
208 ~~~~~~~~~~~~~~~~~~~~~
209 The bind_fvs field of FunBind and PatBind records the free variables
210 of the definition.  It is used for two purposes
211
212 a) Dependency analysis prior to type checking
213     (see TcBinds.tc_group)
214
215 b) Deciding whether we can do generalisation of the binding
216     (see TcBinds.decideGeneralisationPlan)
217
218 Specifically,
219
220   * bind_fvs includes all free vars that are defined in this module
221     (including top-level things and lexically scoped type variables)
222
223   * bind_fvs excludes imported vars; this is just to keep the set smaller
224
225   * Before renaming, and after typechecking, the field is unused;
226     it's just an error thunk
227
228 \begin{code}
229 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
230   ppr (HsValBinds bs) = ppr bs
231   ppr (HsIPBinds bs)  = ppr bs
232   ppr EmptyLocalBinds = empty
233
234 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
235   ppr (ValBindsIn binds sigs)
236    = pprDeclList (pprLHsBindsForUser binds sigs)
237
238   ppr (ValBindsOut sccs sigs)
239     = getPprStyle $ \ sty ->
240       if debugStyle sty then    -- Print with sccs showing
241         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
242      else
243         pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)
244    where
245      ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
246      pp_rec Recursive    = ptext (sLit "rec")
247      pp_rec NonRecursive = ptext (sLit "nonrec")
248
249 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
250 pprLHsBinds binds
251   | isEmptyLHsBinds binds = empty
252   | otherwise = pprDeclList (map ppr (bagToList binds))
253
254 pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
255                    => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
256 --  pprLHsBindsForUser is different to pprLHsBinds because
257 --  a) No braces: 'let' and 'where' include a list of HsBindGroups
258 --     and we don't want several groups of bindings each
259 --     with braces around
260 --  b) Sort by location before printing
261 --  c) Include signatures
262 pprLHsBindsForUser binds sigs
263   = map snd (sort_by_loc decls)
264   where
265
266     decls :: [(SrcSpan, SDoc)]
267     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
268             [(loc, ppr bind) | L loc bind <- bagToList binds]
269
270     sort_by_loc decls = sortBy (comparing fst) decls
271
272 pprDeclList :: [SDoc] -> SDoc   -- Braces with a space
273 -- Print a bunch of declarations
274 -- One could choose  { d1; d2; ... }, using 'sep'
275 -- or      d1
276 --         d2
277 --         ..
278 --    using vcat
279 -- At the moment we chose the latter
280 -- Also we do the 'pprDeeperList' thing.
281 pprDeclList ds = pprDeeperList vcat ds
282
283 ------------
284 emptyLocalBinds :: HsLocalBindsLR a b
285 emptyLocalBinds = EmptyLocalBinds
286
287 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
288 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
289 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
290 isEmptyLocalBinds EmptyLocalBinds = True
291
292 isEmptyValBinds :: HsValBindsLR a b -> Bool
293 isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
294 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
295
296 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
297 emptyValBindsIn  = ValBindsIn emptyBag []
298 emptyValBindsOut = ValBindsOut []      []
299
300 emptyLHsBinds :: LHsBindsLR idL idR
301 emptyLHsBinds = emptyBag
302
303 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
304 isEmptyLHsBinds = isEmptyBag
305
306 ------------
307 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
308 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
309   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
310 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
311   = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
312 plusHsValBinds _ _
313   = panic "HsBinds.plusHsValBinds"
314
315 getTypeSigNames :: HsValBinds a -> NameSet
316 -- Get the names that have a user type sig
317 getTypeSigNames (ValBindsOut _ sigs)
318   = mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names]
319 getTypeSigNames _
320   = panic "HsBinds.getTypeSigNames"
321 \end{code}
322
323 What AbsBinds means
324 ~~~~~~~~~~~~~~~~~~~
325          AbsBinds tvs
326                   [d1,d2]
327                   [(tvs1, f1p, f1m),
328                    (tvs2, f2p, f2m)]
329                   BIND
330 means
331
332         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
333                                      in fm
334
335         gp = ...same again, with gm instead of fm
336
337 This is a pretty bad translation, because it duplicates all the bindings.
338 So the desugarer tries to do a better job:
339
340         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
341                                         (fm,gm) -> fm
342         ..ditto for gp..
343
344         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
345                                       in (fm,gm)
346
347 \begin{code}
348 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
349     ppr mbind = ppr_monobind mbind
350
351 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
352
353 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
354   = pprPatBind pat grhss
355 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
356   = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
357 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
358                         fun_co_fn = wrap,
359                         fun_matches = matches,
360                         fun_tick = tick })
361   = pprTicks empty (case tick of
362                         Nothing -> empty
363                         Just t  -> text "-- tick id = " <> ppr t)
364     $$  ifPprDebug (pprBndr LetBind (unLoc fun))
365     $$  pprFunBind (unLoc fun) inf matches
366     $$  ifPprDebug (ppr wrap)
367
368 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
369                        , abs_exports = exports, abs_binds = val_binds
370                        , abs_ev_binds = ev_binds })
371   = hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars) 
372                                   <+> brackets (interpp'SP dictvars))
373        2 $ braces $ vcat 
374     [ ptext (sLit "Exports:") <+> brackets (sep (punctuate comma (map ppr exports)))
375     , ptext (sLit "Exported types:") <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
376     , ptext (sLit "Binds:") <+> pprLHsBinds val_binds
377     , ifPprDebug (ptext (sLit "Evidence:") <+> ppr ev_binds) ]
378
379 instance (OutputableBndr id) => Outputable (ABExport id) where
380   ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
381     = vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl
382            , nest 2 (pprTcSpecPrags prags)
383            , nest 2 (ppr wrap)]
384 \end{code}
385
386
387 \begin{code}
388 pprTicks :: SDoc -> SDoc -> SDoc
389 -- Print stuff about ticks only when -dppr-debug is on, to avoid
390 -- them appearing in error messages (from the desugarer); see Trac # 3263
391 -- Also print ticks in dumpStyle, so that -ddump-hpc actually does
392 -- something useful.
393 pprTicks pp_no_debug pp_when_debug
394   = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty
395                              then pp_when_debug
396                              else pp_no_debug)
397 \end{code}
398
399 %************************************************************************
400 %*                                                                      *
401                 Implicit parameter bindings
402 %*                                                                      *
403 %************************************************************************
404
405 \begin{code}
406 data HsIPBinds id
407   = IPBinds
408         [LIPBind id]
409         TcEvBinds       -- Only in typechecker output; binds
410                         -- uses of the implicit parameters
411   deriving (Data, Typeable)
412
413 isEmptyIPBinds :: HsIPBinds id -> Bool
414 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
415
416 type LIPBind id = Located (IPBind id)
417
418 -- | Implicit parameter bindings.
419 {- These bindings start off as (Left "x") in the parser and stay
420 that way until after type-checking when they are replaced with
421 (Right d), where "d" is the name of the dictionary holding the
422 evidene for the implicit parameter. -}
423 data IPBind id
424   = IPBind (Either HsIPName id) (LHsExpr id)
425   deriving (Data, Typeable)
426
427 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
428   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
429                         $$ ifPprDebug (ppr ds)
430
431 instance (OutputableBndr id) => Outputable (IPBind id) where
432   ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
433     where name = case lr of
434                    Left ip  -> pprBndr LetBind ip
435                    Right id -> pprBndr LetBind id
436 \end{code}
437
438
439 %************************************************************************
440 %*                                                                      *
441 \subsection{@Sig@: type signatures and value-modifying user pragmas}
442 %*                                                                      *
443 %************************************************************************
444
445 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
446 ``specialise this function to these four types...'') in with type
447 signatures.  Then all the machinery to move them into place, etc.,
448 serves for both.
449
450 \begin{code}
451 type LSig name = Located (Sig name)
452
453 data Sig name   -- Signatures and pragmas
454   =     -- An ordinary type signature
455         -- f :: Num a => a -> a
456     TypeSig [Located name] (LHsType name)
457
458         -- A type signature for a default method inside a class
459         -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
460   | GenericSig [Located name] (LHsType name)
461
462         -- A type signature in generated code, notably the code
463         -- generated for record selectors.  We simply record
464         -- the desired Id itself, replete with its name, type
465         -- and IdDetails.  Otherwise it's just like a type
466         -- signature: there should be an accompanying binding
467   | IdSig Id
468
469         -- An ordinary fixity declaration
470         --      infixl *** 8
471   | FixSig (FixitySig name)
472
473         -- An inline pragma
474         -- {#- INLINE f #-}
475   | InlineSig   (Located name)  -- Function name
476                 InlinePragma    -- Never defaultInlinePragma
477
478         -- A specialisation pragma
479         -- {-# SPECIALISE f :: Int -> Int #-}
480   | SpecSig     (Located name)  -- Specialise a function or datatype ...
481                 (LHsType name)  -- ... to these types
482                 InlinePragma    -- The pragma on SPECIALISE_INLINE form
483                                 -- If it's just defaultInlinePragma, then we said
484                                 --    SPECIALISE, not SPECIALISE_INLINE
485
486         -- A specialisation pragma for instance declarations only
487         -- {-# SPECIALISE instance Eq [Int] #-}
488   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the
489                                 -- current instance decl
490   deriving (Data, Typeable)
491
492
493 type LFixitySig name = Located (FixitySig name)
494 data FixitySig name = FixitySig (Located name) Fixity
495   deriving (Data, Typeable)
496
497 -- TsSpecPrags conveys pragmas from the type checker to the desugarer
498 data TcSpecPrags
499   = IsDefaultMethod     -- Super-specialised: a default method should
500                         -- be macro-expanded at every call site
501   | SpecPrags [LTcSpecPrag]
502   deriving (Data, Typeable)
503
504 type LTcSpecPrag = Located TcSpecPrag
505
506 data TcSpecPrag
507   = SpecPrag
508         Id              -- The Id to be specialised
509         HsWrapper       -- An wrapper, that specialises the polymorphic function
510         InlinePragma    -- Inlining spec for the specialised function
511   deriving (Data, Typeable)
512
513 noSpecPrags :: TcSpecPrags
514 noSpecPrags = SpecPrags []
515
516 hasSpecPrags :: TcSpecPrags -> Bool
517 hasSpecPrags (SpecPrags ps) = not (null ps)
518 hasSpecPrags IsDefaultMethod = False
519
520 isDefaultMethod :: TcSpecPrags -> Bool
521 isDefaultMethod IsDefaultMethod = True
522 isDefaultMethod (SpecPrags {})  = False
523
524 \end{code}
525
526 \begin{code}
527 isFixityLSig :: LSig name -> Bool
528 isFixityLSig (L _ (FixSig {})) = True
529 isFixityLSig _                 = False
530
531 isVanillaLSig :: LSig name -> Bool       -- User type signatures
532 -- A badly-named function, but it's part of the GHCi (used
533 -- by Haddock) so I don't want to change it gratuitously.
534 isVanillaLSig (L _(TypeSig {})) = True
535 isVanillaLSig _                 = False
536
537 isTypeLSig :: LSig name -> Bool  -- Type signatures
538 isTypeLSig (L _(TypeSig {}))    = True
539 isTypeLSig (L _(GenericSig {})) = True
540 isTypeLSig (L _(IdSig {}))      = True
541 isTypeLSig _                    = False
542
543 isSpecLSig :: LSig name -> Bool
544 isSpecLSig (L _(SpecSig {})) = True
545 isSpecLSig _                 = False
546
547 isSpecInstLSig :: LSig name -> Bool
548 isSpecInstLSig (L _ (SpecInstSig {})) = True
549 isSpecInstLSig _                      = False
550
551 isPragLSig :: LSig name -> Bool
552 -- Identifies pragmas
553 isPragLSig (L _ (SpecSig {}))   = True
554 isPragLSig (L _ (InlineSig {})) = True
555 isPragLSig _                    = False
556
557 isInlineLSig :: LSig name -> Bool
558 -- Identifies inline pragmas
559 isInlineLSig (L _ (InlineSig {})) = True
560 isInlineLSig _                    = False
561
562 hsSigDoc :: Sig name -> SDoc
563 hsSigDoc (TypeSig {})           = ptext (sLit "type signature")
564 hsSigDoc (GenericSig {})        = ptext (sLit "default type signature")
565 hsSigDoc (IdSig {})             = ptext (sLit "id signature")
566 hsSigDoc (SpecSig {})           = ptext (sLit "SPECIALISE pragma")
567 hsSigDoc (InlineSig {})         = ptext (sLit "INLINE pragma")
568 hsSigDoc (SpecInstSig {})       = ptext (sLit "SPECIALISE instance pragma")
569 hsSigDoc (FixSig {})            = ptext (sLit "fixity declaration")
570 \end{code}
571
572 Check if signatures overlap; this is used when checking for duplicate
573 signatures. Since some of the signatures contain a list of names, testing for
574 equality is not enough -- we have to check if they overlap.
575
576 \begin{code}
577 instance (OutputableBndr name) => Outputable (Sig name) where
578     ppr sig = ppr_sig sig
579
580 ppr_sig :: OutputableBndr name => Sig name -> SDoc
581 ppr_sig (TypeSig vars ty)         = pprVarSig (map unLoc vars) (ppr ty)
582 ppr_sig (GenericSig vars ty)      = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
583 ppr_sig (IdSig id)                = pprVarSig [id] (ppr (varType id))
584 ppr_sig (FixSig fix_sig)          = ppr fix_sig
585 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var (ppr ty) inl)
586 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
587 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
588
589 instance Outputable name => Outputable (FixitySig name) where
590   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
591
592 pragBrackets :: SDoc -> SDoc
593 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
594
595 pprVarSig :: (Outputable id) => [id] -> SDoc -> SDoc
596 pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
597   where
598     pprvars = hsep $ punctuate comma (map ppr vars)
599
600 pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
601 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty
602   where
603     pp_inl | isDefaultInlinePragma inl = empty
604            | otherwise = ppr inl
605
606 pprTcSpecPrags :: TcSpecPrags -> SDoc
607 pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
608 pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)
609
610 instance Outputable TcSpecPrag where
611   ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
612 \end{code}