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

lukemaurer's avatar
lukemaurer committed
27
        Arity, RepArity, JoinArity,
28 29

        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,

lukemaurer's avatar
lukemaurer committed
67 68
        OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,
        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,
69
        strongLoopBreaker, weakLoopBreaker,
70

71 72 73
        InsideLam, insideLam, notInsideLam,
        OneBranch, oneBranch, notOneBranch,
        InterestingCxt,
lukemaurer's avatar
lukemaurer committed
74 75
        TailCallInfo(..), tailCallInfo, zapOccTailCallInfo,
        isAlwaysTailCalled,
76

77 78
        EP(..),

79
        DefMethSpec(..),
80
        SwapFlag(..), flipSwap, unSwap, isSwapped,
81

82
        CompilerPhase(..), PhaseNum,
83 84

        Activation(..), isActive, isActiveIn, competesWith,
85
        isNeverActive, isAlwaysActive, isEarlyActive,
86

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

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

100 101 102 103
        IntegralLit(..), FractionalLit(..),
        negateIntegralLit, negateFractionalLit,
        mkIntegralLit, mkFractionalLit,
        integralFractionalLit,
104

Alan Zimmerman's avatar
Alan Zimmerman committed
105
        SourceText(..), pprWithSourceText,
106

Alan Zimmerman's avatar
Alan Zimmerman committed
107 108 109
        IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,

        SpliceExplicitFlag(..)
sof's avatar
sof committed
110 111
   ) where

112
import FastString
sof's avatar
sof committed
113
import Outputable
114
import SrcLoc ( Located,unLoc )
115
import Data.Data hiding (Fixity, Prefix, Infix)
116
import Data.Function (on)
117

Ben Gamari's avatar
Ben Gamari committed
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136
{-
************************************************************************
*                                                                      *
          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
137 138 139
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
140
\subsection[Arity]{Arity}
Austin Seipp's avatar
Austin Seipp committed
141 142 143
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
144

145 146 147 148
-- | 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
149
-- See also Note [Definition of arity] in CoreArity
sof's avatar
sof committed
150
type Arity = Int
151

152 153 154
-- | Representation Arity
--
-- The number of represented arguments that can be applied to a value before it does
155 156 157 158 159
-- "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
160

lukemaurer's avatar
lukemaurer committed
161 162 163 164 165 166
-- | 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

Austin Seipp's avatar
Austin Seipp committed
167 168 169
{-
************************************************************************
*                                                                      *
170
              Constructor tags
Austin Seipp's avatar
Austin Seipp committed
171 172 173
*                                                                      *
************************************************************************
-}
174

175 176 177 178
-- | Constructor Tag
--
-- Type of the tags associated with each constructor possibility or superclass
-- selector
179 180
type ConTag = Int

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

184 185
fIRST_TAG :: ConTag
-- ^ Tags are allocated from here for real constructors
186
--   or for superclass selectors
187 188
fIRST_TAG =  1

Austin Seipp's avatar
Austin Seipp committed
189 190 191
{-
************************************************************************
*                                                                      *
192
\subsection[Alignment]{Alignment}
Austin Seipp's avatar
Austin Seipp committed
193 194 195
*                                                                      *
************************************************************************
-}
196 197 198

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

Austin Seipp's avatar
Austin Seipp committed
199 200 201
{-
************************************************************************
*                                                                      *
202
         One-shot information
Austin Seipp's avatar
Austin Seipp committed
203 204 205
*                                                                      *
************************************************************************
-}
206 207 208 209 210 211 212 213

-- | 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.
214 215 216
data OneShotInfo
  = NoOneShotInfo -- ^ No information
  | OneShotLam    -- ^ The lambda is applied at most once.
Peter Wortmann's avatar
Peter Wortmann committed
217
  deriving (Eq)
218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238

-- | 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
239
pprOneShotInfo OneShotLam    = text "OneShot"
240 241 242 243

instance Outputable OneShotInfo where
    ppr = pprOneShotInfo

Austin Seipp's avatar
Austin Seipp committed
244 245 246
{-
************************************************************************
*                                                                      *
247
           Swap flag
Austin Seipp's avatar
Austin Seipp committed
248 249 250
*                                                                      *
************************************************************************
-}
251

252 253
data SwapFlag
  = NotSwapped  -- Args are: actual,   expected
254 255 256
  | IsSwapped   -- Args are: expected, actual

instance Outputable SwapFlag where
257 258
  ppr IsSwapped  = text "Is-swapped"
  ppr NotSwapped = text "Not-swapped"
259 260 261 262 263

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

264 265 266 267
isSwapped :: SwapFlag -> Bool
isSwapped IsSwapped  = True
isSwapped NotSwapped = False

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

data FunctionOrData = IsFunction | IsData
281
    deriving (Eq, Ord, Data)
282 283 284 285

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

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

type Version = Int
296

297
bumpVersion :: Version -> Version
298
bumpVersion v = v+1
299 300 301

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

Austin Seipp's avatar
Austin Seipp committed
303 304 305
{-
************************************************************************
*                                                                      *
306
                Deprecations
Austin Seipp's avatar
Austin Seipp committed
307 308 309
*                                                                      *
************************************************************************
-}
310

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

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

Alan Zimmerman's avatar
Alan Zimmerman committed
322 323 324
instance Outputable StringLiteral where
  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)

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

