BasicTypes.hs 47.6 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

Ben Gamari's avatar
Ben Gamari committed
22 23 24
        LeftOrRight(..),
        pickLR,

25
        ConTag, ConTagZ, fIRST_TAG,
26

27 28 29
        Arity, RepArity,

        Alignment,
30

31
        FunctionOrData(..),
32

Alan Zimmerman's avatar
Alan Zimmerman committed
33
        WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),
34 35 36 37 38

        Fixity(..), FixityDirection(..),
        defaultFixity, maxPrecedence, minPrecedence,
        negateFixity, funTyFixity,
        compareFixity,
39
        LexicalFixity(..),
40

41
        RecFlag(..), isRec, isNonRec, boolToRecFlag,
cactus's avatar
cactus committed
42
        Origin(..), isGenerated,
43

44
        RuleName, pprRuleName,
45

46
        TopLevelFlag(..), isTopLevel, isNotTopLevel,
47

Ryan Scott's avatar
Ryan Scott committed
48 49
        DerivStrategy(..),

50
        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
51
        hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
52

53
        Boxity(..), isBoxed,
54

Ben Gamari's avatar
Ben Gamari committed
55 56
        TyPrec(..), maybeParen,

57
        TupleSort(..), tupleSortBoxity, boxityTupleSort,
batterseapower's avatar
batterseapower committed
58
        tupleParens,
59

60 61
        sumParens, pprAlternative,

62 63 64 65 66
        -- ** The OneShotInfo type
        OneShotInfo(..),
        noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
        bestOneShot, worstOneShot,

67 68 69
        OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc,
        strongLoopBreaker, weakLoopBreaker,
70

71 72 73
        InsideLam, insideLam, notInsideLam,
        OneBranch, oneBranch, notOneBranch,
        InterestingCxt,
74

75 76
        EP(..),

77
        DefMethSpec(..),
78
        SwapFlag(..), flipSwap, unSwap, isSwapped,
79

80
        CompilerPhase(..), PhaseNum,
81 82

        Activation(..), isActive, isActiveIn, competesWith,
83
        isNeverActive, isAlwaysActive, isEarlyActive,
84

85
        RuleMatchInfo(..), isConLike, isFunLike,
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
86
        InlineSpec(..), isEmptyInlineSpec,
87 88 89
        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
        neverInlinePragma, dfunInlinePragma,
        isDefaultInlinePragma,
90
        isInlinePragma, isInlinablePragma, isAnyInlinePragma,
91
        inlinePragmaSpec, inlinePragmaSat,
92 93
        inlinePragmaActivation, inlinePragmaRuleMatchInfo,
        setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
Alan Zimmerman's avatar
Alan Zimmerman committed
94
        pprInline, pprInlineDebug,
95

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

98 99
        FractionalLit(..), negateFractionalLit, integralFractionalLit,

Alan Zimmerman's avatar
Alan Zimmerman committed
100
        SourceText(..), pprWithSourceText,
101

Alan Zimmerman's avatar
Alan Zimmerman committed
102 103 104
        IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,

        SpliceExplicitFlag(..)
sof's avatar
sof committed
105 106
   ) where

107
import FastString
sof's avatar
sof committed
108
import Outputable
109
import SrcLoc ( Located,unLoc )
110
import StaticFlags( opt_PprStyle_Debug )
111
import Data.Data hiding (Fixity, Prefix, Infix)
112
import Data.Function (on)
113

