Fix Trac #3263: don't print Hpc tick stuff unless -dppr-debug is on
[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-incomplete-patterns #-}
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and fix
13 -- any warnings in the module. See
14 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
15 -- for details
16
17 module HsBinds where
18
19 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
20                                MatchGroup, pprFunBind,
21                                GRHSs, pprPatBind )
22 import {-# SOURCE #-} HsPat  ( LPat )
23
24 import HsTypes
25 import PprCore ()
26 import Coercion
27 import Type
28 import Name
29 import NameSet
30 import BasicTypes
31 import Outputable       
32 import SrcLoc
33 import Util
34 import Var
35 import Bag
36 import FastString
37 \end{code}
38
39 %************************************************************************
40 %*                                                                      *
41 \subsection{Bindings: @BindGroup@}
42 %*                                                                      *
43 %************************************************************************
44
45 Global bindings (where clauses)
46
47 \begin{code}
48 -- During renaming, we need bindings where the left-hand sides
49 -- have been renamed but the the right-hand sides have not.
50 -- the ...LR datatypes are parametrized by two id types,
51 -- one for the left and one for the right.
52 -- Other than during renaming, these will be the same.
53
54 type HsLocalBinds id = HsLocalBindsLR id id
55
56 data HsLocalBindsLR idL idR     -- Bindings in a 'let' expression
57                                -- or a 'where' clause
58   = HsValBinds (HsValBindsLR idL idR)
59   | HsIPBinds  (HsIPBinds idR)
60   | EmptyLocalBinds
61
62 type HsValBinds id = HsValBindsLR id id
63
64 data HsValBindsLR idL idR  -- Value bindings (not implicit parameters)
65   = ValBindsIn             -- Before typechecking
66         (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
67                                         -- Recursive by default
68
69   | ValBindsOut                -- After renaming
70         [(RecFlag, LHsBinds idL)]       -- Dependency analysed, later bindings 
71                                         -- in the list may depend on earlier
72                                         -- ones.
73         [LSig Name]
74
75 type LHsBinds id  = Bag (LHsBind id)
76 type DictBinds id = LHsBinds id         -- Used for dictionary or method bindings
77 type LHsBind  id  = Located (HsBind id)
78 type HsBind id = HsBindLR id id
79
80 type LHsBindLR idL idR = Located (HsBindLR idL idR)
81 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
82
83 data HsBindLR idL idR
84   = -- | FunBind is used for both functions   @f x = e@
85     -- and variables                          @f = \x -> e@
86     --
87     -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
88     --
89     -- Reason 2: Instance decls can only have FunBinds, which is convenient.
90     --           If you change this, you'll need to change e.g. rnMethodBinds
91     --
92     -- But note that the form                 @f :: a->a = ...@
93     -- parses as a pattern binding, just like
94     --                                        @(f :: a -> a) = ... @
95     FunBind {
96
97         fun_id :: Located idL,
98
99         fun_infix :: Bool,      -- ^ True => infix declaration
100
101         fun_matches :: MatchGroup idR,  -- ^ The payload
102
103         fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
104                                 -- the Id.  Example:
105                                 -- @
106                                 --      f :: Int -> forall a. a -> a
107                                 --      f x y = y
108                                 -- @
109                                 -- Then the MatchGroup will have type (Int -> a' -> a')
110                                 -- (with a free type variable a').  The coercion will take
111                                 -- a CoreExpr of this type and convert it to a CoreExpr of
112                                 -- type         Int -> forall a'. a' -> a'
113                                 -- Notice that the coercion captures the free a'.
114
115         bind_fvs :: NameSet,    -- ^ After the renamer, this contains a superset of the
116                                 -- Names of the other binders in this binding group that 
117                                 -- are free in the RHS of the defn
118                                 -- Before renaming, and after typechecking, 
119                                 -- the field is unused; it's just an error thunk
120
121         fun_tick :: Maybe (Int,[idR])   -- ^ This is the (optional) module-local tick number.
122     }
123
124   | PatBind {   -- The pattern is never a simple variable;
125                 -- That case is done by FunBind
126         pat_lhs    :: LPat idL,
127         pat_rhs    :: GRHSs idR,
128         pat_rhs_ty :: PostTcType,       -- Type of the GRHSs
129         bind_fvs   :: NameSet           -- Same as for FunBind
130     }
131
132   | VarBind {   -- Dictionary binding and suchlike 
133         var_id :: idL,          -- All VarBinds are introduced by the type checker
134         var_rhs :: LHsExpr idR  -- Located only for consistency
135     }
136
137   | AbsBinds {                                  -- Binds abstraction; TRANSLATION
138         abs_tvs     :: [TyVar],  
139         abs_dicts   :: [DictId],                -- Includes equality constraints
140
141        -- AbsBinds only gets used when idL = idR after renaming,
142        -- but these need to be idL's for the collect... code in HsUtil to have
143        -- the right type
144         abs_exports :: [([TyVar], idL, idL, [LPrag])],  -- (tvs, poly_id, mono_id, prags)
145         abs_binds   :: LHsBinds idL             -- The dictionary bindings and typechecked user bindings
146                                                 -- mixed up together; you can tell the dict bindings because
147                                                 -- they are all VarBinds
148     }
149         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
150         -- 
151         -- Creates bindings for (polymorphic, overloaded) poly_f
152         -- in terms of monomorphic, non-overloaded mono_f
153         --
154         -- Invariants: 
155         --      1. 'binds' binds mono_f
156         --      2. ftvs is a subset of tvs
157         --      3. ftvs includes all tyvars free in ds
158         --
159         -- See section 9 of static semantics paper for more details.
160         -- (You can get a PhD for explaining the True Meaning
161         --  of this last construct.)
162
163 placeHolderNames :: NameSet
164 -- Used for the NameSet in FunBind and PatBind prior to the renamer
165 placeHolderNames = panic "placeHolderNames"
166
167 ------------
168 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
169   ppr (HsValBinds bs) = ppr bs
170   ppr (HsIPBinds bs)  = ppr bs
171   ppr EmptyLocalBinds = empty
172
173 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
174   ppr (ValBindsIn binds sigs)
175    = pprValBindsForUser binds sigs
176
177   ppr (ValBindsOut sccs sigs) 
178     = getPprStyle $ \ sty ->
179       if debugStyle sty then    -- Print with sccs showing
180         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
181      else
182         pprValBindsForUser (unionManyBags (map snd sccs)) sigs
183    where
184      ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
185      pp_rec Recursive    = ptext (sLit "rec")
186      pp_rec NonRecursive = ptext (sLit "nonrec")
187
188 --  *not* pprLHsBinds because we don't want braces; 'let' and
189 -- 'where' include a list of HsBindGroups and we don't want
190 -- several groups of bindings each with braces around.
191 -- Sort by location before printing
192 pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
193                    => LHsBindsLR idL idR -> [LSig id2] -> SDoc
194 pprValBindsForUser binds sigs
195   = pprDeeperList vcat (map snd (sort_by_loc decls))
196   where
197
198     decls :: [(SrcSpan, SDoc)]
199     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
200              [(loc, ppr bind) | L loc bind <- bagToList binds]
201
202     sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
203
204 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
205 pprLHsBinds binds 
206   | isEmptyLHsBinds binds = empty
207   | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
208
209 ------------
210 emptyLocalBinds :: HsLocalBindsLR a b
211 emptyLocalBinds = EmptyLocalBinds
212
213 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
214 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
215 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
216 isEmptyLocalBinds EmptyLocalBinds = True
217
218 isEmptyValBinds :: HsValBindsLR a b -> Bool
219 isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
220 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
221
222 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
223 emptyValBindsIn  = ValBindsIn emptyBag []
224 emptyValBindsOut = ValBindsOut []      []
225
226 emptyLHsBinds :: LHsBindsLR idL idR
227 emptyLHsBinds = emptyBag
228
229 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
230 isEmptyLHsBinds = isEmptyBag
231
232 ------------
233 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
234 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
235   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
236 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
237   = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
238 \end{code}
239
240 What AbsBinds means
241 ~~~~~~~~~~~~~~~~~~~
242          AbsBinds tvs
243                   [d1,d2]
244                   [(tvs1, f1p, f1m), 
245                    (tvs2, f2p, f2m)]
246                   BIND
247 means
248
249         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND 
250                                       in fm
251
252         gp = ...same again, with gm instead of fm
253
254 This is a pretty bad translation, because it duplicates all the bindings.
255 So the desugarer tries to do a better job:
256
257         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
258                                         (fm,gm) -> fm
259         ..ditto for gp..
260
261         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND 
262                                        in (fm,gm)
263
264 \begin{code}
265 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
266     ppr mbind = ppr_monobind mbind
267
268 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
269
270 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
271 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = pprBndr CaseBind var <+> equals <+> pprExpr (unLoc rhs)
272 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
273                         fun_matches = matches,
274                         fun_tick = tick })
275   = pprTicks empty (case tick of 
276                         Nothing -> empty
277                         Just t  -> text "-- tick id = " <> ppr t)
278     $$  pprFunBind (unLoc fun) inf matches
279
280 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, 
281                          abs_exports = exports, abs_binds = val_binds })
282   = sep [ptext (sLit "AbsBinds"),
283          brackets (interpp'SP tyvars),
284          brackets (interpp'SP dictvars),
285          brackets (sep (punctuate comma (map ppr_exp exports)))]
286     $$
287     nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
288                         -- Print type signatures
289              $$ pprLHsBinds val_binds )
290   where
291     ppr_exp (tvs, gbl, lcl, prags)
292         = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
293                 nest 2 (vcat (map (pprPrag gbl) prags))]
294 \end{code}
295
296
297 \begin{code}
298 pprTicks :: SDoc -> SDoc -> SDoc
299 -- Print stuff about ticks only when -dppr-debug is on, to avoid
300 -- them appearing in error messages (from the desugarer); see Trac # 3263
301 pprTicks pp_no_debug pp_when_debug
302   = getPprStyle (\ sty -> if debugStyle sty then pp_when_debug 
303                                             else pp_no_debug)
304 \end{code}
305
306 %************************************************************************
307 %*                                                                      *
308                 Implicit parameter bindings
309 %*                                                                      *
310 %************************************************************************
311
312 \begin{code}
313 data HsIPBinds id
314   = IPBinds 
315         [LIPBind id] 
316         (DictBinds id)  -- Only in typechecker output; binds 
317                         -- uses of the implicit parameters
318
319 isEmptyIPBinds :: HsIPBinds id -> Bool
320 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
321
322 type LIPBind id = Located (IPBind id)
323
324 -- | Implicit parameter bindings.
325 data IPBind id
326   = IPBind
327         (IPName id)
328         (LHsExpr id)
329
330 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
331   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) 
332                         $$ pprLHsBinds ds
333
334 instance (OutputableBndr id) => Outputable (IPBind id) where
335   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
336 \end{code}
337
338
339 %************************************************************************
340 %*                                                                      *
341 \subsection{Coercion functions}
342 %*                                                                      *
343 %************************************************************************
344
345 \begin{code}
346 -- A HsWrapper is an expression with a hole in it
347 -- We need coercions to have concrete form so that we can zonk them
348
349 data HsWrapper
350   = WpHole                      -- The identity coercion
351
352   | WpCompose HsWrapper HsWrapper       -- (\a1..an. []) `WpCompose` (\x1..xn. [])
353                                 --      = (\a1..an \x1..xn. [])
354
355   | WpCast Coercion             -- A cast:  [] `cast` co
356                                 -- Guaranteed not the identity coercion
357
358   | WpApp Var                   -- [] d         the 'd' is a type-class dictionary or coercion variable
359
360   | WpTyApp Type                -- [] t         the 't' is a type or corecion
361                                 --      ToDo: it'd be tidier if 't' was always a type (not coercion),
362                                 --            but that is inconvenient in Inst.instCallDicts
363
364   | WpLam Var                   -- \d. []       the 'd' is a type-class dictionary or coercion variable
365   | WpTyLam TyVar               -- \a. []       the 'a' is a type variable (not coercion var)
366   | WpInline                    -- inline_me []   Wrap inline around the thing
367
368         -- Non-empty bindings, so that the identity coercion
369         -- is always exactly WpHole
370   | WpLet (LHsBinds Id)         -- let binds in []
371                                 -- (would be nicer to be core bindings)
372
373 instance Outputable HsWrapper where 
374   ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
375
376 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
377 pprHsWrapper it wrap = 
378     let 
379         help it WpHole            = it
380         help it (WpCompose f1 f2) = help (help it f2) f1
381         help it (WpCast co)   = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)]
382         help it (WpApp id)    = sep [it, nest 2 (ppr id)]
383         help it (WpTyApp ty)  = sep [it, ptext (sLit "@") <+> pprParendType ty]
384         help it (WpLam id)    = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
385         help it (WpTyLam tv)  = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
386         help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
387         help it WpInline      = sep [ptext (sLit "_inline_me_"), it]
388     in
389       -- in debug mode, print the wrapper
390       -- otherwise just print what's inside
391       getPprStyle (\ s -> if debugStyle s then (help it wrap) else it)
392
393 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
394 WpHole <.> c = c
395 c <.> WpHole = c
396 c1 <.> c2    = c1 `WpCompose` c2
397
398 mkWpTyApps :: [Type] -> HsWrapper
399 mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys)
400
401 mkWpApps :: [Var] -> HsWrapper
402 mkWpApps ids = mk_co_fn WpApp (reverse ids)
403
404 mkWpTyLams :: [TyVar] -> HsWrapper
405 mkWpTyLams ids = mk_co_fn WpTyLam ids
406
407 mkWpLams :: [Var] -> HsWrapper
408 mkWpLams ids = mk_co_fn WpLam ids
409
410 mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
411 mk_co_fn f as = foldr (WpCompose . f) WpHole as
412
413 idHsWrapper :: HsWrapper
414 idHsWrapper = WpHole
415
416 isIdHsWrapper :: HsWrapper -> Bool
417 isIdHsWrapper WpHole = True
418 isIdHsWrapper _      = False
419 \end{code}
420
421
422 %************************************************************************
423 %*                                                                      *
424 \subsection{@Sig@: type signatures and value-modifying user pragmas}
425 %*                                                                      *
426 %************************************************************************
427
428 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
429 ``specialise this function to these four types...'') in with type
430 signatures.  Then all the machinery to move them into place, etc.,
431 serves for both.
432
433 \begin{code}
434 type LSig name = Located (Sig name)
435
436 data Sig name   -- Signatures and pragmas
437   =     -- An ordinary type signature
438         -- f :: Num a => a -> a
439     TypeSig (Located name) (LHsType name)
440
441         -- A type signature in generated code, notably the code
442         -- generated for record selectors.  We simply record
443         -- the desired Id itself, replete with its name, type
444         -- and IdDetails.  Otherwise it's just like a type 
445         -- signature: there should be an accompanying binding
446   | IdSig Id
447
448         -- An ordinary fixity declaration
449         --      infixl *** 8
450   | FixSig (FixitySig name)
451
452         -- An inline pragma
453         -- {#- INLINE f #-}
454   | InlineSig   (Located name)  -- Function name
455                 InlineSpec
456
457         -- A specialisation pragma
458         -- {-# SPECIALISE f :: Int -> Int #-}
459   | SpecSig     (Located name)  -- Specialise a function or datatype ...
460                 (LHsType name)  -- ... to these types
461                 InlineSpec
462
463         -- A specialisation pragma for instance declarations only
464         -- {-# SPECIALISE instance Eq [Int] #-}
465   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the 
466                                 -- current instance decl
467
468
469 type LFixitySig name = Located (FixitySig name)
470 data FixitySig name = FixitySig (Located name) Fixity 
471
472 -- A Prag conveys pragmas from the type checker to the desugarer
473 type LPrag = Located Prag
474 data Prag 
475   = InlinePrag 
476         InlineSpec
477
478   | SpecPrag   
479         (HsExpr Id)     -- An expression, of the given specialised type, which
480         PostTcType      -- specialises the polymorphic function
481         InlineSpec      -- Inlining spec for the specialised function
482
483 isInlinePrag :: Prag -> Bool
484 isInlinePrag (InlinePrag _) = True
485 isInlinePrag _              = False
486
487 isSpecPrag :: Prag -> Bool
488 isSpecPrag (SpecPrag {}) = True
489 isSpecPrag _             = False
490 \end{code}
491
492 \begin{code}
493 okBindSig :: Sig a -> Bool
494 okBindSig _ = True
495
496 okHsBootSig :: Sig a -> Bool
497 okHsBootSig (TypeSig  _ _) = True
498 okHsBootSig (FixSig _)     = True
499 okHsBootSig _              = False
500
501 okClsDclSig :: Sig a -> Bool
502 okClsDclSig (SpecInstSig _) = False
503 okClsDclSig _               = True        -- All others OK
504
505 okInstDclSig :: Sig a -> Bool
506 okInstDclSig (TypeSig _ _)   = False
507 okInstDclSig (FixSig _)      = False
508 okInstDclSig _               = True
509
510 sigForThisGroup :: NameSet -> LSig Name -> Bool
511 sigForThisGroup ns sig
512   = case sigName sig of
513         Nothing -> False
514         Just n  -> n `elemNameSet` ns
515
516 sigName :: LSig name -> Maybe name
517 sigName (L _ sig) = sigNameNoLoc sig
518
519 sigNameNoLoc :: Sig name -> Maybe name    
520 sigNameNoLoc (TypeSig   n _)          = Just (unLoc n)
521 sigNameNoLoc (SpecSig   n _ _)        = Just (unLoc n)
522 sigNameNoLoc (InlineSig n _)          = Just (unLoc n)
523 sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
524 sigNameNoLoc _                        = Nothing
525
526 isFixityLSig :: LSig name -> Bool
527 isFixityLSig (L _ (FixSig {})) = True
528 isFixityLSig _                 = False
529
530 isVanillaLSig :: LSig name -> Bool       -- User type signatures
531 -- A badly-named function, but it's part of the GHCi (used
532 -- by Haddock) so I don't want to change it gratuitously.
533 isVanillaLSig (L _(TypeSig {})) = True
534 isVanillaLSig _                 = False
535
536 isTypeLSig :: LSig name -> Bool  -- Type signatures
537 isTypeLSig (L _(TypeSig {})) = True
538 isTypeLSig (L _(IdSig {}))   = True
539 isTypeLSig _                 = False
540
541 isSpecLSig :: LSig name -> Bool
542 isSpecLSig (L _(SpecSig {})) = True
543 isSpecLSig _                 = False
544
545 isSpecInstLSig :: LSig name -> Bool
546 isSpecInstLSig (L _ (SpecInstSig {})) = True
547 isSpecInstLSig _                      = False
548
549 isPragLSig :: LSig name -> Bool
550         -- Identifies pragmas 
551 isPragLSig (L _ (SpecSig {}))   = True
552 isPragLSig (L _ (InlineSig {})) = True
553 isPragLSig _                    = False
554
555 isInlineLSig :: LSig name -> Bool
556         -- Identifies inline pragmas 
557 isInlineLSig (L _ (InlineSig {})) = True
558 isInlineLSig _                    = False
559
560 hsSigDoc :: Sig name -> SDoc
561 hsSigDoc (TypeSig {})           = ptext (sLit "type signature")
562 hsSigDoc (IdSig {})             = ptext (sLit "id signature")
563 hsSigDoc (SpecSig {})           = ptext (sLit "SPECIALISE pragma")
564 hsSigDoc (InlineSig {})         = ptext (sLit "INLINE pragma")
565 hsSigDoc (SpecInstSig {})       = ptext (sLit "SPECIALISE instance pragma")
566 hsSigDoc (FixSig {})            = ptext (sLit "fixity declaration")
567 \end{code}
568
569 Signature equality is used when checking for duplicate signatures
570
571 \begin{code}
572 eqHsSig :: Eq a => LSig a -> LSig a -> Bool
573 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
574 eqHsSig (L _ (IdSig n1))                (L _ (IdSig n2))                = n1 == n2
575 eqHsSig (L _ (TypeSig n1 _))            (L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
576 eqHsSig (L _ (InlineSig n1 _))          (L _ (InlineSig n2 _))          = unLoc n1 == unLoc n2
577         -- For specialisations, we don't have equality over
578         -- HsType, so it's not convenient to spot duplicate 
579         -- specialisations here.  Check for this later, when we're in Type land
580 eqHsSig _other1 _other2 = False
581 \end{code}
582
583 \begin{code}
584 instance (OutputableBndr name) => Outputable (Sig name) where
585     ppr sig = ppr_sig sig
586
587 ppr_sig :: OutputableBndr name => Sig name -> SDoc
588 ppr_sig (TypeSig var ty)          = pprVarSig (unLoc var) ty
589 ppr_sig (IdSig id)                = pprVarSig id (varType id)
590 ppr_sig (FixSig fix_sig)          = ppr fix_sig
591 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var ty inl)
592 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
593 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
594
595 instance Outputable name => Outputable (FixitySig name) where
596   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
597
598 pragBrackets :: SDoc -> SDoc
599 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") 
600
601 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
602 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
603
604 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
605 pprSpec var ty inl = sep [ptext (sLit "SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
606
607 pprPrag :: Outputable id => id -> LPrag -> SDoc
608 pprPrag var (L _ (InlinePrag inl))        = ppr inl <+> ppr var
609 pprPrag var (L _ (SpecPrag _expr ty inl)) = pprSpec var ty inl
610 \end{code}
611