Use FractionalLit more extensively to improve other pretty printers

[ghc-hetmet.git] / compiler / basicTypes / BasicTypes.lhs

diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index f125714..65002d5 100644 (file)
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -59,23 +59,29 @@ module BasicTypes(
 
        DefMethSpec(..),
 
-       CompilerPhase, 
-       Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
+        CompilerPhase(..), PhaseNum,
+        Activation(..), isActive, isActiveIn,
+        isNeverActive, isAlwaysActive, isEarlyActive,
         RuleMatchInfo(..), isConLike, isFunLike, 
         InlineSpec(..), 
         InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, 
         neverInlinePragma, dfunInlinePragma, 
-       isDefaultInlinePragma, isInlinePragma, inlinePragmaSpec, inlinePragmaSat,
+       isDefaultInlinePragma, 
+        isInlinePragma, isInlinablePragma, isAnyInlinePragma,
+        inlinePragmaSpec, inlinePragmaSat,
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 
-       SuccessFlag(..), succeeded, failed, successIf
+       SuccessFlag(..), succeeded, failed, successIf,
+       
+       FractionalLit(..), negateFractionalLit, integralFractionalLit
    ) where
 
 import FastString
 import Outputable
 
 import Data.Data hiding (Fixity)
+import Data.Function (on)
 \end{code}
 
 %************************************************************************
@@ -635,14 +641,22 @@ failed Failed    = True
 When a rule or inlining is active
 
 \begin{code}
-type CompilerPhase = Int       -- Compilation phase
-                               -- Phases decrease towards zero
-                               -- Zero is the last phase
+type PhaseNum = Int  -- Compilation phase
+                     -- Phases decrease towards zero
+                     -- Zero is the last phase
+
+data CompilerPhase
+  = Phase PhaseNum
+  | InitialPhase    -- The first phase -- number = infinity!
+
+instance Outputable CompilerPhase where
+   ppr (Phase n)    = int n
+   ppr InitialPhase = ptext (sLit "InitialPhase")
 
 data Activation = NeverActive
                | AlwaysActive
-               | ActiveBefore CompilerPhase    -- Active only *before* this phase
-               | ActiveAfter CompilerPhase     -- Active in this phase and later
+                | ActiveBefore PhaseNum -- Active only *before* this phase
+                | ActiveAfter PhaseNum  -- Active in this phase and later
                deriving( Eq, Data, Typeable )  -- Eq used in comparing rules in HsDecls
 
 data RuleMatchInfo = ConLike                   -- See Note [CONLIKE pragma]
@@ -735,10 +749,9 @@ isFunLike :: RuleMatchInfo -> Bool
 isFunLike FunLike = True
 isFunLike _            = False
 
-isInlineSpec :: InlineSpec -> Bool
-isInlineSpec Inline    = True
-isInlineSpec Inlinable = True
-isInlineSpec _         = False
+isEmptyInlineSpec :: InlineSpec -> Bool
+isEmptyInlineSpec EmptyInlineSpec = True
+isEmptyInlineSpec _               = False
 
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
@@ -764,11 +777,25 @@ isDefaultInlinePragma :: InlinePragma -> Bool
 isDefaultInlinePragma (InlinePragma { inl_act = activation
                                     , inl_rule = match_info
                                     , inl_inline = inline })
-  = isInlineSpec inline && isAlwaysActive activation && isFunLike match_info
+  = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info
 
 isInlinePragma :: InlinePragma -> Bool
-isInlinePragma prag = isInlineSpec (inl_inline prag)
-
+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
+-- INLINE or INLINABLE
+isAnyInlinePragma prag = case inl_inline prag of
+                        Inline    -> True
+                        Inlinable -> True
+                        _         -> False
+ 
 inlinePragmaSat :: InlinePragma -> Maybe Arity
 inlinePragmaSat = inl_sat
 
@@ -815,10 +842,16 @@ instance Outputable InlinePragma where
               | otherwise      = ppr info
 
 isActive :: CompilerPhase -> Activation -> Bool
-isActive _ NeverActive      = False
-isActive _ AlwaysActive     = True
-isActive p (ActiveAfter n)  = p <= n
-isActive p (ActiveBefore n) = p >  n
+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
@@ -832,3 +865,35 @@ isEarlyActive (ActiveBefore {}) = True
 isEarlyActive _                        = False
 \end{code}
 
+
+
+\begin{code}
+-- Used (instead of Rational) to represent exactly the floating point literal that we
+-- encountered in the user's source program. This allows us to pretty-print exactly what
+-- the user wrote, which is important e.g. for floating point numbers that can't represented
+-- as Doubles (we used to via Double for pretty-printing). See also #2245.
+data FractionalLit
+  = FL { fl_text :: String         -- How the value was written in the source
+       , fl_value :: Rational      -- Numeric value of the literal
+       }
+  deriving (Data, Typeable)
+
+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 }
+
+-- Comparison operations are needed when grouping literals
+-- for compiling pattern-matching (module MatchLit)
+
+instance Eq FractionalLit where
+  (==) = (==) `on` fl_value
+
+instance Ord FractionalLit where
+  compare = compare `on` fl_value
+
+instance Outputable FractionalLit where
+  ppr = text . fl_text
+\end{code}