utc (empty) → 0.1.0.0
raw patch · 23 files changed
+2087/−0 lines, 23 filesdep +Cabaldep +QuickCheckdep +attoparsecsetup-changed
Dependencies added: Cabal, QuickCheck, attoparsec, base, bytestring, clock, test-framework, test-framework-quickcheck2, text
Files
- Data/UTC.hs +121/−0
- Data/UTC/Class.hs +15/−0
- Data/UTC/Class/Epoch.hs +9/−0
- Data/UTC/Class/HasUnixTime.hs +44/−0
- Data/UTC/Class/IsDate.hs +106/−0
- Data/UTC/Class/IsDate/Test.hs +89/−0
- Data/UTC/Class/IsTime.hs +87/−0
- Data/UTC/Class/IsUnixTime.hs +21/−0
- Data/UTC/Class/Midnight.hs +9/−0
- Data/UTC/Format/Rfc3339.hs +74/−0
- Data/UTC/Format/Rfc3339/Builder.hs +67/−0
- Data/UTC/Format/Rfc3339/Parser.hs +112/−0
- Data/UTC/Internal.hs +162/−0
- Data/UTC/Internal/Test.hs +332/−0
- Data/UTC/Type.hs +11/−0
- Data/UTC/Type/Date.hs +71/−0
- Data/UTC/Type/DateTime.hs +228/−0
- Data/UTC/Type/Local.hs +126/−0
- Data/UTC/Type/Time.hs +68/−0
- LICENSE +20/−0
- Setup.hs +2/−0
- tests/Test.hs +211/−0
- utc.cabal +102/−0
+ Data/UTC.hs view
@@ -0,0 +1,121 @@+module Data.UTC+ ( + -- * Introduction+ -- ** Quick Start+ -- $quickstart++ -- ** General Concepts++ -- *** Handling Failure+ -- $failure++ -- *** Integer vs. Int+ -- $integerint++ -- *** Leap Seconds+ -- $leapseconds++ -- * Interfaces+ -- ** Date+ IsDate(..)+ -- ** Time+ , IsTime (..)+ -- ** Unix Time+ , IsUnixTime(..)+ -- ** Epoch / Midnight+ , Epoch(..)+ , Midnight(..)+ -- ** Getting (Current) Timestamps+ , HasUnixTime (..)+ -- * Generic Date/Time Types+ -- ** Date+ , Date+ -- ** Time+ , Time+ -- ** DateTime+ , DateTime (..)+ -- ** Local Time+ , Local (..)++ -- * Formatting+ -- ** RFC 3339+ -- *** Parsing+ , Rfc3339Parser(..)+ -- *** Rendering+ , Rfc3339Renderer(..)+ ) where++import Data.UTC.Class.Epoch+import Data.UTC.Class.Midnight+import Data.UTC.Class.IsDate+import Data.UTC.Class.IsTime+import Data.UTC.Class.IsUnixTime+import Data.UTC.Class.HasUnixTime+import Data.UTC.Type.Date+import Data.UTC.Type.Time+import Data.UTC.Type.DateTime+import Data.UTC.Type.Local+import Data.UTC.Format.Rfc3339++-- $quickstart+--+-- Just import the main module and use the 'DateTime' type! +-- It supports all functions you'll find below.+-- Use 'Maybe' for all occurences of 'm'.+--+-- > Prelude> :m +Data.UTC+-- > Prelude Data.UTC> type MT = Maybe (Local DateTime)+-- > Prelude Data.UTC> type MS = Maybe String+-- > Prelude Data.UTC> (parseRfc3339 "2014-12-24T13:37:00Z" :: MT) >>= addHours 25 >>= setMonth 1 >>= renderRfc3339 :: MS+-- > Just "2014-01-25T14:37:00Z"++-- $failure+--+-- The library's main idea is to make it hard to use it wrong. It should+-- be impossible by the API's design to construct invalid date or time values.+--+-- Furthermore, the library is safe in the sense that its functions don't do+-- anything that is not visible in the functions signature. Escpecially, none of the+-- functions throw exceptions via 'Prelude.error' or 'Prelude.undefined'.+--+-- Whenever a function cannot be total, its result is wrapped in a type variable with+-- a 'Prelude.Monad' restriction on it. You can always just use 'Prelude.Maybe' and+-- 'Data.Maybe.fromMaybe' to obtain a plain value:+--+-- > fromMaybe epoch (addDays 24 epoch) :: Date+-- > > 1970-01-25+--+-- Using another 'Prelude.Monad' instance might give you additional information in case of failure:+--+-- > setHour 10 midnight >>= setMinute 61 :: IO Time+-- > > *** Exception: user error (Time.setMinute 61)++-- $integerint+--+-- This library uses 'Prelude.Integer' instead of 'Prelude.Int'. This bears the advantage+-- of easier reasoning about the code's correctness and the ability+-- to work on date and time with arbitrary range and precision.+--+-- One might think that 'Prelude.Integer' is slower, but indeed it uses 'Prelude.Int'+-- internally unless its range is exceeded. The dispatching should not take more than a+-- few cycles. Using 'Prelude.Int' in the first place can rightly be considered+-- /premature optimisation/. If this really is your application's bottle neck+-- you should first consider creating your own time type (i.e. a newtyped 'Prelude.Int'+-- representing Unixtime) and making it an instance of the relevant classes.+-- Do the critical operations on the bare type. If that is not an option consider+-- using a more specialised library.++-- $leapseconds+--+-- As most other date and time libraries this library does __not support__ handling of leap seconds.+--+-- The problem is not so much that this task would be tedious and difficult, but+-- rather that future leap seconds are not known in advance and are announced+-- just a few weeks before they occur.+-- How should a library deal with this? Changing the function's semantic from version to version whenever+-- a leap second occured? Probably not desireable. The only sane answer seems to be: /Not at all!/+--+-- In reality the problem is less severe than it seems: Your system clock is most probably+-- counting unix seconds and does not know about leap seconds either. So chances are that+-- when dealing with computer generated timestamps you'll never encounter problems with+-- leap seconds.
+ Data/UTC/Class.hs view
@@ -0,0 +1,15 @@+module Data.UTC.Class+ ( module Data.UTC.Class.IsDate+ , module Data.UTC.Class.IsTime+ , module Data.UTC.Class.IsUnixTime+ , module Data.UTC.Class.HasUnixTime+ , module Data.UTC.Class.Epoch+ , module Data.UTC.Class.Midnight+ ) where++import Data.UTC.Class.Epoch+import Data.UTC.Class.Midnight+import Data.UTC.Class.IsDate+import Data.UTC.Class.IsTime+import Data.UTC.Class.IsUnixTime+import Data.UTC.Class.HasUnixTime
+ Data/UTC/Class/Epoch.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE Safe #-}+module Data.UTC.Class.Epoch+ ( Epoch(..)+ ) where++-- | The instant in time also known as __the epoch__: 1970-01-01T00:00:00Z+class Epoch t where+ epoch :: t+
+ Data/UTC/Class/HasUnixTime.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE Safe #-}+module Data.UTC.Class.HasUnixTime where++import Data.Ratio+import System.Clock as C++import Data.UTC.Class.IsUnixTime++-- | This class defines an interface for contexts that can be asked for a timestamp.+--+-- Most users are likely to just need the 'Prelude.IO' instance, but you might+-- think of other instances:+--+-- - A wrapper around the system clock with internal state that ensures+-- strict monotonically increasing values.+-- - A custom monadic computation that needs time, but should not be given+-- 'Prelude.IO' access.+-- - Testing contexts where you might want to inject and test specific timestamps.+class HasUnixTime m where+ -- | Get a timestamp from the surrounding context. The 'Prelude.IO' instance gives+ -- access to the __system clock__ and is what most users are probably looking for.+ --+ -- /Beware:/ The 'Prelude.IO' instance does __not__ guarantee that+ -- subsequent calls are monotonically increasing. The system's clock might+ -- stop or even go backwards when synchronised manually or via NTP or when+ -- adapting to a leap second.+ --+ -- /Example:/+ --+ -- > import Data.UTC+ -- > + -- > printCurrentYear :: IO ()+ -- > printCurrentYear+ -- > = do now <- getUnixTime :: IO DateTime+ -- > print (year now)+ getUnixTime :: (Monad m, IsUnixTime a) => m a++instance HasUnixTime IO where+ getUnixTime+ = do TimeSpec s ns <- C.getTime Realtime+ case fromUnixSeconds ((fromIntegral s) % 1 + (fromIntegral ns) % 1000000000) of+ Just t -> return t+ Nothing -> fail "Data.UTC.Class.HasUnixTime.getUnixTime: failed"+
+ Data/UTC/Class/IsDate.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE Safe #-}+module Data.UTC.Class.IsDate+ ( IsDate (..)+ ) where++import Data.UTC.Internal+import Data.UTC.Class.Epoch++-- | This class captures the behaviour of the __Proleptic Gregorian Calendar__.+--+-- Without any exception the following holds:+--+-- * A regular year has 365 days and the corresponding February has 28 days.+-- * A leap year has 366 days and the corresponding February has 29 days.+-- * A year that is a multiple of 400 is a leap year.+-- * A year that is a multiple of 100 but not of 400 is not a leap year.+-- * A year that is a multiple of 4 but not of 100 is a leap year.+class Epoch t => IsDate t where+ -- | > year "2014-12-24" == 2014+ -- For negative years the function assumes astronomical year+ -- numbering (year 1 ~ 1 AD, year 0 ~ 1 BC, year -1 ~ 2 BC etc).+ -- Note that 1 BC and 5 BC are therefore leap years.+ year :: t -> Integer+ -- | > month "2014-12-24" == 12+ -- The function only returns values ranging from 1 to 12.+ month :: t -> Integer+ -- | > day "2014-12-24" == 24+ -- The function only returns values ranging from 1 to 31.+ day :: t -> Integer++ -- | Sets the year and fails if the result would be invalid.+ --+ -- > setYear 2005 "2004-02-28" :: Maybe Date+ -- > > Just 2005-02-28+ -- > setYear 2005 "2004-02-29" :: Maybe Date+ -- > > Nothing+ setYear :: (Monad m) => Integer -> t -> m t+ -- | Sets the month of year and fails if the result would be invalid.+ --+ -- The function only accepts input ranging from 1 to 12.+ setMonth :: (Monad m) => Integer -> t -> m t+ -- | Sets the day of month and fails if the result would be invalid.+ --+ -- The function only accepts input ranging from 1 to 31 (or less depending on month and year).+ setDay :: (Monad m) => Integer -> t -> m t++ -- | A /year/ is a relative amount of time.+ -- The function's semantic is a follows:+ --+ -- * The years (positive or negative) are added.+ -- * If the target date is invalid then days are subtracted until the date gets valid.+ -- * If the resulting date is out of the instance type's range, the function fails+ -- (cannot happen for 'Data.UTC.Date' and 'Data.UTC.DateTime' as they use + -- multiprecision integers).+ --+ -- > addYears 4 "2000-02-29" :: Maybe Date+ -- > > Just 2004-02-29+ -- > addYears 1 "2000-02-29" :: Maybe Date+ -- > > Just 2001-02-28+ addYears :: (Monad m) => Integer -> t -> m t+ addYears ys t+ = if isValidDate (year t + ys, month t, day t)+ then setYear (year t + ys) t+ else setYear (year t + ys) =<< setDay (day t - 1) t++ -- | A /month/ is a relative amount of time.+ -- The function's semantic is equivalent to that of 'addYears'.+ --+ -- The function fails if the resulting date is out of the instance type's range+ -- (cannot happen for 'Data.UTC.Date' and 'Data.UTC.DateTime' as they use + -- multiprecision integers).+ --+ -- > addMonths (-13) "1970-01-01" :: Maybe Date+ -- > > Just 1968-12-01+ addMonths :: (Monad m) => Integer -> t -> m t+ addMonths ms t+ = setDay 1 t >>= setYear y >>= setMonth m >>= setDay d+ where+ ym = (year t * monthsPerYear)+ + (month t - 1)+ + ms+ y = ym `div` monthsPerYear+ m = (ym `mod` monthsPerYear) + 1+ d' = day t+ d | isValidDate (y, m, d') = d'+ | isValidDate (y, m, d' - 1) = d' - 1+ | isValidDate (y, m, d' - 2) = d' - 2+ | otherwise = d' - 3 -- was 31, now 28++ -- | A /day/ is an absolute amount of time. There is no surprise to expect.+ --+ -- The function fails if the resulting date is out of the instance type's range+ -- (cannot happen for 'Data.UTC.Date' and 'Data.UTC.DateTime' as they use + -- multiprecision integers).+ --+ -- > addDays 365 "1970-01-01" :: Maybe Date+ -- > > Just 1971-01-01+ -- > addDays 365 "2000-01-01" :: Maybe Date+ -- > > Just 2000-12-31+ addDays :: (Monad m) => Integer -> t -> m t+ addDays ds t+ -- setDay 1 to avoid intermediate generation of invalid dates!+ = setDay 1 t >>= setYear y >>= setMonth m >>= setDay d+ where+ ds' = yearMonthDayToDays (year t, month t, day t)+ (y, m, d) = daysToYearMonthDay (ds' + ds)
+ Data/UTC/Class/IsDate/Test.hs view
@@ -0,0 +1,89 @@+module Data.UTC.Class.IsDate.Test where++import Test.QuickCheck+import Test.Framework (testGroup)+import Test.Framework (Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++import Data.UTC++test :: Test+test+ = testGroup "Data.UTC.Class.IsDate"+ $ [ testGroup "addYears"+ [ testProperty "addYears 1 '2000-02-28'"+ $ let d = setYear 2000 (epoch :: Date) >>= setMonth 2 >>= setDay 28 >>= addYears 1+ in conjoin+ [ (year `fmap` d) === Just 2001+ , (month `fmap` d) === Just 2+ , (day `fmap` d) === Just 28+ ]+ , testProperty "addYears 1 '2000-02-29'"+ $ let d = setYear 2000 (epoch :: Date) >>= setMonth 2 >>= setDay 29 >>= addYears 1+ in conjoin+ [ (year `fmap` d) === Just 2001+ , (month `fmap` d) === Just 2+ , (day `fmap` d) === Just 28+ ]+ , testProperty "addYears 4 '2000-02-29'"+ $ let d = setYear 2000 (epoch :: Date) >>= setMonth 2 >>= setDay 29 >>= addYears 4+ in conjoin+ [ (year `fmap` d) === Just 2004+ , (month `fmap` d) === Just 2+ , (day `fmap` d) === Just 29+ ]+ , testProperty "addYears (-4) '2000-02-29'"+ $ let d = setYear 2000 (epoch :: Date) >>= setMonth 2 >>= setDay 29 >>= addYears (-4)+ in conjoin+ [ (year `fmap` d) === Just 1996+ , (month `fmap` d) === Just 2+ , (day `fmap` d) === Just 29+ ]+ ]+ , testGroup "addMonths"+ [ testProperty "addMonths 1 '2000-01-31'"+ $ let d = setYear 2000 (epoch :: Date) >>= setMonth 1 >>= setDay 31 >>= addMonths 1+ in conjoin+ [ (year `fmap` d) === Just 2000+ , (month `fmap` d) === Just 2+ , (day `fmap` d) === Just 29+ ]+ , testProperty "addMonths 2 '2000-01-31'"+ $ let d = setYear 2000 (epoch :: Date) >>= setMonth 1 >>= setDay 31 >>= addMonths 2+ in conjoin+ [ (year `fmap` d) === Just 2000+ , (month `fmap` d) === Just 3+ , (day `fmap` d) === Just 31+ ]+ , testProperty "addMonths 3 '2000-01-31'"+ $ let d = setYear 2000 (epoch :: Date) >>= setMonth 1 >>= setDay 31 >>= addMonths 3+ in conjoin+ [ (year `fmap` d) === Just 2000+ , (month `fmap` d) === Just 4+ , (day `fmap` d) === Just 30+ ]+ , testProperty "addMonths 1 '2001-01-31'"+ $ let d = setYear 2001 (epoch :: Date) >>= setMonth 1 >>= setDay 31 >>= addMonths 1+ in conjoin+ [ (year `fmap` d) === Just 2001+ , (month `fmap` d) === Just 2+ , (day `fmap` d) === Just 28+ ]+ , testProperty "addMonths (-47) '2000-01-31'"+ $ let d = setYear 2000 (epoch :: Date) >>= setMonth 1 >>= setDay 31 >>= addMonths (-47)+ in conjoin+ [ (year `fmap` d) === Just 1996+ , (month `fmap` d) === Just 2+ , (day `fmap` d) === Just 29+ ]+ ] + , testGroup "addDays"+ [ testProperty "addDays 366 '2000-01-01'"+ $ let d = setYear 2000 (epoch :: Date) >>= setMonth 1 >>= setDay 1 >>= addDays 366+ in conjoin+ [ (year `fmap` d) === Just 2001+ , (month `fmap` d) === Just 1+ , (day `fmap` d) === Just 1+ ]+ ]+ ]
+ Data/UTC/Class/IsTime.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE Safe #-}+module Data.UTC.Class.IsTime+ ( IsTime (..)+ ) where++import Data.Ratio++import Data.UTC.Internal++-- | This class captures the concept of a 24-hour clock time+-- during a day.+class IsTime t where+ -- | Returns values in the range 0 to 23.+ hour :: t -> Integer+ -- | Returns values in the range 0 to 59.+ minute :: t -> Integer+ -- | Returns values in the range 0 to 59.+ second :: t -> Integer+ -- | Returns values in the range 0.0 <= x < 1.0.+ secondFraction :: t -> Rational+ -- | Accepts values in the range 0 to 23.+ --+ -- The function fails if the result cannot be represented by the type (cannot happen for 'Data.UTC.Time' and 'Data.UTC.DateTime').+ setHour :: (Monad m) => Integer -> t -> m t+ -- | Accepts values in the range 0 to 59.+ --+ -- The function fails if the result cannot be represented by the type (cannot happen for 'Data.UTC.Time' and 'Data.UTC.DateTime').+ setMinute :: (Monad m) => Integer -> t -> m t+ -- | Accepts values in the range 0 to 59.+ --+ -- The function fails if the result cannot be represented by the type (cannot happen for 'Data.UTC.Time' and 'Data.UTC.DateTime').+ setSecond :: (Monad m) => Integer -> t -> m t+ -- | Accepts values in the range 0.0 <= x < 1.0.+ --+ -- The function fails if the result cannot be represented by the type (cannot happen for 'Data.UTC.Time' and 'Data.UTC.DateTime').+ setSecondFraction :: (Monad m) => Rational -> t -> m t++ -- | Adds an arbitrary count of hours (positive or negative).+ --+ -- * Full days flow over to 'Data.UTC.addDays' if the type is also an instance of 'Data.UTC.Class.IsDate' (this is the case for 'Data.UTC.DateTime').+ -- * Types not implementing the 'Data.UTC.Class.IsDate' class should just ignore the days part on overflow (like 'Data.UTC.Time' does).+ -- * Fails if the result cannot be represented by the type (cannot happen for 'Data.UTC.Time' and 'Data.UTC.DateTime').+ addHours :: (Monad m) => Integer -> t -> m t+ addHours h t+ = setHour hors t+ where+ h' = h + (hour t)+ hors = h' `mod` hoursPerDay++ -- | Adds an arbitrary count of minutes (positive or negative).+ --+ -- * Full hours flow over to 'addHours'.+ -- * Fails if the result cannot be represented by the type (cannot happen for 'Data.UTC.Time' and 'Data.UTC.DateTime').+ addMinutes :: (Monad m) => Integer -> t -> m t+ addMinutes m t+ = setMinute mins t >>= addHours hors+ where+ m' = m + (minute t)+ mins = m' `mod` minsPerHour+ hors = m' `div` minsPerHour++ -- | Adds an arbitrary count of seconds (positive or negative).+ --+ -- * Full minutes flow over to 'addMinutes'.+ -- * Fails if the result cannot be represented by the type (cannot happen for 'Data.UTC.Time' and 'Data.UTC.DateTime').+ addSeconds :: (Monad m) => Integer -> t -> m t+ addSeconds s t+ = setSecond secs t >>= addMinutes mins+ where+ s' = s + (second t)+ secs = s' `mod` secsPerMinute+ mins = s' `div` secsPerMinute++ -- | Adds an arbitrary second fraction (positive or negative).+ --+ -- * Full seconds flow over to 'addSeconds'.+ -- * Instances of this class are not required to preserve full precision (although 'Data.UTC.Time' and 'Data.UTC.DateTime' do so).+ -- * Fails if the result cannot be represented by the type (cannot happen for 'Data.UTC.Time' and 'Data.UTC.DateTime').+ addSecondFractions :: (Monad m) => Rational -> t -> m t+ addSecondFractions f t+ | f == 0 = return t+ | f >= 0 = setSecondFraction frcs t >>= addSeconds secs+ | otherwise = setSecondFraction (frcs + 1.0) t >>= addSeconds (secs - 1)+ where+ f' = f + (secondFraction t)+ frcs = f' - (truncate f' % 1)+ secs = truncate f'
+ Data/UTC/Class/IsUnixTime.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE Safe #-}+module Data.UTC.Class.IsUnixTime+ ( IsUnixTime(..)+ ) where++-- | This class is for types that have a well-defined+-- mapping to and from the <https://en.wikipedia.org/wiki/Unix_time Unix Time> system +-- (based on <https://en.wikipedia.org/wiki/Coordinated_Universal_Time UTC>).+--+-- /Beware/: It is a common misconception that the Unix time in general counts+-- <https://en.wikipedia.org/wiki/International_System_of_Units SI> seconds since 1970-01-01T00:00:00Z.+-- There is a common definition that may be called /Unix time based on UTC/: In general, the second+-- boundaries match with UTC, but in the event of a positive (or negative) leap second+-- the Unix second has a duration of 2 (or 0) SI seconds. This library is in accordance with+-- this definition. This definition can also be understood as "ignoring leap seconds"+-- (a Unix day therefore always has 86400 Unix seconds).+--+-- The concrete behaviour of your system clock is implementation dependant.+class IsUnixTime t where+ unixSeconds :: t -> Rational+ fromUnixSeconds :: Monad m => Rational -> m t
+ Data/UTC/Class/Midnight.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE Safe #-}+module Data.UTC.Class.Midnight+ ( Midnight(..)+ ) where++-- | The beginning of a day: 00:00:00+class Midnight t where+ midnight :: t+
+ Data/UTC/Format/Rfc3339.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleInstances #-}+module Data.UTC.Format.Rfc3339+ ( -- * Parsing+ Rfc3339Parser(..)+ -- * Rendering+ , Rfc3339Renderer(..)+ -- * Low-Level+ , rfc3339Parser, rfc3339Builder+ ) where++import qualified Data.Attoparsec.ByteString as Atto+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Builder as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL++import Data.UTC.Class.Epoch+import Data.UTC.Class.IsDate+import Data.UTC.Class.IsTime+import Data.UTC.Type.Local+import Data.UTC.Format.Rfc3339.Parser+import Data.UTC.Format.Rfc3339.Builder++class Rfc3339Parser a where+ parseRfc3339 :: (Monad m, IsDate t, IsTime t, Epoch t) => a -> m (Local t)++instance Rfc3339Parser BS.ByteString where+ parseRfc3339 s+ = case Atto.parseOnly rfc3339Parser s of+ Right t -> return t+ Left _ -> fail ""++instance Rfc3339Parser BSL.ByteString where+ parseRfc3339 s+ = parseRfc3339 (BSL.toStrict s)++instance Rfc3339Parser T.Text where+ parseRfc3339 s+ = parseRfc3339 (T.encodeUtf8 s)++instance Rfc3339Parser TL.Text where+ parseRfc3339 s+ = parseRfc3339 (TL.encodeUtf8 s)++instance Rfc3339Parser [Char] where+ parseRfc3339 s+ = parseRfc3339 (T.pack s)+++class Rfc3339Renderer a where+ renderRfc3339 :: (Monad m, IsDate t, IsTime t, Epoch t) => Local t -> m a++instance Rfc3339Renderer BS.ByteString where+ renderRfc3339 t+ = renderRfc3339 t >>= return . BSL.toStrict++instance Rfc3339Renderer BSL.ByteString where+ renderRfc3339 t+ = rfc3339Builder t >>= return . B.toLazyByteString++instance Rfc3339Renderer T.Text where+ renderRfc3339 t+ = renderRfc3339 t >>= return . T.decodeUtf8++instance Rfc3339Renderer TL.Text where+ renderRfc3339 t+ = renderRfc3339 t >>= return . TL.decodeUtf8++instance Rfc3339Renderer [Char] where+ renderRfc3339 t + = renderRfc3339 t >>= return . T.unpack
+ Data/UTC/Format/Rfc3339/Builder.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE Safe #-}+module Data.UTC.Format.Rfc3339.Builder+ ( rfc3339Builder+ ) where++import Data.Monoid+import Data.ByteString.Builder as BS++import Data.UTC.Type.Local+import Data.UTC.Class.IsDate+import Data.UTC.Class.IsTime++rfc3339Builder :: (Monad m, IsDate t, IsTime t) => Local t -> m BS.Builder+rfc3339Builder (Local t os)+ = do -- calculate the single digits+ let y3 = fromIntegral $ year t `div` 1000 `mod` 10+ y2 = fromIntegral $ year t `div` 100 `mod` 10+ y1 = fromIntegral $ year t `div` 10 `mod` 10+ y0 = fromIntegral $ year t `div` 1 `mod` 10+ m1 = fromIntegral $ month t `div` 10 `mod` 10+ m0 = fromIntegral $ month t `div` 1 `mod` 10+ d1 = fromIntegral $ day t `div` 10 `mod` 10+ d0 = fromIntegral $ day t `div` 1 `mod` 10+ h1 = fromIntegral $ hour t `div` 10 `mod` 10+ h0 = fromIntegral $ hour t `div` 1 `mod` 10+ n1 = fromIntegral $ minute t `div` 10 `mod` 10+ n0 = fromIntegral $ minute t `div` 1 `mod` 10+ s1 = fromIntegral $ second t `div` 10 `mod` 10+ s0 = fromIntegral $ second t `div` 1 `mod` 10+ f2 = truncate (secondFraction t * 10) `mod` 10+ f1 = truncate (secondFraction t * 100) `mod` 10+ f0 = truncate (secondFraction t * 1000) `mod` 10+ return $ mconcat+ [ BS.word16HexFixed (y3*16*16*16 + y2*16*16 + y1*16 + y0)+ , BS.char7 '-'+ , BS.word8HexFixed (m1*16 + m0)+ , BS.char7 '-'+ , BS.word8HexFixed (d1*16 + d0)+ , BS.char7 'T'+ , BS.word8HexFixed (h1*16 + h0)+ , BS.char7 ':'+ , BS.word8HexFixed (n1*16 + n0)+ , BS.char7 ':'+ , BS.word8HexFixed (s1*16 + s0)+ , if f0 == 0+ then if f1 == 0+ then if f2 == 0+ then mempty+ else BS.char7 '.' `mappend` BS.intDec f2+ else BS.char7 '.' `mappend` BS.intDec f2 `mappend` BS.intDec f1+ else BS.char7 '.' `mappend` BS.intDec f2 `mappend` BS.intDec f1 `mappend` BS.intDec f0+ , case os of+ Nothing -> BS.string7 "-00:00"+ Just 0 -> BS.char7 'Z'+ Just o -> let oh1 = fromIntegral $ abs (truncate o `quot` 600 `rem` 10 :: Integer)+ oh0 = fromIntegral $ abs (truncate o `quot` 60 `rem` 10 :: Integer)+ om1 = fromIntegral $ abs (truncate o `rem` 60 `quot` 10 `rem` 10 :: Integer)+ om0 = fromIntegral $ abs (truncate o `rem` 60 `rem` 10 :: Integer)+ in mconcat+ [ if o < 0+ then BS.char7 '-'+ else BS.char7 '+'+ , BS.word8HexFixed (oh1*16 + oh0)+ , BS.char7 ':'+ , BS.word8HexFixed (om1*16 + om0)+ ]+ ]
+ Data/UTC/Format/Rfc3339/Parser.hs view
@@ -0,0 +1,112 @@+module Data.UTC.Format.Rfc3339.Parser+ ( rfc3339Parser+ ) where++import Data.Ratio++import Data.Attoparsec.ByteString ( Parser, skipWhile, choice, option, satisfy )+import Data.Attoparsec.ByteString.Char8 ( char, isDigit_w8 )++import Data.UTC.Class.Epoch+import Data.UTC.Class.IsDate+import Data.UTC.Class.IsTime+import Data.UTC.Type.Local++rfc3339Parser :: (IsDate t, IsTime t) => Parser (Local t)+rfc3339Parser + = do year' <- dateFullYear+ _ <- char '-'+ month' <- dateMonth+ _ <- char '-'+ day' <- dateMDay+ _ <- char 'T'+ hour' <- timeHour+ _ <- char ':'+ minute' <- timeMinute+ _ <- char ':'+ second' <- timeSecond+ secfrac' <- option 0 timeSecfrac+ offset' <- timeOffset+ datetime <- return epoch+ >>= setYear year'+ >>= setMonth month'+ >>= setDay day'+ >>= setHour hour'+ >>= setMinute minute'+ >>= setSecond second'+ >>= setSecondFraction secfrac'+ return (Local datetime offset')+ where+ dateFullYear+ = decimal4+ dateMonth+ = decimal2+ dateMDay+ = decimal2+ timeHour+ = decimal2+ timeMinute+ = decimal2+ timeSecond+ = decimal2+ timeSecfrac+ = do _ <- char '.'+ choice+ [ do d <- decimal3+ skipWhile isDigit_w8+ return (d % 1000)+ , do d <- decimal2+ return (d % 100)+ , do d <- decimal1+ return (d % 10)+ ]+ timeOffset+ = choice+ [ do _ <- char 'Z'+ return $ Just 0+ , do _ <- char '+'+ x1 <- decimal2+ _ <- char ':'+ x2 <- decimal2+ return $ Just+ $ (x1 * 3600 + x2 * 60) % 1+ , do _ <- char '-'+ _ <- char '0'+ _ <- char '0'+ _ <- char ':'+ _ <- char '0'+ _ <- char '0'+ return Nothing+ , do _ <- char '-'+ x1 <- decimal2+ _ <- char ':'+ x2 <- decimal2+ return $ Just+ $ negate+ $ (x1 * 3600 + x2 * 60) % 1+ ]++ decimal1+ = do w8 <- satisfy isDigit_w8+ return (fromIntegral (w8 - 48))+ decimal2+ = do d1 <- decimal1+ d2 <- decimal1+ return $ d1 * 10+ + d2+ decimal3+ = do d1 <- decimal1+ d2 <- decimal1+ d3 <- decimal1+ return $ d1 * 100+ + d2 * 10+ + d3+ decimal4+ = do d1 <- decimal1+ d2 <- decimal1+ d3 <- decimal1+ d4 <- decimal1+ return $ d1 * 1000+ + d2 * 100+ + d3 * 10+ + d4
+ Data/UTC/Internal.hs view
@@ -0,0 +1,162 @@+module Data.UTC.Internal+ ( daysToYearMonthDay+ , yearMonthDayToDays++ , yearToDays+ , daysToYear++ , deltaUnixEpochCommonEpoch++ , isValidDate++ , secsPerDay, secsPerHour, secsPerMinute, minsPerHour, hoursPerDay+ , monthsPerYear+ ) where++deltaUnixEpochCommonEpoch :: Rational+deltaUnixEpochCommonEpoch+ = 62167219200++secsPerDay :: Integer+secsPerDay+ = hoursPerDay * secsPerHour++secsPerHour :: Integer+secsPerHour+ = minsPerHour * secsPerMinute++secsPerMinute :: Integer+secsPerMinute+ = 60++minsPerHour :: Integer+minsPerHour+ = 60++hoursPerDay :: Integer+hoursPerDay+ = 24++monthsPerYear :: Integer+monthsPerYear+ = 12++-- | Convert Year-Month-Day to since 0000-01-01 in the Gregorian Calendar+--+-- * year 0 is a leap year+-- * year 400 is a leap year+-- * year 100,200,300 is not a leap year+-- * year / 4 is a leap year+-- * year (-4) (5 BC) is a leap year++-- * AD/BC vs. astronomical year numbering (as used by ISO8601)+-- * year 0 ia 1 BC+-- * year (-1) is 2 BC+-- * year (-2) is 3 BC etc.++yearMonthDayToDays :: (Integer, Integer, Integer) -> Integer+yearMonthDayToDays (year,month,day)+ = -- count of days of the "finalised" years+ let daysY = yearToDays year+ -- count of days of the "finalised" months+ daysM = case month - 1 of+ 1 -> 31+ 2 -> 31 + 28 + leapDay+ 3 -> 31 + 28 + 31 + leapDay+ 4 -> 31 + 28 + 31 + 30 + leapDay+ 5 -> 31 + 28 + 31 + 30 + 31 + leapDay+ 6 -> 31 + 28 + 31 + 30 + 31 + 30 + leapDay+ 7 -> 31 + 28 + 31 + 30 + 31 + 30 + 31 + leapDay+ 8 -> 31 + 28 + 31 + 30 + 31 + 30 + 31 + 31 + leapDay+ 9 -> 31 + 28 + 31 + 30 + 31 + 30 + 31 + 31 + 30 + leapDay+ 10 -> 31 + 28 + 31 + 30 + 31 + 30 + 31 + 31 + 30 + 31 + leapDay+ 11 -> 31 + 28 + 31 + 30 + 31 + 30 + 31 + 31 + 30 + 31 + 30 + leapDay+ _ -> 0+ -- count of the "finalised" days+ daysD = day - 1+ in daysY + daysM + daysD+ where+ leapDay :: Integer+ leapDay+ | (year `mod` 4 == 0) && ((year `mod` 400 == 0) || (year `mod` 100 /= 0)) = 1+ | otherwise = 0++yearToDays :: Integer -> Integer+yearToDays y+ | y == 0 = 0+ | y >= 0 = 366+ + ((y-1) * 365) -- .. and a normal year has 365 days ..+ + ((y-1) `quot` 4) -- .. and every 4 years a leap day occurs..+ - ((y-1) `quot` 100) -- .. but not in centuries ..+ + ((y-1) `quot` 400) -- .. except every 400 years.+ | otherwise = (y * 365)+ + (y `quot` 4)+ - (y `quot` 100)+ + (y `quot` 400)++daysToYear :: Integer -> Integer+daysToYear ds+ = if ds <= d+ then y - 1+ else y+ where+ y = ds `div` 365+ d = yearToDays y++daysToYearMonthDay :: Integer -> (Integer, Integer, Integer)+daysToYearMonthDay d'+ = (year + y400 * 400, month, day)+ where+ d400 = yearToDays 400+ y400 = d' `div` d400+ d = d' `mod` d400+ year = daysToYear (d + 1)+ ld = if (year `mod` 4 == 0) &&+ ((year `mod` 400 == 0)+ || (year `mod` 100 /= 0)) then (1+) else id+ doy = d - yearToDays year+ (month,day) + | doy < 31 = ( 1, doy + 1)+ | doy < ld 59 = ( 2, doy - 31 + 1)+ | doy < ld 90 = ( 3, doy - ld 59 + 1)+ | doy < ld 120 = ( 4, doy - ld 90 + 1)+ | doy < ld 151 = ( 5, doy - ld 120 + 1)+ | doy < ld 181 = ( 6, doy - ld 151 + 1)+ | doy < ld 212 = ( 7, doy - ld 181 + 1)+ | doy < ld 243 = ( 8, doy - ld 212 + 1)+ | doy < ld 273 = ( 9, doy - ld 243 + 1)+ | doy < ld 304 = (10, doy - ld 273 + 1)+ | doy < ld 334 = (11, doy - ld 304 + 1)+ | otherwise = (12, doy - ld 334 + 1)++isValidDate :: (Integer, Integer, Integer) -> Bool+isValidDate (y,m,d)+ | m < 1 = False+ | m > 12 = False+ | otherwise = case m of+ 1 -> validateDays31+ 2 -> validateDays28or29+ 3 -> validateDays31+ 4 -> validateDays30+ 5 -> validateDays31+ 6 -> validateDays30+ 7 -> validateDays31+ 8 -> validateDays31+ 9 -> validateDays30+ 10 -> validateDays31+ 11 -> validateDays30+ 12 -> validateDays31+ _ -> False+ where+ validateDays31+ | 1 <= d && d <= 31 = True+ | otherwise = False+ validateDays30+ | 1 <= d && d <= 30 = True+ | otherwise = False+ validateDays28or29+ | 1 <= d && d <= 28 = True+ | d == 29 && isLeapYear = True+ | otherwise = False+ isLeapYear+ = (y `mod` 4 == 0) && ((y `mod` 400 == 0) || (y `mod` 100 /= 0))
+ Data/UTC/Internal/Test.hs view
@@ -0,0 +1,332 @@+module Data.UTC.Internal.Test where++import Test.QuickCheck+import Test.Framework (testGroup)+import Test.Framework (Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++import Data.UTC.Internal++test :: Test+test+ = testGroup "Data.UTC.Internal"+ $ [ testYearMonthDayToDays+ , testYearToDays+ , testYearToDaysAndDaysToYear+ , testDaysToYearMonthDay+ , testYearMonthDayToDaysAndDaysToYearMonthDay++ , testProperty "yearMonthDayToDays for every day in year 0-400"+ $ conjoin+ $ map (\(ds, ymd)-> ds == yearMonthDayToDays ymd+ ) (dayDateTuples)++ , testProperty "daysToYearMonthDay for every day in year 0-400"+ $ conjoin+ $ map (\(ds, ymd)-> daysToYearMonthDay ds == ymd+ ) (dayDateTuples)+ ]++dayDateTuples :: [(Integer, (Integer, Integer, Integer))]+dayDateTuples+ = zip [0..]+ [ (y,m,d) | y <- [0..400]+ , m <- [1..12]+ , d <- [1..31]+ , isValidDate (y,m,d)+ ]++testYearMonthDayToDays :: Test+testYearMonthDayToDays+ = testGroup "yearMonthDayToDays"+ $ [ testProperty ("yearMonthDayToDays (0,1,1) === 0")+ $ yearMonthDayToDays (0,1,1) === 0++ , testProperty ("yearMonthDayToDays (1,1,1) === 366 + 365")+ $ yearMonthDayToDays (1,1,1) === 366++ , testProperty ("yearMonthDayToDays (2,1,1) === 366 + 365")+ $ yearMonthDayToDays (2,1,1) === 366 + 365++ , testProperty ("yearMonthDayToDays (3,1,1) === 366 + 365 + 365")+ $ yearMonthDayToDays (3,1,1) === 366 + 365 + 365++ , testProperty ("yearMonthDayToDays (4,1,1) === 366 + 365 + 365 + 365")+ $ yearMonthDayToDays (4,1,1) === 366 + 365 + 365 + 365++ , testProperty ("yearMonthDayToDays (4,3,3) === 366 + 365 + 365 + 365 + 31 + 29 + 2")+ $ yearMonthDayToDays (4,3,3) === 366 + 365 + 365 + 365 + 31 + 29 + 2+ ]++testYearToDaysAndDaysToYear :: Test+testYearToDaysAndDaysToYear+ = testGroup "yearToDays <-> daysToYear"+ $ [ testProperty "yearToDays (daysToYear x) - x === 0"+ $ forAll (choose (0, 146463))+ $ \x-> (x - yearToDays (daysToYear x)) `div` 366 === 0+ ]++testYearToDays :: Test+testYearToDays+ = testGroup "yearToDays"+ $ [ testProperty "400 years are 146463 days"+ $ yearToDays 401 === (fromIntegral $ length dayDateTuples)+ , testProperty ("yearToDays 800 === 365 * 800 + length " ++ show (js 800))+ $ yearToDays 800 === 365 * 800 + (fromIntegral $ length (js 800))+ , testProperty ("yearToDays 700 === 365 * 700 + length " ++ show (js 700))+ $ yearToDays 700 === 365 * 700 + (fromIntegral $ length (js 700))+ , testProperty ("yearToDays 600 === 365 * 600 + length " ++ show (js 600))+ $ yearToDays 600 === 365 * 600 + (fromIntegral $ length (js 600))+ , testProperty ("yearToDays 500 === 365 * 500 + length " ++ show (js 500))+ $ yearToDays 500 === 365 * 500 + (fromIntegral $ length (js 500))+ , testProperty ("yearToDays 401 === 365 * 401 + length " ++ show (js 401))+ $ yearToDays 401 === 365 * 401 + (fromIntegral $ length (js 401))+ , testProperty ("yearToDays 400 === 365 * 400 + length " ++ show (js 400))+ $ yearToDays 400 === 365 * 400 + (fromIntegral $ length (js 400))+ , testProperty ("yearToDays 399 === 365 * 399 + length " ++ show (js 399))+ $ yearToDays 399 === 365 * 399 + (fromIntegral $ length (js 399))+ , testProperty ("yearToDays 300 === 365 * 300 + length " ++ show (js 300))+ $ yearToDays 300 === 365 * 300 + (fromIntegral $ length (js 300))+ , testProperty ("yearToDays 200 === 365 * 200 + length " ++ show (js 200))+ $ yearToDays 200 === 365 * 200 + (fromIntegral $ length (js 200))+ , testProperty ("yearToDays 101 === 365 * 101 + length " ++ show (js 101))+ $ yearToDays 101 === 365 * 101 + (fromIntegral $ length (js 101))+ , testProperty ("yearToDays 100 === 365 * 100 + length " ++ show (js 100))+ $ yearToDays 100 === 365 * 100 + (fromIntegral $ length (js 100))+ , testProperty ("yearToDays 99 === 365 * 99 + length " ++ show (js 99))+ $ yearToDays 99 === 365 * 99 + (fromIntegral $ length (js 99))+ , testProperty ("yearToDays 4 === 365 * 4 + length " ++ show (js 4))+ $ yearToDays 4 === 365 * 4 + (fromIntegral $ length (js 4))+ , testProperty ("yearToDays 3 === 365 * 3 + length " ++ show (js 3))+ $ yearToDays 3 === 365 * 3 + (fromIntegral $ length (js 3))+ , testProperty ("yearToDays 2 === 365 * 2 + length " ++ show (js 2))+ $ yearToDays 2 === 365 * 2 + (fromIntegral $ length (js 2))+ , testProperty ("yearToDays 1 === 365 * 1 + length " ++ show (js 1))+ $ yearToDays 1 === 365 * 1 + (fromIntegral $ length (js 1))+ , testProperty "yearToDays 0 === 0"+ $ yearToDays 0 === 0+ , testProperty "yearToDays (-1) === 0 - 365"+ $ yearToDays (-1) === 0 - 365+ , testProperty "yearToDays (-2) === 0 - 365 - 365"+ $ yearToDays (-2) === 0 - 365 - 365+ , testProperty "yearToDays (-3) === 0 - 365 - 365 - 365"+ $ yearToDays (-3) === 0 - 365 - 365 - 365+ , testProperty "yearToDays (-4) === 0 - 365 - 365 - 365 - 366"+ $ yearToDays (-4) === 0 - 365 - 365 - 365 - 366+ , testProperty ("yearToDays (-100) === (-365) * 100 - length " ++ show (ls 100))+ $ yearToDays (-100) === (-365) * 100 - (fromIntegral $ length (ls 100))+ , testProperty ("yearToDays (-200) === (-365) * 200 - length " ++ show (ls 200))+ $ yearToDays (-200) === (-365) * 200 - (fromIntegral $ length (ls 200))+ , testProperty ("yearToDays (-300) === (-365) * 300 - length " ++ show (ls 300))+ $ yearToDays (-300) === (-365) * 300 - (fromIntegral $ length (ls 300))+ , testProperty ("yearToDays (-400) === (-365) * 400 - length " ++ show (ls 400))+ $ yearToDays (-400) === (-365) * 400 - (fromIntegral $ length (ls 400))+ ]+ where+ ls :: Int -> [Int]+ ls z = [x | x <- [negate z..(-1)], x `mod` 400 == 0 || (x `mod` 4 == 0 && x `mod` 100 /= 0 )]+ js :: Int -> [Int]+ js z = [x | x <- [0..(z-1)], x `mod` 400 == 0 || (x `mod` 4 == 0 && x `mod` 100 /= 0 )]++testDaysToYearMonthDay :: Test+testDaysToYearMonthDay+ = testGroup "daysToYearMonthDay"+ $ [ + testProperty "daysToYearMonthDay 366 === (1,1,1)"+ $ daysToYearMonthDay 366 === (1,1,1)++ , testProperty "daysToYearMonthDay 365 === (0,12,31)"+ $ daysToYearMonthDay 365 === (0,12,31)++ , testProperty "daysToYearMonthDay 335 === (0,12,1)"+ $ daysToYearMonthDay 335 === (0,12,1)++ , testProperty "daysToYearMonthDay 334 === (0,11,30)"+ $ daysToYearMonthDay 334 === (0,11,30)++ , testProperty "daysToYearMonthDay 305 === (0,11,1)"+ $ daysToYearMonthDay 305 === (0,11,1)++ , testProperty "daysToYearMonthDay 304 === (0,10,31)"+ $ daysToYearMonthDay 304 === (0,10,31)++ , testProperty "daysToYearMonthDay 274 === (0,10,1)"+ $ daysToYearMonthDay 274 === (0,10,1)++ , testProperty "daysToYearMonthDay 273 === (0,9,30)"+ $ daysToYearMonthDay 273 === (0,9,30)++ , testProperty "daysToYearMonthDay 244 === (0,9,1)"+ $ daysToYearMonthDay 244 === (0,9,1)++ , testProperty "daysToYearMonthDay 243 === (0,8,31)"+ $ daysToYearMonthDay 243 === (0,8,31)++ , testProperty "daysToYearMonthDay 213 === (0,8,1)"+ $ daysToYearMonthDay 213 === (0,8,1)++ , testProperty "daysToYearMonthDay 212 === (0,7,31)"+ $ daysToYearMonthDay 212 === (0,7,31)++ , testProperty "daysToYearMonthDay 182 === (0,7,1)"+ $ daysToYearMonthDay 182 === (0,7,1)++ , testProperty "daysToYearMonthDay 181 === (0,6,30)"+ $ daysToYearMonthDay 181 === (0,6,30)++ , testProperty "daysToYearMonthDay 152 === (0,6,1)"+ $ daysToYearMonthDay 152 === (0,6,1)++ , testProperty "daysToYearMonthDay 151 === (0,5,31)"+ $ daysToYearMonthDay 151 === (0,5,31)++ , testProperty "daysToYearMonthDay 121 === (0,5,1)"+ $ daysToYearMonthDay 121 === (0,5,1)++ , testProperty "daysToYearMonthDay 120 === (0,4,30)"+ $ daysToYearMonthDay 120 === (0,4,30)++ , testProperty "daysToYearMonthDay 91 === (0,4,1)"+ $ daysToYearMonthDay 91 === (0,4,1)++ , testProperty "daysToYearMonthDay 90 === (0,3,31)"+ $ daysToYearMonthDay 90 === (0,3,31)++ , testProperty "daysToYearMonthDay 60 === (0,3,1)"+ $ daysToYearMonthDay 60 === (0,3,1)++ , testProperty "daysToYearMonthDay 59 === (0,2,29)"+ $ daysToYearMonthDay 59 === (0,2,29)++ , testProperty "daysToYearMonthDay 58 === (0,2,28)"+ $ daysToYearMonthDay 58 === (0,2,28)++ , testProperty "daysToYearMonthDay 31 === (0,2,1)"+ $ daysToYearMonthDay 31 === (0,2,1)++ , testProperty "daysToYearMonthDay 30 === (0,1,31)"+ $ daysToYearMonthDay 30 === (0,1,31)++ , testProperty "daysToYearMonthDay 0 === (0,1,1)"+ $ daysToYearMonthDay 0 === (0,1,1)++ , testProperty "daysToYearMonthDay (-1) === (-1,12,31)"+ $ daysToYearMonthDay (-1) === (-1,12,31)++ , testProperty "daysToYearMonthDay (-31) === (-1,12,1)"+ $ daysToYearMonthDay (-31) === (-1,12,1)++ , testProperty "daysToYearMonthDay (-32) === (-1,11,30)"+ $ daysToYearMonthDay (-32) === (-1,11,30)++ , testProperty "daysToYearMonthDay (-61) === (-1,11,1)"+ $ daysToYearMonthDay (-61) === (-1,11,1)++ , testProperty "daysToYearMonthDay (-62) === (-1,10,31)"+ $ daysToYearMonthDay (-62) === (-1,10,31)++ , testProperty "daysToYearMonthDay (-92) === (-1,10,1)"+ $ daysToYearMonthDay (-92) === (-1,10,1)++ , testProperty "daysToYearMonthDay (-93) === (-1,9,30)"+ $ daysToYearMonthDay (-93) === (-1,9,30)++ , testProperty "daysToYearMonthDay (-103) === (-1,9,20)"+ $ daysToYearMonthDay (-103) === (-1,9,20)++ , testProperty "daysToYearMonthDay (-108) === (-1,9,15)"+ $ daysToYearMonthDay (-108) === (-1,9,15)++ , testProperty "daysToYearMonthDay (-111) === (-1,9,12)"+ $ daysToYearMonthDay (-111) === (-1,9,12)++ , testProperty "daysToYearMonthDay (-112) === (-1,9,11)"+ $ daysToYearMonthDay (-112) === (-1,9,11)++ , testProperty "daysToYearMonthDay (-113) === (-1,9,10)"+ $ daysToYearMonthDay (-113) === (-1,9,10)++ , testProperty "daysToYearMonthDay (-114) === (-1,9,9)"+ $ daysToYearMonthDay (-114) === (-1,9,9)++ , testProperty "daysToYearMonthDay (-122) === (-1,9,1)"+ $ daysToYearMonthDay (-122) === (-1,9,1)++ , testProperty "daysToYearMonthDay (-123) === (-1,8,31)"+ $ daysToYearMonthDay (-123) === (-1,8,31)++ , testProperty "daysToYearMonthDay (-153) === (-1,8,1)"+ $ daysToYearMonthDay (-153) === (-1,8,1)++ , testProperty "daysToYearMonthDay (-154) === (-1,7,31)"+ $ daysToYearMonthDay (-154) === (-1,7,31)++ , testProperty "daysToYearMonthDay (-184) === (-1,7,1)"+ $ daysToYearMonthDay (-184) === (-1,7,1)++ , testProperty "daysToYearMonthDay (-185) === (-1,6,30)"+ $ daysToYearMonthDay (-185) === (-1,6,30)++ , testProperty "daysToYearMonthDay (-214) === (-1,6,1)"+ $ daysToYearMonthDay (-214) === (-1,6,1)++ , testProperty "daysToYearMonthDay (-215) === (-1,5,31)"+ $ daysToYearMonthDay (-215) === (-1,5,31)++ , testProperty "daysToYearMonthDay (-245) === (-1,5,1)"+ $ daysToYearMonthDay (-245) === (-1,5,1)++ , testProperty "daysToYearMonthDay (-246) === (-1,4,30)"+ $ daysToYearMonthDay (-246) === (-1,4,30)++ , testProperty "daysToYearMonthDay (-275) === (-1,4,1)"+ $ daysToYearMonthDay (-275) === (-1,4,1)++ , testProperty "daysToYearMonthDay (-276) === (-1,3,31)"+ $ daysToYearMonthDay (-276) === (-1,3,31)++ , testProperty "daysToYearMonthDay (-306) === (-1,3,1)"+ $ daysToYearMonthDay (-306) === (-1,3,1)++ , testProperty "daysToYearMonthDay (-307) === (-1,2,28)"+ $ daysToYearMonthDay (-307) === (-1,2,28)++ , testProperty "daysToYearMonthDay (-334) === (-1,2,1)"+ $ daysToYearMonthDay (-334) === (-1,2,1)++ , testProperty "daysToYearMonthDay (-335) === (-1,1,31)"+ $ daysToYearMonthDay (-335) === (-1,1,31)++ , testProperty "daysToYearMonthDay (-365) === (-1,1,1)"+ $ daysToYearMonthDay (-365) === (-1,1,1)++ , testProperty "daysToYearMonthDay (-366) === (-2,12,31)"+ $ daysToYearMonthDay (-366) === (-2,12,31)+ ]++testYearMonthDayToDaysAndDaysToYearMonthDay :: Test+testYearMonthDayToDaysAndDaysToYearMonthDay+ = testGroup "yearMonthDayToDays <-> daysToYearMonthDay"+ $ [ testProperty ("daysToYearMonthDay (yearMonthDayToDays (0,1,1)) === (0,1,1)")+ $ daysToYearMonthDay (yearMonthDayToDays (0,1,1)) === (0,1,1)++ , testProperty ("yearMonthDayToDays (daysToYearMonthDay x) - x === 0 for 0 < x < 1000")+ $ forAll (choose (0, 1000))+ $ \x-> yearMonthDayToDays (daysToYearMonthDay x) - x === 0++ , testProperty ("yearMonthDayToDays (daysToYearMonthDay x) - x === 0 for 0 < x < 2000")+ $ forAll (choose (0, 2000))+ $ \x-> yearMonthDayToDays (daysToYearMonthDay x) - x === 0++ , testProperty ("yearMonthDayToDays (daysToYearMonthDay x) - x === 0 for 0 < x < 3652424")+ $ forAll (choose (0, 3652424)) -- 0000-01-01 to 9999-12-31+ $ \x-> yearMonthDayToDays (daysToYearMonthDay x) - x === 0++ , testProperty ("yearMonthDayToDays (daysToYearMonthDay x) - x === 0 for -100 < x < 100")+ $ forAll (choose ((-100), 100)) -- 0000-01-01 to 9999-12-31+ $ \x-> yearMonthDayToDays (daysToYearMonthDay x) - x === 0++ , testProperty ("yearMonthDayToDays (daysToYearMonthDay x) - x === 0 for -1000000 < x < 5000000")+ $ forAll (choose (-1000000, 5000000)) -- 0000-01-01 to 9999-12-31+ $ \x-> yearMonthDayToDays (daysToYearMonthDay x) - x === 0+ ]
+ Data/UTC/Type.hs view
@@ -0,0 +1,11 @@+module Data.UTC.Type+ ( module Data.UTC.Type.Date+ , module Data.UTC.Type.Time+ , module Data.UTC.Type.DateTime+ , module Data.UTC.Type.Local+ ) where++import Data.UTC.Type.Date+import Data.UTC.Type.Time+import Data.UTC.Type.DateTime+import Data.UTC.Type.Local
+ Data/UTC/Type/Date.hs view
@@ -0,0 +1,71 @@+module Data.UTC.Type.Date+ ( Date ()+ ) where++import Data.Ratio++import Data.UTC.Class.Epoch+import Data.UTC.Class.IsDate+import Data.UTC.Class.IsUnixTime+import Data.UTC.Internal++-- | This type represents dates in the __Proleptic Gregorian Calendar__.+--+-- * It can represent any date in the past and in the future by using+-- 'Prelude.Integer' internally.+-- * The internal structure is not exposed to avoid the construction of invalid values.+-- Use 'Data.UTC.epoch' or a parser to construct values.+-- * The instance of 'Prelude.Show' is only meant for debugging purposes+-- and is subject to change.+data Date+ = Date+ { dYear :: Integer+ , dMonth :: Integer+ , dDay :: Integer+ } deriving (Eq, Ord, Show)++instance Epoch Date where+ epoch+ = Date+ { dYear = 1970+ , dMonth = 1+ , dDay = 1+ }++instance IsUnixTime Date where+ unixSeconds t+ = (days * secsPerDay % 1)+ - deltaUnixEpochCommonEpoch+ where+ days = yearMonthDayToDays (year t, month t, day t)+ fromUnixSeconds u+ = return+ $ Date+ { dYear = y+ , dMonth = m+ , dDay = d+ }+ where+ s = u + deltaUnixEpochCommonEpoch+ (y, m, d) = daysToYearMonthDay (truncate s `div` secsPerDay)++instance IsDate Date where+ year+ = dYear+ month+ = dMonth+ day+ = dDay+ setYear x t+ = if isValidDate (x, month t, day t)+ then return $ t { dYear = x }+ else fail $ "Dated.setYear " ++ show x+ setMonth x t+ = if isValidDate (year t, x, day t)+ then return $ t { dMonth = x }+ else fail $ "Dated.setMonth " ++ show x+ setDay x t+ = if isValidDate (year t, month t, x)+ then return $ t { dDay = x }+ else fail $ "Dated.setDay " ++ show x+
+ Data/UTC/Type/DateTime.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE FlexibleInstances #-}+module Data.UTC.Type.DateTime+ ( -- * Type+ DateTime (..)+ ) where++import Data.String+import Data.Maybe++import Data.UTC.Class.Epoch+import Data.UTC.Class.IsDate+import Data.UTC.Class.IsTime+import Data.UTC.Class.IsUnixTime+import Data.UTC.Type.Date+import Data.UTC.Type.Time+import Data.UTC.Type.Local+import Data.UTC.Format.Rfc3339+import Data.UTC.Internal++-- | A time representation based on a 'Data.UTC.Date' and the 'Data.UTC.Time' of the day.+--+-- * The type uses multiprecision integers internally and is able to represent+-- any UTC date in the past and in the future with arbitrary precision+-- (apart from the time span within a leap second).+-- * The instances of 'Data.String.IsString' and 'Prelude.Show' are only+-- meant for debugging purposes and default to 'epoch' in case of+-- failure. Don't rely on their behaviour!+data DateTime+ = DateTime+ { date :: Date+ , time :: Time+ } deriving (Eq, Ord)++instance Show DateTime where+ show = fromMaybe "1970-01-01T00:00:00-00:00" . renderRfc3339 . unknown++instance Show (Local DateTime) where+ show = fromMaybe "1970-01-01T00:00:00-00:00" . renderRfc3339++instance IsString DateTime where+ fromString = utc . fromMaybe epoch . parseRfc3339++instance Epoch DateTime where+ epoch = DateTime epoch midnight++instance IsUnixTime DateTime where+ unixSeconds (DateTime d t)+ = unixSeconds d+ + unixSeconds t+ fromUnixSeconds u+ = do d <- fromUnixSeconds u+ t <- fromUnixSeconds u+ return (DateTime d t)++instance IsDate DateTime where+ year+ = year . date+ month+ = month . date+ day+ = day . date+ setYear y t+ = do dt <- setYear y (date t)+ return $ t { date = dt }+ setMonth m t+ = do dt <- setMonth m (date t)+ return $ t { date = dt }+ setDay d t+ = do dt <- setDay d (date t)+ return $ t { date = dt }++instance IsTime DateTime where+ hour+ = hour . time+ minute+ = minute . time+ second+ = second . time+ secondFraction+ = secondFraction . time+ setHour y t+ = do tm <- setHour y (time t)+ return $ t { time = tm }+ setMinute y t+ = do tm <- setMinute y (time t)+ return $ t { time = tm }+ setSecond y t+ = do tm <- setSecond y (time t)+ return $ t { time = tm }+ setSecondFraction y t+ = do tm <- setSecondFraction y (time t)+ return $ t { time = tm }++ -- The default implementation of addHours fails whena day flows over. + -- For DateTimes we can let it ripple into the days.+ addHours h t+ = setHour hors t >>= addDays days+ where+ h' = h + (hour t)+ hors = h' `mod` hoursPerDay+ days = h' `div` hoursPerDay++-- assumption: addSecondFractions for DateTime is always successful+instance IsDate (Local DateTime) where+ year (Local t Nothing)+ = year t+ year (Local t (Just 0))+ = year t+ year (Local t (Just o))+ = year+ $ fromMaybe undefined $ addSecondFractions o t+ month (Local t Nothing)+ = month t+ month (Local t (Just 0))+ = month t+ month (Local t (Just o))+ = month+ $ fromMaybe undefined $ addSecondFractions o t+ day (Local t Nothing)+ = day t+ day (Local t (Just 0))+ = day t+ day (Local t (Just o))+ = day+ $ fromMaybe undefined $ addSecondFractions o t+ setYear h (Local t o@Nothing)+ = do t' <- setYear h t+ return (Local t' o)+ setYear h (Local t o@(Just 0))+ = do t' <- setYear h t+ return (Local t' o)+ setYear h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setYear h >>= addSecondFractions (negate i)+ return (Local t' o)+ setMonth h (Local t o@Nothing)+ = do t' <- setMonth h t+ return (Local t' o)+ setMonth h (Local t o@(Just 0))+ = do t' <- setMonth h t+ return (Local t' o)+ setMonth h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setMonth h >>= addSecondFractions (negate i)+ return (Local t' o)+ setDay h (Local t o@Nothing)+ = do t' <- setDay h t+ return (Local t' o)+ setDay h (Local t o@(Just 0))+ = do t' <- setDay h t+ return (Local t' o)+ setDay h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setDay h >>= addSecondFractions (negate i)+ return (Local t' o)++-- assumption: addSecondFractions for DateTime is always successful+instance IsTime (Local DateTime) where+ hour (Local t Nothing)+ = hour t+ hour (Local t (Just 0))+ = hour t+ hour (Local t (Just o))+ = hour+ $ fromMaybe undefined $ addSecondFractions o t+ minute (Local t Nothing)+ = minute t+ minute (Local t (Just 0))+ = minute t+ minute (Local t (Just o))+ = minute+ $ fromMaybe undefined $ addSecondFractions o t+ second (Local t Nothing)+ = second t+ second (Local t (Just 0))+ = second t+ second (Local t (Just o))+ = second+ $ fromMaybe undefined $ addSecondFractions o t+ secondFraction (Local t Nothing)+ = secondFraction t+ secondFraction (Local t (Just 0))+ = secondFraction t+ secondFraction (Local t (Just o))+ = secondFraction+ $ fromMaybe undefined $ addSecondFractions o t+ setHour h (Local t o@Nothing)+ = do t' <- setHour h t+ return (Local t' o)+ setHour h (Local t o@(Just 0))+ = do t' <- setHour h t+ return (Local t' o)+ setHour h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setHour h >>= addSecondFractions (negate i)+ return (Local t' o)+ setMinute h (Local t o@Nothing)+ = do t' <- setMinute h t+ return (Local t' o)+ setMinute h (Local t o@(Just 0))+ = do t' <- setMinute h t+ return (Local t' o)+ setMinute h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setMinute h >>= addSecondFractions (negate i)+ return (Local t' o)+ setSecond h (Local t o@Nothing)+ = do t' <- setSecond h t+ return (Local t' o)+ setSecond h (Local t o@(Just 0))+ = do t' <- setSecond h t+ return (Local t' o)+ setSecond h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setSecond h >>= addSecondFractions (negate i)+ return (Local t' o)+ setSecondFraction h (Local t o@Nothing)+ = do t' <- setSecondFraction h t+ return (Local t' o)+ setSecondFraction h (Local t o@(Just 0))+ = do t' <- setSecondFraction h t+ return (Local t' o)+ setSecondFraction h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setSecondFraction h >>= addSecondFractions (negate i)+ return (Local t' o)++ -- This one is necessary to override, because the overflow should+ -- ripple into the date part.+ addHours h t+ = setHour hors t >>= addDays days+ where+ h' = h + (hour t)+ days = h' `div` hoursPerDay+ hors = h' `mod` hoursPerDay
+ Data/UTC/Type/Local.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE Safe, FlexibleInstances #-}+module Data.UTC.Type.Local+ ( Local (..)+ , unknown+ ) where++import Data.Maybe++import Data.UTC.Class.Epoch+import Data.UTC.Class.Midnight+import Data.UTC.Class.IsTime+import Data.UTC.Type.Time++-- | This type is used to extend UTC time types by a local offset in seconds (positive or negative).+--+-- /Beware/: A local offset is not a time zone. It is just a fix+-- period of time. In contrast to a time zone this does not take+-- summer or winter time into account.+data Local time+ = Local + { -- | The time to be interpreted as UTC+00:00 (__W__estern __E__uropean __T__ime)+ utc :: time+ , -- | ['Nothing'] The local offset is unknown (behaves like __W__estern __E__uropean __T__ime)+ --+ -- ['Just' 0] UTC+00:00 (__W__estern __E__uropean __T__ime)+ --+ -- ['Just' 3600] UTC+01:00 (__C__entral __E__uropean __T__ime)+ offset :: Maybe Rational+ }++instance Eq t => Eq (Local t) where+ (==) (Local a _) (Local b _)+ = a == b++instance Ord t => Ord (Local t) where+ compare (Local a _) (Local b _)+ = compare a b++instance Epoch t => Epoch (Local t) where+ epoch+ = unknown epoch++instance Midnight t => Midnight (Local t) where+ midnight+ = unknown midnight++instance Functor Local where+ fmap f (Local t o)+ = Local (f t) o++instance Bounded t => Bounded (Local t) where+ minBound = unknown minBound+ maxBound = unknown maxBound++-- assumption: addSecondFractions for Time is always successful+instance IsTime (Local Time) where+ hour (Local t Nothing)+ = hour t+ hour (Local t (Just 0))+ = hour t+ hour (Local t (Just o))+ = hour+ $ fromMaybe undefined $ addSecondFractions o t+ minute (Local t Nothing)+ = minute t+ minute (Local t (Just 0))+ = minute t+ minute (Local t (Just o))+ = minute+ $ fromMaybe undefined $ addSecondFractions o t+ second (Local t Nothing)+ = second t+ second (Local t (Just 0))+ = second t+ second (Local t (Just o))+ = second+ $ fromMaybe undefined $ addSecondFractions o t+ secondFraction (Local t Nothing)+ = secondFraction t+ secondFraction (Local t (Just 0))+ = secondFraction t+ secondFraction (Local t (Just o))+ = secondFraction+ $ fromMaybe undefined $ addSecondFractions o t+ setHour h (Local t o@Nothing)+ = do t' <- setHour h t+ return (Local t' o)+ setHour h (Local t o@(Just 0))+ = do t' <- setHour h t+ return (Local t' o)+ setHour h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setHour h >>= addSecondFractions (negate i)+ return (Local t' o)+ setMinute h (Local t o@Nothing)+ = do t' <- setMinute h t+ return (Local t' o)+ setMinute h (Local t o@(Just 0))+ = do t' <- setMinute h t+ return (Local t' o)+ setMinute h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setMinute h >>= addSecondFractions (negate i)+ return (Local t' o)+ setSecond h (Local t o@Nothing)+ = do t' <- setSecond h t+ return (Local t' o)+ setSecond h (Local t o@(Just 0))+ = do t' <- setSecond h t+ return (Local t' o)+ setSecond h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setSecond h >>= addSecondFractions (negate i)+ return (Local t' o)+ setSecondFraction h (Local t o@Nothing)+ = do t' <- setSecondFraction h t+ return (Local t' o)+ setSecondFraction h (Local t o@(Just 0))+ = do t' <- setSecondFraction h t+ return (Local t' o)+ setSecondFraction h (Local t o@(Just i))+ = do t' <- addSecondFractions i t >>= setSecondFraction h >>= addSecondFractions (negate i)+ return (Local t' o)++++unknown :: t -> Local t+unknown t+ = Local t Nothing
+ Data/UTC/Type/Time.hs view
@@ -0,0 +1,68 @@+module Data.UTC.Type.Time+ ( Time ()+ , midnight+ ) where++import Data.Ratio++import Data.UTC.Class.Midnight+import Data.UTC.Class.IsTime+import Data.UTC.Class.IsUnixTime+import Data.UTC.Internal++-- | This type represents time instants during a day (__00:00:00 - 23:59:59.999__..)+-- with arbitrary precision (uses 'Prelude.Integer' internally).+--+-- * The internal structure is not exposed to avoid the creation of+-- invalid values.+-- Use 'Data.UTC.midnight' or a parser to construct values.+-- * The instance of 'Prelude.Show' is only meant for debugging purposes+-- and is subject to change.+data Time+ = Time+ { tHour :: Integer+ , tMinute :: Integer+ , tSecond :: Integer+ , tSecondFraction :: Rational+ } deriving (Eq, Ord, Show)++instance Midnight Time where+ midnight+ = Time 0 0 0 0++instance IsUnixTime Time where+ unixSeconds t+ = (hour t * secsPerHour % 1)+ + (minute t * secsPerMinute % 1)+ + (second t % 1)+ + (secondFraction t)+ fromUnixSeconds s+ = return $ Time+ { tHour = truncate s `div` secsPerHour `mod` hoursPerDay+ , tMinute = truncate s `div` secsPerMinute `mod` minsPerHour+ , tSecond = truncate s `mod` secsPerMinute+ , tSecondFraction = s - (truncate s % 1)+ }++instance IsTime Time where+ hour+ = tHour+ minute+ = tMinute+ second+ = tSecond+ secondFraction+ = tSecondFraction++ setHour x t+ | x < 0 || 23 < x = fail $ "Time.setHour " ++ show x+ | otherwise = return $ t { tHour = x }+ setMinute x t+ | x < 0 || 59 < x = fail $ "Time.setMinute " ++ show x+ | otherwise = return $ t { tMinute = x }+ setSecond x t+ | x < 0 || 59 < x = fail $ "Time.setSecond " ++ show x+ | otherwise = return $ t { tSecond = x }+ setSecondFraction x t+ | x < 0 || 1 <= x = fail $ "Time.setSecondFraction " ++ show x+ | otherwise = return $ t { tSecondFraction = x }
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Lars Petersen++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/Test.hs view
@@ -0,0 +1,211 @@+module Main (main) where++import Test.QuickCheck+import Test.Framework (defaultMain, testGroup)+import Test.Framework (Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++import Data.String++import Data.UTC++import Data.UTC.Internal.Test (test)+import Data.UTC.Class.IsDate.Test (test)++main :: IO ()+main+ = defaultMain+ [ testGroup "instance IsUnixTime DateTime"+ $ testUnixTimeInstance (undefined :: DateTime)+ , testGroup "instance IsDate DateTime"+ $ testDateInstance (undefined :: DateTime)+ , testGroup "instance Time DateTime"+ $ testTimeInstance (epoch :: DateTime)+ , testGroup "instance Time Time"+ $ testTimeInstance (midnight :: Time)++ , Data.UTC.Internal.Test.test+ , Data.UTC.Class.IsDate.Test.test++ , testProperty "(parseRfc3339 \"2014-12-24T13:37:00Z\" :: Maybe (Local DateTime)) >>= addHours 25 >>= setMonth 1 >>= renderRfc3339"+ $ ((parseRfc3339 "2014-12-24T13:37:00Z" :: Maybe (Local DateTime)) >>= addHours 25 >>= setMonth 1 >>= renderRfc3339)+ === (Just "2014-01-25T14:37:00Z" :: Maybe String)+ ]++testTimeInstance :: (IsTime t, Eq t) => t -> [Test]+testTimeInstance t+ = [ testProperty ("test 1.t1")+ $ (t1 >>= return . hour) == Just 12+ , testProperty ("test 1.t2")+ $ (t2 >>= return . hour) == Just 12+ , testProperty ("test 2.t1")+ $ (t2 >>= return . minute) == Just 13+ , testProperty ("test 2.t2")+ $ (t2 >>= return . minute) == Just 13+ , testProperty ("test 3.t1")+ $ (t2 >>= return . second) == Just 14+ , testProperty ("test 3.t2")+ $ (t2 >>= return . second) == Just 14+ , testProperty ("test 4.t1")+ $ (t2 >>= return . secondFraction) == Just 0.56789+ , testProperty ("test 4.t2")+ $ (t2 >>= return . secondFraction) == Just 0.56789+ ]+ ++ map (\(n,d)-> testProperty ("test 5." ++ n)+ $ d == (Nothing `asTypeOf` Just t)+ ) invalidTimes+ +++ -- Testing the add* functions of the Time class.+ [ testGroup "addHours"+ [ testProperty ("adding 1 hour should result in 01:00")+ $ (addHours 1 t >>= return . hour) == Just 1+ , testProperty ("adding 25 hours should result in 01:00")+ $ (addHours 25 t >>= return . hour) == Just 1+ , testProperty ("adding 49 hours should result in 01:00")+ $ (addHours 49 t >>= return . hour) == Just 1+ , testProperty ("adding -1 hours should result in 23:00")+ $ (addHours (-1) t >>= return . hour) == Just 23+ , testProperty ("adding twice in sequence")+ $ (addHours 3 t >>= addHours 4 >>= return . hour) == Just 7+ ]+ , testGroup "addMinutes"+ [ testProperty ("adding 1 minute should result in 00:01")+ $ (addMinutes 1 t >>= return . hour) == Just 0 &&+ (addMinutes 1 t >>= return . minute) == Just 1+ , testProperty ("adding 60 minutes should result in 01:00")+ $ (addMinutes 60 t >>= return . hour) == Just 1 &&+ (addMinutes 60 t >>= return . minute) == Just 0 + , testProperty ("adding 62 minutes should result in 01:02")+ $ (addMinutes 62 t >>= return . hour) == Just 1 &&+ (addMinutes 62 t >>= return . minute) == Just 2+ , testProperty ("adding -1 minute should result in 23:59")+ $ (addMinutes (-1) t >>= return . hour) == Just 23 &&+ (addMinutes (-1) t >>= return . minute) == Just 59+ ]+ , testGroup "addSeconds"+ [ testProperty ("adding 1 second should result in 00:00:01")+ $ (addSeconds 1 t >>= return . second) == Just 1+ , testProperty ("adding 60 seconds should result in 00:01:00")+ $ (addSeconds 60 t >>= return . minute) == Just 1 &&+ (addSeconds 60 t >>= return . second) == Just 0+ , testProperty ("adding 61 seconds should result in 00:01:02")+ $ (addSeconds 62 t >>= return . minute) == Just 1 &&+ (addSeconds 62 t >>= return . second) == Just 2+ , testProperty ("adding -1 second should result in 23:59:59")+ $ (addSeconds (-1) t >>= return . hour) == Just 23 &&+ (addSeconds (-1) t >>= return . minute) == Just 59 &&+ (addSeconds (-1) t >>= return . second) == Just 59+ ]+ , testGroup "addSecondFractions"+ [ testProperty ("adding 0.1 seconds should add 0.1 seconds")+ $ (addSecondFractions 0.1 t >>= return . secondFraction) == Just 0.1+ , testProperty ("adding 1.2 seconds should add 1 second and 0.2 seconds")+ $ (addSecondFractions 1.2 t >>= return . second) == Just 1 &&+ (addSecondFractions 1.2 t >>= return . secondFraction) == Just 0.2+ , testProperty ("adding -0.001 seconds should result in 23:59:59.999")+ $ (addSecondFractions (-0.001) t >>= return . hour) == Just 23 &&+ (addSecondFractions (-0.001) t >>= return . minute) == Just 59 &&+ (addSecondFractions (-0.001) t >>= return . second) == Just 59 &&+ (addSecondFractions (-0.001) t >>= return . secondFraction) == Just 0.999+ ]+ ]+ where+ t1 = setHour 12 (t `asTypeOf` t) >>= setMinute 13 >>= setSecond 14 >>= setSecondFraction 0.56789+ t2 = setSecondFraction 0.56789 (t `asTypeOf` t) >>= setSecond 14 >>= setMinute 13 >>= setHour 12+ invalidTimes+ = [ ("01", setHour (-1) t)+ , ("02", setHour 24 t)+ , ("03", setMinute (-1) t)+ , ("04", setMinute 60 t)+ , ("05", setSecond (-1) t)+ , ("06", setSecond 60 t)+ , ("07", setSecondFraction (-1.0) t)+ , ("08", setSecondFraction (-0.1) t)+ , ("09", setSecondFraction 1.0 t)+ , ("10", setSecondFraction 1.1 t)+ ]++testUnixTimeInstance :: (Show t, IsUnixTime t, IsString t,Eq t) => t -> [Test]+testUnixTimeInstance t+ = (map+ (\(i64,s)->+ testProperty ("fromUnixSeconds " ++ show i64 ++ ") == Just " ++ show s)+ $ (fromUnixSeconds i64) === Just (fromString s `asTypeOf` t)+ )+ unixEpochMsRfc3339TimeTuples+ )+ +++ (map+ (\(i64,s)->+ testProperty ("unixSeconds (" ++ show s ++ ") == " ++ show i64)+ $ unixSeconds (fromString s `asTypeOf` t) === i64+ )+ unixEpochMsRfc3339TimeTuples+ )++testDateInstance :: (IsDate t, Eq t) => t -> [Test]+testDateInstance t+ = [ testProperty ("year dat1")+ $ (dat1 >>= return . year) == Just 1972+ , testProperty ("month dat1")+ $ (dat1 >>= return . month) == Just 7+ , testProperty ("day dat1")+ $ (dat1 >>= return . day) == Just 23+ ]+ ++ map (\(n,d)-> testProperty n+ $ d == Nothing+ ) invalidDates+ where+ dat1 = (setYear 1972 epoch >>= setMonth 7 >>= setDay 23) `asTypeOf` (Just t)+ invalidDates+ = [-- * invalid dates+ -- ** month or day out of bound bound+ ("inv001", (setYear 1973 epoch >>= setMonth 0 ) `asTypeOf` (Just t))+ , ("inv002", (setYear 1973 epoch >>= setMonth 13 ) `asTypeOf` (Just t))+ , ("inv003", (setYear 1973 epoch >>= setDay 00) `asTypeOf` (Just t))+ -- ** day beyond upper bound+ , ("inv004", (setYear 1973 epoch >>= setMonth 1 >>= setDay 32) `asTypeOf` (Just t))+ , ("inv005", (setYear 1973 epoch >>= setMonth 2 >>= setDay 29) `asTypeOf` (Just t))+ , ("inv006", (setYear 1973 epoch >>= setMonth 3 >>= setDay 32) `asTypeOf` (Just t))+ , ("inv007", (setYear 1973 epoch >>= setMonth 4 >>= setDay 31) `asTypeOf` (Just t))+ , ("inv008", (setYear 1973 epoch >>= setMonth 5 >>= setDay 32) `asTypeOf` (Just t))+ , ("inv009", (setYear 1973 epoch >>= setMonth 6 >>= setDay 31) `asTypeOf` (Just t))+ , ("inv010", (setYear 1973 epoch >>= setMonth 7 >>= setDay 32) `asTypeOf` (Just t))+ , ("inv011", (setYear 1973 epoch >>= setMonth 8 >>= setDay 32) `asTypeOf` (Just t))+ , ("inv012", (setYear 1973 epoch >>= setMonth 9 >>= setDay 31) `asTypeOf` (Just t))+ , ("inv013", (setYear 1973 epoch >>= setMonth 10 >>= setDay 32) `asTypeOf` (Just t))+ , ("inv014", (setYear 1973 epoch >>= setMonth 11 >>= setDay 31) `asTypeOf` (Just t))+ , ("inv015", (setYear 1973 epoch >>= setMonth 12 >>= setDay 32) `asTypeOf` (Just t))+ ]++unixEpochMsRfc3339TimeTuples :: [(Rational,String)]+unixEpochMsRfc3339TimeTuples+ = [ ( -62167219200.000, "0000-01-01T00:00:00Z") -- verified against moment.js (lowest possible date)+ , ( -62162208000.000, "0000-02-28T00:00:00Z") -- -62162035200000 - (2*24*60*60*1000)+ , ( -62162121600.000, "0000-02-29T00:00:00Z") -- -62162035200000 - (24*60*60*1000)+ , ( -62162035200.000, "0000-03-01T00:00:00Z") -- verified against moment.js+ , ( -62135596800.000, "0001-01-01T00:00:00Z") -- verified against moment.js+ , ( -12275625600.000, "1581-01-01T00:00:00Z") -- verified against moment.js+ , ( -12244089600.000, "1582-01-01T00:00:00Z") -- verified against moment.js+ , ( -12212553600.000, "1583-01-01T00:00:00Z") -- verified against moment.js+ , ( -2208988800.000, "1900-01-01T00:00:00Z") -- verified against moment.js+ , ( -2203891200.000, "1900-03-01T00:00:00Z") -- verified against moment.js (1900 is not a leap year)+ , ( -1.000, "1969-12-31T23:59:59Z") -- verified against moment.js+ , ( 0.000, "1970-01-01T00:00:00Z") -- verified against moment.js+ , ( 951696000.000, "2000-02-28T00:00:00Z") -- verified against moment.js (2000 is a leap year)+ , ( 1234234234.000, "2009-02-10T02:50:34Z") -- verified against moment.js+ , ( 1330473600.000, "2012-02-29T00:00:00Z") -- verified against moment.js (2012 is a leap year)+ , ( 1330559999.999, "2012-02-29T23:59:59.999Z") -- verified against moment.js+ , ( 1330560000.000, "2012-03-01T00:00:00Z") -- verified against moment.js+ , ( 1330560000.001, "2012-03-01T00:00:00.001Z") -- verified against moment.js+ , ( 1334491994.000, "2012-04-15T12:13:14Z") -- verified against moment.js+ , ( 2177410394.000, "2038-12-31T12:13:14Z") -- verified against moment.js+ , ( 32503680000.000, "3000-01-01T00:00:00Z") -- verified against moment.js+ , ( 190288396800.000, "8000-01-01T00:00:00Z") -- verified against moment.js+ , ( 221845392000.000, "9000-01-01T00:00:00Z") -- verified against moment.js+ , ( 240779520000.000, "9600-01-01T00:00:00Z") -- verified against moment.js+ , ( 253370764800.000, "9999-01-01T00:00:00Z") -- verified against moment.js+ , ( 253402214400.000, "9999-12-31T00:00:00Z") -- verified against moment.js+ , ( 253402300799.999, "9999-12-31T23:59:59.999Z") -- verified against moment.js (highest possible date)+ ]+
+ utc.cabal view
@@ -0,0 +1,102 @@+name: utc+version: 0.1.0.0+stability: experimental+synopsis: A pragmatic time and date library.+description: This library aims to supply you with common+ types and operations for working with time and date.+ .+ * Parsing and rendering common formats like ISO8601 and RFC3339.+ .+ * Modifying dates and times in a way that is easy to understand+ and not overengineered (srsly, who needs something else than the+ Gregorian Calendar?)+ .+ * A set of classes that provide interfaces for your own application+ specific or maybe more efficient time and date types. Implement the+ interfaces and get all the parsing and rendering functions for free!+ .+ This is a work in progress!+ .+ Try it out and play with it. Tell me what you think+ about the API design and naming, but __DON'T USE IT+ IN PRODUCTION YET!__+ .+ Bug reports or (even better) tests are welcome.+license: MIT+license-file: LICENSE+author: Lars Petersen+maintainer: lars@nyantec.com+copyright: Copyright (c) Lars Petersen 2014-2015+homepage: https://github.com/lpeterse/haskell-utc+bug-reports: https://github.com/lpeterse/haskell-utc/issues+category: Data, Time, Parsing+build-type: Simple+cabal-version: >=1.10++Library+ build-depends: base < 5+ , text+ , bytestring >= 0.10.4.0+ , attoparsec+ , clock >= 0.3 && < 0.5+ ghc-options: -Wall+ hs-source-dirs: .+ default-language: Haskell98+ exposed-modules: Data.UTC+ , Data.UTC.Class+ , Data.UTC.Class.Epoch+ , Data.UTC.Class.Midnight+ , Data.UTC.Class.IsDate+ , Data.UTC.Class.IsTime+ , Data.UTC.Class.IsUnixTime+ , Data.UTC.Class.HasUnixTime+ , Data.UTC.Type+ , Data.UTC.Type.Date+ , Data.UTC.Type.Time+ , Data.UTC.Type.DateTime+ , Data.UTC.Type.Local+ , Data.UTC.Format.Rfc3339+ , Data.UTC.Internal+ other-modules: Data.UTC.Format.Rfc3339.Parser+ , Data.UTC.Format.Rfc3339.Builder++Test-Suite test+ type: exitcode-stdio-1.0+ main-is: Test.hs+ ghc-options: -Wall -O2+ hs-source-dirs: tests .+ other-modules: Data.UTC+ , Data.UTC.Class+ , Data.UTC.Class.Epoch+ , Data.UTC.Class.Midnight+ , Data.UTC.Class.IsDate+ , Data.UTC.Class.IsDate.Test+ , Data.UTC.Class.IsTime+ , Data.UTC.Class.IsUnixTime+ , Data.UTC.Class.HasUnixTime+ , Data.UTC.Type+ , Data.UTC.Type.Date+ , Data.UTC.Type.Time+ , Data.UTC.Type.DateTime+ , Data.UTC.Type.Local+ , Data.UTC.Format.Rfc3339+ -- in library unexposed modules+ , Data.UTC.Format.Rfc3339.Parser+ , Data.UTC.Format.Rfc3339.Builder+ , Data.UTC.Internal+ , Data.UTC.Internal.Test+ build-depends: base < 5+ , text+ , bytestring >= 0.10.4.0+ , attoparsec+ , clock >= 0.3 && < 0.5+ -- additional deps for testing+ , Cabal+ , test-framework >= 0.8.0.2+ , test-framework-quickcheck2 >= 0.3.0.3+ , QuickCheck+ default-language: Haskell98++source-repository head+ type: git+ location: https://github.com/lpeterse/haskell-utc.git