Implement Partial Type Signatures
[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       -- @f :: Num a => a -> a@
589       -- After renaming, this list of Names contains the named and unnamed
590       -- wildcards brought into scope by this signature. For a signature
591       -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@
592       -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@
593       -- are then both replaced with fresh meta vars in the type. Their names
594       -- are stored in the type signature that brought them into scope, in
595       -- this third field to be more specific.
596       --
597       --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
598       --          'ApiAnnotation.AnnComma'
599     TypeSig [Located name] (LHsType name) (PostRn name [Name])
600
601       -- | A pattern synonym type signature
602       -- @pattern type forall b. (Eq b) => P a b :: forall a. (Num a) => T a
603   | PatSynSig (Located name)
604               (HsExplicitFlag, LHsTyVarBndrs name)
605               (LHsContext name) -- Provided context
606               (LHsContext name) -- Required context
607               (LHsType name)
608
609         -- | A type signature for a default method inside a class
610         --
611         -- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
612         --
613   | GenericSig [Located name] (LHsType name)
614
615         -- | A type signature in generated code, notably the code
616         -- generated for record selectors.  We simply record
617         -- the desired Id itself, replete with its name, type
618         -- and IdDetails.  Otherwise it's just like a type
619         -- signature: there should be an accompanying binding
620         --
621         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
622         --           'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnDotdot'
623
624   | IdSig Id
625
626         -- | An ordinary fixity declaration
627         --
628         -- >     infixl 8 ***
629         --
630   | FixSig (FixitySig name)
631
632         -- | An inline pragma
633         --
634         -- > {#- INLINE f #-}
635         --
636         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
637         --       'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',
638         --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',
639         --       'ApiAnnotation.AnnClose'
640   | InlineSig   (Located name)  -- Function name
641                 InlinePragma    -- Never defaultInlinePragma
642
643         -- | A specialisation pragma
644         --
645         -- > {-# SPECIALISE f :: Int -> Int #-}
646         --
647         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
648         --      'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
649         --      'ApiAnnotation.AnnVal','ApiAnnotation.AnnClose',
650         --      'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose',
651   | SpecSig     (Located name)  -- Specialise a function or datatype  ...
652                 [LHsType name]  -- ... to these types
653                 InlinePragma    -- The pragma on SPECIALISE_INLINE form.
654                                 -- If it's just defaultInlinePragma, then we said
655                                 --    SPECIALISE, not SPECIALISE_INLINE
656
657         -- | A specialisation pragma for instance declarations only
658         --
659         -- > {-# SPECIALISE instance Eq [Int] #-}
660         --
661         -- (Class tys); should be a specialisation of the
662         -- current instance declaration
663         --
664         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
665         --      'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
666   | SpecInstSig (LHsType name)
667
668         -- | A minimal complete definition pragma
669         --
670         -- > {-# MINIMAL a | (b, c | (d | e)) #-}
671         --
672         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
673         --      'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',
674         --      'ApiAnnotation.AnnClose'
675   | MinimalSig (BooleanFormula (Located name))
676
677   deriving (Typeable)
678 deriving instance (DataId name) => Data (Sig name)
679
680
681 type LFixitySig name = Located (FixitySig name)
682 data FixitySig name = FixitySig [Located name] Fixity
683   deriving (Data, Typeable)
684
685 -- | TsSpecPrags conveys pragmas from the type checker to the desugarer
686 data TcSpecPrags
687   = IsDefaultMethod     -- ^ Super-specialised: a default method should
688                         -- be macro-expanded at every call site
689   | SpecPrags [LTcSpecPrag]
690   deriving (Data, Typeable)
691
692 type LTcSpecPrag = Located TcSpecPrag
693
694 data TcSpecPrag
695   = SpecPrag
696         Id
697         HsWrapper
698         InlinePragma
699   -- ^ The Id to be specialised, an wrapper that specialises the
700   -- polymorphic function, and inlining spec for the specialised function
701   deriving (Data, Typeable)
702
703 noSpecPrags :: TcSpecPrags
704 noSpecPrags = SpecPrags []
705
706 hasSpecPrags :: TcSpecPrags -> Bool
707 hasSpecPrags (SpecPrags ps) = not (null ps)
708 hasSpecPrags IsDefaultMethod = False
709
710 isDefaultMethod :: TcSpecPrags -> Bool
711 isDefaultMethod IsDefaultMethod = True
712 isDefaultMethod (SpecPrags {})  = False
713
714
715 isFixityLSig :: LSig name -> Bool
716 isFixityLSig (L _ (FixSig {})) = True
717 isFixityLSig _                 = False
718
719 isVanillaLSig :: LSig name -> Bool       -- User type signatures
720 -- A badly-named function, but it's part of the GHCi (used
721 -- by Haddock) so I don't want to change it gratuitously.
722 isVanillaLSig (L _(TypeSig {})) = True
723 isVanillaLSig _                 = False
724
725 isTypeLSig :: LSig name -> Bool  -- Type signatures
726 isTypeLSig (L _(TypeSig {}))    = True
727 isTypeLSig (L _(GenericSig {})) = True
728 isTypeLSig (L _(IdSig {}))      = True
729 isTypeLSig _                    = False
730
731 isSpecLSig :: LSig name -> Bool
732 isSpecLSig (L _(SpecSig {})) = True
733 isSpecLSig _                 = False
734
735 isSpecInstLSig :: LSig name -> Bool
736 isSpecInstLSig (L _ (SpecInstSig {})) = True
737 isSpecInstLSig _                      = False
738
739 isPragLSig :: LSig name -> Bool
740 -- Identifies pragmas
741 isPragLSig (L _ (SpecSig {}))   = True
742 isPragLSig (L _ (InlineSig {})) = True
743 isPragLSig _                    = False
744
745 isInlineLSig :: LSig name -> Bool
746 -- Identifies inline pragmas
747 isInlineLSig (L _ (InlineSig {})) = True
748 isInlineLSig _                    = False
749
750 isMinimalLSig :: LSig name -> Bool
751 isMinimalLSig (L _ (MinimalSig {})) = True
752 isMinimalLSig _                    = False
753
754 hsSigDoc :: Sig name -> SDoc
755 hsSigDoc (TypeSig {})           = ptext (sLit "type signature")
756 hsSigDoc (PatSynSig {})         = ptext (sLit "pattern synonym signature")
757 hsSigDoc (GenericSig {})        = ptext (sLit "default type signature")
758 hsSigDoc (IdSig {})             = ptext (sLit "id signature")
759 hsSigDoc (SpecSig {})           = ptext (sLit "SPECIALISE pragma")
760 hsSigDoc (InlineSig _ prag)     = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma")
761 hsSigDoc (SpecInstSig {})       = ptext (sLit "SPECIALISE instance pragma")
762 hsSigDoc (FixSig {})            = ptext (sLit "fixity declaration")
763 hsSigDoc (MinimalSig {})        = ptext (sLit "MINIMAL pragma")
764 \end{code}
765
766 Check if signatures overlap; this is used when checking for duplicate
767 signatures. Since some of the signatures contain a list of names, testing for
768 equality is not enough -- we have to check if they overlap.
769
770 \begin{code}
771 instance (OutputableBndr name) => Outputable (Sig name) where
772     ppr sig = ppr_sig sig
773
774 ppr_sig :: OutputableBndr name => Sig name -> SDoc
775 ppr_sig (TypeSig vars ty _wcs)    = pprVarSig (map unLoc vars) (ppr ty)
776 ppr_sig (GenericSig vars ty)      = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
777 ppr_sig (IdSig id)                = pprVarSig [id] (ppr (varType id))
778 ppr_sig (FixSig fix_sig)          = ppr fix_sig
779 ppr_sig (SpecSig var ty inl)
780   = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
781 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
782 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
783 ppr_sig (MinimalSig bf)           = pragBrackets (pprMinimalSig bf)
784 ppr_sig (PatSynSig name (flag, qtvs) (L _ prov) (L _ req) ty)
785   = pprPatSynSig (unLoc name) False -- TODO: is_bindir
786                  (pprHsForAll flag qtvs (noLoc []))
787                  (pprHsContextMaybe prov) (pprHsContextMaybe req)
788                  (ppr ty)
789
790 pprPatSynSig :: (OutputableBndr name)
791              => name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
792 pprPatSynSig ident _is_bidir tvs prov req ty
793   = ptext (sLit "pattern") <+> pprPrefixOcc ident <+> dcolon <+>
794     tvs <+> context <+> ty
795   where
796     context = case (prov, req) of
797         (Nothing, Nothing)    -> empty
798         (Nothing, Just req)   -> parens empty <+> darrow <+> req <+> darrow
799         (Just prov, Nothing)  -> prov <+> darrow
800         (Just prov, Just req) -> prov <+> darrow <+> req <+> darrow
801
802 instance OutputableBndr name => Outputable (FixitySig name) where
803   ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
804     where
805       pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
806
807 pragBrackets :: SDoc -> SDoc
808 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
809
810 pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
811 pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
812   where
813     pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
814
815 pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
816 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty
817   where
818     pp_inl | isDefaultInlinePragma inl = empty
819            | otherwise = ppr inl
820
821 pprTcSpecPrags :: TcSpecPrags -> SDoc
822 pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
823 pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)
824
825 instance Outputable TcSpecPrag where
826   ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
827
828 pprMinimalSig :: OutputableBndr name => BooleanFormula (Located name) -> SDoc
829 pprMinimalSig bf = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf)
830 \end{code}
831
832 %************************************************************************
833 %*                                                                      *
834 \subsection[PatSynBind]{A pattern synonym definition}
835 %*                                                                      *
836 %************************************************************************
837
838 \begin{code}
839 data HsPatSynDetails a
840   = InfixPatSyn a a
841   | PrefixPatSyn [a]
842   deriving (Data, Typeable)
843
844 instance Functor HsPatSynDetails where
845     fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
846     fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
847
848 instance Foldable HsPatSynDetails where
849     foldMap f (InfixPatSyn left right) = f left `mappend` f right
850     foldMap f (PrefixPatSyn args) = foldMap f args
851
852     foldl1 f (InfixPatSyn left right) = left `f` right
853     foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
854
855     foldr1 f (InfixPatSyn left right) = left `f` right
856     foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
857
858 -- TODO: After a few more versions, we should probably use these.
859 #if __GLASGOW_HASKELL__ >= 709
860     length (InfixPatSyn _ _) = 2
861     length (PrefixPatSyn args) = Data.List.length args
862
863     null (InfixPatSyn _ _) = False
864     null (PrefixPatSyn args) = Data.List.null args
865
866     toList (InfixPatSyn left right) = [left, right]
867     toList (PrefixPatSyn args) = args
868 #endif
869
870 instance Traversable HsPatSynDetails where
871     traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
872     traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
873
874 data HsPatSynDir id
875   = Unidirectional
876   | ImplicitBidirectional
877   | ExplicitBidirectional (MatchGroup id (LHsExpr id))
878   deriving (Typeable)
879 deriving instance (DataId id) => Data (HsPatSynDir id)
880 \end{code}