HsBinds.hs 38.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

5
6
\section[HsBinds]{Abstract syntax: top-level bindings and signatures}

7
Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
Austin Seipp's avatar
Austin Seipp committed
8
-}
9

10
{-# LANGUAGE DeriveDataTypeable #-}
11
12
13
14
15
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                      -- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
16
{-# LANGUAGE BangPatterns #-}
17

18
19
module HsBinds where

20
import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
21
22
                               MatchGroup, pprFunBind,
                               GRHSs, pprPatBind )
23
import {-# SOURCE #-} HsPat  ( LPat )
sof's avatar
sof committed
24

25
import PlaceHolder ( PostTc,PostRn,DataId )
26
import HsTypes
27
import PprCore ()
28
import CoreSyn
29
import TcEvidence
30
31
32
33
import Type
import Name
import NameSet
import BasicTypes
34
import Outputable
35
36
37
import SrcLoc
import Var
import Bag
38
import FastString
39
import BooleanFormula (LBooleanFormula)
40
import DynFlags
41
42

import Data.Data hiding ( Fixity )
43
import Data.List hiding ( foldr )
44
import Data.Ord
Gergő Érdi's avatar
Gergő Érdi committed
45
import Data.Foldable ( Foldable(..) )
46

Austin Seipp's avatar
Austin Seipp committed
47
48
49
{-
************************************************************************
*                                                                      *
50
\subsection{Bindings: @BindGroup@}
Austin Seipp's avatar
Austin Seipp committed
51
52
*                                                                      *
************************************************************************
53

54
Global bindings (where clauses)
Austin Seipp's avatar
Austin Seipp committed
55
-}
56

57
58
59
60
61
62
63
64
-- During renaming, we need bindings where the left-hand sides
-- have been renamed but the the right-hand sides have not.
-- the ...LR datatypes are parametrized by two id types,
-- one for the left and one for the right.
-- Other than during renaming, these will be the same.

type HsLocalBinds id = HsLocalBindsLR id id

65
66
-- | Bindings in a 'let' expression
-- or a 'where' clause
67
data HsLocalBindsLR idL idR
68
  = HsValBinds (HsValBindsLR idL idR)
69
70
71
72
73
         -- There should be no pattern synonyms in the HsValBindsLR
         -- These are *local* (not top level) bindings
         -- The parser accepts them, however, leaving the the
         -- renamer to report them

74
  | HsIPBinds  (HsIPBinds idR)
75

76
  | EmptyLocalBinds
77
  deriving (Typeable)
78

79
80
deriving instance (DataId idL, DataId idR)
  => Data (HsLocalBindsLR idL idR)
sof's avatar
sof committed
81

82
83
type HsValBinds id = HsValBindsLR id id

84
-- | Value bindings (not implicit parameters)
85
86
-- Used for both top level and nested bindings
-- May contain pattern synonym bindings
87
data HsValBindsLR idL idR
88
89
90
91
  = -- | Before renaming RHS; idR is always RdrName
    -- Not dependency analysed
    -- Recursive by default
    ValBindsIn
92
        (LHsBindsLR idL idR) [LSig idR]
93
94
95
96
97

    -- | After renaming RHS; idR can be Name or Id
    --  Dependency analysed,
    -- later bindings in the list may depend on earlier
    -- ones.
98
99
  | ValBindsOut
        [(RecFlag, LHsBinds idL)]
100
        [LSig Name]
101
  deriving (Typeable)
102

103
104
deriving instance (DataId idL, DataId idR)
  => Data (HsValBindsLR idL idR)
105

106
107
108
type LHsBind  id = LHsBindLR  id id
type LHsBinds id = LHsBindsLR id id
type HsBind   id = HsBindLR   id id
109

110
type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
111
type LHsBindLR  idL idR = Located (HsBindLR idL idR)
112

113
data HsBindLR idL idR
114
115
116
117
118
119
120
121
122
123
124
  = -- | FunBind is used for both functions   @f x = e@
    -- and variables                          @f = \x -> e@
    --
    -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
    --
    -- Reason 2: Instance decls can only have FunBinds, which is convenient.
    --           If you change this, you'll need to change e.g. rnMethodBinds
    --
    -- But note that the form                 @f :: a->a = ...@
    -- parses as a pattern binding, just like
    --                                        @(f :: a -> a) = ... @
Alan Zimmerman's avatar
Alan Zimmerman committed
125
126
127
128
129
130
131
    --
    --  'ApiAnnotation.AnnKeywordId's
    --
    --  - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches
    --
    --  - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
    --    'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
132
133

    -- For details on above see note [Api annotations] in ApiAnnotation
134
    FunBind {
135

Alan Zimmerman's avatar
Alan Zimmerman committed
136
        fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr
137

138
        fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload
139

140
141
        fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
                                -- the Id.  Example:
Alan Zimmerman's avatar
Alan Zimmerman committed
142
                                --
143
                                -- @
144
145
                                --      f :: Int -> forall a. a -> a
                                --      f x y = y
146
                                -- @
Alan Zimmerman's avatar
Alan Zimmerman committed
147
                                --
148
149
150
151
152
                                -- Then the MatchGroup will have type (Int -> a' -> a')
                                -- (with a free type variable a').  The coercion will take
                                -- a CoreExpr of this type and convert it to a CoreExpr of
                                -- type         Int -> forall a'. a' -> a'
                                -- Notice that the coercion captures the free a'.
153

154
155
        bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains
                                --  the locally-bound
156
157
                                -- free variables of this defn.
                                -- See Note [Bind free vars]
158

andy@galois.com's avatar
andy@galois.com committed
159

160
        fun_tick :: [Tickish Id]  -- ^ Ticks to put on the rhs, if any
161
162
    }

163
164
  -- | The pattern is never a simple variable;
  -- That case is done by FunBind
Alan Zimmerman's avatar
Alan Zimmerman committed
165
166
167
168
  --
  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
  --       'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
  --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
169
170

  -- For details on above see note [Api annotations] in ApiAnnotation
171
  | PatBind {
172
        pat_lhs    :: LPat idL,
173
        pat_rhs    :: GRHSs idR (LHsExpr idR),
174
175
        pat_rhs_ty :: PostTc idR Type,      -- ^ Type of the GRHSs
        bind_fvs   :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
176
177
        pat_ticks  :: ([Tickish Id], [[Tickish Id]])
               -- ^ Ticks to put on the rhs, if any, and ticks to put on
178
               -- the bound variables.
179
180
    }

181
182
  -- | Dictionary binding and suchlike.
  -- All VarBinds are introduced by the type checker
183
184
  | VarBind {
        var_id     :: idL,
185
186
        var_rhs    :: LHsExpr idR,   -- ^ Located only for consistency
        var_inline :: Bool           -- ^ True <=> inline this binding regardless
187
                                     -- (used for implication constraints only)
188
189
    }

190
  | AbsBinds {                      -- Binds abstraction; TRANSLATION
191
        abs_tvs     :: [TyVar],
192
        abs_ev_vars :: [EvVar],  -- ^ Includes equality constraints
193

194
       -- | AbsBinds only gets used when idL = idR after renaming,
195
       -- but these need to be idL's for the collect... code in HsUtil
Simon Peyton Jones's avatar
Simon Peyton Jones committed
196
       -- to have the right type
197
        abs_exports :: [ABExport idL],
198

199
200
201
202
203
204
205
        -- | Evidence bindings
        -- Why a list? See TcInstDcls
        -- Note [Typechecking plan for instance declarations]
        abs_ev_binds :: [TcEvBinds],

        -- | Typechecked user bindings
        abs_binds    :: LHsBinds idL
206
    }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
207

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
208
209
210
211
212
213
214
215
216
217
218
219
220
221
  | AbsBindsSig {  -- Simpler form of AbsBinds, used with a type sig
                   -- in tcPolyCheck. Produces simpler desugaring and
                   -- is necessary to avoid #11405, comment:3.
        abs_tvs     :: [TyVar],
        abs_ev_vars :: [EvVar],

        abs_sig_export :: idL,  -- like abe_poly
        abs_sig_prags  :: TcSpecPrags,

        abs_sig_ev_bind :: TcEvBinds,  -- no list needed here
        abs_sig_bind    :: LHsBind idL -- always only one, and it's always a
                                       -- FunBind
    }

222
  | PatSynBind (PatSynBind idL idR)
Alan Zimmerman's avatar
Alan Zimmerman committed
223
        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
Alan Zimmerman's avatar
Alan Zimmerman committed
224
225
226
        --          'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
        --          'ApiAnnotation.AnnWhere'
        --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@
Gergő Érdi's avatar
Gergő Érdi committed
227

228
229
        -- For details on above see note [Api annotations] in ApiAnnotation

230
231
232
233
  deriving (Typeable)
deriving instance (DataId idL, DataId idR)
  => Data (HsBindLR idL idR)

234
235
236
237
238
239
240
241
242
243
        -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
        --
        -- Creates bindings for (polymorphic, overloaded) poly_f
        -- in terms of monomorphic, non-overloaded mono_f
        --
        -- Invariants:
        --      1. 'binds' binds mono_f
        --      2. ftvs is a subset of tvs
        --      3. ftvs includes all tyvars free in ds
        --
244
        -- See Note [AbsBinds]
245
246

data ABExport id
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
247
248
  = ABE { abe_poly      :: id    -- ^ Any INLINE pragmas is attached to this Id
        , abe_mono      :: id
249
250
        , abe_wrap      :: HsWrapper    -- ^ See Note [ABExport wrapper]
             -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
251
        , abe_prags     :: TcSpecPrags  -- ^ SPECIALISE pragmas
252
  } deriving (Data, Typeable)
253

Alan Zimmerman's avatar
Alan Zimmerman committed
254
255
256
257
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
--             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
--             'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@,
--             'ApiAnnotation.AnnClose' @'}'@,
258
259

-- For details on above see note [Api annotations] in ApiAnnotation
260
data PatSynBind idL idR
261
262
  = PSB { psb_id   :: Located idL,             -- ^ Name of the pattern synonym
          psb_fvs  :: PostRn idR NameSet,      -- ^ See Note [Bind free vars]
263
264
265
          psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names
          psb_def  :: LPat idR,                      -- ^ Right-hand side
          psb_dir  :: HsPatSynDir idR                -- ^ Directionality
266
  } deriving (Typeable)
Matthew Pickering's avatar
Matthew Pickering committed
267
deriving instance (DataId idL, DataId idR)
268
  => Data (PatSynBind idL idR)
269

Austin Seipp's avatar
Austin Seipp committed
270
{-
271
272
273
274
Note [AbsBinds]
~~~~~~~~~~~~~~~
The AbsBinds constructor is used in the output of the type checker, to record
*typechecked* and *generalised* bindings.  Consider a module M, with this
275
top-level binding, where there is no type signature for M.reverse,
276
277
278
279
    M.reverse []     = []
    M.reverse (x:xs) = M.reverse xs ++ [x]

In Hindley-Milner, a recursive binding is typechecked with the *recursive* uses
Simon Peyton Jones's avatar
Simon Peyton Jones committed
280
being *monomorphic*.  So after typechecking *and* desugaring we will get something
281
like this
282

283
    M.reverse :: forall a. [a] -> [a]
284
      = /\a. letrec
285
286
287
288
289
290
                reverse :: [a] -> [a] = \xs -> case xs of
                                                []     -> []
                                                (x:xs) -> reverse xs ++ [x]
             in reverse

Notice that 'M.reverse' is polymorphic as expected, but there is a local
Simon Peyton Jones's avatar
Simon Peyton Jones committed
291
definition for plain 'reverse' which is *monomorphic*.  The type variable
292
293
'a' scopes over the entire letrec.

294
295
That's after desugaring.  What about after type checking but before
desugaring?  That's where AbsBinds comes in.  It looks like this:
296
297
298

   AbsBinds { abs_tvs     = [a]
            , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],
299
                                 , abe_mono = reverse :: [a] -> [a]}]
300
            , abs_binds = { reverse :: [a] -> [a]
301
302
303
304
305
                               = \xs -> case xs of
                                            []     -> []
                                            (x:xs) -> reverse xs ++ [x] } }

Here,
306
  * abs_tvs says what type variables are abstracted over the binding group,
307
308
    just 'a' in this case.
  * abs_binds is the *monomorphic* bindings of the group
309
  * abs_exports describes how to get the polymorphic Id 'M.reverse' from the
310
311
312
313
314
315
316
    monomorphic one 'reverse'

Notice that the *original* function (the polymorphic one you thought
you were defining) appears in the abe_poly field of the
abs_exports. The bindings in abs_binds are for fresh, local, Ids with
a *monomorphic* Id.

Gabor Greif's avatar
Gabor Greif committed
317
If there is a group of mutually recursive (see Note [Polymorphic
318
319
320
321
recursion]) functions without type signatures, we get one AbsBinds
with the monomorphic versions of the bindings in abs_binds, and one
element of abe_exports for each variable bound in the mutually
recursive group.  This is true even for pattern bindings.  Example:
322
323
324
325
326
327
328
329
330
        (f,g) = (\x -> x, f)
After type checking we get
   AbsBinds { abs_tvs     = [a]
            , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a
                                  , abe_mono = f :: a -> a }
                            , ABE { abe_poly = M.g :: forall a. a -> a
                                  , abe_mono = g :: a -> a }]
            , abs_binds = { (f,g) = (\x -> x, f) }

