Allow CSE'ing of work-wrapped bindings (#14186)
[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 BangPatterns #-}
17
18 module HsBinds where
19
20 import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
21 MatchGroup, pprFunBind,
22 GRHSs, pprPatBind )
23 import {-# SOURCE #-} HsPat ( LPat )
24
25 import HsExtension
26 import HsTypes
27 import PprCore ()
28 import CoreSyn
29 import TcEvidence
30 import Type
31 import NameSet
32 import BasicTypes
33 import Outputable
34 import SrcLoc
35 import Var
36 import Bag
37 import FastString
38 import BooleanFormula (LBooleanFormula)
39 import DynFlags
40
41 import Data.Data hiding ( Fixity )
42 import Data.List hiding ( foldr )
43 import Data.Ord
44 import Data.Foldable ( Foldable(..) )
45
46 {-
47 ************************************************************************
48 * *
49 \subsection{Bindings: @BindGroup@}
50 * *
51 ************************************************************************
52
53 Global bindings (where clauses)
54 -}
55
56 -- During renaming, we need bindings where the left-hand sides
57 -- have been renamed but the the right-hand sides have not.
58 -- the ...LR datatypes are parametrized by two id types,
59 -- one for the left and one for the right.
60 -- Other than during renaming, these will be the same.
61
62 -- | Haskell Local Bindings
63 type HsLocalBinds id = HsLocalBindsLR id id
64
65 -- | Located Haskell local bindings
66 type LHsLocalBinds id = Located (HsLocalBinds id)
67
68 -- | Haskell Local Bindings with separate Left and Right identifier types
69 --
70 -- Bindings in a 'let' expression
71 -- or a 'where' clause
72 data HsLocalBindsLR idL idR
73 = HsValBinds (HsValBindsLR idL idR)
74 -- ^ Haskell Value Bindings
75
76 -- There should be no pattern synonyms in the HsValBindsLR
77 -- These are *local* (not top level) bindings
78 -- The parser accepts them, however, leaving the the
79 -- renamer to report them
80
81 | HsIPBinds (HsIPBinds idR)
82 -- ^ Haskell Implicit Parameter Bindings
83
84 | EmptyLocalBinds
85 -- ^ Empty Local Bindings
86
87 type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
88
89 deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR)
90
91 -- | Haskell Value Bindings
92 type HsValBinds id = HsValBindsLR id id
93
94 -- | Haskell Value bindings with separate Left and Right identifier types
95 -- (not implicit parameters)
96 -- Used for both top level and nested bindings
97 -- May contain pattern synonym bindings
98 data HsValBindsLR idL idR
99 = -- | Value Bindings In
100 --
101 -- Before renaming RHS; idR is always RdrName
102 -- Not dependency analysed
103 -- Recursive by default
104 ValBindsIn
105 (LHsBindsLR idL idR) [LSig idR]
106
107 -- | Value Bindings Out
108 --
109 -- After renaming RHS; idR can be Name or Id Dependency analysed,
110 -- later bindings in the list may depend on earlier ones.
111 | ValBindsOut
112 [(RecFlag, LHsBinds idL)]
113 [LSig GhcRn] -- AZ: how to do this?
114
115 deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR)
116
117 -- | Located Haskell Binding
118 type LHsBind id = LHsBindLR id id
119
120 -- | Located Haskell Bindings
121 type LHsBinds id = LHsBindsLR id id
122
123 -- | Haskell Binding
124 type HsBind id = HsBindLR id id
125
126 -- | Located Haskell Bindings with separate Left and Right identifier types
127 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
128
129 -- | Located Haskell Binding with separate Left and Right identifier types
130 type LHsBindLR idL idR = Located (HsBindLR idL idR)
131
132 {- Note [FunBind vs PatBind]
133 ~~~~~~~~~~~~~~~~~~~~~~~~~
134 The distinction between FunBind and PatBind is a bit subtle. FunBind covers
135 patterns which resemble function bindings and simple variable bindings.
136
137 f x = e
138 f !x = e
139 f = e
140 !x = e -- FunRhs has SrcStrict
141 x `f` y = e -- FunRhs has Infix
142
143 The actual patterns and RHSs of a FunBind are encoding in fun_matches.
144 The m_ctxt field of each Match in fun_matches will be FunRhs and carries
145 two bits of information about the match,
146
147 * The mc_fixity field on each Match describes the fixity of the
148 function binder in that match. E.g. this is legal:
149 f True False = e1
150 True `f` True = e2
151
152 * The mc_strictness field is used /only/ for nullary FunBinds: ones
153 with one Match, which has no pats. For these, it describes whether
154 the match is decorated with a bang (e.g. `!x = e`).
155
156 By contrast, PatBind represents data constructor patterns, as well as a few
157 other interesting cases. Namely,
158
159 Just x = e
160 (x) = e
161 x :: Ty = e
162 -}
163
164 -- | Haskell Binding with separate Left and Right id's
165 data HsBindLR idL idR
166 = -- | Function-like Binding
167 --
168 -- FunBind is used for both functions @f x = e@
169 -- and variables @f = \x -> e@
170 -- and strict variables @!x = x + 1@
171 --
172 -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
173 --
174 -- Reason 2: Instance decls can only have FunBinds, which is convenient.
175 -- If you change this, you'll need to change e.g. rnMethodBinds
176 --
177 -- But note that the form @f :: a->a = ...@
178 -- parses as a pattern binding, just like
179 -- @(f :: a -> a) = ... @
180 --
181 -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their
182 -- 'MatchContext'. See Note [FunBind vs PatBind] for
183 -- details about the relationship between FunBind and PatBind.
184 --
185 -- 'ApiAnnotation.AnnKeywordId's
186 --
187 -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches
188 --
189 -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
190 -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
191
192 -- For details on above see note [Api annotations] in ApiAnnotation
193 FunBind {
194
195 fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr
196
197 fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
198
199 fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
200 -- the Id. Example:
201 --
202 -- @
203 -- f :: Int -> forall a. a -> a
204 -- f x y = y
205 -- @
206 --
207 -- Then the MatchGroup will have type (Int -> a' -> a')
208 -- (with a free type variable a'). The coercion will take
209 -- a CoreExpr of this type and convert it to a CoreExpr of
210 -- type Int -> forall a'. a' -> a'
211 -- Notice that the coercion captures the free a'.
212
213 bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains
214 -- the locally-bound
215 -- free variables of this defn.
216 -- See Note [Bind free vars]
217
218
219 fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
220 }
221
222 -- | Pattern Binding
223 --
224 -- The pattern is never a simple variable;
225 -- That case is done by FunBind.
226 -- See Note [FunBind vs PatBind] for details about the
227 -- relationship between FunBind and PatBind.
228
229 --
230 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
231 -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
232 -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
233
234 -- For details on above see note [Api annotations] in ApiAnnotation
235 | PatBind {
236 pat_lhs :: LPat idL,
237 pat_rhs :: GRHSs idR (LHsExpr idR),
238 pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs
239 bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
240 pat_ticks :: ([Tickish Id], [[Tickish Id]])
241 -- ^ Ticks to put on the rhs, if any, and ticks to put on
242 -- the bound variables.
243 }
244
245 -- | Variable Binding
246 --
247 -- Dictionary binding and suchlike.
248 -- All VarBinds are introduced by the type checker
249 | VarBind {
250 var_id :: IdP idL,
251 var_rhs :: LHsExpr idR, -- ^ Located only for consistency
252 var_inline :: Bool -- ^ True <=> inline this binding regardless
253 -- (used for implication constraints only)
254 }
255
256 -- | Abstraction Bindings
257 | AbsBinds { -- Binds abstraction; TRANSLATION
258 abs_tvs :: [TyVar],
259 abs_ev_vars :: [EvVar], -- ^ Includes equality constraints
260
261 -- | AbsBinds only gets used when idL = idR after renaming,
262 -- but these need to be idL's for the collect... code in HsUtil
263 -- to have the right type
264 abs_exports :: [ABExport idL],
265
266 -- | Evidence bindings
267 -- Why a list? See TcInstDcls
268 -- Note [Typechecking plan for instance declarations]
269 abs_ev_binds :: [TcEvBinds],
270
271 -- | Typechecked user bindings
272 abs_binds :: LHsBinds idL,
273
274 abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds]
275 }
276
277 -- | Patterns Synonym Binding
278 | PatSynBind (PatSynBind idL idR)
279 -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
280 -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
281 -- 'ApiAnnotation.AnnWhere'
282 -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@
283
284 -- For details on above see note [Api annotations] in ApiAnnotation
285
286 deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR)
287
288 -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
289 --
290 -- Creates bindings for (polymorphic, overloaded) poly_f
291 -- in terms of monomorphic, non-overloaded mono_f
292 --
293 -- Invariants:
294 -- 1. 'binds' binds mono_f
295 -- 2. ftvs is a subset of tvs
296 -- 3. ftvs includes all tyvars free in ds
297 --
298 -- See Note [AbsBinds]
299
300 -- | Abtraction Bindings Export
301 data ABExport p
302 = ABE { abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id
303 , abe_mono :: IdP p
304 , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper]
305 -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
306 , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
307 }
308 deriving instance (DataId p) => Data (ABExport p)
309
310 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
311 -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
312 -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@,
313 -- 'ApiAnnotation.AnnClose' @'}'@,
314
315 -- For details on above see note [Api annotations] in ApiAnnotation
316
317 -- | Pattern Synonym binding
318 data PatSynBind idL idR
319 = PSB { psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym
320 psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars]
321 psb_args :: HsPatSynDetails (Located (IdP idR)),
322 -- ^ Formal parameter names
323 psb_def :: LPat idR, -- ^ Right-hand side
324 psb_dir :: HsPatSynDir idR -- ^ Directionality
325 }
326 deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR)
327
328 {-
329 Note [AbsBinds]
330 ~~~~~~~~~~~~~~~
331 The AbsBinds constructor is used in the output of the type checker, to
332 record *typechecked* and *generalised* bindings. Specifically
333
334 AbsBinds { abs_tvs = tvs
335 , abs_ev_vars = [d1,d2]
336 , abs_exports = [ABE { abe_poly = fp, abe_mono = fm
337 , abe_wrap = fwrap }
338 ABE { slly for g } ]
339 , abs_ev_binds = DBINDS
340 , abs_binds = BIND[fm,gm] }
341
342 where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means
343
344 fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ]
345 [ ; BIND[fm,gm] } ]
346 [ in fm ]
347
348 gp = ...same again, with gm instead of fm
349
350 The 'fwrap' is an impedence-matcher that typically does nothing; see
351 Note [ABExport wrapper].
352
353 This is a pretty bad translation, because it duplicates all the bindings.
354 So the desugarer tries to do a better job:
355
356 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
357 (fm,gm) -> fm
358 ..ditto for gp..
359
360 tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND }
361 in (fm,gm)
362
363 In general:
364
365 * abs_tvs are the type variables over which the binding group is
366 generalised
367 * abs_ev_var are the evidence variables (usually dictionaries)
368 over which the binding group is generalised
369 * abs_binds are the monomorphic bindings
370 * abs_ex_binds are the evidence bindings that wrap the abs_binds
371 * abs_exports connects the monomorphic Ids bound by abs_binds
372 with the polymorphic Ids bound by the AbsBinds itself.
373
374 For example, consider a module M, with this top-level binding, where
375 there is no type signature for M.reverse,
376 M.reverse [] = []
377 M.reverse (x:xs) = M.reverse xs ++ [x]
378
379 In Hindley-Milner, a recursive binding is typechecked with the
380 *recursive* uses being *monomorphic*. So after typechecking *and*
381 desugaring we will get something like this
382
383 M.reverse :: forall a. [a] -> [a]
384 = /\a. letrec
385 reverse :: [a] -> [a] = \xs -> case xs of
386 [] -> []
387 (x:xs) -> reverse xs ++ [x]
388 in reverse
389
390 Notice that 'M.reverse' is polymorphic as expected, but there is a local
391 definition for plain 'reverse' which is *monomorphic*. The type variable
392 'a' scopes over the entire letrec.
393
394 That's after desugaring. What about after type checking but before
395 desugaring? That's where AbsBinds comes in. It looks like this:
396
397 AbsBinds { abs_tvs = [a]
398 , abs_ev_vars = []
399 , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],
400 , abe_mono = reverse :: [a] -> [a]}]
401 , abs_ev_binds = {}
402 , abs_binds = { reverse :: [a] -> [a]
403 = \xs -> case xs of
404 [] -> []
405 (x:xs) -> reverse xs ++ [x] } }
406
407 Here,
408
409 * abs_tvs says what type variables are abstracted over the binding
410 group, just 'a' in this case.
411 * abs_binds is the *monomorphic* bindings of the group
412 * abs_exports describes how to get the polymorphic Id 'M.reverse'
413 from the monomorphic one 'reverse'
414
415 Notice that the *original* function (the polymorphic one you thought
416 you were defining) appears in the abe_poly field of the
417 abs_exports. The bindings in abs_binds are for fresh, local, Ids with
418 a *monomorphic* Id.
419
420 If there is a group of mutually recursive (see Note [Polymorphic
421 recursion]) functions without type signatures, we get one AbsBinds
422 with the monomorphic versions of the bindings in abs_binds, and one
423 element of abe_exports for each variable bound in the mutually
424 recursive group. This is true even for pattern bindings. Example:
425 (f,g) = (\x -> x, f)
426 After type checking we get
427 AbsBinds { abs_tvs = [a]
428 , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a
429 , abe_mono = f :: a -> a }
430 , ABE { abe_poly = M.g :: forall a. a -> a
431 , abe_mono = g :: a -> a }]
432 , abs_binds = { (f,g) = (\x -> x, f) }
433
434 Note [Polymorphic recursion]
435 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
436 Consider
437 Rec { f x = ...(g ef)...
438
439 ; g :: forall a. [a] -> [a]
440 ; g y = ...(f eg)... }
441
442 These bindings /are/ mutually recursive (f calls g, and g calls f).
443 But we can use the type signature for g to break the recursion,
444 like this:
445
446 1. Add g :: forall a. [a] -> [a] to the type environment
447
448 2. Typecheck the definition of f, all by itself,
449 including generalising it to find its most general
450 type, say f :: forall b. b -> b -> [b]
451
452 3. Extend the type environment with that type for f
453
454 4. Typecheck the definition of g, all by itself,
455 checking that it has the type claimed by its signature
456
457 Steps 2 and 4 each generate a separate AbsBinds, so we end
458 up with
459 Rec { AbsBinds { ...for f ... }
460 ; AbsBinds { ...for g ... } }
461
462 This approach allows both f and to call each other
463 polymorphically, even though only g has a signature.
464
465 We get an AbsBinds that encompasses multiple source-program
466 bindings only when
467 * Each binding in the group has at least one binder that
468 lacks a user type signature
469 * The group forms a strongly connected component
470
471
472 Note [The abs_sig field of AbsBinds]
473 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
474 The abs_sig field supports a couple of special cases for bindings.
475 Consider
476
477 x :: Num a => (# a, a #)
478 x = (# 3, 4 #)
479
480 The general desugaring for AbsBinds would give
481
482 x = /\a. \ ($dNum :: Num a) ->
483 letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in
484 xm
485
486 But that has an illegal let-binding for an unboxed tuple. In this
487 case we'd prefer to generate the (more direct)
488
489 x = /\ a. \ ($dNum :: Num a) ->
490 (# fromInteger $dNum 3, fromInteger $dNum 4 #)
491
492 A similar thing happens with representation-polymorphic defns
493 (Trac #11405):
494
495 undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
496 undef = error "undef"
497
498 Again, the vanilla desugaring gives a local let-binding for a
499 representation-polymorphic (undefm :: a), which is illegal. But
500 again we can desugar without a let:
501
502 undef = /\ a. \ (d:HasCallStack) -> error a d "undef"
503
504 The abs_sig field supports this direct desugaring, with no local
505 let-bining. When abs_sig = True
506
507 * the abs_binds is single FunBind
508
509 * the abs_exports is a singleton
510
511 * we have a complete type sig for binder
512 and hence the abs_binds is non-recursive
513 (it binds the mono_id but refers to the poly_id
514
515 These properties are exploited in DsBinds.dsAbsBinds to
516 generate code without a let-binding.
517
518 Note [ABExport wrapper]
519 ~~~~~~~~~~~~~~~~~~~~~~~
520 Consider
521 (f,g) = (\x.x, \y.y)
522 This ultimately desugars to something like this:
523 tup :: forall a b. (a->a, b->b)
524 tup = /\a b. (\x:a.x, \y:b.y)
525 f :: forall a. a -> a
526 f = /\a. case tup a Any of
527 (fm::a->a,gm:Any->Any) -> fm
528 ...similarly for g...
529
530 The abe_wrap field deals with impedance-matching between
531 (/\a b. case tup a b of { (f,g) -> f })
532 and the thing we really want, which may have fewer type
533 variables. The action happens in TcBinds.mkExport.
534
535 Note [Bind free vars]
536 ~~~~~~~~~~~~~~~~~~~~~
537 The bind_fvs field of FunBind and PatBind records the free variables
538 of the definition. It is used for the following purposes
539
540 a) Dependency analysis prior to type checking
541 (see TcBinds.tc_group)
542
543 b) Deciding whether we can do generalisation of the binding
544 (see TcBinds.decideGeneralisationPlan)
545
546 c) Deciding whether the binding can be used in static forms
547 (see TcExpr.checkClosedInStaticForm for the HsStatic case and
548 TcBinds.isClosedBndrGroup).
549
550 Specifically,
551
552 * bind_fvs includes all free vars that are defined in this module
553 (including top-level things and lexically scoped type variables)
554
555 * bind_fvs excludes imported vars; this is just to keep the set smaller
556
557 * Before renaming, and after typechecking, the field is unused;
558 it's just an error thunk
559 -}
560
561 instance (SourceTextX idL, SourceTextX idR,
562 OutputableBndrId idL, OutputableBndrId idR)
563 => Outputable (HsLocalBindsLR idL idR) where
564 ppr (HsValBinds bs) = ppr bs
565 ppr (HsIPBinds bs) = ppr bs
566 ppr EmptyLocalBinds = empty
567
568 instance (SourceTextX idL, SourceTextX idR,
569 OutputableBndrId idL, OutputableBndrId idR)
570 => Outputable (HsValBindsLR idL idR) where
571 ppr (ValBindsIn binds sigs)
572 = pprDeclList (pprLHsBindsForUser binds sigs)
573
574 ppr (ValBindsOut sccs sigs)
575 = getPprStyle $ \ sty ->
576 if debugStyle sty then -- Print with sccs showing
577 vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
578 else
579 pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)
580 where
581 ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
582 pp_rec Recursive = text "rec"
583 pp_rec NonRecursive = text "nonrec"
584
585 pprLHsBinds :: (SourceTextX idL, SourceTextX idR,
586 OutputableBndrId idL, OutputableBndrId idR)
587 => LHsBindsLR idL idR -> SDoc
588 pprLHsBinds binds
589 | isEmptyLHsBinds binds = empty
590 | otherwise = pprDeclList (map ppr (bagToList binds))
591
592 pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR,
593 OutputableBndrId idL, OutputableBndrId idR,
594 SourceTextX id2, OutputableBndrId id2)
595 => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
596 -- pprLHsBindsForUser is different to pprLHsBinds because
597 -- a) No braces: 'let' and 'where' include a list of HsBindGroups
598 -- and we don't want several groups of bindings each
599 -- with braces around
600 -- b) Sort by location before printing
601 -- c) Include signatures
602 pprLHsBindsForUser binds sigs
603 = map snd (sort_by_loc decls)
604 where
605
606 decls :: [(SrcSpan, SDoc)]
607 decls = [(loc, ppr sig) | L loc sig <- sigs] ++
608 [(loc, ppr bind) | L loc bind <- bagToList binds]
609
610 sort_by_loc decls = sortBy (comparing fst) decls
611
612 pprDeclList :: [SDoc] -> SDoc -- Braces with a space
613 -- Print a bunch of declarations
614 -- One could choose { d1; d2; ... }, using 'sep'
615 -- or d1
616 -- d2
617 -- ..
618 -- using vcat
619 -- At the moment we chose the latter
620 -- Also we do the 'pprDeeperList' thing.
621 pprDeclList ds = pprDeeperList vcat ds
622
623 ------------
624 emptyLocalBinds :: HsLocalBindsLR a b
625 emptyLocalBinds = EmptyLocalBinds
626
627 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
628 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
629 isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
630 isEmptyLocalBinds EmptyLocalBinds = True
631
632 eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
633 eqEmptyLocalBinds EmptyLocalBinds = True
634 eqEmptyLocalBinds _ = False
635
636 isEmptyValBinds :: HsValBindsLR a b -> Bool
637 isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
638 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
639
640 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
641 emptyValBindsIn = ValBindsIn emptyBag []
642 emptyValBindsOut = ValBindsOut [] []
643
644 emptyLHsBinds :: LHsBindsLR idL idR
645 emptyLHsBinds = emptyBag
646
647 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
648 isEmptyLHsBinds = isEmptyBag
649
650 ------------
651 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
652 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
653 = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
654 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
655 = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
656 plusHsValBinds _ _
657 = panic "HsBinds.plusHsValBinds"
658
659 instance (SourceTextX idL, SourceTextX idR,
660 OutputableBndrId idL, OutputableBndrId idR)
661 => Outputable (HsBindLR idL idR) where
662 ppr mbind = ppr_monobind mbind
663
664 ppr_monobind :: (SourceTextX idL, SourceTextX idR,
665 OutputableBndrId idL, OutputableBndrId idR)
666 => HsBindLR idL idR -> SDoc
667
668 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
669 = pprPatBind pat grhss
670 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
671 = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
672 ppr_monobind (FunBind { fun_id = fun,
673 fun_co_fn = wrap,
674 fun_matches = matches,
675 fun_tick = ticks })
676 = pprTicks empty (if null ticks then empty
677 else text "-- ticks = " <> ppr ticks)
678 $$ whenPprDebug (pprBndr LetBind (unLoc fun))
679 $$ pprFunBind matches
680 $$ whenPprDebug (ppr wrap)
681 ppr_monobind (PatSynBind psb) = ppr psb
682 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
683 , abs_exports = exports, abs_binds = val_binds
684 , abs_ev_binds = ev_binds })
685 = sdocWithDynFlags $ \ dflags ->
686 if gopt Opt_PrintTypecheckerElaboration dflags then
687 -- Show extra information (bug number: #10662)
688 hang (text "AbsBinds" <+> brackets (interpp'SP tyvars)
689 <+> brackets (interpp'SP dictvars))
690 2 $ braces $ vcat
691 [ text "Exports:" <+>
692 brackets (sep (punctuate comma (map ppr exports)))
693 , text "Exported types:" <+>
694 vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
695 , text "Binds:" <+> pprLHsBinds val_binds
696 , text "Evidence:" <+> ppr ev_binds ]
697 else
698 pprLHsBinds val_binds
699
700 instance (OutputableBndrId p) => Outputable (ABExport p) where
701 ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
702 = vcat [ ppr gbl <+> text "<=" <+> ppr lcl
703 , nest 2 (pprTcSpecPrags prags)
704 , nest 2 (text "wrap:" <+> ppr wrap)]
705
706 instance (SourceTextX idR,
707 OutputableBndrId idL, OutputableBndrId idR)
708 => Outputable (PatSynBind idL idR) where
709 ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
710 psb_dir = dir })
711 = ppr_lhs <+> ppr_rhs
712 where
713 ppr_lhs = text "pattern" <+> ppr_details
714 ppr_simple syntax = syntax <+> ppr pat
715
716 ppr_details = case details of
717 InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
718 PrefixPatSyn vs -> hsep (pprPrefixOcc psyn : map ppr vs)
719 RecordPatSyn vs ->
720 pprPrefixOcc psyn
721 <> braces (sep (punctuate comma (map ppr vs)))
722
723 ppr_rhs = case dir of
724 Unidirectional -> ppr_simple (text "<-")
725 ImplicitBidirectional -> ppr_simple equals
726 ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$
727 (nest 2 $ pprFunBind mg)
728
729 pprTicks :: SDoc -> SDoc -> SDoc
730 -- Print stuff about ticks only when -dppr-debug is on, to avoid
731 -- them appearing in error messages (from the desugarer); see Trac # 3263
732 -- Also print ticks in dumpStyle, so that -ddump-hpc actually does
733 -- something useful.
734 pprTicks pp_no_debug pp_when_debug
735 = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty
736 then pp_when_debug
737 else pp_no_debug)
738
739 {-
740 ************************************************************************
741 * *
742 Implicit parameter bindings
743 * *
744 ************************************************************************
745 -}
746
747 -- | Haskell Implicit Parameter Bindings
748 data HsIPBinds id
749 = IPBinds
750 [LIPBind id]
751 TcEvBinds -- Only in typechecker output; binds
752 -- uses of the implicit parameters
753 deriving instance (DataId id) => Data (HsIPBinds id)
754
755 isEmptyIPBinds :: HsIPBinds id -> Bool
756 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
757
758 -- | Located Implicit Parameter Binding
759 type LIPBind id = Located (IPBind id)
760 -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
761 -- list
762
763 -- For details on above see note [Api annotations] in ApiAnnotation
764
765 -- | Implicit parameter bindings.
766 --
767 -- These bindings start off as (Left "x") in the parser and stay
768 -- that way until after type-checking when they are replaced with
769 -- (Right d), where "d" is the name of the dictionary holding the
770 -- evidence for the implicit parameter.
771 --
772 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
773
774 -- For details on above see note [Api annotations] in ApiAnnotation
775 data IPBind id
776 = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id)
777 deriving instance (DataId name) => Data (IPBind name)
778
779 instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where
780 ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
781 $$ whenPprDebug (ppr ds)
782
783 instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where
784 ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
785 where name = case lr of
786 Left (L _ ip) -> pprBndr LetBind ip
787 Right id -> pprBndr LetBind id
788
789 {-
790 ************************************************************************
791 * *
792 \subsection{@Sig@: type signatures and value-modifying user pragmas}
793 * *
794 ************************************************************************
795
796 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
797 ``specialise this function to these four types...'') in with type
798 signatures. Then all the machinery to move them into place, etc.,
799 serves for both.
800 -}
801
802 -- | Located Signature
803 type LSig pass = Located (Sig pass)
804
805 -- | Signatures and pragmas
806 data Sig pass
807 = -- | An ordinary type signature
808 --
809 -- > f :: Num a => a -> a
810 --
811 -- After renaming, this list of Names contains the named and unnamed
812 -- wildcards brought into scope by this signature. For a signature
813 -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@
814 -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@
815 -- are then both replaced with fresh meta vars in the type. Their names
816 -- are stored in the type signature that brought them into scope, in
817 -- this third field to be more specific.
818 --
819 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
820 -- 'ApiAnnotation.AnnComma'
821
822 -- For details on above see note [Api annotations] in ApiAnnotation
823 TypeSig
824 [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah
825 (LHsSigWcType pass) -- RHS of the signature; can have wildcards
826
827 -- | A pattern synonym type signature
828 --
829 -- > pattern Single :: () => (Show a) => a -> [a]
830 --
831 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
832 -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall'
833 -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
834
835 -- For details on above see note [Api annotations] in ApiAnnotation
836 | PatSynSig [Located (IdP pass)] (LHsSigType pass)
837 -- P :: forall a b. Req => Prov => ty
838
839 -- | A signature for a class method
840 -- False: ordinary class-method signature
841 -- True: generic-default class method signature
842 -- e.g. class C a where
843 -- op :: a -> a -- Ordinary
844 -- default op :: Eq a => a -> a -- Generic default
845 -- No wildcards allowed here
846 --
847 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
848 -- 'ApiAnnotation.AnnDcolon'
849 | ClassOpSig Bool [Located (IdP pass)] (LHsSigType pass)
850
851 -- | A type signature in generated code, notably the code
852 -- generated for record selectors. We simply record
853 -- the desired Id itself, replete with its name, type
854 -- and IdDetails. Otherwise it's just like a type
855 -- signature: there should be an accompanying binding
856 | IdSig Id
857
858 -- | An ordinary fixity declaration
859 --
860 -- > infixl 8 ***
861 --
862 --
863 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix',
864 -- 'ApiAnnotation.AnnVal'
865
866 -- For details on above see note [Api annotations] in ApiAnnotation
867 | FixSig (FixitySig pass)
868
869 -- | An inline pragma
870 --
871 -- > {#- INLINE f #-}
872 --
873 -- - 'ApiAnnotation.AnnKeywordId' :
874 -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@,
875 -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',
876 -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',
877 -- 'ApiAnnotation.AnnClose'
878
879 -- For details on above see note [Api annotations] in ApiAnnotation
880 | InlineSig (Located (IdP pass)) -- Function name
881 InlinePragma -- Never defaultInlinePragma
882
883 -- | A specialisation pragma
884 --
885 -- > {-# SPECIALISE f :: Int -> Int #-}
886 --
887 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
888 -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,
889 -- 'ApiAnnotation.AnnTilde',
890 -- 'ApiAnnotation.AnnVal',
891 -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@,
892 -- 'ApiAnnotation.AnnDcolon'
893
894 -- For details on above see note [Api annotations] in ApiAnnotation
895 | SpecSig (Located (IdP pass)) -- Specialise a function or datatype ...
896 [LHsSigType pass] -- ... to these types
897 InlinePragma -- The pragma on SPECIALISE_INLINE form.
898 -- If it's just defaultInlinePragma, then we said
899 -- SPECIALISE, not SPECIALISE_INLINE
900
901 -- | A specialisation pragma for instance declarations only
902 --
903 -- > {-# SPECIALISE instance Eq [Int] #-}
904 --
905 -- (Class tys); should be a specialisation of the
906 -- current instance declaration
907 --
908 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
909 -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
910
911 -- For details on above see note [Api annotations] in ApiAnnotation
912 | SpecInstSig SourceText (LHsSigType pass)
913 -- Note [Pragma source text] in BasicTypes
914
915 -- | A minimal complete definition pragma
916 --
917 -- > {-# MINIMAL a | (b, c | (d | e)) #-}
918 --
919 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
920 -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',
921 -- 'ApiAnnotation.AnnClose'
922
923 -- For details on above see note [Api annotations] in ApiAnnotation
924 | MinimalSig SourceText (LBooleanFormula (Located (IdP pass)))
925 -- Note [Pragma source text] in BasicTypes
926
927 -- | A "set cost centre" pragma for declarations
928 --
929 -- > {-# SCC funName #-}
930 --
931 -- or
932 --
933 -- > {-# SCC funName "cost_centre_name" #-}
934
935 | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes
936 (Located (IdP pass)) -- Function name
937 (Maybe (Located StringLiteral))
938 -- | A complete match pragma
939 --
940 -- > {-# COMPLETE C, D [:: T] #-}
941 --
942 -- Used to inform the pattern match checker about additional
943 -- complete matchings which, for example, arise from pattern
944 -- synonym definitions.
945 | CompleteMatchSig SourceText
946 (Located [Located (IdP pass)])
947 (Maybe (Located (IdP pass)))
948
949 deriving instance (DataId pass) => Data (Sig pass)
950
951 -- | Located Fixity Signature
952 type LFixitySig pass = Located (FixitySig pass)
953
954 -- | Fixity Signature
955 data FixitySig pass = FixitySig [Located (IdP pass)] Fixity
956 deriving instance (DataId pass) => Data (FixitySig pass)
957
958 -- | Type checker Specialisation Pragmas
959 --
960 -- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer
961 data TcSpecPrags
962 = IsDefaultMethod -- ^ Super-specialised: a default method should
963 -- be macro-expanded at every call site
964 | SpecPrags [LTcSpecPrag]
965 deriving Data
966
967 -- | Located Type checker Specification Pragmas
968 type LTcSpecPrag = Located TcSpecPrag
969
970 -- | Type checker Specification Pragma
971 data TcSpecPrag
972 = SpecPrag
973 Id
974 HsWrapper
975 InlinePragma
976 -- ^ The Id to be specialised, an wrapper that specialises the
977 -- polymorphic function, and inlining spec for the specialised function
978 deriving Data
979
980 noSpecPrags :: TcSpecPrags
981 noSpecPrags = SpecPrags []
982
983 hasSpecPrags :: TcSpecPrags -> Bool
984 hasSpecPrags (SpecPrags ps) = not (null ps)
985 hasSpecPrags IsDefaultMethod = False
986
987 isDefaultMethod :: TcSpecPrags -> Bool
988 isDefaultMethod IsDefaultMethod = True
989 isDefaultMethod (SpecPrags {}) = False
990
991
992 isFixityLSig :: LSig name -> Bool
993 isFixityLSig (L _ (FixSig {})) = True
994 isFixityLSig _ = False
995
996 isTypeLSig :: LSig name -> Bool -- Type signatures
997 isTypeLSig (L _(TypeSig {})) = True
998 isTypeLSig (L _(ClassOpSig {})) = True
999 isTypeLSig (L _(IdSig {})) = True
1000 isTypeLSig _ = False
1001
1002 isSpecLSig :: LSig name -> Bool
1003 isSpecLSig (L _(SpecSig {})) = True
1004 isSpecLSig _ = False
1005
1006 isSpecInstLSig :: LSig name -> Bool
1007 isSpecInstLSig (L _ (SpecInstSig {})) = True
1008 isSpecInstLSig _ = False
1009
1010 isPragLSig :: LSig name -> Bool
1011 -- Identifies pragmas
1012 isPragLSig (L _ (SpecSig {})) = True
1013 isPragLSig (L _ (InlineSig {})) = True
1014 isPragLSig (L _ (SCCFunSig {})) = True
1015 isPragLSig (L _ (CompleteMatchSig {})) = True
1016 isPragLSig _ = False
1017
1018 isInlineLSig :: LSig name -> Bool
1019 -- Identifies inline pragmas
1020 isInlineLSig (L _ (InlineSig {})) = True
1021 isInlineLSig _ = False
1022
1023 isMinimalLSig :: LSig name -> Bool
1024 isMinimalLSig (L _ (MinimalSig {})) = True
1025 isMinimalLSig _ = False
1026
1027 isSCCFunSig :: LSig name -> Bool
1028 isSCCFunSig (L _ (SCCFunSig {})) = True
1029 isSCCFunSig _ = False
1030
1031 isCompleteMatchSig :: LSig name -> Bool
1032 isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True
1033 isCompleteMatchSig _ = False
1034
1035 hsSigDoc :: Sig name -> SDoc
1036 hsSigDoc (TypeSig {}) = text "type signature"
1037 hsSigDoc (PatSynSig {}) = text "pattern synonym signature"
1038 hsSigDoc (ClassOpSig is_deflt _ _)
1039 | is_deflt = text "default type signature"
1040 | otherwise = text "class method signature"
1041 hsSigDoc (IdSig {}) = text "id signature"
1042 hsSigDoc (SpecSig {}) = text "SPECIALISE pragma"
1043 hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma"
1044 hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma"
1045 hsSigDoc (FixSig {}) = text "fixity declaration"
1046 hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"
1047 hsSigDoc (SCCFunSig {}) = text "SCC pragma"
1048 hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"
1049
1050 {-
1051 Check if signatures overlap; this is used when checking for duplicate
1052 signatures. Since some of the signatures contain a list of names, testing for
1053 equality is not enough -- we have to check if they overlap.
1054 -}
1055
1056 instance (SourceTextX pass, OutputableBndrId pass)
1057 => Outputable (Sig pass) where
1058 ppr sig = ppr_sig sig
1059
1060 ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc
1061 ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
1062 ppr_sig (ClassOpSig is_deflt vars ty)
1063 | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
1064 | otherwise = pprVarSig (map unLoc vars) (ppr ty)
1065 ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id))
1066 ppr_sig (FixSig fix_sig) = ppr fix_sig
1067 ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec }))
1068 = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var)
1069 (interpp'SP ty) inl)
1070 where
1071 pragmaSrc = case spec of
1072 NoUserInline -> "{-# SPECIALISE"
1073 _ -> "{-# SPECIALISE_INLINE"
1074 ppr_sig (InlineSig var inl)
1075 = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl
1076 <+> pprPrefixOcc (unLoc var))
1077 ppr_sig (SpecInstSig src ty)
1078 = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty)
1079 ppr_sig (MinimalSig src bf)
1080 = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)
1081 ppr_sig (PatSynSig names sig_ty)
1082 = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
1083 ppr_sig (SCCFunSig src fn mlabel)
1084 = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )
1085 ppr_sig (CompleteMatchSig src cs mty)
1086 = pragSrcBrackets src "{-# COMPLETE"
1087 ((hsep (punctuate comma (map ppr (unLoc cs))))
1088 <+> opt_sig)
1089 where
1090 opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
1091
1092 instance OutputableBndrId pass => Outputable (FixitySig pass) where
1093 ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
1094 where
1095 pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
1096
1097 pragBrackets :: SDoc -> SDoc
1098 pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
1099
1100 -- | Using SourceText in case the pragma was spelled differently or used mixed
1101 -- case
1102 pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc
1103 pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}"
1104 pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}"
1105
1106 pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
1107 pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
1108 where
1109 pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
1110
1111 pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
1112 pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty
1113 where
1114 pp_inl | isDefaultInlinePragma inl = empty
1115 | otherwise = pprInline inl
1116
1117 pprTcSpecPrags :: TcSpecPrags -> SDoc
1118 pprTcSpecPrags IsDefaultMethod = text "<default method>"
1119 pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
1120
1121 instance Outputable TcSpecPrag where
1122 ppr (SpecPrag var _ inl)
1123 = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl
1124
1125 pprMinimalSig :: (OutputableBndr name)
1126 => LBooleanFormula (Located name) -> SDoc
1127 pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
1128
1129 {-
1130 ************************************************************************
1131 * *
1132 \subsection[PatSynBind]{A pattern synonym definition}
1133 * *
1134 ************************************************************************
1135 -}
1136
1137 -- | Haskell Pattern Synonym Details
1138 data HsPatSynDetails a
1139 = InfixPatSyn a a -- ^ Infix Pattern Synonym
1140 | PrefixPatSyn [a] -- ^ Prefix Pattern Synonym
1141 | RecordPatSyn [RecordPatSynField a] -- ^ Record Pattern Synonym
1142 deriving Data
1143
1144
1145 -- See Note [Record PatSyn Fields]
1146 -- | Record Pattern Synonym Field
1147 data RecordPatSynField a
1148 = RecordPatSynField {
1149 recordPatSynSelectorId :: a -- Selector name visible in rest of the file
1150 , recordPatSynPatVar :: a
1151 -- Filled in by renamer, the name used internally
1152 -- by the pattern
1153 } deriving Data
1154
1155
1156
1157 {-
1158 Note [Record PatSyn Fields]
1159
1160 Consider the following two pattern synonyms.
1161
1162 pattern P x y = ([x,True], [y,'v'])
1163 pattern Q{ x, y } =([x,True], [y,'v'])
1164
1165 In P, we just have two local binders, x and y.
1166
1167 In Q, we have local binders but also top-level record selectors
1168 x :: ([Bool], [Char]) -> Bool and similarly for y.
1169
1170 It would make sense to support record-like syntax
1171
1172 pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])
1173
1174 when we have a different name for the local and top-level binder
1175 the distinction between the two names clear
1176
1177 -}
1178 instance Functor RecordPatSynField where
1179 fmap f (RecordPatSynField { recordPatSynSelectorId = visible
1180 , recordPatSynPatVar = hidden })
1181 = RecordPatSynField { recordPatSynSelectorId = f visible
1182 , recordPatSynPatVar = f hidden }
1183
1184 instance Outputable a => Outputable (RecordPatSynField a) where
1185 ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v
1186
1187 instance Foldable RecordPatSynField where
1188 foldMap f (RecordPatSynField { recordPatSynSelectorId = visible
1189 , recordPatSynPatVar = hidden })
1190 = f visible `mappend` f hidden
1191
1192 instance Traversable RecordPatSynField where
1193 traverse f (RecordPatSynField { recordPatSynSelectorId =visible
1194 , recordPatSynPatVar = hidden })
1195 = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id
1196 , recordPatSynPatVar = pat_var })
1197 <$> f visible <*> f hidden
1198
1199
1200 instance Functor HsPatSynDetails where
1201 fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
1202 fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
1203 fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args)
1204
1205 instance Foldable HsPatSynDetails where
1206 foldMap f (InfixPatSyn left right) = f left `mappend` f right
1207 foldMap f (PrefixPatSyn args) = foldMap f args
1208 foldMap f (RecordPatSyn args) = foldMap (foldMap f) args
1209
1210 foldl1 f (InfixPatSyn left right) = left `f` right
1211 foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
1212 foldl1 f (RecordPatSyn args) =
1213 Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args)
1214
1215 foldr1 f (InfixPatSyn left right) = left `f` right
1216 foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
1217 foldr1 f (RecordPatSyn args) =
1218 Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args)
1219
1220 length (InfixPatSyn _ _) = 2
1221 length (PrefixPatSyn args) = Data.List.length args
1222 length (RecordPatSyn args) = Data.List.length args
1223
1224 null (InfixPatSyn _ _) = False
1225 null (PrefixPatSyn args) = Data.List.null args
1226 null (RecordPatSyn args) = Data.List.null args
1227
1228 toList (InfixPatSyn left right) = [left, right]
1229 toList (PrefixPatSyn args) = args
1230 toList (RecordPatSyn args) = foldMap toList args
1231
1232 instance Traversable HsPatSynDetails where
1233 traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
1234 traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
1235 traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args
1236
1237 -- | Haskell Pattern Synonym Direction
1238 data HsPatSynDir id
1239 = Unidirectional
1240 | ImplicitBidirectional
1241 | ExplicitBidirectional (MatchGroup id (LHsExpr id))
1242 deriving instance (DataId id) => Data (HsPatSynDir id)