diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,20 @@ # Revision history for pact-time +## 0.3.0.0 -- 2024-06-30 + +Breaking changes: + +* Replaced dependency on the vector-spaces package by internal public + `numeric` library. + + Most notably class method `zeroV` is now just called `zero`. Otherwise, most + numeric operators remain identical and are now (re-)exported by the main + module `Pact.Time`. + +Other changes: + +* Support for builds with GHC-9.10.1. + ## 0.2.0.2 -- 2023-05-11 * Support mtl-2.3 diff --git a/numeric/src/Numeric/Additive.hs b/numeric/src/Numeric/Additive.hs new file mode 100644 --- /dev/null +++ b/numeric/src/Numeric/Additive.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: Numeric.Additive +-- Copyright: Copyright © 2018 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Haskell's @Num@ class doesn't support fine grained control +-- over what arithmetic operations are defined for a type. +-- Sometimes only some operations have a well defined semantics +-- and @Num@ instances are notorious for including undefined/error +-- values or unlawful workarounds. +-- +module Numeric.Additive +( +-- * Additive Semigroup + AdditiveSemigroup(..) +, AdditiveAbelianSemigroup +, (^+^) + +-- * Additive Monoid +, AdditiveMonoid(..) +, AdditiveAbelianMonoid + +-- * Additive Group +, AdditiveGroup(..) + +-- * Additive Abelian Group +, AdditiveAbelianGroup +, (^-^) +) where + +import Data.DoubleWord +import Data.Int +import Data.Word + +import Numeric.Natural + +-- -------------------------------------------------------------------------- -- +-- | Additive Semigroup +-- +-- prop> (a `plus` b) `plus` c == a `plus` (b `plus` c) +-- +class AdditiveSemigroup g where + plus :: g -> g -> g + +instance AdditiveSemigroup Integer where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Rational where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Natural where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Int where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Word where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Word8 where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Word16 where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Word32 where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Word64 where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Word128 where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Word256 where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Int8 where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Int16 where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Int32 where + plus = (+) + {-# INLINE plus #-} + +instance AdditiveSemigroup Int64 where + plus = (+) + {-# INLINE plus #-} + +-- -------------------------------------------------------------------------- -- +-- | Additive Abelian Semigroup +-- +-- prop> a `plus` b == b `plus` a +-- +class AdditiveSemigroup g => AdditiveAbelianSemigroup g + +instance AdditiveAbelianSemigroup Integer +instance AdditiveAbelianSemigroup Rational +instance AdditiveAbelianSemigroup Natural +instance AdditiveAbelianSemigroup Int +instance AdditiveAbelianSemigroup Int8 +instance AdditiveAbelianSemigroup Int16 +instance AdditiveAbelianSemigroup Int32 +instance AdditiveAbelianSemigroup Int64 +instance AdditiveAbelianSemigroup Word +instance AdditiveAbelianSemigroup Word8 +instance AdditiveAbelianSemigroup Word16 +instance AdditiveAbelianSemigroup Word32 +instance AdditiveAbelianSemigroup Word64 +instance AdditiveAbelianSemigroup Word128 +instance AdditiveAbelianSemigroup Word256 + +infixl 6 ^+^ +(^+^) :: AdditiveAbelianSemigroup g => g -> g -> g +(^+^) = plus +{-# INLINE (^+^) #-} + +-- -------------------------------------------------------------------------- -- +-- | Additive Monoid +-- +-- prop> a `plus` zero == a +-- prop> zero `plus` a == a +-- +class AdditiveSemigroup g => AdditiveMonoid g where + zero :: g + +instance AdditiveMonoid Integer where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Rational where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Natural where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Int where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Word where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Word8 where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Word16 where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Word32 where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Word64 where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Word128 where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Word256 where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Int8 where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Int16 where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Int32 where + zero = 0 + {-# INLINE zero #-} + +instance AdditiveMonoid Int64 where + zero = 0 + {-# INLINE zero #-} + +type AdditiveAbelianMonoid g = (AdditiveMonoid g, AdditiveAbelianSemigroup g) + +-- -------------------------------------------------------------------------- -- +-- | Additive Group +-- +-- prop> a `plus` inverse a == zero +-- prop> inverse a `plus` a == zero +-- +class AdditiveMonoid g => AdditiveGroup g where + invert :: g -> g + invert a = zero `minus` a + + minus :: g -> g -> g + minus a b = a `plus` invert b + + {-# MINIMAL invert | minus #-} + +instance AdditiveGroup Integer where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Rational where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Int where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Word where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Word8 where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Word16 where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Word32 where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Word64 where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Word128 where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Word256 where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Int8 where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Int16 where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Int32 where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +instance AdditiveGroup Int64 where + invert a = -a + minus = (-) + {-# INLINE invert #-} + {-# INLINE minus #-} + +-- -------------------------------------------------------------------------- -- +-- | Additive Abelian Group +-- +type AdditiveAbelianGroup g = (AdditiveGroup g, AdditiveAbelianMonoid g) + +infix 6 ^-^ +(^-^) :: AdditiveAbelianGroup g => g -> g -> g +(^-^) = minus +{-# INLINE (^-^) #-} diff --git a/numeric/src/Numeric/AffineSpace.hs b/numeric/src/Numeric/AffineSpace.hs new file mode 100644 --- /dev/null +++ b/numeric/src/Numeric/AffineSpace.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: Numeric.AffineSpace +-- Copyright: Copyright © 2018 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Numeric.AffineSpace +( +-- * Torsor + LeftTorsor(..) +, (.+^) +, (^+.) +, (.-.) +, (.-^) + +-- * Vector Space +, FractionalVectorSpace(..) + +-- * AfficeSpace +, AffineSpace +) where + +import Numeric.Additive + +-- -------------------------------------------------------------------------- -- +-- Torsor + +-- | A torsor is a generalization of affine spaces. It doesn't require the +-- underlying structure to be vector space, but an additive group suffices. +-- This means that it doesn't support scalar multiplication. In particular +-- it doesn't require an inverse operation to multiplication, which would +-- add unneeded complexity to the formal definition of the operational +-- semantics. +-- +-- A Torsor is also called principal homogeous space. +-- +-- prop> zero `add` a == a +-- prop> (a `plus` b) `add` t == a `add` (b `add` t) +-- prop> (s `diff` t) `add` t == s +-- +-- The last property is states that `add` is a bijection. +-- +class (AdditiveGroup (Diff t)) => LeftTorsor t where + type Diff t + add :: Diff t -> t -> t + diff :: t -> t -> Diff t + +instance LeftTorsor Integer where + type Diff Integer = Integer + add = (+) + diff = (-) + {-# INLINE add #-} + {-# INLINE diff #-} + +instance LeftTorsor Rational where + type Diff Rational = Rational + add = (+) + diff = (-) + {-# INLINE add #-} + {-# INLINE diff #-} + +infix 6 .-. +(.-.) :: AdditiveAbelianGroup (Diff t) => LeftTorsor t => t -> t -> Diff t +(.-.) = diff + +infixl 6 ^+. +(^+.) :: AdditiveAbelianGroup (Diff t) => LeftTorsor t => Diff t -> t -> t +(^+.) = add + +infixl 6 .+^ +(.+^) :: AdditiveAbelianGroup (Diff t) => LeftTorsor t => t -> Diff t -> t +(.+^) = flip add + +infixl 6 .-^ +(.-^) :: AdditiveAbelianGroup (Diff t) => LeftTorsor t => t -> Diff t -> t +(.-^) t d = t .+^ invert d + +-- -------------------------------------------------------------------------- -- +-- | Vector Space over Fractional Numbers +-- +-- A real vector space is an additive abelian group that forms an module +-- with the field of real numbers. +-- +-- prop> a * (b `scale` c) == (a * b) `scale` c +-- prop> 1 `scale` a == a +-- prop> a `scale` (b `plus` c) == (a `scale` b) `plus` (a `scale` c) +-- prop> (a + b) `scale` c == (a `scale` c) `plus` (b `scale` c) +-- +class (AdditiveAbelianGroup v, Fractional (Scalar v)) => FractionalVectorSpace v where + type Scalar v + scale :: Scalar v -> v -> v + +instance FractionalVectorSpace Rational where + type Scalar Rational = Rational + scale = (*) + +-- -------------------------------------------------------------------------- -- +-- Affine Space + +-- | An affine space is a torsor for the action of the additive group +-- of a vector space. +-- +type AffineSpace t = (FractionalVectorSpace (Diff t), LeftTorsor t) diff --git a/pact-time.cabal b/pact-time.cabal --- a/pact-time.cabal +++ b/pact-time.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: pact-time -version: 0.2.0.2 +version: 0.3.0.0 synopsis: Time Library for Pact Description: A minimal time library for usage with the [Pact Smart Contract @@ -27,11 +27,10 @@ copyright: Copyright (c) 2021 Kadena LLC. category: Data, System tested-with: + GHC==9.10 + GHC==9.8 GHC==9.6 GHC==9.4 - GHC==9.2 - GHC==9.0 - GHC==8.10.7 extra-source-files: @@ -48,6 +47,19 @@ manual: True default: False +library numeric + visibility: public + hs-source-dirs: numeric/src + default-language: Haskell2010 + ghc-options: + -Wall + exposed-modules: + Numeric.Additive + Numeric.AffineSpace + build-depends: + -- external + , base >=4.11 && <5 + , data-dword >=0.3 library hs-source-dirs: src default-language: Haskell2010 @@ -59,6 +71,8 @@ Pact.Time.Format Pact.Time.System build-depends: + -- internal + , pact-time:numeric -- external , Decimal >=0.4 , aeson >=0.11 @@ -70,20 +84,19 @@ , microlens >=0.4 , text >=1.2 , vector >=0.12 - , vector-space >=0.10 - if flag(with-time) - cpp-options: -DWITH_TIME=1 - other-modules: Pact.Time.Format.External - build-depends: time >= 1.8 - else - cpp-options: -DWITH_TIME=0 - other-modules: - Pact.Time.Format.Internal - Pact.Time.Format.Locale - build-depends: - , clock >= 0.7.2 - , mtl >=2.2 + if flag(with-time) + cpp-options: -DWITH_TIME=1 + other-modules: Pact.Time.Format.External + build-depends: time >= 1.8 + else + cpp-options: -DWITH_TIME=0 + other-modules: + Pact.Time.Format.Internal + Pact.Time.Format.Locale + build-depends: + , clock >= 0.7.2 + , mtl >=2.2 test-suite tests type: exitcode-stdio-1.0 @@ -98,8 +111,9 @@ other-modules: Test.Pact.Time.Format build-depends: - pact-time - + -- internal + , pact-time + -- external , base >=4.11 && <5 , tasty >=1.4 , tasty-hunit >=0.10 diff --git a/src/Pact/Time.hs b/src/Pact/Time.hs --- a/src/Pact/Time.hs +++ b/src/Pact/Time.hs @@ -48,8 +48,16 @@ , formatTime -- * Reexports -, AffineSpace(..) -, VectorSpace(..) +, AdditiveSemigroup(..) +, AdditiveMonoid(..) +, AdditiveGroup(..) +, (^-^) +, (^+^) +, (.+^) +, (^+.) +, (.-.) +, (.-^) +, (*^) ) where import Pact.Time.Format diff --git a/src/Pact/Time/Format/Internal.hs b/src/Pact/Time/Format/Internal.hs --- a/src/Pact/Time/Format/Internal.hs +++ b/src/Pact/Time/Format/Internal.hs @@ -42,7 +42,6 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Vector.Unboxed as VU -import Data.VectorSpace import Lens.Micro @@ -793,7 +792,7 @@ 'q' -> lift micro >>= assign tpSecFrac . NominalDiffTime >> go rspec 'v' -> lift micro >>= assign tpSecFrac . NominalDiffTime >> go rspec - 'Q' -> lift ((P.char '.' >> NominalDiffTime <$> micro) <|> return zeroV) + 'Q' -> lift ((P.char '.' >> NominalDiffTime <$> micro) <|> return zero) >>= assign tpSecFrac >> go rspec -- Year @@ -923,8 +922,8 @@ , _tpHour = 0 , _tpMinute = 0 , _tpSecond = 0 - , _tpSecFrac = zeroV - , _tpPOSIXTime = zeroV + , _tpSecFrac = zero + , _tpPOSIXTime = zero , _tpTimeZone = utc } {-# INLINE unixEpoch #-} @@ -1029,8 +1028,8 @@ toDayTime :: TimeOfDay -> NominalDiffTime toDayTime (TimeOfDay h m s) = s - ^+^ fromIntegral m *^ NominalDiffTime 60000000 - ^+^ fromIntegral h *^ NominalDiffTime 3600000000 + ^+^ m *^ NominalDiffTime 60000000 + ^+^ h *^ NominalDiffTime 3600000000 {-# INLINEABLE toDayTime #-} {-# INLINE buildTime #-} diff --git a/src/Pact/Time/Internal.hs b/src/Pact/Time/Internal.hs --- a/src/Pact/Time/Internal.hs +++ b/src/Pact/Time/Internal.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Module: Pact.Time.Internal @@ -29,6 +30,8 @@ , toSeconds , fromSeconds , nominalDay +, scaleNominalDiffTime +, divNominalDiffTime -- * UTCTime , UTCTime(..) @@ -48,17 +51,23 @@ , fromModifiedJulianDate -- * Reexports -, AffineSpace(..) -, VectorSpace(..) +, AdditiveSemigroup(..) +, AdditiveMonoid(..) +, AdditiveGroup(..) +, (^-^) +, (^+^) +, (.+^) +, (^+.) +, (.-.) +, (.-^) +, (*^) ) where import Control.DeepSeq -import Data.AdditiveGroup -import Data.AffineSpace import Data.Decimal import Data.Serialize -import Data.VectorSpace +-- import Data.VectorSpace import GHC.Generics hiding (from) import GHC.Int (Int64) @@ -69,6 +78,9 @@ import Pact.Time.System +import Numeric.Additive +import Numeric.AffineSpace + -- -------------------------------------------------------------------------- -- -- Types for internal representations @@ -83,7 +95,11 @@ -- newtype NominalDiffTime = NominalDiffTime { _microseconds :: Micros } deriving (Eq, Ord) - deriving newtype (NFData) + deriving newtype + ( NFData + , AdditiveSemigroup, AdditiveAbelianSemigroup, AdditiveMonoid, AdditiveGroup + , Enum, Bounded + ) -- | Convert from 'NominalDiffTime' to a 64-bit representation of microseconds. -- @@ -97,21 +113,6 @@ fromMicroseconds = NominalDiffTime {-# INLINE fromMicroseconds #-} -instance AdditiveGroup NominalDiffTime where - zeroV = NominalDiffTime 0 - NominalDiffTime a ^+^ NominalDiffTime b = NominalDiffTime (a + b) - negateV (NominalDiffTime v) = NominalDiffTime (-v) - NominalDiffTime a ^-^ NominalDiffTime b = NominalDiffTime (a - b) - {-# INLINE zeroV #-} - {-# INLINE (^+^) #-} - {-# INLINE negateV #-} - {-# INLINE (^-^) #-} - -instance VectorSpace NominalDiffTime where - type Scalar NominalDiffTime = Rational - s *^ (NominalDiffTime m) = NominalDiffTime $ round (s * fromIntegral m) - {-# INLINE (*^) #-} - -- | Serializes 'NominalDiffTime' as 64-bit signed microseconds in little endian -- encoding. -- @@ -150,6 +151,18 @@ fromPosixTimestampMicros = fromPosix . fromTimestampMicros {-# INLINE fromPosixTimestampMicros #-} +scaleNominalDiffTime :: Integral a => a -> NominalDiffTime -> NominalDiffTime +scaleNominalDiffTime scalar (NominalDiffTime t) = NominalDiffTime (fromIntegral scalar * t) +{-# INLINE scaleNominalDiffTime #-} + +(*^) :: Integral a => a -> NominalDiffTime -> NominalDiffTime +(*^) = scaleNominalDiffTime +{-# INLINE (*^) #-} + +divNominalDiffTime :: Integral a => NominalDiffTime -> a -> NominalDiffTime +divNominalDiffTime (NominalDiffTime a) s = NominalDiffTime $ a `div` (fromIntegral s) +{-# INLINE divNominalDiffTime #-} + -- -------------------------------------------------------------------------- -- -- UTCTime @@ -167,12 +180,12 @@ deriving newtype (NFData) deriving newtype (Serialize) -instance AffineSpace UTCTime where +instance LeftTorsor UTCTime where type Diff UTCTime = NominalDiffTime - UTCTime a .-. UTCTime b = a ^-^ b - UTCTime a .+^ b = UTCTime (a ^+^ b) - {-# INLINE (.-.) #-} - {-# INLINE (.+^) #-} + add s (UTCTime t) = UTCTime (s `plus` t) + diff (UTCTime t₁) (UTCTime t₂) = t₁ `minus` t₂ + {-# INLINE add #-} + {-# INLINE diff #-} getCurrentTime :: IO UTCTime getCurrentTime = UTCTime . (^+^ _utcTime posixEpoch) . _posixTime @@ -210,7 +223,7 @@ -- | The POSIX Epoch represented as UTCTime. -- posixEpoch :: UTCTime -posixEpoch = UTCTime (fromIntegral d *^ nominalDay) +posixEpoch = UTCTime (d *^ nominalDay) where ModifiedJulianDay d = posixEpochDay {-# INLINE posixEpoch #-} @@ -218,7 +231,7 @@ -- | The Epoch of the modified Julian day represented as 'UTCTime'. -- mjdEpoch :: UTCTime -mjdEpoch = UTCTime zeroV +mjdEpoch = UTCTime zero {-# INLINE mjdEpoch #-} -- -------------------------------------------------------------------------- -- @@ -311,6 +324,6 @@ -- fromModifiedJulianDate :: ModifiedJulianDate -> UTCTime fromModifiedJulianDate (ModifiedJulianDate (ModifiedJulianDay d) t) - = UTCTime $ (fromIntegral d *^ nominalDay) ^+^ t + = UTCTime $ (d *^ nominalDay) ^+^ t {-# INLINE fromModifiedJulianDate #-}