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