Gabor Greif's avatar
Gabor Greif committed
331
Note [Polymorphic recursion]
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   Rec { f x = ...(g ef)...

       ; g :: forall a. [a] -> [a]
       ; g y = ...(f eg)...  }

These bindings /are/ mutually recursive (f calls g, and g calls f).
But we can use the type signature for g to break the recursion,
like this:

  1. Add g :: forall a. [a] -> [a] to the type environment

  2. Typecheck the definition of f, all by itself,
     including generalising it to find its most general
     type, say f :: forall b. b -> b -> [b]

  3. Extend the type environment with that type for f

  4. Typecheck the definition of g, all by itself,
     checking that it has the type claimed by its signature

Steps 2 and 4 each generate a separate AbsBinds, so we end
up with
   Rec { AbsBinds { ...for f ... }
       ; AbsBinds { ...for g ... } }

This approach allows both f and to call each other
Gabor Greif's avatar
Gabor Greif committed
360
polymorphically, even though only g has a signature.
361
362
363
364
365
366
367

We get an AbsBinds that encompasses multiple source-program
bindings only when
 * Each binding in the group has at least one binder that
   lacks a user type signature
 * The group forms a strongly connected component

368
369
Note [ABExport wrapper]
~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
370
Consider
371
372
373
374
375
   (f,g) = (\x.x, \y.y)
