ref: 13788f969b81d2d8fbd32f6bdb71ecd9a3c824db
parent: 494ebd7139ae4ce6d84e3a35b12874246a72adb7
author: Lennart Augustsson <lennart@augustsson.net>
date: Thu Sep 26 11:44:13 EDT 2024
Add Data.Fixed
--- a/Makefile
+++ b/Makefile
@@ -198,7 +198,7 @@
MCABALBIN=$(MCABAL)/bin
MDIST=dist-mcabal
BASE=base-$(VERSION)
-BASEMODULES=Control.Applicative Control.Arrow Control.Category Control.DeepSeq Control.Error Control.Exception Control.Monad Control.Monad.Fail Control.Monad.Fix Control.Monad.IO.Class Control.Monad.ST Control.Monad.Zip Data.Array Data.Bifoldable Data.Bifunctor Data.Bitraversable Data.Bits Data.Bool Data.Bounded Data.ByteString Data.Char Data.Complex Data.Constraint Data.Data Data.Double Data.Dynamic Data.Either Data.Enum Data.Eq Data.Float Data.FloatW Data.Floating Data.Foldable Data.Foldable1 Data.Fractional Data.Function Data.Functor Data.Functor.Classes Data.Functor.Compose Data.Functor.Const Data.Functor.Contravariant Data.Functor.Identity Data.Functor.Product Data.Functor.Sum Data.IOArray Data.IORef Data.Int Data.Integer Data.Integral Data.Ix Data.Kind Data.List Data.List.NonEmpty Data.Maybe Data.Monoid Data.Num Data.Ord Data.Proxy Data.Ratio Data.Real Data.RealFloat Data.RealFrac Data.Records Data.STRef Data.Semigroup Data.String Data.Text Data.Time.Clock Data.Time.Format Data.Traversable Data.Tuple Data.Tuple.Instances Data.Type.Equality Data.TypeLits Data.Typeable Data.Version Data.Void Data.Word Data.ZipList Debug.Trace Foreign.C.String Foreign.C.Types Foreign.ForeignPtr Foreign.Marshal.Alloc Foreign.Marshal.Array Foreign.Marshal.Utils Foreign.Ptr Foreign.Storable GHC.Stack GHC.Types Numeric Numeric.FormatFloat Numeric.Natural Prelude System.Cmd System.Console.GetOpt System.Compress System.Directory System.Environment System.Exit System.IO System.IO.Error System.IO.MD5 System.IO.PrintOrRun System.IO.Serialize System.IO.TimeMilli System.IO.Unsafe System.Info System.Process Text.Printf Text.ParserCombinators.ReadP Text.ParserCombinators.ReadPrec Text.Read Text.Read.Lex Text.Show TimeCompat Unsafe.Coerce
+BASEMODULES=Control.Applicative Control.Arrow Control.Category Control.DeepSeq Control.Error Control.Exception Control.Monad Control.Monad.Fail Control.Monad.Fix Control.Monad.IO.Class Control.Monad.ST Control.Monad.Zip Data.Array Data.Bifoldable Data.Bifunctor Data.Bitraversable Data.Bits Data.Bool Data.Bounded Data.ByteString Data.Char Data.Complex Data.Constraint Data.Data Data.Double Data.Dynamic Data.Either Data.Enum Data.Eq Data.Fixed Data.Float Data.FloatW Data.Floating Data.Foldable Data.Foldable1 Data.Fractional Data.Function Data.Functor Data.Functor.Classes Data.Functor.Compose Data.Functor.Const Data.Functor.Contravariant Data.Functor.Identity Data.Functor.Product Data.Functor.Sum Data.IOArray Data.IORef Data.Int Data.Integer Data.Integral Data.Ix Data.Kind Data.List Data.List.NonEmpty Data.Maybe Data.Monoid Data.Num Data.Ord Data.Proxy Data.Ratio Data.Real Data.RealFloat Data.RealFrac Data.Records Data.STRef Data.Semigroup Data.String Data.Text Data.Time.Clock Data.Time.Format Data.Traversable Data.Tuple Data.Tuple.Instances Data.Type.Equality Data.TypeLits Data.Typeable Data.Version Data.Void Data.Word Data.ZipList Debug.Trace Foreign.C.String Foreign.C.Types Foreign.ForeignPtr Foreign.Marshal.Alloc Foreign.Marshal.Array Foreign.Marshal.Utils Foreign.Ptr Foreign.Storable GHC.Stack GHC.Types Numeric Numeric.FormatFloat Numeric.Natural Prelude System.Cmd System.Console.GetOpt System.Compress System.Directory System.Environment System.Exit System.IO System.IO.Error System.IO.MD5 System.IO.PrintOrRun System.IO.Serialize System.IO.TimeMilli System.IO.Unsafe System.Info System.Process Text.Printf Text.ParserCombinators.ReadP Text.ParserCombinators.ReadPrec Text.Read Text.Read.Lex Text.Show TimeCompat Unsafe.Coerce
$(MCABALBIN)/mhs: bin/mhs
@mkdir -p $(MCABALBIN)
--- a/lib/AllOfLib.hs
+++ b/lib/AllOfLib.hs
@@ -29,6 +29,7 @@
import Data.Either
import Data.Enum
import Data.Eq
+import Data.Fixed
import Data.FloatW
import Data.Floating
import Data.Foldable
--- /dev/null
+++ b/lib/Data/Fixed.hs
@@ -1,0 +1,227 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 Data.Data
+import Data.TypeLits (KnownNat, natVal)
+import Text.Read.Internal
+import Text.ParserCombinators.ReadPrec
+import Text.Read.Lex
+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