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