This ultimately desugars to something like this:
   tup :: forall a b. (a->a, b->b)
   tup = /\a b. (\x:a.x, \y:b.y)
   f :: forall a. a -> a
376
   f = /\a. case tup a Any of
377
378
379
               (fm::a->a,gm:Any->Any) -> fm
   ...similarly for g...

Gabor Greif's avatar
Gabor Greif committed
380
The abe_wrap field deals with impedance-matching between
381
382
383
384
385
386
387
    (/\a b. case tup a b of { (f,g) -> f })
and the thing we really want, which may have fewer type
variables.  The action happens in TcBinds.mkExport.

Note [Bind free vars]
~~~~~~~~~~~~~~~~~~~~~
The bind_fvs field of FunBind and PatBind records the free variables
388
of the definition.  It is used for the following purposes
389
390
391

a) Dependency analysis prior to type checking
    (see TcBinds.tc_group)
392

393
394
395
b) Deciding whether we can do generalisation of the binding
    (see TcBinds.decideGeneralisationPlan)

396
397
398
399
c) Deciding whether the binding can be used in static forms
    (see TcExpr.checkClosedInStaticForm for the HsStatic case and
     TcBinds.isClosedBndrGroup).

400
Specifically,
401
402
403
404
405
406
407
408

  * bind_fvs includes all free vars that are defined in this module
    (including top-level things and lexically scoped type variables)

  * bind_fvs excludes imported vars; this is just to keep the set smaller

  * Before renaming, and after typechecking, the field is unused;
    it's just an error thunk
