diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,14 @@ +Change log +========== +o'clock uses [PVP Versioning][1]. +The change log is available [on GitHub][2]. + +0.0.0 +===== + +* Initially created. See [`README`][3] for more information. + + +[1]: https://pvp.haskell.org +[2]: https://github.com/serokell/o-clock/releases +[3]: https://github.com/serokell/o-clock#readme diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018 Serokell + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,139 @@ +# O'Clock + +[![Hackage](https://img.shields.io/hackage/v/o-clock.svg)](https://hackage.haskell.org/package/o-clock) +[![Build status](https://travis-ci.org/serokell/o-clock.svg?branch=master)](https://travis-ci.org/serokell/o-clock) +[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/serokell/o-clock/blob/master/LICENSE) + +## Overview + +O'Clock is the library that provides type-safe time units data types. + +Most understandable use case is using [`threadDelay`](http://hackage.haskell.org/package/base-4.10.1.0/docs/Control-Concurrent.html#v:threadDelay) function. +If you want to wait for _5 seconds_ in your program, you need to write something like this: + +```haskell ignore +threadDelay (5 * 10^(6 :: Int)) +``` + +With O'Clock you can write in several more convenient ways (and use more preferred to you): + +```haskell ignore +threadDelay $ sec 5 +threadDelay (5 :: Time Second) +threadDelay @Second 5 +``` + +## Features + +`O'Clock` provides the following features to its users: + +1. Single data type for all time units. + + * Different time units represented as different type parameters for single `Time` data type. + Amount of required boilerplate is minimal. + +2. Time stored as `Rational` number. + + * It means that if you convert `900` milliseconds to seconds, you will have `0.9` second instead of `0` seconds. + So property `toUnit @to @from . toUnit @from @to ≡ id` is satisfied. + +3. Different unit types are stored as rational multiplier in type. + + * `o-clock` package introduces its own kind `Rat` for type-level rational numbers. + Units are stored as rational multipliers in type. Because of that some computation is performed on type-level. + So if you want to convert `Week` to `Day`, `o-clock` library ensures that time units will just be multipled by `7`. + +4. Functions from `base` that work with time are converted to more time-safe versions: + + * These functions are: `threadDelay`, `timeout`, `getCPUTime`. + +5. Externally extensible interface. + + * It means that if you want to roll out your own time units and use it in your project, + this can be done in easy and convenient way (see tutorial below). + +_**Note:**_ features support for `GHC-8.2.2` is quite limited. + +## Example: How to make your own time unit + +This README section contains tutorial on how you can introduce your own time units. +Let's solve the following problem: + +_You're CEO of big company. Your employers report you number of hours they worked this month. +You want format hours in more human-readable way, i.e. in number of work weeks and work days. +So we want `140 hours` be formatted as `3ww2wd` (3 full work weeks and 2 full work days)._ + +### Setting up + +Since this tutorial is literate haskell file, let's first write some pragmas and imports. + +```haskell +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +#if ( __GLASGOW_HASKELL__ >= 804 ) +import Time (type (*)) +#endif +import Time ((:%), Time, Hour, UnitName,floorUnit, hour, seriesF, toUnit) + +``` + +### Introduce custom units + +You need to write some code in order to introduce your own time units. In our task we need +work day represented as `8` hours and work week represented as `5` work days. + +```haskell +-- | Time unit for a working day (8 hours). +#if ( __GLASGOW_HASKELL__ >= 804 ) +type WorkDay = 8 * Hour +#else +type WorkDay = 28800 :% 1 +#endif + +-- | Time unit for a work week (5 working days). +#if ( __GLASGOW_HASKELL__ >= 804 ) +type WorkWeek = 5 * WorkDay +#else +type WorkWeek = 144000 :% 1 +#endif + +-- this allows to use 'Show' and 'Read' functions for our time units +type instance UnitName (28800 :% 1) = "wd" -- One WorkDay contains 28800 seconds +type instance UnitName (144000 :% 1) = "ww" -- One WorkWeek contains 144000 seconds + +``` + +### Calculations + +Now let's implement main logic of our application. Our main function should take hours, +convert them to work weeks and work days and then show in human readable format. + +```haskell +calculateWork :: Time Hour -- type synonym for 'Time HourUnit' + -> (Time WorkWeek, Time WorkDay) +calculateWork workHours = + let completeWeeks = floorUnit $ toUnit @WorkWeek workHours + completeDays = floorUnit $ toUnit @WorkDay workHours - toUnit completeWeeks + in (completeWeeks, completeDays) + +formatHours :: Time Hour -> String +formatHours hours = let (weeks, days) = calculateWork hours in show weeks ++ show days +``` + +After that we can simply print the output we wanted. + +Thought we have special function for this kind of formatting purposes `seriesF`. +So the same result can be gained with the usage of it. Check it out: + +```haskell +main :: IO () +main = do + putStrLn $ formatHours 140 + putStrLn $ seriesF @'[WorkWeek, WorkDay] $ hour 140 +``` diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,139 @@ +# O'Clock + +[![Hackage](https://img.shields.io/hackage/v/o-clock.svg)](https://hackage.haskell.org/package/o-clock) +[![Build status](https://travis-ci.org/serokell/o-clock.svg?branch=master)](https://travis-ci.org/serokell/o-clock) +[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/serokell/o-clock/blob/master/LICENSE) + +## Overview + +O'Clock is the library that provides type-safe time units data types. + +Most understandable use case is using [`threadDelay`](http://hackage.haskell.org/package/base-4.10.1.0/docs/Control-Concurrent.html#v:threadDelay) function. +If you want to wait for _5 seconds_ in your program, you need to write something like this: + +```haskell ignore +threadDelay (5 * 10^(6 :: Int)) +``` + +With O'Clock you can write in several more convenient ways (and use more preferred to you): + +```haskell ignore +threadDelay $ sec 5 +threadDelay (5 :: Time Second) +threadDelay @Second 5 +``` + +## Features + +`O'Clock` provides the following features to its users: + +1. Single data type for all time units. + + * Different time units represented as different type parameters for single `Time` data type. + Amount of required boilerplate is minimal. + +2. Time stored as `Rational` number. + + * It means that if you convert `900` milliseconds to seconds, you will have `0.9` second instead of `0` seconds. + So property `toUnit @to @from . toUnit @from @to ≡ id` is satisfied. + +3. Different unit types are stored as rational multiplier in type. + + * `o-clock` package introduces its own kind `Rat` for type-level rational numbers. + Units are stored as rational multipliers in type. Because of that some computation is performed on type-level. + So if you want to convert `Week` to `Day`, `o-clock` library ensures that time units will just be multipled by `7`. + +4. Functions from `base` that work with time are converted to more time-safe versions: + + * These functions are: `threadDelay`, `timeout`, `getCPUTime`. + +5. Externally extensible interface. + + * It means that if you want to roll out your own time units and use it in your project, + this can be done in easy and convenient way (see tutorial below). + +_**Note:**_ features support for `GHC-8.2.2` is quite limited. + +## Example: How to make your own time unit + +This README section contains tutorial on how you can introduce your own time units. +Let's solve the following problem: + +_You're CEO of big company. Your employers report you number of hours they worked this month. +You want format hours in more human-readable way, i.e. in number of work weeks and work days. +So we want `140 hours` be formatted as `3ww2wd` (3 full work weeks and 2 full work days)._ + +### Setting up + +Since this tutorial is literate haskell file, let's first write some pragmas and imports. + +```haskell +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +#if ( __GLASGOW_HASKELL__ >= 804 ) +import Time (type (*)) +#endif +import Time ((:%), Time, Hour, UnitName,floorUnit, hour, seriesF, toUnit) + +``` + +### Introduce custom units + +You need to write some code in order to introduce your own time units. In our task we need +work day represented as `8` hours and work week represented as `5` work days. + +```haskell +-- | Time unit for a working day (8 hours). +#if ( __GLASGOW_HASKELL__ >= 804 ) +type WorkDay = 8 * Hour +#else +type WorkDay = 28800 :% 1 +#endif + +-- | Time unit for a work week (5 working days). +#if ( __GLASGOW_HASKELL__ >= 804 ) +type WorkWeek = 5 * WorkDay +#else +type WorkWeek = 144000 :% 1 +#endif + +-- this allows to use 'Show' and 'Read' functions for our time units +type instance UnitName (28800 :% 1) = "wd" -- One WorkDay contains 28800 seconds +type instance UnitName (144000 :% 1) = "ww" -- One WorkWeek contains 144000 seconds + +``` + +### Calculations + +Now let's implement main logic of our application. Our main function should take hours, +convert them to work weeks and work days and then show in human readable format. + +```haskell +calculateWork :: Time Hour -- type synonym for 'Time HourUnit' + -> (Time WorkWeek, Time WorkDay) +calculateWork workHours = + let completeWeeks = floorUnit $ toUnit @WorkWeek workHours + completeDays = floorUnit $ toUnit @WorkDay workHours - toUnit completeWeeks + in (completeWeeks, completeDays) + +formatHours :: Time Hour -> String +formatHours hours = let (weeks, days) = calculateWork hours in show weeks ++ show days +``` + +After that we can simply print the output we wanted. + +Thought we have special function for this kind of formatting purposes `seriesF`. +So the same result can be gained with the usage of it. Check it out: + +```haskell +main :: IO () +main = do + putStrLn $ formatHours 140 + putStrLn $ seriesF @'[WorkWeek, WorkDay] $ hour 140 +``` diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Control.DeepSeq (NFData) +import Gauge (bench, bgroup, defaultMain, nf, whnf) + +import Time (Day, Hour, Microsecond, Nanosecond, Rat, Second, Time (..), hour, mcs, ns, sec, toUnit, + week) + +import qualified Data.Time.Units as TU (Day, Hour, Microsecond, Nanosecond, Second, Week, + convertUnit) +import qualified Tiempo (hours, microSeconds, toHours, toMicroSeconds) + + +deriving instance NFData (Time (unit :: Rat)) + +main :: IO () +main = defaultMain + [ bgroup "Second to Nanosecond" + [ bench "o'clock" $ nf (toUnit @Nanosecond . sec) 1 + , bench "time-units" $ whnf (TU.convertUnit :: TU.Second -> TU.Nanosecond) 1 + ] + , bgroup "Hour to Microsecond" + [ bench "o'clock" $ nf (toUnit @Microsecond . hour) 1 + , bench "time-units" $ whnf (TU.convertUnit :: TU.Hour -> TU.Microsecond) 1 + , bench "tiempo" $ nf (Tiempo.toMicroSeconds . Tiempo.hours) 1 + ] + , bgroup "3600000000 Microsecond to Hours" + [ bench "o'clock" $ nf (toUnit @Hour . mcs) 3600000000 + , bench "time-units" $ whnf (TU.convertUnit :: TU.Microsecond -> TU.Hour) 3600000000 + , bench "tiempo" $ nf (Tiempo.toHours . Tiempo.microSeconds) 3600000000 + ] + , bgroup "1000ns to s" + [ bench "o'clock" $ nf (toUnit @Second . ns) 1000 + , bench "time-units" $ whnf (TU.convertUnit :: TU.Nanosecond -> TU.Second) 1000 + ] + , bgroup "week to days" + [ bench "o'clock" $ nf (toUnit @Day . week ) 1 + , bench "time-units" $ whnf (TU.convertUnit :: TU.Week -> TU.Day) 1 + ] + ] diff --git a/examples/Playground.hs b/examples/Playground.hs new file mode 100644 --- /dev/null +++ b/examples/Playground.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Time (Second, Time, threadDelay) + +main :: IO () +main = do + let twoSecs = 2 :: Time Second + putStrLn "Hello!" + threadDelay twoSecs + putStrLn "Hello after 2 seconds" diff --git a/o-clock.cabal b/o-clock.cabal new file mode 100644 --- /dev/null +++ b/o-clock.cabal @@ -0,0 +1,96 @@ +name: o-clock +version: 0.0.0 +synopsis: Type-safe time library. +description: See README.md for details. +homepage: https://github.com/serokell/o-clock +bug-reports: https://github.com/serokell/o-clock/issues +license: MIT +license-file: LICENSE +author: @serokell +maintainer: Serokell +copyright: 2018 Serokell +category: Time +build-type: Simple +extra-doc-files: CHANGELOG.md + , README.md + , README.lhs +cabal-version: >=2.0 +tested-with: GHC == 8.4.1 + +source-repository head + type: git + location: https://github.com/serokell/o-clock + +library + hs-source-dirs: src + exposed-modules: Time + Time.Formatting + Time.Rational + Time.TimeStamp + Time.Units + ghc-options: -Wall + build-depends: base >= 4.10 && < 5 + , ghc-prim >= 0.5 + , transformers >= 0.5 + default-language: Haskell2010 + default-extensions: OverloadedStrings + RecordWildCards + +executable play-o-clock + main-is: Playground.hs + build-depends: o-clock + , base >= 4.10 && < 5 + hs-source-dirs: examples + default-language: Haskell2010 + ghc-options: -threaded -Wall + -fno-warn-orphans + +test-suite o-clock-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + + other-modules: Test.Time.Property + Test.Time.TimeStamp + Test.Time.TypeSpec + Test.Time.Units + + build-depends: base >= 4.10 && < 5 + , o-clock + , hedgehog ^>= 0.5.1 + , tasty ^>= 0.12 + , tasty-hedgehog ^>= 0.1 + , tasty-hspec ^>= 1.1.3 + , type-spec ^>= 0.3.0.1 + + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: OverloadedStrings + RecordWildCards + + +test-suite readme-test + type: exitcode-stdio-1.0 + main-is: README.lhs + + build-tool-depends: markdown-unlit:markdown-unlit + build-depends: base >= 4.10 && < 5 + , o-clock + , markdown-unlit ^>= 0.5 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -pgmL markdown-unlit + default-language: Haskell2010 + +benchmark o-clock-benchmark + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: benchmark + main-is: Main.hs + build-depends: base >= 4.8 && < 5 + , o-clock + , deepseq >= 1.4 + , gauge >= 0.2.1 && < 1 + , tiempo >= 0.0.1.1 + , time-units == 1.0.0 + default-extensions: OverloadedStrings + RecordWildCards diff --git a/src/Time.hs b/src/Time.hs new file mode 100644 --- /dev/null +++ b/src/Time.hs @@ -0,0 +1,16 @@ +-- | This module reexports main functionality. +-- +-- More information about @O'Clock@ features +-- can be found here: + +module Time + ( module Time.Formatting + , module Time.Rational + , module Time.TimeStamp + , module Time.Units + ) where + +import Time.Formatting +import Time.Rational +import Time.TimeStamp +import Time.Units diff --git a/src/Time/Formatting.hs b/src/Time/Formatting.hs new file mode 100644 --- /dev/null +++ b/src/Time/Formatting.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | This module introduces function to format time in desired way. + +__Examples__ + +>>> seriesF @'[Day, Hour, Minute, Second] (minute 4000) +"2d18h40m" + +>>> seriesF @'[Day, Minute, Second] (minute 4000) +"2d1120m" + +>>> seriesF @'[Hour, Minute, Second] (sec 3601) +"1h1s" + +>>> seriesF @'[Hour, Second, Millisecond] (Time @Minute $ 3 % 2) +"90s" + +-} + +module Time.Formatting + ( Series (..) + , unitsF + ) where + +import Time.Rational (Rat) +#if ( __GLASGOW_HASKELL__ >= 804 ) +import Time.Rational (withRuntimeDivRat) +#endif +import Time.Units (AllTimes, KnownRatName, Time, floorUnit, toUnit) + +-- | Class for time formatting. +class Series (units :: [Rat]) where + seriesF :: forall (someUnit :: Rat) . KnownRatName someUnit + => Time someUnit + -> String + +instance Series ('[] :: [Rat]) where + seriesF :: Time someUnit -> String + seriesF _ = "" + +instance (KnownRatName unit, Series units) + => Series (unit ': units :: [Rat]) where + seriesF :: forall (someUnit :: Rat) . KnownRatName someUnit + => Time someUnit + -> String +#if ( __GLASGOW_HASKELL__ >= 804 ) + seriesF t = let newUnit = withRuntimeDivRat @someUnit @unit $ toUnit @unit t +#else + seriesF t = let newUnit = toUnit @unit t +#endif + format = floorUnit newUnit + timeStr = case floor newUnit :: Int of + 0 -> "" + _ -> show format + in timeStr ++ seriesF @units @unit (newUnit - format) + +{- | Similar to 'seriesF', but formats using all time units of the library. + +>>> unitsF $ fortnight 5 +"5fn" + +>>> unitsF $ minute 4000 +"2d18h40m" + +-} +unitsF :: forall unit . KnownRatName unit => Time unit -> String +unitsF = seriesF @AllTimes diff --git a/src/Time/Rational.hs b/src/Time/Rational.hs new file mode 100644 --- /dev/null +++ b/src/Time/Rational.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module introduces 'Rat' kind and all necessary functional. + +module Time.Rational + ( Rat (..) + , type (:%) +#if ( __GLASGOW_HASKELL__ >= 804 ) + , type (%) + , type (*) + , type (/) +#endif + , MulK + , DivK +#if ( __GLASGOW_HASKELL__ >= 804 ) + , Gcd + , Normalize + , DivRat +#endif + + -- Utilities + , RatioNat + , KnownRat (..) + +#if ( __GLASGOW_HASKELL__ >= 804 ) + , withRuntimeDivRat +#endif + , KnownDivRat + ) where + +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import GHC.Natural (Natural) +import GHC.Real (Ratio ((:%))) +#if ( __GLASGOW_HASKELL__ >= 804 ) +import GHC.TypeNats (Div, Mod) +#endif +import GHC.TypeNats (KnownNat, Nat, natVal) +#if ( __GLASGOW_HASKELL__ >= 804 ) +import Unsafe.Coerce (unsafeCoerce) +#endif + +#if ( __GLASGOW_HASKELL__ >= 804 ) +import qualified GHC.TypeNats +#endif + +-- | Data structure represents the rational number. +-- Rational number can be represented as a pair of +-- natural numbers @n@ and @m@ where @m@ is nor equal +-- to zero. +data Rat = Nat ::% Nat + +-- | The result kind of overloaded multiplication. +type family MulK (k1 :: Type) (k2 :: Type) :: Type + +type instance MulK Nat Nat = Nat +type instance MulK Rat Rat = Rat +type instance MulK Rat Nat = Rat +type instance MulK Nat Rat = Rat + +-- | The result kind of overloaded division. +type family DivK (k1 :: Type) (k2 :: Type) :: Type + +type instance DivK Nat Nat = Rat +type instance DivK Rat Rat = Rat +type instance DivK Rat Nat = Rat +type instance DivK Nat Rat = Rat + +#if ( __GLASGOW_HASKELL__ >= 804 ) +-- | Overloaded multiplication. +type family (*) (a :: k1) (b :: k2) :: MulK k1 k2 + +type instance (a :: Nat) * (b :: Nat) = (GHC.TypeNats.*) a b +type instance (a :: Rat) * (b :: Rat) = MulRat a b +type instance (a :: Rat) * (b :: Nat) = MulNatRat b a +type instance (a :: Nat) * (b :: Rat) = MulNatRat a b + +-- | Overloaded division. +type family (/) (a :: k1) (b :: k2) :: DivK k1 k2 + +type instance (a :: Nat) / (b :: Nat) = a % b +type instance (a :: Rat) / (b :: Rat) = DivRat a b +type instance (a :: Rat) / (b :: Nat) = DivRatNat a b +type instance (a :: Nat) / (b :: Rat) = DivRat (a :% 1) b +#endif + +-- | More convenient name for promoted constructor of 'Rat'. +type (:%) = '(::%) + +#if ( __GLASGOW_HASKELL__ >= 804 ) +-- | Type family for normalized pair of 'Nat's — 'Rat'. +type family (m :: Nat) % (n :: Nat) :: Rat where + a % b = Normalize (a :% b) +infixl 7 % + +{- | Division of type-level rationals. + +If there are 'Rat' with 'Nat's @a@ and @b@ and another +'Rat' with @c@ @d@ then the following formula should be applied: + \[ + \frac{a}{b} / \frac{c}{d} = \frac{a * d}{b * c} + \] + +__Example:__ + +>>> :kind! DivRat (9 % 11) (9 % 11) +DivRat (9 % 11) (9 % 11) :: Rat += 1 :% 1 +-} +type family DivRat (m :: Rat) (n :: Rat) :: Rat where + DivRat (a :% b) (c :% d) = (a * d) % (b * c) + +{- | Multiplication for type-level rationals. + +__Example:__ + +>>> :kind! MulRat (2 % 3) (9 % 11) +MulRat (2 % 3) (9 % 11) :: Rat += 6 :% 11 +-} +type family MulRat (m :: Rat) (n :: Rat) :: Rat where + MulRat (a :% b) (c :% d) = (a * c) % (b * d) + +{- | Multiplication of type-level natural with rational. + +__Example:__ + +>>> :kind! MulNatRat 2 (9 % 11) +MulNatRat 2 (9 % 11) :: Rat += 18 :% 11 +-} +type family MulNatRat (n :: Nat) (r :: Rat) :: Rat where + MulNatRat x (a :% b) = (x * a) % b + +{- | Division of type-level rational and natural. + +__Example:__ + +>>> :kind! DivRatNat (9 % 11) 2 +DivRatNat (9 % 11) 2 :: Rat += 9 :% 22 +-} +type family DivRatNat (r :: Rat) (n :: Nat) :: Rat where + DivRatNat (a :% b) x = a % (b * x) + +{- | Greatest common divisor for type-level naturals. + +__Example:__ + +>>> :kind! Gcd 9 11 +Gcd 9 11 :: Nat += 1 + +>>> :kind! Gcd 9 12 +Gcd 9 12 :: Nat += 3 +-} +type family Gcd (m :: Nat) (n :: Nat) :: Nat where + Gcd a 0 = a + Gcd a b = Gcd b (a `Mod` b) + +{- | Normalization of type-level rational. + +__Example:__ + +>>> :kind! Normalize (9 % 11) +Normalize (9 % 11) :: Rat += 9 :% 11 + +>>> :kind! Normalize (9 % 12) +Normalize (9 % 12) :: Rat += 3 :% 4 +-} +type family Normalize (r :: Rat) :: Rat where + Normalize (a :% b) = (a `Div` Gcd a b) :% (b `Div` Gcd a b) +#endif + +-- | Rational numbers, with numerator and denominator of 'Natural' type. +type RatioNat = Ratio Natural + +-- | This class gives the integer associated with a type-level rational. +class KnownRat (r :: Rat) where + ratVal :: RatioNat + +instance (KnownNat a, KnownNat b) => KnownRat (a :% b) where + ratVal = natVal (Proxy @a) :% natVal (Proxy @b) + + +#if ( __GLASGOW_HASKELL__ >= 804 ) +newtype KnownRatDict (unit :: Rat) r = MkKnownRatDict (KnownRat unit => r) + +giftRat :: forall (unit :: Rat) r . (KnownRat unit => r) -> RatioNat -> r +giftRat given = unsafeCoerce (MkKnownRatDict given :: KnownRatDict unit r) +{-# INLINE giftRat #-} + +-- | Performs action with introduced 'DivRat' constraint for rational numbers. +withRuntimeDivRat :: forall (a :: Rat) (b :: Rat) r . (KnownRat a, KnownRat b) => (KnownRat (a / b) => r) -> r +withRuntimeDivRat r = giftRat @(a / b) r (ratVal @a / ratVal @b) +{-# INLINE withRuntimeDivRat #-} +#endif + +-- | Constraint alias for 'DivRat' units. +type KnownDivRat a b = ( KnownRat a + , KnownRat b +#if ( __GLASGOW_HASKELL__ >= 804 ) + , KnownRat (a / b) +#endif + ) diff --git a/src/Time/TimeStamp.hs b/src/Time/TimeStamp.hs new file mode 100644 --- /dev/null +++ b/src/Time/TimeStamp.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module introduces 'TimeStamp' data type +-- and corresponding functions for operations with time. + +module Time.TimeStamp + ( TimeStamp (..) + , timeDiff + , timeAdd + , timeMul + , timeDiv + ) where + +import Time.Rational (KnownRat, Rat, RatioNat) +import Time.Units (Time (..)) + +-- | Similar to 'Time' but has no units and can be negative. +newtype TimeStamp = TimeStamp Rational + deriving (Show, Read, Num, Eq, Ord, Enum, Fractional, Real, RealFrac) + + +-- | Returns the result of comparison of two 'Timestamp's and +-- the 'Time' of that difference of given time unit. +timeDiff :: forall (unit :: Rat) . KnownRat unit + => TimeStamp + -> TimeStamp + -> (Ordering, Time unit) +timeDiff (TimeStamp a) (TimeStamp b) = + let order = compare a b + d = fromRational $ case order of + EQ -> 0 + GT -> a - b + LT -> b - a + in (order, d) + +-- | Returns the result of addition of two 'Time' elements. +timeAdd :: forall (unit :: Rat) . KnownRat unit + => Time unit + -> Time unit + -> Time unit +timeAdd = (+) + +-- | Returns the result of multiplication of two 'Time' elements. +timeMul :: forall (unit :: Rat) . KnownRat unit + => RatioNat + -> Time unit + -> Time unit +timeMul n (Time t) = Time (n * t) + +-- | Returns the result of division of two 'Time' elements. +timeDiv :: forall (unit :: Rat) . KnownRat unit + => Time unit + -> Time unit + -> RatioNat +timeDiv (Time t1) (Time t2) = t1 / t2 diff --git a/src/Time/Units.hs b/src/Time/Units.hs new file mode 100644 --- /dev/null +++ b/src/Time/Units.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module contains time unit data structures +-- and functions to work with time. + +module Time.Units + ( -- * Time + Time (..) + + -- ** Time data types + , Second + , Millisecond + , Microsecond + , Nanosecond + , Picosecond + , Minute + , Hour + , Day + , Week + , Fortnight + + , AllTimes + + , UnitName + , KnownUnitName + , KnownRatName + , unitNameVal + + -- ** Creation helpers + , time + , floorUnit + + , sec + , ms + , mcs + , ns + , ps + + , minute + , hour + , day + , week + , fortnight + + , (+:) + + -- ** Functions + , toUnit + , threadDelay + , getCPUTime + , timeout + ) where + +import Control.Applicative ((*>)) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Char (isDigit, isLetter) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic) +import GHC.Natural (Natural) +import GHC.Prim (coerce) +import GHC.Read (Read (readPrec)) +import GHC.Real (Ratio ((:%)), denominator, numerator, (%)) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Text.ParserCombinators.ReadP (ReadP, char, munch1, option, pfail) +import Text.ParserCombinators.ReadPrec (ReadPrec, lift) + +#if ( __GLASGOW_HASKELL__ >= 804 ) +import Time.Rational (type (*), type (/)) +#endif +import Time.Rational (type (:%), KnownDivRat, Rat, RatioNat, KnownRat, ratVal) + +import qualified Control.Concurrent as Concurrent +import qualified System.CPUTime as CPUTime +import qualified System.Timeout as Timeout + +---------------------------------------------------------------------------- +-- Units +---------------------------------------------------------------------------- + +#if ( __GLASGOW_HASKELL__ >= 804 ) +type Second = 1 / 1 +type Millisecond = Second / 1000 +type Microsecond = Millisecond / 1000 +type Nanosecond = Microsecond / 1000 +type Picosecond = Nanosecond / 1000 + +type Minute = 60 * Second +type Hour = 60 * Minute +type Day = 24 * Hour +type Week = 7 * Day +type Fortnight = 2 * Week + +#else +type Second = 1 :% 1 +type Millisecond = 1 :% 1000 +type Microsecond = 1 :% 1000000 +type Nanosecond = 1 :% 1000000000 +type Picosecond = 1 :% 1000000000000 + +type Minute = 60 :% 1 +type Hour = 3600 :% 1 +type Day = 86400 :% 1 +type Week = 604800 :% 1 +type Fortnight = 1209600 :% 1 +#endif + +---------------------------------------------------------------------------- +-- Time data type +---------------------------------------------------------------------------- + +-- | Time unit is represented as type level rational multiplier with kind 'Rat'. +newtype Time (rat :: Rat) = Time { unTime :: RatioNat } + deriving (Eq, Ord, Enum, Real, RealFrac, Generic) + +-- | Type-level list that consist of all times. +type AllTimes = + '[ Fortnight, Week, Day, Hour, Minute, Second + , Millisecond , Microsecond, Nanosecond, Picosecond + ] + + +-- | Type family for prettier 'show' of time units. +type family UnitName (unit :: Rat) :: Symbol + +type instance UnitName (1 :% 1) = "s" -- second unit +type instance UnitName (1 :% 1000) = "ms" -- millisecond unit +type instance UnitName (1 :% 1000000) = "mcs" -- microsecond unit +type instance UnitName (1 :% 1000000000) = "ns" -- nanosecond unit +type instance UnitName (1 :% 1000000000000) = "ps" -- picosecond unit + +type instance UnitName (60 :% 1) = "m" -- minute unit +type instance UnitName (3600 :% 1) = "h" -- hour unit +type instance UnitName (86400 :% 1) = "d" -- day unit +type instance UnitName (604800 :% 1) = "w" -- week unit +type instance UnitName (1209600 :% 1) = "fn" -- fortnight unit + +-- | Constraint alias for 'KnownSymbol' 'UnitName'. +type KnownUnitName unit = KnownSymbol (UnitName unit) + +-- | Constraint alias for 'KnownUnitName' and 'KnownRat' for time unit. +type KnownRatName unit = (KnownUnitName unit, KnownRat unit) + +-- | Returns type-level 'Symbol' of the time unit converted to 'String'. +unitNameVal :: forall (unit :: Rat) . (KnownUnitName unit) => String +unitNameVal = symbolVal (Proxy @(UnitName unit)) + +instance KnownUnitName unit => Show (Time unit) where + show (Time rat) = let numeratorStr = show (numerator rat) + denominatorStr = case denominator rat of + 1 -> "" + n -> '/' : show n + in numeratorStr ++ denominatorStr ++ unitNameVal @unit + +instance KnownUnitName unit => Read (Time unit) where + readPrec :: ReadPrec (Time unit) + readPrec = lift readP + where + readP :: ReadP (Time unit) + readP = do + let naturalP = read <$> munch1 isDigit + n <- naturalP + m <- option 1 (char '/' *> naturalP) + timeUnitStr <- munch1 isLetter + unless (timeUnitStr == unitNameVal @unit) pfail + pure $ Time (n % m) + +-- | Has the same behavior as derived instance, but '*' operator +-- throws the runtime error with 'error'. +instance Num (Time unit) where + (+) = coerce ((+) :: RatioNat -> RatioNat -> RatioNat) + {-# INLINE (+) #-} + (-) = coerce ((-) :: RatioNat -> RatioNat -> RatioNat) + {-# INLINE (-) #-} + (*) = error "It's not possible to multiply time" + abs = id + {-# INLINE abs #-} + signum = coerce (signum :: RatioNat -> RatioNat) + {-# INLINE signum #-} + fromInteger = coerce (fromInteger :: Integer -> RatioNat) + {-# INLINE fromInteger #-} + +-- | Has the same behavior as derived instance, but '/' operator +-- throws the runtime error with 'error'. +instance Fractional (Time unit) where + fromRational = coerce (fromRational :: Rational -> RatioNat) + {-# INLINE fromRational #-} + (/) = error "It's not possible to divide time" + +---------------------------------------------------------------------------- +-- Creation helpers +---------------------------------------------------------------------------- + +-- | Creates 'Time' of some type from given 'Natural'. +time :: Natural -> Time unit +time n = Time (n :% 1) +{-# INLINE time #-} + +-- | Creates 'Second' from given 'Natural'. +-- +-- >>> sec 42 +-- 42s :: Time Second +sec :: Natural -> Time Second +sec = time +{-# INLINE sec #-} + +-- | Creates 'Millisecond' from given 'Natural'. +-- +-- >>> ms 42 +-- 42ms :: Time Millisecond +ms :: Natural -> Time Millisecond +ms = time +{-# INLINE ms #-} + +-- | Creates 'Microsecond' from given 'Natural'. +-- +-- >>> mcs 42 +-- 42mcs :: Time Microsecond +mcs :: Natural -> Time Microsecond +mcs = time +{-# INLINE mcs #-} + +-- | Creates 'Nanosecond' from given 'Natural'. +-- +-- >>> ns 42 +-- 42ns :: Time Nanosecond +ns :: Natural -> Time Nanosecond +ns = time +{-# INLINE ns #-} + +-- | Creates 'Picosecond' from given 'Natural'. +-- +-- >>> ps 42 +-- 42ps :: Time Picosecond +ps :: Natural -> Time Picosecond +ps = time +{-# INLINE ps #-} + +-- | Creates 'Minute' from given 'Natural'. +-- +-- >>> minute 42 +-- 42m :: Time Minute +minute :: Natural -> Time Minute +minute = time +{-# INLINE minute #-} + +-- | Creates 'Hour' from given 'Natural'. +-- +-- >>> hour 42 +-- 42h :: Time Hour +hour :: Natural -> Time Hour +hour = time +{-# INLINE hour #-} + +-- | Creates 'Day' from given 'Natural'. +-- +-- >>> day 42 +-- 42d :: Time Day +day :: Natural -> Time Day +day = time +{-# INLINE day #-} + +-- | Creates 'Week' from given 'Natural'. +-- +-- >>> sec 42 +-- 42w :: Time Week +week :: Natural -> Time Week +week = time +{-# INLINE week #-} + +-- | Creates 'Fortnight' from given 'Natural'. +-- +-- >>> fortnight 42 +-- 42fn :: Time Fortnight +fortnight :: Natural -> Time Fortnight +fortnight = time +{-# INLINE fortnight #-} + +{- | Similar to 'floor', but works with 'Time' units. + +>>> floorUnit @Day (Time $ 5 % 2) +2d + +>>> floorUnit (Time @Second $ 2 % 3) +0s + +>>> floorUnit $ ps 42 +42ps + +-} +floorUnit :: forall (unit :: Rat) . Time unit -> Time unit +floorUnit = time . floor + +-- | Sums times of different units. +-- +-- >>> minute 1 +: sec 1 +-- 61s +-- +(+:) :: forall (unitResult :: Rat) (unitLeft :: Rat) . KnownDivRat unitLeft unitResult + => Time unitLeft + -> Time unitResult + -> Time unitResult +t1 +: t2 = toUnit t1 + t2 +{-# INLINE (+:) #-} + +---------------------------------------------------------------------------- +-- Functional +---------------------------------------------------------------------------- + +{- | Converts from one time unit to another time unit. + +>>> toUnit @Hour (120 :: Time Minute) +2h + +>>> toUnit @Second (ms 7) +7/1000s + +>>> toUnit @Week (Time @Day 45) +45/7w + +>>> toUnit @Second @Minute 3 +180s + +>>> toUnit (day 42000000) :: Time Second +3628800000000s + +-} +toUnit :: forall (unitTo :: Rat) (unitFrom :: Rat) . KnownDivRat unitFrom unitTo + => Time unitFrom + -> Time unitTo +#if ( __GLASGOW_HASKELL__ >= 804 ) +toUnit Time{..} = Time $ unTime * ratVal @(unitFrom / unitTo) +#else +toUnit (Time t) = Time (t * ratVal @unitFrom / ratVal @unitTo) +#endif +{-# INLINE toUnit #-} + +{- | Convenient version of 'Control.Concurrent.threadDelay' which takes + any time-unit and operates in any MonadIO. + + +>>> threadDelay $ sec 2 +>>> threadDelay (2 :: Time Second) +>>> threadDelay @Second 2 + +-} +threadDelay :: forall (unit :: Rat) m . (KnownDivRat unit Microsecond, MonadIO m) + => Time unit + -> m () +threadDelay = liftIO . Concurrent.threadDelay . floor . toUnit @Microsecond +{-# INLINE threadDelay #-} + +-- | Similar to 'CPUTime.getCPUTime' but returns the CPU time used by the current +-- program in the given time unit. +-- The precision of this result is implementation-dependent. +-- +-- >>> getCPUTime @Second +-- 1064046949/1000000000s +getCPUTime :: forall (unit :: Rat) m . (KnownDivRat Picosecond unit, MonadIO m) + => m (Time unit) +getCPUTime = toUnit . ps . fromInteger <$> liftIO CPUTime.getCPUTime +{-# INLINE getCPUTime #-} + +{- | Similar to 'Timeout.timeout' but receiving any time unit +instead of number of microseconds. + +>>> timeout (sec 1) (putStrLn "Hello O'Clock") +Hello O'Clock +Just () + +>>> timeout (ps 1) (putStrLn "Hello O'Clock") +Nothing + +>>> timeout (mcs 1) (putStrLn "Hello O'Clock") +HellNothing + +-} +timeout :: forall (unit :: Rat) m a . (MonadIO m, KnownDivRat unit Microsecond) + => Time unit -- ^ time + -> IO a -- ^ 'IO' action + -> m (Maybe a) -- ^ returns 'Nothing' if no result is available within the given time +timeout t = liftIO . Timeout.timeout (floor $ toUnit @Microsecond t) +{-# INLINE timeout #-} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,22 @@ +module Main where + +import Test.Tasty (defaultMain, testGroup) + +import Test.Time.Property (hedgehogTestTrees) +import Test.Time.TimeStamp (timeStampTestTree) +import Test.Time.TypeSpec (runTypeSpecTests) +import Test.Time.Units (unitsTestTree) + +main :: IO () +main = do + -- type specs + runTypeSpecTests + -- Units tests with tasty: + -- * toUnit tests + -- * read tests + unitTests <- unitsTestTree + -- TimeStamp tests + tsTests <- timeStampTestTree + + let allTests = testGroup "O'Clock" $ [unitTests, tsTests] ++ hedgehogTestTrees + defaultMain allTests diff --git a/test/Test/Time/Property.hs b/test/Test/Time/Property.hs new file mode 100644 --- /dev/null +++ b/test/Test/Time/Property.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Time.Property + ( hedgehogTestTrees + ) where + +import GHC.Natural (Natural) +import GHC.Real ((%)) +import Hedgehog (MonadGen, MonadTest, Property, PropertyT, forAll, property, (===)) +import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog (testProperty) + +import Time (Day, Fortnight, Hour, KnownRat, KnownRatName, Microsecond, + Millisecond, Minute, Nanosecond, Picosecond, Rat, RatioNat, Second, + Time (..), Week, toUnit) +#if ( __GLASGOW_HASKELL__ >= 804 ) +import Time (withRuntimeDivRat) +#endif + +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +hedgehogTestTrees :: [TestTree] +hedgehogTestTrees = [readShowTestTree, toUnitTestTree] + +readShowTestTree :: TestTree +readShowTestTree = testProperty "Hedgehog read . show == id" prop_readShowUnit + +toUnitTestTree :: TestTree +toUnitTestTree = testProperty "Hedgehog toUnit @to @from . toUnit @from @to ≡ id' property" prop_toUnit + +-- | Existential data type for 'Unit's. +data AnyTime = forall (unit :: Rat) . (KnownRatName unit) + => MkAnyTime (Time unit) + +instance Show AnyTime where + show (MkAnyTime t) = show t + +-- | Returns random 'AnyTime'. +unitChooser :: (MonadGen m) => RatioNat -> m AnyTime +unitChooser t = Gen.element + [ MkAnyTime (Time @Second t) + , MkAnyTime (Time @Millisecond t) + , MkAnyTime (Time @Microsecond t) + , MkAnyTime (Time @Nanosecond t) + , MkAnyTime (Time @Picosecond t) + , MkAnyTime (Time @Minute t) + , MkAnyTime (Time @Hour t) + , MkAnyTime (Time @Day t) + , MkAnyTime (Time @Week t) + , MkAnyTime (Time @Fortnight t) + ] + +-- | Verifier for 'AnyTime' @read . show = id@. +verifyAnyTime :: (MonadTest m) => AnyTime -> m () +verifyAnyTime (MkAnyTime t) = read (show t) === t + +-- | Verifier for 'toUnit'. +verifyToUnit :: forall m . (MonadTest m) => AnyTime -> AnyTime -> m () +verifyToUnit (MkAnyTime t1) (MkAnyTime t2) = checkToUnit t1 t2 + where + checkToUnit :: forall (unitFrom :: Rat) (unitTo :: Rat) . + (KnownRatName unitFrom, KnownRat unitTo) + => Time unitFrom + -> Time unitTo + -> m () + checkToUnit t _ = +#if ( __GLASGOW_HASKELL__ >= 804 ) + withRuntimeDivRat @unitTo @unitFrom $ + withRuntimeDivRat @unitFrom @unitTo $ +#endif + toUnit (toUnit @unitTo t) === t + +-- | Generates random natural number up to 10^20. +-- it receives the lower bound so that it wouldn't be possible +-- to get 0 for denominator. +natural :: (MonadGen m) => Natural -> m Natural +natural n = Gen.integral (Range.constant n $ 10 ^ (20 :: Int)) + +-- | Generates random rational number. +rationalNum :: (MonadGen m) => m RatioNat +rationalNum = do + numeratorVal <- natural 0 + isOne <- Gen.bool + denomVal <- if isOne then pure 1 + else natural 1 + return $ numeratorVal % denomVal + +anyTime :: (MonadGen m) => m AnyTime +anyTime = rationalNum >>= unitChooser + +genAnyTime :: Monad m => PropertyT m AnyTime +genAnyTime = forAll anyTime + +-- | Property test. +prop_readShowUnit :: Property +prop_readShowUnit = property $ genAnyTime >>= verifyAnyTime + +prop_toUnit :: Property +prop_toUnit = property $ do + t1 <- genAnyTime + t2 <- genAnyTime + verifyToUnit t1 t2 diff --git a/test/Test/Time/TimeStamp.hs b/test/Test/Time/TimeStamp.hs new file mode 100644 --- /dev/null +++ b/test/Test/Time/TimeStamp.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Time.TimeStamp + ( timeStampTestTree + ) where + +import Control.Exception (evaluate) +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (Spec, anyException, describe, it, shouldBe, shouldThrow, testSpec) + +import Time (Day, Hour, Microsecond, Picosecond, Second, TimeStamp (..), Week, timeAdd, timeDiff, + timeDiv, timeMul) + +timeStampTestTree :: IO TestTree +timeStampTestTree = testSpec "TimeStamp and time operations" spec_TimeStamp + + +spec_TimeStamp :: Spec +spec_TimeStamp = do + describe "TimeDiff" $ do + it "1 is less than 5, diff is 4 seconds" $ + timeDiff @Second (TimeStamp 1) (TimeStamp 5) `shouldBe` (LT, 4) + it "100 is greater that 11, diff is 89 Days" $ + timeDiff @Day (TimeStamp 100) (TimeStamp 11) `shouldBe` (GT, 89) + it "42 is equal to 42, diff is 0 Weeks" $ + timeDiff @Week (TimeStamp 42) (TimeStamp 42) `shouldBe` (EQ, 0) + it "3 hours + 7 hours is 10" $ + timeAdd @Hour 3 7 `shouldBe` 10 + it "twice 21 mcs is 42 mcs" $ + timeMul @Microsecond 2 21 `shouldBe` 42 + it "zero x 42 s is zero" $ + timeMul @Second 0 42 `shouldBe` 0 + it "84 picoseconds divide by 2 is 42" $ + timeDiv @Picosecond 84 2 `shouldBe` 42 + it "fails when trying to divide by zero" $ + evaluate (timeDiv @Second 42 0) `shouldThrow` anyException diff --git a/test/Test/Time/TypeSpec.hs b/test/Test/Time/TypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Time/TypeSpec.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Time.TypeSpec + ( runTypeSpecTests + ) where + +-- implicit import because we import a lot of strange operators here... +import Test.TypeSpec +import Test.TypeSpecCrazy + +import Time.Rational ((:%)) +#if ( __GLASGOW_HASKELL__ >= 804 ) +import Time.Rational (type (/), Gcd, Normalize) +#endif +import Time.Units (Day, Fortnight, Hour, Microsecond, Millisecond, Minute, + Nanosecond, Picosecond, Second, UnitName, Week) + +runTypeSpecTests :: IO () +runTypeSpecTests = do +#if ( __GLASGOW_HASKELL__ >= 804 ) + print typeSpec_Gcd + print typeSpec_Normalize + print typeSpec_DivRat +#endif + print typeSpec_UnitCalculation + print typeSpec_UnitNames + +#if ( __GLASGOW_HASKELL__ >= 804 ) +typeSpec_Gcd :: + + "GCD" + ###### + + "Base cases" + ~~~~~~~~~~~~ + It "GCD 3 0 = 3" (Gcd 3 0 `Is` 3) + -*- It "GCD 0 3 = 3" (Gcd 0 3 `Is` 3) + -*- It "GCD 3 3 = 3" (Gcd 3 3 `Is` 3) + + -/- + + "Relatively simple" + ~~~~~~~~~~~~ + It "GCD 3 5 = 1" (Gcd 3 5 `Is` 1) + -*- It "GCD 2 7 = 1" (Gcd 2 7 `Is` 1) + -*- It "GCD 9 1000 = 1" (Gcd 9 1000 `Is` 1) + -*- It "GCD 1000 9 = 1" (Gcd 1000 9 `Is` 1) + + -/- + + "Common divisor" + ~~~~~~~~~~~~ + It "GCD 2 6 = 2" (Gcd 2 6 `Is` 2) + -*- It "GCD 3 6 = 3" (Gcd 3 6 `Is` 3) + -*- It "GCD 500 1000 = 500" (Gcd 500 1000 `Is` 500) + -*- It "GCD 400 1000 = 200" (Gcd 400 1000 `Is` 200) + +typeSpec_Gcd = Valid + +typeSpec_Normalize :: + + "Normalize" + ###### + + "Already normalized" + ~~~~~~~~~~~~ + It "Norm: 2/7 = 2%7" (Normalize (2 :% 7) `Is` (2 :% 7)) + -*- It "Norm: 1/9 = 1%9" (Normalize (1 :% 9) `Is` (1 :% 9)) + + -/- + + "GCD" + ~~~~~~~~~~~~ + It "Norm: 2%14 = 1%7" (Normalize (2 :% 14) `Is` (1 :% 7)) + -*- It "Norm: 300%900 = 1%3" (Normalize (300 :% 900) `Is` (1 :% 3)) + +typeSpec_Normalize = Valid + +typeSpec_DivRat :: + + "DivRat" + ###### + + "Dividing" + ~~~~~~~~~~~~ + It "2%7 / 2%7 = 1%1" ((2 / 7) / (2 / 7) `Is` (1 :% 1)) + -*- It "2%7 / 7%2 = 4%49" ((2 / 7) / (7 / 2) `Is` (4 :% 49)) + -*- It "5%6 / 25%3 = 1%10" ((5 / 6) / (25 / 3) `Is` (1 :% 10)) + +typeSpec_DivRat = Valid +#endif + +typeSpec_UnitCalculation :: + + "Units" + ###### + + "Lower" + ~~~~~~~~~~~~ + It "Second = 1 % 1" ( Second `Is` (1 :% 1)) + -*- It "Millisecond = 1 % 1000" (Millisecond `Is` (1 :% 1000)) + -*- It "Microsecond = 1 % 1000000" (Microsecond `Is` (1 :% 1000000)) + -*- It "Nanosecond = 1 % 1000000000" ( Nanosecond `Is` (1 :% 1000000000)) + -*- It "Picosecond = 1 % 1000000000000" ( Picosecond `Is` (1 :% 1000000000000)) + + -/- + + "Bigger" + ~~~~~~~~~~~~ + It "Minute = 60 % 1" (Minute `Is` (60 :% 1)) + -*- It "Hour = 3600 % 1" (Hour `Is` (3600 :% 1)) + -*- It "Day = 86400 % 1" (Day `Is` (86400 :% 1)) + -*- It "Week = 604800 % 1" (Week `Is` (604800 :% 1)) + -*- It "Fortnight = 1209600 % 1" (Fortnight `Is` (1209600 :% 1)) + +typeSpec_UnitCalculation = Valid + +typeSpec_UnitNames :: + + "Units" + ###### + + "Lower" + ~~~~~~~~~~~~ + It "UnitName Second = 's'" (UnitName Second `Is` "s") + -*- It "UnitName Millisecond = 'ms'" (UnitName Millisecond `Is` "ms") + -*- It "UnitName Microsecond = 'mcs'" (UnitName Microsecond `Is` "mcs") + -*- It "UnitName Nanosecond = 'ns'" (UnitName Nanosecond `Is` "ns") + -*- It "UnitName Picosecond = 'ps'" (UnitName Picosecond `Is` "ps") + + -/- + + "Bigger" + ~~~~~~~~~~~~ + It "UnitName Minute = 'm'" (UnitName Minute `Is` "m") + -*- It "UnitName Hour = 'h'" (UnitName Hour `Is` "h") + -*- It "UnitName Day = 'd'" (UnitName Day `Is` "d") + -*- It "UnitName Week = 'w'" (UnitName Week `Is` "w") + -*- It "UnitName Fortnight = 'fn'" (UnitName Fortnight `Is` "fn") + +typeSpec_UnitNames = Valid diff --git a/test/Test/Time/Units.hs b/test/Test/Time/Units.hs new file mode 100644 --- /dev/null +++ b/test/Test/Time/Units.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Time.Units + ( unitsTestTree + ) where + +import Control.Exception (evaluate) +import GHC.Real (Ratio ((:%))) +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (Spec, anyException, describe, it, shouldBe, shouldThrow, testSpec) + +import Time (Day, Hour, Microsecond, Millisecond, Minute, Picosecond, Second, Time (..), Week, day, + floorUnit, fortnight, hour, mcs, minute, ms, ns, ps, sec, seriesF, toUnit, unitsF, + week, (+:)) + +unitsTestTree :: IO TestTree +unitsTestTree = testSpec "Units" spec_Units + +spec_Units :: Spec +spec_Units = do + describe "Unit Conversion Test" $ do + it "11 seconds is 11000 milliseconds" $ + toUnit @Millisecond (sec 11) `shouldBe` 11000 + it "5000 milliseconds is 5 seconds" $ + toUnit @Second (ms 5000) `shouldBe` 5 + it "3 seconds is 3000000 microseconds" $ + toUnit @Microsecond (sec 3) `shouldBe` 3000000 + it "3 microseconds is 3/1000000 seconds" $ + toUnit @Second (mcs 3) `shouldBe` Time (3 :% 1000000) + it "7 days is 1 week" $ + toUnit @Week (day 7) `shouldBe` 1 + it "2 fornights is 28 days" $ + toUnit @Day (fortnight 2) `shouldBe` 28 + it "1 nanosecond is 1000 picoseconds" $ + toUnit @Picosecond (ns 1) `shouldBe` 1000 + describe "Read Time Test" $ do + it "parses '42s' as 42 seconds" $ + read @(Time Second) "42s" `shouldBe` 42 + it "fails when '42mm' is expected as seconds" $ + evaluate (read @(Time Second) "42mm") `shouldThrow` anyException + it "parses '7/2s' as 7/2 seconds" $ + read @(Time Second) "7/2s" `shouldBe` Time (7 :% 2) + it "fails when '-4s' is expected as seconds" $ + evaluate (read @(Time Second) "-4s") `shouldThrow` anyException + it "parses '14/2h' as 7 hours" $ + read @(Time Hour) "14/2h" `shouldBe` 7 + it "fails when '14/2h' expected as 7 seconds" $ + evaluate (read @(Time Second) "14/2h") `shouldThrow` anyException + it "parses big number to big number" $ + read @(Time Microsecond) ('1' : replicate 20 '0' ++ "mcs") `shouldBe` 100000000000000000000 + it "fails when '4ms' expected as 4 seconds" $ + evaluate (read @(Time Second) "4ms") `shouldThrow` anyException + describe "Floor tests" $ do + it "returns 0s when floor < 1 second" $ + floorUnit (Time @Second $ 2 :% 3) `shouldBe` 0 + it "returns 2d when floor 2.5 days" $ + floorUnit @Day (Time $ 5 :% 2) `shouldBe` 2 + it "returns 42ps when floor integer" $ + floorUnit (ps 42) `shouldBe` 42 + describe "Formatting tests" $ do + it "4000 minutes should be formatted without ending-zeros" $ + seriesF @'[Day, Hour, Minute, Second] (minute 4000) `shouldBe` "2d18h40m" + it "4000 minutes should be formatted without beginning-zeros" $ + seriesF @'[Week, Day, Hour, Minute] (minute 4000) `shouldBe` "2d18h40m" + it "3601 sec should be formatted without middle-zeros" $ + seriesF @'[Hour, Minute, Second] (sec 3601) `shouldBe` "1h1s" + it "works on rational nums" $ + seriesF @'[Hour, Second, Millisecond] (Time @Minute $ 3 :% 2) `shouldBe` "90s" + it "works without minutes formatting" $ + seriesF @'[Day, Minute, Second] (minute 4000) `shouldBe` "2d1120m" + + it "4000 minutes should be formatted like 2d18h40m" $ + unitsF (minute 4000) `shouldBe` "2d18h40m" + it "42 fortnights should be formatted like 42fn" $ + unitsF (fortnight 42) `shouldBe` "42fn" + it "empty when receive zero time" $ + unitsF (Time @Hour 0) `shouldBe` "" + it "sums all time units" $ + unitsF ( fortnight 1 +: week 1 +: day 1 +: hour 1 +: minute 1 + +: sec 1 +: ms 1 +: mcs 1 +: ns 1 +: ps 1 + ) `shouldBe` "1fn1w1d1h1m1s1ms1mcs1ns1ps"