BasicTypes.hs 44 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1997-1998

sof's avatar
sof committed
5 6 7 8 9 10 11 12 13 14
\section[BasicTypes]{Miscellanous 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}
Austin Seipp's avatar
Austin Seipp committed
15
-}
sof's avatar
sof committed
16

17 18
{-# LANGUAGE DeriveDataTypeable #-}

sof's avatar
sof committed
19
module BasicTypes(
20
        Version, bumpVersion, initialVersion,
21

22
        ConTag, ConTagZ, fIRST_TAG,
23

24 25 26
        Arity, RepArity,

        Alignment,
27

28
        FunctionOrData(..),
29

30
        WarningTxt(..), StringLiteral(..),
31 32 33 34 35

        Fixity(..), FixityDirection(..),
        defaultFixity, maxPrecedence, minPrecedence,
        negateFixity, funTyFixity,
        compareFixity,
36

37
        RecFlag(..), isRec, isNonRec, boolToRecFlag,
cactus's avatar
cactus committed
38
        Origin(..), isGenerated,
39

40
        RuleName, pprRuleName,
41

42
        TopLevelFlag(..), isTopLevel, isNotTopLevel,
43

Ryan Scott's avatar
Ryan Scott committed
44 45
        DerivStrategy(..),

46
        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
47
        hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
48

49
        Boxity(..), isBoxed,
50

51
        TupleSort(..), tupleSortBoxity, boxityTupleSort,
batterseapower's avatar
batterseapower committed
52
        tupleParens,
53

54 55
        sumParens, pprAlternative,

56 57 58 59 60
        -- ** The OneShotInfo type
        OneShotInfo(..),
        noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
        bestOneShot, worstOneShot,

61 62 63
        OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc,
        strongLoopBreaker, weakLoopBreaker,
64

65 66 67
        InsideLam, insideLam, notInsideLam,
        OneBranch, oneBranch, notOneBranch,
        InterestingCxt,
68

69 70
        EP(..),

71
        DefMethSpec(..),
72
        SwapFlag(..), flipSwap, unSwap, isSwapped,
73

74
        CompilerPhase(..), PhaseNum,
75 76

        Activation(..), isActive, isActiveIn, competesWith,
77
        isNeverActive, isAlwaysActive, isEarlyActive,
78

79
        RuleMatchInfo(..), isConLike, isFunLike,
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
80
        InlineSpec(..), isEmptyInlineSpec,
81 82 83
        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
        neverInlinePragma, dfunInlinePragma,
        isDefaultInlinePragma,
84
        isInlinePragma, isInlinablePragma, isAnyInlinePragma,
85
        inlinePragmaSpec, inlinePragmaSat,
86 87
        inlinePragmaActivation, inlinePragmaRuleMatchInfo,
        setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
88

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

91 92
        FractionalLit(..), negateFractionalLit, integralFractionalLit,

93 94
        SourceText,

95
        IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit
sof's avatar
sof committed
96 97
   ) where

98
import FastString
sof's avatar
sof committed
99
import Outputable
100
import SrcLoc ( Located,unLoc )
101
import StaticFlags( opt_PprStyle_Debug )
102
import Data.Data hiding (Fixity)
103
import Data.Function (on)
104

Austin Seipp's avatar
Austin Seipp committed
105 106 107
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
108
\subsection[Arity]{Arity}
Austin Seipp's avatar
Austin Seipp committed
109 110 111
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
112

113 114 115 116
-- | 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
117
-- See also Note [Definition of arity] in CoreArity
sof's avatar
sof committed
118
type Arity = Int
119

120 121 122
-- | Representation Arity
--
-- The number of represented arguments that can be applied to a value before it does
123 124 125 126 127
-- "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
sof's avatar
sof committed
128

Austin Seipp's avatar
Austin Seipp committed
129 130 131
{-
************************************************************************
*                                                                      *
132
              Constructor tags
Austin Seipp's avatar
Austin Seipp committed
133 134 135
*                                                                      *
************************************************************************
-}
136

137 138 139 140
-- | Constructor Tag
--
-- Type of the tags associated with each constructor possibility or superclass
-- selector
141 142
type ConTag = Int

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

146 147
fIRST_TAG :: ConTag
-- ^ Tags are allocated from here for real constructors
148
--   or for superclass selectors
149 150
fIRST_TAG =  1

Austin Seipp's avatar
Austin Seipp committed
151 152 153
{-
************************************************************************
*                                                                      *
154
\subsection[Alignment]{Alignment}
Austin Seipp's avatar
Austin Seipp committed
155 156 157
*                                                                      *
************************************************************************
-}
158 159 160

type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).

