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