Austin Seipp's avatar
Austin Seipp committed
409
-}
410

411
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
412
413
414
415
  ppr (HsValBinds bs) = ppr bs
  ppr (HsIPBinds bs)  = ppr bs
  ppr EmptyLocalBinds = empty

416
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
417
  ppr (ValBindsIn binds sigs)
418
   = pprDeclList (pprLHsBindsForUser binds sigs)
419

420
  ppr (ValBindsOut sccs sigs)
421
    = getPprStyle $ \ sty ->
422
423
      if debugStyle sty then    -- Print with sccs showing
        vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
424
     else
425
        pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)
426
427
   where
     ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
428
429
     pp_rec Recursive    = text "rec"
     pp_rec NonRecursive = text "nonrec"
430

431
pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
432
pprLHsBinds binds
433
  | isEmptyLHsBinds binds = empty
434
  | otherwise = pprDeclList (map ppr (bagToList binds))
435
436

pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
437
438
                   => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
--  pprLHsBindsForUser is different to pprLHsBinds because
439
--  a) No braces: 'let' and 'where' include a list of HsBindGroups
440
--     and we don't want several groups of bindings each
441
442
443
444
--     with braces around
--  b) Sort by location before printing
--  c) Include signatures
pprLHsBindsForUser binds sigs
445
  = map snd (sort_by_loc decls)
446
447
448
449
  where

    decls :: [(SrcSpan, SDoc)]
    decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
450
            [(loc, ppr bind) | L loc bind <- bagToList binds]
451

452
    sort_by_loc decls = sortBy (comparing fst) decls
453

454
455
456
457
458
pprDeclList :: [SDoc] -> SDoc   -- Braces with a space
-- Print a bunch of declarations
-- One could choose  { d1; d2; ... }, using 'sep'
-- or      d1
--         d2
459
--         ..
460
461
462
463
464
--    using vcat
-- At the moment we chose the latter
-- Also we do the 'pprDeeperList' thing.
pprDeclList ds = pprDeeperList vcat ds

465
------------
466
emptyLocalBinds :: HsLocalBindsLR a b
467
468
emptyLocalBinds = EmptyLocalBinds

469
isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
470
471
472
473
isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
isEmptyLocalBinds EmptyLocalBinds = True

474
isEmptyValBinds :: HsValBindsLR a b -> Bool
475
476
isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
477

478
emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
479
emptyValBindsIn  = ValBindsIn emptyBag []
480
emptyValBindsOut = ValBindsOut []      []
481