Ben Gamari's avatar
Ben Gamari committed
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
{-
************************************************************************
*                                                                      *
          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"

Austin Seipp's avatar
Austin Seipp committed
133 134 135
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
136
\subsection[Arity]{Arity}
Austin Seipp's avatar
Austin Seipp committed
137 138 139
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
140

141 142 143 144
-- | 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
145
-- See also Note [Definition of arity] in CoreArity
sof's avatar
sof committed
146
type Arity = Int
147

148 149 150
-- | Representation Arity
--
-- The number of represented arguments that can be applied to a value before it does
151 152 153 154 155
-- "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
156

Austin Seipp's avatar
Austin Seipp committed
157 158 159
{-
************************************************************************
*                                                                      *
160
              Constructor tags
Austin Seipp's avatar
Austin Seipp committed
161 162 163
*                                                                      *
************************************************************************
-}
164

165 166 167 168
-- | Constructor Tag
--
-- Type of the tags associated with each constructor possibility or superclass
-- selector
169 170
type ConTag = Int

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

174 175
fIRST_TAG :: ConTag
-- ^ Tags are allocated from here for real constructors
176
--   or for superclass selectors
177 178
fIRST_TAG =  1

Austin Seipp's avatar
Austin Seipp committed
179 180 181
{-
************************************************************************
*                                                                      *
182
\subsection[Alignment]{Alignment}
Austin Seipp's avatar
Austin Seipp committed
183 184 185
*                                                                      *
************************************************************************
-}
186 187 188

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

Austin Seipp's avatar
Austin Seipp committed
189 190 191
{-
************************************************************************
*                                                                      *
192
         One-shot information
Austin Seipp's avatar
Austin Seipp committed
193 194 195
*                                                                      *
************************************************************************
-}
196 197 198 199 200 201 202 203

-- | 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.
204 205 206
data OneShotInfo
  = NoOneShotInfo -- ^ No information
  | ProbOneShot   -- ^ The lambda is probably applied at most once
207
                  -- See Note [Computing one-shot info, and ProbOneShot] in Demand
208
  | OneShotLam    -- ^ The lambda is applied at most once.
Peter Wortmann's avatar
Peter Wortmann committed
209
  deriving (Eq)
210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234

-- | 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
235 236
pprOneShotInfo ProbOneShot   = text "ProbOneShot"
pprOneShotInfo OneShotLam    = text "OneShot"
237 238 239 240

instance Outputable OneShotInfo where
    ppr = pprOneShotInfo

Austin Seipp's avatar
Austin Seipp committed
241 242 243
{-
************************************************************************
*                                                                      *
244
           Swap flag
Austin Seipp's avatar
Austin Seipp committed
245 246 247
*                                                                      *
************************************************************************
-}
248

249 250
data SwapFlag
  = NotSwapped  -- Args are: actual,   expected
251 252 253
  | IsSwapped   -- Args are: expected, actual

instance Outputable SwapFlag where
254 255
  ppr IsSwapped  = text "Is-swapped"
  ppr NotSwapped = text "Not-swapped"
256 257 258 259 260

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

261 262 263 264
isSwapped :: SwapFlag -> Bool
isSwapped IsSwapped  = True
isSwapped NotSwapped = False

265 266 267 268
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
269 270 271
{-
************************************************************************
*                                                                      *
272
\subsection[FunctionOrData]{FunctionOrData}
Austin Seipp's avatar
Austin Seipp committed
273 274 275
*                                                                      *
************************************************************************
-}
276 277

data FunctionOrData = IsFunction | IsData
278
    deriving (Eq, Ord, Data)
279 280 281 282

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

Austin Seipp's avatar
Austin Seipp committed
284 285 286
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
287
\subsection[Version]{Module and identifier version numbers}
Austin Seipp's avatar
Austin Seipp committed
288 289 290
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
291 292

type Version = Int
293

294
bumpVersion :: Version -> Version
295
bumpVersion v = v+1
296 297 298

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

Austin Seipp's avatar
Austin Seipp committed
300 301 302
{-
************************************************************************
*                                                                      *
303
                Deprecations
Austin Seipp's avatar
Austin Seipp committed
304 305 306
*                                                                      *
************************************************************************
-}
307

308
-- | A String Literal in the source, including its original raw format for use by
309 310 311 312 313
-- 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
314
                       } deriving Data
315 316 317 318

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

Alan Zimmerman's avatar
Alan Zimmerman committed
319 320 321
instance Outputable StringLiteral where
  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)

322 323
-- | Warning Text
--
Ian Lynagh's avatar
Ian Lynagh committed
324
-- reason/explanation from a WARNING or DEPRECATED pragma
325
data WarningTxt = WarningTxt (Located SourceText)
326
                             [Located StringLiteral]