Austin Seipp's avatar
Austin Seipp committed
161 162 163
{-
************************************************************************
*                                                                      *
164
         One-shot information
Austin Seipp's avatar
Austin Seipp committed
165 166 167
*                                                                      *
************************************************************************
-}
168 169 170 171 172 173 174 175

-- | 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.
176 177 178
data OneShotInfo
  = NoOneShotInfo -- ^ No information
  | ProbOneShot   -- ^ The lambda is probably applied at most once
179
                  -- See Note [Computing one-shot info, and ProbOneShot] in Demand
180
  | OneShotLam    -- ^ The lambda is applied at most once.
Peter Wortmann's avatar
Peter Wortmann committed
181
  deriving (Eq)
182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206

-- | 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 ProbOneShot   NoOneShotInfo = NoOneShotInfo
worstOneShot ProbOneShot   _             = ProbOneShot
worstOneShot OneShotLam    os            = os

bestOneShot NoOneShotInfo os         = os
bestOneShot ProbOneShot   OneShotLam = OneShotLam
bestOneShot ProbOneShot   _          = ProbOneShot
bestOneShot OneShotLam    _          = OneShotLam

pprOneShotInfo :: OneShotInfo -> SDoc
pprOneShotInfo NoOneShotInfo = empty
207 208
pprOneShotInfo ProbOneShot   = text "ProbOneShot"
pprOneShotInfo OneShotLam    = text "OneShot"
209 210 211 212

instance Outputable OneShotInfo where
    ppr = pprOneShotInfo

Austin Seipp's avatar
Austin Seipp committed
213 214 215
{-
************************************************************************
*                                                                      *
216
           Swap flag
Austin Seipp's avatar
Austin Seipp committed
217 218 219
*                                                                      *
************************************************************************
-}
220

221 222
data SwapFlag
  = NotSwapped  -- Args are: actual,   expected
223 224 225
  | IsSwapped   -- Args are: expected, actual

instance Outputable SwapFlag where
226 227
  ppr IsSwapped  = text "Is-swapped"
  ppr NotSwapped = text "Not-swapped"
228 229 230 231 232

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

233 234 235 236
isSwapped :: SwapFlag -> Bool
isSwapped IsSwapped  = True
isSwapped NotSwapped = False

237 238 239 240
unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
unSwap NotSwapped f a b = f a b
unSwap IsSwapped  f a b = f b a

Austin Seipp's avatar
Austin Seipp committed
241 242 243
{-
************************************************************************
*                                                                      *
244
\subsection[FunctionOrData]{FunctionOrData}
Austin Seipp's avatar
Austin Seipp committed
245 246 247
*                                                                      *
************************************************************************
-}
248 249

data FunctionOrData = IsFunction | IsData
250
    deriving (Eq, Ord, Data)
251 252 253 254

instance Outputable FunctionOrData where
    ppr IsFunction = text "(function)"
    ppr IsData     = text "(data)"
sof's avatar
sof committed
255

Austin Seipp's avatar
Austin Seipp committed
256 257 258
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
259
\subsection[Version]{Module and identifier version numbers}
Austin Seipp's avatar
Austin Seipp committed
260 261 262
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
263 264

type Version = Int
265

266
bumpVersion :: Version -> Version
267
bumpVersion v = v+1
268 269 270

initialVersion :: Version
initialVersion = 1
sof's avatar
sof committed
271

Austin Seipp's avatar
Austin Seipp committed
272 273 274
{-
************************************************************************
*                                                                      *
275
                Deprecations
Austin Seipp's avatar
Austin Seipp committed
276 277 278
*                                                                      *
************************************************************************
-}
279

