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