327
                | DeprecatedTxt (Located SourceText)
328
                                [Located StringLiteral]
329
    deriving (Eq, Data)
Ian Lynagh's avatar
Ian Lynagh committed
330 331

instance Outputable WarningTxt where
Alan Zimmerman's avatar
Alan Zimmerman committed
332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355
    ppr (WarningTxt    lsrc ws)
      = case unLoc lsrc of
          NoSourceText   -> pp_ws ws
          SourceText src -> text src <+> pp_ws ws <+> text "#-}"

    ppr (DeprecatedTxt lsrc  ds)
      = case unLoc lsrc of
          NoSourceText   -> pp_ws ds
          SourceText src -> text src <+> pp_ws ds <+> text "#-}"

pp_ws :: [Located StringLiteral] -> SDoc
pp_ws [l] = ppr $ unLoc l
pp_ws ws
  = text "["
    <+> vcat (punctuate comma (map (ppr . unLoc) ws))
    <+> text "]"


pprWarningTxtForMsg :: WarningTxt -> SDoc
pprWarningTxtForMsg (WarningTxt    _ ws)
                     = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
pprWarningTxtForMsg (DeprecatedTxt _ ds)
                     = text "Deprecated:" <+>
                       doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
sof's avatar
sof committed
356

Austin Seipp's avatar
Austin Seipp committed
357 358 359
{-
************************************************************************
*                                                                      *
360
                Rules
Austin Seipp's avatar
Austin Seipp committed
361 362 363
*                                                                      *
************************************************************************
-}
364 365

type RuleName = FastString
366

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

Austin Seipp's avatar
Austin Seipp committed
370 371 372
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
373
\subsection[Fixity]{Fixity info}
Austin Seipp's avatar
Austin Seipp committed
374 375 376
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
377

378
------------------------
379 380
data Fixity = Fixity SourceText Int FixityDirection
  -- Note [Pragma source text]
381
  deriving Data
sof's avatar
sof committed
382 383

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

386
instance Eq Fixity where -- Used to determine if two fixities conflict
387
  (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2
388 389

------------------------
390
data FixityDirection = InfixL | InfixR | InfixN
391
                     deriving (Eq, Data)
392

sof's avatar
sof committed
393
instance Outputable FixityDirection where
394 395 396
    ppr InfixL = text "infixl"
    ppr InfixR = text "infixr"
    ppr InfixN = text "infix"
sof's avatar
sof committed
397

398
------------------------
399
maxPrecedence, minPrecedence :: Int
400
maxPrecedence = 9
401 402
minPrecedence = 0

403
defaultFixity :: Fixity
Alan Zimmerman's avatar
Alan Zimmerman committed
404
defaultFixity = Fixity NoSourceText maxPrecedence InfixL
405

406 407
negateFixity, funTyFixity :: Fixity
-- Wired-in fixities
Alan Zimmerman's avatar
Alan Zimmerman committed
408 409
negateFixity = Fixity NoSourceText 6 InfixL  -- Fixity of unary negate
funTyFixity  = Fixity NoSourceText 0 InfixR  -- Fixity of '->'
sof's avatar
sof committed
410

Austin Seipp's avatar
Austin Seipp committed
411
{-
412 413 414
Consider

\begin{verbatim}
415
        a `op1` b `op2` c
416
\end{verbatim}
417
@(compareFixity op1 op2)@ tells which way to arrange application, or
418
whether there's an error.
Austin Seipp's avatar
Austin Seipp committed
419
-}
420 421

compareFixity :: Fixity -> Fixity
422 423
              -> (Bool,         -- Error please
                  Bool)         -- Associate to the right: a op1 (b op2 c)
424
compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)
425
  = case prec1 `compare` prec2 of
426 427 428 429 430 431
        GT -> left
        LT -> right
        EQ -> case (dir1, dir2) of
                        (InfixR, InfixR) -> right
                        (InfixL, InfixL) -> left
                        _                -> error_please
432
  where
433
    right        = (False, True)
434 435
    left         = (False, False)
    error_please = (True,  False)