280
-- | A String Literal in the source, including its original raw format for use by
281 282 283 284 285
-- source to source manipulation tools.
data StringLiteral = StringLiteral
                       { sl_st :: SourceText, -- literal raw source.
                                              -- See not [Literal source text]
                         sl_fs :: FastString  -- literal string value
286
                       } deriving Data
287 288 289 290

instance Eq StringLiteral where
  (StringLiteral _ a) == (StringLiteral _ b) = a == b

291 292
-- | Warning Text
--
Ian Lynagh's avatar
Ian Lynagh committed
293
-- reason/explanation from a WARNING or DEPRECATED pragma
294
data WarningTxt = WarningTxt (Located SourceText)
295
                             [Located StringLiteral]
296
                | DeprecatedTxt (Located SourceText)
297
                                [Located StringLiteral]
298
    deriving (Eq, Data)
Ian Lynagh's avatar
Ian Lynagh committed
299 300

instance Outputable WarningTxt where
301
    ppr (WarningTxt    _ ws)
302
                         = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
303
    ppr (DeprecatedTxt _ ds)
304 305
                         = text "Deprecated:" <+>
                           doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
sof's avatar
sof committed
306

Austin Seipp's avatar
Austin Seipp committed
307 308 309
{-
************************************************************************
*                                                                      *
310
                Rules
Austin Seipp's avatar
Austin Seipp committed
311 312 313
*                                                                      *
************************************************************************
-}
314 315

type RuleName = FastString
316

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

Austin Seipp's avatar
Austin Seipp committed
320 321 322
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
323
\subsection[Fixity]{Fixity info}
Austin Seipp's avatar
Austin Seipp committed
324 325 326
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
327

328
------------------------
329 330
data Fixity = Fixity SourceText Int FixityDirection
  -- Note [Pragma source text]
331
  deriving Data
sof's avatar
sof committed
332 333

instance Outputable Fixity where
334
    ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]
sof's avatar
sof committed
335

336
instance Eq Fixity where -- Used to determine if two fixities conflict
337
  (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2
338 339

------------------------
340
data FixityDirection = InfixL | InfixR | InfixN
341
                     deriving (Eq, Data)
342

sof's avatar
sof committed
343
instance Outputable FixityDirection where
344 345 346
    ppr InfixL = text "infixl"
    ppr InfixR = text "infixr"
    ppr InfixN = text "infix"
sof's avatar
sof committed
347

348
------------------------
349
maxPrecedence, minPrecedence :: Int
350
maxPrecedence = 9
351 352
minPrecedence = 0

353
defaultFixity :: Fixity
354
defaultFixity = Fixity (show maxPrecedence) maxPrecedence InfixL
355

356 357
negateFixity, funTyFixity :: Fixity
-- Wired-in fixities
358 359
negateFixity = Fixity "6" 6 InfixL  -- Fixity of unary negate
funTyFixity  = Fixity "0" 0 InfixR  -- Fixity of '->'
sof's avatar
sof committed
360

Austin Seipp's avatar
Austin Seipp committed
361
{-
362 363 364
Consider

\begin{verbatim}
365
        a `op1` b `op2` c
366 367 368
\end{verbatim}
@(compareFixity op1 op2)@ tells which way to arrange appication, or
whether there's an error.
Austin Seipp's avatar
Austin Seipp committed
369
-}
370 371

compareFixity :: Fixity -> Fixity
372 373
              -> (Bool,         -- Error please
                  Bool)         -- Associate to the right: a op1 (b op2 c)
374
compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)
375
  = case prec1 `compare` prec2 of
376 377 378 379 380 381
        GT -> left
        LT -> right
        EQ -> case (dir1, dir2) of
                        (InfixR, InfixR) -> right
                        (InfixL, InfixL) -> left
                        _                -> error_please
382
  where
383
    right        = (False, True)
384 385
    left         = (False, False)
    error_please = (True,  False)
sof's avatar
sof committed
386

Austin Seipp's avatar
Austin Seipp committed
387 388 389
{-
************************************************************************
*                                                                      *
390
\subsection[Top-level/local]{Top-level/not-top level flag}
Austin Seipp's avatar
Austin Seipp committed
391 392 393
*                                                                      *
************************************************************************
-}
394 395 396 397

data TopLevelFlag
  = TopLevel
  | NotTopLevel
398 399 400 401 402 403

isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool

isNotTopLevel NotTopLevel = True
isNotTopLevel TopLevel    = False

404
isTopLevel TopLevel     = True
405
isTopLevel NotTopLevel  = False
406 407

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

Austin Seipp's avatar
Austin Seipp committed
411 412 413
{-
************************************************************************
*                                                                      *
414
                Boxity flag
Austin Seipp's avatar
Austin Seipp committed
415 416 417
*                                                                      *
************************************************************************
-}
418 419 420 421

data Boxity
  = Boxed
  | Unboxed
422
  deriving( Eq, Data )
423 424 425 426 427

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

428 429 430 431
instance Outputable Boxity where
  ppr Boxed   = text "Boxed"
  ppr Unboxed = text "Unboxed"

Austin Seipp's avatar
Austin Seipp committed
432 433 434
{-
************************************************************************
*                                                                      *
435
                Recursive/Non-Recursive flag
Austin Seipp's avatar
Austin Seipp committed
436 437 438
*                                                                      *
************************************************************************
-}
439

440
-- | Recursivity Flag
441 442
data RecFlag = Recursive
             | NonRecursive
443
             deriving( Eq, Data )
sof's avatar
sof committed
444

445 446 447
isRec :: RecFlag -> Bool
isRec Recursive    = True
isRec NonRecursive = False
sof's avatar
sof committed
448

449 450 451
isNonRec :: RecFlag -> Bool
isNonRec Recursive    = False
isNonRec NonRecursive = True
452 453 454 455 456 457

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

instance Outputable RecFlag where
458 459
  ppr Recursive    = text "Recursive"
  ppr NonRecursive = text "NonRecursive"
460

Austin Seipp's avatar
Austin Seipp committed
461 462 463
{-
************************************************************************
*                                                                      *
cactus's avatar
cactus committed
464
                Code origin
Austin Seipp's avatar
Austin Seipp committed
465 466 467 468
*                                                                      *
************************************************************************
-}

cactus's avatar
cactus committed
469 470
data Origin = FromSource
            | Generated
471
            deriving( Eq, Data )
cactus's avatar
cactus committed
472 473 474 475 476 477

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

instance Outputable Origin where
478 479
  ppr FromSource  = text "FromSource"
  ppr Generated   = text "Generated"
cactus's avatar
cactus committed
480

Ryan Scott's avatar
Ryan Scott committed
481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504
{-
************************************************************************
*                                                                      *
                Deriving strategies
*                                                                      *
************************************************************************
-}

-- | Which technique the user explicitly requested when deriving an instance.
data DerivStrategy
  -- See Note [Deriving strategies] in TcDeriv
  = DerivStock    -- ^ GHC's \"standard\" strategy, which is to implement a
                  --   custom instance for the data type. This only works for
                  --   certain types that GHC knows about (e.g., 'Eq', 'Show',
                  --   'Functor' when @-XDeriveFunctor@ is enabled, etc.)
  | DerivAnyclass -- ^ @-XDeriveAnyClass@
  | DerivNewtype  -- ^ @-XGeneralizedNewtypeDeriving@
  deriving (Eq, Data)

instance Outputable DerivStrategy where
    ppr DerivStock    = text "stock"
    ppr DerivAnyclass = text "anyclass"
    ppr DerivNewtype  = text "newtype"

Austin Seipp's avatar
Austin Seipp committed
505 506 507
{-
************************************************************************
*                                                                      *
508
                Instance overlap flag
Austin Seipp's avatar
Austin Seipp committed
509 510 511
*                                                                      *
************************************************************************
-}
512

dterei's avatar
dterei committed
513
-- | The semantics allowed for overlapping instances for a particular
514
-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a
dterei's avatar
dterei committed
515
-- explanation of the `isSafeOverlap` field.
Alan Zimmerman's avatar
Alan Zimmerman committed
516 517 518 519 520 521 522
--
-- - 'ApiAnnotation.AnnKeywordId' :
--      'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
--                              @'\{-\# OVERLAPPING'@ or
--                              @'\{-\# OVERLAPS'@ or
--                              @'\{-\# INCOHERENT'@,
--      'ApiAnnotation.AnnClose' @`\#-\}`@,
523 524

