ref: 418f23827bbdf375c0129a2f4a5ec65435a44c33
dir: /lib/Data/Fixed.hs/
-----------------------------------------------------------------------------
-- |
-- Module : Data.Fixed
-- Copyright : (c) Ashley Yakeley 2005, 2006, 2009
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : Ashley Yakeley <ashley@semantic.org>
-- Stability : stable
-- Portability : portable
-----------------------------------------------------------------------------
module Data.Fixed
( -- * The Fixed Type
Fixed(..), HasResolution(..),
showFixed,
-- ** 1\/1
E0,Uni,
-- ** 1\/10
E1,Deci,
-- ** 1\/100
E2,Centi,
-- ** 1\/1 000
E3,Milli,
-- ** 1\/1 000 000
E6,Micro,
-- ** 1\/1 000 000 000
E9,Nano,
-- ** 1\/1 000 000 000 000
E12,Pico,
-- * Generalized Functions on Real's
div',
mod',
divMod'
) where
import Prelude()
import MiniPrelude
import Data.TypeLits (KnownNat, natVal)
import Text.Read.Internal
import Text.ParserCombinators.ReadPrec
import Text.Read.Lex
import Data.Double
import Data.Floating
import Data.Fractional
import Data.Integer
import Data.Real
import Data.RealFrac
import Data.Typeable
default () -- avoid any defaulting shenanigans
div' :: (Real a,Integral b) => a -> a -> b
div' n d = floor ((toRational n) / (toRational d))
divMod' :: (Real a,Integral b) => a -> a -> (b,a)
divMod' n d = (f,n - (fromIntegral f) * d) where
f = div' n d
mod' :: (Real a) => a -> a -> a
mod' n d = n - (fromInteger f) * d where
f = div' n d
type Fixed :: forall k . k -> Type
newtype Fixed a = MkFixed Integer
deriving ( Eq -- ^ @since 2.01
, Ord -- ^ @since 2.01
)
{-
tyFixed :: DataType
tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
conMkFixed :: Constr
conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
-- | @since 4.1.0.0
instance (Typeable k,Typeable a) => Data (Fixed (a :: k)) where
gfoldl k z (MkFixed a) = k (z MkFixed) a
gunfold k z _ = k (z MkFixed)
dataTypeOf _ = tyFixed
toConstr _ = conMkFixed
-}
type HasResolution :: forall k . k -> Constraint
class HasResolution a where
resolution :: p a -> Integer
instance forall n . KnownNat n => HasResolution n where
resolution _ = natVal (Proxy :: Proxy n)
withType :: (Proxy a -> f a) -> f a
withType foo = foo Proxy
withResolution :: (HasResolution a) => (Integer -> f a) -> f a
withResolution foo = withType (foo . resolution)
instance Enum (Fixed a) where
succ (MkFixed a) = MkFixed (succ a)
pred (MkFixed a) = MkFixed (pred a)
toEnum = MkFixed . toEnum
fromEnum (MkFixed a) = fromEnum a
enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)
enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)
enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)
enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)
instance (HasResolution a) => Num (Fixed a) where
(MkFixed a) + (MkFixed b) = MkFixed (a + b)
(MkFixed a) - (MkFixed b) = MkFixed (a - b)
fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa))
negate (MkFixed a) = MkFixed (negate a)
abs (MkFixed a) = MkFixed (abs a)
signum (MkFixed a) = fromInteger (signum a)
fromInteger i = withResolution (\res -> MkFixed (i * res))
instance (HasResolution a) => Real (Fixed a) where
toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa))
instance (HasResolution a) => Fractional (Fixed a) where
fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b)
recip fa@(MkFixed a) = MkFixed (div (res * res) a) where
res = resolution fa
fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))
instance (HasResolution a) => RealFrac (Fixed a) where
properFraction a = (i,a - (fromIntegral i)) where
i = truncate a
truncate f = truncate (toRational f)
round f = round (toRational f)
ceiling f = ceiling (toRational f)
floor f = floor (toRational f)
chopZeros :: Integer -> String
chopZeros 0 = ""
chopZeros a | mod a 10 == 0 = chopZeros (div a 10)
chopZeros a = show a
showIntegerZeros :: Bool -> Int -> Integer -> String
showIntegerZeros True _ 0 = ""
showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where
s = show a
s' = if chopTrailingZeros then chopZeros a else s
withDot :: String -> String
withDot "" = ""
withDot s = '.':s
showFixed :: (HasResolution a) => Bool -> Fixed a -> String
showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))
showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where
res = resolution fa
(i,d) = divMod a res
-- enough digits to be unambiguous
digits = ceiling (logBase 10 (fromInteger res) :: Double)
maxnum = 10 ^ digits
-- read floors, so show must ceil for `read . show = id` to hold. See #9240
fracNum = divCeil (d * maxnum) res
divCeil x y = (x + y - 1) `div` y
instance (HasResolution a) => Show (Fixed a) where
showsPrec p n = showParen (p > 6 && n < 0) $ showString $ showFixed False n
instance (HasResolution a) => Read (Fixed a) where
readPrec = readNumber convertFixed
readListPrec = readListPrecDefault
readList = readListDefault
convertFixed :: forall a . HasResolution a => Lexeme -> ReadPrec (Fixed a)
convertFixed (Number n)
| Just (i, f) <- numberToFixed e n =
return (fromInteger i + (fromInteger f / (10 ^ e)))
where r = resolution (Proxy :: Proxy a)
-- round 'e' up to help make the 'read . show == id' property
-- possible also for cases where 'resolution' is not a
-- power-of-10, such as e.g. when 'resolution = 128'
e = ceiling (logBase 10 (fromInteger r) :: Double)
convertFixed _ = pfail
data E0
instance HasResolution E0 where
resolution _ = 1
type Uni = Fixed E0
data E1
instance HasResolution E1 where
resolution _ = 10
type Deci = Fixed E1
data E2
instance HasResolution E2 where
resolution _ = 100
type Centi = Fixed E2
data E3
instance HasResolution E3 where
resolution _ = 1000
type Milli = Fixed E3
data E6
instance HasResolution E6 where
resolution _ = 1000000
type Micro = Fixed E6
data E9
instance HasResolution E9 where
resolution _ = 1000000000
type Nano = Fixed E9
data E12
instance HasResolution E12 where
resolution _ = 1000000000000
type Pico = Fixed E12