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 #ifndef __NHC__
  39 import Data.Typeable
  40 import Data.Data
  41 #endif
  42
  43 #ifndef __NHC__
  44 default () -- avoid any defaulting shenanigans
  45 #endif
  46
  47 -- | generalisation of 'div' to any instance of Real
  48 div' :: (Real a,Integral b) => a -> a -> b
  49 div' n d = floor ((toRational n) / (toRational d))
  50
  51 -- | generalisation of 'divMod' to any instance of Real
  52 divMod' :: (Real a,Integral b) => a -> a -> (b,a)
  53 divMod' n d = (f,n - (fromIntegral f) * d) where
  54     f = div' n d
  55
  56 -- | generalisation of 'mod' to any instance of Real
  57 mod' :: (Real a) => a -> a -> a
  58 mod' n d = n - (fromInteger f) * d where
  59     f = div' n d
  60
  61 -- | The type parameter should be an instance of 'HasResolution'.
  62 newtype Fixed a = MkFixed Integer
  63 #ifndef __NHC__
  64         deriving (Eq,Ord,Typeable)
  65 #else
  66         deriving (Eq,Ord)
  67 #endif
  68
  69 #ifndef __NHC__
  70 -- We do this because the automatically derived Data instance requires (Data a) context.
  71 -- Our manual instance has the more general (Typeable a) context.
  72 tyFixed :: DataType
  73 tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
  74 conMkFixed :: Constr
  75 conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
  76 instance (Typeable a) => Data (Fixed a) where
  77     gfoldl k z (MkFixed a) = k (z MkFixed) a
  78     gunfold k z _ = k (z MkFixed)
  79     dataTypeOf _ = tyFixed
  80     toConstr _ = conMkFixed
  81 #endif
  82
  83 class HasResolution a where
  84     resolution :: p a -> Integer
  85
  86 withType :: (p a -> f a) -> f a
  87 withType foo = foo undefined
  88
  89 withResolution :: (HasResolution a) => (Integer -> f a) -> f a
  90 withResolution foo = withType (foo . resolution)
  91
  92 instance Enum (Fixed a) where
  93     succ (MkFixed a) = MkFixed (succ a)
  94     pred (MkFixed a) = MkFixed (pred a)
  95     toEnum = MkFixed . toEnum
  96     fromEnum (MkFixed a) = fromEnum a
  97     enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)
  98     enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)
  99     enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)
 100     enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)
 101
 102 instance (HasResolution a) => Num (Fixed a) where
 103     (MkFixed a) + (MkFixed b) = MkFixed (a + b)
 104     (MkFixed a) - (MkFixed b) = MkFixed (a - b)
 105     fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa))
 106     negate (MkFixed a) = MkFixed (negate a)
 107     abs (MkFixed a) = MkFixed (abs a)
 108     signum (MkFixed a) = fromInteger (signum a)
 109     fromInteger i = withResolution (\res -> MkFixed (i * res))
 110
 111 instance (HasResolution a) => Real (Fixed a) where
 112     toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa))
 113
 114 instance (HasResolution a) => Fractional (Fixed a) where
 115     fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b)
 116     recip fa@(MkFixed a) = MkFixed (div (res * res) a) where
 117         res = resolution fa
 118     fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))
 119
 120 instance (HasResolution a) => RealFrac (Fixed a) where
 121     properFraction a = (i,a - (fromIntegral i)) where
 122         i = truncate a
 123     truncate f = truncate (toRational f)
 124     round f = round (toRational f)
 125     ceiling f = ceiling (toRational f)
 126     floor f = floor (toRational f)
 127
 128 chopZeros :: Integer -> String
 129 chopZeros 0 = ""
 130 chopZeros a | mod a 10 == 0 = chopZeros (div a 10)
 131 chopZeros a = show a
 132
 133 -- only works for positive a
 134 showIntegerZeros :: Bool -> Int -> Integer -> String
 135 showIntegerZeros True _ 0 = ""
 136 showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where
 137     s = show a
 138     s' = if chopTrailingZeros then chopZeros a else s
 139
 140 withDot :: String -> String
 141 withDot "" = ""
 142 withDot s = '.':s
 143
 144 -- | First arg is whether to chop off trailing zeros
 145 showFixed :: (HasResolution a) => Bool -> Fixed a -> String
 146 showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))
 147 showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where
 148     res = resolution fa
 149     (i,d) = divMod a res
 150     -- enough digits to be unambiguous
 151     digits = ceiling (logBase 10 (fromInteger res) :: Double)
 152     maxnum = 10 ^ digits
 153     fracNum = div (d * maxnum) res
 154
 155 instance (HasResolution a) => Show (Fixed a) where
 156     show = showFixed False
 157
 158
 159 data E0 = E0
 160 #ifndef __NHC__
 161      deriving (Typeable)
 162 #endif
 163 instance HasResolution E0 where
 164     resolution _ = 1
 165 -- | resolution of 1, this works the same as Integer
 166 type Uni = Fixed E0
 167
 168 data E1 = E1
 169 #ifndef __NHC__
 170      deriving (Typeable)
 171 #endif
 172 instance HasResolution E1 where
 173     resolution _ = 10
 174 -- | resolution of 10^-1 = .1
 175 type Deci = Fixed E1
 176
 177 data E2 = E2
 178 #ifndef __NHC__
 179      deriving (Typeable)
 180 #endif
 181 instance HasResolution E2 where
 182     resolution _ = 100
 183 -- | resolution of 10^-2 = .01, useful for many monetary currencies
 184 type Centi = Fixed E2
 185
 186 data E3 = E3
 187 #ifndef __NHC__
 188      deriving (Typeable)
 189 #endif
 190 instance HasResolution E3 where
 191     resolution _ = 1000
 192 -- | resolution of 10^-3 = .001
 193 type Milli = Fixed E3
 194
 195 data E6 = E6
 196 #ifndef __NHC__
 197      deriving (Typeable)
 198 #endif
 199 instance HasResolution E6 where
 200     resolution _ = 1000000
 201 -- | resolution of 10^-6 = .000001
 202 type Micro = Fixed E6
 203
 204 data E9 = E9
 205 #ifndef __NHC__
 206      deriving (Typeable)
 207 #endif
 208 instance HasResolution E9 where
 209     resolution _ = 1000000000
 210 -- | resolution of 10^-9 = .000000001
 211 type Nano = Fixed E9
 212
 213 data E12 = E12
 214 #ifndef __NHC__
 215      deriving (Typeable)
 216 #endif
 217 instance HasResolution E12 where
 218     resolution _ = 1000000000000
 219 -- | resolution of 10^-12 = .000000000001
 220 type Pico = Fixed E12