sof's avatar
sof committed
436

437 438 439 440 441 442 443 444 445
-- |Captures the fixity of declarations as they are parsed. This is not
-- necessarily the same as the fixity declaration, as the normal fixity may be
-- overridden using parens or backticks.
data LexicalFixity = Prefix | Infix deriving (Typeable,Data,Eq)

instance Outputable LexicalFixity where
  ppr Prefix = text "Prefix"
  ppr Infix  = text "Infix"

Austin Seipp's avatar
Austin Seipp committed
446 447 448
{-
************************************************************************
*                                                                      *
449
\subsection[Top-level/local]{Top-level/not-top level flag}
Austin Seipp's avatar
Austin Seipp committed
450 451 452
*                                                                      *
************************************************************************
-}
453 454 455 456

data TopLevelFlag
  = TopLevel
  | NotTopLevel
457 458 459 460 461 462

isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool

isNotTopLevel NotTopLevel = True
isNotTopLevel TopLevel    = False

463
isTopLevel TopLevel     = True
464
isTopLevel NotTopLevel  = False
465 466

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

Austin Seipp's avatar
Austin Seipp committed
470 471 472
{-
************************************************************************
*                                                                      *
473
                Boxity flag
Austin Seipp's avatar
Austin Seipp committed
474 475 476
*                                                                      *
************************************************************************
-}
477 478 479 480

data Boxity
  = Boxed
  | Unboxed
481
  deriving( Eq, Data )
482 483 484 485 486

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

487 488 489 490
instance Outputable Boxity where
  ppr Boxed   = text "Boxed"
  ppr Unboxed = text "Unboxed"

Austin Seipp's avatar
Austin Seipp committed
491 492 493
{-
************************************************************************
*                                                                      *
494
                Recursive/Non-Recursive flag
Austin Seipp's avatar
Austin Seipp committed
495 496 497
*                                                                      *
************************************************************************
-}
498

499
-- | Recursivity Flag
500 501
data RecFlag = Recursive
             | NonRecursive
502
             deriving( Eq, Data )
sof's avatar
sof committed
503

504 505 506
isRec :: RecFlag -> Bool
isRec Recursive    = True
isRec NonRecursive = False
sof's avatar
sof committed
507

508 509 510
isNonRec :: RecFlag -> Bool
isNonRec Recursive    = False
isNonRec NonRecursive = True
511 512 513 514 515 516

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

instance Outputable RecFlag where
517 518
  ppr Recursive    = text "Recursive"
  ppr NonRecursive = text "NonRecursive"
519

Austin Seipp's avatar
Austin Seipp committed
520 521 522
{-
************************************************************************
*                                                                      *
cactus's avatar
cactus committed
523
                Code origin
Austin Seipp's avatar
Austin Seipp committed
524 525 526 527
*                                                                      *
************************************************************************
-}

cactus's avatar
cactus committed
528 529
data Origin = FromSource
            | Generated
530
            deriving( Eq, Data )
cactus's avatar
cactus committed
531 532 533 534 535 536

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

instance Outputable Origin where
537 538
  ppr FromSource  = text "FromSource"
  ppr Generated   = text "Generated"
cactus's avatar
cactus committed
539

Ryan Scott's avatar
Ryan Scott committed
540 541 542 543 544 545 546 547 548 549 550
{-
************************************************************************
*                                                                      *
                Deriving strategies
*                                                                      *
************************************************************************
-}

-- | Which technique the user explicitly requested when deriving an instance.
data DerivStrategy
  -- See Note [Deriving strategies] in TcDeriv
551 552 553 554 555 556 557
  = StockStrategy    -- ^ 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.)
  | AnyclassStrategy -- ^ @-XDeriveAnyClass@
  | NewtypeStrategy  -- ^ @-XGeneralizedNewtypeDeriving@
Ryan Scott's avatar
Ryan Scott committed
558 559 560
  deriving (Eq, Data)

instance Outputable DerivStrategy where
561 562 563
    ppr StockStrategy    = text "stock"
    ppr AnyclassStrategy = text "anyclass"
    ppr NewtypeStrategy  = text "newtype"
