GHC/Types/Basic.hs

    {-
    (c) The University of Glasgow 2006
    (c) The GRASP/AQUA Project, Glasgow University, 1997-1998

    \section[BasicTypes]{Miscellaneous types}

    This module defines a miscellaneously collection of very simple
    types that

    \begin{itemize}
    \item have no other obvious home
    \item don't depend on any other complicated types
    \item are used in more than one "part" of the compiler
    \end{itemize}
    -}

    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE FlexibleInstances #-}

    {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

    module GHC.Types.Basic (
            LeftOrRight(..),
            pickLR,

            ConTag, ConTagZ, fIRST_TAG,

            Arity, RepArity, JoinArity, FullArgCount,

            Alignment, mkAlignment, alignmentOf, alignmentBytes,

            PromotionFlag(..), isPromoted,
            FunctionOrData(..),

            RecFlag(..), isRec, isNonRec, boolToRecFlag,
            Origin(..), isGenerated,

            RuleName, pprRuleName,

            TopLevelFlag(..), isTopLevel, isNotTopLevel,

            OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
            hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,

            Boxity(..), isBoxed,

            PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec,
            maybeParen,

            TupleSort(..), tupleSortBoxity, boxityTupleSort,
            tupleParens,

            sumParens, pprAlternative,

            -- ** The OneShotInfo type
            OneShotInfo(..),
            noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
            bestOneShot, worstOneShot,

            OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,
            isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,
            isNoOccInfo, strongLoopBreaker, weakLoopBreaker,

            InsideLam(..),
            BranchCount, oneBranch,
            InterestingCxt(..),
            TailCallInfo(..), tailCallInfo, zapOccTailCallInfo,
            isAlwaysTailCalled,

            EP(..),

            DefMethSpec(..),
            SwapFlag(..), flipSwap, unSwap, isSwapped,

            CompilerPhase(..), PhaseNum,

            Activation(..), isActive, competesWith,
            isNeverActive, isAlwaysActive, activeInFinalPhase,
            activateAfterInitial, activateDuringFinal,

            RuleMatchInfo(..), isConLike, isFunLike,
            InlineSpec(..), noUserInlineSpec,
            InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
            neverInlinePragma, dfunInlinePragma,
            isDefaultInlinePragma,
            isInlinePragma, isInlinablePragma, isAnyInlinePragma,
            inlinePragmaSpec, inlinePragmaSat,
            inlinePragmaActivation, inlinePragmaRuleMatchInfo,
            setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
            pprInline, pprInlineDebug,

            SuccessFlag(..), succeeded, failed, successIf,

            IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,

            SpliceExplicitFlag(..),

            TypeOrKind(..), isTypeLevel, isKindLevel,

            ForeignSrcLang (..)
       ) where

    import GHC.Prelude

    import GHC.ForeignSrcLang
    import GHC.Data.FastString
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Utils.Binary
    import GHC.Types.SourceText
    import Data.Data
    import Data.Bits
    import qualified Data.Semigroup as Semi

    {-
    ************************************************************************
    *                                                                      *
              Binary choice
    *                                                                      *
    ************************************************************************
    -}

    data LeftOrRight = CLeft | CRight
                     deriving( Eq, Data )

    pickLR :: LeftOrRight -> (a,a) -> a
    pickLR CLeft  (l,_) = l
    pickLR CRight (_,r) = r

    instance Outputable LeftOrRight where
      ppr CLeft    = text "Left"
      ppr CRight   = text "Right"

    instance Binary LeftOrRight where
       put_ bh CLeft  = putByte bh 0
       put_ bh CRight = putByte bh 1

       get bh = do { h <- getByte bh
                   ; case h of
                       0 -> return CLeft
                       _ -> return CRight }

    {-
    ************************************************************************
    *                                                                      *
    \subsection[Arity]{Arity}
    *                                                                      *
    ************************************************************************
    -}

    -- | The number of value arguments that can be applied to a value before it does
    -- "real work". So:
    --  fib 100     has arity 0
    --  \x -> fib x has arity 1
    -- See also Note [Definition of arity] in "GHC.Core.Opt.Arity"
    type Arity = Int

    -- | Representation Arity
    --
    -- The number of represented arguments that can be applied to a value before it does
    -- "real work". So:
    --  fib 100                    has representation arity 0
    --  \x -> fib x                has representation arity 1
    --  \(# x, y #) -> fib (x + y) has representation arity 2
    type RepArity = Int

    -- | The number of arguments that a join point takes. Unlike the arity of a
    -- function, this is a purely syntactic property and is fixed when the join
    -- point is created (or converted from a value). Both type and value arguments
    -- are counted.
    type JoinArity = Int

    -- | FullArgCount is the number of type or value arguments in an application,
    -- or the number of type or value binders in a lambda.  Note: it includes
    -- both type and value arguments!
    type FullArgCount = Int

    {-
    ************************************************************************
    *                                                                      *
                  Constructor tags
    *                                                                      *
    ************************************************************************
    -}

    -- | A *one-index* constructor tag
    --
    -- Type of the tags associated with each constructor possibility or superclass
    -- selector
    type ConTag = Int

    -- | A *zero-indexed* constructor tag
    type ConTagZ = Int

    fIRST_TAG :: ConTag
    -- ^ Tags are allocated from here for real constructors
    --   or for superclass selectors
    fIRST_TAG =  1

    {-
    ************************************************************************
    *                                                                      *
    \subsection[Alignment]{Alignment}
    *                                                                      *
    ************************************************************************
    -}

    -- | A power-of-two alignment
    newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord)

    -- Builds an alignment, throws on non power of 2 input. This is not
    -- ideal, but convenient for internal use and better then silently
    -- passing incorrect data.
    mkAlignment :: Int -> Alignment
    mkAlignment n
      | n == 1 = Alignment 1
      | n == 2 = Alignment 2
      | n == 4 = Alignment 4
      | n == 8 = Alignment 8
      | n == 16 = Alignment 16
      | n == 32 = Alignment 32
      | n == 64 = Alignment 64
      | n == 128 = Alignment 128
      | n == 256 = Alignment 256
      | n == 512 = Alignment 512
      | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512"

    -- Calculates an alignment of a number. x is aligned at N bytes means
    -- the remainder from x / N is zero. Currently, interested in N <= 8,
    -- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX
    -- context.
    alignmentOf :: Int -> Alignment
    alignmentOf x = case x .&. 7 of
      0 -> Alignment 8
      4 -> Alignment 4
      2 -> Alignment 2
      _ -> Alignment 1

    instance Outputable Alignment where
      ppr (Alignment m) = ppr m

    instance OutputableP env Alignment where
      pdoc _ = ppr

    {-
    ************************************************************************
    *                                                                      *
             One-shot information
    *                                                                      *
    ************************************************************************
    -}

    {-
    Note [OneShotInfo overview]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Lambda-bound Ids (and only lambda-bound Ids) may be decorated with
    one-shot info.  The idea is that if we see
        (\x{one-shot}. e)
    it means that this lambda will only be applied once.  In particular
    that means we can float redexes under the lambda without losing
    work.  For example, consider
        let t = expensive in
        (\x{one-shot}. case t of { True -> ...; False -> ... })

    Because it's a one-shot lambda, we can safely inline t, giving
        (\x{one_shot}. case <expensive> of
                           { True -> ...; False -> ... })

    Moving parts:

    * Usage analysis, performed as part of demand-analysis, finds
      out whether functions call their argument once.  Consider
         f g x = Just (case g x of { ... })

      Here 'f' is lazy in 'g', but it guarantees to call it no
      more than once.  So g will get a C1(U) usage demand.

    * Occurrence analysis propagates this usage information
      (in the demand signature of a function) to its calls.
      Example, given 'f' above
         f (\x.e) blah

      Since f's demand signature says it has a C1(U) usage demand on its
      first argument, the occurrence analyser sets the \x to be one-shot.
      This is done via the occ_one_shots field of OccEnv.

    * Float-in and float-out take account of one-shot-ness

    * Occurrence analysis doesn't set "inside-lam" for occurrences inside
      a one-shot lambda

    Other notes

    * A one-shot lambda can use its argument many times.  To elaborate
      the example above
        let t = expensive in
        (\x{one-shot}. case t of { True -> x+x; False -> x*x })

      Here the '\x' is one-shot, which justifies inlining 't',
      but x is used many times. That's absolutely fine.

    * It's entirely possible to have
         (\x{one-shot}. \y{many-shot}. e)

      For example
         let t = expensive
             g = \x -> let v = x+t in
                 \y -> x + v
         in map (g 5) xs

      Here the `\x` is a one-shot binder: `g` is applied to one argument
      exactly once.  And because the `\x` is one-shot, it would be fine to
      float that `let t = expensive` binding inside the `\x`.

      But the `\y` is most definitely not one-shot!
    -}

    -- | If the 'Id' is a lambda-bound variable then it may have lambda-bound
    -- variable info. Sometimes we know whether the lambda binding this variable
    -- is a "one-shot" lambda; that is, whether it is applied at most once.
    --
    -- This information may be useful in optimisation, as computations may
    -- safely be floated inside such a lambda without risk of duplicating
    -- work.
    --
    -- See also Note [OneShotInfo overview] above.
    data OneShotInfo
      = NoOneShotInfo -- ^ No information
      | OneShotLam    -- ^ The lambda is applied at most once.
      deriving (Eq)

    -- | It is always safe to assume that an 'Id' has no lambda-bound variable information
    noOneShotInfo :: OneShotInfo
    noOneShotInfo = NoOneShotInfo

    isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool
    isOneShotInfo OneShotLam = True
    isOneShotInfo _          = False

    hasNoOneShotInfo NoOneShotInfo = True
    hasNoOneShotInfo _             = False

    worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo
    worstOneShot NoOneShotInfo _             = NoOneShotInfo
    worstOneShot OneShotLam    os            = os

    bestOneShot NoOneShotInfo os         = os
    bestOneShot OneShotLam    _          = OneShotLam

    pprOneShotInfo :: OneShotInfo -> SDoc
    pprOneShotInfo NoOneShotInfo = empty
    pprOneShotInfo OneShotLam    = text "OneShot"

    instance Outputable OneShotInfo where
        ppr = pprOneShotInfo

    {-
    ************************************************************************
    *                                                                      *
               Swap flag
    *                                                                      *
    ************************************************************************
    -}

    data SwapFlag
      = NotSwapped  -- Args are: actual,   expected
      | IsSwapped   -- Args are: expected, actual

    instance Outputable SwapFlag where
      ppr IsSwapped  = text "Is-swapped"
      ppr NotSwapped = text "Not-swapped"

    flipSwap :: SwapFlag -> SwapFlag
    flipSwap IsSwapped  = NotSwapped
    flipSwap NotSwapped = IsSwapped

    isSwapped :: SwapFlag -> Bool
    isSwapped IsSwapped  = True
    isSwapped NotSwapped = False

    unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
    unSwap NotSwapped f a b = f a b
    unSwap IsSwapped  f a b = f b a

    {- *********************************************************************
    *                                                                      *
               Promotion flag
    *                                                                      *
    ********************************************************************* -}

    -- | Is a TyCon a promoted data constructor or just a normal type constructor?
    data PromotionFlag
      = NotPromoted
      | IsPromoted
      deriving ( Eq, Data )

    isPromoted :: PromotionFlag -> Bool
    isPromoted IsPromoted  = True
    isPromoted NotPromoted = False

    instance Outputable PromotionFlag where
      ppr NotPromoted = text "NotPromoted"
      ppr IsPromoted  = text "IsPromoted"

    instance Binary PromotionFlag where
       put_ bh NotPromoted = putByte bh 0
       put_ bh IsPromoted  = putByte bh 1

       get bh = do
           n <- getByte bh
           case n of
             0 -> return NotPromoted
             1 -> return IsPromoted
             _ -> fail "Binary(IsPromoted): fail)"

    {-
    ************************************************************************
    *                                                                      *
    \subsection[FunctionOrData]{FunctionOrData}
    *                                                                      *
    ************************************************************************
    -}

    data FunctionOrData = IsFunction | IsData
        deriving (Eq, Ord, Data)

    instance Outputable FunctionOrData where
        ppr IsFunction = text "(function)"
        ppr IsData     = text "(data)"

    instance Binary FunctionOrData where
        put_ bh IsFunction = putByte bh 0
        put_ bh IsData     = putByte bh 1
        get bh = do
            h <- getByte bh
            case h of
              0 -> return IsFunction
              1 -> return IsData
              _ -> panic "Binary FunctionOrData"

    {-
    ************************************************************************
    *                                                                      *
                    Rules
    *                                                                      *
    ************************************************************************
    -}

    type RuleName = FastString

    pprRuleName :: RuleName -> SDoc
    pprRuleName rn = doubleQuotes (ftext rn)

    {-
    ************************************************************************
    *                                                                      *
    \subsection[Top-level/local]{Top-level/not-top level flag}
    *                                                                      *
    ************************************************************************
    -}

    data TopLevelFlag
      = TopLevel
      | NotTopLevel
      deriving Data

    isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool

    isNotTopLevel NotTopLevel = True
    isNotTopLevel TopLevel    = False

    isTopLevel TopLevel     = True
    isTopLevel NotTopLevel  = False

    instance Outputable TopLevelFlag where
      ppr TopLevel    = text "<TopLevel>"
      ppr NotTopLevel = text "<NotTopLevel>"

    {-
    ************************************************************************
    *                                                                      *
                    Boxity flag
    *                                                                      *
    ************************************************************************
    -}

    data Boxity
      = Boxed
      | Unboxed
      deriving( Eq, Data )

    isBoxed :: Boxity -> Bool
    isBoxed Boxed   = True
    isBoxed Unboxed = False

    instance Outputable Boxity where
      ppr Boxed   = text "Boxed"
      ppr Unboxed = text "Unboxed"

    {-
    ************************************************************************
    *                                                                      *
                    Recursive/Non-Recursive flag
    *                                                                      *
    ************************************************************************
    -}

    -- | Recursivity Flag
    data RecFlag = Recursive
                 | NonRecursive
                 deriving( Eq, Data )

    isRec :: RecFlag -> Bool
    isRec Recursive    = True
    isRec NonRecursive = False

    isNonRec :: RecFlag -> Bool
    isNonRec Recursive    = False
    isNonRec NonRecursive = True

    boolToRecFlag :: Bool -> RecFlag
    boolToRecFlag True  = Recursive
    boolToRecFlag False = NonRecursive

    instance Outputable RecFlag where
      ppr Recursive    = text "Recursive"
      ppr NonRecursive = text "NonRecursive"

    instance Binary RecFlag where
        put_ bh Recursive =
                putByte bh 0
        put_ bh NonRecursive =
                putByte bh 1
        get bh = do
                h <- getByte bh
                case h of
                  0 -> return Recursive
                  _ -> return NonRecursive

    {-
    ************************************************************************
    *                                                                      *
                    Code origin
    *                                                                      *
    ************************************************************************
    -}

    data Origin = FromSource
                | Generated
                deriving( Eq, Data )

    isGenerated :: Origin -> Bool
    isGenerated Generated = True
    isGenerated FromSource = False

    instance Outputable Origin where
      ppr FromSource  = text "FromSource"
      ppr Generated   = text "Generated"

    {-
    ************************************************************************
    *                                                                      *
                    Instance overlap flag
    *                                                                      *
    ************************************************************************
    -}

    -- | The semantics allowed for overlapping instances for a particular
    -- instance. See Note [Safe Haskell isSafeOverlap] (in "GHC.Core.InstEnv") for a
    -- explanation of the `isSafeOverlap` field.
    --
    -- - 'GHC.Parser.Annotation.AnnKeywordId' :
    --      'GHC.Parser.Annotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
    --                              @'\{-\# OVERLAPPING'@ or
    --                              @'\{-\# OVERLAPS'@ or
    --                              @'\{-\# INCOHERENT'@,
    --      'GHC.Parser.Annotation.AnnClose' @`\#-\}`@,

    -- For details on above see note [exact print annotations] in "GHC.Parser.Annotation"
    data OverlapFlag = OverlapFlag
      { overlapMode   :: OverlapMode
      , isSafeOverlap :: Bool
      } deriving (Eq, Data)

    setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag
    setOverlapModeMaybe f Nothing  = f
    setOverlapModeMaybe f (Just m) = f { overlapMode = m }

    hasIncoherentFlag :: OverlapMode -> Bool
    hasIncoherentFlag mode =
      case mode of
        Incoherent   _ -> True
        _              -> False

    hasOverlappableFlag :: OverlapMode -> Bool
    hasOverlappableFlag mode =
      case mode of
        Overlappable _ -> True
        Overlaps     _ -> True
        Incoherent   _ -> True
        _              -> False

    hasOverlappingFlag :: OverlapMode -> Bool
    hasOverlappingFlag mode =
      case mode of
        Overlapping  _ -> True
        Overlaps     _ -> True
        Incoherent   _ -> True
        _              -> False

    data OverlapMode  -- See Note [Rules for instance lookup] in GHC.Core.InstEnv
      = NoOverlap SourceText
                      -- See Note [Pragma source text]
        -- ^ This instance must not overlap another `NoOverlap` instance.
        -- However, it may be overlapped by `Overlapping` instances,
        -- and it may overlap `Overlappable` instances.

      | Overlappable SourceText
                      -- See Note [Pragma source text]
        -- ^ Silently ignore this instance if you find a
        -- more specific one that matches the constraint
        -- you are trying to resolve
        --
        -- Example: constraint (Foo [Int])
        --   instance                      Foo [Int]
        --   instance {-# OVERLAPPABLE #-} Foo [a]
        --
        -- Since the second instance has the Overlappable flag,
        -- the first instance will be chosen (otherwise
        -- its ambiguous which to choose)

      | Overlapping SourceText
                      -- See Note [Pragma source text]
        -- ^ Silently ignore any more general instances that may be
        --   used to solve the constraint.
        --
        -- Example: constraint (Foo [Int])
        --   instance {-# OVERLAPPING #-} Foo [Int]
        --   instance                     Foo [a]
        --
        -- Since the first instance has the Overlapping flag,
        -- the second---more general---instance will be ignored (otherwise
        -- it is ambiguous which to choose)

      | Overlaps SourceText
                      -- See Note [Pragma source text]
        -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.

      | Incoherent SourceText
                      -- See Note [Pragma source text]
        -- ^ Behave like Overlappable and Overlapping, and in addition pick
        -- an arbitrary one if there are multiple matching candidates, and
        -- don't worry about later instantiation
        --
        -- Example: constraint (Foo [b])
        -- instance {-# INCOHERENT -} Foo [Int]
        -- instance                   Foo [a]
        -- Without the Incoherent flag, we'd complain that
        -- instantiating 'b' would change which instance
        -- was chosen. See also note [Incoherent instances] in "GHC.Core.InstEnv"

      deriving (Eq, Data)

    instance Outputable OverlapFlag where
       ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)

    instance Outputable OverlapMode where
       ppr (NoOverlap    _) = empty
       ppr (Overlappable _) = text "[overlappable]"
       ppr (Overlapping  _) = text "[overlapping]"
       ppr (Overlaps     _) = text "[overlap ok]"
       ppr (Incoherent   _) = text "[incoherent]"

    instance Binary OverlapMode where
        put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s
        put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s
        put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s
        put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s
        put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
        get bh = do
            h <- getByte bh
            case h of
                0 -> (get bh) >>= \s -> return $ NoOverlap s
                1 -> (get bh) >>= \s -> return $ Overlaps s
                2 -> (get bh) >>= \s -> return $ Incoherent s
                3 -> (get bh) >>= \s -> return $ Overlapping s
                4 -> (get bh) >>= \s -> return $ Overlappable s
                _ -> panic ("get OverlapMode" ++ show h)

    instance Binary OverlapFlag where
        put_ bh flag = do put_ bh (overlapMode flag)
                          put_ bh (isSafeOverlap flag)
        get bh = do
            h <- get bh
            b <- get bh
            return OverlapFlag { overlapMode = h, isSafeOverlap = b }

    pprSafeOverlap :: Bool -> SDoc
    pprSafeOverlap True  = text "[safe]"
    pprSafeOverlap False = empty

    {-
    ************************************************************************
    *                                                                      *
                    Precedence
    *                                                                      *
    ************************************************************************
    -}

    -- | A general-purpose pretty-printing precedence type.
    newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)
    -- See Note [Precedence in types]

    topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec
    topPrec = PprPrec 0 -- No parens
    sigPrec = PprPrec 1 -- Explicit type signatures
    funPrec = PprPrec 2 -- Function args; no parens for constructor apps
                        -- See [Type operator precedence] for why both
                        -- funPrec and opPrec exist.
    opPrec  = PprPrec 2 -- Infix operator
    starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *)
                         -- See Note [Star kind precedence]
    appPrec  = PprPrec 4 -- Constructor args; no parens for atomic

    maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc
    maybeParen ctxt_prec inner_prec pretty
      | ctxt_prec < inner_prec = pretty
      | otherwise              = parens pretty

    {- Note [Precedence in types]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Many pretty-printing functions have type
        ppr_ty :: PprPrec -> Type -> SDoc

    The PprPrec gives the binding strength of the context.  For example, in
       T ty1 ty2
    we will pretty-print 'ty1' and 'ty2' with the call
      (ppr_ty appPrec ty)
    to indicate that the context is that of an argument of a TyConApp.

    We use this consistently for Type and HsType.

    Note [Type operator precedence]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We don't keep the fixity of type operators in the operator. So the
    pretty printer follows the following precedence order:

       TyConPrec         Type constructor application
       TyOpPrec/FunPrec  Operator application and function arrow

    We have funPrec and opPrec to represent the precedence of function
    arrow and type operators respectively, but currently we implement
    funPrec == opPrec, so that we don't distinguish the two. Reason:
    it's hard to parse a type like
        a ~ b => c * d -> e - f

    By treating opPrec = funPrec we end up with more parens
        (a ~ b) => (c * d) -> (e - f)

    But the two are different constructors of PprPrec so we could make
    (->) bind more or less tightly if we wanted.

    Note [Star kind precedence]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We parenthesize the (*) kind to avoid two issues:

    1. Printing invalid or incorrect code.
       For example, instead of  type F @(*) x = x
             GHC used to print  type F @*   x = x
       However, (@*) is a type operator, not a kind application.

    2. Printing kinds that are correct but hard to read.
       Should  Either * Int  be read as  Either (*) Int
                                  or as  (*) Either Int  ?
       This depends on whether -XStarIsType is enabled, but it would be
       easier if we didn't have to check for the flag when reading the code.

    At the same time, we cannot parenthesize (*) blindly.
    Consider this Haskell98 kind:          ((* -> *) -> *) -> *
    With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*)

    The solution is to assign a special precedence to (*), 'starPrec', which is
    higher than 'funPrec' but lower than 'appPrec':

       F * * *   becomes  F (*) (*) (*)
       F A * B   becomes  F A (*) B
       Proxy *   becomes  Proxy (*)
       a * -> *  becomes  a (*) -> *
    -}

    {-
    ************************************************************************
    *                                                                      *
                    Tuples
    *                                                                      *
    ************************************************************************
    -}

    data TupleSort
      = BoxedTuple
      | UnboxedTuple
      | ConstraintTuple
      deriving( Eq, Data )

    instance Outputable TupleSort where
      ppr ts = text $
        case ts of
          BoxedTuple      -> "BoxedTuple"
          UnboxedTuple    -> "UnboxedTuple"
          ConstraintTuple -> "ConstraintTuple"

    instance Binary TupleSort where
        put_ bh BoxedTuple      = putByte bh 0
        put_ bh UnboxedTuple    = putByte bh 1
        put_ bh ConstraintTuple = putByte bh 2
        get bh = do
          h <- getByte bh
          case h of
            0 -> return BoxedTuple
            1 -> return UnboxedTuple
            _ -> return ConstraintTuple

    tupleSortBoxity :: TupleSort -> Boxity
    tupleSortBoxity BoxedTuple      = Boxed
    tupleSortBoxity UnboxedTuple    = Unboxed
    tupleSortBoxity ConstraintTuple = Boxed

    boxityTupleSort :: Boxity -> TupleSort
    boxityTupleSort Boxed   = BoxedTuple
    boxityTupleSort Unboxed = UnboxedTuple

    tupleParens :: TupleSort -> SDoc -> SDoc
    tupleParens BoxedTuple      p = parens p
    tupleParens UnboxedTuple    p = text "(#" <+> p <+> ptext (sLit "#)")
    tupleParens ConstraintTuple p   -- In debug-style write (% Eq a, Ord b %)
      = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)"))
                   (parens p)

    {-
    ************************************************************************
    *                                                                      *
                    Sums
    *                                                                      *
    ************************************************************************
    -}

    sumParens :: SDoc -> SDoc
    sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")

    -- | Pretty print an alternative in an unboxed sum e.g. "| a | |".
    pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use
                   -> a           -- ^ The things to be pretty printed
                   -> ConTag      -- ^ Alternative (one-based)
                   -> Arity       -- ^ Arity
                   -> SDoc        -- ^ 'SDoc' where the alternative havs been pretty
                                  -- printed and finally packed into a paragraph.
    pprAlternative pp x alt arity =
        fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)

    {-
    ************************************************************************
    *                                                                      *
    \subsection[Generic]{Generic flag}
    *                                                                      *
    ************************************************************************

    This is the "Embedding-Projection pair" datatype, it contains
    two pieces of code (normally either RenamedExpr's or Id's)
    If we have a such a pair (EP from to), the idea is that 'from' and 'to'
    represents functions of type

            from :: T -> Tring
            to   :: Tring -> T

    And we should have

            to (from x) = x

    T and Tring are arbitrary, but typically T is the 'main' type while
    Tring is the 'representation' type.  (This just helps us remember
    whether to use 'from' or 'to'.
    -}

    -- | Embedding Projection pair
    data EP a = EP { fromEP :: a,   -- :: T -> Tring
                     toEP   :: a }  -- :: Tring -> T

    {-
    Embedding-projection pairs are used in several places:

    First of all, each type constructor has an EP associated with it, the
    code in EP converts (datatype T) from T to Tring and back again.

    Secondly, when we are filling in Generic methods (in the typechecker,
    tcMethodBinds), we are constructing bimaps by induction on the structure
    of the type of the method signature.

    ************************************************************************
    *                                                                      *
    \subsection{Occurrence information}
    *                                                                      *
    ************************************************************************

    This data type is used exclusively by the simplifier, but it appears in a
    SubstResult, which is currently defined in GHC.Types.Var.Env, which is pretty
    near the base of the module hierarchy.  So it seemed simpler to put the defn of
    OccInfo here, safely at the bottom
    -}

    -- | identifier Occurrence Information
    data OccInfo
      = ManyOccs        { occ_tail    :: !TailCallInfo }
                            -- ^ There are many occurrences, or unknown occurrences

      | IAmDead             -- ^ Marks unused variables.  Sometimes useful for
                            -- lambda and case-bound variables.

      | OneOcc          { occ_in_lam  :: !InsideLam
                        , occ_n_br    :: {-# UNPACK #-} !BranchCount
                        , occ_int_cxt :: !InterestingCxt
                        , occ_tail    :: !TailCallInfo }
                            -- ^ Occurs exactly once (per branch), not inside a rule

      -- | This identifier breaks a loop of mutually recursive functions. The field
      -- marks whether it is only a loop breaker due to a reference in a rule
      | IAmALoopBreaker { occ_rules_only :: !RulesOnly
                        , occ_tail       :: !TailCallInfo }
                            -- Note [LoopBreaker OccInfo]
      deriving (Eq)

    type RulesOnly = Bool

    type BranchCount = Int
      -- For OneOcc, the BranchCount says how many syntactic occurrences there are
      -- At the moment we really only check for 1 or >1, but in principle
      --   we could pay attention to how *many* occurrences there are
      --   (notably in postInlineUnconditionally).
      -- But meanwhile, Ints are very efficiently represented.

    oneBranch :: BranchCount
    oneBranch = 1

    {-
    Note [LoopBreaker OccInfo]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
       IAmALoopBreaker True  <=> A "weak" or rules-only loop breaker
                                 Do not preInlineUnconditionally

       IAmALoopBreaker False <=> A "strong" loop breaker
                                 Do not inline at all

    See OccurAnal Note [Weak loop breakers]
    -}

    noOccInfo :: OccInfo
    noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }

    isNoOccInfo :: OccInfo -> Bool
    isNoOccInfo ManyOccs { occ_tail = NoTailCallInfo } = True
    isNoOccInfo _ = False

    isManyOccs :: OccInfo -> Bool
    isManyOccs ManyOccs{} = True
    isManyOccs _          = False

    seqOccInfo :: OccInfo -> ()
    seqOccInfo occ = occ `seq` ()

    -----------------
    -- | Interesting Context
    data InterestingCxt
      = IsInteresting
        -- ^ Function: is applied
        --   Data value: scrutinised by a case with at least one non-DEFAULT branch
      | NotInteresting
      deriving (Eq)

    -- | If there is any 'interesting' identifier occurrence, then the
    -- aggregated occurrence info of that identifier is considered interesting.
    instance Semi.Semigroup InterestingCxt where
      NotInteresting <> x = x
      IsInteresting  <> _ = IsInteresting

    instance Monoid InterestingCxt where
      mempty = NotInteresting
      mappend = (Semi.<>)

    -----------------
    -- | Inside Lambda
    data InsideLam
      = IsInsideLam
        -- ^ Occurs inside a non-linear lambda
        -- Substituting a redex for this occurrence is
        -- dangerous because it might duplicate work.
      | NotInsideLam
      deriving (Eq)

    -- | If any occurrence of an identifier is inside a lambda, then the
    -- occurrence info of that identifier marks it as occurring inside a lambda
    instance Semi.Semigroup InsideLam where
      NotInsideLam <> x = x
      IsInsideLam  <> _ = IsInsideLam

    instance Monoid InsideLam where
      mempty = NotInsideLam
      mappend = (Semi.<>)

    -----------------
    data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]
                      | NoTailCallInfo
      deriving (Eq)

    tailCallInfo :: OccInfo -> TailCallInfo
    tailCallInfo IAmDead   = NoTailCallInfo
    tailCallInfo other     = occ_tail other

    zapOccTailCallInfo :: OccInfo -> OccInfo
    zapOccTailCallInfo IAmDead   = IAmDead
    zapOccTailCallInfo occ       = occ { occ_tail = NoTailCallInfo }

    isAlwaysTailCalled :: OccInfo -> Bool
    isAlwaysTailCalled occ
      = case tailCallInfo occ of AlwaysTailCalled{} -> True
                                 NoTailCallInfo     -> False

    instance Outputable TailCallInfo where
      ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ]
      ppr _                     = empty

    -----------------
    strongLoopBreaker, weakLoopBreaker :: OccInfo
    strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo
    weakLoopBreaker   = IAmALoopBreaker True  NoTailCallInfo

    isWeakLoopBreaker :: OccInfo -> Bool
    isWeakLoopBreaker (IAmALoopBreaker{}) = True
    isWeakLoopBreaker _                   = False

    isStrongLoopBreaker :: OccInfo -> Bool
    isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True
      -- Loop-breaker that breaks a non-rule cycle
    isStrongLoopBreaker _                                            = False

    isDeadOcc :: OccInfo -> Bool
    isDeadOcc IAmDead = True
    isDeadOcc _       = False

    isOneOcc :: OccInfo -> Bool
    isOneOcc (OneOcc {}) = True
    isOneOcc _           = False

    zapFragileOcc :: OccInfo -> OccInfo
    -- Keep only the most robust data: deadness, loop-breaker-hood
    zapFragileOcc (OneOcc {}) = noOccInfo
    zapFragileOcc occ         = zapOccTailCallInfo occ

    instance Outputable OccInfo where
      -- only used for debugging; never parsed.  KSW 1999-07
      ppr (ManyOccs tails)     = pprShortTailCallInfo tails
      ppr IAmDead              = text "Dead"
      ppr (IAmALoopBreaker rule_only tails)
            = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails
            where
              pp_ro | rule_only = char '!'
                    | otherwise = empty
      ppr (OneOcc inside_lam one_branch int_cxt tail_info)
            = text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail
            where
              pp_lam IsInsideLam     = char 'L'
              pp_lam NotInsideLam    = empty
              pp_args IsInteresting  = char '!'
              pp_args NotInteresting = empty
              pp_tail                = pprShortTailCallInfo tail_info

    pprShortTailCallInfo :: TailCallInfo -> SDoc
    pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar)
    pprShortTailCallInfo NoTailCallInfo        = empty

    {-
    Note [TailCallInfo]
    ~~~~~~~~~~~~~~~~~~~
    The occurrence analyser determines what can be made into a join point, but it
    doesn't change the binder into a JoinId because then it would be inconsistent
    with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to
    change the IdDetails.

    The AlwaysTailCalled marker actually means slightly more than simply that the
    function is always tail-called. See Note [Invariants on join points].

    This info is quite fragile and should not be relied upon unless the occurrence
    analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of
    the join-point-hood of a binder; a join id itself will not be marked
    AlwaysTailCalled.

    Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that
    being tail-called would mean that the variable could only appear once per branch
    (thus getting a `OneOcc { }` occurrence info), but a join
    point can also be invoked from other join points, not just from case branches:

      let j1 x = ...
          j2 y = ... j1 z {- tail call -} ...
      in case w of
           A -> j1 v
           B -> j2 u
           C -> j2 q

    Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get
    ManyOccs and j2 will get `OneOcc { occ_n_br = 2 }`.

    ************************************************************************
    *                                                                      *
                    Default method specification
    *                                                                      *
    ************************************************************************

    The DefMethSpec enumeration just indicates what sort of default method
    is used for a class. It is generated from source code, and present in
    interface files; it is converted to Class.DefMethInfo before begin put in a
    Class object.
    -}

    -- | Default Method Specification
    data DefMethSpec ty
      = VanillaDM     -- Default method given with polymorphic code
      | GenericDM ty  -- Default method given with code of this type

    instance Outputable (DefMethSpec ty) where
      ppr VanillaDM      = text "{- Has default method -}"
      ppr (GenericDM {}) = text "{- Has generic default method -}"

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Success flag}
    *                                                                      *
    ************************************************************************
    -}

    data SuccessFlag = Succeeded | Failed

    instance Outputable SuccessFlag where
        ppr Succeeded = text "Succeeded"
        ppr Failed    = text "Failed"

    successIf :: Bool -> SuccessFlag
    successIf True  = Succeeded
    successIf False = Failed

    succeeded, failed :: SuccessFlag -> Bool
    succeeded Succeeded = True
    succeeded Failed    = False

    failed Succeeded = False
    failed Failed    = True

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Activation}
    *                                                                      *
    ************************************************************************

    When a rule or inlining is active

    Note [Compiler phases]
    ~~~~~~~~~~~~~~~~~~~~~~
    The CompilerPhase says which phase the simplifier is running in:

    * InitialPhase: before all user-visible phases

    * Phase 2,1,0: user-visible phases; the phase number
      controls rule ordering an inlining.

    * FinalPhase: used for all subsequent simplifier
      runs. By delaying inlining of wrappers to FinalPhase we can
      ensure that RULE have a good chance to fire. See
      Note [Wrapper activation] in GHC.Core.Opt.WorkWrap

      NB: FinalPhase is run repeatedly, not just once.

      NB: users don't have access to InitialPhase or FinalPhase.
      They write {-# INLINE[n] f #-}, meaning (Phase n)

    The phase sequencing is done by GHC.Opt.Simplify.Driver
    -}

    -- | Phase Number
    type PhaseNum = Int  -- Compilation phase
                         -- Phases decrease towards zero
                         -- Zero is the last phase

    data CompilerPhase
      = InitialPhase    -- The first phase -- number = infinity!
      | Phase PhaseNum  -- User-specificable phases
      | FinalPhase      -- The last phase  -- number = -infinity!
      deriving Eq

    instance Outputable CompilerPhase where
       ppr (Phase n)    = int n
       ppr InitialPhase = text "InitialPhase"
       ppr FinalPhase   = text "FinalPhase"

    -- See note [Pragma source text]
    data Activation
      = AlwaysActive
      | ActiveBefore SourceText PhaseNum  -- Active only *strictly before* this phase
      | ActiveAfter  SourceText PhaseNum  -- Active in this phase and later
      | FinalActive                       -- Active in final phase only
      | NeverActive
      deriving( Eq, Data )
        -- Eq used in comparing rules in GHC.Hs.Decls

    activateAfterInitial :: Activation
    -- Active in the first phase after the initial phase
    -- Currently we have just phases [2,1,0,FinalPhase,FinalPhase,...]
    -- Where FinalPhase means GHC's internal simplification steps
    -- after all rules have run
    activateAfterInitial = ActiveAfter NoSourceText 2

    activateDuringFinal :: Activation
    -- Active in the final simplification phase (which is repeated)
    activateDuringFinal = FinalActive

    isActive :: CompilerPhase -> Activation -> Bool
    isActive InitialPhase act = activeInInitialPhase act
    isActive (Phase p)    act = activeInPhase p act
    isActive FinalPhase   act = activeInFinalPhase act

    activeInInitialPhase :: Activation -> Bool
    activeInInitialPhase AlwaysActive      = True
    activeInInitialPhase (ActiveBefore {}) = True
    activeInInitialPhase _                 = False

    activeInPhase :: PhaseNum -> Activation -> Bool
    activeInPhase _ AlwaysActive       = True
    activeInPhase _ NeverActive        = False
    activeInPhase _ FinalActive        = False
    activeInPhase p (ActiveAfter  _ n) = p <= n
    activeInPhase p (ActiveBefore _ n) = p >  n

    activeInFinalPhase :: Activation -> Bool
    activeInFinalPhase AlwaysActive     = True
    activeInFinalPhase FinalActive      = True
    activeInFinalPhase (ActiveAfter {}) = True
    activeInFinalPhase _                = False

    isNeverActive, isAlwaysActive :: Activation -> Bool
    isNeverActive NeverActive = True
    isNeverActive _           = False

    isAlwaysActive AlwaysActive = True
    isAlwaysActive _            = False

    competesWith :: Activation -> Activation -> Bool
    -- See Note [Activation competition]
    competesWith AlwaysActive      _                = True

    competesWith NeverActive       _                = False
    competesWith _                 NeverActive      = False

    competesWith FinalActive       FinalActive      = True
    competesWith FinalActive       _                = False

    competesWith (ActiveBefore {})  AlwaysActive      = True
    competesWith (ActiveBefore {})  FinalActive       = False
    competesWith (ActiveBefore {})  (ActiveBefore {}) = True
    competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b

    competesWith (ActiveAfter {})  AlwaysActive      = False
    competesWith (ActiveAfter {})  FinalActive       = True
    competesWith (ActiveAfter {})  (ActiveBefore {}) = False
    competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b

    {- Note [Competing activations]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Sometimes a RULE and an inlining may compete, or two RULES.
    See Note [Rules and inlining/other rules] in GHC.HsToCore.

    We say that act1 "competes with" act2 iff
       act1 is active in the phase when act2 *becomes* active
    NB: remember that phases count *down*: 2, 1, 0!

    It's too conservative to ensure that the two are never simultaneously
    active.  For example, a rule might be always active, and an inlining
    might switch on in phase 2.  We could switch off the rule, but it does
    no harm.
    -}

    {- *********************************************************************
    *                                                                      *
                     InlinePragma, InlineSpec, RuleMatchInfo
    *                                                                      *
    ********************************************************************* -}

    data InlinePragma            -- Note [InlinePragma]
      = InlinePragma
          { inl_src    :: SourceText -- Note [Pragma source text]
          , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act]

          , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n
                                         --            explicit (non-type, non-dictionary) args
                                         --   That is, inl_sat describes the number of *source-code*
                                         --   arguments the thing must be applied to.  We add on the
                                         --   number of implicit, dictionary arguments when making
                                         --   the Unfolding, and don't look at inl_sat further

          , inl_act    :: Activation     -- Says during which phases inlining is allowed
                                         -- See Note [inl_inline and inl_act]

          , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
        } deriving( Eq, Data )

    -- | Rule Match Information
    data RuleMatchInfo = ConLike                    -- See Note [CONLIKE pragma]
                       | FunLike
                       deriving( Eq, Data, Show )
            -- Show needed for GHC.Parser.Lexer

    -- | Inline Specification
    data InlineSpec   -- What the user's INLINE pragma looked like
      = Inline           -- User wrote INLINE
      | Inlinable        -- User wrote INLINABLE
      | NoInline         -- User wrote NOINLINE
      | NoUserInlinePrag -- User did not write any of INLINE/INLINABLE/NOINLINE
                         -- e.g. in `defaultInlinePragma` or when created by CSE
      deriving( Eq, Data, Show )
            -- Show needed for GHC.Parser.Lexer

    {- Note [InlinePragma]
    ~~~~~~~~~~~~~~~~~~~~~~
    This data type mirrors what you can write in an INLINE or NOINLINE pragma in
    the source program.

    If you write nothing at all, you get defaultInlinePragma:
       inl_inline = NoUserInlinePrag
       inl_act    = AlwaysActive
       inl_rule   = FunLike

    It's not possible to get that combination by *writing* something, so
    if an Id has defaultInlinePragma it means the user didn't specify anything.

    If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding.

    If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair

    Note [inl_inline and inl_act]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    * inl_inline says what the user wrote: did they say INLINE, NOINLINE,
      INLINABLE, or nothing at all

    * inl_act says in what phases the unfolding is active or inactive
      E.g  If you write INLINE[1]    then inl_act will be set to ActiveAfter 1
           If you write NOINLINE[1]  then inl_act will be set to ActiveBefore 1
           If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1
      So note that inl_act does not say what pragma you wrote: it just
      expresses its consequences

    * inl_act just says when the unfolding is active; it doesn't say what
      to inline.  If you say INLINE f, then f's inl_act will be AlwaysActive,
      but in addition f will get a "stable unfolding" with UnfoldingGuidance
      that tells the inliner to be pretty eager about it.

    Note [CONLIKE pragma]
    ~~~~~~~~~~~~~~~~~~~~~
    The ConLike constructor of a RuleMatchInfo is aimed at the following.
    Consider first
        {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
        g b bs = let x = b:bs in ..x...x...(r x)...
    Now, the rule applies to the (r x) term, because GHC "looks through"
    the definition of 'x' to see that it is (b:bs).

    Now consider
        {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
        g v = let x = f v in ..x...x...(r x)...
    Normally the (r x) would *not* match the rule, because GHC would be
    scared about duplicating the redex (f v), so it does not "look
    through" the bindings.

    However the CONLIKE modifier says to treat 'f' like a constructor in
    this situation, and "look through" the unfolding for x.  So (r x)
    fires, yielding (f (v+1)).

    This is all controlled with a user-visible pragma:
         {-# NOINLINE CONLIKE [1] f #-}

    The main effects of CONLIKE are:

        - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
          CONLIKE thing like constructors, by ANF-ing them

        - New function GHC.Core.Utils.exprIsExpandable is like exprIsCheap, but
          additionally spots applications of CONLIKE functions

        - A CoreUnfolding has a field that caches exprIsExpandable

        - The rule matcher consults this field.  See
          Note [Expanding variables] in GHC.Core.Rules.
    -}

    isConLike :: RuleMatchInfo -> Bool
    isConLike ConLike = True
    isConLike _       = False

    isFunLike :: RuleMatchInfo -> Bool
    isFunLike FunLike = True
    isFunLike _       = False

    noUserInlineSpec :: InlineSpec -> Bool
    noUserInlineSpec NoUserInlinePrag = True
    noUserInlineSpec _                = False

    defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
      :: InlinePragma
    defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"
                                       , inl_act = AlwaysActive
                                       , inl_rule = FunLike
                                       , inl_inline = NoUserInlinePrag
                                       , inl_sat = Nothing }

    alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
    neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }

    inlinePragmaSpec :: InlinePragma -> InlineSpec
    inlinePragmaSpec = inl_inline

    -- A DFun has an always-active inline activation so that
    -- exprIsConApp_maybe can "see" its unfolding
    -- (However, its actual Unfolding is a DFunUnfolding, which is
    --  never inlined other than via exprIsConApp_maybe.)
    dfunInlinePragma   = defaultInlinePragma { inl_act  = AlwaysActive
                                             , inl_rule = ConLike }

    isDefaultInlinePragma :: InlinePragma -> Bool
    isDefaultInlinePragma (InlinePragma { inl_act = activation
                                        , inl_rule = match_info
                                        , inl_inline = inline })
      = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info

    isInlinePragma :: InlinePragma -> Bool
    isInlinePragma prag = case inl_inline prag of
                            Inline -> True
                            _      -> False

    isInlinablePragma :: InlinePragma -> Bool
    isInlinablePragma prag = case inl_inline prag of
                               Inlinable -> True
                               _         -> False

    isAnyInlinePragma :: InlinePragma -> Bool
    -- INLINE or INLINABLE
    isAnyInlinePragma prag = case inl_inline prag of
                            Inline    -> True
                            Inlinable -> True
                            _         -> False

    inlinePragmaSat :: InlinePragma -> Maybe Arity
    inlinePragmaSat = inl_sat

    inlinePragmaActivation :: InlinePragma -> Activation
    inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation

    inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
    inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info

    setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
    setInlinePragmaActivation prag activation = prag { inl_act = activation }

    setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
    setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }

    instance Outputable Activation where
       ppr AlwaysActive       = empty
       ppr NeverActive        = brackets (text "~")
       ppr (ActiveBefore _ n) = brackets (char '~' <> int n)
       ppr (ActiveAfter  _ n) = brackets (int n)
       ppr FinalActive        = text "[final]"

    instance Binary Activation where
        put_ bh NeverActive =
                putByte bh 0
        put_ bh FinalActive =
                putByte bh 1
        put_ bh AlwaysActive =
                putByte bh 2
        put_ bh (ActiveBefore src aa) = do
                putByte bh 3
                put_ bh src
                put_ bh aa
        put_ bh (ActiveAfter src ab) = do
                putByte bh 4
                put_ bh src
                put_ bh ab
        get bh = do
                h <- getByte bh
                case h of
                  0 -> return NeverActive
                  1 -> return FinalActive
                  2 -> return AlwaysActive
                  3 -> do src <- get bh
                          aa <- get bh
                          return (ActiveBefore src aa)
                  _ -> do src <- get bh
                          ab <- get bh
                          return (ActiveAfter src ab)

    instance Outputable RuleMatchInfo where
       ppr ConLike = text "CONLIKE"
       ppr FunLike = text "FUNLIKE"

    instance Binary RuleMatchInfo where
        put_ bh FunLike = putByte bh 0
        put_ bh ConLike = putByte bh 1
        get bh = do
                h <- getByte bh
                if h == 1 then return ConLike
                          else return FunLike

    instance Outputable InlineSpec where
       ppr Inline           = text "INLINE"
       ppr NoInline         = text "NOINLINE"
       ppr Inlinable        = text "INLINABLE"
       ppr NoUserInlinePrag = empty

    instance Binary InlineSpec where
        put_ bh NoUserInlinePrag = putByte bh 0
        put_ bh Inline           = putByte bh 1
        put_ bh Inlinable        = putByte bh 2
        put_ bh NoInline         = putByte bh 3

        get bh = do h <- getByte bh
                    case h of
                      0 -> return NoUserInlinePrag
                      1 -> return Inline
                      2 -> return Inlinable
                      _ -> return NoInline

    instance Outputable InlinePragma where
      ppr = pprInline

    instance Binary InlinePragma where
        put_ bh (InlinePragma s a b c d) = do
                put_ bh s
                put_ bh a
                put_ bh b
                put_ bh c
                put_ bh d

        get bh = do
               s <- get bh
               a <- get bh
               b <- get bh
               c <- get bh
               d <- get bh
               return (InlinePragma s a b c d)

    pprInline :: InlinePragma -> SDoc
    pprInline = pprInline' True

    pprInlineDebug :: InlinePragma -> SDoc
    pprInlineDebug = pprInline' False

    pprInline' :: Bool           -- True <=> do not display the inl_inline field
               -> InlinePragma
               -> SDoc
    pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation
                                        , inl_rule = info, inl_sat = mb_arity })
        = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info
        where
          pp_inl x = if emptyInline then empty else ppr x

          pp_act Inline   AlwaysActive = empty
          pp_act NoInline NeverActive  = empty
          pp_act _        act          = ppr act

          pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar)
                 | otherwise           = empty
          pp_info | isFunLike info = empty
                  | otherwise      = ppr info

    {-
    ************************************************************************
    *                                                                      *
        IntWithInf
    *                                                                      *
    ************************************************************************

    Represents an integer or positive infinity

    -}

    -- | An integer or infinity
    data IntWithInf = Int {-# UNPACK #-} !Int
                    | Infinity
      deriving Eq

    -- | A representation of infinity
    infinity :: IntWithInf
    infinity = Infinity

    instance Ord IntWithInf where
      compare Infinity Infinity = EQ
      compare (Int _)  Infinity = LT
      compare Infinity (Int _)  = GT
      compare (Int a)  (Int b)  = a `compare` b

    instance Outputable IntWithInf where
      ppr Infinity = char '∞'
      ppr (Int n)  = int n

    instance Num IntWithInf where
      (+) = plusWithInf
      (*) = mulWithInf

      abs Infinity = Infinity
      abs (Int n)  = Int (abs n)

      signum Infinity = Int 1
      signum (Int n)  = Int (signum n)

      fromInteger = Int . fromInteger

      (-) = panic "subtracting IntWithInfs"

    intGtLimit :: Int -> IntWithInf -> Bool
    intGtLimit _ Infinity = False
    intGtLimit n (Int m)  = n > m

    -- | Add two 'IntWithInf's
    plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf
    plusWithInf Infinity _        = Infinity
    plusWithInf _        Infinity = Infinity
    plusWithInf (Int a)  (Int b)  = Int (a + b)

    -- | Multiply two 'IntWithInf's
    mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf
    mulWithInf Infinity _        = Infinity
    mulWithInf _        Infinity = Infinity
    mulWithInf (Int a)  (Int b)  = Int (a * b)

    -- | Turn a positive number into an 'IntWithInf', where 0 represents infinity
    treatZeroAsInf :: Int -> IntWithInf
    treatZeroAsInf 0 = Infinity
    treatZeroAsInf n = Int n

    -- | Inject any integer into an 'IntWithInf'
    mkIntWithInf :: Int -> IntWithInf
    mkIntWithInf = Int

    data SpliceExplicitFlag
              = ExplicitSplice | -- ^ <=> $(f x y)
                ImplicitSplice   -- ^ <=> f x y,  i.e. a naked top level expression
        deriving Data

    {- *********************************************************************
    *                                                                      *
                            Types vs Kinds
    *                                                                      *
    ********************************************************************* -}

    -- | Flag to see whether we're type-checking terms or kind-checking types
    data TypeOrKind = TypeLevel | KindLevel
      deriving Eq

    instance Outputable TypeOrKind where
      ppr TypeLevel = text "TypeLevel"
      ppr KindLevel = text "KindLevel"

    isTypeLevel :: TypeOrKind -> Bool
    isTypeLevel TypeLevel = True
    isTypeLevel KindLevel = False

    isKindLevel :: TypeOrKind -> Bool
    isKindLevel TypeLevel = False
    isKindLevel KindLevel = True