-{-# OPTIONS -Wall -Werror -fno-warn-unused-binds #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS -Wall -fno-warn-unused-binds #-}
+#ifndef __NHC__
+{-# LANGUAGE DeriveDataTypeable #-}
+#endif
-----------------------------------------------------------------------------
-- |
-- Module : Data.Fixed
--- Copyright : (c) Ashley Yakeley 2005, 2006
+-- Copyright : (c) Ashley Yakeley 2005, 2006, 2009
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : Ashley Yakeley <ashley@semantic.org>
-- Stability : experimental
-- Portability : portable
--
--- This module defines a "Fixed" type for fixed-precision arithmetic.
+-- This module defines a \"Fixed\" type for fixed-precision arithmetic.
-- The parameter to Fixed is any type that's an instance of HasResolution.
-- HasResolution has a single method that gives the resolution of the Fixed type.
--- Parameter types E6 and E12 (for 10^6 and 10^12) are defined, as well as
--- type synonyms for Fixed E6 and Fixed E12.
--
-- This module also contains generalisations of div, mod, and divmod to work
-- with any Real instance.
module Data.Fixed
(
- div',mod',divMod',
-
- Fixed,HasResolution(..),
- showFixed,
- E6,Micro,
- E12,Pico
+ div',mod',divMod',
+
+ Fixed,HasResolution(..),
+ showFixed,
+ E0,Uni,
+ E1,Deci,
+ E2,Centi,
+ E3,Milli,
+ E6,Micro,
+ E9,Nano,
+ E12,Pico
) where
import Prelude -- necessary to get dependencies right
+import Data.Char
+import Data.List
+#ifndef __NHC__
+import Data.Typeable
+import Data.Data
+#endif
+
+#ifndef __NHC__
+default () -- avoid any defaulting shenanigans
+#endif
-- | generalisation of 'div' to any instance of Real
div' :: (Real a,Integral b) => a -> a -> b
-- | generalisation of 'divMod' to any instance of Real
divMod' :: (Real a,Integral b) => a -> a -> (b,a)
divMod' n d = (f,n - (fromIntegral f) * d) where
- f = div' n d
+ f = div' n d
-- | generalisation of 'mod' to any instance of Real
mod' :: (Real a) => a -> a -> a
mod' n d = n - (fromInteger f) * d where
- f = div' n d
-
-newtype Fixed a = MkFixed Integer deriving (Eq,Ord)
+ f = div' n d
+
+-- | The type parameter should be an instance of 'HasResolution'.
+newtype Fixed a = MkFixed Integer
+#ifndef __NHC__
+ deriving (Eq,Ord,Typeable)
+#else
+ deriving (Eq,Ord)
+#endif
+
+#ifndef __NHC__
+-- We do this because the automatically derived Data instance requires (Data a) context.
+-- Our manual instance has the more general (Typeable a) context.
+tyFixed :: DataType
+tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
+conMkFixed :: Constr
+conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
+instance (Typeable a) => Data (Fixed a) where
+ gfoldl k z (MkFixed a) = k (z MkFixed) a
+ gunfold k z _ = k (z MkFixed)
+ dataTypeOf _ = tyFixed
+ toConstr _ = conMkFixed
+#endif
class HasResolution a where
- resolution :: a -> Integer
+ resolution :: p a -> Integer
-fixedResolution :: (HasResolution a) => Fixed a -> Integer
-fixedResolution fa = resolution (uf fa) where
- uf :: Fixed a -> a
- uf _ = undefined
-
-withType :: (a -> f a) -> f a
+withType :: (p a -> f a) -> f a
withType foo = foo undefined
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)
+ 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) (fixedResolution 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))
+ (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 (fixedResolution fa))
+ toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa))
instance (HasResolution a) => Fractional (Fixed a) where
- fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (fixedResolution fa)) b)
- recip fa@(MkFixed a) = MkFixed (div (res * res) a) where
- res = fixedResolution fa
- fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))
+ 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)
+ 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 = ""
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
+ s = show a
+ s' = if chopTrailingZeros then chopZeros a else s
withDot :: String -> String
withDot "" = ""
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 = fixedResolution fa
- (i,d) = divMod a res
- -- enough digits to be unambiguous
- digits = ceiling (logBase 10 (fromInteger res) :: Double)
- maxnum = 10 ^ digits
- fracNum = div (d * maxnum) res
+ res = resolution fa
+ (i,d) = divMod a res
+ -- enough digits to be unambiguous
+ digits = ceiling (logBase 10 (fromInteger res) :: Double)
+ maxnum = 10 ^ digits
+ fracNum = div (d * maxnum) res
+
+readsFixed :: (HasResolution a) => ReadS (Fixed a)
+readsFixed = readsSigned
+ where readsSigned ('-' : xs) = [ (negate x, rest)
+ | (x, rest) <- readsUnsigned xs ]
+ readsSigned xs = readsUnsigned xs
+ readsUnsigned xs = case span isDigit xs of
+ ([], _) -> []
+ (is, xs') ->
+ let i = fromInteger (read is)
+ in case xs' of
+ '.' : xs'' ->
+ case span isDigit xs'' of
+ ([], _) -> []
+ (js, xs''') ->
+ let j = fromInteger (read js)
+ l = genericLength js :: Integer
+ in [(i + (j / (10 ^ l)), xs''')]
+ _ -> [(i, xs')]
instance (HasResolution a) => Show (Fixed a) where
- show = showFixed False
-
-
+ show = showFixed False
+
+instance (HasResolution a) => Read (Fixed a) where
+ readsPrec _ = readsFixed
+
+data E0 = E0
+#ifndef __NHC__
+ deriving (Typeable)
+#endif
+instance HasResolution E0 where
+ resolution _ = 1
+-- | resolution of 1, this works the same as Integer
+type Uni = Fixed E0
+
+data E1 = E1
+#ifndef __NHC__
+ deriving (Typeable)
+#endif
+instance HasResolution E1 where
+ resolution _ = 10
+-- | resolution of 10^-1 = .1
+type Deci = Fixed E1
+
+data E2 = E2
+#ifndef __NHC__
+ deriving (Typeable)
+#endif
+instance HasResolution E2 where
+ resolution _ = 100
+-- | resolution of 10^-2 = .01, useful for many monetary currencies
+type Centi = Fixed E2
+
+data E3 = E3
+#ifndef __NHC__
+ deriving (Typeable)
+#endif
+instance HasResolution E3 where
+ resolution _ = 1000
+-- | resolution of 10^-3 = .001
+type Milli = Fixed E3
data E6 = E6
-
+#ifndef __NHC__
+ deriving (Typeable)
+#endif
instance HasResolution E6 where
- resolution _ = 1000000
-
+ resolution _ = 1000000
+-- | resolution of 10^-6 = .000001
type Micro = Fixed E6
+data E9 = E9
+#ifndef __NHC__
+ deriving (Typeable)
+#endif
+instance HasResolution E9 where
+ resolution _ = 1000000000
+-- | resolution of 10^-9 = .000000001
+type Nano = Fixed E9
data E12 = E12
-
+#ifndef __NHC__
+ deriving (Typeable)
+#endif
instance HasResolution E12 where
- resolution _ = 1000000000000
-
+ resolution _ = 1000000000000
+-- | resolution of 10^-12 = .000000000001
type Pico = Fixed E12
projects / ghc-base.git / blobdiff