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