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