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