-- For details on above see note [Api annotations] in ApiAnnotation
525 526 527
data OverlapFlag = OverlapFlag
  { overlapMode   :: OverlapMode
  , isSafeOverlap :: Bool
528
  } deriving (Eq, Data)
529 530 531 532 533

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

534 535 536 537 538 539
hasIncoherentFlag :: OverlapMode -> Bool
hasIncoherentFlag mode =
  case mode of
    Incoherent   _ -> True
    _              -> False

540 541 542
hasOverlappableFlag :: OverlapMode -> Bool
hasOverlappableFlag mode =
  case mode of
Alan Zimmerman's avatar
Alan Zimmerman committed
543 544 545 546
    Overlappable _ -> True
    Overlaps     _ -> True
    Incoherent   _ -> True
    _              -> False
547 548 549 550

hasOverlappingFlag :: OverlapMode -> Bool
hasOverlappingFlag mode =
  case mode of
Alan Zimmerman's avatar
Alan Zimmerman committed
551 552 553 554
    Overlapping  _ -> True
    Overlaps     _ -> True
    Incoherent   _ -> True
    _              -> False
555

556
data OverlapMode  -- See Note [Rules for instance lookup] in InstEnv
Alan Zimmerman's avatar
Alan Zimmerman committed
557 558
  = NoOverlap SourceText
                  -- See Note [Pragma source text]
559 560 561
    -- ^ This instance must not overlap another `NoOverlap` instance.
    -- However, it may be overlapped by `Overlapping` instances,
    -- and it may overlap `Overlappable` instances.
562

563

Alan Zimmerman's avatar
Alan Zimmerman committed
564 565
  | Overlappable SourceText
                  -- See Note [Pragma source text]
566 567 568 569 570 571 572 573 574 575 576
    -- ^ 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)
577 578


Alan Zimmerman's avatar
Alan Zimmerman committed
579 580
  | Overlapping SourceText
                  -- See Note [Pragma source text]
581 582 583 584 585 586 587 588 589 590
    -- ^ 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)
591 592


Alan Zimmerman's avatar
Alan Zimmerman committed
593 594
  | Overlaps SourceText
                  -- See Note [Pragma source text]
Gabor Greif's avatar
Gabor Greif committed
595
    -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
596

Alan Zimmerman's avatar
Alan Zimmerman committed
597 598
  | Incoherent SourceText
                  -- See Note [Pragma source text]
599 600 601 602 603 604 605 606 607 608 609
    -- ^ Behave like Overlappable and Overlapping, and in addition pick
    -- an 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 InstEnv

610
  deriving (Eq, Data)
611

612

613
instance Outputable OverlapFlag where
614 615 616
   ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)

instance Outputable OverlapMode where
Alan Zimmerman's avatar
Alan Zimmerman committed
617
   ppr (NoOverlap    _) = empty
618 619 620 621
   ppr (Overlappable _) = text "[overlappable]"
   ppr (Overlapping  _) = text "[overlapping]"
   ppr (Overlaps     _) = text "[overlap ok]"
   ppr (Incoherent   _) = text "[incoherent]"
622

623
pprSafeOverlap :: Bool -> SDoc
624
pprSafeOverlap True  = text "[safe]"
625
pprSafeOverlap False = empty
626

Austin Seipp's avatar
Austin Seipp committed
627 628 629
{-
************************************************************************
*                                                                      *
630
                Tuples
Austin Seipp's avatar
Austin Seipp committed
631 632 633
*                                                                      *
************************************************************************
-}
634

batterseapower's avatar
batterseapower committed
635 636 637
data TupleSort
  = BoxedTuple
  | UnboxedTuple
638
  | ConstraintTuple
639
  deriving( Eq, Data )
batterseapower's avatar
batterseapower committed
640 641

tupleSortBoxity :: TupleSort -> Boxity
642 643
tupleSortBoxity BoxedTuple      = Boxed
tupleSortBoxity UnboxedTuple    = Unboxed
644
tupleSortBoxity ConstraintTuple = Boxed
batterseapower's avatar
batterseapower committed
645

646 647 648
boxityTupleSort :: Boxity -> TupleSort
boxityTupleSort Boxed   = BoxedTuple
boxityTupleSort Unboxed = UnboxedTuple
batterseapower's avatar
batterseapower committed
649 650

