Data/Fixed.hs

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