BasicTypes.hs 54.7 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,
88
        InlineSpec(..), noUserInlineSpec,
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
  = TopPrec         -- No parens
  | FunPrec         -- Function args; no parens for tycon apps
  | TyOpPrec        -- Infix operator
  | TyConPrec       -- Tycon args; no parens for atomic
703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724

instance Eq TyPrec where
  (==) a b = case compare a b of
               EQ -> True
               _  -> False

instance Ord TyPrec where
  compare TopPrec TopPrec  = EQ
  compare TopPrec _        = LT

  compare FunPrec TopPrec   = GT
  compare FunPrec FunPrec   = EQ
  compare FunPrec TyOpPrec  = EQ   -- See Note [Type operator precedence]
  compare FunPrec TyConPrec = LT

  compare TyOpPrec TopPrec   = GT
  compare TyOpPrec FunPrec   = EQ  -- See Note [Type operator precedence]
  compare TyOpPrec TyOpPrec  = EQ
  compare TyOpPrec TyConPrec = LT

  compare TyConPrec TyConPrec = EQ
  compare TyConPrec _         = GT
Ben Gamari's avatar
Ben Gamari committed
725 726 727 728 729 730

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

731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764
{- Note [Precedence in types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Many pretty-printing functions have type
    ppr_ty :: TyPrec -> Type -> SDoc

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

We use this consistently for Type and HsType.

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

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
765 766 767
{-
************************************************************************
*                                                                      *
768
                Tuples
Austin Seipp's avatar
Austin Seipp committed
769 770 771
*                                                                      *
************************************************************************
-}
772

batterseapower's avatar
batterseapower committed
773 774 775
data TupleSort
  = BoxedTuple
  | UnboxedTuple
776
  | ConstraintTuple
777
  deriving( Eq, Data )
batterseapower's avatar
batterseapower committed
778 779

tupleSortBoxity :: TupleSort -> Boxity
780 781
tupleSortBoxity BoxedTuple      = Boxed
tupleSortBoxity UnboxedTuple    = Unboxed
782
tupleSortBoxity ConstraintTuple = Boxed
batterseapower's avatar
batterseapower committed
783

784 785 786
boxityTupleSort :: Boxity -> TupleSort
boxityTupleSort Boxed   = BoxedTuple
boxityTupleSort Unboxed = UnboxedTuple
batterseapower's avatar
batterseapower committed
787 788

tupleParens :: TupleSort -> SDoc -> SDoc
789
tupleParens BoxedTuple      p = parens p
790
tupleParens UnboxedTuple    p = text "(#" <+> p <+> ptext (sLit "#)")
791
tupleParens ConstraintTuple p   -- In debug-style write (% Eq a, Ord b %)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
792 793
  = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)"))
               (parens p)
794

795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813
{-
************************************************************************
*                                                                      *
                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
814
    fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)
815

Austin Seipp's avatar
Austin Seipp committed
816 817 818
{-
************************************************************************
*                                                                      *
819
\subsection[Generic]{Generic flag}
Austin Seipp's avatar
Austin Seipp committed
820 821
*                                                                      *
************************************************************************
822

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

828 829
        from :: T -> Tring
        to   :: Tring -> T
830

831
And we should have
832

833
        to (from x) = x
834 835

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

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

Austin Seipp's avatar
Austin Seipp committed
844
{-
845 846 847 848 849
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.

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

854

Austin Seipp's avatar
Austin Seipp committed
855 856
************************************************************************
*                                                                      *
857
\subsection{Occurrence information}
Austin Seipp's avatar
Austin Seipp committed
858 859
*                                                                      *
************************************************************************
860 861 862 863 864

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
865
-}
866

867
-- | identifier Occurrence Information
868
data OccInfo
lukemaurer's avatar
lukemaurer committed
869 870
  = ManyOccs        { occ_tail    :: !TailCallInfo }
                        -- ^ There are many occurrences, or unknown occurrences
871

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

lukemaurer's avatar
lukemaurer committed
875 876 877 878 879
  | 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
880

batterseapower's avatar
batterseapower committed
881 882
  -- | 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
883 884 885
  | IAmALoopBreaker { occ_rules_only :: !RulesOnly
                    , occ_tail       :: !TailCallInfo }
                        -- Note [LoopBreaker OccInfo]
886

Peter Wortmann's avatar
Peter Wortmann committed
887 888
  deriving (Eq)

889
type RulesOnly = Bool
890

Austin Seipp's avatar
Austin Seipp committed
891
{-
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
892 893
Note [LoopBreaker OccInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~
894
   IAmALoopBreaker True  <=> A "weak" or rules-only loop breaker
895
                             Do not preInlineUnconditionally
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
896

897 898 899 900
   IAmALoopBreaker False <=> A "strong" loop breaker
                             Do not inline at all

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

lukemaurer's avatar
lukemaurer committed
903 904 905 906 907 908
noOccInfo :: OccInfo
noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }

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

910
seqOccInfo :: OccInfo -> ()
911 912 913
seqOccInfo occ = occ `seq` ()

-----------------
914
-- | Interesting Context
915 916 917
type InterestingCxt = Bool      -- True <=> Function: is applied
                                --          Data value: scrutinised by a case with
                                --                      at least one non-DEFAULT branch
918

919
-----------------
920
-- | Inside Lambda
921 922 923
type InsideLam = Bool   -- True <=> Occurs inside a non-linear lambda
                        -- Substituting a redex for this occurrence is
                        -- dangerous because it might duplicate work.
924
insideLam, notInsideLam :: InsideLam
925 926 927
insideLam    = True
notInsideLam = False

928
-----------------
929 930
type OneBranch = Bool   -- True <=> Occurs in only one case branch
                        --      so no code-duplication issue to worry about
931
oneBranch, notOneBranch :: OneBranch
932 933 934
oneBranch    = True
notOneBranch = False

lukemaurer's avatar
lukemaurer committed
935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957
-----------------
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

-----------------
958
strongLoopBreaker, weakLoopBreaker :: OccInfo
lukemaurer's avatar
lukemaurer committed
959 960
strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo
weakLoopBreaker   = IAmALoopBreaker True  NoTailCallInfo
961

962
isWeakLoopBreaker :: OccInfo -> Bool
lukemaurer's avatar
lukemaurer committed
963
isWeakLoopBreaker (IAmALoopBreaker{}) = True
964
isWeakLoopBreaker _                   = False
965

966
isStrongLoopBreaker :: OccInfo -> Bool
lukemaurer's avatar
lukemaurer committed
967 968 969
isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True
  -- Loop-breaker that breaks a non-rule cycle
isStrongLoopBreaker _                                            = False
970

971 972
isDeadOcc :: OccInfo -> Bool
isDeadOcc IAmDead = True
973
isDeadOcc _       = False
974

975
isOneOcc :: OccInfo -> Bool
976 977
isOneOcc (OneOcc {}) = True
isOneOcc _           = False
978

979
zapFragileOcc :: OccInfo -> OccInfo
lukemaurer's avatar
lukemaurer committed
980 981 982
-- Keep only the most robust data: deadness, loop-breaker-hood
zapFragileOcc (OneOcc {}) = noOccInfo
zapFragileOcc occ         = zapOccTailCallInfo occ
983 984 985

instance Outputable OccInfo where
  -- only used for debugging; never parsed.  KSW 1999-07
lukemaurer's avatar
lukemaurer committed
986
  ppr (ManyOccs tails)     = pprShortTailCallInfo tails
987
  ppr IAmDead              = text "Dead"
lukemaurer's avatar
lukemaurer committed
988 989 990 991 992 993 994
  ppr (IAmALoopBreaker rule_only tails)
        = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails
        where
          pp_ro | rule_only = char '!'
                | otherwise = empty
  ppr (OneOcc inside_lam one_branch int_cxt tail_info)
        = text "Once" <> pp_lam <> pp_br <> pp_args <> pp_tail
995 996 997 998 999 1000 1001
        where
          pp_lam | inside_lam = char 'L'
                 | otherwise  = empty
          pp_br  | one_branch = empty
                 | otherwise  = char '*'
          pp_args | int_cxt   = char '!'
                  | otherwise = empty
lukemaurer's avatar
lukemaurer committed
1002 1003 1004 1005 1006
          pp_tail             = pprShortTailCallInfo tail_info

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