Ryan Scott's avatar
Ryan Scott committed
564

Austin Seipp's avatar
Austin Seipp committed
565 566 567
{-
************************************************************************
*                                                                      *
568
                Instance overlap flag
Austin Seipp's avatar
Austin Seipp committed
569 570 571
*                                                                      *
************************************************************************
-}
572

dterei's avatar
dterei committed
573
-- | The semantics allowed for overlapping instances for a particular
574
-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a
dterei's avatar
dterei committed
575
-- explanation of the `isSafeOverlap` field.
Alan Zimmerman's avatar
Alan Zimmerman committed
576 577 578 579 580 581 582
--
-- - 'ApiAnnotation.AnnKeywordId' :
--      'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
--                              @'\{-\# OVERLAPPING'@ or
--                              @'\{-\# OVERLAPS'@ or
--                              @'\{-\# INCOHERENT'@,
--      'ApiAnnotation.AnnClose' @`\#-\}`@,
583 584

-- For details on above see note [Api annotations] in ApiAnnotation
585 586 587
data OverlapFlag = OverlapFlag
  { overlapMode   :: OverlapMode
  , isSafeOverlap :: Bool
588
  } deriving (Eq, Data)
589 590 591 592 593

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

594 595 596 597 598 599
hasIncoherentFlag :: OverlapMode -> Bool
hasIncoherentFlag mode =
  case mode of
    Incoherent   _ -> True
    _              -> False

600 601 602
hasOverlappableFlag :: OverlapMode -> Bool
hasOverlappableFlag mode =
  case mode of
Alan Zimmerman's avatar
Alan Zimmerman committed
603 604 605 606
    Overlappable _ -> True
    Overlaps     _ -> True
    Incoherent   _ -> True
    _              -> False
607 608 609 610

hasOverlappingFlag :: OverlapMode -> Bool
hasOverlappingFlag mode =
  case mode of
Alan Zimmerman's avatar
Alan Zimmerman committed
611 612 613 614
    Overlapping  _ -> True
    Overlaps     _ -> True
    Incoherent   _ -> True
    _              -> False
615

616
data OverlapMode  -- See Note [Rules for instance lookup] in InstEnv
Alan Zimmerman's avatar
Alan Zimmerman committed
617 618
  = NoOverlap SourceText
                  -- See Note [Pragma source text]
619 620 621
    -- ^ This instance must not overlap another `NoOverlap` instance.
    -- However, it may be overlapped by `Overlapping` instances,
    -- and it may overlap `Overlappable` instances.
622

623

Alan Zimmerman's avatar
Alan Zimmerman committed
624 625
  | Overlappable SourceText
                  -- See Note [Pragma source text]
626 627 628 629 630 631 632 633 634 635 636
    -- ^ 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)
637 638


Alan Zimmerman's avatar
Alan Zimmerman committed
639 640
  | Overlapping SourceText
                  -- See Note [Pragma source text]
641 642 643 644 645 646 647 648 649 650
    -- ^ 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)
651 652


Alan Zimmerman's avatar
Alan Zimmerman committed
653 654
  | Overlaps SourceText
                  -- See Note [Pragma source text]
Gabor Greif's avatar
Gabor Greif committed
655
    -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
656

Alan Zimmerman's avatar
Alan Zimmerman committed
657 658
  | Incoherent SourceText
                  -- See Note [Pragma source text]
659 660 661 662 663 664 665 666 667 668 669
    -- ^ 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

670
  deriving (Eq, Data)
671

672

673
instance Outputable OverlapFlag where
674 675 676
   ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)

instance Outputable OverlapMode where
Alan Zimmerman's avatar
Alan Zimmerman committed
677
   ppr (NoOverlap    _) = empty
678 679 680 681
   ppr (Overlappable _) = text "[overlappable]"
   ppr (Overlapping  _) = text "[overlapping]"
   ppr (Overlaps     _) = text "[overlap ok]"
   ppr (Incoherent   _) = text "[incoherent]"
682

