module BasicTypes(
Version, bumpVersion, initialVersion,
ConTag, fIRST_TAG,
Arity, RepArity,
Alignment,
FunctionOrData(..),
WarningTxt(..),
Fixity(..), FixityDirection(..),
defaultFixity, maxPrecedence, minPrecedence,
negateFixity, funTyFixity,
compareFixity,
RecFlag(..), isRec, isNonRec, boolToRecFlag,
Origin(..), isGenerated,
RuleName,
TopLevelFlag(..), isTopLevel, isNotTopLevel,
OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
hasOverlappingFlag, hasOverlappableFlag,
Boxity(..), isBoxed,
TupleSort(..), tupleSortBoxity, boxityNormalTupleSort,
tupleParens,
OneShotInfo(..),
noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
bestOneShot, worstOneShot,
OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc,
strongLoopBreaker, weakLoopBreaker,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch,
InterestingCxt,
EP(..),
DefMethSpec(..),
SwapFlag(..), flipSwap, unSwap, isSwapped,
CompilerPhase(..), PhaseNum,
Activation(..), isActive, isActiveIn,
isNeverActive, isAlwaysActive, isEarlyActive,
RuleMatchInfo(..), isConLike, isFunLike,
InlineSpec(..), isEmptyInlineSpec,
InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
neverInlinePragma, dfunInlinePragma,
isDefaultInlinePragma,
isInlinePragma, isInlinablePragma, isAnyInlinePragma,
inlinePragmaSpec, inlinePragmaSat,
inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
SuccessFlag(..), succeeded, failed, successIf,
FractionalLit(..), negateFractionalLit, integralFractionalLit,
HValue(..)
) where
import FastString
import Outputable
import SrcLoc ( Located,unLoc )
import Data.Data hiding (Fixity)
import Data.Function (on)
import GHC.Exts (Any)
type Arity = Int
type RepArity = Int
type ConTag = Int
fIRST_TAG :: ConTag
fIRST_TAG = 1
type Alignment = Int
data OneShotInfo
= NoOneShotInfo
| ProbOneShot
| OneShotLam
deriving (Eq)
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
pprOneShotInfo ProbOneShot = ptext (sLit "ProbOneShot")
pprOneShotInfo OneShotLam = ptext (sLit "OneShot")
instance Outputable OneShotInfo where
ppr = pprOneShotInfo
data SwapFlag
= NotSwapped
| IsSwapped
instance Outputable SwapFlag where
ppr IsSwapped = ptext (sLit "Is-swapped")
ppr NotSwapped = ptext (sLit "Not-swapped")
flipSwap :: SwapFlag -> SwapFlag
flipSwap IsSwapped = NotSwapped
flipSwap NotSwapped = IsSwapped
isSwapped :: SwapFlag -> Bool
isSwapped IsSwapped = True
isSwapped NotSwapped = False
unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
unSwap NotSwapped f a b = f a b
unSwap IsSwapped f a b = f b a
data FunctionOrData = IsFunction | IsData
deriving (Eq, Ord, Data, Typeable)
instance Outputable FunctionOrData where
ppr IsFunction = text "(function)"
ppr IsData = text "(data)"
type Version = Int
bumpVersion :: Version -> Version
bumpVersion v = v+1
initialVersion :: Version
initialVersion = 1
data WarningTxt = WarningTxt [Located FastString]
| DeprecatedTxt [Located FastString]
deriving (Eq, Data, Typeable)
instance Outputable WarningTxt where
ppr (WarningTxt ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
doubleQuotes (vcat (map (ftext . unLoc) ds))
type RuleName = FastString
data Fixity = Fixity Int FixityDirection
deriving (Data, Typeable)
instance Outputable Fixity where
ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
instance Eq Fixity where
(Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
data FixityDirection = InfixL | InfixR | InfixN
deriving (Eq, Data, Typeable)
instance Outputable FixityDirection where
ppr InfixL = ptext (sLit "infixl")
ppr InfixR = ptext (sLit "infixr")
ppr InfixN = ptext (sLit "infix")
maxPrecedence, minPrecedence :: Int
maxPrecedence = 9
minPrecedence = 0
defaultFixity :: Fixity
defaultFixity = Fixity maxPrecedence InfixL
negateFixity, funTyFixity :: Fixity
negateFixity = Fixity 6 InfixL
funTyFixity = Fixity 0 InfixR
compareFixity :: Fixity -> Fixity
-> (Bool,
Bool)
compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
= case prec1 `compare` prec2 of
GT -> left
LT -> right
EQ -> case (dir1, dir2) of
(InfixR, InfixR) -> right
(InfixL, InfixL) -> left
_ -> error_please
where
right = (False, True)
left = (False, False)
error_please = (True, False)
data TopLevelFlag
= TopLevel
| NotTopLevel
isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool
isNotTopLevel NotTopLevel = True
isNotTopLevel TopLevel = False
isTopLevel TopLevel = True
isTopLevel NotTopLevel = False
instance Outputable TopLevelFlag where
ppr TopLevel = ptext (sLit "<TopLevel>")
ppr NotTopLevel = ptext (sLit "<NotTopLevel>")
data Boxity
= Boxed
| Unboxed
deriving( Eq, Data, Typeable )
isBoxed :: Boxity -> Bool
isBoxed Boxed = True
isBoxed Unboxed = False
data RecFlag = Recursive
| NonRecursive
deriving( Eq, Data, Typeable )
isRec :: RecFlag -> Bool
isRec Recursive = True
isRec NonRecursive = False
isNonRec :: RecFlag -> Bool
isNonRec Recursive = False
isNonRec NonRecursive = True
boolToRecFlag :: Bool -> RecFlag
boolToRecFlag True = Recursive
boolToRecFlag False = NonRecursive
instance Outputable RecFlag where
ppr Recursive = ptext (sLit "Recursive")
ppr NonRecursive = ptext (sLit "NonRecursive")
data Origin = FromSource
| Generated
deriving( Eq, Data, Typeable )
isGenerated :: Origin -> Bool
isGenerated Generated = True
isGenerated FromSource = False
instance Outputable Origin where
ppr FromSource = ptext (sLit "FromSource")
ppr Generated = ptext (sLit "Generated")
data OverlapFlag = OverlapFlag
{ overlapMode :: OverlapMode
, isSafeOverlap :: Bool
} deriving (Eq, Data, Typeable)
setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag
setOverlapModeMaybe f Nothing = f
setOverlapModeMaybe f (Just m) = f { overlapMode = m }
hasOverlappableFlag :: OverlapMode -> Bool
hasOverlappableFlag mode =
case mode of
Overlappable -> True
Overlaps -> True
Incoherent -> True
_ -> False
hasOverlappingFlag :: OverlapMode -> Bool
hasOverlappingFlag mode =
case mode of
Overlapping -> True
Overlaps -> True
Incoherent -> True
_ -> False
data OverlapMode
= NoOverlap
| Overlappable
| Overlapping
| Overlaps
| Incoherent
deriving (Eq, Data, Typeable)
instance Outputable OverlapFlag where
ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
instance Outputable OverlapMode where
ppr NoOverlap = empty
ppr Overlappable = ptext (sLit "[overlappable]")
ppr Overlapping = ptext (sLit "[overlapping]")
ppr Overlaps = ptext (sLit "[overlap ok]")
ppr Incoherent = ptext (sLit "[incoherent]")
pprSafeOverlap :: Bool -> SDoc
pprSafeOverlap True = ptext $ sLit "[safe]"
pprSafeOverlap False = empty
data TupleSort
= BoxedTuple
| UnboxedTuple
| ConstraintTuple
deriving( Eq, Data, Typeable )
tupleSortBoxity :: TupleSort -> Boxity
tupleSortBoxity BoxedTuple = Boxed
tupleSortBoxity UnboxedTuple = Unboxed
tupleSortBoxity ConstraintTuple = Boxed
boxityNormalTupleSort :: Boxity -> TupleSort
boxityNormalTupleSort Boxed = BoxedTuple
boxityNormalTupleSort Unboxed = UnboxedTuple
tupleParens :: TupleSort -> SDoc -> SDoc
tupleParens BoxedTuple p = parens p
tupleParens ConstraintTuple p = parens p
tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
data EP a = EP { fromEP :: a,
toEP :: a }
data OccInfo
= NoOccInfo
| IAmDead
| OneOcc
!InsideLam
!OneBranch
!InterestingCxt
| IAmALoopBreaker
!RulesOnly
deriving (Eq)
type RulesOnly = Bool
isNoOcc :: OccInfo -> Bool
isNoOcc NoOccInfo = True
isNoOcc _ = False
seqOccInfo :: OccInfo -> ()
seqOccInfo occ = occ `seq` ()
type InterestingCxt = Bool
type InsideLam = Bool
insideLam, notInsideLam :: InsideLam
insideLam = True
notInsideLam = False
type OneBranch = Bool
oneBranch, notOneBranch :: OneBranch
oneBranch = True
notOneBranch = False
strongLoopBreaker, weakLoopBreaker :: OccInfo
strongLoopBreaker = IAmALoopBreaker False
weakLoopBreaker = IAmALoopBreaker True
isWeakLoopBreaker :: OccInfo -> Bool
isWeakLoopBreaker (IAmALoopBreaker _) = True
isWeakLoopBreaker _ = False
isStrongLoopBreaker :: OccInfo -> Bool
isStrongLoopBreaker (IAmALoopBreaker False) = True
isStrongLoopBreaker _ = False
isDeadOcc :: OccInfo -> Bool
isDeadOcc IAmDead = True
isDeadOcc _ = False
isOneOcc :: OccInfo -> Bool
isOneOcc (OneOcc {}) = True
isOneOcc _ = False
zapFragileOcc :: OccInfo -> OccInfo
zapFragileOcc (OneOcc {}) = NoOccInfo
zapFragileOcc occ = occ
instance Outputable OccInfo where
ppr NoOccInfo = empty
ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty
ppr IAmDead = ptext (sLit "Dead")
ppr (OneOcc inside_lam one_branch int_cxt)
= ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args
where
pp_lam | inside_lam = char 'L'
| otherwise = empty
pp_br | one_branch = empty
| otherwise = char '*'
pp_args | int_cxt = char '!'
| otherwise = empty
data DefMethSpec = NoDM
| VanillaDM
| GenericDM
deriving Eq
instance Outputable DefMethSpec where
ppr NoDM = empty
ppr VanillaDM = ptext (sLit "{- Has default method -}")
ppr GenericDM = ptext (sLit "{- Has generic default method -}")
data SuccessFlag = Succeeded | Failed
instance Outputable SuccessFlag where
ppr Succeeded = ptext (sLit "Succeeded")
ppr Failed = ptext (sLit "Failed")
successIf :: Bool -> SuccessFlag
successIf True = Succeeded
successIf False = Failed
succeeded, failed :: SuccessFlag -> Bool
succeeded Succeeded = True
succeeded Failed = False
failed Succeeded = False
failed Failed = True
type PhaseNum = Int
data CompilerPhase
= Phase PhaseNum
| InitialPhase
instance Outputable CompilerPhase where
ppr (Phase n) = int n
ppr InitialPhase = ptext (sLit "InitialPhase")
data Activation = NeverActive
| AlwaysActive
| ActiveBefore PhaseNum
| ActiveAfter PhaseNum
deriving( Eq, Data, Typeable )
data RuleMatchInfo = ConLike
| FunLike
deriving( Eq, Data, Typeable, Show )
data InlinePragma
= InlinePragma
{ inl_inline :: InlineSpec
, inl_sat :: Maybe Arity
, inl_act :: Activation
, inl_rule :: RuleMatchInfo
} deriving( Eq, Data, Typeable )
data InlineSpec
= Inline
| Inlinable
| NoInline
| EmptyInlineSpec
deriving( Eq, Data, Typeable, Show )
isConLike :: RuleMatchInfo -> Bool
isConLike ConLike = True
isConLike _ = False
isFunLike :: RuleMatchInfo -> Bool
isFunLike FunLike = True
isFunLike _ = False
isEmptyInlineSpec :: InlineSpec -> Bool
isEmptyInlineSpec EmptyInlineSpec = True
isEmptyInlineSpec _ = False
defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
:: InlinePragma
defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
, inl_rule = FunLike
, inl_inline = EmptyInlineSpec
, inl_sat = Nothing }
alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
neverInlinePragma = defaultInlinePragma { inl_act = NeverActive }
inlinePragmaSpec :: InlinePragma -> InlineSpec
inlinePragmaSpec = inl_inline
dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive
, inl_rule = ConLike }
isDefaultInlinePragma :: InlinePragma -> Bool
isDefaultInlinePragma (InlinePragma { inl_act = activation
, inl_rule = match_info
, inl_inline = inline })
= isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info
isInlinePragma :: InlinePragma -> Bool
isInlinePragma prag = case inl_inline prag of
Inline -> True
_ -> False
isInlinablePragma :: InlinePragma -> Bool
isInlinablePragma prag = case inl_inline prag of
Inlinable -> True
_ -> False
isAnyInlinePragma :: InlinePragma -> Bool
isAnyInlinePragma prag = case inl_inline prag of
Inline -> True
Inlinable -> True
_ -> False
inlinePragmaSat :: InlinePragma -> Maybe Arity
inlinePragmaSat = inl_sat
inlinePragmaActivation :: InlinePragma -> Activation
inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
setInlinePragmaActivation prag activation = prag { inl_act = activation }
setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
instance Outputable Activation where
ppr AlwaysActive = brackets (ptext (sLit "ALWAYS"))
ppr NeverActive = brackets (ptext (sLit "NEVER"))
ppr (ActiveBefore n) = brackets (char '~' <> int n)
ppr (ActiveAfter n) = brackets (int n)
instance Outputable RuleMatchInfo where
ppr ConLike = ptext (sLit "CONLIKE")
ppr FunLike = ptext (sLit "FUNLIKE")
instance Outputable InlineSpec where
ppr Inline = ptext (sLit "INLINE")
ppr NoInline = ptext (sLit "NOINLINE")
ppr Inlinable = ptext (sLit "INLINABLE")
ppr EmptyInlineSpec = empty
instance Outputable InlinePragma where
ppr (InlinePragma { inl_inline = inline, inl_act = activation
, inl_rule = info, inl_sat = mb_arity })
= ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info
where
pp_act Inline AlwaysActive = empty
pp_act NoInline NeverActive = empty
pp_act _ act = ppr act
pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
| otherwise = empty
pp_info | isFunLike info = empty
| otherwise = ppr info
isActive :: CompilerPhase -> Activation -> Bool
isActive InitialPhase AlwaysActive = True
isActive InitialPhase (ActiveBefore {}) = True
isActive InitialPhase _ = False
isActive (Phase p) act = isActiveIn p act
isActiveIn :: PhaseNum -> Activation -> Bool
isActiveIn _ NeverActive = False
isActiveIn _ AlwaysActive = True
isActiveIn p (ActiveAfter n) = p <= n
isActiveIn p (ActiveBefore n) = p > n
isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
isNeverActive NeverActive = True
isNeverActive _ = False
isAlwaysActive AlwaysActive = True
isAlwaysActive _ = False
isEarlyActive AlwaysActive = True
isEarlyActive (ActiveBefore {}) = True
isEarlyActive _ = False
data FractionalLit
= FL { fl_text :: String
, fl_value :: Rational
}
deriving (Data, Typeable, Show)
negateFractionalLit :: FractionalLit -> FractionalLit
negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }
integralFractionalLit :: Integer -> FractionalLit
integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }
instance Eq FractionalLit where
(==) = (==) `on` fl_value
instance Ord FractionalLit where
compare = compare `on` fl_value
instance Outputable FractionalLit where
ppr = text . fl_text
newtype HValue = HValue Any