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