683
pprSafeOverlap :: Bool -> SDoc
684
pprSafeOverlap True  = text "[safe]"
685
pprSafeOverlap False = empty
686

Ben Gamari's avatar
Ben Gamari committed
687 688 689 690 691 692 693 694
{-
************************************************************************
*                                                                      *
                Type precedence
*                                                                      *
************************************************************************
-}

695
data TyPrec   -- See Note [Precedence in types] in TyCoRep.hs
Ben Gamari's avatar
Ben Gamari committed
696 697 698 699 700 701 702 703 704 705 706
  = TopPrec         -- No parens
  | FunPrec         -- Function args; no parens for tycon apps
  | TyOpPrec        -- Infix operator
  | TyConPrec       -- Tycon args; no parens for atomic
  deriving( Eq, Ord )

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

Austin Seipp's avatar
Austin Seipp committed
707 708 709
{-
************************************************************************
*                                                                      *
710
                Tuples
Austin Seipp's avatar
Austin Seipp committed
711 712 713
*                                                                      *
************************************************************************
-}
714

batterseapower's avatar
batterseapower committed
715 716 717
data TupleSort
  = BoxedTuple
  | UnboxedTuple
718
  | ConstraintTuple
719
  deriving( Eq, Data )
batterseapower's avatar
batterseapower committed
720 721

tupleSortBoxity :: TupleSort -> Boxity
722 723
tupleSortBoxity BoxedTuple      = Boxed
tupleSortBoxity UnboxedTuple    = Unboxed
724
tupleSortBoxity ConstraintTuple = Boxed
batterseapower's avatar
batterseapower committed
725

726 727 728
boxityTupleSort :: Boxity -> TupleSort
boxityTupleSort Boxed   = BoxedTuple
boxityTupleSort Unboxed = UnboxedTuple
batterseapower's avatar
batterseapower committed
729 730

tupleParens :: TupleSort -> SDoc -> SDoc
731
tupleParens BoxedTuple      p = parens p
732
tupleParens UnboxedTuple    p = text "(#" <+> p <+> ptext (sLit "#)")
733
tupleParens ConstraintTuple p   -- In debug-style write (% Eq a, Ord b %)
734
  | opt_PprStyle_Debug        = text "(%" <+> p <+> ptext (sLit "%)")
735
  | otherwise                 = parens p
736

737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755
{-
************************************************************************
*                                                                      *
                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 =
Richard Eisenberg's avatar
Richard Eisenberg committed
756
    fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)
757

