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