instance Outputable WarningTxt where
Alan Zimmerman's avatar
Alan Zimmerman committed
335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358
    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
359

Austin Seipp's avatar
Austin Seipp committed
360 361 362
{-
************************************************************************
*                                                                      *
363
                Rules
Austin Seipp's avatar
Austin Seipp committed
364 365 366
*                                                                      *
************************************************************************
-}
367 368

type RuleName = FastString
369

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

Austin Seipp's avatar
Austin Seipp committed
373 374 375
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
376
\subsection[Fixity]{Fixity info}
Austin Seipp's avatar
Austin Seipp committed
377 378 379
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
380

381
------------------------
382 383
data Fixity = Fixity SourceText Int FixityDirection
  -- Note [Pragma source text]
384
  deriving Data
sof's avatar
sof committed
385 386

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

389
instance Eq Fixity where -- Used to determine if two fixities conflict
390
  (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2
391 392

------------------------
393
data FixityDirection = InfixL | InfixR | InfixN
394
                     deriving (Eq, Data)
395

sof's avatar
sof committed
396
instance Outputable FixityDirection where
397 398 399
    ppr InfixL = text "infixl"
    ppr InfixR = text "infixr"
    ppr InfixN = text "infix"
sof's avatar
sof committed
400

401
------------------------
402
maxPrecedence, minPrecedence :: Int
403
maxPrecedence = 9
404 405
minPrecedence = 0

406
defaultFixity :: Fixity
Alan Zimmerman's avatar
Alan Zimmerman committed
407
defaultFixity = Fixity NoSourceText maxPrecedence InfixL
408

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

Austin Seipp's avatar
Austin Seipp committed
414
{-
415 416 417
Consider

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

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

440 441 442 443 444 445 446 447 448
-- |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
449 450 451
{-
************************************************************************
*                                                                      *
452
\subsection[Top-level/local]{Top-level/not-top level flag}
Austin Seipp's avatar
Austin Seipp committed
453 454 455
*                                                                      *
************************************************************************
-}
456 457 458 459

data TopLevelFlag
  = TopLevel
  | NotTopLevel
460 461 462 463 464 465

isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool

isNotTopLevel NotTopLevel = True
isNotTopLevel TopLevel    = False

466
isTopLevel TopLevel     = True
467
isTopLevel NotTopLevel  = False
468 469

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

Austin Seipp's avatar
Austin Seipp committed
473 474 475
{-
************************************************************************
*                                                                      *
476
                Boxity flag
Austin Seipp's avatar
Austin Seipp committed
477 478 479
*                                                                      *
************************************************************************
-}
480 481 482 483

data Boxity
  = Boxed
  | Unboxed
484
  deriving( Eq, Data )
485 486 487 488 489

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

490 491 492 493
instance Outputable Boxity where
  ppr Boxed   = text "Boxed"
  ppr Unboxed = text "Unboxed"

Austin Seipp's avatar
Austin Seipp committed
494 495 496
{-
************************************************************************
*                                                                      *
497
                Recursive/Non-Recursive flag
Austin Seipp's avatar
Austin Seipp committed
498 499 500
*                                                                      *
************************************************************************
-}
501

502
-- | Recursivity Flag
503 504
data RecFlag = Recursive
             | NonRecursive
505
             deriving( Eq, Data )
sof's avatar
sof committed
506

507 508 509
isRec :: RecFlag -> Bool
isRec Recursive    = True
isRec NonRecursive = False
sof's avatar
sof committed
510

511 512 513
isNonRec :: RecFlag -> Bool
isNonRec Recursive    = False
isNonRec NonRecursive = True
514 515 516 517 518 519

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

instance Outputable RecFlag where
520 521
  ppr Recursive    = text "Recursive"
  ppr NonRecursive = text "NonRecursive"
522

Austin Seipp's avatar
Austin Seipp committed
523 524 525
{-
************************************************************************
*                                                                      *
cactus's avatar
cactus committed
526
                Code origin
Austin Seipp's avatar
Austin Seipp committed
527 528 529 530
*                                                                      *
************************************************************************
-}

cactus's avatar
cactus committed
531 532
data Origin = FromSource
            | Generated
533
            deriving( Eq, Data )
cactus's avatar
cactus committed
534 535 536 537 538 539

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

instance Outputable Origin where
540 541
  ppr FromSource  = text "FromSource"
  ppr Generated   = text "Generated"
cactus's avatar
cactus committed
542

Ryan Scott's avatar
Ryan Scott committed
543 544 545 546 547 548 549 550 551 552 553
{-
************************************************************************
*                                                                      *
                Deriving strategies
*                                                                      *
************************************************************************
-}

-- | Which technique the user explicitly requested when deriving an instance.
data DerivStrategy
  -- See Note [Deriving strategies] in TcDeriv
554 555 556 557 558 559 560
  = 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
561 562 563
  deriving (Eq, Data)

instance Outputable DerivStrategy where
564 565 566
    ppr StockStrategy    = text "stock"
    ppr AnyclassStrategy = text "anyclass"
    ppr NewtypeStrategy  = text "newtype"
Ryan Scott's avatar
Ryan Scott committed
567

Austin Seipp's avatar
Austin Seipp committed
568 569 570
{-
************************************************************************
*                                                                      *
571
                Instance overlap flag
Austin Seipp's avatar
Austin Seipp committed
572 573 574
*                                                                      *
************************************************************************
-}
575

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

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

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

597 598 599 600 601 602
hasIncoherentFlag :: OverlapMode -> Bool
hasIncoherentFlag mode =
  case mode of
    Incoherent   _ -> True
    _              -> False

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

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

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

626

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


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


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

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

673
  deriving (Eq, Data)
674

675

676
instance Outputable OverlapFlag where
677 678 679
   ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)

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

686
pprSafeOverlap :: Bool -> SDoc
687
pprSafeOverlap True  = text "[safe]"
688
pprSafeOverlap False = empty
689

Ben Gamari's avatar
Ben Gamari committed
690 691 692 693 694 695 696 697
{-
************************************************************************
*                                                                      *
                Type precedence
*                                                                      *
************************************************************************
-}

698
data TyPrec   -- See Note [Precedence in types] in TyCoRep.hs
Ben Gamari's avatar
Ben Gamari committed
699 700 701 702 703 704 705 706 707 708 709
  = 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
710 711 712
{-
************************************************************************
*                                                                      *
713
                Tuples
Austin Seipp's avatar
Austin Seipp committed
714 715 716
*                                                                      *
************************************************************************
-}
717

batterseapower's avatar
batterseapower committed
718 719 720
data TupleSort
  = BoxedTuple
  | UnboxedTuple
721
  | ConstraintTuple
722
  deriving( Eq, Data )
batterseapower's avatar
batterseapower committed
723 724

tupleSortBoxity :: TupleSort -> Boxity
725 726
tupleSortBoxity BoxedTuple      = Boxed
tupleSortBoxity UnboxedTuple    = Unboxed
727
tupleSortBoxity ConstraintTuple = Boxed
batterseapower's avatar
batterseapower committed
728

729 730 731
boxityTupleSort :: Boxity -> TupleSort
boxityTupleSort Boxed   = BoxedTuple
boxityTupleSort Unboxed = UnboxedTuple
batterseapower's avatar
batterseapower committed
732 733

tupleParens :: TupleSort -> SDoc -> SDoc
734
tupleParens BoxedTuple      p = parens p
735
tupleParens UnboxedTuple    p = text "(#" <+> p <+> ptext (sLit "#)")
736
tupleParens ConstraintTuple p   -- In debug-style write (% Eq a, Ord b %)
Sylvain Henry's avatar
Sylvain Henry committed
737 738 739
  = sdocWithPprDebug $ \dbg -> if dbg
      then text "(%" <+> p <+> ptext (sLit "%)")
      else parens p
740

741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759
{-
************************************************************************
*                                                                      *
                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
760
    fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)
761

Austin Seipp's avatar
Austin Seipp committed
762 763 764
{-
************************************************************************
*                                                                      *
765
\subsection[Generic]{Generic flag}
Austin Seipp's avatar
Austin Seipp committed
766 767
*                                                                      *
************************************************************************
768

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

774 775
        from :: T -> Tring
        to   :: Tring -> T
776

777
And we should have
778

779
        to (from x) = x
780 781

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

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

Austin Seipp's avatar
Austin Seipp committed
790
{-
791 792 793 794 795
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.

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

800

Austin Seipp's avatar
Austin Seipp committed
801 802
************************************************************************
*                                                                      *
803
\subsection{Occurrence information}
Austin Seipp's avatar
Austin Seipp committed
804 805
*                                                                      *
************************************************************************
806 807 808 809 810

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
811
-}
812

813
-- | identifier Occurrence Information
814
data OccInfo
lukemaurer's avatar
lukemaurer committed
815 816
  = ManyOccs        { occ_tail    :: !TailCallInfo }
                        -- ^ There are many occurrences, or unknown occurrences
817

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

lukemaurer's avatar
lukemaurer committed
821 822 823 824 825
  | OneOcc          { occ_in_lam  :: !InsideLam
                    , occ_one_br  :: !OneBranch
                    , occ_int_cxt :: !InterestingCxt
                    , occ_tail    :: !TailCallInfo }
                        -- ^ Occurs exactly once (per branch), not inside a rule
826

batterseapower's avatar
batterseapower committed
827 828
  -- | 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
lukemaurer's avatar
lukemaurer committed
829 830 831
  | IAmALoopBreaker { occ_rules_only :: !RulesOnly
                    , occ_tail       :: !TailCallInfo }
                        -- Note [LoopBreaker OccInfo]
832

Peter Wortmann's avatar
Peter Wortmann committed
833 834
  deriving (Eq)

835
type RulesOnly = Bool
836

Austin Seipp's avatar
Austin Seipp committed
837
{-
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
838 839
Note [LoopBreaker OccInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~
840
   IAmALoopBreaker True  <=> A "weak" or rules-only loop breaker
841
                             Do not preInlineUnconditionally
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
842

843 844 845 846
   IAmALoopBreaker False <=> A "strong" loop breaker
                             Do not inline at all

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

lukemaurer's avatar
lukemaurer committed
849 850 851 852 853 854
noOccInfo :: OccInfo
noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }

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

856
seqOccInfo :: OccInfo -> ()
857 858 859
seqOccInfo occ = occ `seq` ()

-----------------
860
-- | Interesting Context
861 862 863
type InterestingCxt = Bool      -- True <=> Function: is applied
                                --          Data value: scrutinised by a case with
                                --                      at least one non-DEFAULT branch
864

865
-----------------
866
-- | Inside Lambda
867 868 869
type InsideLam = Bool   -- True <=> Occurs inside a non-linear lambda
                        -- Substituting a redex for this occurrence is
                        -- dangerous because it might duplicate work.
870
insideLam, notInsideLam :: InsideLam
871 872 873
insideLam    = True
notInsideLam = False

874
-----------------
875 876
type OneBranch = Bool   -- True <=> Occurs in only one case branch
                        --      so no code-duplication issue to worry about
877
oneBranch, notOneBranch :: OneBranch
878 879 880
oneBranch    = True
notOneBranch = False

lukemaurer's avatar
lukemaurer committed
881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903
-----------------
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

-----------------
904
strongLoopBreaker, weakLoopBreaker :: OccInfo
lukemaurer's avatar
lukemaurer committed
905 906
strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo
weakLoopBreaker   = IAmALoopBreaker True  NoTailCallInfo
907

908
isWeakLoopBreaker :: OccInfo -> Bool
lukemaurer's avatar
lukemaurer committed
909
isWeakLoopBreaker (IAmALoopBreaker{}) = True
910
isWeakLoopBreaker _                   = False
911

912
isStrongLoopBreaker :: OccInfo -> Bool
lukemaurer's avatar
lukemaurer committed
913 914 915
isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True
  -- Loop-breaker that breaks a non-rule cycle
isStrongLoopBreaker _                                            = False
916

917 918
isDeadOcc :: OccInfo -> Bool
isDeadOcc IAmDead = True
919
isDeadOcc _       = False
920

921
isOneOcc :: OccInfo -> Bool
922 923
isOneOcc (OneOcc {}) = True
isOneOcc _           = False
924

925
zapFragileOcc :: OccInfo -> OccInfo
lukemaurer's avatar
lukemaurer committed
926 927 928
-- Keep only the most robust data: deadness, loop-breaker-hood
zapFragileOcc (OneOcc {}) = noOccInfo
zapFragileOcc occ         = zapOccTailCallInfo occ
929 930 931

instance Outputable OccInfo where
  -- only used for debugging; never parsed.  KSW 1999-07
lukemaurer's avatar
lukemaurer committed
932
  ppr (ManyOccs tails)     = pprShortTailCallInfo tails
933
  ppr IAmDead              = text "Dead"