482
emptyLHsBinds :: LHsBindsLR idL idR
483
484
emptyLHsBinds = emptyBag

485
isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
486
487
488
489
490
491
isEmptyLHsBinds = isEmptyBag

------------
plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
  = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
492
493
plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
  = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
494
495
plusHsValBinds _ _
  = panic "HsBinds.plusHsValBinds"
496

497

Austin Seipp's avatar
Austin Seipp committed
498
{-
499
500
What AbsBinds means
~~~~~~~~~~~~~~~~~~~
501
502
503
504
505
         AbsBinds tvs
                  [d1,d2]
                  [(tvs1, f1p, f1m),
                   (tvs2, f2p, f2m)]
                  BIND
506
507
means

508
509
        f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
                                     in fm
510

511
        gp = ...same again, with gm instead of fm
512
513
514
515

This is a pretty bad translation, because it duplicates all the bindings.
So the desugarer tries to do a better job:

516
517
518
        fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
                                        (fm,gm) -> fm
        ..ditto for gp..
519

520
521
        tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
                                      in (fm,gm)
Austin Seipp's avatar
Austin Seipp committed
522
-}
523

524
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
525
    ppr mbind = ppr_monobind mbind
sof's avatar
sof committed
526

527
ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
528

529
530
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
  = pprPatBind pat grhss
531
ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
532
  = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
533
ppr_monobind (FunBind { fun_id = fun,
534
535
                        fun_co_fn = wrap,
                        fun_matches = matches,
536
537
538
                        fun_tick = ticks })
  = pprTicks empty (if null ticks then empty
                    else text "-- ticks = " <> ppr ticks)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
539
    $$  ifPprDebug (pprBndr LetBind (unLoc fun))
540
    $$  pprFunBind (unLoc fun) matches
541
    $$  ifPprDebug (ppr wrap)
542
ppr_monobind (PatSynBind psb) = ppr psb
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
543
544
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
                       , abs_exports = exports, abs_binds = val_binds
545
                       , abs_ev_binds = ev_binds })
546
  = sdocWithDynFlags $ \ dflags ->
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
547
    if gopt Opt_PrintTypecheckerElaboration dflags then
