compiler/basicTypes/BasicTypes.lhs

   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 \begin{code}
  17 module BasicTypes(
  18         Version, bumpVersion, initialVersion,
  19
  20         Arity,
  21
  22     FunctionOrData(..),
  23
  24         WarningTxt(..),
  25
  26         Fixity(..), FixityDirection(..),
  27         defaultFixity, maxPrecedence,
  28         negateFixity, funTyFixity,
  29         compareFixity,
  30
  31         IPName(..), ipNameName, mapIPName,
  32
  33         RecFlag(..), isRec, isNonRec, boolToRecFlag,
  34
  35         RuleName,
  36
  37         TopLevelFlag(..), isTopLevel, isNotTopLevel,
  38
  39         OverlapFlag(..),
  40
  41         Boxity(..), isBoxed,
  42
  43         TupCon(..), tupleParens,
  44
  45         OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
  46         isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc,
  47         nonRuleLoopBreaker,
  48
  49         InsideLam, insideLam, notInsideLam,
  50         OneBranch, oneBranch, notOneBranch,
  51         InterestingCxt,
  52
  53         EP(..),
  54
  55         StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
  56
  57         CompilerPhase,
  58         Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
  59         RuleMatchInfo(..), isConLike, isFunLike,
  60         InlinePragma(..), defaultInlinePragma, neverInlinePragma, dfunInlinePragma,
  61         isDefaultInlinePragma, isInlinePragma,
  62         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
  63         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
  64
  65         SuccessFlag(..), succeeded, failed, successIf
  66    ) where
  67
  68 import FastString
  69 import Outputable
  70 \end{code}
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection[Arity]{Arity}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 type Arity = Int
  80 \end{code}
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection[FunctionOrData]{FunctionOrData}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \begin{code}
  89 data FunctionOrData = IsFunction | IsData
  90     deriving (Eq, Ord)
  91
  92 instance Outputable FunctionOrData where
  93     ppr IsFunction = text "(function)"
  94     ppr IsData     = text "(data)"
  95 \end{code}
  96
  97
  98 %************************************************************************
  99 %*                                                                      *
 100 \subsection[Version]{Module and identifier version numbers}
 101 %*                                                                      *
 102 %************************************************************************
 103
 104 \begin{code}
 105 type Version = Int
 106
 107 bumpVersion :: Version -> Version
 108 bumpVersion v = v+1
 109
 110 initialVersion :: Version
 111 initialVersion = 1
 112 \end{code}
 113
 114 %************************************************************************
 115 %*                                                                      *
 116                 Deprecations
 117 %*                                                                      *
 118 %************************************************************************
 119
 120
 121 \begin{code}
 122 -- reason/explanation from a WARNING or DEPRECATED pragma
 123 data WarningTxt = WarningTxt [FastString]
 124                 | DeprecatedTxt [FastString]
 125     deriving Eq
 126
 127 instance Outputable WarningTxt where
 128     ppr (WarningTxt    ws) = doubleQuotes (vcat (map ftext ws))
 129     ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
 130                              doubleQuotes (vcat (map ftext ds))
 131 \end{code}
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection{Implicit parameter identity}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 The @IPName@ type is here because it is used in TypeRep (i.e. very
 140 early in the hierarchy), but also in HsSyn.
 141
 142 \begin{code}
 143 newtype IPName name = IPName name       -- ?x
 144   deriving( Eq, Ord )   -- Ord is used in the IP name cache finite map
 145                         --      (used in HscTypes.OrigIParamCache)
 146
 147 ipNameName :: IPName name -> name
 148 ipNameName (IPName n) = n
 149
 150 mapIPName :: (a->b) -> IPName a -> IPName b
 151 mapIPName f (IPName n) = IPName (f n)
 152
 153 instance Outputable name => Outputable (IPName name) where
 154     ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters
 155 \end{code}
 156
 157 %************************************************************************
 158 %*                                                                      *
 159                 Rules
 160 %*                                                                      *
 161 %************************************************************************
 162
 163 \begin{code}
 164 type RuleName = FastString
 165 \end{code}
 166
 167 %************************************************************************
 168 %*                                                                      *
 169 \subsection[Fixity]{Fixity info}
 170 %*                                                                      *
 171 %************************************************************************
 172
 173 \begin{code}
 174 ------------------------
 175 data Fixity = Fixity Int FixityDirection
 176
 177 instance Outputable Fixity where
 178     ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
 179
 180 instance Eq Fixity where                -- Used to determine if two fixities conflict
 181   (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
 182
 183 ------------------------
 184 data FixityDirection = InfixL | InfixR | InfixN
 185                      deriving(Eq)
 186
 187 instance Outputable FixityDirection where
 188     ppr InfixL = ptext (sLit "infixl")
 189     ppr InfixR = ptext (sLit "infixr")
 190     ppr InfixN = ptext (sLit "infix")
 191
 192 ------------------------
 193 maxPrecedence :: Int
 194 maxPrecedence = 9
 195 defaultFixity :: Fixity
 196 defaultFixity = Fixity maxPrecedence InfixL
 197
 198 negateFixity, funTyFixity :: Fixity
 199 -- Wired-in fixities
 200 negateFixity = Fixity 6 InfixL  -- Fixity of unary negate
 201 funTyFixity  = Fixity 0 InfixR  -- Fixity of '->'
 202 \end{code}
 203
 204 Consider
 205
 206 \begin{verbatim}
 207         a `op1` b `op2` c
 208 \end{verbatim}
 209 @(compareFixity op1 op2)@ tells which way to arrange appication, or
 210 whether there's an error.
 211
 212 \begin{code}
 213 compareFixity :: Fixity -> Fixity
 214               -> (Bool,         -- Error please
 215                   Bool)         -- Associate to the right: a op1 (b op2 c)
 216 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
 217   = case prec1 `compare` prec2 of
 218         GT -> left
 219         LT -> right
 220         EQ -> case (dir1, dir2) of
 221                         (InfixR, InfixR) -> right
 222                         (InfixL, InfixL) -> left
 223                         _                -> error_please
 224   where
 225     right        = (False, True)
 226     left         = (False, False)
 227     error_please = (True,  False)
 228 \end{code}
 229
 230
 231 %************************************************************************
 232 %*                                                                      *
 233 \subsection[Top-level/local]{Top-level/not-top level flag}
 234 %*                                                                      *
 235 %************************************************************************
 236
 237 \begin{code}
 238 data TopLevelFlag
 239   = TopLevel
 240   | NotTopLevel
 241
 242 isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool
 243
 244 isNotTopLevel NotTopLevel = True
 245 isNotTopLevel TopLevel    = False
 246
 247 isTopLevel TopLevel     = True
 248 isTopLevel NotTopLevel  = False
 249
 250 instance Outputable TopLevelFlag where
 251   ppr TopLevel    = ptext (sLit "<TopLevel>")
 252   ppr NotTopLevel = ptext (sLit "<NotTopLevel>")
 253 \end{code}
 254
 255
 256 %************************************************************************
 257 %*                                                                      *
 258                 Top-level/not-top level flag
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 \begin{code}
 263 data Boxity
 264   = Boxed
 265   | Unboxed
 266   deriving( Eq )
 267
 268 isBoxed :: Boxity -> Bool
 269 isBoxed Boxed   = True
 270 isBoxed Unboxed = False
 271 \end{code}
 272
 273
 274 %************************************************************************
 275 %*                                                                      *
 276                 Recursive/Non-Recursive flag
 277 %*                                                                      *
 278 %************************************************************************
 279
 280 \begin{code}
 281 data RecFlag = Recursive
 282              | NonRecursive
 283              deriving( Eq )
 284
 285 isRec :: RecFlag -> Bool
 286 isRec Recursive    = True
 287 isRec NonRecursive = False
 288
 289 isNonRec :: RecFlag -> Bool
 290 isNonRec Recursive    = False
 291 isNonRec NonRecursive = True
 292
 293 boolToRecFlag :: Bool -> RecFlag
 294 boolToRecFlag True  = Recursive
 295 boolToRecFlag False = NonRecursive
 296
 297 instance Outputable RecFlag where
 298   ppr Recursive    = ptext (sLit "Recursive")
 299   ppr NonRecursive = ptext (sLit "NonRecursive")
 300 \end{code}
 301
 302 %************************************************************************
 303 %*                                                                      *
 304                 Instance overlap flag
 305 %*                                                                      *
 306 %************************************************************************
 307
 308 \begin{code}
 309 data OverlapFlag
 310   = NoOverlap   -- This instance must not overlap another
 311
 312   | OverlapOk   -- Silently ignore this instance if you find a
 313                 -- more specific one that matches the constraint
 314                 -- you are trying to resolve
 315                 --
 316                 -- Example: constraint (Foo [Int])
 317                 --          instances  (Foo [Int])
 318                 --                     (Foo [a])        OverlapOk
 319                 -- Since the second instance has the OverlapOk flag,
 320                 -- the first instance will be chosen (otherwise
 321                 -- its ambiguous which to choose)
 322
 323   | Incoherent  -- Like OverlapOk, but also ignore this instance
 324                 -- if it doesn't match the constraint you are
 325                 -- trying to resolve, but could match if the type variables
 326                 -- in the constraint were instantiated
 327                 --
 328                 -- Example: constraint (Foo [b])
 329                 --          instances  (Foo [Int])      Incoherent
 330                 --                     (Foo [a])
 331                 -- Without the Incoherent flag, we'd complain that
 332                 -- instantiating 'b' would change which instance
 333                 -- was chosen
 334   deriving( Eq )
 335
 336 instance Outputable OverlapFlag where
 337    ppr NoOverlap  = empty
 338    ppr OverlapOk  = ptext (sLit "[overlap ok]")
 339    ppr Incoherent = ptext (sLit "[incoherent]")
 340
 341 \end{code}
 342
 343 %************************************************************************
 344 %*                                                                      *
 345                 Tuples
 346 %*                                                                      *
 347 %************************************************************************
 348
 349 \begin{code}
 350 data TupCon = TupCon Boxity Arity
 351
 352 instance Eq TupCon where
 353   (TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2
 354
 355 tupleParens :: Boxity -> SDoc -> SDoc
 356 tupleParens Boxed   p = parens p
 357 tupleParens Unboxed p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
 358 \end{code}
 359
 360 %************************************************************************
 361 %*                                                                      *
 362 \subsection[Generic]{Generic flag}
 363 %*                                                                      *
 364 %************************************************************************
 365
 366 This is the "Embedding-Projection pair" datatype, it contains
 367 two pieces of code (normally either RenamedExpr's or Id's)
 368 If we have a such a pair (EP from to), the idea is that 'from' and 'to'
 369 represents functions of type
 370
 371         from :: T -> Tring
 372         to   :: Tring -> T
 373
 374 And we should have
 375
 376         to (from x) = x
 377
 378 T and Tring are arbitrary, but typically T is the 'main' type while
 379 Tring is the 'representation' type.  (This just helps us remember
 380 whether to use 'from' or 'to'.
 381
 382 \begin{code}
 383 data EP a = EP { fromEP :: a,   -- :: T -> Tring
 384                  toEP   :: a }  -- :: Tring -> T
 385 \end{code}
 386
 387 Embedding-projection pairs are used in several places:
 388
 389 First of all, each type constructor has an EP associated with it, the
 390 code in EP converts (datatype T) from T to Tring and back again.
 391
 392 Secondly, when we are filling in Generic methods (in the typechecker,
 393 tcMethodBinds), we are constructing bimaps by induction on the structure
 394 of the type of the method signature.
 395
 396
 397 %************************************************************************
 398 %*                                                                      *
 399 \subsection{Occurrence information}
 400 %*                                                                      *
 401 %************************************************************************
 402
 403 This data type is used exclusively by the simplifier, but it appears in a
 404 SubstResult, which is currently defined in VarEnv, which is pretty near
 405 the base of the module hierarchy.  So it seemed simpler to put the
 406 defn of OccInfo here, safely at the bottom
 407
 408 \begin{code}
 409 -- | Identifier occurrence information
 410 data OccInfo
 411   = NoOccInfo           -- ^ There are many occurrences, or unknown occurences
 412
 413   | IAmDead             -- ^ Marks unused variables.  Sometimes useful for
 414                         -- lambda and case-bound variables.
 415
 416   | OneOcc
 417         !InsideLam
 418         !OneBranch
 419         !InterestingCxt -- ^ Occurs exactly once, not inside a rule
 420
 421   -- | This identifier breaks a loop of mutually recursive functions. The field
 422   -- marks whether it is only a loop breaker due to a reference in a rule
 423   | IAmALoopBreaker     -- Note [LoopBreaker OccInfo]
 424         !RulesOnly      -- True <=> This is a weak or rules-only loop breaker
 425                         --          See OccurAnal Note [Weak loop breakers]
 426
 427 type RulesOnly = Bool
 428 \end{code}
 429
 430 Note [LoopBreaker OccInfo]
 431 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 432 An OccInfo of (IAmLoopBreaker False) is used by the occurrence
 433 analyser in two ways:
 434   (a) to mark loop-breakers in a group of recursive
 435       definitions (hence the name)
 436   (b) to mark binders that must not be inlined in this phase
 437       (perhaps it has a NOINLINE pragma)
 438 Things with (IAmLoopBreaker False) do not get an unfolding
 439 pinned on to them, so they are completely opaque.
 440
 441 See OccurAnal Note [Weak loop breakers] for (IAmLoopBreaker True).
 442
 443
 444 \begin{code}
 445 isNoOcc :: OccInfo -> Bool
 446 isNoOcc NoOccInfo = True
 447 isNoOcc _         = False
 448
 449 seqOccInfo :: OccInfo -> ()
 450 seqOccInfo occ = occ `seq` ()
 451
 452 -----------------
 453 type InterestingCxt = Bool      -- True <=> Function: is applied
 454                                 --          Data value: scrutinised by a case with
 455                                 --                      at least one non-DEFAULT branch
 456
 457 -----------------
 458 type InsideLam = Bool   -- True <=> Occurs inside a non-linear lambda
 459                         -- Substituting a redex for this occurrence is
 460                         -- dangerous because it might duplicate work.
 461 insideLam, notInsideLam :: InsideLam
 462 insideLam    = True
 463 notInsideLam = False
 464
 465 -----------------
 466 type OneBranch = Bool   -- True <=> Occurs in only one case branch
 467                         --      so no code-duplication issue to worry about
 468 oneBranch, notOneBranch :: OneBranch
 469 oneBranch    = True
 470 notOneBranch = False
 471
 472 isLoopBreaker :: OccInfo -> Bool
 473 isLoopBreaker (IAmALoopBreaker _) = True
 474 isLoopBreaker _                   = False
 475
 476 isNonRuleLoopBreaker :: OccInfo -> Bool
 477 isNonRuleLoopBreaker (IAmALoopBreaker False) = True   -- Loop-breaker that breaks a non-rule cycle
 478 isNonRuleLoopBreaker _                       = False
 479
 480 nonRuleLoopBreaker :: OccInfo
 481 nonRuleLoopBreaker = IAmALoopBreaker False
 482
 483 isDeadOcc :: OccInfo -> Bool
 484 isDeadOcc IAmDead = True
 485 isDeadOcc _       = False
 486
 487 isOneOcc :: OccInfo -> Bool
 488 isOneOcc (OneOcc {}) = True
 489 isOneOcc _           = False
 490
 491 zapFragileOcc :: OccInfo -> OccInfo
 492 zapFragileOcc (OneOcc {}) = NoOccInfo
 493 zapFragileOcc occ         = occ
 494 \end{code}
 495
 496 \begin{code}
 497 instance Outputable OccInfo where
 498   -- only used for debugging; never parsed.  KSW 1999-07
 499   ppr NoOccInfo            = empty
 500   ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty
 501   ppr IAmDead              = ptext (sLit "Dead")
 502   ppr (OneOcc inside_lam one_branch int_cxt)
 503         = ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args
 504         where
 505           pp_lam | inside_lam = char 'L'
 506                  | otherwise  = empty
 507           pp_br  | one_branch = empty
 508                  | otherwise  = char '*'
 509           pp_args | int_cxt   = char '!'
 510                   | otherwise = empty
 511
 512 instance Show OccInfo where
 513   showsPrec p occ = showsPrecSDoc p (ppr occ)
 514 \end{code}
 515
 516 %************************************************************************
 517 %*                                                                      *
 518 \subsection{Strictness indication}
 519 %*                                                                      *
 520 %************************************************************************
 521
 522 The strictness annotations on types in data type declarations
 523 e.g.    data T = MkT !Int !(Bool,Bool)
 524
 525 \begin{code}
 526 data StrictnessMark     -- Used in interface decls only
 527    = MarkedStrict
 528    | MarkedUnboxed
 529    | NotMarkedStrict
 530    deriving( Eq )
 531
 532 isMarkedUnboxed :: StrictnessMark -> Bool
 533 isMarkedUnboxed MarkedUnboxed = True
 534 isMarkedUnboxed _             = False
 535
 536 isMarkedStrict :: StrictnessMark -> Bool
 537 isMarkedStrict NotMarkedStrict = False
 538 isMarkedStrict _               = True   -- All others are strict
 539
 540 instance Outputable StrictnessMark where
 541   ppr MarkedStrict     = ptext (sLit "!")
 542   ppr MarkedUnboxed    = ptext (sLit "!!")
 543   ppr NotMarkedStrict  = ptext (sLit "_")
 544 \end{code}
 545
 546
 547 %************************************************************************
 548 %*                                                                      *
 549 \subsection{Success flag}
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 \begin{code}
 554 data SuccessFlag = Succeeded | Failed
 555
 556 instance Outputable SuccessFlag where
 557     ppr Succeeded = ptext (sLit "Succeeded")
 558     ppr Failed    = ptext (sLit "Failed")
 559
 560 successIf :: Bool -> SuccessFlag
 561 successIf True  = Succeeded
 562 successIf False = Failed
 563
 564 succeeded, failed :: SuccessFlag -> Bool
 565 succeeded Succeeded = True
 566 succeeded Failed    = False
 567
 568 failed Succeeded = False
 569 failed Failed    = True
 570 \end{code}
 571
 572
 573 %************************************************************************
 574 %*                                                                      *
 575 \subsection{Activation}
 576 %*                                                                      *
 577 %************************************************************************
 578
 579 When a rule or inlining is active
 580
 581 \begin{code}
 582 type CompilerPhase = Int        -- Compilation phase
 583                                 -- Phases decrease towards zero
 584                                 -- Zero is the last phase
 585
 586 data Activation = NeverActive
 587                 | AlwaysActive
 588                 | ActiveBefore CompilerPhase    -- Active only *before* this phase
 589                 | ActiveAfter CompilerPhase     -- Active in this phase and later
 590                 deriving( Eq )                  -- Eq used in comparing rules in HsDecls
 591
 592 data RuleMatchInfo = ConLike                    -- See Note [CONLIKE pragma]
 593                    | FunLike
 594                    deriving( Eq )
 595
 596 data InlinePragma            -- Note [InlinePragma]
 597   = InlinePragma
 598       { inl_inline :: Bool           -- True <=> INLINE,
 599                                      -- False <=> no pragma at all, or NOINLINE
 600       , inl_act    :: Activation     -- Says during which phases inlining is allowed
 601       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
 602     } deriving( Eq )
 603 \end{code}
 604
 605 Note [InlinePragma]
 606 ~~~~~~~~~~~~~~~~~~~
 607 This data type mirrors what you can write in an INLINE or NOINLINE pragma in
 608 the source program.
 609
 610 If you write nothing at all, you get defaultInlinePragma:
 611    inl_inline = False
 612    inl_act    = AlwaysActive
 613    inl_rule   = FunLike
 614
 615 It's not possible to get that combination by *writing* something, so
 616 if an Id has defaultInlinePragma it means the user didn't specify anything.
 617
 618 Note [CONLIKE pragma]
 619 ~~~~~~~~~~~~~~~~~~~~~
 620 The ConLike constructor of a RuleMatchInfo is aimed at the following.
 621 Consider first
 622     {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
 623     g b bs = let x = b:bs in ..x...x...(r x)...
 624 Now, the rule applies to the (r x) term, because GHC "looks through"
 625 the definition of 'x' to see that it is (b:bs).
 626
 627 Now consider
 628     {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
 629     g v = let x = f v in ..x...x...(r x)...
 630 Normally the (r x) would *not* match the rule, because GHC would be
 631 scared about duplicating the redex (f v), so it does not "look
 632 through" the bindings.
 633
 634 However the CONLIKE modifier says to treat 'f' like a constructor in
 635 this situation, and "look through" the unfolding for x.  So (r x)
 636 fires, yielding (f (v+1)).
 637
 638 This is all controlled with a user-visible pragma:
 639      {-# NOINLINE CONLIKE [1] f #-}
 640
 641 The main effects of CONLIKE are:
 642
 643     - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
 644       CONLIKE thing like constructors, by ANF-ing them
 645
 646     - New function coreUtils.exprIsExpandable is like exprIsCheap, but
 647       additionally spots applications of CONLIKE functions
 648
 649     - A CoreUnfolding has a field that caches exprIsExpandable
 650
 651     - The rule matcher consults this field.  See
 652       Note [Expanding variables] in Rules.lhs.
 653
 654 \begin{code}
 655 isConLike :: RuleMatchInfo -> Bool
 656 isConLike ConLike = True
 657 isConLike _            = False
 658
 659 isFunLike :: RuleMatchInfo -> Bool
 660 isFunLike FunLike = True
 661 isFunLike _            = False
 662
 663 defaultInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma
 664 defaultInlinePragma
 665   = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = False }
 666 neverInlinePragma
 667    = InlinePragma { inl_act = NeverActive, inl_rule = FunLike, inl_inline = False }
 668 dfunInlinePragma
 669    = InlinePragma { inl_act = AlwaysActive, inl_rule = ConLike, inl_inline = False }
 670
 671
 672 isDefaultInlinePragma :: InlinePragma -> Bool
 673 isDefaultInlinePragma (InlinePragma { inl_act = activation
 674                                     , inl_rule = match_info
 675                                     , inl_inline = inline })
 676   = not inline && isAlwaysActive activation && isFunLike match_info
 677
 678 isInlinePragma :: InlinePragma -> Bool
 679 isInlinePragma prag = inl_inline prag
 680
 681 inlinePragmaActivation :: InlinePragma -> Activation
 682 inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
 683
 684 inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
 685 inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
 686
 687 setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
 688 setInlinePragmaActivation prag activation = prag { inl_act = activation }
 689
 690 setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
 691 setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
 692
 693 instance Outputable Activation where
 694    ppr AlwaysActive     = ptext (sLit "ALWAYS")
 695    ppr NeverActive      = ptext (sLit "NEVER")
 696    ppr (ActiveBefore n) = brackets (char '~' <> int n)
 697    ppr (ActiveAfter n)  = brackets (int n)
 698
 699 instance Outputable RuleMatchInfo where
 700    ppr ConLike = ptext (sLit "CONLIKE")
 701    ppr FunLike = ptext (sLit "FUNLIKE")
 702
 703 instance Outputable InlinePragma where
 704   ppr (InlinePragma { inl_inline = inline, inl_act = activation, inl_rule = info })
 705     = pp_inline <+> pp_info <+> pp_activation
 706     where
 707       pp_inline | inline    = ptext (sLit "INLINE")
 708                 | otherwise = ptext (sLit "NOINLINE")
 709       pp_info | isFunLike info = empty
 710               | otherwise      = ppr info
 711       pp_activation
 712         | inline     && isAlwaysActive activation = empty
 713         | not inline && isNeverActive  activation = empty
 714         | otherwise                               = ppr activation
 715
 716 isActive :: CompilerPhase -> Activation -> Bool
 717 isActive _ NeverActive      = False
 718 isActive _ AlwaysActive     = True
 719 isActive p (ActiveAfter n)  = p <= n
 720 isActive p (ActiveBefore n) = p >  n
 721
 722 isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
 723 isNeverActive NeverActive = True
 724 isNeverActive _           = False
 725
 726 isAlwaysActive AlwaysActive = True
 727 isAlwaysActive _            = False
 728
 729 isEarlyActive AlwaysActive      = True
 730 isEarlyActive (ActiveBefore {}) = True
 731 isEarlyActive _                 = False
 732 \end{code}
 733