, Monad((>>=), (>>), return, fail)
, MonadPlus ( -- class context: Monad
- mzero -- :: (MonadPlus m) => m a
- , mplus -- :: (MonadPlus m) => m a -> m a -> m a
- )
+ mzero -- :: (MonadPlus m) => m a
+ , mplus -- :: (MonadPlus m) => m a -> m a -> m a
+ )
-- * Functions
-- ** Naming conventions
-- | Same as '>>=', but with the arguments interchanged.
{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}
(=<<) :: Monad m => (a -> m b) -> m a -> m b
-f =<< x = x >>= f
+f =<< x = x >>= f
-- | Evaluate each action in the sequence from left to right,
-- and collect the results.
sequence :: Monad m => [m a] -> m [a]
{-# INLINE sequence #-}
sequence ms = foldr k (return []) ms
- where
- k m m' = do { x <- m; xs <- m'; return (x:xs) }
+ where
+ k m m' = do { x <- m; xs <- m'; return (x:xs) }
-- | Evaluate each action in the sequence from left to right,
-- and ignore the results.
--
-- (but the instance for 'System.IO.IO' defined in Control.Monad.Error
-- in the mtl package does not satisfy the second one).
- mzero :: m a
+ mzero :: m a
-- | an associative operation
mplus :: m a -> m a -> m a
function' are not commutative.
-> foldM f a1 [x1, x2, ..., xm ]
+> foldM f a1 [x1, x2, ..., xm ]
==
-> do
-> a2 <- f a1 x1
-> a3 <- f a2 x2
-> ...
-> f am xm
+> do
+> a2 <- f a1 x1
+> a3 <- f a2 x2
+> ...
+> f am xm
If right-to-left evaluation is required, the input list should be reversed.
-}
{- | Conditional execution of monadic expressions. For example,
-> when debug (putStr "Debugging\n")
+> when debug (putStr "Debugging\n")
will output the string @Debugging\\n@ if the Boolean value @debug@ is 'True',
and otherwise do nothing.
-- | Promote a function to a monad, scanning the monadic arguments from
-- left to right. For example,
--
--- > liftM2 (+) [0,1] [0,2] = [0,2,1,3]
--- > liftM2 (+) (Just 1) Nothing = Nothing
+-- > liftM2 (+) [0,1] [0,2] = [0,2,1,3]
+-- > liftM2 (+) (Just 1) Nothing = Nothing
--
liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
{- | In many situations, the 'liftM' operations can be replaced by uses of
'ap', which promotes function application.
-> return f `ap` x1 `ap` ... `ap` xn
+> return f `ap` x1 `ap` ... `ap` xn
is equivalent to
-> liftMn f x1 x2 ... xn
+> liftMn f x1 x2 ... xn
-}
module Data.Either (
Either(..),
- either -- :: (a -> c) -> (b -> c) -> Either a b -> c
+ either -- :: (a -> c) -> (b -> c) -> Either a b -> c
) where
#ifdef __GLASGOW_HASKELL__
used to hold an error value and the 'Right' constructor is used to
hold a correct value (mnemonic: \"right\" also means \"correct\").
-}
-data Either a b = Left a | Right b deriving (Eq, Ord )
+data Either a b = Left a | Right b deriving (Eq, Ord )
-- | Case analysis for the 'Either' type.
-- If the value is @'Left' a@, apply the first function to @a@;
-----------------------------------------------------------------------------
module Data.Word
- (
- -- * Unsigned integral types
+ (
+ -- * Unsigned integral types
- Word,
- Word8, Word16, Word32, Word64,
-
- -- * Notes
-
- -- $notes
- ) where
+ Word,
+ Word8, Word16, Word32, Word64,
+
+ -- * Notes
+
+ -- $notes
+ ) where
#ifdef __GLASGOW_HASKELL__
import GHC.Word
#ifdef __NHC__
import NHC.FFI (Word8, Word16, Word32, Word64)
-import NHC.SizedTypes (Word8, Word16, Word32, Word64) -- instances of Bits
+import NHC.SizedTypes (Word8, Word16, Word32, Word64) -- instances of Bits
type Word = Word32
#endif
%*********************************************************
-%* *
+%* *
\subsection{The @Ix@ class}
-%* *
+%* *
%*********************************************************
\begin{code}
--
class (Ord a) => Ix a where
-- | The list of values in the subrange defined by a bounding pair.
- range :: (a,a) -> [a]
+ range :: (a,a) -> [a]
-- | The position of a subscript in the subrange.
- index :: (a,a) -> a -> Int
+ index :: (a,a) -> a -> Int
-- | Like 'index', but without checking that the value is in range.
- unsafeIndex :: (a,a) -> a -> Int
+ unsafeIndex :: (a,a) -> a -> Int
-- | Returns 'True' the given subscript lies in the range defined
-- the bounding pair.
- inRange :: (a,a) -> a -> Bool
+ inRange :: (a,a) -> a -> Bool
-- | The size of the subrange defined by a bounding pair.
- rangeSize :: (a,a) -> Int
+ rangeSize :: (a,a) -> Int
-- | like 'rangeSize', but without checking that the upper bound is
-- in range.
unsafeRangeSize :: (a,a) -> Int
- -- Must specify one of index, unsafeIndex
- index b i | inRange b i = unsafeIndex b i
- | otherwise = error "Error in array index"
+ -- Must specify one of index, unsafeIndex
+ index b i | inRange b i = unsafeIndex b i
+ | otherwise = error "Error in array index"
unsafeIndex b i = index b i
rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1
- | otherwise = 0 -- This case is only here to
- -- check for an empty range
- -- NB: replacing (inRange b h) by (l <= h) fails for
- -- tuples. E.g. (1,2) <= (2,1) but the range is empty
+ | otherwise = 0 -- This case is only here to
+ -- check for an empty range
+ -- NB: replacing (inRange b h) by (l <= h) fails for
+ -- tuples. E.g. (1,2) <= (2,1) but the range is empty
unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1
\end{code}
Note that the following is NOT right
- rangeSize (l,h) | l <= h = index b h + 1
- | otherwise = 0
+ rangeSize (l,h) | l <= h = index b h + 1
+ | otherwise = 0
Because it might be the case that l<h, but the range
is nevertheless empty. Consider
- ((1,2),(2,1))
+ ((1,2),(2,1))
Here l<h, but the second index ranges from 2..1 and
hence is empty
%*********************************************************
-%* *
+%* *
\subsection{Instances of @Ix@}
-%* *
+%* *
%*********************************************************
\begin{code}
indexError rng i tp
= error (showString "Ix{" . showString tp . showString "}.index: Index " .
showParen True (showsPrec 0 i) .
- showString " out of range " $
- showParen True (showsPrec 0 rng) "")
+ showString " out of range " $
+ showParen True (showsPrec 0 rng) "")
----------------------------------------------------------------------
instance Ix Char where
unsafeIndex (m,_n) i = fromEnum i - fromEnum m
index b i | inRange b i = unsafeIndex b i
- | otherwise = indexError b i "Char"
+ | otherwise = indexError b i "Char"
- inRange (m,n) i = m <= i && i <= n
+ inRange (m,n) i = m <= i && i <= n
----------------------------------------------------------------------
instance Ix Int where
{-# INLINE range #-}
- -- The INLINE stops the build in the RHS from getting inlined,
- -- so that callers can fuse with the result of range
+ -- The INLINE stops the build in the RHS from getting inlined,
+ -- so that callers can fuse with the result of range
range (m,n) = [m..n]
{-# INLINE unsafeIndex #-}
unsafeIndex (m,_n) i = i - m
index b i | inRange b i = unsafeIndex b i
- | otherwise = indexError b i "Int"
+ | otherwise = indexError b i "Int"
{-# INLINE inRange #-}
inRange (I# m,I# n) (I# i) = m <=# i && i <=# n
unsafeIndex (m,_n) i = fromInteger (i - m)
index b i | inRange b i = unsafeIndex b i
- | otherwise = indexError b i "Integer"
+ | otherwise = indexError b i "Integer"
- inRange (m,n) i = m <= i && i <= n
+ inRange (m,n) i = m <= i && i <= n
----------------------------------------------------------------------
instance Ix Bool where -- as derived
unsafeIndex (l,_) i = fromEnum i - fromEnum l
index b i | inRange b i = unsafeIndex b i
- | otherwise = indexError b i "Bool"
+ | otherwise = indexError b i "Bool"
inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u
unsafeIndex (l,_) i = fromEnum i - fromEnum l
index b i | inRange b i = unsafeIndex b i
- | otherwise = indexError b i "Ordering"
+ | otherwise = indexError b i "Ordering"
inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{The @Array@ types}
-%* *
+%* *
%*********************************************************
\begin{code}
-- used to make sure an index is
-- really in range
(MutableArray# s e) -- The actual elements
- -- No Ix context for STArray. They are stupid,
- -- and force an Ix context on the equality instance.
+ -- No Ix context for STArray. They are stupid,
+ -- and force an Ix context on the equality instance.
-- Just pointer equality on mutable arrays:
instance Eq (STArray s i e) where
%*********************************************************
-%* *
+%* *
\subsection{Operations on immutable arrays}
-%* *
+%* *
%*********************************************************
\begin{code}
-- with which the array was constructed.
{-# INLINE array #-}
array :: Ix i
- => (i,i) -- ^ a pair of /bounds/, each of the index type
- -- of the array. These bounds are the lowest and
- -- highest indices in the array, in that order.
- -- For example, a one-origin vector of length
- -- '10' has bounds '(1,10)', and a one-origin '10'
- -- by '10' matrix has bounds '((1,1),(10,10))'.
- -> [(i, e)] -- ^ a list of /associations/ of the form
- -- (/index/, /value/). Typically, this list will
- -- be expressed as a comprehension. An
- -- association '(i, x)' defines the value of
- -- the array at index 'i' to be 'x'.
- -> Array i e
+ => (i,i) -- ^ a pair of /bounds/, each of the index type
+ -- of the array. These bounds are the lowest and
+ -- highest indices in the array, in that order.
+ -- For example, a one-origin vector of length
+ -- '10' has bounds '(1,10)', and a one-origin '10'
+ -- by '10' matrix has bounds '((1,1),(10,10))'.
+ -> [(i, e)] -- ^ a list of /associations/ of the form
+ -- (/index/, /value/). Typically, this list will
+ -- be expressed as a comprehension. An
+ -- association '(i, x)' defines the value of
+ -- the array at index 'i' to be 'x'.
+ -> Array i e
array (l,u) ies
= let n = safeRangeSize (l,u)
in unsafeArray' (l,u) n
-- not in general be recursive.
{-# INLINE accumArray #-}
accumArray :: Ix i
- => (e -> a -> e) -- ^ accumulating function
- -> e -- ^ initial value
- -> (i,i) -- ^ bounds of the array
- -> [(i, a)] -- ^ association list
- -> Array i e
+ => (e -> a -> e) -- ^ accumulating function
+ -> e -- ^ initial value
+ -> (i,i) -- ^ bounds of the array
+ -> [(i, a)] -- ^ association list
+ -> Array i e
accumArray f init (l,u) ies =
let n = safeRangeSize (l,u)
in unsafeAccumArray' f init (l,u) n
%*********************************************************
-%* *
+%* *
\subsection{Array instances}
-%* *
+%* *
%*********************************************************
\begin{code}
showsPrec appPrec1 (bounds a) .
showChar ' ' .
showsPrec appPrec1 (assocs a)
- -- Precedence of 'array' is the precedence of application
+ -- Precedence of 'array' is the precedence of application
-- The Read instance is in GHC.Read
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Operations on mutable arrays}
-%* *
+%* *
%*********************************************************
Idle ADR question: What's the tradeoff here between flattening these
%*********************************************************
-%* *
+%* *
\subsection{Moving between mutable and immutable}
-%* *
+%* *
%*********************************************************
\begin{code}
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Standard numeric classes}
-%* *
+%* *
%*********************************************************
\begin{code}
-- 'pi', 'exp', 'log', 'sin', 'cos', 'sinh', 'cosh',
-- 'asin', 'acos', 'atan', 'asinh', 'acosh' and 'atanh'
class (Fractional a) => Floating a where
- pi :: a
- exp, log, sqrt :: a -> a
- (**), logBase :: a -> a -> a
- sin, cos, tan :: a -> a
- asin, acos, atan :: a -> a
- sinh, cosh, tanh :: a -> a
+ pi :: a
+ exp, log, sqrt :: a -> a
+ (**), logBase :: a -> a -> a
+ sin, cos, tan :: a -> a
+ asin, acos, atan :: a -> a
+ sinh, cosh, tanh :: a -> a
asinh, acosh, atanh :: a -> a
- x ** y = exp (log x * y)
- logBase x y = log y / log x
- sqrt x = x ** 0.5
- tan x = sin x / cos x
- tanh x = sinh x / cosh x
+ x ** y = exp (log x * y)
+ logBase x y = log y / log x
+ sqrt x = x ** 0.5
+ tan x = sin x / cos x
+ tanh x = sinh x / cosh x
-- | Efficient, machine-independent access to the components of a
-- floating-point number.
--
-- Minimal complete definition:
--- all except 'exponent', 'significand', 'scaleFloat' and 'atan2'
+-- all except 'exponent', 'significand', 'scaleFloat' and 'atan2'
class (RealFrac a, Floating a) => RealFloat a where
-- | a constant function, returning the radix of the representation
-- (often @2@)
- floatRadix :: a -> Integer
+ floatRadix :: a -> Integer
-- | a constant function, returning the number of digits of
-- 'floatRadix' in the significand
- floatDigits :: a -> Int
+ floatDigits :: a -> Int
-- | a constant function, returning the lowest and highest values
-- the exponent may assume
- floatRange :: a -> (Int,Int)
+ floatRange :: a -> (Int,Int)
-- | The function 'decodeFloat' applied to a real floating-point
-- number returns the significand expressed as an 'Integer' and an
-- appropriately scaled exponent (an 'Int'). If @'decodeFloat' x@
-- is the floating-point radix, and furthermore, either @m@ and @n@
-- are both zero or else @b^(d-1) <= m < b^d@, where @d@ is the value
-- of @'floatDigits' x@. In particular, @'decodeFloat' 0 = (0,0)@.
- decodeFloat :: a -> (Integer,Int)
+ decodeFloat :: a -> (Integer,Int)
-- | 'encodeFloat' performs the inverse of 'decodeFloat'
- encodeFloat :: Integer -> Int -> a
+ encodeFloat :: Integer -> Int -> a
-- | the second component of 'decodeFloat'.
- exponent :: a -> Int
+ exponent :: a -> Int
-- | the first component of 'decodeFloat', scaled to lie in the open
-- interval (@-1@,@1@)
- significand :: a -> a
+ significand :: a -> a
-- | multiplies a floating-point number by an integer power of the radix
- scaleFloat :: Int -> a -> a
+ scaleFloat :: Int -> a -> a
-- | 'True' if the argument is an IEEE \"not-a-number\" (NaN) value
- isNaN :: a -> Bool
+ isNaN :: a -> Bool
-- | 'True' if the argument is an IEEE infinity or negative infinity
- isInfinite :: a -> Bool
+ isInfinite :: a -> Bool
-- | 'True' if the argument is too small to be represented in
-- normalized format
- isDenormalized :: a -> Bool
+ isDenormalized :: a -> Bool
-- | 'True' if the argument is an IEEE negative zero
- isNegativeZero :: a -> Bool
+ isNegativeZero :: a -> Bool
-- | 'True' if the argument is an IEEE floating point number
- isIEEE :: a -> Bool
+ isIEEE :: a -> Bool
-- | a version of arctangent taking two real floating-point arguments.
-- For real floating @x@ and @y@, @'atan2' y x@ computes the angle
-- (from the positive x-axis) of the vector from the origin to the
-- that is 'RealFloat', should return the same value as @'atan' y@.
-- A default definition of 'atan2' is provided, but implementors
-- can provide a more accurate implementation.
- atan2 :: a -> a -> a
+ atan2 :: a -> a -> a
- exponent x = if m == 0 then 0 else n + floatDigits x
- where (m,n) = decodeFloat x
+ exponent x = if m == 0 then 0 else n + floatDigits x
+ where (m,n) = decodeFloat x
- significand x = encodeFloat m (negate (floatDigits x))
- where (m,_) = decodeFloat x
+ significand x = encodeFloat m (negate (floatDigits x))
+ where (m,_) = decodeFloat x
- scaleFloat k x = encodeFloat m (n+k)
- where (m,n) = decodeFloat x
-
+ scaleFloat k x = encodeFloat m (n+k)
+ where (m,n) = decodeFloat x
+
atan2 y x
| x > 0 = atan (y/x)
| x == 0 && y > 0 = pi/2
%*********************************************************
-%* *
+%* *
\subsection{Type @Integer@, @Float@, @Double@}
-%* *
+%* *
%*********************************************************
\begin{code}
-- | Single-precision floating point numbers.
-- It is desirable that this type be at least equal in range and precision
-- to the IEEE single-precision type.
-data Float = F# Float#
+data Float = F# Float#
-- | Double-precision floating point numbers.
-- It is desirable that this type be at least equal in range and precision
-- to the IEEE double-precision type.
-data Double = D# Double#
+data Double = D# Double#
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Type @Float@}
-%* *
+%* *
%*********************************************************
\begin{code}
instance Ord Float where
(F# x) `compare` (F# y) | x `ltFloat#` y = LT
- | x `eqFloat#` y = EQ
- | otherwise = GT
+ | x `eqFloat#` y = EQ
+ | otherwise = GT
(F# x) < (F# y) = x `ltFloat#` y
(F# x) <= (F# y) = x `leFloat#` y
(F# x) > (F# y) = x `gtFloat#` y
instance Num Float where
- (+) x y = plusFloat x y
- (-) x y = minusFloat x y
- negate x = negateFloat x
- (*) x y = timesFloat x y
- abs x | x >= 0.0 = x
- | otherwise = negateFloat x
- signum x | x == 0.0 = 0
- | x > 0.0 = 1
- | otherwise = negate 1
+ (+) x y = plusFloat x y
+ (-) x y = minusFloat x y
+ negate x = negateFloat x
+ (*) x y = timesFloat x y
+ abs x | x >= 0.0 = x
+ | otherwise = negateFloat x
+ signum x | x == 0.0 = 0
+ | x > 0.0 = 1
+ | otherwise = negate 1
{-# INLINE fromInteger #-}
fromInteger (S# i#) = case (int2Float# i#) of { d# -> F# d# }
fromInteger (J# s# d#) = encodeFloat# s# d# 0
- -- previous code: fromInteger n = encodeFloat n 0
- -- doesn't work too well, because encodeFloat is defined in
- -- terms of ccalls which can never be simplified away. We
- -- want simple literals like (fromInteger 3 :: Float) to turn
- -- into (F# 3.0), hence the special case for S# here.
+ -- previous code: fromInteger n = encodeFloat n 0
+ -- doesn't work too well, because encodeFloat is defined in
+ -- terms of ccalls which can never be simplified away. We
+ -- want simple literals like (fromInteger 3 :: Float) to turn
+ -- into (F# 3.0), hence the special case for S# here.
instance Real Float where
- toRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
+ toRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
instance Fractional Float where
- (/) x y = divideFloat x y
- fromRational x = fromRat x
- recip x = 1.0 / x
+ (/) x y = divideFloat x y
+ fromRational x = fromRat x
+ recip x = 1.0 / x
{-# RULES "truncate/Float->Int" truncate = float2Int #-}
instance RealFrac Float where
{-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-}
{-# SPECIALIZE round :: Float -> Integer #-}
- -- ceiling, floor, and truncate are all small
+ -- ceiling, floor, and truncate are all small
{-# INLINE ceiling #-}
{-# INLINE floor #-}
{-# INLINE truncate #-}
properFraction x
= case (decodeFloat x) of { (m,n) ->
- let b = floatRadix x in
- if n >= 0 then
- (fromInteger m * fromInteger b ^ n, 0.0)
- else
- case (quotRem m (b^(negate n))) of { (w,r) ->
- (fromInteger w, encodeFloat r n)
- }
+ let b = floatRadix x in
+ if n >= 0 then
+ (fromInteger m * fromInteger b ^ n, 0.0)
+ else
+ case (quotRem m (b^(negate n))) of { (w,r) ->
+ (fromInteger w, encodeFloat r n)
+ }
}
- truncate x = case properFraction x of
- (n,_) -> n
+ truncate x = case properFraction x of
+ (n,_) -> n
- round x = case properFraction x of
- (n,r) -> let
- m = if r < 0.0 then n - 1 else n + 1
- half_down = abs r - 0.5
- in
- case (compare half_down 0.0) of
- LT -> n
- EQ -> if even n then n else m
- GT -> m
+ round x = case properFraction x of
+ (n,r) -> let
+ m = if r < 0.0 then n - 1 else n + 1
+ half_down = abs r - 0.5
+ in
+ case (compare half_down 0.0) of
+ LT -> n
+ EQ -> if even n then n else m
+ GT -> m
ceiling x = case properFraction x of
- (n,r) -> if r > 0.0 then n + 1 else n
+ (n,r) -> if r > 0.0 then n + 1 else n
- floor x = case properFraction x of
- (n,r) -> if r < 0.0 then n - 1 else n
+ floor x = case properFraction x of
+ (n,r) -> if r < 0.0 then n - 1 else n
instance Floating Float where
- pi = 3.141592653589793238
- exp x = expFloat x
- log x = logFloat x
- sqrt x = sqrtFloat x
- sin x = sinFloat x
- cos x = cosFloat x
- tan x = tanFloat x
- asin x = asinFloat x
- acos x = acosFloat x
- atan x = atanFloat x
- sinh x = sinhFloat x
- cosh x = coshFloat x
- tanh x = tanhFloat x
- (**) x y = powerFloat x y
- logBase x y = log y / log x
+ pi = 3.141592653589793238
+ exp x = expFloat x
+ log x = logFloat x
+ sqrt x = sqrtFloat x
+ sin x = sinFloat x
+ cos x = cosFloat x
+ tan x = tanFloat x
+ asin x = asinFloat x
+ acos x = acosFloat x
+ atan x = atanFloat x
+ sinh x = sinhFloat x
+ cosh x = coshFloat x
+ tanh x = tanhFloat x
+ (**) x y = powerFloat x y
+ logBase x y = log y / log x
asinh x = log (x + sqrt (1.0+x*x))
acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
atanh x = log ((x+1.0) / sqrt (1.0-x*x))
instance RealFloat Float where
- floatRadix _ = FLT_RADIX -- from float.h
- floatDigits _ = FLT_MANT_DIG -- ditto
- floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto
+ floatRadix _ = FLT_RADIX -- from float.h
+ floatDigits _ = FLT_MANT_DIG -- ditto
+ floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto
decodeFloat (F# f#)
- = case decodeFloat# f# of
- (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
+ = case decodeFloat# f# of
+ (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
encodeFloat (S# i) j = int_encodeFloat# i j
encodeFloat (J# s# d#) e = encodeFloat# s# d# e
- exponent x = case decodeFloat x of
- (m,n) -> if m == 0 then 0 else n + floatDigits x
+ exponent x = case decodeFloat x of
+ (m,n) -> if m == 0 then 0 else n + floatDigits x
- significand x = case decodeFloat x of
- (m,_) -> encodeFloat m (negate (floatDigits x))
+ significand x = case decodeFloat x of
+ (m,_) -> encodeFloat m (negate (floatDigits x))
- scaleFloat k x = case decodeFloat x of
- (m,n) -> encodeFloat m (n+k)
+ scaleFloat k x = case decodeFloat x of
+ (m,n) -> encodeFloat m (n+k)
isNaN x = 0 /= isFloatNaN x
isInfinite x = 0 /= isFloatInfinite x
isDenormalized x = 0 /= isFloatDenormalized x
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Type @Double@}
-%* *
+%* *
%*********************************************************
\begin{code}
instance Ord Double where
(D# x) `compare` (D# y) | x <## y = LT
- | x ==## y = EQ
- | otherwise = GT
+ | x ==## y = EQ
+ | otherwise = GT
(D# x) < (D# y) = x <## y
(D# x) <= (D# y) = x <=## y
(D# x) > (D# y) = x >## y
instance Num Double where
- (+) x y = plusDouble x y
- (-) x y = minusDouble x y
- negate x = negateDouble x
- (*) x y = timesDouble x y
- abs x | x >= 0.0 = x
- | otherwise = negateDouble x
- signum x | x == 0.0 = 0
- | x > 0.0 = 1
- | otherwise = negate 1
+ (+) x y = plusDouble x y
+ (-) x y = minusDouble x y
+ negate x = negateDouble x
+ (*) x y = timesDouble x y
+ abs x | x >= 0.0 = x
+ | otherwise = negateDouble x
+ signum x | x == 0.0 = 0
+ | x > 0.0 = 1
+ | otherwise = negate 1
{-# INLINE fromInteger #-}
- -- See comments with Num Float
+ -- See comments with Num Float
fromInteger (S# i#) = case (int2Double# i#) of { d# -> D# d# }
fromInteger (J# s# d#) = encodeDouble# s# d# 0
instance Real Double where
- toRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
+ toRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
instance Fractional Double where
- (/) x y = divideDouble x y
- fromRational x = fromRat x
- recip x = 1.0 / x
+ (/) x y = divideDouble x y
+ fromRational x = fromRat x
+ recip x = 1.0 / x
instance Floating Double where
- pi = 3.141592653589793238
- exp x = expDouble x
- log x = logDouble x
- sqrt x = sqrtDouble x
- sin x = sinDouble x
- cos x = cosDouble x
- tan x = tanDouble x
- asin x = asinDouble x
- acos x = acosDouble x
- atan x = atanDouble x
- sinh x = sinhDouble x
- cosh x = coshDouble x
- tanh x = tanhDouble x
- (**) x y = powerDouble x y
- logBase x y = log y / log x
+ pi = 3.141592653589793238
+ exp x = expDouble x
+ log x = logDouble x
+ sqrt x = sqrtDouble x
+ sin x = sinDouble x
+ cos x = cosDouble x
+ tan x = tanDouble x
+ asin x = asinDouble x
+ acos x = acosDouble x
+ atan x = atanDouble x
+ sinh x = sinhDouble x
+ cosh x = coshDouble x
+ tanh x = tanhDouble x
+ (**) x y = powerDouble x y
+ logBase x y = log y / log x
asinh x = log (x + sqrt (1.0+x*x))
acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
{-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}
{-# SPECIALIZE round :: Double -> Integer #-}
- -- ceiling, floor, and truncate are all small
+ -- ceiling, floor, and truncate are all small
{-# INLINE ceiling #-}
{-# INLINE floor #-}
{-# INLINE truncate #-}
properFraction x
= case (decodeFloat x) of { (m,n) ->
- let b = floatRadix x in
- if n >= 0 then
- (fromInteger m * fromInteger b ^ n, 0.0)
- else
- case (quotRem m (b^(negate n))) of { (w,r) ->
- (fromInteger w, encodeFloat r n)
- }
+ let b = floatRadix x in
+ if n >= 0 then
+ (fromInteger m * fromInteger b ^ n, 0.0)
+ else
+ case (quotRem m (b^(negate n))) of { (w,r) ->
+ (fromInteger w, encodeFloat r n)
+ }
}
- truncate x = case properFraction x of
- (n,_) -> n
+ truncate x = case properFraction x of
+ (n,_) -> n
- round x = case properFraction x of
- (n,r) -> let
- m = if r < 0.0 then n - 1 else n + 1
- half_down = abs r - 0.5
- in
- case (compare half_down 0.0) of
- LT -> n
- EQ -> if even n then n else m
- GT -> m
+ round x = case properFraction x of
+ (n,r) -> let
+ m = if r < 0.0 then n - 1 else n + 1
+ half_down = abs r - 0.5
+ in
+ case (compare half_down 0.0) of
+ LT -> n
+ EQ -> if even n then n else m
+ GT -> m
ceiling x = case properFraction x of
- (n,r) -> if r > 0.0 then n + 1 else n
+ (n,r) -> if r > 0.0 then n + 1 else n
- floor x = case properFraction x of
- (n,r) -> if r < 0.0 then n - 1 else n
+ floor x = case properFraction x of
+ (n,r) -> if r < 0.0 then n - 1 else n
instance RealFloat Double where
- floatRadix _ = FLT_RADIX -- from float.h
- floatDigits _ = DBL_MANT_DIG -- ditto
- floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
+ floatRadix _ = FLT_RADIX -- from float.h
+ floatDigits _ = DBL_MANT_DIG -- ditto
+ floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
decodeFloat (D# x#)
- = case decodeDouble# x# of
- (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
+ = case decodeDouble# x# of
+ (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
encodeFloat (S# i) j = int_encodeDouble# i j
encodeFloat (J# s# d#) e = encodeDouble# s# d# e
- exponent x = case decodeFloat x of
- (m,n) -> if m == 0 then 0 else n + floatDigits x
+ exponent x = case decodeFloat x of
+ (m,n) -> if m == 0 then 0 else n + floatDigits x
- significand x = case decodeFloat x of
- (m,_) -> encodeFloat m (negate (floatDigits x))
+ significand x = case decodeFloat x of
+ (m,_) -> encodeFloat m (negate (floatDigits x))
- scaleFloat k x = case decodeFloat x of
- (m,n) -> encodeFloat m (n+k)
+ scaleFloat k x = case decodeFloat x of
+ (m,n) -> encodeFloat m (n+k)
- isNaN x = 0 /= isDoubleNaN x
- isInfinite x = 0 /= isDoubleInfinite x
- isDenormalized x = 0 /= isDoubleDenormalized x
- isNegativeZero x = 0 /= isDoubleNegativeZero x
- isIEEE _ = True
+ isNaN x = 0 /= isDoubleNaN x
+ isInfinite x = 0 /= isDoubleInfinite x
+ isDenormalized x = 0 /= isDoubleDenormalized x
+ isNegativeZero x = 0 /= isDoubleNegativeZero x
+ isIEEE _ = True
instance Show Double where
showsPrec x = showSigned showFloat x
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{@Enum@ instances}
-%* *
+%* *
%*********************************************************
The @Enum@ instances for Floats and Doubles are slightly unusual.
\begin{code}
instance Enum Float where
- succ x = x + 1
- pred x = x - 1
+ succ x = x + 1
+ pred x = x - 1
toEnum = int2Float
fromEnum = fromInteger . truncate -- may overflow
- enumFrom = numericEnumFrom
+ enumFrom = numericEnumFrom
enumFromTo = numericEnumFromTo
enumFromThen = numericEnumFromThen
enumFromThenTo = numericEnumFromThenTo
instance Enum Double where
- succ x = x + 1
- pred x = x - 1
+ succ x = x + 1
+ pred x = x - 1
toEnum = int2Double
fromEnum = fromInteger . truncate -- may overflow
- enumFrom = numericEnumFrom
+ enumFrom = numericEnumFrom
enumFromTo = numericEnumFromTo
enumFromThen = numericEnumFromThen
enumFromThenTo = numericEnumFromThenTo
%*********************************************************
-%* *
+%* *
\subsection{Printing floating point}
-%* *
+%* *
%*********************************************************
formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
formatRealFloat fmt decs x
- | isNaN x = "NaN"
+ | isNaN x = "NaN"
| isInfinite x = if x < 0 then "-Infinity" else "Infinity"
| x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x))
- | otherwise = doFmt fmt (floatToDigits (toInteger base) x)
+ | otherwise = doFmt fmt (floatToDigits (toInteger base) x)
where
base = 10
case format of
FFGeneric ->
doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
- (is,e)
+ (is,e)
FFExponent ->
case decs of
Nothing ->
let show_e' = show (e-1) in
- case ds of
+ case ds of
"0" -> "0.0e0"
[d] -> d : ".0e" ++ show_e'
- (d:ds') -> d : '.' : ds' ++ "e" ++ show_e'
+ (d:ds') -> d : '.' : ds' ++ "e" ++ show_e'
Just dec ->
let dec' = max dec 1 in
case is of
[0] -> '0' :'.' : take dec' (repeat '0') ++ "e0"
_ ->
let
- (ei,is') = roundTo base (dec'+1) is
- (d:ds') = map intToDigit (if ei > 0 then init is' else is')
+ (ei,is') = roundTo base (dec'+1) is
+ (d:ds') = map intToDigit (if ei > 0 then init is' else is')
in
- d:'.':ds' ++ 'e':show (e-1+ei)
+ d:'.':ds' ++ 'e':show (e-1+ei)
FFFixed ->
let
mk0 ls = case ls of { "" -> "0" ; _ -> ls}
in
case decs of
Nothing
- | e <= 0 -> "0." ++ replicate (-e) '0' ++ ds
- | otherwise ->
- let
- f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs
- f n s "" = f (n-1) ('0':s) ""
- f n s (r:rs) = f (n-1) (r:s) rs
- in
- f e "" ds
+ | e <= 0 -> "0." ++ replicate (-e) '0' ++ ds
+ | otherwise ->
+ let
+ f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs
+ f n s "" = f (n-1) ('0':s) ""
+ f n s (r:rs) = f (n-1) (r:s) rs
+ in
+ f e "" ds
Just dec ->
let dec' = max dec 0 in
- if e >= 0 then
- let
- (ei,is') = roundTo base (dec' + e) is
- (ls,rs) = splitAt (e+ei) (map intToDigit is')
- in
- mk0 ls ++ (if null rs then "" else '.':rs)
- else
- let
- (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is)
- d:ds' = map intToDigit (if ei > 0 then is' else 0:is')
- in
- d : (if null ds' then "" else '.':ds')
+ if e >= 0 then
+ let
+ (ei,is') = roundTo base (dec' + e) is
+ (ls,rs) = splitAt (e+ei) (map intToDigit is')
+ in
+ mk0 ls ++ (if null rs then "" else '.':rs)
+ else
+ let
+ (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is)
+ d:ds' = map intToDigit (if ei > 0 then is' else 0:is')
+ in
+ d : (if null ds' then "" else '.':ds')
roundTo :: Int -> Int -> [Int] -> (Int,[Int])
--
-- then
--
--- (1) @n >= 1@
+-- (1) @n >= 1@
--
--- (2) @x = 0.d1d2...dn * (base**e)@
+-- (2) @x = 0.d1d2...dn * (base**e)@
--
--- (3) @0 <= di <= base-1@
+-- (3) @0 <= di <= base-1@
floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
floatToDigits _ 0 = ([0], 0)
k0 =
if b == 2 && base == 10 then
-- logBase 10 2 is slightly bigger than 3/10 so
- -- the following will err on the low side. Ignoring
- -- the fraction will make it err even more.
- -- Haskell promises that p-1 <= logBase b f < p.
- (p - 1 + e0) * 3 `div` 10
+ -- the following will err on the low side. Ignoring
+ -- the fraction will make it err even more.
+ -- Haskell promises that p-1 <= logBase b f < p.
+ (p - 1 + e0) * 3 `div` 10
else
ceiling ((log (fromInteger (f+1)) +
- fromInteger (int2Integer e) * log (fromInteger b)) /
- log (fromInteger base))
---WAS: fromInt e * log (fromInteger b))
+ fromInteger (int2Integer e) * log (fromInteger b)) /
+ log (fromInteger base))
+--WAS: fromInt e * log (fromInteger b))
fixup n =
if n >= 0 then
%*********************************************************
-%* *
+%* *
\subsection{Converting from a Rational to a RealFloat
-%* *
+%* *
%*********************************************************
[In response to a request for documentation of how fromRational works,
main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n")
This program prints
- 0.0000000000000000
+ 0.0000000000000000
instead of
- 1.8217369128763981e-300
+ 1.8217369128763981e-300
Here's Joe's code:
\begin{pseudocode}
fromRat :: (RealFloat a) => Rational -> a
fromRat x = x'
- where x' = f e
-
--- If the exponent of the nearest floating-point number to x
--- is e, then the significand is the integer nearest xb^(-e),
--- where b is the floating-point radix. We start with a good
--- guess for e, and if it is correct, the exponent of the
--- floating-point number we construct will again be e. If
--- not, one more iteration is needed.
-
- f e = if e' == e then y else f e'
- where y = encodeFloat (round (x * (1 % b)^^e)) e
- (_,e') = decodeFloat y
- b = floatRadix x'
-
--- We obtain a trial exponent by doing a floating-point
--- division of x's numerator by its denominator. The
--- result of this division may not itself be the ultimate
--- result, because of an accumulation of three rounding
--- errors.
-
- (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
- / fromInteger (denominator x))
+ where x' = f e
+
+-- If the exponent of the nearest floating-point number to x
+-- is e, then the significand is the integer nearest xb^(-e),
+-- where b is the floating-point radix. We start with a good
+-- guess for e, and if it is correct, the exponent of the
+-- floating-point number we construct will again be e. If
+-- not, one more iteration is needed.
+
+ f e = if e' == e then y else f e'
+ where y = encodeFloat (round (x * (1 % b)^^e)) e
+ (_,e') = decodeFloat y
+ b = floatRadix x'
+
+-- We obtain a trial exponent by doing a floating-point
+-- division of x's numerator by its denominator. The
+-- result of this division may not itself be the ultimate
+-- result, because of an accumulation of three rounding
+-- errors.
+
+ (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
+ / fromInteger (denominator x))
\end{pseudocode}
Now, here's Lennart's code (which works)
\begin{code}
-- | Converts a 'Rational' value into any type in class 'RealFloat'.
{-# SPECIALISE fromRat :: Rational -> Double,
- Rational -> Float #-}
+ Rational -> Float #-}
fromRat :: (RealFloat a) => Rational -> a
-- Deal with special cases first, delegating the real work to fromRat'
-fromRat (n :% 0) | n > 0 = 1/0 -- +Infinity
- | n == 0 = 0/0 -- NaN
- | n < 0 = -1/0 -- -Infinity
+fromRat (n :% 0) | n > 0 = 1/0 -- +Infinity
+ | n == 0 = 0/0 -- NaN
+ | n < 0 = -1/0 -- -Infinity
fromRat (n :% d) | n > 0 = fromRat' (n :% d)
- | n == 0 = encodeFloat 0 0 -- Zero
- | n < 0 = - fromRat' ((-n) :% d)
+ | n == 0 = encodeFloat 0 0 -- Zero
+ | n < 0 = - fromRat' ((-n) :% d)
-- Conversion process:
-- Scale the rational number by the RealFloat base until
fromRat' x = r
where b = floatRadix r
p = floatDigits r
- (minExp0, _) = floatRange r
- minExp = minExp0 - p -- the real minimum exponent
- xMin = toRational (expt b (p-1))
- xMax = toRational (expt b p)
- p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp
- f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
- (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
- r = encodeFloat (round x') p'
+ (minExp0, _) = floatRange r
+ minExp = minExp0 - p -- the real minimum exponent
+ xMin = toRational (expt b (p-1))
+ xMax = toRational (expt b p)
+ p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp
+ f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
+ (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
+ r = encodeFloat (round x') p'
-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int)
| i < b = 0
| otherwise = doDiv (i `div` (b^l)) l
where
- -- Try squaring the base first to cut down the number of divisions.
+ -- Try squaring the base first to cut down the number of divisions.
l = 2 * integerLogBase (b*b) i
- doDiv :: Integer -> Int -> Int
- doDiv x y
- | x < b = y
- | otherwise = doDiv (x `div` b) (y+1)
+ doDiv :: Integer -> Int -> Int
+ doDiv x y
+ | x < b = y
+ | otherwise = doDiv (x `div` b) (y+1)
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Floating point numeric primops}
-%* *
+%* *
%*********************************************************
Definitions of the boxed PrimOps; these will be
negateFloat (F# x) = F# (negateFloat# x)
gtFloat, geFloat, eqFloat, neFloat, ltFloat, leFloat :: Float -> Float -> Bool
-gtFloat (F# x) (F# y) = gtFloat# x y
-geFloat (F# x) (F# y) = geFloat# x y
-eqFloat (F# x) (F# y) = eqFloat# x y
-neFloat (F# x) (F# y) = neFloat# x y
-ltFloat (F# x) (F# y) = ltFloat# x y
-leFloat (F# x) (F# y) = leFloat# x y
+gtFloat (F# x) (F# y) = gtFloat# x y
+geFloat (F# x) (F# y) = geFloat# x y
+eqFloat (F# x) (F# y) = eqFloat# x y
+neFloat (F# x) (F# y) = neFloat# x y
+ltFloat (F# x) (F# y) = ltFloat# x y
+leFloat (F# x) (F# y) = leFloat# x y
float2Int :: Float -> Int
float2Int (F# x) = I# (float2Int# x)
\begin{code}
foreign import ccall unsafe "__encodeFloat"
- encodeFloat# :: Int# -> ByteArray# -> Int -> Float
+ encodeFloat# :: Int# -> ByteArray# -> Int -> Float
foreign import ccall unsafe "__int_encodeFloat"
- int_encodeFloat# :: Int# -> Int -> Float
+ int_encodeFloat# :: Int# -> Int -> Float
foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int
foreign import ccall unsafe "__encodeDouble"
- encodeDouble# :: Int# -> ByteArray# -> Int -> Double
+ encodeDouble# :: Int# -> ByteArray# -> Int -> Double
foreign import ccall unsafe "__int_encodeDouble"
- int_encodeDouble# :: Int# -> Int -> Double
+ int_encodeDouble# :: Int# -> Int -> Double
foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int
foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Coercion rules}
-%* *
+%* *
%*********************************************************
\begin{code}
infixl 7 *
infixl 6 +, -
-default () -- Double isn't available yet,
- -- and we shouldn't be using defaults anyway
+default () -- Double isn't available yet,
+ -- and we shouldn't be using defaults anyway
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Standard numeric class}
-%* *
+%* *
%*********************************************************
\begin{code}
--
-- Minimal complete definition: all except 'negate' or @(-)@
class (Eq a, Show a) => Num a where
- (+), (-), (*) :: a -> a -> a
+ (+), (-), (*) :: a -> a -> a
-- | Unary negation.
- negate :: a -> a
+ negate :: a -> a
-- | Absolute value.
- abs :: a -> a
+ abs :: a -> a
-- | Sign of a number.
-- The functions 'abs' and 'signum' should satisfy the law:
--
--
-- For real numbers, the 'signum' is either @-1@ (negative), @0@ (zero)
-- or @1@ (positive).
- signum :: a -> a
+ signum :: a -> a
-- | Conversion from an 'Integer'.
-- An integer literal represents the application of the function
-- 'fromInteger' to the appropriate value of type 'Integer',
-- so such literals have type @('Num' a) => a@.
- fromInteger :: Integer -> a
+ fromInteger :: Integer -> a
- x - y = x + negate y
- negate x = 0 - x
+ x - y = x + negate y
+ negate x = 0 - x
-- | the same as @'flip' ('-')@.
--
%*********************************************************
-%* *
+%* *
\subsection{Instances for @Int@}
-%* *
+%* *
%*********************************************************
\begin{code}
instance Num Int where
- (+) = plusInt
- (-) = minusInt
+ (+) = plusInt
+ (-) = minusInt
negate = negateInt
- (*) = timesInt
+ (*) = timesInt
abs n = if n `geInt` 0 then n else negateInt n
signum n | n `ltInt` 0 = negateInt 1
- | n `eqInt` 0 = 0
- | otherwise = 1
+ | n `eqInt` 0 = 0
+ | otherwise = 1
fromInteger = integer2Int
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{The @Integer@ type}
-%* *
+%* *
%*********************************************************
\begin{code}
-- | Arbitrary-precision integers.
-data Integer
- = S# Int# -- small integers
+data Integer
+ = S# Int# -- small integers
#ifndef ILX
- | J# Int# ByteArray# -- large integers
+ | J# Int# ByteArray# -- large integers
#else
| J# Void BigInteger -- .NET big ints
%*********************************************************
-%* *
+%* *
\subsection{Dividing @Integers@}
-%* *
+%* *
%*********************************************************
\begin{code}
quotRemInteger i1@(S# _) i2@(J# _ _) = quotRemInteger (toBig i1) i2
quotRemInteger (J# s1 d1) (J# s2 d2)
= case (quotRemInteger# s1 d1 s2 d2) of
- (# s3, d3, s4, d4 #)
- -> (J# s3 d3, J# s4 d4)
+ (# s3, d3, s4, d4 #)
+ -> (J# s3 d3, J# s4 d4)
divModInteger a@(S# (-LEFTMOST_BIT#)) b = divModInteger (toBig a) b
divModInteger (S# i) (S# j)
divModInteger i1@(S# _) i2@(J# _ _) = divModInteger (toBig i1) i2
divModInteger (J# s1 d1) (J# s2 d2)
= case (divModInteger# s1 d1 s2 d2) of
- (# s3, d3, s4, d4 #)
- -> (J# s3 d3, J# s4 d4)
+ (# s3, d3, s4, d4 #)
+ -> (J# s3 d3, J# s4 d4)
remInteger :: Integer -> Integer -> Integer
remInteger ia ib
%*********************************************************
-%* *
+%* *
\subsection{The @Integer@ instances for @Eq@, @Ord@}
-%* *
+%* *
%*********************************************************
\begin{code}
| otherwise = GT
compare (J# s d) (S# i)
= case cmpIntegerInt# s d i of { res# ->
- if res# <# 0# then LT else
- if res# ># 0# then GT else EQ
- }
+ if res# <# 0# then LT else
+ if res# ># 0# then GT else EQ
+ }
compare (S# i) (J# s d)
= case cmpIntegerInt# s d i of { res# ->
- if res# ># 0# then LT else
- if res# <# 0# then GT else EQ
- }
+ if res# ># 0# then LT else
+ if res# <# 0# then GT else EQ
+ }
compare (J# s1 d1) (J# s2 d2)
= case cmpInteger# s1 d1 s2 d2 of { res# ->
- if res# <# 0# then LT else
- if res# ># 0# then GT else EQ
- }
+ if res# <# 0# then LT else
+ if res# ># 0# then GT else EQ
+ }
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{The @Integer@ instances for @Num@}
-%* *
+%* *
%*********************************************************
\begin{code}
(+) = plusInteger
(-) = minusInteger
(*) = timesInteger
- negate = negateInteger
- fromInteger x = x
+ negate = negateInteger
+ fromInteger x = x
-- ORIG: abs n = if n >= 0 then n else -n
abs (S# (-LEFTMOST_BIT#)) = LEFTMOST_BIT
signum (S# i) = case signum (I# i) of I# j -> S# j
signum (J# s d)
= let
- cmp = cmpIntegerInt# s d 0#
- in
- if cmp ># 0# then S# 1#
- else if cmp ==# 0# then S# 0#
- else S# (negateInt# 1#)
+ cmp = cmpIntegerInt# s d 0#
+ in
+ if cmp ># 0# then S# 1#
+ else if cmp ==# 0# then S# 0#
+ else S# (negateInt# 1#)
plusInteger i1@(S# i) i2@(S# j) = case addIntC# i j of { (# r, c #) ->
- if c ==# 0# then S# r
- else toBig i1 + toBig i2 }
+ if c ==# 0# then S# r
+ else toBig i1 + toBig i2 }
plusInteger i1@(J# _ _) i2@(S# _) = i1 + toBig i2
plusInteger i1@(S# _) i2@(J# _ _) = toBig i1 + i2
plusInteger (J# s1 d1) (J# s2 d2) = case plusInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d
minusInteger i1@(S# i) i2@(S# j) = case subIntC# i j of { (# r, c #) ->
- if c ==# 0# then S# r
- else toBig i1 - toBig i2 }
+ if c ==# 0# then S# r
+ else toBig i1 - toBig i2 }
minusInteger i1@(J# _ _) i2@(S# _) = i1 - toBig i2
minusInteger i1@(S# _) i2@(J# _ _) = toBig i1 - i2
minusInteger (J# s1 d1) (J# s2 d2) = case minusInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d
timesInteger (J# s1 d1) (J# s2 d2) = case timesInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d
negateInteger (S# (-LEFTMOST_BIT#)) = LEFTMOST_BIT
-negateInteger (S# i) = S# (negateInt# i)
-negateInteger (J# s d) = J# (negateInt# s) d
+negateInteger (S# i) = S# (negateInt# i)
+negateInteger (J# s d) = J# (negateInt# s) d
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{The @Integer@ instance for @Enum@}
-%* *
+%* *
%*********************************************************
\begin{code}
instance Enum Integer where
- succ x = x + 1
- pred x = x - 1
- toEnum n = int2Integer n
- fromEnum n = integer2Int n
+ succ x = x + 1
+ pred x = x - 1
+ toEnum n = int2Integer n
+ fromEnum n = integer2Int n
{-# INLINE enumFrom #-}
{-# INLINE enumFromThen #-}
{-# INLINE enumFromThenTo #-}
enumFrom x = enumDeltaInteger x 1
enumFromThen x y = enumDeltaInteger x (y-x)
- enumFromTo x lim = enumDeltaToInteger x 1 lim
+ enumFromTo x lim = enumDeltaToInteger x 1 lim
enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim
{-# RULES
-"enumDeltaInteger" [~1] forall x y. enumDeltaInteger x y = build (\c _ -> enumDeltaIntegerFB c x y)
-"efdtInteger" [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)
-"enumDeltaInteger" [1] enumDeltaIntegerFB (:) = enumDeltaInteger
-"enumDeltaToInteger" [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger
+"enumDeltaInteger" [~1] forall x y. enumDeltaInteger x y = build (\c _ -> enumDeltaIntegerFB c x y)
+"efdtInteger" [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)
+"enumDeltaInteger" [1] enumDeltaIntegerFB (:) = enumDeltaInteger
+"enumDeltaToInteger" [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger
#-}
enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b
| otherwise = dn_list x delta lim
up_fb c n x delta lim = go (x::Integer)
- where
- go x | x > lim = n
- | otherwise = x `c` go (x+delta)
+ where
+ go x | x > lim = n
+ | otherwise = x `c` go (x+delta)
dn_fb c n x delta lim = go (x::Integer)
- where
- go x | x < lim = n
- | otherwise = x `c` go (x+delta)
+ where
+ go x | x < lim = n
+ | otherwise = x `c` go (x+delta)
up_list x delta lim = go (x::Integer)
- where
- go x | x > lim = []
- | otherwise = x : go (x+delta)
+ where
+ go x | x > lim = []
+ | otherwise = x : go (x+delta)
dn_list x delta lim = go (x::Integer)
- where
- go x | x < lim = []
- | otherwise = x : go (x+delta)
+ where
+ go x | x < lim = []
+ | otherwise = x : go (x+delta)
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{The @Integer@ instances for @Show@}
-%* *
+%* *
%*********************************************************
\begin{code}
instance Show Integer where
showsPrec p n r
| p > 6 && n < 0 = '(' : jtos n (')' : r)
- -- Minor point: testing p first gives better code
- -- in the not-uncommon case where the p argument
- -- is a constant
+ -- Minor point: testing p first gives better code
+ -- in the not-uncommon case where the p argument
+ -- is a constant
| otherwise = jtos n r
showList = showList__ (showsPrec 0)
-----------------------------------------------------------------------------
-- #hide
-module GHC.Read
+module GHC.Read
( Read(..) -- class
-
+
-- ReadS type
, ReadS -- :: *; = String -> [(a,String)]
-
+
-- utility functions
, reads -- :: Read a => ReadS a
, readp -- :: Read a => ReadP a
, read -- :: Read a => String -> a
-- H98 compatibility
- , lex -- :: ReadS String
- , lexLitChar -- :: ReadS String
- , readLitChar -- :: ReadS Char
- , lexDigits -- :: ReadS String
-
+ , lex -- :: ReadS String
+ , lexLitChar -- :: ReadS String
+ , readLitChar -- :: ReadS Char
+ , lexDigits -- :: ReadS String
+
-- defining readers
, lexP -- :: ReadPrec Lexeme
, paren -- :: ReadPrec a -> ReadPrec a
import Data.Either
#ifndef __HADDOCK__
-import {-# SOURCE #-} GHC.Unicode ( isDigit )
+import {-# SOURCE #-} GHC.Unicode ( isDigit )
#endif
import GHC.Num
import GHC.Real
readParen b g = if b then mandatory else optional
where optional r = g r ++ mandatory r
mandatory r = do
- ("(",s) <- lex r
- (x,t) <- optional s
- (")",u) <- lex t
- return (x,u)
+ ("(",s) <- lex r
+ (x,t) <- optional s
+ (")",u) <- lex t
+ return (x,u)
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{The @Read@ class}
-%* *
+%* *
%*********************************************************
\begin{code}
-- 'Text.Show.showsPrec', and delivers the value that
-- 'Text.Show.showsPrec' started with.
- readsPrec :: Int -- ^ the operator precedence of the enclosing
- -- context (a number from @0@ to @11@).
- -- Function application has precedence @10@.
- -> ReadS a
+ readsPrec :: Int -- ^ the operator precedence of the enclosing
+ -- context (a number from @0@ to @11@).
+ -- Function application has precedence @10@.
+ -> ReadS a
-- | The method 'readList' is provided to allow the programmer to
-- give a specialised way of parsing lists of values.
readEither s =
case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
[x] -> Right x
- [] -> Left "Prelude.read: no parse"
- _ -> Left "Prelude.read: ambiguous parse"
+ [] -> Left "Prelude.read: no parse"
+ _ -> Left "Prelude.read: ambiguous parse"
where
read' =
do x <- readPrec
-- * Octal and hexadecimal numerics are not recognized as a single token
--
-- * Comments are not treated properly
-lex :: ReadS String -- As defined by H98
+lex :: ReadS String -- As defined by H98
lex s = readP_to_S L.hsLex s
-- | Read a string representation of a character, using Haskell
--
-- > lexLitChar "\\nHello" = [("\\n", "Hello")]
--
-lexLitChar :: ReadS String -- As defined by H98
+lexLitChar :: ReadS String -- As defined by H98
lexLitChar = readP_to_S (do { (s, _) <- P.gather L.lexChar ;
- return s })
- -- There was a skipSpaces before the P.gather L.lexChar,
- -- but that seems inconsistent with readLitChar
+ return s })
+ -- There was a skipSpaces before the P.gather L.lexChar,
+ -- but that seems inconsistent with readLitChar
-- | Read a string representation of a character, using Haskell
-- source-language escape conventions, and convert it to the character
--
-- > readLitChar "\\nHello" = [('\n', "Hello")]
--
-readLitChar :: ReadS Char -- As defined by H98
+readLitChar :: ReadS Char -- As defined by H98
readLitChar = readP_to_S L.lexChar
-- | Reads a non-empty string of decimal digits.
paren :: ReadPrec a -> ReadPrec a
-- ^ @(paren p)@ parses \"(P0)\"
--- where @p@ parses \"P0\" in precedence context zero
+-- where @p@ parses \"P0\" in precedence context zero
paren p = do L.Punc "(" <- lexP
- x <- reset p
- L.Punc ")" <- lexP
- return x
+ x <- reset p
+ L.Punc ")" <- lexP
+ return x
parens :: ReadPrec a -> ReadPrec a
-- ^ @(parens p)@ parses \"P\", \"(P0)\", \"((P0))\", etc,
--- where @p@ parses \"P\" in the current precedence context
--- and parses \"P0\" in precedence context zero
+-- where @p@ parses \"P\" in the current precedence context
+-- and parses \"P0\" in precedence context zero
parens p = optional
where
optional = p +++ mandatory
-- Esp useful for nullary constructors; e.g.
-- @choose [(\"A\", return A), (\"B\", return B)]@
choose sps = foldr ((+++) . try_one) pfail sps
- where
- try_one (s,p) = do { L.Ident s' <- lexP ;
- if s == s' then p else pfail }
+ where
+ try_one (s,p) = do { L.Ident s' <- lexP ;
+ if s == s' then p else pfail }
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Simple instances of Read}
-%* *
+%* *
%*********************************************************
\begin{code}
readListPrec =
parens
- ( do L.String s <- lexP -- Looks for "foo"
+ ( do L.String s <- lexP -- Looks for "foo"
return s
+++
- readListPrecDefault -- Looks for ['f','o','o']
- ) -- (more generous than H98 spec)
+ readListPrecDefault -- Looks for ['f','o','o']
+ ) -- (more generous than H98 spec)
readList = readListDefault
%*********************************************************
-%* *
+%* *
\subsection{Structure instances of Read: Maybe, List etc}
-%* *
+%* *
%*********************************************************
For structured instances of Read we start using the precedences. The
return Nothing
+++
prec appPrec (
- do L.Ident "Just" <- lexP
+ do L.Ident "Just" <- lexP
x <- step readPrec
return (Just x))
)
instance (Ix a, Read a, Read b) => Read (Array a b) where
readPrec = parens $ prec appPrec $
- do L.Ident "array" <- lexP
- bounds <- step readPrec
- vals <- step readPrec
- return (array bounds vals)
+ do L.Ident "array" <- lexP
+ bounds <- step readPrec
+ vals <- step readPrec
+ return (array bounds vals)
readListPrec = readListPrecDefault
readList = readListDefault
%*********************************************************
-%* *
+%* *
\subsection{Numeric instances of Read}
-%* *
+%* *
%*********************************************************
\begin{code}
%*********************************************************
-%* *
- Tuple instances of Read, up to size 15
-%* *
+%* *
+ Tuple instances of Read, up to size 15
+%* *
%*********************************************************
\begin{code}
read_tup2 :: (Read a, Read b) => ReadPrec (a,b)
-- Reads "a , b" no parens!
read_tup2 = do x <- readPrec
- read_comma
- y <- readPrec
- return (x,y)
+ read_comma
+ y <- readPrec
+ return (x,y)
read_tup4 :: (Read a, Read b, Read c, Read d) => ReadPrec (a,b,c,d)
-read_tup4 = do (a,b) <- read_tup2
- read_comma
- (c,d) <- read_tup2
- return (a,b,c,d)
+read_tup4 = do (a,b) <- read_tup2
+ read_comma
+ (c,d) <- read_tup2
+ return (a,b,c,d)
read_tup8 :: (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)
- => ReadPrec (a,b,c,d,e,f,g,h)
-read_tup8 = do (a,b,c,d) <- read_tup4
- read_comma
- (e,f,g,h) <- read_tup4
- return (a,b,c,d,e,f,g,h)
+ => ReadPrec (a,b,c,d,e,f,g,h)
+read_tup8 = do (a,b,c,d) <- read_tup4
+ read_comma
+ (e,f,g,h) <- read_tup4
+ return (a,b,c,d,e,f,g,h)
instance (Read a, Read b, Read c) => Read (a, b, c) where
readPrec = wrap_tup (do { (a,b) <- read_tup2; read_comma
- ; c <- readPrec
- ; return (a,b,c) })
+ ; c <- readPrec
+ ; return (a,b,c) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
- ; e <- readPrec
- ; return (a,b,c,d,e) })
+ ; e <- readPrec
+ ; return (a,b,c,d,e) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f)
- => Read (a, b, c, d, e, f) where
+ => Read (a, b, c, d, e, f) where
readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
- ; (e,f) <- read_tup2
- ; return (a,b,c,d,e,f) })
+ ; (e,f) <- read_tup2
+ ; return (a,b,c,d,e,f) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g)
- => Read (a, b, c, d, e, f, g) where
+ => Read (a, b, c, d, e, f, g) where
readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
- ; (e,f) <- read_tup2; read_comma
- ; g <- readPrec
- ; return (a,b,c,d,e,f,g) })
+ ; (e,f) <- read_tup2; read_comma
+ ; g <- readPrec
+ ; return (a,b,c,d,e,f,g) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)
- => Read (a, b, c, d, e, f, g, h) where
+ => Read (a, b, c, d, e, f, g, h) where
readPrec = wrap_tup read_tup8
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i)
- => Read (a, b, c, d, e, f, g, h, i) where
+ Read i)
+ => Read (a, b, c, d, e, f, g, h, i) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; i <- readPrec
- ; return (a,b,c,d,e,f,g,h,i) })
+ ; i <- readPrec
+ ; return (a,b,c,d,e,f,g,h,i) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j)
- => Read (a, b, c, d, e, f, g, h, i, j) where
+ Read i, Read j)
+ => Read (a, b, c, d, e, f, g, h, i, j) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j) <- read_tup2
- ; return (a,b,c,d,e,f,g,h,i,j) })
+ ; (i,j) <- read_tup2
+ ; return (a,b,c,d,e,f,g,h,i,j) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j, Read k)
- => Read (a, b, c, d, e, f, g, h, i, j, k) where
+ Read i, Read j, Read k)
+ => Read (a, b, c, d, e, f, g, h, i, j, k) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j) <- read_tup2; read_comma
- ; k <- readPrec
- ; return (a,b,c,d,e,f,g,h,i,j,k) })
+ ; (i,j) <- read_tup2; read_comma
+ ; k <- readPrec
+ ; return (a,b,c,d,e,f,g,h,i,j,k) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j, Read k, Read l)
- => Read (a, b, c, d, e, f, g, h, i, j, k, l) where
+ Read i, Read j, Read k, Read l)
+ => Read (a, b, c, d, e, f, g, h, i, j, k, l) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j,k,l) <- read_tup4
- ; return (a,b,c,d,e,f,g,h,i,j,k,l) })
+ ; (i,j,k,l) <- read_tup4
+ ; return (a,b,c,d,e,f,g,h,i,j,k,l) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j, Read k, Read l, Read m)
- => Read (a, b, c, d, e, f, g, h, i, j, k, l, m) where
+ Read i, Read j, Read k, Read l, Read m)
+ => Read (a, b, c, d, e, f, g, h, i, j, k, l, m) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j,k,l) <- read_tup4; read_comma
- ; m <- readPrec
- ; return (a,b,c,d,e,f,g,h,i,j,k,l,m) })
+ ; (i,j,k,l) <- read_tup4; read_comma
+ ; m <- readPrec
+ ; return (a,b,c,d,e,f,g,h,i,j,k,l,m) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j, Read k, Read l, Read m, Read n)
- => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where
+ Read i, Read j, Read k, Read l, Read m, Read n)
+ => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j,k,l) <- read_tup4; read_comma
- ; (m,n) <- read_tup2
- ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n) })
+ ; (i,j,k,l) <- read_tup4; read_comma
+ ; (m,n) <- read_tup2
+ ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
- Read i, Read j, Read k, Read l, Read m, Read n, Read o)
- => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where
+ Read i, Read j, Read k, Read l, Read m, Read n, Read o)
+ => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
- ; (i,j,k,l) <- read_tup4; read_comma
- ; (m,n) <- read_tup2; read_comma
- ; o <- readPrec
- ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) })
+ ; (i,j,k,l) <- read_tup4; read_comma
+ ; (m,n) <- read_tup2; read_comma
+ ; o <- readPrec
+ ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) })
readListPrec = readListPrecDefault
readList = readListDefault
\end{code}
infixl 7 /, `quot`, `rem`, `div`, `mod`
infixl 7 %
-default () -- Double isn't available yet,
- -- and we shouldn't be using defaults anyway
+default () -- Double isn't available yet,
+ -- and we shouldn't be using defaults anyway
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{The @Ratio@ and @Rational@ types}
-%* *
+%* *
%*********************************************************
\begin{code}
-- | Rational numbers, with numerator and denominator of some 'Integral' type.
-data (Integral a) => Ratio a = !a :% !a deriving (Eq)
+data (Integral a) => Ratio a = !a :% !a deriving (Eq)
-- | Arbitrary-precision rational numbers, represented as a ratio of
-- two 'Integer' values. A rational number may be constructed using
-- the '%' operator.
-type Rational = Ratio Integer
+type Rational = Ratio Integer
ratioPrec, ratioPrec1 :: Int
-ratioPrec = 7 -- Precedence of ':%' constructor
+ratioPrec = 7 -- Precedence of ':%' constructor
ratioPrec1 = ratioPrec + 1
infinity, notANumber :: Rational
\begin{code}
-- | Forms the ratio of two integral numbers.
{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-}
-(%) :: (Integral a) => a -> a -> Ratio a
+(%) :: (Integral a) => a -> a -> Ratio a
-- | Extract the numerator of the ratio in reduced form:
-- the numerator and denominator have no common factor and the denominator
-- is positive.
-numerator :: (Integral a) => Ratio a -> a
+numerator :: (Integral a) => Ratio a -> a
-- | Extract the denominator of the ratio in reduced form:
-- the numerator and denominator have no common factor and the denominator
-- is positive.
-denominator :: (Integral a) => Ratio a -> a
+denominator :: (Integral a) => Ratio a -> a
\end{code}
\tr{reduce} is a subsidiary function used only in this module .
\begin{code}
reduce :: (Integral a) => a -> a -> Ratio a
{-# SPECIALISE reduce :: Integer -> Integer -> Rational #-}
-reduce _ 0 = error "Ratio.%: zero denominator"
-reduce x y = (x `quot` d) :% (y `quot` d)
- where d = gcd x y
+reduce _ 0 = error "Ratio.%: zero denominator"
+reduce x y = (x `quot` d) :% (y `quot` d)
+ where d = gcd x y
\end{code}
\begin{code}
-x % y = reduce (x * signum y) (abs y)
+x % y = reduce (x * signum y) (abs y)
-numerator (x :% _) = x
-denominator (_ :% y) = y
+numerator (x :% _) = x
+denominator (_ :% y) = y
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Standard numeric classes}
-%* *
+%* *
%*********************************************************
\begin{code}
class (Num a, Ord a) => Real a where
-- | the rational equivalent of its real argument with full precision
- toRational :: a -> Rational
+ toRational :: a -> Rational
-- | Integral numbers, supporting integer division.
--
-- Minimal complete definition: 'quotRem' and 'toInteger'
class (Real a, Enum a) => Integral a where
-- | integer division truncated toward zero
- quot :: a -> a -> a
+ quot :: a -> a -> a
-- | integer remainder, satisfying
--
-- > (x `quot` y)*y + (x `rem` y) == x
- rem :: a -> a -> a
+ rem :: a -> a -> a
-- | integer division truncated toward negative infinity
- div :: a -> a -> a
+ div :: a -> a -> a
-- | integer modulus, satisfying
--
-- > (x `div` y)*y + (x `mod` y) == x
- mod :: a -> a -> a
+ mod :: a -> a -> a
-- | simultaneous 'quot' and 'rem'
- quotRem :: a -> a -> (a,a)
+ quotRem :: a -> a -> (a,a)
-- | simultaneous 'div' and 'mod'
- divMod :: a -> a -> (a,a)
+ divMod :: a -> a -> (a,a)
-- | conversion to 'Integer'
- toInteger :: a -> Integer
+ toInteger :: a -> Integer
- n `quot` d = q where (q,_) = quotRem n d
- n `rem` d = r where (_,r) = quotRem n d
- n `div` d = q where (q,_) = divMod n d
- n `mod` d = r where (_,r) = divMod n d
- divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr
- where qr@(q,r) = quotRem n d
+ n `quot` d = q where (q,_) = quotRem n d
+ n `rem` d = r where (_,r) = quotRem n d
+ n `div` d = q where (q,_) = divMod n d
+ n `mod` d = r where (_,r) = divMod n d
+ divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr
+ where qr@(q,r) = quotRem n d
-- | Fractional numbers, supporting real division.
--
-- Minimal complete definition: 'fromRational' and ('recip' or @('/')@)
class (Num a) => Fractional a where
-- | fractional division
- (/) :: a -> a -> a
+ (/) :: a -> a -> a
-- | reciprocal fraction
- recip :: a -> a
+ recip :: a -> a
-- | Conversion from a 'Rational' (that is @'Ratio' 'Integer'@).
-- A floating literal stands for an application of 'fromRational'
-- to a value of type 'Rational', so such literals have type
-- @('Fractional' a) => a@.
- fromRational :: Rational -> a
+ fromRational :: Rational -> a
- recip x = 1 / x
- x / y = x * recip y
+ recip x = 1 / x
+ x / y = x * recip y
-- | Extracting components of fractions.
--
--
-- The default definitions of the 'ceiling', 'floor', 'truncate'
-- and 'round' functions are in terms of 'properFraction'.
- properFraction :: (Integral b) => a -> (b,a)
+ properFraction :: (Integral b) => a -> (b,a)
-- | @'truncate' x@ returns the integer nearest @x@ between zero and @x@
- truncate :: (Integral b) => a -> b
+ truncate :: (Integral b) => a -> b
-- | @'round' x@ returns the nearest integer to @x@
- round :: (Integral b) => a -> b
+ round :: (Integral b) => a -> b
-- | @'ceiling' x@ returns the least integer not less than @x@
- ceiling :: (Integral b) => a -> b
+ ceiling :: (Integral b) => a -> b
-- | @'floor' x@ returns the greatest integer not greater than @x@
- floor :: (Integral b) => a -> b
+ floor :: (Integral b) => a -> b
- truncate x = m where (m,_) = properFraction x
+ truncate x = m where (m,_) = properFraction x
- round x = let (n,r) = properFraction x
- m = if r < 0 then n - 1 else n + 1
- in case signum (abs r - 0.5) of
- -1 -> n
- 0 -> if even n then n else m
- 1 -> m
+ round x = let (n,r) = properFraction x
+ m = if r < 0 then n - 1 else n + 1
+ in case signum (abs r - 0.5) of
+ -1 -> n
+ 0 -> if even n then n else m
+ 1 -> m
- ceiling x = if r > 0 then n + 1 else n
- where (n,r) = properFraction x
+ ceiling x = if r > 0 then n + 1 else n
+ where (n,r) = properFraction x
- floor x = if r < 0 then n - 1 else n
- where (n,r) = properFraction x
+ floor x = if r < 0 then n - 1 else n
+ where (n,r) = properFraction x
\end{code}
These 'numeric' enumerations come straight from the Report
\begin{code}
-numericEnumFrom :: (Fractional a) => a -> [a]
-numericEnumFrom = iterate (+1)
+numericEnumFrom :: (Fractional a) => a -> [a]
+numericEnumFrom = iterate (+1)
-numericEnumFromThen :: (Fractional a) => a -> a -> [a]
-numericEnumFromThen n m = iterate (+(m-n)) n
+numericEnumFromThen :: (Fractional a) => a -> a -> [a]
+numericEnumFromThen n m = iterate (+(m-n)) n
numericEnumFromTo :: (Ord a, Fractional a) => a -> a -> [a]
numericEnumFromTo n m = takeWhile (<= m + 1/2) (numericEnumFrom n)
numericEnumFromThenTo :: (Ord a, Fractional a) => a -> a -> a -> [a]
numericEnumFromThenTo e1 e2 e3 = takeWhile pred (numericEnumFromThen e1 e2)
- where
- mid = (e2 - e1) / 2
- pred | e2 >= e1 = (<= e3 + mid)
- | otherwise = (>= e3 + mid)
+ where
+ mid = (e2 - e1) / 2
+ pred | e2 >= e1 = (<= e3 + mid)
+ | otherwise = (>= e3 + mid)
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Instances for @Int@}
-%* *
+%* *
%*********************************************************
\begin{code}
instance Real Int where
- toRational x = toInteger x % 1
+ toRational x = toInteger x % 1
-instance Integral Int where
+instance Integral Int where
toInteger i = int2Integer i -- give back a full-blown Integer
a `quot` b
%*********************************************************
-%* *
+%* *
\subsection{Instances for @Integer@}
-%* *
+%* *
%*********************************************************
\begin{code}
instance Real Integer where
- toRational x = x % 1
+ toRational x = x % 1
instance Integral Integer where
- toInteger n = n
+ toInteger n = n
a `quot` 0 = divZeroError
n `quot` d = n `quotInteger` d
%*********************************************************
-%* *
+%* *
\subsection{Instances for @Ratio@}
-%* *
+%* *
%*********************************************************
\begin{code}
-instance (Integral a) => Ord (Ratio a) where
+instance (Integral a) => Ord (Ratio a) where
{-# SPECIALIZE instance Ord Rational #-}
- (x:%y) <= (x':%y') = x * y' <= x' * y
- (x:%y) < (x':%y') = x * y' < x' * y
+ (x:%y) <= (x':%y') = x * y' <= x' * y
+ (x:%y) < (x':%y') = x * y' < x' * y
-instance (Integral a) => Num (Ratio a) where
+instance (Integral a) => Num (Ratio a) where
{-# SPECIALIZE instance Num Rational #-}
- (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
- (x:%y) - (x':%y') = reduce (x*y' - x'*y) (y*y')
- (x:%y) * (x':%y') = reduce (x * x') (y * y')
- negate (x:%y) = (-x) :% y
- abs (x:%y) = abs x :% y
- signum (x:%_) = signum x :% 1
- fromInteger x = fromInteger x :% 1
-
-instance (Integral a) => Fractional (Ratio a) where
+ (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
+ (x:%y) - (x':%y') = reduce (x*y' - x'*y) (y*y')
+ (x:%y) * (x':%y') = reduce (x * x') (y * y')
+ negate (x:%y) = (-x) :% y
+ abs (x:%y) = abs x :% y
+ signum (x:%_) = signum x :% 1
+ fromInteger x = fromInteger x :% 1
+
+instance (Integral a) => Fractional (Ratio a) where
{-# SPECIALIZE instance Fractional Rational #-}
- (x:%y) / (x':%y') = (x*y') % (y*x')
- recip (x:%y) = y % x
+ (x:%y) / (x':%y') = (x*y') % (y*x')
+ recip (x:%y) = y % x
fromRational (x:%y) = fromInteger x :% fromInteger y
-instance (Integral a) => Real (Ratio a) where
+instance (Integral a) => Real (Ratio a) where
{-# SPECIALIZE instance Real Rational #-}
- toRational (x:%y) = toInteger x :% toInteger y
+ toRational (x:%y) = toInteger x :% toInteger y
-instance (Integral a) => RealFrac (Ratio a) where
+instance (Integral a) => RealFrac (Ratio a) where
{-# SPECIALIZE instance RealFrac Rational #-}
properFraction (x:%y) = (fromInteger (toInteger q), r:%y)
- where (q,r) = quotRem x y
+ where (q,r) = quotRem x y
instance (Integral a) => Show (Ratio a) where
{-# SPECIALIZE instance Show Rational #-}
- showsPrec p (x:%y) = showParen (p > ratioPrec) $
- showsPrec ratioPrec1 x .
- showString "%" . -- H98 report has spaces round the %
- -- but we removed them [May 04]
- showsPrec ratioPrec1 y
+ showsPrec p (x:%y) = showParen (p > ratioPrec) $
+ showsPrec ratioPrec1 x .
+ showString "%" . -- H98 report has spaces round the %
+ -- but we removed them [May 04]
+ showsPrec ratioPrec1 y
-instance (Integral a) => Enum (Ratio a) where
+instance (Integral a) => Enum (Ratio a) where
{-# SPECIALIZE instance Enum Rational #-}
- succ x = x + 1
- pred x = x - 1
+ succ x = x + 1
+ pred x = x - 1
toEnum n = fromInteger (int2Integer n) :% 1
fromEnum = fromInteger . truncate
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo = numericEnumFromTo
- enumFromThenTo = numericEnumFromThenTo
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo = numericEnumFromTo
+ enumFromThenTo = numericEnumFromThenTo
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Coercions}
-%* *
+%* *
%*********************************************************
\begin{code}
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Overloaded numeric functions}
-%* *
+%* *
%*********************************************************
\begin{code}
-- | Converts a possibly-negative 'Real' value to a string.
showSigned :: (Real a)
- => (a -> ShowS) -- ^ a function that can show unsigned values
- -> Int -- ^ the precedence of the enclosing context
- -> a -- ^ the value to show
+ => (a -> ShowS) -- ^ a function that can show unsigned values
+ -> Int -- ^ the precedence of the enclosing context
+ -> a -- ^ the value to show
-> ShowS
showSigned showPos p x
| x < 0 = showParen (p > 6) (showChar '-' . showPos (-x))
| otherwise = showPos x
-even, odd :: (Integral a) => a -> Bool
-even n = n `rem` 2 == 0
-odd = not . even
+even, odd :: (Integral a) => a -> Bool
+even n = n `rem` 2 == 0
+odd = not . even
-------------------------------------------------------
-- | raise a number to a non-negative integral power
{-# SPECIALISE (^) ::
- Integer -> Integer -> Integer,
- Integer -> Int -> Integer,
- Int -> Int -> Int #-}
-(^) :: (Num a, Integral b) => a -> b -> a
-_ ^ 0 = 1
-x ^ n | n > 0 = f x (n-1) x
- where f _ 0 y = y
- f a d y = g a d where
- g b i | even i = g (b*b) (i `quot` 2)
- | otherwise = f b (i-1) (b*y)
-_ ^ _ = error "Prelude.^: negative exponent"
+ Integer -> Integer -> Integer,
+ Integer -> Int -> Integer,
+ Int -> Int -> Int #-}
+(^) :: (Num a, Integral b) => a -> b -> a
+_ ^ 0 = 1
+x ^ n | n > 0 = f x (n-1) x
+ where f _ 0 y = y
+ f a d y = g a d where
+ g b i | even i = g (b*b) (i `quot` 2)
+ | otherwise = f b (i-1) (b*y)
+_ ^ _ = error "Prelude.^: negative exponent"
-- | raise a number to an integral power
{-# SPECIALISE (^^) ::
- Rational -> Int -> Rational #-}
-(^^) :: (Fractional a, Integral b) => a -> b -> a
-x ^^ n = if n >= 0 then x^n else recip (x^(negate n))
+ Rational -> Int -> Rational #-}
+(^^) :: (Fractional a, Integral b) => a -> b -> a
+x ^^ n = if n >= 0 then x^n else recip (x^(negate n))
-------------------------------------------------------
-- | @'gcd' x y@ is the greatest (positive) integer that divides both @x@
-- and @y@; for example @'gcd' (-3) 6@ = @3@, @'gcd' (-3) (-6)@ = @3@,
-- @'gcd' 0 4@ = @4@. @'gcd' 0 0@ raises a runtime error.
-gcd :: (Integral a) => a -> a -> a
-gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
-gcd x y = gcd' (abs x) (abs y)
- where gcd' a 0 = a
- gcd' a b = gcd' b (a `rem` b)
+gcd :: (Integral a) => a -> a -> a
+gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
+gcd x y = gcd' (abs x) (abs y)
+ where gcd' a 0 = a
+ gcd' a b = gcd' b (a `rem` b)
-- | @'lcm' x y@ is the smallest positive integer that both @x@ and @y@ divide.
-lcm :: (Integral a) => a -> a -> a
+lcm :: (Integral a) => a -> a -> a
{-# SPECIALISE lcm :: Int -> Int -> Int #-}
-lcm _ 0 = 0
-lcm 0 _ = 0
-lcm x y = abs ((x `quot` (gcd x y)) * y)
+lcm _ 0 = 0
+lcm 0 _ = 0
+lcm x y = abs ((x `quot` (gcd x y)) * y)
{-# RULES
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{The @ST@ monad}
-%* *
+%* *
%*********************************************************
The state-transformer monad proper. By default the monad is strict;
(ST m) >>= k
= ST (\ s ->
- case (m s) of { (# new_s, r #) ->
- case (k r) of { ST k2 ->
- (k2 new_s) }})
+ case (m s) of { (# new_s, r #) ->
+ case (k r) of { ST k2 ->
+ (k2 new_s) }})
data STret s a = STret (State# s) a
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST (ST m) = ST ( \ s ->
let
- r = case m s of (# _, res #) -> res
+ r = case m s of (# _, res #) -> res
in
(# s, r #)
)
fixST :: (a -> ST s a) -> ST s a
fixST k = ST $ \ s ->
let ans = liftST (k r) s
- STret _ r = ans
+ STret _ r = ans
in
case ans of STret s' x -> (# s', x #)
instance Show (ST s a) where
showsPrec _ _ = showString "<<ST action>>"
- showList = showList__ (showsPrec 0)
+ showList = showList__ (showsPrec 0)
\end{code}
Definition of runST
\begin{verbatim}
f x =
runST ( \ s -> let
- (a, s') = newArray# 100 [] s
- (_, s'') = fill_in_array_or_something a x s'
- in
- freezeArray# a s'' )
+ (a, s') = newArray# 100 [] s
+ (_, s'') = fill_in_array_or_something a x s'
+ in
+ freezeArray# a s'' )
\end{verbatim}
If we inline @runST@, we'll get:
\begin{verbatim}
f x = let
- (a, s') = newArray# 100 [] realWorld#{-NB-}
- (_, s'') = fill_in_array_or_something a x s'
+ (a, s') = newArray# 100 [] realWorld#{-NB-}
+ (_, s'') = fill_in_array_or_something a x s'
in
freezeArray# a s''
\end{verbatim}
(a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
in
\ x ->
- let (_, s'') = fill_in_array_or_something a x s' in
- freezeArray# a s''
+ let (_, s'') = fill_in_array_or_something a x s' in
+ freezeArray# a s''
\end{verbatim}
All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
-- I'm only letting runSTRep be inlined right at the end, in particular *after* full laziness
-- That's what the "INLINE [0]" says.
--- SLPJ Apr 99
+-- SLPJ Apr 99
-- {-# INLINE [0] runSTRep #-}
-- SDM: further to the above, inline phase 0 is run *before*
{-# NOINLINE runSTRep #-}
runSTRep :: (forall s. STRep s a) -> a
runSTRep st_rep = case st_rep realWorld# of
- (# _, r #) -> r
+ (# _, r #) -> r
\end{code}
-- #hide
module GHC.Show
- (
- Show(..), ShowS,
+ (
+ Show(..), ShowS,
- -- Instances for Show: (), [], Bool, Ordering, Int, Char
+ -- Instances for Show: (), [], Bool, Ordering, Int, Char
- -- Show support code
- shows, showChar, showString, showParen, showList__, showSpace,
- showLitChar, protectEsc,
- intToDigit, showSignedInt,
- appPrec, appPrec1,
+ -- Show support code
+ shows, showChar, showString, showParen, showList__, showSpace,
+ showLitChar, protectEsc,
+ intToDigit, showSignedInt,
+ appPrec, appPrec1,
- -- Character operations
- asciiTab,
- )
- where
+ -- Character operations
+ asciiTab,
+ )
+ where
import GHC.Base
import Data.Maybe
import Data.Either
-import GHC.List ( (!!), foldr1
+import GHC.List ( (!!), foldr1
#ifdef USE_REPORT_PRELUDE
, concatMap
#endif
%*********************************************************
-%* *
+%* *
\subsection{The @Show@ class}
-%* *
+%* *
%*********************************************************
\begin{code}
-- That is, 'Text.Read.readsPrec' parses the string produced by
-- 'showsPrec', and delivers the value that 'showsPrec' started with.
- showsPrec :: Int -- ^ the operator precedence of the enclosing
- -- context (a number from @0@ to @11@).
- -- Function application has precedence @10@.
- -> a -- ^ the value to be converted to a 'String'
- -> ShowS
+ showsPrec :: Int -- ^ the operator precedence of the enclosing
+ -- context (a number from @0@ to @11@).
+ -- Function application has precedence @10@.
+ -> a -- ^ the value to be converted to a 'String'
+ -> ShowS
-- | A specialised variant of 'showsPrec', using precedence context
-- zero, and returning an ordinary 'String'.
showl (y:ys) = ',' : showx y (showl ys)
appPrec, appPrec1 :: Int
- -- Use unboxed stuff because we don't have overloaded numerics yet
-appPrec = I# 10# -- Precedence of application:
- -- one more than the maximum operator precedence of 9
-appPrec1 = I# 11# -- appPrec + 1
+ -- Use unboxed stuff because we don't have overloaded numerics yet
+appPrec = I# 10# -- Precedence of application:
+ -- one more than the maximum operator precedence of 9
+appPrec1 = I# 11# -- appPrec + 1
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Simple Instances}
-%* *
+%* *
%*********************************************************
\begin{code}
showsPrec _ c = showChar '\'' . showLitChar c . showChar '\''
showList cs = showChar '"' . showl cs
- where showl "" s = showChar '"' s
- showl ('"':xs) s = showString "\\\"" (showl xs s)
- showl (x:xs) s = showLitChar x (showl xs s)
- -- Making 's' an explicit parameter makes it clear to GHC
- -- that showl has arity 2, which avoids it allocating an extra lambda
- -- The sticking point is the recursive call to (showl xs), which
- -- it can't figure out would be ok with arity 2.
+ where showl "" s = showChar '"' s
+ showl ('"':xs) s = showString "\\\"" (showl xs s)
+ showl (x:xs) s = showLitChar x (showl xs s)
+ -- Making 's' an explicit parameter makes it clear to GHC
+ -- that showl has arity 2, which avoids it allocating an extra lambda
+ -- The sticking point is the recursive call to (showl xs), which
+ -- it can't figure out would be ok with arity 2.
instance Show Int where
showsPrec = showSignedInt
showsPrec _p Nothing s = showString "Nothing" s
showsPrec p (Just x) s
= (showParen (p > appPrec) $
- showString "Just " .
- showsPrec appPrec1 x) s
+ showString "Just " .
+ showsPrec appPrec1 x) s
instance (Show a, Show b) => Show (Either a b) where
showsPrec p e s =
(showParen (p > appPrec) $
case e of
Left a -> showString "Left " . showsPrec appPrec1 a
- Right b -> showString "Right " . showsPrec appPrec1 b)
+ Right b -> showString "Right " . showsPrec appPrec1 b)
s
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Show instances for the first few tuples
-%* *
+%* *
%*********************************************************
\begin{code}
-- The explicit 's' parameters are important
-- Otherwise GHC thinks that "shows x" might take a lot of work to compute
-- and generates defns like
--- showsPrec _ (x,y) = let sx = shows x; sy = shows y in
--- \s -> showChar '(' (sx (showChar ',' (sy (showChar ')' s))))
+-- showsPrec _ (x,y) = let sx = shows x; sy = shows y in
+-- \s -> showChar '(' (sx (showChar ',' (sy (showChar ')' s))))
instance (Show a, Show b) => Show (a,b) where
showsPrec _ (a,b) s = show_tuple [shows a, shows b] s
showsPrec _ (a,b,c,d,e,f) s = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f] s
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g)
- => Show (a,b,c,d,e,f,g) where
+ => Show (a,b,c,d,e,f,g) where
showsPrec _ (a,b,c,d,e,f,g) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] s
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h)
- => Show (a,b,c,d,e,f,g,h) where
+ => Show (a,b,c,d,e,f,g,h) where
showsPrec _ (a,b,c,d,e,f,g,h) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h] s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h] s
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i)
- => Show (a,b,c,d,e,f,g,h,i) where
+ => Show (a,b,c,d,e,f,g,h,i) where
showsPrec _ (a,b,c,d,e,f,g,h,i) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i] s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
+ shows i] s
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j)
- => Show (a,b,c,d,e,f,g,h,i,j) where
+ => Show (a,b,c,d,e,f,g,h,i,j) where
showsPrec _ (a,b,c,d,e,f,g,h,i,j) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j] s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
+ shows i, shows j] s
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k)
- => Show (a,b,c,d,e,f,g,h,i,j,k) where
+ => Show (a,b,c,d,e,f,g,h,i,j,k) where
showsPrec _ (a,b,c,d,e,f,g,h,i,j,k) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j, shows k] s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
+ shows i, shows j, shows k] s
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
- Show l)
- => Show (a,b,c,d,e,f,g,h,i,j,k,l) where
+ Show l)
+ => Show (a,b,c,d,e,f,g,h,i,j,k,l) where
showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j, shows k, shows l] s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
+ shows i, shows j, shows k, shows l] s
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
- Show l, Show m)
- => Show (a,b,c,d,e,f,g,h,i,j,k,l,m) where
+ Show l, Show m)
+ => Show (a,b,c,d,e,f,g,h,i,j,k,l,m) where
showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j, shows k, shows l, shows m] s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
+ shows i, shows j, shows k, shows l, shows m] s
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
- Show l, Show m, Show n)
- => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
+ Show l, Show m, Show n)
+ => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j, shows k, shows l, shows m, shows n] s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
+ shows i, shows j, shows k, shows l, shows m, shows n] s
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
- Show l, Show m, Show n, Show o)
- => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
+ Show l, Show m, Show n, Show o)
+ => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) s
- = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
- shows i, shows j, shows k, shows l, shows m, shows n, shows o] s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
+ shows i, shows j, shows k, shows l, shows m, shows n, shows o] s
show_tuple :: [ShowS] -> ShowS
show_tuple ss = showChar '('
- . foldr1 (\s r -> s . showChar ',' . r) ss
- . showChar ')'
+ . foldr1 (\s r -> s . showChar ',' . r) ss
+ . showChar ')'
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Support code for @Show@}
-%* *
+%* *
%*********************************************************
\begin{code}
--
-- > showLitChar '\n' s = "\\n" ++ s
--
-showLitChar :: Char -> ShowS
+showLitChar :: Char -> ShowS
showLitChar c s | c > '\DEL' = showChar '\\' (protectEsc isDec (shows (ord c)) s)
-showLitChar '\DEL' s = showString "\\DEL" s
-showLitChar '\\' s = showString "\\\\" s
+showLitChar '\DEL' s = showString "\\DEL" s
+showLitChar '\\' s = showString "\\\\" s
showLitChar c s | c >= ' ' = showChar c s
-showLitChar '\a' s = showString "\\a" s
-showLitChar '\b' s = showString "\\b" s
-showLitChar '\f' s = showString "\\f" s
-showLitChar '\n' s = showString "\\n" s
-showLitChar '\r' s = showString "\\r" s
-showLitChar '\t' s = showString "\\t" s
-showLitChar '\v' s = showString "\\v" s
-showLitChar '\SO' s = protectEsc (== 'H') (showString "\\SO") s
-showLitChar c s = showString ('\\' : asciiTab!!ord c) s
- -- I've done manual eta-expansion here, becuase otherwise it's
- -- impossible to stop (asciiTab!!ord) getting floated out as an MFE
+showLitChar '\a' s = showString "\\a" s
+showLitChar '\b' s = showString "\\b" s
+showLitChar '\f' s = showString "\\f" s
+showLitChar '\n' s = showString "\\n" s
+showLitChar '\r' s = showString "\\r" s
+showLitChar '\t' s = showString "\\t" s
+showLitChar '\v' s = showString "\\v" s
+showLitChar '\SO' s = protectEsc (== 'H') (showString "\\SO") s
+showLitChar c s = showString ('\\' : asciiTab!!ord c) s
+ -- I've done manual eta-expansion here, becuase otherwise it's
+ -- impossible to stop (asciiTab!!ord) getting floated out as an MFE
isDec c = c >= '0' && c <= '9'
protectEsc :: (Char -> Bool) -> ShowS -> ShowS
-protectEsc p f = f . cont
- where cont s@(c:_) | p c = "\\&" ++ s
- cont s = s
+protectEsc p f = f . cont
+ where cont s@(c:_) | p c = "\\&" ++ s
+ cont s = s
asciiTab :: [String]
asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ')
- ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
- "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
- "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
- "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
- "SP"]
+ ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
+ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
+ "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
+ "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
+ "SP"]
\end{code}
Code specific for Ints.
intToDigit (I# i)
| i >=# 0# && i <=# 9# = unsafeChr (ord '0' `plusInt` I# i)
| i >=# 10# && i <=# 15# = unsafeChr (ord 'a' `minusInt` ten `plusInt` I# i)
- | otherwise = error ("Char.intToDigit: not a digit " ++ show (I# i))
+ | otherwise = error ("Char.intToDigit: not a digit " ++ show (I# i))
ten = I# 10#
itos :: Int# -> String -> String
itos n# cs
| n# <# 0# =
- let I# minInt# = minInt in
- if n# ==# minInt#
- -- negateInt# minInt overflows, so we can't do that:
- then '-' : itos' (negateInt# (n# `quotInt#` 10#))
+ let I# minInt# = minInt in
+ if n# ==# minInt#
+ -- negateInt# minInt overflows, so we can't do that:
+ then '-' : itos' (negateInt# (n# `quotInt#` 10#))
(itos' (negateInt# (n# `remInt#` 10#)) cs)
- else '-' : itos' (negateInt# n#) cs
+ else '-' : itos' (negateInt# n#) cs
| otherwise = itos' n# cs
where
itos' :: Int# -> String -> String
itos' n# cs
| n# <# 10# = C# (chr# (ord# '0'# +# n#)) : cs
| otherwise = case chr# (ord# '0'# +# (n# `remInt#` 10#)) of { c# ->
- itos' (n# `quotInt#` 10#) (C# c# : cs) }
+ itos' (n# `quotInt#` 10#) (C# c# : cs) }
\end{code}
import GHC.Real (fromIntegral)
import GHC.Int
import GHC.Word
-import GHC.Num (fromInteger)
+import GHC.Num (fromInteger)
#include "HsBaseConfig.h"
-- | Selects the first 128 characters of the Unicode character set,
-- corresponding to the ASCII character set.
isAscii :: Char -> Bool
-isAscii c = c < '\x80'
+isAscii c = c < '\x80'
-- | Selects the first 256 characters of the Unicode character set,
-- corresponding to the ISO 8859-1 (Latin-1) character set.
-- isSpace includes non-breaking space
-- Done with explicit equalities both for efficiency, and to avoid a tiresome
-- recursion with GHC.List elem
-isSpace c = c == ' ' ||
- c == '\t' ||
- c == '\n' ||
- c == '\r' ||
- c == '\f' ||
- c == '\v' ||
- c == '\xa0' ||
- iswspace (fromIntegral (ord c)) /= 0
+isSpace c = c == ' ' ||
+ c == '\t' ||
+ c == '\n' ||
+ c == '\r' ||
+ c == '\f' ||
+ c == '\v' ||
+ c == '\xa0' ||
+ iswspace (fromIntegral (ord c)) /= 0
-- | Selects upper-case or title-case alphabetic Unicode characters (letters).
-- Title case is used by a small number of letter ligatures like the
-- | Selects ASCII digits, i.e. @\'0\'@..@\'9\'@.
isDigit :: Char -> Bool
-isDigit c = c >= '0' && c <= '9'
+isDigit c = c >= '0' && c <= '9'
-- | Selects ASCII octal digits, i.e. @\'0\'@..@\'7\'@.
isOctDigit :: Char -> Bool
-isOctDigit c = c >= '0' && c <= '7'
+isOctDigit c = c >= '0' && c <= '7'
-- | Selects ASCII hexadecimal digits,
-- i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@.
isHexDigit :: Char -> Bool
-isHexDigit c = isDigit c || c >= 'A' && c <= 'F' ||
+isHexDigit c = isDigit c || c >= 'A' && c <= 'F' ||
c >= 'a' && c <= 'f'
-- | Convert a letter to the corresponding upper-case letter, if any.
#else
-isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
-isPrint c = not (isControl c)
+isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
+isPrint c = not (isControl c)
-- The upper case ISO characters have the multiplication sign dumped
-- randomly in the middle of the range. Go figure.
-isUpper c = c >= 'A' && c <= 'Z' ||
+isUpper c = c >= 'A' && c <= 'Z' ||
c >= '\xC0' && c <= '\xD6' ||
c >= '\xD8' && c <= '\xDE'
-- The lower case ISO characters have the division sign dumped
-- randomly in the middle of the range. Go figure.
-isLower c = c >= 'a' && c <= 'z' ||
+isLower c = c >= 'a' && c <= 'z' ||
c >= '\xDF' && c <= '\xF6' ||
c >= '\xF8' && c <= '\xFF'
-isAlpha c = isLower c || isUpper c
-isAlphaNum c = isAlpha c || isDigit c
+isAlpha c = isLower c || isUpper c
+isAlphaNum c = isAlpha c || isDigit c
-- Case-changing operations
| isAsciiLower c = C# (chr# (ord# c# -# 32#))
| isAscii c = c
-- fall-through to the slower stuff.
- | isLower c && c /= '\xDF' && c /= '\xFF'
+ | isLower c && c /= '\xDF' && c /= '\xFF'
= unsafeChr (ord c `minusInt` ord 'a' `plusInt` ord 'A')
| otherwise
= c
toLower c@(C# c#)
| isAsciiUpper c = C# (chr# (ord# c# +# 32#))
| isAscii c = c
- | isUpper c = unsafeChr (ord c `minusInt` ord 'A' `plusInt` ord 'a')
- | otherwise = c
+ | isUpper c = unsafeChr (ord c `minusInt` ord 'A' `plusInt` ord 'a')
+ | otherwise = c
#endif
module GHC.Unicode where
import GHC.Base( Char, Bool )
-isAscii :: Char -> Bool
-isLatin1 :: Char -> Bool
-isControl :: Char -> Bool
-isPrint :: Char -> Bool
-isSpace :: Char -> Bool
-isUpper :: Char -> Bool
-isLower :: Char -> Bool
-isAlpha :: Char -> Bool
-isDigit :: Char -> Bool
-isOctDigit :: Char -> Bool
-isHexDigit :: Char -> Bool
-isAlphaNum :: Char -> Bool
+isAscii :: Char -> Bool
+isLatin1 :: Char -> Bool
+isControl :: Char -> Bool
+isPrint :: Char -> Bool
+isSpace :: Char -> Bool
+isUpper :: Char -> Bool
+isLower :: Char -> Bool
+isAlpha :: Char -> Bool
+isDigit :: Char -> Bool
+isOctDigit :: Char -> Bool
+isHexDigit :: Char -> Bool
+isAlphaNum :: Char -> Bool
| otherwise = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#)))
where
i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))
- wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -}
+ wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -}
bitSize _ = WORD_SIZE_IN_BITS
isSigned _ = False
shiftL64#, shiftRL64# :: Word64# -> Int# -> Word64#
a `shiftL64#` b | b >=# 64# = wordToWord64# (int2Word# 0#)
- | otherwise = a `uncheckedShiftL64#` b
+ | otherwise = a `uncheckedShiftL64#` b
a `shiftRL64#` b | b >=# 64# = wordToWord64# (int2Word# 0#)
- | otherwise = a `uncheckedShiftRL64#` b
+ | otherwise = a `uncheckedShiftRL64#` b
foreign import ccall unsafe "hs_eqWord64" eqWord64# :: Word64# -> Word64# -> Bool
module Text.Read.Lex
-- lexing types
( Lexeme(..) -- :: *; Show, Eq
-
- -- lexer
- , lex -- :: ReadP Lexeme Skips leading spaces
- , hsLex -- :: ReadP String
- , lexChar -- :: ReadP Char Reads just one char, with H98 escapes
-
+
+ -- lexer
+ , lex -- :: ReadP Lexeme Skips leading spaces
+ , hsLex -- :: ReadP String
+ , lexChar -- :: ReadP Char Reads just one char, with H98 escapes
+
, readIntP -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
, readOctP -- :: Num a => ReadP a
, readDecP -- :: Num a => ReadP a
import {-# SOURCE #-} GHC.Unicode ( isSpace, isAlpha, isAlphaNum )
#endif
import GHC.Real( Ratio(..), Integral, Rational, (%), fromIntegral,
- toInteger, (^), (^^), infinity, notANumber )
+ toInteger, (^), (^^), infinity, notANumber )
import GHC.List
import GHC.Enum( maxBound )
#else
-- ^ Haskell lexemes.
data Lexeme
- = Char Char -- ^ Character literal
- | String String -- ^ String literal, with escapes interpreted
- | Punc String -- ^ Punctuation or reserved symbol, e.g. @(@, @::@
- | Ident String -- ^ Haskell identifier, e.g. @foo@, @Baz@
- | Symbol String -- ^ Haskell symbol, e.g. @>>@, @:%@
- | Int Integer -- ^ Integer literal
- | Rat Rational -- ^ Floating point literal
+ = Char Char -- ^ Character literal
+ | String String -- ^ String literal, with escapes interpreted
+ | Punc String -- ^ Punctuation or reserved symbol, e.g. @(@, @::@
+ | Ident String -- ^ Haskell identifier, e.g. @foo@, @Baz@
+ | Symbol String -- ^ Haskell symbol, e.g. @>>@, @:%@
+ | Int Integer -- ^ Integer literal
+ | Rat Rational -- ^ Floating point literal
| EOF
deriving (Eq, Show)
hsLex :: ReadP String
-- ^ Haskell lexer: returns the lexed string, rather than the lexeme
hsLex = do skipSpaces
- (s,_) <- gather lexToken
- return s
+ (s,_) <- gather lexToken
+ return s
lexToken :: ReadP Lexeme
lexToken = lexEOF +++
- lexLitChar +++
- lexString +++
- lexPunc +++
- lexSymbol +++
- lexId +++
- lexNumber
+ lexLitChar +++
+ lexString +++
+ lexPunc +++
+ lexSymbol +++
+ lexId +++
+ lexNumber
-- ----------------------------------------------------------------------
-- End of file
lexEOF :: ReadP Lexeme
lexEOF = do s <- look
- guard (null s)
- return EOF
+ guard (null s)
+ return EOF
-- ---------------------------------------------------------------------------
-- Single character lexemes
lexSymbol =
do s <- munch1 isSymbolChar
if s `elem` reserved_ops then
- return (Punc s) -- Reserved-ops count as punctuation
+ return (Punc s) -- Reserved-ops count as punctuation
else
- return (Symbol s)
+ return (Symbol s)
where
isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
reserved_ops = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]
lexId :: ReadP Lexeme
lexId = lex_nan <++ lex_id
where
- -- NaN and Infinity look like identifiers, so
- -- we parse them first.
+ -- NaN and Infinity look like identifiers, so
+ -- we parse them first.
lex_nan = (string "NaN" >> return (Rat notANumber)) +++
- (string "Infinity" >> return (Rat infinity))
+ (string "Infinity" >> return (Rat infinity))
lex_id = do c <- satisfy isIdsChar
- s <- munch isIdfChar
- return (Ident (c:s))
+ s <- munch isIdfChar
+ return (Ident (c:s))
- -- Identifiers can start with a '_'
+ -- Identifiers can start with a '_'
isIdsChar c = isAlpha c || c == '_'
isIdfChar c = isAlphaNum c || c `elem` "_'"
lexLitChar =
do char '\''
(c,esc) <- lexCharE
- guard (esc || c /= '\'') -- Eliminate '' possibility
+ guard (esc || c /= '\'') -- Eliminate '' possibility
char '\''
return (Char c)
lexAscii =
do choice
[ (string "SOH" >> return '\SOH') <++
- (string "SO" >> return '\SO')
- -- \SO and \SOH need maximal-munch treatment
- -- See the Haskell report Sect 2.6
+ (string "SO" >> return '\SO')
+ -- \SO and \SOH need maximal-munch treatment
+ -- See the Haskell report Sect 2.6
, string "NUL" >> return '\NUL'
, string "STX" >> return '\STX'
if c /= '"' || esc
then body (f.(c:))
else let s = f "" in
- return (String s)
+ return (String s)
lexStrItem = (lexEmpty >> lexStrItem)
- +++ lexCharE
+ +++ lexCharE
lexEmpty =
do char '\\'
lexNumber :: ReadP Lexeme
lexNumber
- = lexHexOct <++ -- First try for hex or octal 0x, 0o etc
- -- If that fails, try for a decimal number
- lexDecNumber -- Start with ordinary digits
-
+ = lexHexOct <++ -- First try for hex or octal 0x, 0o etc
+ -- If that fails, try for a decimal number
+ lexDecNumber -- Start with ordinary digits
+
lexHexOct :: ReadP Lexeme
lexHexOct
- = do char '0'
- base <- lexBaseChar
- digits <- lexDigits base
- return (Int (val (fromIntegral base) 0 digits))
+ = do char '0'
+ base <- lexBaseChar
+ digits <- lexDigits base
+ return (Int (val (fromIntegral base) 0 digits))
lexBaseChar :: ReadP Int
-- Lex a single character indicating the base; fail if not there
lexBaseChar = do { c <- get;
- case c of
- 'o' -> return 8
- 'O' -> return 8
- 'x' -> return 16
- 'X' -> return 16
- _ -> pfail }
+ case c of
+ 'o' -> return 8
+ 'O' -> return 8
+ 'x' -> return 16
+ 'X' -> return 16
+ _ -> pfail }
lexDecNumber :: ReadP Lexeme
lexDecNumber =
value xs mFrac mExp = valueFracExp (val 10 0 xs) mFrac mExp
valueFracExp :: Integer -> Maybe Digits -> Maybe Integer
- -> Lexeme
- valueFracExp a Nothing Nothing
- = Int a -- 43
+ -> Lexeme
+ valueFracExp a Nothing Nothing
+ = Int a -- 43
valueFracExp a Nothing (Just exp)
- | exp >= 0 = Int (a * (10 ^ exp)) -- 43e7
- | otherwise = Rat (valExp (fromInteger a) exp) -- 43e-7
+ | exp >= 0 = Int (a * (10 ^ exp)) -- 43e7
+ | otherwise = Rat (valExp (fromInteger a) exp) -- 43e-7
valueFracExp a (Just fs) mExp
= case mExp of
- Nothing -> Rat rat -- 4.3
- Just exp -> Rat (valExp rat exp) -- 4.3e-4
+ Nothing -> Rat rat -- 4.3
+ Just exp -> Rat (valExp rat exp) -- 4.3e-4
where
- rat :: Rational
- rat = fromInteger a + frac 10 0 1 fs
+ rat :: Rational
+ rat = fromInteger a + frac 10 0 1 fs
valExp :: Rational -> Integer -> Rational
valExp rat exp = rat * (10 ^^ exp)
-- Read the fractional part; fail if it doesn't
-- start ".d" where d is a digit
lexFrac = do char '.'
- frac <- lexDigits 10
- return (Just frac)
+ frac <- lexDigits 10
+ return (Just frac)
lexExp :: ReadP (Maybe Integer)
lexExp = do char 'e' +++ char 'E'
exp <- signedExp +++ lexInteger 10
- return (Just exp)
+ return (Just exp)
where
signedExp
= do c <- char '-' +++ char '+'
projects / ghc-base.git / commitdiff