548
      -- Show extra information (bug number: #10662)
549
      hang (text "AbsBinds" <+> brackets (interpp'SP tyvars)
550
551
                                    <+> brackets (interpp'SP dictvars))
         2 $ braces $ vcat
552
      [ text "Exports:" <+>
553
          brackets (sep (punctuate comma (map ppr exports)))
554
      , text "Exported types:" <+>
555
          vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
556
557
      , text "Binds:" <+> pprLHsBinds val_binds
      , text "Evidence:" <+> ppr ev_binds ]
558
559
    else
      pprLHsBinds val_binds
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
560
561
562
563
564
565
566
567
568
569
570
571
572
ppr_monobind (AbsBindsSig { abs_tvs         = tyvars
                          , abs_ev_vars     = dictvars
                          , abs_sig_ev_bind = ev_bind
                          , abs_sig_bind    = bind })
  = sdocWithDynFlags $ \ dflags ->
    if gopt Opt_PrintTypecheckerElaboration dflags then
      hang (text "AbsBindsSig" <+> brackets (interpp'SP tyvars)
                               <+> brackets (interpp'SP dictvars))
         2 $ braces $ vcat
      [ text "Bind:"     <+> ppr bind
      , text "Evidence:" <+> ppr ev_bind ]
    else
      ppr bind
573
574

instance (OutputableBndr id) => Outputable (ABExport id) where
575
  ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
576
    = vcat [ ppr gbl <+> text "<=" <+> ppr lcl
577
           , nest 2 (pprTcSpecPrags prags)
578
           , nest 2 (text "wrap:" <+> ppr wrap)]
579
580
581
582
583

instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where
  ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir })
      = ppr_lhs <+> ppr_rhs
    where
584
      ppr_lhs = text "pattern" <+> ppr_details
585
586
      ppr_simple syntax = syntax <+> ppr pat

587
588
589
      ppr_details = case details of
          InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
          PrefixPatSyn vs   -> hsep (pprPrefixOcc psyn : map ppr vs)
Matthew Pickering's avatar
Matthew Pickering committed
590
          RecordPatSyn vs   ->
591
592
            pprPrefixOcc psyn
                      <> braces (sep (punctuate comma (map ppr vs)))
593
594

      ppr_rhs = case dir of
595
          Unidirectional           -> ppr_simple (text "<-")
596
          ImplicitBidirectional    -> ppr_simple equals
597
          ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$
598
                                      (nest 2 $ pprFunBind psyn mg)
599

600
601
602
pprTicks :: SDoc -> SDoc -> SDoc
-- Print stuff about ticks only when -dppr-debug is on, to avoid
-- them appearing in error messages (from the desugarer); see Trac # 3263
603
604
-- Also print ticks in dumpStyle, so that -ddump-hpc actually does
-- something useful.
605
pprTicks pp_no_debug pp_when_debug
606
607
608
  = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty
                             then pp_when_debug
                             else pp_no_debug)
609

Austin Seipp's avatar
Austin Seipp committed
610
611
612
{-
************************************************************************
*                                                                      *
613
                Implicit parameter bindings
Austin Seipp's avatar
Austin Seipp committed
614
615
616
*                                                                      *
************************************************************************
-}
617
618

data HsIPBinds id
619
620
621
622
  = IPBinds
        [LIPBind id]
        TcEvBinds       -- Only in typechecker output; binds
                        -- uses of the implicit parameters
623
624
  deriving (Typeable)
deriving instance (DataId id) => Data (HsIPBinds id)
625
626

isEmptyIPBinds :: HsIPBinds id -> Bool
627
isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
628
629

type LIPBind id = Located (IPBind id)
Alan Zimmerman's avatar
Alan Zimmerman committed
630
631
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
--   list
632

633
634
-- For details on above see note [Api annotations] in ApiAnnotation

635
-- | Implicit parameter bindings.
Alan Zimmerman's avatar
Alan Zimmerman committed
636
--
Alan Zimmerman's avatar
Alan Zimmerman committed
637
638
639
640
641
-- These bindings start off as (Left "x") in the parser and stay
-- that way until after type-checking when they are replaced with
-- (Right d), where "d" is the name of the dictionary holding the
-- evidence for the implicit parameter.
--
Alan Zimmerman's avatar
Alan Zimmerman committed
642
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
643
644

-- For details on above see note [Api annotations] in ApiAnnotation
645
data IPBind id
Alan Zimmerman's avatar
Alan Zimmerman committed
646
  = IPBind (Either (Located HsIPName) id) (LHsExpr id)
647
648
  deriving (Typeable)
deriving instance (DataId name) => Data (IPBind name)
649
650

instance (OutputableBndr id) => Outputable (HsIPBinds id) where
651
  ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
652
                        $$ ifPprDebug (ppr ds)
653
654

instance (OutputableBndr id) => Outputable (IPBind id) where
655
656
  ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
    where name = case lr of
Alan Zimmerman's avatar
Alan Zimmerman committed
657
658
                   Left (L _ ip) -> pprBndr LetBind ip
                   Right     id  -> pprBndr LetBind id
659

Austin Seipp's avatar
Austin Seipp committed
660
661
662
{-
************************************************************************
*                                                                      *
663
\subsection{@Sig@: type signatures and value-modifying user pragmas}
Austin Seipp's avatar
Austin Seipp committed
664
665
*                                                                      *
************************************************************************
666
667
668
669
670

It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
``specialise this function to these four types...'') in with type
signatures.  Then all the machinery to move them into place, etc.,
serves for both.
Austin Seipp's avatar
Austin Seipp committed
671
-}
672

673
674
type LSig name = Located (Sig name)

675
-- | Signatures and pragmas
676
data Sig name
677
  =   -- | An ordinary type signature
678
679
680
      --
      -- > f :: Num a => a -> a
      --
thomasw's avatar
thomasw committed
681
682
683
684
685
686
687
      -- After renaming, this list of Names contains the named and unnamed
      -- wildcards brought into scope by this signature. For a signature
      -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@
      -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@
      -- are then both replaced with fresh meta vars in the type. Their names
      -- are stored in the type signature that brought them into scope, in
      -- this third field to be more specific.
Alan Zimmerman's avatar
Alan Zimmerman committed
688
689
690
      --
      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
      --          'ApiAnnotation.AnnComma'
691
692

      -- For details on above see note [Api annotations] in ApiAnnotation
Matthew Pickering's avatar
Matthew Pickering committed
693
    TypeSig
694
695
       [Located name]        -- LHS of the signature; e.g.  f,g,h :: blah
       (LHsSigWcType name)   -- RHS of the signature; can have wildcards
696

Gergő Érdi's avatar
Gergő Érdi committed
697
      -- | A pattern synonym type signature
698
699
700
701
702
703
      --
      -- > pattern Single :: () => (Show a) => a -> [a]
      --
      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
      --           'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall'
      --           'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
704
705

      -- For details on above see note [Api annotations] in ApiAnnotation
706
  | PatSynSig (Located name) (LHsSigType name)
Rik Steenkamp's avatar
Rik Steenkamp committed
707
      -- P :: forall a b. Req => Prov => ty
708
709

      -- | A signature for a class method
Rik Steenkamp's avatar
Rik Steenkamp committed
710
      --   False: ordinary class-method signature
711
712
713
714
715
716
717
718
719
      --   True:  default class method signature
      -- e.g.   class C a where
      --          op :: a -> a                   -- Ordinary
      --          default op :: Eq a => a -> a   -- Generic default
      -- No wildcards allowed here
      --
      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
      --           'ApiAnnotation.AnnDcolon'
  | ClassOpSig Bool [Located name] (LHsSigType name)
720

721
        -- | A type signature in generated code, notably the code
722
723
724
725
        -- generated for record selectors.  We simply record
        -- the desired Id itself, replete with its name, type
        -- and IdDetails.  Otherwise it's just like a type
        -- signature: there should be an accompanying binding
726
  | IdSig Id
727

728
729
        -- | An ordinary fixity declaration
        --
Alan Zimmerman's avatar
Alan Zimmerman committed
730
        -- >     infixl 8 ***
731
        --
732
733
734
        --
        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix',
        --           'ApiAnnotation.AnnVal'
735
736

        -- For details on above see note [Api annotations] in ApiAnnotation
737
  | FixSig (FixitySig name)
738

739
740
741
742
        -- | An inline pragma
        --
        -- > {#- INLINE f #-}
        --
Alan Zimmerman's avatar
Alan Zimmerman committed
743
744
        --  - 'ApiAnnotation.AnnKeywordId' :
        --       'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@,
Alan Zimmerman's avatar
Alan Zimmerman committed
745
746
747
        --       'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',
        --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',
        --       'ApiAnnotation.AnnClose'
748
749

        -- For details on above see note [Api annotations] in ApiAnnotation
750
751
  | InlineSig   (Located name)  -- Function name
                InlinePragma    -- Never defaultInlinePragma
752

753
754
755
756
        -- | A specialisation pragma
        --
        -- > {-# SPECIALISE f :: Int -> Int #-}
        --
Alan Zimmerman's avatar
Alan Zimmerman committed
757
        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
Alan Zimmerman's avatar
Alan Zimmerman committed
758
759
760
761
762
        --      'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,
        --      'ApiAnnotation.AnnTilde',
        --      'ApiAnnotation.AnnVal',
        --      'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@,
        --      'ApiAnnotation.AnnDcolon'
763
764

        -- For details on above see note [Api annotations] in ApiAnnotation
765
766
767
768
769
  | SpecSig     (Located name)     -- Specialise a function or datatype  ...
                [LHsSigType name]  -- ... to these types
                InlinePragma       -- The pragma on SPECIALISE_INLINE form.
                                   -- If it's just defaultInlinePragma, then we said
                                   --    SPECIALISE, not SPECIALISE_INLINE
770

771
772
773
774
775
776
        -- | A specialisation pragma for instance declarations only
        --
        -- > {-# SPECIALISE instance Eq [Int] #-}
        --
        -- (Class tys); should be a specialisation of the
        -- current instance declaration
Alan Zimmerman's avatar
Alan Zimmerman committed
777
778
779
        --
        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
        --      'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
780
781

        -- For details on above see note [Api annotations] in ApiAnnotation
782
  | SpecInstSig SourceText (LHsSigType name)
Alan Zimmerman's avatar
Alan Zimmerman committed
783
                  -- Note [Pragma source text] in BasicTypes
784
785
786
787

        -- | A minimal complete definition pragma
        --
        -- > {-# MINIMAL a | (b, c | (d | e)) #-}
Alan Zimmerman's avatar
Alan Zimmerman committed
788
789
790
791
        --
        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
        --      'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',
        --      'ApiAnnotation.AnnClose'
792
793

        -- For details on above see note [Api annotations] in ApiAnnotation
794
  | MinimalSig SourceText (LBooleanFormula (Located name))
Alan Zimmerman's avatar
Alan Zimmerman committed
795
               -- Note [Pragma source text] in BasicTypes
796

797
798
  deriving (Typeable)
deriving instance (DataId name) => Data (Sig name)
799

800

801
type LFixitySig name = Located (FixitySig name)
802
data FixitySig name = FixitySig [Located name] Fixity
803
  deriving (Data, Typeable)
804

805
-- | TsSpecPrags conveys pragmas from the type checker to the desugarer
806
data TcSpecPrags
807
  = IsDefaultMethod     -- ^ Super-specialised: a default method should
808
                        -- be macro-expanded at every call site
809
  | SpecPrags [LTcSpecPrag]
810
  deriving (Data, Typeable)
811

812
813
type LTcSpecPrag = Located TcSpecPrag

814
815
data TcSpecPrag
  = SpecPrag
816
817
818
        Id
        HsWrapper
        InlinePragma
819
820
  -- ^ The Id to be specialised, an wrapper that specialises the
  -- polymorphic function, and inlining spec for the specialised function
821
  deriving (Data, Typeable)
822

823
824
825
826
827
828
829
830
831
832
833
noSpecPrags :: TcSpecPrags
noSpecPrags = SpecPrags []

hasSpecPrags :: TcSpecPrags -> Bool
hasSpecPrags (SpecPrags ps) = not (null ps)
hasSpecPrags IsDefaultMethod = False

isDefaultMethod :: TcSpecPrags -> Bool
isDefaultMethod IsDefaultMethod = True
isDefaultMethod (SpecPrags {})  = False

sof's avatar
sof committed
834

835
isFixityLSig :: LSig name -> Bool
836
isFixityLSig (L _ (FixSig {})) = True
837
isFixityLSig _                 = False
sof's avatar
sof committed
838

839
isTypeLSig :: LSig name -> Bool  -- Type signatures
840
isTypeLSig (L _(TypeSig {}))    = True
841
isTypeLSig (L _(ClassOpSig {})) = True
842
843
isTypeLSig (L _(IdSig {}))      = True
isTypeLSig _                    = False
844

845
isSpecLSig :: LSig name -> Bool
846
isSpecLSig (L _(SpecSig {})) = True
847
isSpecLSig _                 = False
848

849
isSpecInstLSig :: LSig name -> Bool
850
isSpecInstLSig (L _ (SpecInstSig {})) = True
851
isSpecInstLSig _                      = False
852

853
isPragLSig :: LSig name -> Bool
854
-- Identifies pragmas
855
856
isPragLSig (L _ (SpecSig {}))   = True
isPragLSig (L _ (InlineSig {})) = True
857
isPragLSig _                    = False
858
859

isInlineLSig :: LSig name -> Bool
860
-- Identifies inline pragmas
861
isInlineLSig (L _ (InlineSig {})) = True
862
isInlineLSig _                    = False
863

864
865
866
867
isMinimalLSig :: LSig name -> Bool
isMinimalLSig (L _ (MinimalSig {})) = True
isMinimalLSig _                    = False

868
hsSigDoc :: Sig name -> SDoc
869
870
hsSigDoc (TypeSig {})           = text "type signature"
hsSigDoc (PatSynSig {})         = text "pattern synonym signature"
871
hsSigDoc (ClassOpSig is_deflt _ _)
872
873
874
875
876
877
878
879
 | is_deflt                     = text "default type signature"
 | otherwise                    = text "class method signature"
hsSigDoc (IdSig {})             = text "id signature"
hsSigDoc (SpecSig {})           = text "SPECIALISE pragma"
hsSigDoc (InlineSig _ prag)     = ppr (inlinePragmaSpec prag) <+> text "pragma"
hsSigDoc (SpecInstSig {})       = text "SPECIALISE instance pragma"
hsSigDoc (FixSig {})            = text "fixity declaration"
hsSigDoc (MinimalSig {})        = text "MINIMAL pragma"
880

Austin Seipp's avatar
Austin Seipp committed
881
{-
882
883
884
Check if signatures overlap; this is used when checking for duplicate
signatures. Since some of the signatures contain a list of names, testing for
equality is not enough -- we have to check if they overlap.
Austin Seipp's avatar
Austin Seipp committed
885
-}
886

887
instance (OutputableBndr name) => Outputable (Sig name) where
888
    ppr sig = ppr_sig sig
sof's avatar
sof committed
889

890
ppr_sig :: OutputableBndr name => Sig name -> SDoc
891
892
ppr_sig (TypeSig vars ty)    = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (ClassOpSig is_deflt vars ty)
893
  | is_deflt                 = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
894
895
896
  | otherwise                = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (IdSig id)           = pprVarSig [id] (ppr (varType id))
ppr_sig (FixSig fix_sig)     = ppr fix_sig
897
898
ppr_sig (SpecSig var ty inl)
  = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
899
ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
Alan Zimmerman's avatar
Alan Zimmerman committed
900
ppr_sig (SpecInstSig _ ty)
901
  = pragBrackets (text "SPECIALIZE instance" <+> ppr ty)
Alan Zimmerman's avatar
Alan Zimmerman committed
902
ppr_sig (MinimalSig _ bf)         = pragBrackets (pprMinimalSig bf)
903
ppr_sig (PatSynSig name sig_ty)
904
  = text "pattern" <+> pprPrefixOcc (unLoc name) <+> dcolon
905
                           <+> ppr sig_ty
906

907
instance OutputableBndr name => Outputable (FixitySig name) where
908
909
910
  ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
    where
      pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
911

912
pragBrackets :: SDoc -> SDoc
913
pragBrackets doc = text "{-#" <+> doc <+> ptext (sLit "#-}")
914

915
pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
916
917
pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
  where
918
    pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
919

920
pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
Jan Stolarek's avatar