Data/Fixed.hs

   1 {-# OPTIONS -Wall -fno-warn-unused-binds #-}
   2
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  Data.Fixed
   6 -- Copyright   :  (c) Ashley Yakeley 2005, 2006, 2009
   7 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   8 --
   9 -- Maintainer  :  Ashley Yakeley <ashley@semantic.org>
  10 -- Stability   :  experimental
  11 -- Portability :  portable
  12 --
  13 -- This module defines a \"Fixed\" type for fixed-precision arithmetic.
  14 -- The parameter to Fixed is any type that's an instance of HasResolution.
  15 -- HasResolution has a single method that gives the resolution of the Fixed type.
  16 --
  17 -- This module also contains generalisations of div, mod, and divmod to work
  18 -- with any Real instance.
  19 --
  20 -----------------------------------------------------------------------------
  21
  22 module Data.Fixed
  23 (
  24     div',mod',divMod',
  25
  26     Fixed,HasResolution(..),
  27     showFixed,
  28     E0,Uni,
  29     E1,Deci,
  30     E2,Centi,
  31     E3,Milli,
  32     E6,Micro,
  33     E9,Nano,
  34     E12,Pico
  35 ) where
  36
  37 import Prelude -- necessary to get dependencies right
  38 import Data.Char
  39 import Data.List
  40 #ifndef __NHC__
  41 import Data.Typeable
  42 import Data.Data
  43 #endif
  44
  45 #ifndef __NHC__
  46 default () -- avoid any defaulting shenanigans
  47 #endif
  48
  49 -- | generalisation of 'div' to any instance of Real
  50 div' :: (Real a,Integral b) => a -> a -> b
  51 div' n d = floor ((toRational n) / (toRational d))
  52
  53 -- | generalisation of 'divMod' to any instance of Real
  54 divMod' :: (Real a,Integral b) => a -> a -> (b,a)
  55 divMod' n d = (f,n - (fromIntegral f) * d) where
  56     f = div' n d
  57
  58 -- | generalisation of 'mod' to any instance of Real
  59 mod' :: (Real a) => a -> a -> a
  60 mod' n d = n - (fromInteger f) * d where
  61     f = div' n d
  62
  63 -- | The type parameter should be an instance of 'HasResolution'.
  64 newtype Fixed a = MkFixed Integer
  65 #ifndef __NHC__
  66         deriving (Eq,Ord,Typeable)
  67 #else
  68         deriving (Eq,Ord)
  69 #endif
  70
  71 #ifndef __NHC__
  72 -- We do this because the automatically derived Data instance requires (Data a) context.
  73 -- Our manual instance has the more general (Typeable a) context.
  74 tyFixed :: DataType
  75 tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
  76 conMkFixed :: Constr
  77 conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
  78 instance (Typeable a) => Data (Fixed a) where
  79     gfoldl k z (MkFixed a) = k (z MkFixed) a
  80     gunfold k z _ = k (z MkFixed)
  81     dataTypeOf _ = tyFixed
  82     toConstr _ = conMkFixed
  83 #endif
  84
  85 class HasResolution a where
  86     resolution :: p a -> Integer
  87
  88 withType :: (p a -> f a) -> f a
  89 withType foo = foo undefined
  90
  91 withResolution :: (HasResolution a) => (Integer -> f a) -> f a
  92 withResolution foo = withType (foo . resolution)
  93
  94 instance Enum (Fixed a) where
  95     succ (MkFixed a) = MkFixed (succ a)
  96     pred (MkFixed a) = MkFixed (pred a)
  97     toEnum = MkFixed . toEnum
  98     fromEnum (MkFixed a) = fromEnum a
  99     enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)
 100     enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)
 101     enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)
 102     enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)
 103
 104 instance (HasResolution a) => Num (Fixed a) where
 105     (MkFixed a) + (MkFixed b) = MkFixed (a + b)
 106     (MkFixed a) - (MkFixed b) = MkFixed (a - b)
 107     fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa))
 108     negate (MkFixed a) = MkFixed (negate a)
 109     abs (MkFixed a) = MkFixed (abs a)
 110     signum (MkFixed a) = fromInteger (signum a)
 111     fromInteger i = withResolution (\res -> MkFixed (i * res))
 112
 113 instance (HasResolution a) => Real (Fixed a) where
 114     toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa))
 115
 116 instance (HasResolution a) => Fractional (Fixed a) where
 117     fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b)
 118     recip fa@(MkFixed a) = MkFixed (div (res * res) a) where
 119         res = resolution fa
 120     fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))
 121
 122 instance (HasResolution a) => RealFrac (Fixed a) where
 123     properFraction a = (i,a - (fromIntegral i)) where
 124         i = truncate a
 125     truncate f = truncate (toRational f)
 126     round f = round (toRational f)
 127     ceiling f = ceiling (toRational f)
 128     floor f = floor (toRational f)
 129
 130 chopZeros :: Integer -> String
 131 chopZeros 0 = ""
 132 chopZeros a | mod a 10 == 0 = chopZeros (div a 10)
 133 chopZeros a = show a
 134
 135 -- only works for positive a
 136 showIntegerZeros :: Bool -> Int -> Integer -> String
 137 showIntegerZeros True _ 0 = ""
 138 showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where
 139     s = show a
 140     s' = if chopTrailingZeros then chopZeros a else s
 141
 142 withDot :: String -> String
 143 withDot "" = ""
 144 withDot s = '.':s
 145
 146 -- | First arg is whether to chop off trailing zeros
 147 showFixed :: (HasResolution a) => Bool -> Fixed a -> String
 148 showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))
 149 showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where
 150     res = resolution fa
 151     (i,d) = divMod a res
 152     -- enough digits to be unambiguous
 153     digits = ceiling (logBase 10 (fromInteger res) :: Double)
 154     maxnum = 10 ^ digits
 155     fracNum = div (d * maxnum) res
 156
 157 readsFixed :: (HasResolution a) => ReadS (Fixed a)
 158 readsFixed = readsSigned
 159     where readsSigned ('-' : xs) = [ (negate x, rest)
 160                                    | (x, rest) <- readsUnsigned xs ]
 161           readsSigned xs = readsUnsigned xs
 162           readsUnsigned xs = case span isDigit xs of
 163                              ([], _) -> []
 164                              (is, xs') ->
 165                                  let i = fromInteger (read is)
 166                                  in case xs' of
 167                                     '.' : xs'' ->
 168                                         case span isDigit xs'' of
 169                                         ([], _) -> []
 170                                         (js, xs''') ->
 171                                             let j = fromInteger (read js)
 172                                                 l = genericLength js :: Integer
 173                                             in [(i + (j / (10 ^ l)), xs''')]
 174                                     _ -> [(i, xs')]
 175
 176 instance (HasResolution a) => Show (Fixed a) where
 177     show = showFixed False
 178
 179 instance (HasResolution a) => Read (Fixed a) where
 180     readsPrec _ = readsFixed
 181
 182 data E0 = E0
 183 #ifndef __NHC__
 184      deriving (Typeable)
 185 #endif
 186 instance HasResolution E0 where
 187     resolution _ = 1
 188 -- | resolution of 1, this works the same as Integer
 189 type Uni = Fixed E0
 190
 191 data E1 = E1
 192 #ifndef __NHC__
 193      deriving (Typeable)
 194 #endif
 195 instance HasResolution E1 where
 196     resolution _ = 10
 197 -- | resolution of 10^-1 = .1
 198 type Deci = Fixed E1
 199
 200 data E2 = E2
 201 #ifndef __NHC__
 202      deriving (Typeable)
 203 #endif
 204 instance HasResolution E2 where
 205     resolution _ = 100
 206 -- | resolution of 10^-2 = .01, useful for many monetary currencies
 207 type Centi = Fixed E2
 208
 209 data E3 = E3
 210 #ifndef __NHC__
 211      deriving (Typeable)
 212 #endif
 213 instance HasResolution E3 where
 214     resolution _ = 1000
 215 -- | resolution of 10^-3 = .001
 216 type Milli = Fixed E3
 217
 218 data E6 = E6
 219 #ifndef __NHC__
 220      deriving (Typeable)
 221 #endif
 222 instance HasResolution E6 where
 223     resolution _ = 1000000
 224 -- | resolution of 10^-6 = .000001
 225 type Micro = Fixed E6
 226
 227 data E9 = E9
 228 #ifndef __NHC__
 229      deriving (Typeable)
 230 #endif
 231 instance HasResolution E9 where
 232     resolution _ = 1000000000
 233 -- | resolution of 10^-9 = .000000001
 234 type Nano = Fixed E9
 235
 236 data E12 = E12
 237 #ifndef __NHC__
 238      deriving (Typeable)
 239 #endif
 240 instance HasResolution E12 where
 241     resolution _ = 1000000000000
 242 -- | resolution of 10^-12 = .000000000001
 243 type Pico = Fixed E12