TcInteract: Ensure that tycons have representations before solving for Typeable
[ghc.git] / compiler / basicTypes / BasicTypes.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
4
5 \section[BasicTypes]{Miscellanous types}
6
7 This module defines a miscellaneously collection of very simple
8 types that
9
10 \begin{itemize}
11 \item have no other obvious home
12 \item don't depend on any other complicated types
13 \item are used in more than one "part" of the compiler
14 \end{itemize}
15 -}
16
17 {-# LANGUAGE DeriveDataTypeable #-}
18
19 module BasicTypes(
20 Version, bumpVersion, initialVersion,
21
22 LeftOrRight(..),
23 pickLR,
24
25 ConTag, ConTagZ, fIRST_TAG,
26
27 Arity, RepArity, JoinArity,
28
29 Alignment,
30
31 FunctionOrData(..),
32
33 WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),
34
35 Fixity(..), FixityDirection(..),
36 defaultFixity, maxPrecedence, minPrecedence,
37 negateFixity, funTyFixity,
38 compareFixity,
39 LexicalFixity(..),
40
41 RecFlag(..), isRec, isNonRec, boolToRecFlag,
42 Origin(..), isGenerated,
43
44 RuleName, pprRuleName,
45
46 TopLevelFlag(..), isTopLevel, isNotTopLevel,
47
48 DerivStrategy(..),
49
50 OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
51 hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
52
53 Boxity(..), isBoxed,
54
55 TyPrec(..), maybeParen,
56
57 TupleSort(..), tupleSortBoxity, boxityTupleSort,
58 tupleParens,
59
60 sumParens, pprAlternative,
61
62 -- ** The OneShotInfo type
63 OneShotInfo(..),
64 noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
65 bestOneShot, worstOneShot,
66
67 OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,
68 isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,
69 strongLoopBreaker, weakLoopBreaker,
70
71 InsideLam, insideLam, notInsideLam,
72 OneBranch, oneBranch, notOneBranch,
73 InterestingCxt,
74 TailCallInfo(..), tailCallInfo, zapOccTailCallInfo,
75 isAlwaysTailCalled,
76
77 EP(..),
78
79 DefMethSpec(..),
80 SwapFlag(..), flipSwap, unSwap, isSwapped,
81
82 CompilerPhase(..), PhaseNum,
83
84 Activation(..), isActive, isActiveIn, competesWith,
85 isNeverActive, isAlwaysActive, isEarlyActive,
86
87 RuleMatchInfo(..), isConLike, isFunLike,
88 InlineSpec(..), noUserInlineSpec,
89 InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
90 neverInlinePragma, dfunInlinePragma,
91 isDefaultInlinePragma,
92 isInlinePragma, isInlinablePragma, isAnyInlinePragma,
93 inlinePragmaSpec, inlinePragmaSat,
94 inlinePragmaActivation, inlinePragmaRuleMatchInfo,
95 setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
96 pprInline, pprInlineDebug,
97
98 SuccessFlag(..), succeeded, failed, successIf,
99
100 IntegralLit(..), FractionalLit(..),
101 negateIntegralLit, negateFractionalLit,
102 mkIntegralLit, mkFractionalLit,
103 integralFractionalLit,
104
105 SourceText(..), pprWithSourceText,
106
107 IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,
108
109 SpliceExplicitFlag(..)
110 ) where
111
112 import GhcPrelude
113
114 import FastString
115 import Outputable
116 import SrcLoc ( Located,unLoc )
117 import Data.Data hiding (Fixity, Prefix, Infix)
118 import Data.Function (on)
119
120 {-
121 ************************************************************************
122 * *
123 Binary choice
124 * *
125 ************************************************************************
126 -}
127
128 data LeftOrRight = CLeft | CRight
129 deriving( Eq, Data )
130
131 pickLR :: LeftOrRight -> (a,a) -> a
132 pickLR CLeft (l,_) = l
133 pickLR CRight (_,r) = r
134
135 instance Outputable LeftOrRight where
136 ppr CLeft = text "Left"
137 ppr CRight = text "Right"
138
139 {-
140 ************************************************************************
141 * *
142 \subsection[Arity]{Arity}
143 * *
144 ************************************************************************
145 -}
146
147 -- | The number of value arguments that can be applied to a value before it does
148 -- "real work". So:
149 -- fib 100 has arity 0
150 -- \x -> fib x has arity 1
151 -- See also Note [Definition of arity] in CoreArity
152 type Arity = Int
153
154 -- | Representation Arity
155 --
156 -- The number of represented arguments that can be applied to a value before it does
157 -- "real work". So:
158 -- fib 100 has representation arity 0
159 -- \x -> fib x has representation arity 1
160 -- \(# x, y #) -> fib (x + y) has representation arity 2
161 type RepArity = Int
162
163 -- | The number of arguments that a join point takes. Unlike the arity of a
164 -- function, this is a purely syntactic property and is fixed when the join
165 -- point is created (or converted from a value). Both type and value arguments
166 -- are counted.
167 type JoinArity = Int
168
169 {-
170 ************************************************************************
171 * *
172 Constructor tags
173 * *
174 ************************************************************************
175 -}
176
177 -- | Constructor Tag
178 --
179 -- Type of the tags associated with each constructor possibility or superclass
180 -- selector
181 type ConTag = Int
182
183 -- | A *zero-indexed* constructor tag
184 type ConTagZ = Int
185
186 fIRST_TAG :: ConTag
187 -- ^ Tags are allocated from here for real constructors
188 -- or for superclass selectors
189 fIRST_TAG = 1
190
191 {-
192 ************************************************************************
193 * *
194 \subsection[Alignment]{Alignment}
195 * *
196 ************************************************************************
197 -}
198
199 type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
200
201 {-
202 ************************************************************************
203 * *
204 One-shot information
205 * *
206 ************************************************************************
207 -}
208
209 -- | If the 'Id' is a lambda-bound variable then it may have lambda-bound
210 -- variable info. Sometimes we know whether the lambda binding this variable
211 -- is a \"one-shot\" lambda; that is, whether it is applied at most once.
212 --
213 -- This information may be useful in optimisation, as computations may
214 -- safely be floated inside such a lambda without risk of duplicating
215 -- work.
216 data OneShotInfo
217 = NoOneShotInfo -- ^ No information
218 | OneShotLam -- ^ The lambda is applied at most once.
219 deriving (Eq)
220
221 -- | It is always safe to assume that an 'Id' has no lambda-bound variable information
222 noOneShotInfo :: OneShotInfo
223 noOneShotInfo = NoOneShotInfo
224
225 isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool
226 isOneShotInfo OneShotLam = True
227 isOneShotInfo _ = False
228
229 hasNoOneShotInfo NoOneShotInfo = True
230 hasNoOneShotInfo _ = False
231
232 worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo
233 worstOneShot NoOneShotInfo _ = NoOneShotInfo
234 worstOneShot OneShotLam os = os
235
236 bestOneShot NoOneShotInfo os = os
237 bestOneShot OneShotLam _ = OneShotLam
238
239 pprOneShotInfo :: OneShotInfo -> SDoc
240 pprOneShotInfo NoOneShotInfo = empty
241 pprOneShotInfo OneShotLam = text "OneShot"
242
243 instance Outputable OneShotInfo where
244 ppr = pprOneShotInfo
245
246 {-
247 ************************************************************************
248 * *
249 Swap flag
250 * *
251 ************************************************************************
252 -}
253
254 data SwapFlag
255 = NotSwapped -- Args are: actual, expected
256 | IsSwapped -- Args are: expected, actual
257
258 instance Outputable SwapFlag where
259 ppr IsSwapped = text "Is-swapped"
260 ppr NotSwapped = text "Not-swapped"
261
262 flipSwap :: SwapFlag -> SwapFlag
263 flipSwap IsSwapped = NotSwapped
264 flipSwap NotSwapped = IsSwapped
265
266 isSwapped :: SwapFlag -> Bool
267 isSwapped IsSwapped = True
268 isSwapped NotSwapped = False
269
270 unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
271 unSwap NotSwapped f a b = f a b
272 unSwap IsSwapped f a b = f b a
273
274 {-
275 ************************************************************************
276 * *
277 \subsection[FunctionOrData]{FunctionOrData}
278 * *
279 ************************************************************************
280 -}
281
282 data FunctionOrData = IsFunction | IsData
283 deriving (Eq, Ord, Data)
284
285 instance Outputable FunctionOrData where
286 ppr IsFunction = text "(function)"
287 ppr IsData = text "(data)"
288
289 {-
290 ************************************************************************
291 * *
292 \subsection[Version]{Module and identifier version numbers}
293 * *
294 ************************************************************************
295 -}
296
297 type Version = Int
298
299 bumpVersion :: Version -> Version
300 bumpVersion v = v+1
301
302 initialVersion :: Version
303 initialVersion = 1
304
305 {-
306 ************************************************************************
307 * *
308 Deprecations
309 * *
310 ************************************************************************
311 -}
312
313 -- | A String Literal in the source, including its original raw format for use by
314 -- source to source manipulation tools.
315 data StringLiteral = StringLiteral
316 { sl_st :: SourceText, -- literal raw source.
317 -- See not [Literal source text]
318 sl_fs :: FastString -- literal string value
319 } deriving Data
320
321 instance Eq StringLiteral where
322 (StringLiteral _ a) == (StringLiteral _ b) = a == b
323
324 instance Outputable StringLiteral where
325 ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)
326
327 -- | Warning Text
328 --
329 -- reason/explanation from a WARNING or DEPRECATED pragma
330 data WarningTxt = WarningTxt (Located SourceText)
331 [Located StringLiteral]
332 | DeprecatedTxt (Located SourceText)
333 [Located StringLiteral]
334 deriving (Eq, Data)
335
336 instance Outputable WarningTxt where
337 ppr (WarningTxt lsrc ws)
338 = case unLoc lsrc of
339 NoSourceText -> pp_ws ws
340 SourceText src -> text src <+> pp_ws ws <+> text "#-}"
341
342 ppr (DeprecatedTxt lsrc ds)
343 = case unLoc lsrc of
344 NoSourceText -> pp_ws ds
345 SourceText src -> text src <+> pp_ws ds <+> text "#-}"
346
347 pp_ws :: [Located StringLiteral] -> SDoc
348 pp_ws [l] = ppr $ unLoc l
349 pp_ws ws
350 = text "["
351 <+> vcat (punctuate comma (map (ppr . unLoc) ws))
352 <+> text "]"
353
354
355 pprWarningTxtForMsg :: WarningTxt -> SDoc
356 pprWarningTxtForMsg (WarningTxt _ ws)
357 = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
358 pprWarningTxtForMsg (DeprecatedTxt _ ds)
359 = text "Deprecated:" <+>
360 doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
361
362 {-
363 ************************************************************************
364 * *
365 Rules
366 * *
367 ************************************************************************
368 -}
369
370 type RuleName = FastString
371
372 pprRuleName :: RuleName -> SDoc
373 pprRuleName rn = doubleQuotes (ftext rn)
374
375 {-
376 ************************************************************************
377 * *
378 \subsection[Fixity]{Fixity info}
379 * *
380 ************************************************************************
381 -}
382
383 ------------------------
384 data Fixity = Fixity SourceText Int FixityDirection
385 -- Note [Pragma source text]
386 deriving Data
387
388 instance Outputable Fixity where
389 ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]
390
391 instance Eq Fixity where -- Used to determine if two fixities conflict
392 (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2
393
394 ------------------------
395 data FixityDirection = InfixL | InfixR | InfixN
396 deriving (Eq, Data)
397
398 instance Outputable FixityDirection where
399 ppr InfixL = text "infixl"
400 ppr InfixR = text "infixr"
401 ppr InfixN = text "infix"
402
403 ------------------------
404 maxPrecedence, minPrecedence :: Int
405 maxPrecedence = 9
406 minPrecedence = 0
407
408 defaultFixity :: Fixity
409 defaultFixity = Fixity NoSourceText maxPrecedence InfixL
410
411 negateFixity, funTyFixity :: Fixity
412 -- Wired-in fixities
413 negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate
414 funTyFixity = Fixity NoSourceText 0 InfixR -- Fixity of '->'
415
416 {-
417 Consider
418
419 \begin{verbatim}
420 a `op1` b `op2` c
421 \end{verbatim}
422 @(compareFixity op1 op2)@ tells which way to arrange application, or
423 whether there's an error.
424 -}
425
426 compareFixity :: Fixity -> Fixity
427 -> (Bool, -- Error please
428 Bool) -- Associate to the right: a op1 (b op2 c)
429 compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)
430 = case prec1 `compare` prec2 of
431 GT -> left
432 LT -> right
433 EQ -> case (dir1, dir2) of
434 (InfixR, InfixR) -> right
435 (InfixL, InfixL) -> left
436 _ -> error_please
437 where
438 right = (False, True)
439 left = (False, False)
440 error_please = (True, False)
441
442 -- |Captures the fixity of declarations as they are parsed. This is not
443 -- necessarily the same as the fixity declaration, as the normal fixity may be
444 -- overridden using parens or backticks.
445 data LexicalFixity = Prefix | Infix deriving (Data,Eq)
446
447 instance Outputable LexicalFixity where
448 ppr Prefix = text "Prefix"
449 ppr Infix = text "Infix"
450
451 {-
452 ************************************************************************
453 * *
454 \subsection[Top-level/local]{Top-level/not-top level flag}
455 * *
456 ************************************************************************
457 -}
458
459 data TopLevelFlag
460 = TopLevel
461 | NotTopLevel
462
463 isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool
464
465 isNotTopLevel NotTopLevel = True
466 isNotTopLevel TopLevel = False
467
468 isTopLevel TopLevel = True
469 isTopLevel NotTopLevel = False
470
471 instance Outputable TopLevelFlag where
472 ppr TopLevel = text "<TopLevel>"
473 ppr NotTopLevel = text "<NotTopLevel>"
474
475 {-
476 ************************************************************************
477 * *
478 Boxity flag
479 * *
480 ************************************************************************
481 -}
482
483 data Boxity
484 = Boxed
485 | Unboxed
486 deriving( Eq, Data )
487
488 isBoxed :: Boxity -> Bool
489 isBoxed Boxed = True
490 isBoxed Unboxed = False
491
492 instance Outputable Boxity where
493 ppr Boxed = text "Boxed"
494 ppr Unboxed = text "Unboxed"
495
496 {-
497 ************************************************************************
498 * *
499 Recursive/Non-Recursive flag
500 * *
501 ************************************************************************
502 -}
503
504 -- | Recursivity Flag
505 data RecFlag = Recursive
506 | NonRecursive
507 deriving( Eq, Data )
508
509 isRec :: RecFlag -> Bool
510 isRec Recursive = True
511 isRec NonRecursive = False
512
513 isNonRec :: RecFlag -> Bool
514 isNonRec Recursive = False
515 isNonRec NonRecursive = True
516
517 boolToRecFlag :: Bool -> RecFlag
518 boolToRecFlag True = Recursive
519 boolToRecFlag False = NonRecursive
520
521 instance Outputable RecFlag where
522 ppr Recursive = text "Recursive"
523 ppr NonRecursive = text "NonRecursive"
524
525 {-
526 ************************************************************************
527 * *
528 Code origin
529 * *
530 ************************************************************************
531 -}
532
533 data Origin = FromSource
534 | Generated
535 deriving( Eq, Data )
536
537 isGenerated :: Origin -> Bool
538 isGenerated Generated = True
539 isGenerated FromSource = False
540
541 instance Outputable Origin where
542 ppr FromSource = text "FromSource"
543 ppr Generated = text "Generated"
544
545 {-
546 ************************************************************************
547 * *
548 Deriving strategies
549 * *
550 ************************************************************************
551 -}
552
553 -- | Which technique the user explicitly requested when deriving an instance.
554 data DerivStrategy
555 -- See Note [Deriving strategies] in TcDeriv
556 = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a
557 -- custom instance for the data type. This only works
558 -- for certain types that GHC knows about (e.g., 'Eq',
559 -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled,
560 -- etc.)
561 | AnyclassStrategy -- ^ @-XDeriveAnyClass@
562 | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@
563 deriving (Eq, Data)
564
565 instance Outputable DerivStrategy where
566 ppr StockStrategy = text "stock"
567 ppr AnyclassStrategy = text "anyclass"
568 ppr NewtypeStrategy = text "newtype"
569
570 {-
571 ************************************************************************
572 * *
573 Instance overlap flag
574 * *
575 ************************************************************************
576 -}
577
578 -- | The semantics allowed for overlapping instances for a particular
579 -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a
580 -- explanation of the `isSafeOverlap` field.
581 --
582 -- - 'ApiAnnotation.AnnKeywordId' :
583 -- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
584 -- @'\{-\# OVERLAPPING'@ or
585 -- @'\{-\# OVERLAPS'@ or
586 -- @'\{-\# INCOHERENT'@,
587 -- 'ApiAnnotation.AnnClose' @`\#-\}`@,
588
589 -- For details on above see note [Api annotations] in ApiAnnotation
590 data OverlapFlag = OverlapFlag
591 { overlapMode :: OverlapMode
592 , isSafeOverlap :: Bool
593 } deriving (Eq, Data)
594
595 setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag
596 setOverlapModeMaybe f Nothing = f
597 setOverlapModeMaybe f (Just m) = f { overlapMode = m }
598
599 hasIncoherentFlag :: OverlapMode -> Bool
600 hasIncoherentFlag mode =
601 case mode of
602 Incoherent _ -> True
603 _ -> False
604
605 hasOverlappableFlag :: OverlapMode -> Bool
606 hasOverlappableFlag mode =
607 case mode of
608 Overlappable _ -> True
609 Overlaps _ -> True
610 Incoherent _ -> True
611 _ -> False
612
613 hasOverlappingFlag :: OverlapMode -> Bool
614 hasOverlappingFlag mode =
615 case mode of
616 Overlapping _ -> True
617 Overlaps _ -> True
618 Incoherent _ -> True
619 _ -> False
620
621 data OverlapMode -- See Note [Rules for instance lookup] in InstEnv
622 = NoOverlap SourceText
623 -- See Note [Pragma source text]
624 -- ^ This instance must not overlap another `NoOverlap` instance.
625 -- However, it may be overlapped by `Overlapping` instances,
626 -- and it may overlap `Overlappable` instances.
627
628
629 | Overlappable SourceText
630 -- See Note [Pragma source text]
631 -- ^ Silently ignore this instance if you find a
632 -- more specific one that matches the constraint
633 -- you are trying to resolve
634 --
635 -- Example: constraint (Foo [Int])
636 -- instance Foo [Int]
637 -- instance {-# OVERLAPPABLE #-} Foo [a]
638 --
639 -- Since the second instance has the Overlappable flag,
640 -- the first instance will be chosen (otherwise
641 -- its ambiguous which to choose)
642
643
644 | Overlapping SourceText
645 -- See Note [Pragma source text]
646 -- ^ Silently ignore any more general instances that may be
647 -- used to solve the constraint.
648 --
649 -- Example: constraint (Foo [Int])
650 -- instance {-# OVERLAPPING #-} Foo [Int]
651 -- instance Foo [a]
652 --
653 -- Since the first instance has the Overlapping flag,
654 -- the second---more general---instance will be ignored (otherwise
655 -- it is ambiguous which to choose)
656
657
658 | Overlaps SourceText
659 -- See Note [Pragma source text]
660 -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
661
662 | Incoherent SourceText
663 -- See Note [Pragma source text]
664 -- ^ Behave like Overlappable and Overlapping, and in addition pick
665 -- an an arbitrary one if there are multiple matching candidates, and
666 -- don't worry about later instantiation
667 --
668 -- Example: constraint (Foo [b])
669 -- instance {-# INCOHERENT -} Foo [Int]
670 -- instance Foo [a]
671 -- Without the Incoherent flag, we'd complain that
672 -- instantiating 'b' would change which instance
673 -- was chosen. See also note [Incoherent instances] in InstEnv
674
675 deriving (Eq, Data)
676
677
678 instance Outputable OverlapFlag where
679 ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
680
681 instance Outputable OverlapMode where
682 ppr (NoOverlap _) = empty
683 ppr (Overlappable _) = text "[overlappable]"
684 ppr (Overlapping _) = text "[overlapping]"
685 ppr (Overlaps _) = text "[overlap ok]"
686 ppr (Incoherent _) = text "[incoherent]"
687
688 pprSafeOverlap :: Bool -> SDoc
689 pprSafeOverlap True = text "[safe]"
690 pprSafeOverlap False = empty
691
692 {-
693 ************************************************************************
694 * *
695 Type precedence
696 * *
697 ************************************************************************
698 -}
699
700 data TyPrec -- See Note [Precedence in types] in TyCoRep.hs
701 = TopPrec -- No parens
702 | FunPrec -- Function args; no parens for tycon apps
703 | TyOpPrec -- Infix operator
704 | TyConPrec -- Tycon args; no parens for atomic
705
706 instance Eq TyPrec where
707 (==) a b = case compare a b of
708 EQ -> True
709 _ -> False
710
711 instance Ord TyPrec where
712 compare TopPrec TopPrec = EQ
713 compare TopPrec _ = LT
714
715 compare FunPrec TopPrec = GT
716 compare FunPrec FunPrec = EQ
717 compare FunPrec TyOpPrec = EQ -- See Note [Type operator precedence]
718 compare FunPrec TyConPrec = LT
719
720 compare TyOpPrec TopPrec = GT
721 compare TyOpPrec FunPrec = EQ -- See Note [Type operator precedence]
722 compare TyOpPrec TyOpPrec = EQ
723 compare TyOpPrec TyConPrec = LT
724
725 compare TyConPrec TyConPrec = EQ
726 compare TyConPrec _ = GT
727
728 maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc
729 maybeParen ctxt_prec inner_prec pretty
730 | ctxt_prec < inner_prec = pretty
731 | otherwise = parens pretty
732
733 {- Note [Precedence in types]
734 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
735 Many pretty-printing functions have type
736 ppr_ty :: TyPrec -> Type -> SDoc
737
738 The TyPrec gives the binding strength of the context. For example, in
739 T ty1 ty2
740 we will pretty-print 'ty1' and 'ty2' with the call
741 (ppr_ty TyConPrec ty)
742 to indicate that the context is that of an argument of a TyConApp.
743
744 We use this consistently for Type and HsType.
745
746 Note [Type operator precedence]
747 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
748 We don't keep the fixity of type operators in the operator. So the
749 pretty printer follows the following precedence order:
750
751 TyConPrec Type constructor application
752 TyOpPrec/FunPrec Operator application and function arrow
753
754 We have FunPrec and TyOpPrec to represent the precedence of function
755 arrow and type operators respectively, but currently we implement
756 FunPred == TyOpPrec, so that we don't distinguish the two. Reason:
757 it's hard to parse a type like
758 a ~ b => c * d -> e - f
759
760 By treating TyOpPrec = FunPrec we end up with more parens
761 (a ~ b) => (c * d) -> (e - f)
762
763 But the two are different constructors of TyPrec so we could make
764 (->) bind more or less tightly if we wanted.
765 -}
766
767 {-
768 ************************************************************************
769 * *
770 Tuples
771 * *
772 ************************************************************************
773 -}
774
775 data TupleSort
776 = BoxedTuple
777 | UnboxedTuple
778 | ConstraintTuple
779 deriving( Eq, Data )
780
781 tupleSortBoxity :: TupleSort -> Boxity
782 tupleSortBoxity BoxedTuple = Boxed
783 tupleSortBoxity UnboxedTuple = Unboxed
784 tupleSortBoxity ConstraintTuple = Boxed
785
786 boxityTupleSort :: Boxity -> TupleSort
787 boxityTupleSort Boxed = BoxedTuple
788 boxityTupleSort Unboxed = UnboxedTuple
789
790 tupleParens :: TupleSort -> SDoc -> SDoc
791 tupleParens BoxedTuple p = parens p
792 tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)")
793 tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %)
794 = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)"))
795 (parens p)
796
797 {-
798 ************************************************************************
799 * *
800 Sums
801 * *
802 ************************************************************************
803 -}
804
805 sumParens :: SDoc -> SDoc
806 sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
807
808 -- | Pretty print an alternative in an unboxed sum e.g. "| a | |".
809 pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use
810 -> a -- ^ The things to be pretty printed
811 -> ConTag -- ^ Alternative (one-based)
812 -> Arity -- ^ Arity
813 -> SDoc -- ^ 'SDoc' where the alternative havs been pretty
814 -- printed and finally packed into a paragraph.
815 pprAlternative pp x alt arity =
816 fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)
817
818 {-
819 ************************************************************************
820 * *
821 \subsection[Generic]{Generic flag}
822 * *
823 ************************************************************************
824
825 This is the "Embedding-Projection pair" datatype, it contains
826 two pieces of code (normally either RenamedExpr's or Id's)
827 If we have a such a pair (EP from to), the idea is that 'from' and 'to'
828 represents functions of type
829
830 from :: T -> Tring
831 to :: Tring -> T
832
833 And we should have
834
835 to (from x) = x
836
837 T and Tring are arbitrary, but typically T is the 'main' type while
838 Tring is the 'representation' type. (This just helps us remember
839 whether to use 'from' or 'to'.
840 -}
841
842 -- | Embedding Projection pair
843 data EP a = EP { fromEP :: a, -- :: T -> Tring
844 toEP :: a } -- :: Tring -> T
845
846 {-
847 Embedding-projection pairs are used in several places:
848
849 First of all, each type constructor has an EP associated with it, the
850 code in EP converts (datatype T) from T to Tring and back again.
851
852 Secondly, when we are filling in Generic methods (in the typechecker,
853 tcMethodBinds), we are constructing bimaps by induction on the structure
854 of the type of the method signature.
855
856
857 ************************************************************************
858 * *
859 \subsection{Occurrence information}
860 * *
861 ************************************************************************
862
863 This data type is used exclusively by the simplifier, but it appears in a
864 SubstResult, which is currently defined in VarEnv, which is pretty near
865 the base of the module hierarchy. So it seemed simpler to put the
866 defn of OccInfo here, safely at the bottom
867 -}
868
869 -- | identifier Occurrence Information
870 data OccInfo
871 = ManyOccs { occ_tail :: !TailCallInfo }
872 -- ^ There are many occurrences, or unknown occurrences
873
874 | IAmDead -- ^ Marks unused variables. Sometimes useful for
875 -- lambda and case-bound variables.
876
877 | OneOcc { occ_in_lam :: !InsideLam
878 , occ_one_br :: !OneBranch
879 , occ_int_cxt :: !InterestingCxt
880 , occ_tail :: !TailCallInfo }
881 -- ^ Occurs exactly once (per branch), not inside a rule
882
883 -- | This identifier breaks a loop of mutually recursive functions. The field
884 -- marks whether it is only a loop breaker due to a reference in a rule
885 | IAmALoopBreaker { occ_rules_only :: !RulesOnly
886 , occ_tail :: !TailCallInfo }
887 -- Note [LoopBreaker OccInfo]
888
889 deriving (Eq)
890
891 type RulesOnly = Bool
892
893 {-
894 Note [LoopBreaker OccInfo]
895 ~~~~~~~~~~~~~~~~~~~~~~~~~~
896 IAmALoopBreaker True <=> A "weak" or rules-only loop breaker
897 Do not preInlineUnconditionally
898
899 IAmALoopBreaker False <=> A "strong" loop breaker
900 Do not inline at all
901
902 See OccurAnal Note [Weak loop breakers]
903 -}
904
905 noOccInfo :: OccInfo
906 noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }
907
908 isManyOccs :: OccInfo -> Bool
909 isManyOccs ManyOccs{} = True
910 isManyOccs _ = False
911
912 seqOccInfo :: OccInfo -> ()
913 seqOccInfo occ = occ `seq` ()
914
915 -----------------
916 -- | Interesting Context
917 type InterestingCxt = Bool -- True <=> Function: is applied
918 -- Data value: scrutinised by a case with
919 -- at least one non-DEFAULT branch
920
921 -----------------
922 -- | Inside Lambda
923 type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda
924 -- Substituting a redex for this occurrence is
925 -- dangerous because it might duplicate work.
926 insideLam, notInsideLam :: InsideLam
927 insideLam = True
928 notInsideLam = False
929
930 -----------------
931 type OneBranch = Bool -- True <=> Occurs in only one case branch
932 -- so no code-duplication issue to worry about
933 oneBranch, notOneBranch :: OneBranch
934 oneBranch = True
935 notOneBranch = False
936
937 -----------------
938 data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]
939 | NoTailCallInfo
940 deriving (Eq)
941
942 tailCallInfo :: OccInfo -> TailCallInfo
943 tailCallInfo IAmDead = NoTailCallInfo
944 tailCallInfo other = occ_tail other
945
946 zapOccTailCallInfo :: OccInfo -> OccInfo
947 zapOccTailCallInfo IAmDead = IAmDead
948 zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo }
949
950 isAlwaysTailCalled :: OccInfo -> Bool
951 isAlwaysTailCalled occ
952 = case tailCallInfo occ of AlwaysTailCalled{} -> True
953 NoTailCallInfo -> False
954
955 instance Outputable TailCallInfo where
956 ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ]
957 ppr _ = empty
958
959 -----------------
960 strongLoopBreaker, weakLoopBreaker :: OccInfo
961 strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo
962 weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo
963
964 isWeakLoopBreaker :: OccInfo -> Bool
965 isWeakLoopBreaker (IAmALoopBreaker{}) = True
966 isWeakLoopBreaker _ = False
967
968 isStrongLoopBreaker :: OccInfo -> Bool
969 isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True
970 -- Loop-breaker that breaks a non-rule cycle
971 isStrongLoopBreaker _ = False
972
973 isDeadOcc :: OccInfo -> Bool
974 isDeadOcc IAmDead = True
975 isDeadOcc _ = False
976
977 isOneOcc :: OccInfo -> Bool
978 isOneOcc (OneOcc {}) = True
979 isOneOcc _ = False
980
981 zapFragileOcc :: OccInfo -> OccInfo
982 -- Keep only the most robust data: deadness, loop-breaker-hood
983 zapFragileOcc (OneOcc {}) = noOccInfo
984 zapFragileOcc occ = zapOccTailCallInfo occ
985
986 instance Outputable OccInfo where
987 -- only used for debugging; never parsed. KSW 1999-07
988 ppr (ManyOccs tails) = pprShortTailCallInfo tails
989 ppr IAmDead = text "Dead"
990 ppr (IAmALoopBreaker rule_only tails)
991 = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails
992 where
993 pp_ro | rule_only = char '!'
994 | otherwise = empty
995 ppr (OneOcc inside_lam one_branch int_cxt tail_info)
996 = text "Once" <> pp_lam <> pp_br <> pp_args <> pp_tail
997 where
998 pp_lam | inside_lam = char 'L'
999 | otherwise = empty
1000 pp_br | one_branch = empty
1001 | otherwise = char '*'
1002 pp_args | int_cxt = char '!'
1003 | otherwise = empty
1004 pp_tail = pprShortTailCallInfo tail_info
1005
1006 pprShortTailCallInfo :: TailCallInfo -> SDoc
1007 pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar)
1008 pprShortTailCallInfo NoTailCallInfo = empty
1009
1010 {-
1011 Note [TailCallInfo]
1012 ~~~~~~~~~~~~~~~~~~~
1013 The occurrence analyser determines what can be made into a join point, but it
1014 doesn't change the binder into a JoinId because then it would be inconsistent
1015 with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to
1016 change the IdDetails.
1017
1018 The AlwaysTailCalled marker actually means slightly more than simply that the
1019 function is always tail-called. See Note [Invariants on join points].
1020
1021 This info is quite fragile and should not be relied upon unless the occurrence
1022 analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of
1023 the join-point-hood of a binder; a join id itself will not be marked
1024 AlwaysTailCalled.
1025
1026 Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that
1027 being tail-called would mean that the variable could only appear once per branch
1028 (thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join
1029 point can also be invoked from other join points, not just from case branches:
1030
1031 let j1 x = ...
1032 j2 y = ... j1 z {- tail call -} ...
1033 in case w of
1034 A -> j1 v
1035 B -> j2 u
1036 C -> j2 q
1037
1038 Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get
1039 ManyOccs and j2 will get `OneOcc { occ_one_br = True }`.
1040
1041 ************************************************************************
1042 * *
1043 Default method specification
1044 * *
1045 ************************************************************************
1046
1047 The DefMethSpec enumeration just indicates what sort of default method
1048 is used for a class. It is generated from source code, and present in
1049 interface files; it is converted to Class.DefMethInfo before begin put in a
1050 Class object.
1051 -}
1052
1053 -- | Default Method Specification
1054 data DefMethSpec ty
1055 = VanillaDM -- Default method given with polymorphic code
1056 | GenericDM ty -- Default method given with code of this type
1057
1058 instance Outputable (DefMethSpec ty) where
1059 ppr VanillaDM = text "{- Has default method -}"
1060 ppr (GenericDM {}) = text "{- Has generic default method -}"
1061
1062 {-
1063 ************************************************************************
1064 * *
1065 \subsection{Success flag}
1066 * *
1067 ************************************************************************
1068 -}
1069
1070 data SuccessFlag = Succeeded | Failed
1071
1072 instance Outputable SuccessFlag where
1073 ppr Succeeded = text "Succeeded"
1074 ppr Failed = text "Failed"
1075
1076 successIf :: Bool -> SuccessFlag
1077 successIf True = Succeeded
1078 successIf False = Failed
1079
1080 succeeded, failed :: SuccessFlag -> Bool
1081 succeeded Succeeded = True
1082 succeeded Failed = False
1083
1084 failed Succeeded = False
1085 failed Failed = True
1086
1087 {-
1088 ************************************************************************
1089 * *
1090 \subsection{Source Text}
1091 * *
1092 ************************************************************************
1093 Keeping Source Text for source to source conversions
1094
1095 Note [Pragma source text]
1096 ~~~~~~~~~~~~~~~~~~~~~~~~~
1097 The lexer does a case-insensitive match for pragmas, as well as
1098 accepting both UK and US spelling variants.
1099
1100 So
1101
1102 {-# SPECIALISE #-}
1103 {-# SPECIALIZE #-}
1104 {-# Specialize #-}
1105
1106 will all generate ITspec_prag token for the start of the pragma.
1107
1108 In order to be able to do source to source conversions, the original
1109 source text for the token needs to be preserved, hence the
1110 `SourceText` field.
1111
1112 So the lexer will then generate
1113
1114 ITspec_prag "{ -# SPECIALISE"
1115 ITspec_prag "{ -# SPECIALIZE"
1116 ITspec_prag "{ -# Specialize"
1117
1118 for the cases above.
1119 [without the space between '{' and '-', otherwise this comment won't parse]
1120
1121
1122 Note [Literal source text]
1123 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1124 The lexer/parser converts literals from their original source text
1125 versions to an appropriate internal representation. This is a problem
1126 for tools doing source to source conversions, so the original source
1127 text is stored in literals where this can occur.
1128
1129 Motivating examples for HsLit
1130
1131 HsChar '\n' == '\x20`
1132 HsCharPrim '\x41`# == `A`
1133 HsString "\x20\x41" == " A"
1134 HsStringPrim "\x20"# == " "#
1135 HsInt 001 == 1
1136 HsIntPrim 002# == 2#
1137 HsWordPrim 003## == 3##
1138 HsInt64Prim 004## == 4##
1139 HsWord64Prim 005## == 5##
1140 HsInteger 006 == 6
1141
1142 For OverLitVal
1143
1144 HsIntegral 003 == 0x003
1145 HsIsString "\x41nd" == "And"
1146 -}
1147
1148 -- Note [Literal source text],[Pragma source text]
1149 data SourceText = SourceText String
1150 | NoSourceText -- ^ For when code is generated, e.g. TH,
1151 -- deriving. The pretty printer will then make
1152 -- its own representation of the item.
1153 deriving (Data, Show, Eq )
1154
1155 instance Outputable SourceText where
1156 ppr (SourceText s) = text "SourceText" <+> text s
1157 ppr NoSourceText = text "NoSourceText"
1158
1159 -- | Special combinator for showing string literals.
1160 pprWithSourceText :: SourceText -> SDoc -> SDoc
1161 pprWithSourceText NoSourceText d = d
1162 pprWithSourceText (SourceText src) _ = text src
1163
1164 {-
1165 ************************************************************************
1166 * *
1167 \subsection{Activation}
1168 * *
1169 ************************************************************************
1170
1171 When a rule or inlining is active
1172 -}
1173
1174 -- | Phase Number
1175 type PhaseNum = Int -- Compilation phase
1176 -- Phases decrease towards zero
1177 -- Zero is the last phase
1178
1179 data CompilerPhase
1180 = Phase PhaseNum
1181 | InitialPhase -- The first phase -- number = infinity!
1182
1183 instance Outputable CompilerPhase where
1184 ppr (Phase n) = int n
1185 ppr InitialPhase = text "InitialPhase"
1186
1187 -- See note [Pragma source text]
1188 data Activation = NeverActive
1189 | AlwaysActive
1190 | ActiveBefore SourceText PhaseNum
1191 -- Active only *strictly before* this phase
1192 | ActiveAfter SourceText PhaseNum
1193 -- Active in this phase and later
1194 deriving( Eq, Data )
1195 -- Eq used in comparing rules in HsDecls
1196
1197 -- | Rule Match Information
1198 data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma]
1199 | FunLike
1200 deriving( Eq, Data, Show )
1201 -- Show needed for Lexer.x
1202
1203 data InlinePragma -- Note [InlinePragma]
1204 = InlinePragma
1205 { inl_src :: SourceText -- Note [Pragma source text]
1206 , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act]
1207
1208 , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n
1209 -- explicit (non-type, non-dictionary) args
1210 -- That is, inl_sat describes the number of *source-code*
1211 -- arguments the thing must be applied to. We add on the
1212 -- number of implicit, dictionary arguments when making
1213 -- the Unfolding, and don't look at inl_sat further
1214
1215 , inl_act :: Activation -- Says during which phases inlining is allowed
1216 -- See Note [inl_inline and inl_act]
1217
1218 , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor?
1219 } deriving( Eq, Data )
1220
1221 -- | Inline Specification
1222 data InlineSpec -- What the user's INLINE pragma looked like
1223 = Inline -- User wrote INLINE
1224 | Inlinable -- User wrote INLINABLE
1225 | NoInline -- User wrote NOINLINE
1226 | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE
1227 -- e.g. in `defaultInlinePragma` or when created by CSE
1228 deriving( Eq, Data, Show )
1229 -- Show needed for Lexer.x
1230
1231 {- Note [InlinePragma]
1232 ~~~~~~~~~~~~~~~~~~~~~~
1233 This data type mirrors what you can write in an INLINE or NOINLINE pragma in
1234 the source program.
1235
1236 If you write nothing at all, you get defaultInlinePragma:
1237 inl_inline = NoUserInline
1238 inl_act = AlwaysActive
1239 inl_rule = FunLike
1240
1241 It's not possible to get that combination by *writing* something, so
1242 if an Id has defaultInlinePragma it means the user didn't specify anything.
1243
1244 If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding.
1245
1246 If you want to know where InlinePragmas take effect: Look in DsBinds.makeCorePair
1247
1248 Note [inl_inline and inl_act]
1249 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1250 * inl_inline says what the user wrote: did she say INLINE, NOINLINE,
1251 INLINABLE, or nothing at all
1252
1253 * inl_act says in what phases the unfolding is active or inactive
1254 E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1
1255 If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1
1256 If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1
1257 So note that inl_act does not say what pragma you wrote: it just
1258 expresses its consequences
1259
1260 * inl_act just says when the unfolding is active; it doesn't say what
1261 to inline. If you say INLINE f, then f's inl_act will be AlwaysActive,
1262 but in addition f will get a "stable unfolding" with UnfoldingGuidance
1263 that tells the inliner to be pretty eager about it.
1264
1265 Note [CONLIKE pragma]
1266 ~~~~~~~~~~~~~~~~~~~~~
1267 The ConLike constructor of a RuleMatchInfo is aimed at the following.
1268 Consider first
1269 {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
1270 g b bs = let x = b:bs in ..x...x...(r x)...
1271 Now, the rule applies to the (r x) term, because GHC "looks through"
1272 the definition of 'x' to see that it is (b:bs).
1273
1274 Now consider
1275 {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
1276 g v = let x = f v in ..x...x...(r x)...
1277 Normally the (r x) would *not* match the rule, because GHC would be
1278 scared about duplicating the redex (f v), so it does not "look
1279 through" the bindings.
1280
1281 However the CONLIKE modifier says to treat 'f' like a constructor in
1282 this situation, and "look through" the unfolding for x. So (r x)
1283 fires, yielding (f (v+1)).
1284
1285 This is all controlled with a user-visible pragma:
1286 {-# NOINLINE CONLIKE [1] f #-}
1287
1288 The main effects of CONLIKE are:
1289
1290 - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
1291 CONLIKE thing like constructors, by ANF-ing them
1292
1293 - New function coreUtils.exprIsExpandable is like exprIsCheap, but
1294 additionally spots applications of CONLIKE functions
1295
1296 - A CoreUnfolding has a field that caches exprIsExpandable
1297
1298 - The rule matcher consults this field. See
1299 Note [Expanding variables] in Rules.hs.
1300 -}
1301
1302 isConLike :: RuleMatchInfo -> Bool
1303 isConLike ConLike = True
1304 isConLike _ = False
1305
1306 isFunLike :: RuleMatchInfo -> Bool
1307 isFunLike FunLike = True
1308 isFunLike _ = False
1309
1310 noUserInlineSpec :: InlineSpec -> Bool
1311 noUserInlineSpec NoUserInline = True
1312 noUserInlineSpec _ = False
1313
1314 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
1315 :: InlinePragma
1316 defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"
1317 , inl_act = AlwaysActive
1318 , inl_rule = FunLike
1319 , inl_inline = NoUserInline
1320 , inl_sat = Nothing }
1321
1322 alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
1323 neverInlinePragma = defaultInlinePragma { inl_act = NeverActive }
1324
1325 inlinePragmaSpec :: InlinePragma -> InlineSpec
1326 inlinePragmaSpec = inl_inline
1327
1328 -- A DFun has an always-active inline activation so that
1329 -- exprIsConApp_maybe can "see" its unfolding
1330 -- (However, its actual Unfolding is a DFunUnfolding, which is
1331 -- never inlined other than via exprIsConApp_maybe.)
1332 dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive
1333 , inl_rule = ConLike }
1334
1335 isDefaultInlinePragma :: InlinePragma -> Bool
1336 isDefaultInlinePragma (InlinePragma { inl_act = activation
1337 , inl_rule = match_info
1338 , inl_inline = inline })
1339 = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info
1340
1341 isInlinePragma :: InlinePragma -> Bool
1342 isInlinePragma prag = case inl_inline prag of
1343 Inline -> True
1344 _ -> False
1345
1346 isInlinablePragma :: InlinePragma -> Bool
1347 isInlinablePragma prag = case inl_inline prag of
1348 Inlinable -> True
1349 _ -> False
1350
1351 isAnyInlinePragma :: InlinePragma -> Bool
1352 -- INLINE or INLINABLE
1353 isAnyInlinePragma prag = case inl_inline prag of
1354 Inline -> True
1355 Inlinable -> True
1356 _ -> False
1357
1358 inlinePragmaSat :: InlinePragma -> Maybe Arity
1359 inlinePragmaSat = inl_sat
1360
1361 inlinePragmaActivation :: InlinePragma -> Activation
1362 inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
1363
1364 inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
1365 inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
1366
1367 setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
1368 setInlinePragmaActivation prag activation = prag { inl_act = activation }
1369
1370 setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
1371 setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
1372
1373 instance Outputable Activation where
1374 ppr AlwaysActive = empty
1375 ppr NeverActive = brackets (text "~")
1376 ppr (ActiveBefore _ n) = brackets (char '~' <> int n)
1377 ppr (ActiveAfter _ n) = brackets (int n)
1378
1379 instance Outputable RuleMatchInfo where
1380 ppr ConLike = text "CONLIKE"
1381 ppr FunLike = text "FUNLIKE"
1382
1383 instance Outputable InlineSpec where
1384 ppr Inline = text "INLINE"
1385 ppr NoInline = text "NOINLINE"
1386 ppr Inlinable = text "INLINABLE"
1387 ppr NoUserInline = text "NOUSERINLINE" -- what is better?
1388
1389 instance Outputable InlinePragma where
1390 ppr = pprInline
1391
1392 pprInline :: InlinePragma -> SDoc
1393 pprInline = pprInline' True
1394
1395 pprInlineDebug :: InlinePragma -> SDoc
1396 pprInlineDebug = pprInline' False
1397
1398 pprInline' :: Bool -- True <=> do not display the inl_inline field
1399 -> InlinePragma
1400 -> SDoc
1401 pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation
1402 , inl_rule = info, inl_sat = mb_arity })
1403 = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info
1404 where
1405 pp_inl x = if emptyInline then empty else ppr x
1406
1407 pp_act Inline AlwaysActive = empty
1408 pp_act NoInline NeverActive = empty
1409 pp_act _ act = ppr act
1410
1411 pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar)
1412 | otherwise = empty
1413 pp_info | isFunLike info = empty
1414 | otherwise = ppr info
1415
1416 isActive :: CompilerPhase -> Activation -> Bool
1417 isActive InitialPhase AlwaysActive = True
1418 isActive InitialPhase (ActiveBefore {}) = True
1419 isActive InitialPhase _ = False
1420 isActive (Phase p) act = isActiveIn p act
1421
1422 isActiveIn :: PhaseNum -> Activation -> Bool
1423 isActiveIn _ NeverActive = False
1424 isActiveIn _ AlwaysActive = True
1425 isActiveIn p (ActiveAfter _ n) = p <= n
1426 isActiveIn p (ActiveBefore _ n) = p > n
1427
1428 competesWith :: Activation -> Activation -> Bool
1429 -- See Note [Activation competition]
1430 competesWith NeverActive _ = False
1431 competesWith _ NeverActive = False
1432 competesWith AlwaysActive _ = True
1433
1434 competesWith (ActiveBefore {}) AlwaysActive = True
1435 competesWith (ActiveBefore {}) (ActiveBefore {}) = True
1436 competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b
1437
1438 competesWith (ActiveAfter {}) AlwaysActive = False
1439 competesWith (ActiveAfter {}) (ActiveBefore {}) = False
1440 competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b
1441
1442 {- Note [Competing activations]
1443 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1444 Sometimes a RULE and an inlining may compete, or two RULES.
1445 See Note [Rules and inlining/other rules] in Desugar.
1446
1447 We say that act1 "competes with" act2 iff
1448 act1 is active in the phase when act2 *becomes* active
1449 NB: remember that phases count *down*: 2, 1, 0!
1450
1451 It's too conservative to ensure that the two are never simultaneously
1452 active. For example, a rule might be always active, and an inlining
1453 might switch on in phase 2. We could switch off the rule, but it does
1454 no harm.
1455 -}
1456
1457 isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
1458 isNeverActive NeverActive = True
1459 isNeverActive _ = False
1460
1461 isAlwaysActive AlwaysActive = True
1462 isAlwaysActive _ = False
1463
1464 isEarlyActive AlwaysActive = True
1465 isEarlyActive (ActiveBefore {}) = True
1466 isEarlyActive _ = False
1467
1468 -- | Integral Literal
1469 --
1470 -- Used (instead of Integer) to represent negative zegative zero which is
1471 -- required for NegativeLiterals extension to correctly parse `-0::Double`
1472 -- as negative zero. See also #13211.
1473 data IntegralLit
1474 = IL { il_text :: SourceText
1475 , il_neg :: Bool -- See Note [Negative zero]
1476 , il_value :: Integer
1477 }
1478 deriving (Data, Show)
1479
1480 mkIntegralLit :: Integral a => a -> IntegralLit
1481 mkIntegralLit i = IL { il_text = SourceText (show (fromIntegral i :: Int))
1482 , il_neg = i < 0
1483 , il_value = toInteger i }
1484
1485 negateIntegralLit :: IntegralLit -> IntegralLit
1486 negateIntegralLit (IL text neg value)
1487 = case text of
1488 SourceText ('-':src) -> IL (SourceText src) False (negate value)
1489 SourceText src -> IL (SourceText ('-':src)) True (negate value)
1490 NoSourceText -> IL NoSourceText (not neg) (negate value)
1491
1492 -- | Fractional Literal
1493 --
1494 -- Used (instead of Rational) to represent exactly the floating point literal that we
1495 -- encountered in the user's source program. This allows us to pretty-print exactly what
1496 -- the user wrote, which is important e.g. for floating point numbers that can't represented
1497 -- as Doubles (we used to via Double for pretty-printing). See also #2245.
1498 data FractionalLit
1499 = FL { fl_text :: SourceText -- How the value was written in the source
1500 , fl_neg :: Bool -- See Note [Negative zero]
1501 , fl_value :: Rational -- Numeric value of the literal
1502 }
1503 deriving (Data, Show)
1504 -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
1505
1506 mkFractionalLit :: Real a => a -> FractionalLit
1507 mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
1508 , fl_neg = r < 0
1509 , fl_value = toRational r }
1510
1511 negateFractionalLit :: FractionalLit -> FractionalLit
1512 negateFractionalLit (FL text neg value)
1513 = case text of
1514 SourceText ('-':src) -> FL (SourceText src) False value
1515 SourceText src -> FL (SourceText ('-':src)) True value
1516 NoSourceText -> FL NoSourceText (not neg) (negate value)
1517
1518 integralFractionalLit :: Bool -> Integer -> FractionalLit
1519 integralFractionalLit neg i = FL { fl_text = SourceText (show i),
1520 fl_neg = neg,
1521 fl_value = fromInteger i }
1522
1523 -- Comparison operations are needed when grouping literals
1524 -- for compiling pattern-matching (module MatchLit)
1525
1526 instance Eq IntegralLit where
1527 (==) = (==) `on` il_value
1528
1529 instance Ord IntegralLit where
1530 compare = compare `on` il_value
1531
1532 instance Outputable IntegralLit where
1533 ppr (IL (SourceText src) _ _) = text src
1534 ppr (IL NoSourceText _ value) = text (show value)
1535
1536 instance Eq FractionalLit where
1537 (==) = (==) `on` fl_value
1538
1539 instance Ord FractionalLit where
1540 compare = compare `on` fl_value
1541
1542 instance Outputable FractionalLit where
1543 ppr f = pprWithSourceText (fl_text f) (rational (fl_value f))
1544
1545 {-
1546 ************************************************************************
1547 * *
1548 IntWithInf
1549 * *
1550 ************************************************************************
1551
1552 Represents an integer or positive infinity
1553
1554 -}
1555
1556 -- | An integer or infinity
1557 data IntWithInf = Int {-# UNPACK #-} !Int
1558 | Infinity
1559 deriving Eq
1560
1561 -- | A representation of infinity
1562 infinity :: IntWithInf
1563 infinity = Infinity
1564
1565 instance Ord IntWithInf where
1566 compare Infinity Infinity = EQ
1567 compare (Int _) Infinity = LT
1568 compare Infinity (Int _) = GT
1569 compare (Int a) (Int b) = a `compare` b
1570
1571 instance Outputable IntWithInf where
1572 ppr Infinity = char ''
1573 ppr (Int n) = int n
1574
1575 instance Num IntWithInf where
1576 (+) = plusWithInf
1577 (*) = mulWithInf
1578
1579 abs Infinity = Infinity
1580 abs (Int n) = Int (abs n)
1581
1582 signum Infinity = Int 1
1583 signum (Int n) = Int (signum n)
1584
1585 fromInteger = Int . fromInteger
1586
1587 (-) = panic "subtracting IntWithInfs"
1588
1589 intGtLimit :: Int -> IntWithInf -> Bool
1590 intGtLimit _ Infinity = False
1591 intGtLimit n (Int m) = n > m
1592
1593 -- | Add two 'IntWithInf's
1594 plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf
1595 plusWithInf Infinity _ = Infinity
1596 plusWithInf _ Infinity = Infinity
1597 plusWithInf (Int a) (Int b) = Int (a + b)
1598
1599 -- | Multiply two 'IntWithInf's
1600 mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf
1601 mulWithInf Infinity _ = Infinity
1602 mulWithInf _ Infinity = Infinity
1603 mulWithInf (Int a) (Int b) = Int (a * b)
1604
1605 -- | Turn a positive number into an 'IntWithInf', where 0 represents infinity
1606 treatZeroAsInf :: Int -> IntWithInf
1607 treatZeroAsInf 0 = Infinity
1608 treatZeroAsInf n = Int n
1609
1610 -- | Inject any integer into an 'IntWithInf'
1611 mkIntWithInf :: Int -> IntWithInf
1612 mkIntWithInf = Int
1613
1614 data SpliceExplicitFlag
1615 = ExplicitSplice | -- ^ <=> $(f x y)
1616 ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression
1617 deriving Data