tupleParens :: TupleSort -> SDoc -> SDoc
651
tupleParens BoxedTuple      p = parens p
652
tupleParens UnboxedTuple    p = text "(#" <+> p <+> ptext (sLit "#)")
653
tupleParens ConstraintTuple p   -- In debug-style write (% Eq a, Ord b %)
654
  | opt_PprStyle_Debug        = text "(%" <+> p <+> ptext (sLit "%)")
655
  | otherwise                 = parens p
656

657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677
{-
************************************************************************
*                                                                      *
                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 - 1) vbar)

Austin Seipp's avatar
Austin Seipp committed
678 679 680
{-
************************************************************************
*                                                                      *
681
\subsection[Generic]{Generic flag}
Austin Seipp's avatar
Austin Seipp committed
682 683
*                                                                      *
************************************************************************
684

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

690 691
        from :: T -> Tring
        to   :: Tring -> T
692

693
And we should have
694

695
        to (from x) = x
696 697

T and Tring are arbitrary, but typically T is the 'main' type while
698
Tring is the 'representation' type.  (This just helps us remember
699
whether to use 'from' or 'to'.
Austin Seipp's avatar
Austin Seipp committed
700
-}
701

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

Austin Seipp's avatar
Austin Seipp committed
706
{-
707 708 709 710 711
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.

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

716

Austin Seipp's avatar
Austin Seipp committed
717 718
************************************************************************
*                                                                      *
719
\subsection{Occurrence information}
Austin Seipp's avatar
Austin Seipp committed
720 721
*                                                                      *
************************************************************************
722 723 724 725 726

This data type is used exclusively by the simplifier, but it appears in a
SubstResult, which is currently defined in VarEnv, 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
Austin Seipp's avatar
Austin Seipp committed
727
-}
728

729
-- | identifier Occurrence Information
730
data OccInfo
Gabor Greif's avatar
Gabor Greif committed
731
  = NoOccInfo           -- ^ There are many occurrences, or unknown occurrences
732

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

batterseapower's avatar
batterseapower committed
736
  | OneOcc
737 738 739
        !InsideLam
        !OneBranch
        !InterestingCxt -- ^ Occurs exactly once, not inside a rule
740

batterseapower's avatar
batterseapower committed
741 742
  -- | 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
743 744
  | IAmALoopBreaker     -- Note [LoopBreaker OccInfo]
        !RulesOnly
745

Peter Wortmann's avatar
Peter Wortmann committed
746 747
  deriving (Eq)

748
type RulesOnly = Bool
749

Austin Seipp's avatar
Austin Seipp committed
750
{-
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
751 752
Note [LoopBreaker OccInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~
753
   IAmALoopBreaker True  <=> A "weak" or rules-only loop breaker
754
                             Do not preInlineUnconditionally
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
755

756 757 758 759
   IAmALoopBreaker False <=> A "strong" loop breaker
                             Do not inline at all

See OccurAnal Note [Weak loop breakers]
Austin Seipp's avatar
Austin Seipp committed
760
-}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
761

762 763
isNoOcc :: OccInfo -> Bool
isNoOcc NoOccInfo = True
764
isNoOcc _         = False
765

766
seqOccInfo :: OccInfo -> ()
767 768 769
seqOccInfo occ = occ `seq` ()

-----------------
770
-- | Interesting Context
771 772 773
type InterestingCxt = Bool      -- True <=> Function: is applied
                                --          Data value: scrutinised by a case with
                                --                      at least one non-DEFAULT branch
774

775
-----------------
776
-- | Inside Lambda
777 778 779
type InsideLam = Bool   -- True <=> Occurs inside a non-linear lambda
                        -- Substituting a redex for this occurrence is
                        -- dangerous because it might duplicate work.
780
insideLam, notInsideLam :: InsideLam
781 782 783
insideLam    = True
notInsideLam = False

784
-----------------
785 786
type OneBranch = Bool   -- True <=> Occurs in only one case branch
                        --      so no code-duplication issue to worry about
787
oneBranch, notOneBranch :: OneBranch
788 789 790
oneBranch    = True
notOneBranch = False

791 792 793
strongLoopBreaker, weakLoopBreaker :: OccInfo
strongLoopBreaker = IAmALoopBreaker False
weakLoopBreaker   = IAmALoopBreaker True
794

795 796 797
isWeakLoopBreaker :: OccInfo -> Bool
isWeakLoopBreaker (IAmALoopBreaker _) = True
isWeakLoopBreaker _                   = False
798

799 800 801
isStrongLoopBreaker :: OccInfo -> Bool
isStrongLoopBreaker (IAmALoopBreaker False) = True   -- Loop-breaker that breaks a non-rule cycle
isStrongLoopBreaker _                       = False
802

803 804
isDeadOcc :: OccInfo -> Bool
isDeadOcc IAmDead = True
805
isDeadOcc _       = False
806

807
isOneOcc :: OccInfo -> Bool
808 809
isOneOcc (OneOcc {}) = True
isOneOcc _           = False
810

811 812 813
zapFragileOcc :: OccInfo -> OccInfo
zapFragileOcc (OneOcc {}) = NoOccInfo
zapFragileOcc occ         = occ
814 815 816

instance Outputable OccInfo where
  -- only used for debugging; never parsed.  KSW 1999-07
817
  ppr NoOccInfo            = empty
818 819
  ppr (IAmALoopBreaker ro) = text "LoopBreaker" <> if ro then char '!' else empty
  ppr IAmDead              = text "Dead"
820
  ppr (OneOcc inside_lam one_branch int_cxt)
821
        = text "Once" <> pp_lam <> pp_br <> pp_args
822 823 824 825 826 827 828
        where
          pp_lam | inside_lam = char 'L'
                 | otherwise  = empty
          pp_br  | one_branch = empty
                 | otherwise  = char '*'
          pp_args | int_cxt   = char '!'
                  | otherwise = empty
829

Austin Seipp's avatar
Austin Seipp committed
830 831 832
{-
************************************************************************
*                                                                      *
833
                Default method specfication
Austin Seipp's avatar
Austin Seipp committed
834 835
*                                                                      *
************************************************************************
836 837

The DefMethSpec enumeration just indicates what sort of default method
838
is used for a class. It is generated from source code, and present in
839
interface files; it is converted to Class.DefMethInfo before begin put in a
840
Class object.
Austin Seipp's avatar
Austin Seipp committed
841
-}
842

843
-- | Default Method Specification
844 845 846
data DefMethSpec ty
  = VanillaDM     -- Default method given with polymorphic code
  | GenericDM ty  -- Default method given with code of this type
847

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

Austin Seipp's avatar
Austin Seipp committed
852 853 854
{-
************************************************************************
*                                                                      *
855
\subsection{Success flag}
Austin Seipp's avatar
Austin Seipp committed
856 857 858
*                                                                      *
************************************************************************
-}
859 860 861

data SuccessFlag = Succeeded | Failed

Ian Lynagh's avatar
Ian Lynagh committed
862
instance Outputable SuccessFlag where
863 864
    ppr Succeeded = text "Succeeded"
    ppr Failed    = text "Failed"
Ian Lynagh's avatar
Ian Lynagh committed
865

866 867 868 869 870 871 872 873 874 875 876
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

Alan Zimmerman's avatar
Alan Zimmerman committed
877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911
{-
************************************************************************
*                                                                      *
\subsection{Source Text}
*                                                                      *
************************************************************************
Keeping Source Text for source to source conversions

Note [Pragma source text]
~~~~~~~~~~~~~~~~~~~~~~~~~
The lexer does a case-insensitive match for pragmas, as well as
accepting both UK and US spelling variants.

So

  {-# SPECIALISE #-}
  {-# SPECIALIZE #-}
  {-# Specialize #-}

will all generate ITspec_prag token for the start of the pragma.

In order to be able to do source to source conversions, the original
source text for the token needs to be preserved, hence the
`SourceText` field.

So the lexer will then generate

  ITspec_prag "{ -# SPECIALISE"
  ITspec_prag "{ -# SPECIALIZE"
  ITspec_prag "{ -# Specialize"

for the cases above.
 [without the space between '{' and '-', otherwise this comment won't parse]


Alan Zimmerman's avatar