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