Austin Seipp's avatar
Austin Seipp committed
758 759 760
{-
************************************************************************
*                                                                      *
761
\subsection[Generic]{Generic flag}
Austin Seipp's avatar
Austin Seipp committed
762 763
*                                                                      *
************************************************************************
764

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

770 771
        from :: T -> Tring
        to   :: Tring -> T
772

773
And we should have
774

775
        to (from x) = x
776 777

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

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

Austin Seipp's avatar
Austin Seipp committed
786
{-
787 788 789 790 791
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.

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

796

Austin Seipp's avatar
Austin Seipp committed
797 798
************************************************************************
*                                                                      *
799
\subsection{Occurrence information}
Austin Seipp's avatar
Austin Seipp committed
800 801
*                                                                      *
************************************************************************
802 803 804 805 806

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
807
-}
808

809
-- | identifier Occurrence Information
810
data OccInfo
Gabor Greif's avatar
Gabor Greif committed
811
  = NoOccInfo           -- ^ There are many occurrences, or unknown occurrences
812

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

batterseapower's avatar
batterseapower committed
816
  | OneOcc
817 818 819
        !InsideLam
        !OneBranch
        !InterestingCxt -- ^ Occurs exactly once, not inside a rule
820

batterseapower's avatar
batterseapower committed
821 822
  -- | 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
823 824
  | IAmALoopBreaker     -- Note [LoopBreaker OccInfo]
        !RulesOnly
825

Peter Wortmann's avatar
Peter Wortmann committed
826 827
  deriving (Eq)

828
type RulesOnly = Bool
829

Austin Seipp's avatar
Austin Seipp committed
830
{-
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
831 832
Note [LoopBreaker OccInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~
833
   IAmALoopBreaker True  <=> A "weak" or rules-only loop breaker
834
                             Do not preInlineUnconditionally
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
835

836 837 838 839
   IAmALoopBreaker False <=> A "strong" loop breaker
                             Do not inline at all

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

842 843
isNoOcc :: OccInfo -> Bool
isNoOcc NoOccInfo = True
844
isNoOcc _         = False
845

846
seqOccInfo :: OccInfo -> ()
847 848 849
seqOccInfo occ = occ `seq` ()

-----------------
850
-- | Interesting Context
851 852 853
type InterestingCxt = Bool      -- True <=> Function: is applied
                                --          Data value: scrutinised by a case with
                                --                      at least one non-DEFAULT branch
854

855
-----------------
856
-- | Inside Lambda
857 858 859
type InsideLam = Bool   -- True <=> Occurs inside a non-linear lambda
                        -- Substituting a redex for this occurrence is
                        -- dangerous because it might duplicate work.
860
insideLam, notInsideLam :: InsideLam
861 862 863
insideLam    = True
notInsideLam = False

864
-----------------
865 866
type OneBranch = Bool   -- True <=> Occurs in only one case branch
                        --      so no code-duplication issue to worry about
867
oneBranch, notOneBranch :: OneBranch
868 869 870
oneBranch    = True
notOneBranch = False

871 872 873
strongLoopBreaker, weakLoopBreaker :: OccInfo
strongLoopBreaker = IAmALoopBreaker False
weakLoopBreaker   = IAmALoopBreaker True
874

875 876 877
isWeakLoopBreaker :: OccInfo -> Bool
isWeakLoopBreaker (IAmALoopBreaker _) = True
isWeakLoopBreaker _                   = False
878

879 880 881
isStrongLoopBreaker :: OccInfo -> Bool
isStrongLoopBreaker (IAmALoopBreaker False) = True   -- Loop-breaker that breaks a non-rule cycle
isStrongLoopBreaker _                       = False
882

883 884
isDeadOcc :: OccInfo -> Bool
isDeadOcc IAmDead = True
885
isDeadOcc _       = False
886

887
isOneOcc :: OccInfo -> Bool
888 889
isOneOcc (OneOcc {}) = True
isOneOcc _           = False
890

891 892 893
zapFragileOcc :: OccInfo -> OccInfo
zapFragileOcc (OneOcc {}) = NoOccInfo
zapFragileOcc occ         = occ
894 895 896

instance Outputable OccInfo where
  -- only used for debugging; never parsed.  KSW 1999-07
897
  ppr NoOccInfo            = empty
898 899
  ppr (IAmALoopBreaker ro) = text "LoopBreaker" <> if ro then char '!' else empty
  ppr IAmDead              = text "Dead"
900
  ppr (OneOcc inside_lam one_branch int_cxt)
901
        = text "Once" <> pp_lam <> pp_br <> pp_args
902 903 904 905 906 907 908
        where
          pp_lam | inside_lam = char 'L'
                 | otherwise  = empty
          pp_br  | one_branch = empty
                 | otherwise  = char '*'
          pp_args | int_cxt   = char '!'
                  | otherwise = empty
909

Austin Seipp's avatar
Austin Seipp committed
910 911 912
{-
************************************************************************
*                                                                      *
913
                Default method specification
Austin Seipp's avatar
Austin Seipp committed
914 915
*                                                                      *
************************************************************************
916 917

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

923
-- | Default Method Specification
924 925 926
data DefMethSpec ty
  = VanillaDM     -- Default method given with polymorphic code
  | GenericDM ty  -- Default method given with code of this type
927

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

Austin Seipp's avatar
Austin Seipp committed
932 933 934
{-
************************************************************************
*                                                                      *
935
\subsection{Success flag}
Austin Seipp's avatar
Austin Seipp committed
936 937 938
*                                                                      *
************************************************************************
-}
939 940 941

data SuccessFlag = Succeeded | Failed

Ian Lynagh's avatar
Ian Lynagh committed
942
instance Outputable SuccessFlag where