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