hodatime 0.1.1.1 → 0.2.1.1

raw patch · 42 files changed

+1654/−466 lines, 42 filesdep +QuickCheckdep +Win32dep +exceptionsdep ~base

Dependencies added: QuickCheck, Win32, exceptions, fingertree, parsec, unix

Dependency ranges changed: base

Files

• hodatime.cabal +39/−8
• platform/linux/Data/HodaTime/Instant/Platform.hs +12/−0
• platform/linux/Data/HodaTime/TimeZone/Platform.hs +22/−0
• platform/osx/Data/HodaTime/Instant/Platform.hs +12/−0
• platform/osx/Data/HodaTime/TimeZone/Platform.hs +22/−0
• platform/windows/Data/HodaTime/Instant/Platform.hsc +19/−0
• platform/windows/Data/HodaTime/TimeZone/Platform.hs +159/−0
• src/Data/HodaTime.hs +84/−0
• src/Data/HodaTime/Calendar/Constants.hs +8/−0
• src/Data/HodaTime/Calendar/Gregorian.hs +6/−18
• src/Data/HodaTime/Calendar/Gregorian/Internal.hs +73/−24
• src/Data/HodaTime/Calendar/Internal.hs +0/−2
• src/Data/HodaTime/Calendar/Iso.hs +1/−1
• src/Data/HodaTime/CalendarDateTime.hs +9/−3
• src/Data/HodaTime/CalendarDateTime/Internal.hs +25/−6
• src/Data/HodaTime/Constants.hs +0/−14
• src/Data/HodaTime/Duration.hs +1/−8
• src/Data/HodaTime/Duration/Internal.hs +10/−8
• src/Data/HodaTime/Instant.hs +9/−70
• src/Data/HodaTime/Instant/Clock.hsc +0/−41
• src/Data/HodaTime/Instant/Internal.hs +64/−2
• src/Data/HodaTime/Instant/Unix.hsc +28/−0
• src/Data/HodaTime/LocalTime/Internal.hs +5/−6
• src/Data/HodaTime/Offset.hs +5/−26
• src/Data/HodaTime/Offset/Internal.hs +69/−0
• src/Data/HodaTime/OffsetDateTime.hs +38/−1
• src/Data/HodaTime/OffsetDateTime/Internal.hs +0/−21
• src/Data/HodaTime/TimeZone.hs +33/−55
• src/Data/HodaTime/TimeZone/Internal.hs +174/−28
• src/Data/HodaTime/TimeZone/Olson.hs +147/−51
• src/Data/HodaTime/TimeZone/ParseTZ.hs +87/−0
• src/Data/HodaTime/TimeZone/Unix.hs +74/−0
• src/Data/HodaTime/ZonedDateTime.hs +141/−0
• src/Data/HodaTime/ZonedDateTime/Internal.hs +13/−8
• tests/HodaTime/Calendar/GregorianTest.hs +42/−16
• tests/HodaTime/CalendarDateTimeTest.hs +5/−17
• tests/HodaTime/InstantTest.hs +19/−10
• tests/HodaTime/LocalTimeTest.hs +2/−2
• tests/HodaTime/OffsetTest.hs +15/−18
• tests/HodaTime/Util.hs +67/−1
• tests/HodaTime/ZonedDateTimeTest.hs +113/−0
• tests/test.hs +2/−1

@@ -1,5 +1,5 @@ name:           hodatime-version:        0.1.1.1+version:        0.2.1.1 stability:      experimental license:        BSD3 license-file:   LICENSE@@ -12,8 +12,14 @@ synopsis:       A fully featured date/time library based on Nodatime description:    A library for dealing with time, dates, calendars and time zones category:       Data, Time-build-type:     Simple tested-with:    GHC == 8.0.2+extra-source-files:+                   platform/osx/Data/HodaTime/TimeZone/Platform.hs+                   platform/osx/Data/HodaTime/Instant/Platform.hs+                   platform/linux/Data/HodaTime/TimeZone/Platform.hs+                   platform/linux/Data/HodaTime/Instant/Platform.hs+                   platform/windows/Data/HodaTime/TimeZone/Platform.hs+                   platform/windows/Data/HodaTime/Instant/Platform.hsc  source-repository head     type:     git@@ -23,15 +29,31 @@   default-language:                    Haskell2010   hs-source-dirs:  src+  if os(linux)+    hs-source-dirs: platform/linux+  if os(darwin)+    hs-source-dirs: platform/osx+  if os(windows)+    hs-source-dirs: platform/windows+   build-depends:                    base >= 4.9 && < 4.10,                    mtl,                    binary,                    bytestring,-                   directory,+                   containers,+                   exceptions,+                   fingertree >= 0.1.3 && < 0.1.4,+                   parsec+  if os(windows)+    build-depends: Win32+  if !os(windows)+    build-depends: unix,                    filepath,-                   containers+                   directory+   ghc-options:     -Wall+   exposed-modules:                    Data.HodaTime,                    Data.HodaTime.Calendar.Coptic,@@ -56,15 +78,22 @@                    Data.HodaTime.Duration.Internal,                    Data.HodaTime.LocalTime.Internal,                    Data.HodaTime.Calendar.Internal,+                   Data.HodaTime.Calendar.Constants,                    Data.HodaTime.Calendar.Gregorian.Internal,                    Data.HodaTime.Calendar.Gregorian.CacheTable,                    Data.HodaTime.CalendarDateTime.Internal,                    Data.HodaTime.Instant.Internal,-                   Data.HodaTime.Instant.Clock,-                   Data.HodaTime.OffsetDateTime.Internal,+                   Data.HodaTime.Instant.Platform,+                   Data.HodaTime.Offset.Internal,                    Data.HodaTime.TimeZone.Internal,-                   Data.HodaTime.TimeZone.Olson,+                   Data.HodaTime.TimeZone.Platform,                    Data.HodaTime.ZonedDateTime.Internal+  if !os(windows)+    other-modules:+                   Data.HodaTime.TimeZone.Olson,+                   Data.HodaTime.TimeZone.ParseTZ,+                   Data.HodaTime.TimeZone.Unix,+                   Data.HodaTime.Instant.Unix  test-suite test   default-language:@@ -82,13 +111,15 @@                    HodaTime.DurationTest,                    HodaTime.OffsetTest,                    HodaTime.Calendar.GregorianTest,-                   HodaTime.CalendarDateTimeTest+                   HodaTime.CalendarDateTimeTest,+                   HodaTime.ZonedDateTimeTest   build-depends:                    base >= 4 && < 5,                    tasty >= 0.11,                    tasty-smallcheck,                    tasty-quickcheck,                    tasty-hunit,+                   QuickCheck,                    time,                    bytestring,                    hodatime

@@ -0,0 +1,12 @@+module Data.HodaTime.Instant.Platform+(+  now+)+where++import Data.HodaTime.Instant.Internal+import qualified Data.HodaTime.Instant.Unix as U++now :: IO Instant+now = U.now+-- TODO: Do we need an inline statement here or will the compiler work it out?

@@ -0,0 +1,22 @@+module Data.HodaTime.TimeZone.Platform+(+   loadUTC+  ,loadLocalZone+  ,loadTimeZone+)+where++import Data.HodaTime.TimeZone.Internal+import qualified Data.HodaTime.TimeZone.Unix as U++loadUTC :: IO (UtcTransitionsMap, CalDateTransitionsMap)+loadUTC = U.loadUTC loadZoneFromOlsonFile++loadLocalZone :: IO (UtcTransitionsMap, CalDateTransitionsMap, String)+loadLocalZone = U.loadLocalZone loadZoneFromOlsonFile++loadTimeZone :: String -> IO (UtcTransitionsMap, CalDateTransitionsMap)+loadTimeZone = U.loadTimeZone loadZoneFromOlsonFile++loadZoneFromOlsonFile :: FilePath -> IO (UtcTransitionsMap, CalDateTransitionsMap)+loadZoneFromOlsonFile = U.defaultLoadZoneFromOlsonFile

@@ -0,0 +1,12 @@+module Data.HodaTime.Instant.Platform+(+  now+)+where++import Data.HodaTime.Instant.Internal+import qualified Data.HodaTime.Instant.Unix as U++now :: IO Instant+now = U.now+-- TODO: Do we need an inline statement here or will the compiler work it out?

@@ -0,0 +1,22 @@+module Data.HodaTime.TimeZone.Platform+(+   loadUTC+  ,loadLocalZone+  ,loadTimeZone+)+where++import Data.HodaTime.TimeZone.Internal+import qualified Data.HodaTime.TimeZone.Unix as U++loadUTC :: IO (UtcTransitionsMap, CalDateTransitionsMap)+loadUTC = U.loadUTC loadZoneFromOlsonFile++loadLocalZone :: IO (UtcTransitionsMap, CalDateTransitionsMap, String)+loadLocalZone = U.loadLocalZone loadZoneFromOlsonFile++loadTimeZone :: String -> IO (UtcTransitionsMap, CalDateTransitionsMap)+loadTimeZone = U.loadTimeZone loadZoneFromOlsonFile++loadZoneFromOlsonFile :: FilePath -> IO (UtcTransitionsMap, CalDateTransitionsMap)+loadZoneFromOlsonFile = U.defaultLoadZoneFromOlsonFile

@@ -0,0 +1,19 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Data.HodaTime.Instant.Platform+(+  now+)+where++import Data.HodaTime.Instant.Internal (fromUnixGetTimeOfDay, Instant)+  +import qualified System.Win32.Time as Win32+  +{-# INLINE now #-}+now :: IO Instant+now = do+  Win32.FILETIME ft <- Win32.getSystemTimeAsFileTime+  let (sec, usec) = (ft - win32_epoch_adjust) `divMod` 10000000+  return $ fromUnixGetTimeOfDay (fromIntegral sec) (fromIntegral usec)+  where+    win32_epoch_adjust = 116444736000000000

@@ -0,0 +1,159 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Data.HodaTime.TimeZone.Platform+(+   loadUTC+  ,loadLocalZone+  ,loadTimeZone+)+where++import Data.HodaTime.TimeZone.Internal+import Data.HodaTime.Instant.Internal (Instant(..), bigBang, minus)+import Data.HodaTime.Offset.Internal (Offset(..))+import Data.HodaTime.Duration.Internal (fromNanoseconds)+import Data.HodaTime.Calendar.Gregorian.Internal (yearMonthDayToDays)++import Data.Char (isDigit)+import Data.List (sortOn, foldl')+import Control.Monad (forM)+import Control.Exception (bracket)+import System.Win32.Types (LONG, HKEY)+import System.Win32.Registry+import System.Win32.Time (SYSTEMTIME(..))+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Storable (sizeOf, Storable(..))+import Foreign.Ptr (castPtr)++data REG_TZI_FORMAT = REG_TZI_FORMAT+  {+     _tziBias :: LONG+    ,_tziStandardBias :: LONG+    ,_tziDaylightBias :: LONG+    ,_tziStandardDate :: SYSTEMTIME+    ,_tziDaylightDate :: SYSTEMTIME+  }+  deriving (Show,Eq,Ord)++instance Storable REG_TZI_FORMAT where+  sizeOf _ = sizeOf (undefined :: LONG) * 3 + sizeOf (undefined :: SYSTEMTIME) * 2+  alignment _ = 4++  poke _ _ = error "poke not implemented"++  peek buf = REG_TZI_FORMAT+    <$> peekByteOff buf 0+    <*> peekByteOff buf 4+    <*> peekByteOff buf 8+    <*> peekByteOff buf 12+    <*> peekByteOff buf (12 + sizeOf (undefined :: SYSTEMTIME))++loadUTC :: IO (UtcTransitionsMap, CalDateTransitionsMap)+loadUTC = loadTimeZone "UTC"++loadLocalZone :: IO (UtcTransitionsMap, CalDateTransitionsMap, String)+loadLocalZone = do+  zone <- readLocalZoneName+  (utcM, calDateM) <- loadTimeZone zone+  return (utcM, calDateM, zone)++loadTimeZone :: String -> IO (UtcTransitionsMap, CalDateTransitionsMap)+loadTimeZone "UTC" = return (utcM, calDateM)+  where+    (utcM, calDateM, _) = fixedOffsetZone "UTC" (Offset 0)+loadTimeZone zone = do+  (stdAbbr, dstAbbr, tzi) <- readTziForZone zone+  dynTzis <- readDynamicDstForZone zone+  return $ mkZoneMaps stdAbbr dstAbbr tzi dynTzis++-- conversion from Windows types++mkZoneMaps :: String -> String -> REG_TZI_FORMAT -> [(Int, REG_TZI_FORMAT)] -> (UtcTransitionsMap, CalDateTransitionsMap)+mkZoneMaps stdAbbr dstAbbr defaultTzi dynTzis = (utcMap, calDateMap')+  where+    dynTzis' = sortOn fst dynTzis+    getInitialExpr [] = tziToExprInfo defaultTzi+    getInitialExpr ((_, tzi):_) = tziToExprInfo tzi+    tl [] = []+    tl (_:xs) = xs+    initialExpr = getInitialExpr dynTzis'+    initialUtcM = addUtcTransitionExpression bigBang initialExpr emptyUtcTransitions+    calDateMap' = addCalDateTransitionExpression lastEntry Largest lastExpr calDateMap+    (utcMap, calDateMap, lastEntry, lastExpr) = foldl' go (initialUtcM, emptyCalDateTransitions, Smallest, initialExpr) $ tl dynTzis'+    go (utcM, calDateM, prevEntry, prevExpr) (y, tzi) = (utcM', calDateM', Entry tran, expr)+      where+        expr = tziToExprInfo tzi+        m = toEnum 0+        tran = Instant (fromIntegral $ yearMonthDayToDays y m 1) 0 0+        utcM' = addUtcTransitionExpression tran expr utcM+        calDateM' = addCalDateTransitionExpression prevEntry before prevExpr calDateM+        before = Entry . flip minus (fromNanoseconds 1) $ tran+    tziToExprInfo (REG_TZI_FORMAT bias stdBias dstBias end start) = TransitionExpressionInfo startExpr endExpr stdTI dstTI+      where+        startExpr = systemTimeToNthDayExpression start stdOffSecs+        endExpr = systemTimeToNthDayExpression end dstOffSecs+        stdTI = TransitionInfo (Offset stdOffSecs) False stdAbbr+        dstTI = TransitionInfo (Offset dstOffSecs) True dstAbbr+        stdOffSecs = 60 * (negate . fromIntegral $ bias + stdBias)+        dstOffSecs = stdOffSecs + 60 * (negate . fromIntegral $ dstBias)++systemTimeToNthDayExpression :: SYSTEMTIME -> Int -> TransitionExpression+systemTimeToNthDayExpression (SYSTEMTIME _ m d nth h mm s _) offsetSecs = NthDayExpression (fromIntegral m - 1) (adjust . fromIntegral $ nth) (fromIntegral d) s''+  where+    adjust 5 = -1                     -- In the registry, 5 actually means last which is -1 for us+    adjust n = n - 1                  -- Switch start nth to zero based+    s'' = s' - offsetSecs             -- Windows times are always local, so convert back to UTC+    s' = h' + mm' + fromIntegral s+    h' = fromIntegral h * 60 * 60+    mm' = fromIntegral mm * 60++readLocalZoneName :: IO String+readLocalZoneName =+  bracket op regCloseKey $ \key ->+  regQueryValue key (Just "TimeZoneKeyName")+    where+      op = regOpenKeyEx hKEY_LOCAL_MACHINE hive kEY_QUERY_VALUE+      hive = "SYSTEM\\CurrentControlSet\\Control\\TimeZoneInformation"++readTziForZone :: String -> IO (String, String, REG_TZI_FORMAT)+readTziForZone zone =+  bracket op regCloseKey $ \key -> do+    std <- regQueryValue key (Just "Std")+    dst <- regQueryValue key (Just "Dlt")+    tzi <- readTzi key "TZI"+    return (std, dst, tzi)+    where+      op = regOpenKeyEx hKEY_LOCAL_MACHINE hive kEY_QUERY_VALUE+      hive = "SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Time Zones\\" ++ zone++readDynamicDstForZone :: String -> IO [(Int, REG_TZI_FORMAT)]+readDynamicDstForZone zone = do+  hasDyn <- hasDynDst+  if hasDyn+  then +    bracket (op dynDstHive) regCloseKey $ \dstKey -> do+      vals <- regEnumKeyVals dstKey+      let years = foldr toYear [] vals+      forM years $ \y -> do+        tzi <- readTzi dstKey y+        return (read y, tzi)+  else return []+  where+    hasDynDst = bracket (op tzHive) regCloseKey $ \key -> do+                  dyn <- regEnumKeys key+                  return $ length dyn == 1 && dyn !! 0 == "Dynamic DST"+    toYear (y, _, _) xs | all isDigit y = y:xs+                        | otherwise = xs+    op hive = regOpenKeyEx hKEY_LOCAL_MACHINE hive kEY_READ+    tzHive = "SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Time Zones\\" ++ zone+    dynDstHive = tzHive ++ "\\Dynamic DST"++readTzi :: HKEY -> String -> IO REG_TZI_FORMAT+readTzi key p =+  allocaBytes sz $ \ptr -> do+    rvt <- regQueryValueEx key p ptr sz+    verifyAndPeak rvt ptr+  where+    sz = sizeOf (undefined :: REG_TZI_FORMAT)+    verifyAndPeak rvt ptr+        | rvt == rEG_BINARY = peek . castPtr $ ptr+        | otherwise         = error $ "registry corrupt: TZI variable was non-binary type: " ++ show rvt

@@ -1,3 +1,87 @@+{-|+Module      :  Data.HodaTime.Interval+Copyright   :  (C) 2017 Jason Johnson+License     :  BSD-style (see the file LICENSE)+Maintainer  :  Jason Johnson <jason.johnson.081@gmail.com>+Stability   :  experimental+Portability :  POSIX, Windows++HodaTime is a Date and Time library that aims to be fully featured, convenient and type safe.++= Overview++This guide provides documentation to complement the API reference. It is recommended that you read at least the first few sections before starting to develop using Hoda Time.+If you have suggestions or questions which are likely to be discussion-based, please create an issue on Github. For more specific solution-focused questions,+please ask on Stack Overflow using the hodatime tag.++= Why does Hoda Time exist?++Hodatime was inspired by Erik Naggum's "Long painful history of time" and the C# library Noda Time which, itself, was inspired by Java's+Joda Time.  Noda Time tried to improve upon Joda Time by improving type saftey.  With Hodatime we seek to use the more advanced Haskell type+system to improve this safty even further.  For example, every attempt is made to avoid runtime errors by making wrong code impossible+to compile.  Failing that, a type is returned to force the user to deal with the fact that the call can fail.++== Why not just use Data.Time?++The Data.Time library is very well thought out and high quality.  For us, the issue is that the library can feel anemic.  We have no doubt that it has the+building blocks for anything one would wish to do with Dates or Time but for most real world functionality there would be more code required than is provided+by the base library.  This leads to two common situations: everyone implements their own versions of the missing "extras" or someone creates an additional package+for eveyone to use.  An example of the latter is that in most real world scenarios proper Time Zone handling will be required.  To do this with Data.Time practically+one will need __two__ additional package dependancies.  We prefer a more "batteries included" approach.  We we find that the "many fine-grained packages" strategy+puts an extra burden on the developer to know exactly what functionality is needed and include only those fine-grained packages and no more.  We prefer to have+fully defined packages and to let the compiler remove any unused code.++== What about leap seconds?++At the time of this writing, Hoda Time does not support leap seconds.  We are not opposed to leap seconds, but have not yet determined a practical way to include+them.  Leap seconds are required to properly represent how time works in the real world but it puts some rather large limitations on code that uses it.  For example,+dates more than six months into the future would be ill-defined (and thus, should be impossible to create) as we cannot predict what leap seconds will occur.  If we+include leap seconds they must be practical, safe and convenient and obvious for users to utilize.++== Design Style++=== Naming++"There are only two hard things in Computer Science: cache invalidation and naming things." -- Phil Karlton++In Hodatime we attempt to lower the burden of naming things by using the simplest name that is correct.  One consequence of this style+is that we use lots of modules.  This way functionality that is fundamentally the same but differs due to some context can share the+same name but occupy a different module.  This allows the user to decide what they would like the "context" part to be named instead+of imposing this on every user by embedding the context in the function name.  We see this use of modules as a positive as most+languages behave similiarly and handling imports is something a proper IDE can generally handle for us.++=== Accessors++For access the convention is simple: read-only accessors are just functions and all read/write accessors are valid lenses.  We incur+no dependancy on any lens library but the accessors are defined+<https://github.com/ekmett/lens/wiki/How-can-I-write-lenses-without-depending-on-lens%3F here>.  The user of the library can use their+favorite lens library or define 3 simple functions (see tests/HodaTime/Util.hs) if they do not wish to use any existing library.++= How to use this library++== Core Concepts++<snip - add stuff rest of documentation>++== Cookbook++=== USA Holidays++>>>import Data.HodaTime.CalendarDate (DayNth(..))+>>>import Data.HodaTime.Calendar.Gregorian (calendarDate, fromNthDay, Month(..), DayOfWeek(..), Gregorian)++>>>usaHolidays y = catMaybes $ ($ y) <$>+        [+           calendarDate 1 January               -- New Year+          ,calendarDate 4 July                  -- Independence Day +          ,calendarDate 25 December             -- Christmas+          ,fromNthDay First Monday September    -- Labor day+          ,fromNthDay Third Monday January      -- MLK day+          ,fromNthDay Second Tuesday February   -- Presidents day+          ,fromNthDay Fourth Thursday November  -- Thanksgiving+          ,calendarDate 29 February             -- Leap day (not a real holiday but demonstrates date that may not exist)+        ]+-} module Data.HodaTime ( )

@@ -0,0 +1,8 @@+module Data.HodaTime.Calendar.Constants+(+  daysPerStandardYear+)+where++daysPerStandardYear :: Num a => a+daysPerStandardYear = 365

@@ -21,36 +21,24 @@ -- | Smart constuctor for Gregorian calendar date. calendarDate :: DayOfMonth -> Month Gregorian -> Year -> Maybe (CalendarDate Gregorian) calendarDate d m y = do-  guard $ y > minDate   guard $ d > 0 && d <= maxDaysInMonth m y   let days = fromIntegral $ yearMonthDayToDays y m d+  guard $ days > invalidDayThresh   return $ CalendarDate days (fromIntegral d) (fromIntegral . fromEnum $ m) (fromIntegral y)  -- | Smart constuctor for Gregorian calendar date based on relative month day. fromNthDay :: DayNth -> DayOfWeek Gregorian -> Month Gregorian -> Year -> Maybe (CalendarDate Gregorian) fromNthDay nth dow m y = do-  guard $ adjustment < fromIntegral mdim           -- NOTE: we have to use < not <= because we're adding to first of the month or subtracting from the end of the month+  guard $ d > 0 && d <= mdim+  guard $ days > invalidDayThresh   return $ CalendarDate (fromIntegral days) (fromIntegral d) (fromIntegral . fromEnum $ m) (fromIntegral y)   where+    nth' = fromEnum nth - 4     mdim = maxDaysInMonth m y-    somDays = yearMonthDayToDays y m 1-    eomDays = yearMonthDayToDays y m mdim-    startDow = dayOfWeekFromDays days'-    targetDow = fromEnum dow-    adjustment = 7 * multiple + adjust startDow targetDow-    (days', multiple, adjust, d, days) = frontOrBack (fromEnum nth)-    frontOrBack nth'-      | nth' < 5  = (somDays, nth', weekdayDistance, adjustment + 1, somDays + adjustment)-      | otherwise = (eomDays, nth' - 5, flip weekdayDistance, mdim - adjustment, eomDays - adjustment)+    d = nthDayToDayOfMonth nth' (fromEnum dow) m y+    days = yearMonthDayToDays y m d  -- | Smart constuctor for Gregorian calendar date based on week date.  Note that this method assumes weeks start on Sunday and the first week of the year is the one --   which has at least one day in the new year.  For ISO compliant behavior use this constructor from the ISO module fromWeekDate :: WeekNumber -> DayOfWeek Gregorian -> Year -> Maybe (CalendarDate Gregorian) fromWeekDate = GI.fromWeekDate 1 Sunday---- help functions--weekdayDistance :: (Ord a, Num a) => a -> a -> a-weekdayDistance s e = e' - s-  where-    e' = if e >= s then e else e + 7

@@ -7,28 +7,44 @@   ,Gregorian   ,Month(..)   ,DayOfWeek(..)-  ,minDate+  ,invalidDayThresh   ,epochDayOfWeek   ,maxDaysInMonth   ,yearMonthDayToDays+  ,nthDayToDayOfMonth   ,dayOfWeekFromDays+  ,instantToYearMonthDay ) where -import Data.HodaTime.Constants (daysPerCycle, daysPerCentury, daysPerFourYears, daysPerYear, monthDayOffsets)-import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), CalendarDate(..), DayOfMonth, Year)+import Data.HodaTime.Constants (daysPerCycle, daysPerCentury, daysPerFourYears)+import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), CalendarDate(..), IsCalendarDateTime(..), DayOfMonth, Year, WeekNumber, CalendarDateTime(..), LocalTime(..))+import Data.HodaTime.Calendar.Gregorian.CacheTable (DTCacheTable(..), decodeMonth, decodeYear, decodeDay, cacheTable)+import Data.HodaTime.Calendar.Constants (daysPerStandardYear)+import Data.HodaTime.Instant.Internal (Instant(..)) import Control.Arrow ((>>>), (&&&), (***), first) import Data.Maybe (fromJust) import Data.List (findIndex)-import Data.HodaTime.Calendar.Gregorian.CacheTable (DTCacheTable(..), decodeMonth, decodeYear, decodeDay, cacheTable) import Data.Int (Int32, Int8) import Data.Word (Word8, Word32)+import Control.Monad (guard) -minDate :: Int-minDate = 1582+-- Constants++invalidDayThresh :: Integral a => a+invalidDayThresh = -152445      -- NOTE: 14.Oct.1582, one day before Gregorian calendar came into effect++firstGregDayTuple :: (Integral a, Integral b, Integral c) => (a, b, c)+firstGregDayTuple = (1582, 9, 15)      epochDayOfWeek :: DayOfWeek Gregorian epochDayOfWeek = Wednesday++monthDayOffsets :: Num a => [a]+monthDayOffsets = 0 : rest+  where+    rest = zipWith (+) daysPerMonth (0:rest)+    daysPerMonth = [31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31, 28]         -- NOTE: rotated (TODO BUG: Why do we need Feb?  That will be past end of year, thus impossible)      -- types     @@ -48,32 +64,33 @@       rest = pred $ yearMonthDayToDays (fromIntegral y) (toEnum . fromIntegral $ m) 1       mkcd days =         let-          days' = fromIntegral days+          days' = fromIntegral $ if days > invalidDayThresh then days else invalidDayThresh + 1           (y', m', d') = daysToYearMonthDay days'-        in CalendarDate (fromIntegral days) d' m' y'+        in CalendarDate days' d' m' y'   {-# INLINE day' #-}        month' (CalendarDate _ _ m _) = toEnum . fromIntegral $ m        monthl' f (CalendarDate _ d m y) = mkcd <$> f (fromEnum m)     where-      mkcd months = CalendarDate (fromIntegral days) d' (fromIntegral m') (fromIntegral y')+      mkcd months = CalendarDate (fromIntegral days) d'' (fromIntegral m') (fromIntegral y'')         where-          (y', m') = flip divMod 12 >>> first (+ fromIntegral y) $ months+          (y', months') = flip divMod 12 >>> first (+ fromIntegral y) $ months+          (y'', m', d') = if (y', months', d) < firstGregDayTuple then firstGregDayTuple else (y', months', d)           mdim = fromIntegral $ maxDaysInMonth (toEnum m') y'-          d' = if d > mdim then mdim else d-          days = yearMonthDayToDays y' (toEnum m') (fromIntegral d')+          d'' = if d' > mdim then mdim else d'+          days = yearMonthDayToDays y'' (toEnum m') (fromIntegral d'')   {-# INLINE monthl' #-}     -  year' f (CalendarDate _ d m y) = mkcd . clamp <$> f (fromIntegral y)+  year' f (CalendarDate _ d m y) = mkcd <$> f (fromIntegral y)     where-      clamp y' = if y' < minDate then minDate else y' -      mkcd y' = CalendarDate days d' m (fromIntegral y')+      mkcd y' = CalendarDate days d'' m' (fromIntegral y'')         where-          m' = toEnum . fromIntegral $ m-          mdim = fromIntegral $ maxDaysInMonth m' y'-          d' = if d > mdim then mdim else d-          days = fromIntegral $ yearMonthDayToDays y' m' (fromIntegral d')+          (y'', m', d') = if (y', m, d) < firstGregDayTuple then firstGregDayTuple else (y', m, d)+          m'' = toEnum . fromIntegral $ m'+          mdim = fromIntegral $ maxDaysInMonth m'' y''+          d'' = if d' > mdim then mdim else d'+          days = fromIntegral $ yearMonthDayToDays y'' m'' (fromIntegral d'')   {-# INLINE year' #-}        dayOfWeek' (CalendarDate days _ _ _) = toEnum . dayOfWeekFromDays . fromIntegral $ days@@ -82,8 +99,20 @@        previous' n dow (CalendarDate days _ _ _) = moveByDow n dow subtract (-) (fromIntegral days)  -- NOTE: subtract is (-) with the arguments flipped -fromWeekDate :: Int -> DayOfWeek Gregorian -> Int -> DayOfWeek Gregorian -> Year -> Maybe (Date Gregorian)+instance IsCalendarDateTime Gregorian where+  fromAdjustedInstant (Instant days secs nsecs) = CalendarDateTime cd lt+    where+      cd = CalendarDate days d m y+      (y, m, d) = daysToYearMonthDay days+      lt = LocalTime secs nsecs++  toUnadjustedInstant (CalendarDateTime (CalendarDate days _ _ _) (LocalTime secs nsecs)) = Instant days secs nsecs++-- constructors++fromWeekDate :: Int -> DayOfWeek Gregorian -> WeekNumber -> DayOfWeek Gregorian -> Year -> Maybe (Date Gregorian) fromWeekDate minWeekDays wkStartDoW weekNum dow y = do+  guard $ days > invalidDayThresh   return $ CalendarDate days d m y'     where       soyDays = yearMonthDayToDays y January minWeekDays@@ -98,6 +127,19 @@  -- helper functions +nthDayToDayOfMonth :: Int -> Int -> Month Gregorian -> Int -> Int+nthDayToDayOfMonth nth day month y = dom + d' + 7 * nth+  where+    mdm = maxDaysInMonth month y+    dom = if nth < 0 then mdm else 1+    m = fromEnum month+    dow = (dom + (13 * m' - 1) `div` 5 + yrhs + (yrhs `div` 4) + (ylhs `div` 4) - 2 * ylhs) `mod` 7+    d = day - dow+    d' = if d < 0 then d + 7 else d+    (m', y') = if m < 2 then (m + 11, y - 1) else (m - 1, y)+    yrhs = y' `mod` 100+    ylhs = y' `div` 100+ dayOfWeekFromDays :: Int -> Int dayOfWeekFromDays = normalize . (fromEnum epochDayOfWeek +) . flip mod 7   where@@ -120,16 +162,19 @@     isLeap       | 0 == y `mod` 100                  = 0 == y `mod` 400       | otherwise                         = 0 == y `mod` 4-maxDaysInMonth n _-  | n == April || n == June || n == September || n == November  = 30+maxDaysInMonth m _+  | m == April || m == June || m == September || m == November  = 30   | otherwise                                                   = 31 +-- NOTE: Epoch is March 1 2000 because that has nicest properties that is near our current time.+-- TODO: The addition of leap days below will add from the previous year.  We need to determine if this is a bug+-- TODO: and if it is not, why isn't it yearMonthDayToDays :: Year -> Month Gregorian -> DayOfMonth -> Int yearMonthDayToDays y m d = days   where     m' = if m > February then fromEnum m - 2 else fromEnum m + 10     years = if m < March then y - 2001 else y - 2000-    yearDays = years * daysPerYear + years `div` 4 + years `div` 400 - years `div` 100+    yearDays = years * daysPerStandardYear + years `div` 4 + years `div` 400 - years `div` 100     days = yearDays + monthDayOffsets !! m' + d - 1  -- | The issue is that 4 * daysPerCentury will be one less than daysPerCycle.  The reason for this is that the Gregorian calendar adds one more day per 400 year cycle@@ -153,7 +198,7 @@   where     (centuryYears, centuryDays, isExtraCycleDay) = calculateCenturyDays days     (fourYears, (remaining, isLeapDay)) = flip divMod daysPerFourYears >>> (* 4) *** id &&& borders daysPerFourYears $ centuryDays-    (oneYears, yearDays) = remaining `divMod` daysPerYear+    (oneYears, yearDays) = remaining `divMod` daysPerStandardYear     m = pred . fromJust . findIndex (\mo -> yearDays < mo) $ monthDayOffsets     (m', startDate) = if m >= 10 then (m - 10, 2001) else (m + 2, 2000)     d = yearDays - monthDayOffsets !! m + 1@@ -169,3 +214,7 @@     (y,m,d) = decodeEntry cacheTable . fromIntegral $ centuryDays     (m',d') = if isExtraCycleDay then (1,29) else (m,d)     (y',m'') = (2000 + centuryYears + fromIntegral y, fromIntegral $ m')++-- here to avoid circular dependancy between Instant and Gregorian+instantToYearMonthDay :: Instant -> (Word32, Word8, Word8)+instantToYearMonthDay (Instant days _ _) = daysToYearMonthDay days

@@ -5,5 +5,3 @@     ) where---- TODO: Do we still need this?

@@ -4,7 +4,7 @@ ) where -import Data.HodaTime.Calendar.Gregorian hiding (fromWeekDate)+import Data.HodaTime.Calendar.Gregorian.Internal hiding (fromWeekDate) import qualified Data.HodaTime.Calendar.Gregorian.Internal as GI import Data.HodaTime.CalendarDateTime.Internal (CalendarDate(..), Year, WeekNumber) 

@@ -1,5 +1,6 @@ module Data.HodaTime.CalendarDateTime (+  -- * Types    DayNth(..)   ,Year   ,WeekNumber@@ -9,15 +10,20 @@   ,IsCalendar(..)   ,HasDate(..)   ,LocalTime+  -- * Constructors   ,on   ,at+  ,atStartOfDay ) where  import Data.HodaTime.CalendarDateTime.Internal+import Data.HodaTime.LocalTime.Internal (midnight) +-- | Returns a 'CalendarDateTime' at 'LocalTime' on the given 'CalendarDate' on :: LocalTime -> CalendarDate cal -> CalendarDateTime cal-on time date = CalendarDateTime date time+on = flip CalendarDateTime -at :: CalendarDate cal -> LocalTime -> CalendarDateTime cal-at date time = CalendarDateTime date time+-- | Returns the first valid time in the day specified by 'CalendarDate' within the given 'TimeZone'+atStartOfDay :: CalendarDate cal -> CalendarDateTime cal+atStartOfDay =  flip at midnight

@@ -11,30 +11,36 @@   ,IsCalendar(..)   ,HasDate(..)   ,LocalTime(..)+  ,IsCalendarDateTime(..)+  ,at ) where +import Data.HodaTime.Instant.Internal (Instant) import Data.Int (Int32) import Data.Word (Word8, Word32)  -- CalendarDate  data DayNth =-    First+    FourthToLast+  | ThirdToLast+  | SecondToLast+  | Last+  | First   | Second   | Third   | Fourth   | Fifth-  | Last-  | SecondToLast-  | ThirdToLast-  | FourthToLast-    deriving (Eq, Show, Enum)+  deriving (Eq, Show, Enum)  type Year = Int type DayOfMonth = Int type WeekNumber = Int +-- TODO: We may want to add a "cycle" field to the calendarDate that counts 400 year cyles.  This would allow days to be non-negative+--       and it would mean that one table can translate all possible days since they repeat each cycle+ -- | Represents a specific date within its calendar system, with no reference to any time zone or time of day. -- Note: We keep the date in 2 formats, redundantly.  We depend on lazy evaluation to only produce the portion that is actually used data CalendarDate calendar = CalendarDate { cdDays :: Int32, cdDay :: Word8, cdMonth :: Word8, cdYear :: Word32 }@@ -115,3 +121,16 @@   dayOfWeek (CalendarDateTime cd _) = dayOfWeek cd   next i dow (CalendarDateTime cd lt) = CalendarDateTime (next i dow cd) lt   previous i dow (CalendarDateTime cd lt) = CalendarDateTime (previous i dow cd) lt++-- | Private class used to allow conversions to and from CalendarDateTime for a given calendar.  If you see this in the documentation, consider it a bug+class IsCalendarDateTime cal where+  -- | Convert an Instant which has already been converted to the correct time for the Calendar and TimeZone into CalendarDateTime+  fromAdjustedInstant :: Instant -> CalendarDateTime cal+  -- | Convert a CalendarDateTime directly to an Instant.  Needed because different calendars use different epochs.  If this ever changes we can revisit this+  toUnadjustedInstant :: CalendarDateTime cal -> Instant++-- constructors++-- | Returns a 'CalendarDateTime' of the 'CalendarDate' at the given 'LocalTime'+at :: CalendarDate cal -> LocalTime -> CalendarDateTime cal+at date time = CalendarDateTime date time

@@ -3,7 +3,6 @@    daysPerCycle   ,daysPerCentury   ,daysPerFourYears-  ,daysPerYear   ,monthsPerYear   ,daysPerWeek   ,hoursPerDay@@ -17,8 +16,6 @@   ,microsecondsPerSecond   ,nsecsPerSecond   ,nsecsPerMicrosecond-  ,daysPerMonth-  ,monthDayOffsets   ,unixDaysOffset ) where@@ -34,9 +31,6 @@ daysPerFourYears :: Num a => a daysPerFourYears = 1461 -daysPerYear :: Num a => a-daysPerYear = 365- monthsPerYear :: Num a => a monthsPerYear = 12 @@ -75,14 +69,6 @@  nsecsPerMicrosecond :: Num a => a nsecsPerMicrosecond = 1000--daysPerMonth :: Num a => [a]-daysPerMonth = [31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31, 28]         -- NOTE: pre-rotated--monthDayOffsets :: Num a => [a]-monthDayOffsets = 0 : rest-  where-    rest = zipWith (+) daysPerMonth (0:rest)  -- conversion constants 

@@ -32,7 +32,7 @@ import Data.HodaTime.Instant.Internal (Instant(..)) import Data.HodaTime.Instant (difference) import qualified Data.HodaTime.Instant as I (add)-import Data.HodaTime.Constants (secondsPerDay, secondsPerHour, nsecsPerSecond)+import Data.HodaTime.Constants (secondsPerHour)  -- | Duration of standard weeks (a standard week is assumed to be exactly 7 24 hour days) fromStandardWeeks :: Int -> Duration@@ -57,13 +57,6 @@ -- | Duration of microseconds fromMicroseconds :: Int -> Duration fromMicroseconds = fromNanoseconds . (* 1000)---- | Duration of nanoseconds-fromNanoseconds :: Int -> Duration-fromNanoseconds ns = Duration $ Instant (fromIntegral d) (fromIntegral s') (fromIntegral ns')-    where-        (s, ns') = normalize ns nsecsPerSecond-        (d, s') = normalize s secondsPerDay  -- | Add two durations together add :: Duration -> Duration -> Duration

@@ -3,18 +3,13 @@    Duration(..)   ,normalize   ,fromSeconds+  ,fromNanoseconds ) where -import Data.HodaTime.Instant.Internal (Instant(..))+import Data.HodaTime.Instant.Internal (Instant(..), Duration(..)) import Control.Arrow ((>>>), (***), first)-import Data.HodaTime.Constants (secondsPerDay)---- | Represents a duration of time between instants.  It can be from days to nanoseconds,---   but anything longer is not representable by a duration because e.g. Months are calendar---   specific concepts.-newtype Duration = Duration { getInstant :: Instant }-    deriving (Eq, Show)             -- TODO: Remove Show+import Data.HodaTime.Constants (secondsPerDay, nsecsPerSecond)  normalize :: Int -> Int -> (Int, Int) normalize x size@@ -34,4 +29,11 @@ fromSeconds :: Int -> Duration fromSeconds s = Duration $ Instant (fromIntegral d) (fromIntegral s') 0     where+        (d, s') = normalize s secondsPerDay++-- | Duration of nanoseconds+fromNanoseconds :: Int -> Duration+fromNanoseconds ns = Duration $ Instant (fromIntegral d) (fromIntegral s') (fromIntegral ns')+    where+        (s, ns') = normalize ns nsecsPerSecond         (d, s') = normalize s secondsPerDay

@@ -21,82 +21,21 @@   ,difference   ,minus   -- * Conversion-  ,inUtc+  ,inTimeZone   -- * Debug - to be removed-  ,LTI.fromInstant  -- TODO:  REMOVE THIS!  This is only exported for testing, remove it immediately after fixing fromSecondsSinceUnixEpoch ) where +-- TODO - BUG: now is based on calling gettimeofday.  The question is if this returns a number with leap seconds removed or not.  If it does not then we will have+-- TODO - BUG: an issue if we go:  now -> ZoneDateTime -> Instant   because the last conversion will remove leap seconds.+ import Data.HodaTime.Instant.Internal-import Data.HodaTime.Instant.Clock (now)-import Data.HodaTime.Constants (secondsPerDay, nsecsPerSecond)-import Data.HodaTime.Duration.Internal (Duration(..))-import Data.HodaTime.OffsetDateTime.Internal(Offset(..))-import Data.HodaTime.TimeZone.Internal (TimeZone(..))+import Data.HodaTime.Instant.Platform (now)+import Data.HodaTime.TimeZone.Internal (TimeZone) import Data.HodaTime.ZonedDateTime.Internal (ZonedDateTime(..))-import qualified Data.HodaTime.OffsetDateTime.Internal as Offset (empty)-import qualified Data.HodaTime.Duration.Internal as D-import qualified Data.HodaTime.LocalTime.Internal as LTI (fromInstant) --- | Create an 'Instant' from an 'Int' that represents a Unix Epoch-fromSecondsSinceUnixEpoch :: Int -> Instant-fromSecondsSinceUnixEpoch s = fromUnixGetTimeOfDay s 0---- | Add a 'Duration' to an 'Instant' to get a future 'Instant'. /NOTE: does not handle all negative durations, use 'minus'/-add :: Instant -> Duration -> Instant-add (Instant ldays lsecs lnsecs) (Duration (Instant rdays rsecs rnsecs)) = Instant days' secs'' nsecs'-    where-        days = ldays + rdays-        secs = lsecs + rsecs-        nsecs = lnsecs + rnsecs-        (secs', nsecs') = adjust secs nsecs nsecsPerSecond-        (days', secs'') = adjust days secs' secondsPerDay-        adjust big small size-            | small >= size = (succ big, small - size)-            | otherwise = (big, small)---- | Get the difference between two instances-difference :: Instant -> Instant -> Duration-difference (Instant ldays lsecs lnsecs) (Instant rdays rsecs rnsecs) = Duration $ Instant days' (fromIntegral secs'') (fromIntegral nsecs')-    where-        days = ldays - rdays-        secs = (fromIntegral lsecs - fromIntegral rsecs) :: Int                   -- TODO: We should specify exactly what sizes we need here.  Keep in mind we can depend that secs and nsecs are never negative so-        nsecs = (fromIntegral lnsecs - fromIntegral rnsecs) :: Int                -- TODO: there is no worry that we get e.g. (-nsecsPerSecond - -nsecsPerSecond) causing us to have more than nsecsPerSecond.-        (secs', nsecs') = normalize nsecs secs nsecsPerSecond-        (days', secs'') = normalize secs' days secondsPerDay-        normalize x bigger size-            | x < 0 = (pred bigger, x + size)-            | otherwise = (bigger, x)---- | Subtract a 'Duration' from an 'Instant' to get an 'Instant' in the past.  /NOTE: does not handle negative durations, use 'add'/-minus :: Instant -> Duration -> Instant-minus linstant (Duration rinstant) = getInstant $ difference linstant rinstant- -- Conversion -{-^}--- | Create an 'OffsetDateTime' from this Instant and an Offset-withOffset :: Instant -> Offset -> Calendar -> OffsetDateTime-withOffset instant offset calendar = OffsetDateTime (LocalDateTime date time) offset          -- TODO: I'm not sure I like applying the offset on construction.  See if we can defer it-    where-        instant' = instant `add` (D.fromSeconds . fromIntegral . offsetSeconds $ offset)-        time = LTI.fromInstant instant'-        date-            | calendar == Gregorian || calendar == Iso  = GI.fromInstantInCalendar instant' calendar-            | otherwise                                 = undefined     -- TODO: Why does compiler think this isn't total without the otherwise?---- | Convert 'Instant' Into a 'ZonedDateTime' based on the supplied 'TimeZone' and 'Calendar'-inZone :: Instant -> TimeZone -> Calendar -> ZonedDateTime-inZone instant UTCzone calendar = ZonedDateTime odt UTCzone-  where-    odt = withOffset instant Offset.empty calendar-inZone instant tzi@TimeZone { } calendar = ZonedDateTime odt tzi-    where-        odt = withOffset instant offset calendar-        offset-            | otherwise = undefined       -- TODO: When TimeZone module is implemented we can finish this (look at the olson time zone series from hackage, but we can't use it all)--}---- | Convert 'Instant' to a 'ZonedDateTime' in the UTC time zone, ISO calendar-inUtc :: Instant -> ZonedDateTime-inUtc instant = undefined+-- | Convert 'Instant' to a 'ZonedDateTime' in the specified time zone.  The calendar must be derivable or specified in the type explicitly+inTimeZone :: Instant -> TimeZone -> ZonedDateTime cal+inTimeZone _instant _tz = undefined

@@ -1,41 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--#ifndef mingw32_HOST_OS-#include <sys/time.h>-#endif--module Data.HodaTime.Instant.Clock-(-    now-)-where--import Data.HodaTime.Instant.Internal (fromUnixGetTimeOfDay, Instant)--#ifdef mingw32_HOST_OS-import System.Win32.Time-#else-import Foreign.C.Error (throwErrnoIfMinus1_)-import Foreign.C.Types-import Foreign.Marshal.Alloc (allocaBytes)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Storable-#endif--{-# INLINE now #-}-now :: IO Instant-#ifdef mingw32_HOST_OS--#else---- | Create an 'Instant' from the current system time-now = allocaBytes #{size struct timeval} $ \ ptv -> do-  throwErrnoIfMinus1_ "gettimeofday" $ gettimeofday ptv nullPtr-  CTime sec <- #{peek struct timeval, tv_sec} ptv-  CSUSeconds usec <- #{peek struct timeval, tv_usec} ptv-  return $ fromUnixGetTimeOfDay (fromIntegral sec) (fromIntegral usec)--foreign import ccall unsafe "time.h gettimeofday"-  gettimeofday :: Ptr () -> Ptr () -> IO CInt--#endif

@@ -1,19 +1,81 @@ module Data.HodaTime.Instant.Internal (    Instant(..)+  ,Duration(..)   ,fromUnixGetTimeOfDay+  ,fromSecondsSinceUnixEpoch+  ,add+  ,minus+  ,difference+  ,bigBang ) where  import Data.Word (Word32) import Data.Int (Int32)-import Data.HodaTime.Constants (secondsPerDay, nsecsPerMicrosecond, unixDaysOffset)+import Data.List (intercalate)+import Data.HodaTime.Constants (secondsPerDay, nsecsPerSecond, nsecsPerMicrosecond, unixDaysOffset) import Control.Arrow ((>>>), first) +-- types+ -- | Represents a point on a global time line.  An Instant has no concept of time zone or --   calendar.  It is nothing more than the number of nanoseconds since epoch (1.March.2000) data Instant = Instant { iDays :: Int32, iSecs :: Word32, iNsecs :: Word32 }                -- TODO: Would this be better with only days and Word64 Nanos?  See if the math is easier-    deriving (Eq, Ord, Show)    -- TODO: Remove Show+  deriving (Eq, Ord)++-- | Represents a duration of time between instants.  It can be from days to nanoseconds,+--   but anything longer is not representable by a duration because e.g. Months are calendar+--   specific concepts.+newtype Duration = Duration { getInstant :: Instant } {- NOTE: Defined here to avoid circular dependancy with Duration.Internal -}+  deriving (Eq, Show)             -- TODO: Remove Show++instance Show Instant where+  show (Instant days secs nsecs) = intercalate "." [show (abs days), show secs, show nsecs, sign]+    where+      sign = if signum days == -1 then "BE" else "E"++-- interface++-- Smallest possible instant+bigBang :: Instant+bigBang = Instant minBound minBound minBound++-- | Create an 'Instant' from an 'Int' that represents a Unix Epoch+fromSecondsSinceUnixEpoch :: Int -> Instant+fromSecondsSinceUnixEpoch s = fromUnixGetTimeOfDay s 0++-- | Add a 'Duration' to an 'Instant' to get a future 'Instant'. /NOTE: does not handle all negative durations, use 'minus'/+add :: Instant -> Duration -> Instant+add (Instant ldays lsecs lnsecs) (Duration (Instant rdays rsecs rnsecs)) = Instant days' secs'' nsecs'+    where+        days = ldays + rdays+        secs = lsecs + rsecs+        nsecs = lnsecs + rnsecs+        (secs', nsecs') = adjust secs nsecs nsecsPerSecond+        (days', secs'') = adjust days secs' secondsPerDay+        adjust big small size+            | small >= size = (succ big, small - size)+            | otherwise = (big, small)++-- | Get the difference between two instances+difference :: Instant -> Instant -> Duration+difference (Instant ldays lsecs lnsecs) (Instant rdays rsecs rnsecs) = Duration $ Instant days' (fromIntegral secs'') (fromIntegral nsecs')+    where+        days = ldays - rdays+        secs = (fromIntegral lsecs - fromIntegral rsecs) :: Int                   -- TODO: We should specify exactly what sizes we need here.  Keep in mind we can depend that secs and nsecs are never negative so+        nsecs = (fromIntegral lnsecs - fromIntegral rnsecs) :: Int                -- TODO: there is no worry that we get e.g. (-nsecsPerSecond - -nsecsPerSecond) causing us to have more than nsecsPerSecond.+        (secs', nsecs') = normalize nsecs secs nsecsPerSecond+        (days', secs'') = normalize secs' days secondsPerDay+        normalize x bigger size+            | x < 0 = (pred bigger, x + size)+            | otherwise = (bigger, x)++-- | Subtract a 'Duration' from an 'Instant' to get an 'Instant' in the past.  /NOTE: does not handle negative durations, use 'add'/+minus :: Instant -> Duration -> Instant+minus linstant (Duration rinstant) = getInstant $ difference linstant rinstant++-- helper functions  fromUnixGetTimeOfDay :: Int -> Word32 -> Instant fromUnixGetTimeOfDay s ms = Instant days (fromIntegral secs) nsecs

@@ -0,0 +1,28 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Data.HodaTime.Instant.Unix+(+    now+)+where++#include <sys/time.h>++import Data.HodaTime.Instant.Internal (fromUnixGetTimeOfDay, Instant)++import Foreign.C.Error (throwErrnoIfMinus1_)+import Foreign.C.Types+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Storable++-- | Create an 'Instant' from the current system time+now :: IO Instant+now = allocaBytes #{size struct timeval} $ \ ptv -> do+  throwErrnoIfMinus1_ "gettimeofday" $ gettimeofday ptv nullPtr+  CTime sec <- #{peek struct timeval, tv_sec} ptv+  CSUSeconds usec <- #{peek struct timeval, tv_usec} ptv+  return $ fromUnixGetTimeOfDay (fromIntegral sec) (fromIntegral usec)+{-# INLINE now #-}++foreign import ccall unsafe "time.h gettimeofday"+  gettimeofday :: Ptr () -> Ptr () -> IO CInt

@@ -6,11 +6,10 @@   ,Minute   ,Second   ,Nanosecond-  ,fromInstant  -- TODO: Remove+  ,midnight ) where -import Data.HodaTime.Instant.Internal (Instant(..)) import Data.HodaTime.CalendarDateTime.Internal (LocalTime(..), CalendarDateTime(..), CalendarDate, day, IsCalendar(..)) import Data.HodaTime.Internal (hoursFromSecs, minutesFromSecs, secondsFromSecs) import Data.HodaTime.Constants (secondsPerDay)@@ -68,11 +67,11 @@   {-# INLINE second #-}    nanosecond f (CalendarDateTime cd lt) = CalendarDateTime cd <$> nanosecond f lt---- Constructors+  {-# INLINE nanosecond #-} -fromInstant :: Instant -> LocalTime                   -- NOTE: This should never go to top level as Instant -> LocalTime is not supported, you must go through a ZonedDateTime-fromInstant (Instant _ secs nsecs) = LocalTime secs nsecs+-- | Private function for constructing a localtime at midnight+midnight :: LocalTime+midnight = LocalTime 0 0  -- helper functions 

@@ -18,6 +18,7 @@   -- * Types    Offset   -- * Constructors+  ,empty   ,fromSeconds   ,fromMinutes   ,fromHours@@ -26,39 +27,25 @@   ,minutes   ,hours   -- * Math-  ,add-  ,minus+  ,addClamped+  ,minusClamped ) where -import Data.HodaTime.OffsetDateTime.Internal-import Data.HodaTime.Constants (secondsPerHour)-import Data.HodaTime.Internal (secondsFromSeconds, secondsFromMinutes, secondsFromHours, clamp, hoursFromSecs, minutesFromSecs, secondsFromSecs)+import Data.HodaTime.Offset.Internal+import Data.HodaTime.Internal (secondsFromMinutes, secondsFromHours, clamp, hoursFromSecs, minutesFromSecs, secondsFromSecs)  -- Offset specific constants -maxOffsetHours :: Num a => a-maxOffsetHours = 18- minOffsetHours :: Num a => a minOffsetHours = negate maxOffsetHours -maxOffsetSeconds :: Num a => a-maxOffsetSeconds = maxOffsetHours * secondsPerHour--minOffsetSeconds :: Num a => a-minOffsetSeconds = negate maxOffsetSeconds- maxOffsetMinutes :: Num a => a maxOffsetMinutes = maxOffsetHours * 60  minOffsetMinutes :: Num a => a minOffsetMinutes = negate maxOffsetMinutes --- | Create an 'Offset' of (clamped) s seconds.-fromSeconds :: Integral a => a -> Offset-fromSeconds = Offset . secondsFromSeconds . clamp minOffsetSeconds maxOffsetSeconds- -- | Create an 'Offset' of (clamped) m minutes. fromMinutes :: Integral a => a -> Offset fromMinutes = Offset . secondsFromMinutes . clamp minOffsetMinutes maxOffsetMinutes@@ -81,11 +68,3 @@ hours :: Functor f => (Int -> f Int) -> Offset -> f Offset hours f (Offset secs) = hoursFromSecs fromSeconds f secs {-# INLINE hours #-}---- | Add one 'Offset' to another  /NOTE: if the result of the addition is outside the accepted range it will be clamped/-add :: Offset -> Offset -> Offset-add (Offset lsecs) (Offset rsecs) = fromSeconds $ lsecs + rsecs---- | Subtract one 'Offset' to another.  /NOTE: See 'add' above/-minus :: Offset -> Offset -> Offset-minus (Offset lsecs) (Offset rsecs) = fromSeconds $ lsecs - rsecs

@@ -0,0 +1,69 @@+module Data.HodaTime.Offset.Internal+(+   Offset(..)+  ,maxOffsetHours+  ,maxOffsetSeconds+  ,minOffsetSeconds+  ,empty+  ,toStringRep+  ,fromSeconds+  ,adjustInstant+  ,addClamped+  ,minusClamped+)+where++import Data.HodaTime.Instant.Internal (Instant, add, minus)+import qualified Data.HodaTime.Duration.Internal as D (fromSeconds)+import Data.HodaTime.Constants (secondsPerHour)+import Data.HodaTime.Internal (secondsFromSeconds, clamp)++-- | An 'Offset' from UTC in seconds.+newtype Offset = Offset { offsetSeconds :: Int }  -- TODO: Any reason to make this 32 bit?  We don't need more space than 32 bit+  deriving (Eq, Ord, Show)     -- TODO: Remove Show++-- Offset specific constants++maxOffsetHours :: Num a => a+maxOffsetHours = 18++maxOffsetSeconds :: Num a => a+maxOffsetSeconds = maxOffsetHours * secondsPerHour++minOffsetSeconds :: Num a => a+minOffsetSeconds = negate maxOffsetSeconds++-- | An 'Offset' with an offset of 0.  This is equivalent to UTC+empty :: Offset+empty = Offset 0++-- TODO: temp solution until we deal with printing+toStringRep :: Offset -> String+toStringRep (Offset secs) = rep+  where+    utc = "UTC"+    rep = if secs == 0 then utc else utc ++ sign ++ show h ++ ":" ++ show s+    sign = if secs < 0 then "-" else "+"+    h = secs `div` secondsPerHour+    s = secs - (h*secondsPerHour)++-- | Create an 'Offset' of (clamped) s seconds.+fromSeconds :: Integral a => a -> Offset+fromSeconds = Offset . secondsFromSeconds . clamp minOffsetSeconds maxOffsetSeconds++-- | Add one 'Offset' to another  /NOTE: if the result of the addition is outside the accepted range it will be clamped/+addClamped :: Offset -> Offset -> Offset+addClamped (Offset lsecs) (Offset rsecs) = fromSeconds $ lsecs + rsecs+  +-- | Subtract one 'Offset' to another.  /NOTE: See 'add' above/+minusClamped :: Offset -> Offset -> Offset+minusClamped (Offset lsecs) (Offset rsecs) = fromSeconds $ lsecs - rsecs++-- helper functions++adjustInstant :: Offset -> Instant -> Instant+adjustInstant (Offset secs) instant = instant'+  where+    op = if secs < 0 then minus else add+    duration = D.fromSeconds . abs $ secs+    instant' = instant `op` duration

@@ -1,6 +1,43 @@ module Data.HodaTime.OffsetDateTime (+  -- * Types+   OffsetDateTime+  -- * Constructors+  ,fromInstantWithOffset+  ,fromCalendarDateTimeWithOffset+  -- * Math+  -- * Conversion ) where -import Data.HodaTime.OffsetDateTime.Internal+import Data.HodaTime.Offset.Internal+import Data.HodaTime.Instant.Internal (Instant)+import Data.HodaTime.CalendarDateTime.Internal (CalendarDateTime, IsCalendarDateTime(..))+import Data.HodaTime.ZonedDateTime.Internal (ZonedDateTime(..))+import Data.HodaTime.TimeZone.Internal (TimeZone(..), TZIdentifier(..), TransitionInfo, fixedOffsetZone)++-- | A 'CalendarDateTime' with a UTC offset.  This is the format used by e.g. HTTP.  This type has a fixed 'TimeZone' with the name "UTC(+/-)offset".  If the offset is+-- empty, the name of the 'TimeZone' will be UTC+newtype OffsetDateTime cal = OffsetDateTime (ZonedDateTime cal)+  deriving (Eq, Show)    -- TODO: Remove Show++-- | Create an 'OffsetDateTime' from an 'Instant' and an 'Offset'.+fromInstantWithOffset :: IsCalendarDateTime cal => Instant -> Offset -> OffsetDateTime cal+fromInstantWithOffset inst offset = OffsetDateTime $ ZonedDateTime cdt tz tInfo+  where+    (tz, tInfo) = makeFixedTimeZone offset+    cdt = fromAdjustedInstant . adjustInstant offset $ inst++-- | Create an 'OffsetDateTime' from a 'CalendarDateTime' and an 'Offset'.+fromCalendarDateTimeWithOffset :: CalendarDateTime cal -> Offset -> OffsetDateTime cal+fromCalendarDateTimeWithOffset cdt offset = OffsetDateTime $ ZonedDateTime cdt tz tInfo+  where+    (tz, tInfo) = makeFixedTimeZone offset++-- helper functions++makeFixedTimeZone :: Offset -> (TimeZone, TransitionInfo)+makeFixedTimeZone offset = (TimeZone (Zone tzName) utcM calDateM, tInfo)+  where+    tzName = toStringRep offset+    (utcM, calDateM, tInfo) = fixedOffsetZone tzName offset

@@ -1,21 +0,0 @@-module Data.HodaTime.OffsetDateTime.Internal-(-   Offset(..)-  ,empty-)-where--import Data.Int (Int32)---- | An 'Offset' from UTC in seconds.-newtype Offset = Offset { offsetSeconds :: Int32 }-    deriving (Eq, Ord, Show)     -- TODO: Remove Show--empty :: Offset-empty = Offset 0--{---- | A 'LocalDateTime' with a UTC offset.  This is the format used by e.g. HTTP.-data OffsetDateTime = OffsetDateTime { osdtDateTime :: LocalDateTime, osdtOffset :: Offset }-    deriving (Eq, Ord, Show)    -- TODO: Remove Show--}

@@ -1,64 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.HodaTime.Instant+-- Copyright   :  (C) 2017 Jason Johnson+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Jason Johnson <jason.johnson.081@gmail.com>+-- Stability   :  experimental+-- Portability :  POSIX, Windows+--+-- This module deals with loading TimeZone information with which to construct ZonedDateTimes.+---------------------------------------------------------------------------- module Data.HodaTime.TimeZone (-   utc-  ,local-  ,timeZoneAt-  ,getUtcOffset-  ,maxOffset-  ,minOffset+  -- * Types+   TimeZone+  -- * Constructors+  ,utc+  ,localZone+  ,timeZone ) where  import Data.HodaTime.TimeZone.Internal-import Data.HodaTime.ZonedDateTime.Internal (ZonedDateTime, ZoneLocalResult(..))-import Data.HodaTime.OffsetDateTime.Internal (Offset)--utc :: TimeZone-utc = UTCzone--timeZoneAt :: TZIdentifier -> Maybe TimeZone-timeZoneAt = undefined--local :: TimeZone-local = undefined--{--atLeniently :: LocalDateTime -> TimeZone -> ZonedDateTime-atLeniently = undefined--atStartOfDay :: LocalDate -> TimeZone -> ZonedDateTime-atStartOfDay = undefined--atStrictly :: LocalDateTime -> TimeZone -> Maybe ZonedDateTime-atStrictly ldt UTCzone = Just $ atLeniently ldt UTCzone-atStrictly _ldt _tz = undefined---- | Return all 'ZonedDateTime' entries for a specific 'LocalDateTime' in a 'TimeZone'. Normally this would be one, but in the case that a time occurs twice in a zone (i.e. due to daylight savings time change)--- | both would be returned.  Also, if the time does not occur at all, 'Nothing' will be returned.  This method allows the user to choose exactly what to do in the case of ambigiuty.-atAll :: LocalDateTime -> TimeZone -> Maybe ZoneLocalResult-atAll ldt UTCzone = Just . ZLSingle $ atLeniently ldt UTCzone-atAll _ldt _tz = undefined---- | Takes two functions to determine how to resolve a 'LocalDateTime' to a 'ZonedDateTime' in the case of ambiguity or skipped times.  The first function is for the ambigous case and is past the first--- | matching 'ZonedDateTime', followed by the second match. The second function is for the case that the 'LocalDateTime' doesn't exist in the 'TimeZone' (e.g. in a spring-forward situation, there will--- | be a missing hour), the first 'ZonedDateTime' will be the the last time before the gap and the second will be the first time after the gap.-resolve :: LocalDateTime -> TimeZone -> (ZonedDateTime -> ZonedDateTime -> Maybe ZonedDateTime) -> (ZonedDateTime -> ZonedDateTime -> Maybe ZonedDateTime) -> Maybe ZonedDateTime-resolve ldt UTCzone _ _ = Just $ atLeniently ldt UTCzone-resolve _ldt _tz _am _sk = undefined---- | Return a special 'ZonedDateTime' for the given 'Offset'.  The identifier will be "UTC" in the case of a zero 'Offset' and "UTC(+/-)Offset" otherwise.-forOffset :: LocalDateTime -> Offset -> TimeZone-forOffset = undefined--}+import Data.HodaTime.TimeZone.Platform -getUtcOffset :: TimeZone -> Int-getUtcOffset UTCzone = 0-getUtcOffset _tz = undefined+-- | Load the UTC time zone+utc :: IO TimeZone+utc = do+  (utcM, calDateM) <- loadUTC+  return $ TimeZone UTC utcM calDateM -maxOffset :: TimeZone -> Int-maxOffset UTCzone = 0-maxOffset _tz = undefined+-- | Load the specified time zone.  The time zone name should be in the standard format (e.g. "Europe/Paris")+timeZone :: String -> IO TimeZone+timeZone tzName = do+  (utcM, calDateM) <- loadTimeZone tzName+  return $ TimeZone (Zone tzName) utcM calDateM -minOffset :: TimeZone -> Int-minOffset UTCzone = 0-minOffset _tz = undefined+-- | Load the locally configured time zone (operating system configuration dependant)+localZone :: IO TimeZone+localZone = do+  (utcM, calDateM, tzName) <- loadLocalZone+  return $ TimeZone (Zone tzName) utcM calDateM

@@ -1,48 +1,194 @@ module Data.HodaTime.TimeZone.Internal (-   TZIdentifier+   TZIdentifier(..)   ,TransitionInfo(..)-  ,Transitions-  ,mkTransitions-  ,addTransitionInfo-  ,activeTransitionInfoFor-  ,nextTransitionInfo+  ,TransitionExpression(..)+  ,TransitionExpressionInfo(..)+  ,UtcTransitionsMap+  ,IntervalEntry(..)+  ,CalDateTransitionsMap   ,TimeZone(..)+  ,emptyUtcTransitions+  ,addUtcTransition+  ,addUtcTransitionExpression+  ,activeTransitionFor+  ,nextTransition+  ,emptyCalDateTransitions+  ,addCalDateTransition+  ,addCalDateTransitionExpression+  ,calDateTransitionsFor+  ,aroundCalDateTransition+  ,fixedOffsetZone+  ,expressionToInstant+  ,yearExpressionToInstant ) where  import Data.Maybe (fromMaybe)-import Data.HodaTime.Instant.Internal (Instant)+import Data.HodaTime.Instant.Internal (Instant(..), minus, bigBang)+import Data.HodaTime.Offset.Internal (Offset(..), adjustInstant)+import Data.HodaTime.Duration.Internal (fromNanoseconds)+import Data.HodaTime.Calendar.Gregorian.Internal (nthDayToDayOfMonth, yearMonthDayToDays, instantToYearMonthDay) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map+import Data.IntervalMap.FingerTree (IntervalMap, Interval(..))+import qualified Data.IntervalMap.FingerTree as IMap -newtype TZIdentifier = Zone String+data TZIdentifier = UTC | Zone String   deriving (Eq, Show) -data TransitionInfo = TransitionInfo {-   ttGmtOffset :: Int-  ,ttIsDst :: Bool-  ,ttAbbreviation :: String-  ,ttIsStd :: Bool-  ,ttIsGmt :: Bool } deriving (Eq, Show)+data TransitionInfo = TransitionInfo { tiUtcOffset :: Offset, tiIsDst :: Bool, tiAbbreviation :: String }+  deriving (Eq, Show) -type Transitions = Map Instant TransitionInfo+data TransitionExpression =+  NthDayExpression+  {+     teMonth :: Int+    ,teNthDay :: Int+    ,teDay :: Int+    ,teSeconds :: Int+  }+  | JulianExpression { jeCountLeaps :: Bool, jeDay :: Int, jeSeconds :: Int }+  deriving (Eq, Show) -mkTransitions :: Transitions-mkTransitions = Map.empty+data TransitionExpressionInfo = TransitionExpressionInfo+  {+     startExpression :: TransitionExpression+    ,endExpression :: TransitionExpression+    ,stdTransInfo :: TransitionInfo+    ,dstTransInfo :: TransitionInfo+  }+  deriving (Eq, Show) -addTransitionInfo :: Instant -> TransitionInfo -> Transitions -> Transitions-addTransitionInfo = Map.insert+data TransitionInfoOrExp = +    TransitionInfoFixed TransitionInfo+  | TransitionInfoExpression TransitionExpressionInfo+    deriving (Eq, Show) -activeTransitionInfoFor :: Instant -> Transitions -> (Instant, TransitionInfo)-activeTransitionInfoFor t ts = fromMaybe (Map.findMin ts) $ Map.lookupLE t ts+-- UTC instant to transition -nextTransitionInfo :: Instant -> Transitions -> (Instant, TransitionInfo)-nextTransitionInfo t ts = fromMaybe (Map.findMax ts) $ Map.lookupGT t ts+type UtcTransitionsMap = Map Instant TransitionInfoOrExp +emptyUtcTransitions :: UtcTransitionsMap+emptyUtcTransitions = Map.empty++addUtcTransition :: Instant -> TransitionInfo -> UtcTransitionsMap -> UtcTransitionsMap+addUtcTransition i fti = Map.insert i (TransitionInfoFixed fti)++addUtcTransitionExpression :: Instant -> TransitionExpressionInfo -> UtcTransitionsMap -> UtcTransitionsMap+addUtcTransitionExpression i texp = Map.insert i (TransitionInfoExpression texp)++activeTransitionFor :: Instant -> TimeZone -> TransitionInfo+activeTransitionFor i (TimeZone _ utcM _) = fromTransInfo i f id . snd . fromMaybe (Map.findMin utcM) $ Map.lookupLE i utcM     -- NOTE: The findMin case should be impossible+  where+    f (dstStart, dstEnd, stdTI, dstTI) = if i <= dstStart || i >= dstEnd then stdTI else dstTI++-- TODO: We would need to get the next year to complete this function but let's see if it's actually used before doing more work+nextTransition :: Instant -> TimeZone -> (Instant, TransitionInfo)+nextTransition i (TimeZone _ utcM _) = f . fromMaybe (Map.findMax utcM) $ Map.lookupGT i utcM+  where+    f (i', ti) = fromTransInfo i g (\ti' -> (i', ti')) ti+    g (dstStart, dstEnd, stdTI, dstTI) = if i < dstStart then (dstStart, dstTI) else if i < dstEnd then (dstEnd, stdTI) else error "nextTransition: need next year"++-- CalendarDate to transition++data IntervalEntry a =+    Smallest+  | Entry a+  | Largest+  deriving (Eq, Ord, Show)++type CalDateTransitionsMap = IntervalMap (IntervalEntry Instant) TransitionInfoOrExp++emptyCalDateTransitions :: CalDateTransitionsMap+emptyCalDateTransitions = IMap.empty++addCalDateTransition :: IntervalEntry Instant -> IntervalEntry Instant -> TransitionInfo -> CalDateTransitionsMap -> CalDateTransitionsMap+addCalDateTransition b e fti = IMap.insert interval (TransitionInfoFixed fti)+  where+    interval = Interval b e++addCalDateTransitionExpression :: IntervalEntry Instant -> IntervalEntry Instant -> TransitionExpressionInfo -> CalDateTransitionsMap -> CalDateTransitionsMap+addCalDateTransitionExpression b e texp = IMap.insert interval (TransitionInfoExpression texp)+  where+    interval = Interval b e++calDateTransitionsFor :: Instant -> TimeZone -> [TransitionInfo]+calDateTransitionsFor i (TimeZone _ _ cdtMap) = concatMap (fromTransInfo i f (:[]) . snd) . search $ cdtMap+  where+    search = IMap.search (Entry i)+    f = fmap snd . search . buildFixedTransIMap++-- TODO: this function need major cleanup, this implementation is really nasty and almost certainly unsafe+aroundCalDateTransition :: Instant -> TimeZone -> (TransitionInfo, TransitionInfo)+aroundCalDateTransition i (TimeZone _ _ cdtMap) = go . fmap snd . IMap.search (Entry i) $ cdtMap+    where+      go [] = (before, after)+      go [(TransitionInfoExpression (TransitionExpressionInfo _ _ stdTI dstTI))] = (stdTI, dstTI) -- NOTE: Should be the only way this happens+      go x = error $ "aroundCalDateTransition: unexpected search result" ++ show x+      before = fromTransInfo i bomb id . snd . go' . flip IMap.search cdtMap . IMap.high . fromMaybe (error "around.before: fixme") . IMap.bounds $ front+      after = fromTransInfo i bomb id . snd . fst . fromMaybe (error "around.after: fixme") . IMap.leastView $ back+      (front, back) = IMap.splitAfter (Entry i) cdtMap+      go' [] = error "aroundCalDateTransition: no before transitions"+      go' [tei] = tei+      go' _ = error "aroundCalDateTransition: too many before transitions"+      bomb = error "aroundCalDateTransition: got expression when fixed expected"++-- | Represents a time zone.  A 'TimeZone' can be used to instanciate a 'ZoneDateTime' from either and 'Instant' or a 'CalendarDateTime' data TimeZone =-    UTCzone-  | TimeZone {-     tzZone :: TZIdentifier-    ,tzTransitions :: Transitions }-      deriving (Eq, Show)+  TimeZone+    {+       zoneName :: TZIdentifier+      ,utcTransitionsMap :: UtcTransitionsMap+      ,calDateTransitionsMap :: CalDateTransitionsMap+    }+  deriving (Eq, Show)++-- constructors++fixedOffsetZone :: String -> Offset -> (UtcTransitionsMap, CalDateTransitionsMap, TransitionInfo)+fixedOffsetZone tzName offset = (utcM, calDateM, tInfo)+    where+      utcM = addUtcTransition bigBang tInfo emptyUtcTransitions+      calDateM = addCalDateTransition Smallest Largest tInfo emptyCalDateTransitions+      tInfo = TransitionInfo offset False tzName++-- helper functions++fromTransInfo :: Instant -> ((Instant, Instant, TransitionInfo, TransitionInfo) -> a) -> (TransitionInfo -> a) -> TransitionInfoOrExp -> a+fromTransInfo _ _ f (TransitionInfoFixed ti) = f ti+fromTransInfo i f _ (TransitionInfoExpression (TransitionExpressionInfo startExpr endExpr stdTI dstTI)) = f (dstStart, dstEnd, stdTI, dstTI)+  where+    dstStart = expressionToInstant i startExpr+    dstEnd = expressionToInstant i endExpr++-- NOTE: We have to store expressions in the year they take effect so this is the first place we can resolve+--       the actual map.  Otherwise we'd have to create two per year+buildFixedTransIMap :: (Instant, Instant, TransitionInfo, TransitionInfo) -> IntervalMap (IntervalEntry Instant) TransitionInfo+buildFixedTransIMap (start, end, stdTI, dstTI) = mkMap entries mempty+  where+    mkMap [] m = m+    mkMap ((b, e, ti):xs) m = mkMap xs $ addEntry b e ti m+    addEntry b e ti = IMap.insert (Interval b e) ti+    entries = [(Smallest, Entry beforeStart, stdTI), (Entry start', Entry beforeEnd, dstTI), (Entry end', Largest, stdTI)]+    (start', beforeStart) = adjust start dstTI stdTI+    (end', beforeEnd) = adjust end stdTI dstTI+    adjust tran ti prevTI = (x, beforeX)+      where+        x = adjustInstant (tiUtcOffset ti) tran+        beforeX = flip minus (fromNanoseconds 1) . adjustInstant (tiUtcOffset prevTI) $ tran++expressionToInstant :: Instant -> TransitionExpression -> Instant+expressionToInstant instant = yearExpressionToInstant y+  where+    y = let (yr, _, _) = instantToYearMonthDay instant in fromIntegral yr++yearExpressionToInstant :: Int -> TransitionExpression -> Instant+yearExpressionToInstant y = go+  where+    go (NthDayExpression m nth day s) = Instant days' (fromIntegral s) 0+      where+        m' = toEnum m+        d = nthDayToDayOfMonth nth day m' y+        days' = fromIntegral $ yearMonthDayToDays y m' d+    go (JulianExpression _cly _d _s) = error "need julian year day function"

@@ -1,73 +1,169 @@ module Data.HodaTime.TimeZone.Olson (-  getTransitions+   getTransitions+  ,ParseException(..) ) where  import Data.HodaTime.TimeZone.Internal+import Data.HodaTime.TimeZone.ParseTZ (parsePosixString)  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import Data.Binary.Get (Get, getWord8, getWord32be, getByteString, runGetOrFail)+import Data.Binary.Get (Get, getWord8, getWord32be, getInt32be, getInt64be, getByteString, runGetOrFail, skip, isEmpty) import Data.Word (Word8)-import Control.Monad (unless, replicateM_, replicateM, liftM, filterM)-import Data.Int (Int32)-import Control.Applicative ((<$>), (<*>), ZipList(..))-import Data.List (nub)-import System.Directory (doesFileExist, getDirectoryContents)-import System.FilePath ((</>))-import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch)-import Data.HodaTime.Instant.Internal (Instant)+import Control.Monad (unless, replicateM)+import Data.List (foldl')+import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow, throwM)+import Data.Typeable (Typeable)+import Data.HodaTime.Instant.Internal (Instant, fromSecondsSinceUnixEpoch, minus, bigBang)+import Data.HodaTime.Duration.Internal (fromNanoseconds)+import Data.HodaTime.Offset.Internal (Offset(..), adjustInstant)+import Data.HodaTime.Calendar.Gregorian.Internal (instantToYearMonthDay) -getTransitions :: L.ByteString -> Either String Transitions-getTransitions bs = case runGetOrFail getTransitions' bs of-    Left (_, _, msg) -> Left msg-    Right (_, _, xs) -> Right xs-    where-        getTransitions' = do-            magic <- (toASCII . B.unpack) <$> getByteString 4-            unless (magic == "TZif") (fail $ "unknown magic: " ++ magic)            -- We could consider creating an error type for this-            _version <- getWord8-            replicateM_ 15 getWord8 -- skip reserved section-            [ttisgmtcnt, ttisstdcnt, leapcnt, transcnt, ttypecnt, abbrlen] <- replicateM 6 get32bitInt-            transitions <- replicateM transcnt $ fromSecondsSinceUnixEpoch <$> get32bitInt-            indexes <- replicateM transcnt get8bitInt-            ttypes <- replicateM ttypecnt $ (,,) <$> get32bitInt <*> getBool <*> get8bitInt-            abbrs <- (toASCII . B.unpack) <$> getByteString abbrlen-            _leaps <- replicateM leapcnt getLeapInfo-            ttisstds <- replicateM ttisstdcnt getBool-            ttisgmts <- replicateM ttisgmtcnt getBool-            return $ zipTransitions (zipTransitionTypes abbrs ttypes ttisstds ttisgmts) transitions indexes+data ParseException = ParseException String Int+  deriving (Typeable, Show) -zipTransitionTypes :: String -> [(Int, Bool, Int)] -> [Bool] -> [Bool] -> [TransitionInfo]-zipTransitionTypes abbrs = zipWith3 toTI-    where-        toTI (gmt, isdst, offset) = TransitionInfo gmt isdst (getAbbr offset abbrs)-        getAbbr offset = takeWhile (/= '\NUL') . drop offset+instance Exception ParseException -zipTransitions :: [TransitionInfo] -> [Instant] -> [Int] -> Transitions-zipTransitions tis trans = foldr (\(i, idx) im -> addTransitionInfo i (tis !! idx) im) mkTransitions . zip trans+data Header = Header String Char Int Int Int Int Int Int -getLeapInfo :: Get (Integer, Int)-getLeapInfo = do-    lTime <- fmap toInteger get32bitInteger-    lOffset <- get32bitInt-    return (lTime, lOffset)+reservedSectionSize :: Int+reservedSectionSize = 15 +getTransitions :: MonadThrow m => L.ByteString -> m (UtcTransitionsMap, CalDateTransitionsMap)+getTransitions bs = case runGetOrFail getTransitions' bs of+  Left (_, consumed, msg) -> throwM $ ParseException msg (fromIntegral consumed)+  Right (_, _, xs) -> return xs+  where+    getTransitions' = do+      header@(Header magic version _ _ _ _ _ _) <- getHeader+      unless (magic == "TZif") (fail $ "unknown magic: " ++ magic)+      (getInt, header'@(Header _ _ isGmtCount isStdCount _ _ typeCount _)) <- getCorrectHeader header+      unless+        (isGmtCount == isStdCount && isStdCount == typeCount)+        (fail $ "format issue: sizes don't match: ttisgmtcnt = " ++ show isGmtCount ++ ", ttisstdcnt = " ++ show isStdCount ++ ", ttypecnt = " ++ show typeCount)+      (transitions, indexes, tInfos) <- getPayload getInt header'+      tzString <- getTZString version+      finished <- isEmpty+      unless finished $ fail "unprocessed data still in olson file"+      let (utcM, calDateM) = buildTransitionMaps (zip transitions indexes) tInfos tzString+      return (utcM, calDateM)++-- Get combinators++getCh :: Get Char+getCh = fmap toChar getWord8+  where+    toChar = toEnum . fromIntegral+ getBool :: Get Bool getBool = fmap (/= 0) getWord8 -get8bitInt :: Get Int-get8bitInt = fmap fromIntegral getWord8+getInt8 :: Get Int+getInt8 = fmap fromIntegral getWord8 -getInt32 :: Get Int32-getInt32 = fmap fromIntegral getWord32be+getUInt32 :: Get Int+getUInt32 = fmap fromIntegral getWord32be -get32bitInt :: Get Int-get32bitInt = fmap fromIntegral getInt32+getInt32 :: Get Int+getInt32 = fmap fromIntegral getInt32be -get32bitInteger :: Get Integer-get32bitInteger = fmap fromIntegral getInt32+getInt64 :: Get Int+getInt64 = fmap fromIntegral getInt64be -toASCII :: [Word8] -> String-toASCII = map (toEnum . fromIntegral)+getHeader :: Get Header+getHeader = do+  magic <- (toString . B.unpack) <$> getByteString 4+  version <- getCh+  skip reservedSectionSize+  [ttisgmtcnt, ttisstdcnt, leapcnt, transcnt, ttypecnt, abbrlen] <- replicateM 6 getUInt32+  return $ Header magic version ttisgmtcnt ttisstdcnt leapcnt transcnt ttypecnt abbrlen++getPayload :: Get Int -> Header -> Get ([Instant], [Int], [TransitionInfo])+getPayload getInt (Header _ _ isGmtCount isStdCount leapCount transCount typeCount abbrLen) = do+  transitions <- replicateM transCount $ fromSecondsSinceUnixEpoch <$> getInt+  indexes <- replicateM transCount getInt8+  types <- replicateM typeCount $ (,,) <$> getInt32 <*> getBool <*> getInt8+  abbrs <- (toString . B.unpack) <$> getByteString abbrLen+  skip $ leapCount + isStdCount + isGmtCount+  let tInfos = mapTransitionInfos abbrs types+  return (transitions, indexes, tInfos)+getCorrectHeader :: Header -> Get (Get Int, Header)+getCorrectHeader header@(Header _ version isGmtCount isStdCount leapCount transCount typeCount abbrLen)+  | version == '\NUL'                 = return (getInt32, header)+  | version == '1' || version == '2'  = skipOldDataAndGetHeader+  | otherwise                         = fail $ "unknown olson version: " ++ show version+  where+    skipOldDataAndGetHeader = do+      skip $ transCount * 4 + transCount + typeCount * 4 + typeCount + typeCount + abbrLen + leapCount * 4 * 2 + isStdCount + isGmtCount+      correctHeader <- getHeader+      return (getInt64, correctHeader)++getTZString :: Char -> Get (Maybe String)+getTZString version+  | version == '\NUL'                 = return Nothing+  | version == '1' || version == '2'  = getTZString'+  | otherwise                         = fail $ "impossible: unknown version in getTZString"+  where+    getTZString' = do+      nl <- getCh+      unless (nl == '\n') (fail $ "POSIX TZ string preceded by non-newline:" ++ show nl)+      posixTZ <- getWhileM (/= '\n')+      return . Just $ posixTZ+    getWhileM p = do+      ch <- getCh+      if p ch then do+        rest <- getWhileM p+        return $ ch : rest+      else return []++-- helper fucntions++mapTransitionInfos :: String -> [(Int, Bool, Int)] -> [TransitionInfo]+mapTransitionInfos abbrs = fmap toTI+  where+    toTI (gmt, isdst, offset) = TransitionInfo (Offset gmt) isdst $ getAbbr offset abbrs+    getAbbr offset = takeWhile (/= '\NUL') . drop offset++buildTransitionMaps :: [(Instant, Int)] -> [TransitionInfo] -> Maybe String -> (UtcTransitionsMap, CalDateTransitionsMap)+buildTransitionMaps transAndIndexes tInfos tzString = (utcMap, calDateMap')+  where+    calDateMap' = addLastCalDateEntry tzString' lastEntry lastTI calDateMap+    tzString' = fmap parsePosixString tzString+    defaultTI = findDefaultTransInfo $ tInfos+    initialUtcTransitions = addUtcTransition bigBang defaultTI emptyUtcTransitions+    (utcMap, calDateMap, lastEntry, lastTI) = foldl' go (initialUtcTransitions, emptyCalDateTransitions, Smallest, defaultTI) transAndIndexes+    go (utcM, calDateM, prevEntry, prevTI) (tran, idx) = (utcM', calDateM', Entry localTran, tInfo)+      where+        utcM' = addUtcTransition tran tInfo utcM+        calDateM' = addCalDateTransition prevEntry before prevTI calDateM+        localTran = adjustInstant (tiUtcOffset tInfo) $ tran+        before = Entry . flip minus (fromNanoseconds 1) . adjustInstant (tiUtcOffset prevTI) $ tran+        tInfo = tInfos !! idx++addLastCalDateEntry :: Maybe (Either TransitionInfo TransitionExpressionInfo) -> IntervalEntry Instant -> TransitionInfo -> CalDateTransitionsMap+                                -> CalDateTransitionsMap+addLastCalDateEntry Nothing start ti calDateMap = addCalDateTransition start Largest ti calDateMap+-- NOTE: If the tzString does not have a time zone specification then the way we process the rest of the file should be correct (TODO: check offset) so we can ignore it+addLastCalDateEntry (Just (Left _)) start ti calDateMap = addCalDateTransition start Largest ti calDateMap+addLastCalDateEntry (Just (Right texpr@(TransitionExpressionInfo stdExpr _ stdTI _))) start ti calDateMap = calDateMap''+  where+    calDateMap' = addCalDateTransition start before ti calDateMap+    calDateMap'' = addCalDateTransitionExpression (Entry cdExprStart) Largest texpr calDateMap'+    cdExprStart = adjustInstant (tiUtcOffset stdTI) $ exprStart+    before = Entry . flip minus (fromNanoseconds 1) . adjustInstant (tiUtcOffset ti) $ exprStart+    exprStart = yearExpressionToInstant (y + 1) stdExpr   -- TODO: if we ever find the gap too large, we could add a check here before incrementing the year+    y = case start of+      (Entry trans) -> let (yr, _, _) = instantToYearMonthDay trans in fromIntegral yr+      _             -> error "impossible: got non Entry for last valid transition"++findDefaultTransInfo :: [TransitionInfo] -> TransitionInfo+findDefaultTransInfo tis = go . filter ((== False) . tiIsDst) $ tis+  where+    go [] = head tis+    go (ti:_) = ti++toString :: [Word8] -> String+toString = map (toEnum . fromIntegral)

@@ -0,0 +1,87 @@+module Data.HodaTime.TimeZone.ParseTZ+(+  parsePosixString+)+where++import Data.HodaTime.TimeZone.Internal+import Data.HodaTime.Offset.Internal (Offset(..))+import Control.Applicative+import Text.Parsec hiding (many, optional, (<|>))++type ExpParser = Parsec String ()++parsePosixString :: String -> (Either TransitionInfo TransitionExpressionInfo)+parsePosixString tzStr = case runParser p_posixTzString () tzStr tzStr of+        Left err -> error $ show err+        Right r -> r++p_posixTzString :: ExpParser (Either TransitionInfo TransitionExpressionInfo)+p_posixTzString = do+  stdID <- p_tzIdentifier <?> "Standard TZ identifier"+  stdOffset <- p_offset <?> "TZ Offset"+  p_dstExpression stdID stdOffset <|> (return . Left . TransitionInfo stdOffset False $ stdID)++p_dstExpression :: String -> Offset -> ExpParser (Either TransitionInfo TransitionExpressionInfo)+p_dstExpression stdID stdOffset@(Offset stdOffsetSecs) = do+  dstID <- p_tzIdentifier+  dstOffset <- option (Offset $ stdOffsetSecs + toHour 1) p_offset+  startExpr <- char ',' *> p_transitionExpression+  endExpr <- char ',' *> p_transitionExpression+  let stdTI = TransitionInfo stdOffset False stdID+  let dstTI = TransitionInfo dstOffset True dstID+  return . Right $ TransitionExpressionInfo startExpr endExpr stdTI dstTI++p_tzIdentifier :: ExpParser String+p_tzIdentifier = p_tzSpecialIdentifier <|> p_tzNormalIdentifier++p_tzSpecialIdentifier :: ExpParser String+p_tzSpecialIdentifier = do+  idt <- char '<' *> many1 (noneOf ">")+  ("<" ++ idt ++ ">") <$ char '>'++p_tzNormalIdentifier :: ExpParser String+p_tzNormalIdentifier = do+  start <- count 3 letter+  rest <- many . noneOf $ ":,+-" ++ ['0'..'9']+  return $ start ++ rest++p_offset :: ExpParser Offset+p_offset = Offset . negate <$> p_time++p_time :: ExpParser Int+p_time = do+  sign <- (negate <$ char '-') <|> (option id (id <$ char '+'))+  hours <- toHour . read <$> many1 digit+  minutes <- option 0 $ (* 60) . read <$> optionalDigit+  seconds <- option 0 $ read <$> optionalDigit+  return . sign $ hours + minutes + seconds+    where+      optionalDigit = char ':' *> many1 digit++p_transitionExpression :: ExpParser TransitionExpression+p_transitionExpression = te <*> time+  where+    te = p_julianExpression <|> p_nthDayExpression+    time = option (toHour 2) (char '/' *> p_time)++p_julianExpression :: ExpParser (Int -> TransitionExpression)+p_julianExpression = JulianExpression <$> cntLp <*> d+  where+    cntLp = option True (False <$ char 'J')+    d = read <$> many1 digit++p_nthDayExpression :: ExpParser (Int -> TransitionExpression)+p_nthDayExpression = NthDayExpression <$> m <*> nth <*> d+  where+    m =   char 'M' *> (subtract 1 <$> p_number)+    nth = char '.' *> (adjust <$> p_number)+    d =   char '.' *> p_number+    p_number = read <$> many1 digit+    adjust 5 = -1+    adjust n = n - 1++-- helper functions++toHour :: Int -> Int+toHour x = x * 60 * 60

@@ -0,0 +1,74 @@+module Data.HodaTime.TimeZone.Unix+(+   loadUTC+  ,loadLocalZone+  ,loadTimeZone+  ,defaultLoadZoneFromOlsonFile+)+where++import Data.HodaTime.TimeZone.Internal+import Data.HodaTime.TimeZone.Olson+import System.Directory (doesFileExist)+import System.FilePath ((</>))+import qualified Data.ByteString.Lazy.Char8 as BS+import System.Posix.Files (readSymbolicLink)+import Data.List (intercalate)+import Control.Exception (Exception, throwIO)+import Control.Monad (unless)+import Data.Typeable (Typeable)++-- exceptions++data TimeZoneDoesNotExistException = TimeZoneDoesNotExistException+  deriving (Typeable, Show)++instance Exception TimeZoneDoesNotExistException++data TZoneDBCorruptException = TZoneDBCorruptException+  deriving (Typeable, Show)++instance Exception TZoneDBCorruptException++type LoadZoneFromOlsonFile = FilePath -> IO (UtcTransitionsMap, CalDateTransitionsMap)++-- interface++loadUTC :: LoadZoneFromOlsonFile -> IO (UtcTransitionsMap, CalDateTransitionsMap)+loadUTC loadZoneFromOlsonFile = loadTimeZone loadZoneFromOlsonFile "UTC"++loadTimeZone :: LoadZoneFromOlsonFile -> String -> IO (UtcTransitionsMap, CalDateTransitionsMap)+loadTimeZone loadZoneFromOlsonFile tzName = do+  loadZoneFromOlsonFile $ tzdbDir </> tzName++loadLocalZone :: LoadZoneFromOlsonFile -> IO (UtcTransitionsMap, CalDateTransitionsMap, String)+loadLocalZone loadZoneFromOlsonFile = do+  let file = "/etc" </> "localtime"+  tzPath <- readSymbolicLink $ file+  let tzName = timeZoneFromPath $ tzPath+  (utcM, calDateM)  <- loadZoneFromOlsonFile file+  return (utcM, calDateM, tzName)++-- helper functions++tzdbDir :: FilePath+tzdbDir = "/usr" </> "share" </> "zoneinfo"++defaultLoadZoneFromOlsonFile :: LoadZoneFromOlsonFile+defaultLoadZoneFromOlsonFile file = do+  exists <- doesFileExist $ file+  unless exists (throwIO TimeZoneDoesNotExistException)+  bs <- BS.readFile $ file+  (utcM, calDateM) <- getTransitions bs+  return (utcM, calDateM)++-- helper functions++timeZoneFromPath :: FilePath -> String+timeZoneFromPath = intercalate "/" . drp . foldr collect [[]]+  where+    drp = drop 1 . dropWhile (/= "zoneinfo")+    collect ch l@(x:xs)+      | ch == '/' = []:l+      | otherwise = (ch:x):xs+    collect _ _ = error "impossible: only used to prove pattern is exhaustive"

@@ -1,6 +1,147 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.HodaTime.Instant+-- Copyright   :  (C) 2017 Jason Johnson+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Jason Johnson <jason.johnson.081@gmail.com>+-- Stability   :  experimental+-- Portability :  POSIX, Windows+--+-- This is the module for 'ZonedDateTime'.  A 'ZonedDateTime' is a universal time, it represents the same moment anywhere in the world and is completely+-- unambiguous.  Each instance of a 'ZonedDateTime' corresponds to exactly one point on a continuous time line.+---------------------------------------------------------------------------- module Data.HodaTime.ZonedDateTime (+  -- * Types+   ZonedDateTime+  -- * Constructors+  ,fromCalendarDateTimeLeniently+  ,fromCalendarDateTimeStrictly+  ,fromInstant+  -- * Math+  -- * Conversion+  ,toCalendarDateTime+  ,toCalendarDate+  ,toLocalTime+  -- * Accessors+  ,inDst+  ,zoneAbbreviation+  -- * Special constructors+  ,fromCalendarDateTimeAll+  ,resolve+  -- * Exceptions+  ,DateTimeDoesNotExistException(..)+  ,DateTimeAmbiguousException(..) ) where  import Data.HodaTime.ZonedDateTime.Internal+import Data.HodaTime.CalendarDateTime.Internal (CalendarDateTime(..), CalendarDate(..), IsCalendarDateTime(..), IsCalendar(..), LocalTime)+import Data.HodaTime.LocalTime.Internal (second)+import Data.HodaTime.Instant.Internal (Instant)+import Data.HodaTime.Offset.Internal (Offset(..), adjustInstant)+import Data.HodaTime.TimeZone.Internal (TimeZone, TransitionInfo(..), calDateTransitionsFor, aroundCalDateTransition, activeTransitionFor)+import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow, throwM)+import Data.Typeable (Typeable)++-- exceptions++-- TODO: find a way to get the offending CalendarDateTime into the exception so that if this is thrown in deeply nested code users can figure out+-- TODO: which date caused it.  The current problem is that "instance Exception" doesn't work if there is a type variable, even if the data type+-- TODO: itself is typeable+data DateTimeDoesNotExistException = DateTimeDoesNotExistException+  deriving (Typeable, Show)++instance Exception DateTimeDoesNotExistException++data DateTimeAmbiguousException = DateTimeAmbiguousException+  deriving (Typeable, Show)++instance Exception DateTimeAmbiguousException++-- constructors++-- | Returns the mapping of this 'CalendarDateTime' within the given 'TimeZone', with "lenient" rules applied such that ambiguous values map to the earlier of the alternatives,+--   and "skipped" values are shifted forward by the duration of the "gap".+fromCalendarDateTimeLeniently :: (IsCalendar cal, IsCalendarDateTime cal) => CalendarDateTime cal -> TimeZone -> ZonedDateTime cal+fromCalendarDateTimeLeniently = resolve ambiguous skipped+  where+    ambiguous zdt _ = zdt+    skipped (ZonedDateTime _ _ (TransitionInfo (Offset bOff) _ _)) (ZonedDateTime cdt tz ti@(TransitionInfo (Offset aOff) _ _)) = ZonedDateTime cdt' tz ti+      where+        cdt' = modify (\s -> s + aOff - bOff) second cdt+        modify f l = head . l ((:[]) . f)                 -- TODO: We may want to break down and define the 3 lens primitives we need somewhere++-- | Returns the mapping of this 'CalendarDateTime' within the given 'TimeZone', with "strict" rules applied such that ambiguous or skipped date times+--   return the requested failure response (e.g. Nothing, Left, exception, etc.)+fromCalendarDateTimeStrictly :: (MonadThrow m, IsCalendarDateTime cal) => CalendarDateTime cal -> TimeZone -> m (ZonedDateTime cal)+fromCalendarDateTimeStrictly cdt = go . fromCalendarDateTimeAll cdt+  where+    go [] = throwM $ DateTimeDoesNotExistException+    go [zdt] = return zdt+    go _ = throwM $ DateTimeAmbiguousException++-- | Return all 'ZonedDateTime' entries for a specific 'CalendarDateTime' in a 'TimeZone'. Normally this would be one, but in the case that a time+-- occurs twice in a zone (i.e. due to daylight savings time change) both would be returned.  Also, if the time does not occur at all, an empty list+-- will be returned.  This method allows the user to choose exactly what to do in the case of ambigiuty.+fromCalendarDateTimeAll :: IsCalendarDateTime cal => CalendarDateTime cal -> TimeZone -> [ZonedDateTime cal]+fromCalendarDateTimeAll cdt tz = zdts+  where+    instant = toUnadjustedInstant cdt+    zdts = fmap mkZdt . calDateTransitionsFor instant $ tz+    mkZdt = ZonedDateTime cdt tz++-- | Returns the 'ZonedDateTime' represented by the passed 'Instant' within the given 'TimeZone'.  This is always an unambiguous conversion.+fromInstant :: IsCalendarDateTime cal => Instant -> TimeZone -> ZonedDateTime cal+fromInstant instant tz = ZonedDateTime cdt tz ti+  where+    ti = activeTransitionFor instant tz+    offset = tiUtcOffset ti+    instant' = adjustInstant offset instant+    cdt = fromAdjustedInstant instant'++-- | Takes two functions to determine how to resolve a 'CalendarDateTime' to a 'ZonedDateTime' in the case of ambiguity or skipped times.  The first+-- function is for the ambigous case and is past the first matching 'ZonedDateTime', followed by the second match. The second function is for the case+-- that the 'CalendarDateTime' doesn't exist in the 'TimeZone' (e.g. in a spring-forward situation, there will be a missing hour), the first+-- 'ZonedDateTime' will be the the last time before the gap and the second will be the first time after the gap.+resolve ::+  IsCalendarDateTime cal =>+  (ZonedDateTime cal -> ZonedDateTime cal -> ZonedDateTime cal) ->+  (ZonedDateTime cal -> ZonedDateTime cal -> ZonedDateTime cal) ->+  CalendarDateTime cal ->+  TimeZone ->+  ZonedDateTime cal -- TODO: This function should probably allow failure+resolve ambiguous skipped cdt tz = go . fmap mkZdt . calDateTransitionsFor instant $ tz+  where+    instant = toUnadjustedInstant cdt+    (before, after) = aroundCalDateTransition instant $ tz+    mkZdt = ZonedDateTime cdt tz+    go [] = skipped (mkZdt before) (mkZdt after)+    go [zdt] = zdt+    go (zdt1:zdt2:[]) = ambiguous zdt1 zdt2+    go _ = error "misconfiguration: more than 2 dates returns from calDateTransitionsFor"++-- conversion++-- | Return the 'CalendarDateTime' represented by this 'ZonedDateTime'.+toCalendarDateTime :: ZonedDateTime cal -> CalendarDateTime cal+toCalendarDateTime (ZonedDateTime cdt _  _) = cdt++-- | Return the 'CalendarDate' represented by this 'ZonedDateTime'.+toCalendarDate :: ZonedDateTime cal -> CalendarDate cal+toCalendarDate (ZonedDateTime (CalendarDateTime cd _) _  _) = cd++-- | Return the 'LocalTime' represented by this 'ZonedDateTime'.+toLocalTime :: ZonedDateTime cal -> LocalTime+toLocalTime (ZonedDateTime (CalendarDateTime _ lt) _  _) = lt++-- Accessors++-- | Return a 'Bool' specifying if this 'ZonedDateTime' is currently in Daylight savings time.+inDst :: ZonedDateTime cal -> Bool+inDst (ZonedDateTime _ _ (TransitionInfo _ isInDst _)) = isInDst++-- | Return a 'String' representing the abbreviation for the TimeZone this 'ZonedDateTime' is currently in.+zoneAbbreviation :: ZonedDateTime cal -> String+zoneAbbreviation (ZonedDateTime _ _ (TransitionInfo _ _ abbr)) = abbr

@@ -1,15 +1,20 @@ module Data.HodaTime.ZonedDateTime.Internal (-   ZonedDateTime(..)-  ,ZoneLocalResult(..)+  ZonedDateTime(..) ) where -import Data.HodaTime.TimeZone.Internal (TimeZone)+import Data.HodaTime.CalendarDateTime.Internal (CalendarDateTime)+import Data.HodaTime.TimeZone.Internal (TimeZone, TransitionInfo) --- | A LocalDateTime in a specific time zone. A ZonedDateTime is global and maps directly to a single Instant.-data ZonedDateTime = ZonedDateTime { {- zdtOffsetDateTime :: OffsetDateTime, -} zdtTimeZone :: TimeZone }     -- TODO: It's not yet clear that we would need an offset time here. UPDATE: I don't want to have it, the TimeZone fulfils that role+-- | A CalendarDateTime in a specific time zone. A 'ZonedDateTime' is global and maps directly to a single 'Instant'.+data ZonedDateTime cal = ZonedDateTime { zdtCalendarDateTime :: CalendarDateTime cal, zdtTimeZone :: TimeZone, zdtActiveTransition :: TransitionInfo }+  deriving (Eq, Show)+-- TODO: We should have an Ord instance, we can just ignore the timezone field.  It would be especially good so that when CalendarDateTime is equal we can+-- TODO: compare the TransitionInfo to see which one comes first -data ZoneLocalResult =-    ZLSingle ZonedDateTime-  | ZLMulti { zlmFirst :: ZonedDateTime, zlmLast :: ZonedDateTime }+-- helper functions++-- TODO: We need functions that help construct this type.  Some of those functions probably need to be in OffsetDateTime so we can hide details of+-- TODO: CalendarDateTime from this module.  What we're trying to do is make sure the OffsetDateTime has the time set to the local time zone+-- TODO: and that the offset part tells us how far we are from UTC.  Nanos tell us how far we are into the current day

@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}- module HodaTime.Calendar.GregorianTest (   gregorianTests@@ -9,25 +7,15 @@ import Test.Tasty import Test.Tasty.QuickCheck as QC import Test.Tasty.HUnit-import Data.Maybe (fromJust)+import Data.Maybe (fromJust, catMaybes) import Data.Time.Calendar (fromGregorianValid, toGregorian)  import HodaTime.Util-import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek)-import Data.HodaTime.Calendar.Gregorian (calendarDate, Month(..), DayOfWeek(..), Gregorian)+import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek, DayNth(..))+import Data.HodaTime.Calendar.Gregorian (calendarDate, fromNthDay, Month(..), DayOfWeek(..)) import qualified Data.HodaTime.Calendar.Gregorian as G import qualified Data.HodaTime.Calendar.Iso as Iso -instance Arbitrary (Month Gregorian) where-  arbitrary = do-    x <- choose (0,11)-    return $ toEnum x--instance Arbitrary (DayOfWeek Gregorian) where-  arbitrary = do-    x <- choose (0,6)-    return $ toEnum x- gregorianTests :: TestTree gregorianTests = testGroup "Gregorian Tests" [qcProps, unitTests] @@ -65,7 +53,7 @@   ]   where     mkcd d m = fromJust . calendarDate d m-    testMonthAdd d (Positive y) m add = y < 400 QC.==> get day (modify (+ add) monthl $ mkcd d m (y + 1900)) == d  -- NOTE: We fix the year so we don't run out of tests+    testMonthAdd d (CycleYear y) m add = get day (modify (+ add) monthl $ mkcd d m (y + 1900)) == d  -- NOTE: We fix the year so we don't run out of tests     testNextDoW dow (Positive n) = (dayOfWeek . next n dow $ epochDay) == dow     testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == modify (adjust $ n * 7) day epochDay     epochDay = mkcd 1 March 2000@@ -74,21 +62,59 @@ constructorUnits = testGroup "Constructor"   [      testCase "CalendarDate 30 February 2000 is not a valid date" $ calendarDate 30 February 2000 @?= Nothing+    ,testCase "CalendarDate 1 October 1582 is not a valid date" $ calendarDate 1 October 1582 @?= Nothing     ,testCase "Gregorian.fromWeekDate 1 Sunday 2000 = 26.Dec.1999" $ G.fromWeekDate 1 Sunday 2000 @?= calendarDate 26 December 1999     ,testCase "Gregorian.fromWeekDate 5 Sunday 2000 = 23.Jan.2000" $ G.fromWeekDate 5 Sunday 2000 @?= calendarDate 23 January 2000     ,testCase "Iso.fromWeekDate 1 Sunday 2000 = 9.Jan.2000" $ Iso.fromWeekDate 1 Sunday 2000 @?= calendarDate 9 January 2000     ,testCase "Iso.fromWeekDate 5 Sunday 2000 = 6.Feb.2000" $ Iso.fromWeekDate 5 Sunday 2000 @?= calendarDate 6 February 2000+    ,testCase "Holidays in year 2000" $ test2k (usaHolidays 2000)+    ,testCase "Holidays in year 2001" $ test2001 (usaHolidays 2001)+    ,testCase "Holidays in year 1582" $ test1582 (usaHolidays 1582)   ]+    where+      test2k hs = do+        assertEqual "length == 8" 8 (length hs)+        assertEqual "First Monday Sept = 4.Sept.2000" (fromJust $ calendarDate 4 September 2000) (hs !! 3)+        assertEqual "Third Monday Jan = 17.Jan.2000" (fromJust $ calendarDate 17 January 2000) (hs !! 4)+        assertEqual "Second Tuesday Feb = 8.Feb.2000" (fromJust $ calendarDate 8 February 2000) (hs !! 5)+        assertEqual "Fourth Thursday Nov = 23.Nov.2000" (fromJust $ calendarDate 23 November 2000) (hs !! 6)+      test2001 hs = do+        assertEqual "length == 7" 7 (length hs)+        assertEqual "First Monday Sept = 3.Sept.2001" (fromJust $ calendarDate 3 September 2001) (hs !! 3)+        assertEqual "Third Monday Jan = 15.Jan.2001" (fromJust $ calendarDate 15 January 2001) (hs !! 4)+        assertEqual "Second Tuesday Feb = 13.Feb.2001" (fromJust $ calendarDate 13 February 2001) (hs !! 5)+        assertEqual "Fourth Thursday Nov = 22.Nov.2001" (fromJust $ calendarDate 22 November 2001) (hs !! 6)+      test1582 hs = do+        assertEqual "length == 2" 2 (length hs)+        assertEqual "Fourth Thursday Nov = 25.Nov.1582" (fromJust $ calendarDate 25 November 1582) (hs !! 1)+      usaHolidays y = catMaybes $ ($ y) <$>+        [+           calendarDate 1 January               -- New Year+          ,calendarDate 4 July                  -- Independence Day +          ,calendarDate 25 December             -- Christmas+          ,fromNthDay First Monday September    -- Labor day+          ,fromNthDay Third Monday January      -- MLK day+          ,fromNthDay Second Tuesday February   -- Presidents day+          ,fromNthDay Fourth Thursday November  -- Thanksgiving+          ,calendarDate 29 February             -- Not a holiday but will sometimes be absent+        ]  lensUnits :: TestTree lensUnits = testGroup "Lens"   [      testCase "31-January-2000 + 2M == 31-March-2000" $ modify (+2) monthl <$> janEnd @?= calendarDate 31 March 2000     ,testCase "31-January-2000 + 1M == 29-February-2000" $ modify (+1) monthl <$> janEnd @?= calendarDate 29 February 2000+    ,testCase "15-November-1582 - 1M == 15-October-1582" $ modify (subtract 1) monthl <$> calendarDate 15 November 1582 @?= firstValidDate+    ,testCase "14-November-1582 - 1M == 15-October-1582 (clamped)" $ modify (subtract 1) monthl <$> calendarDate 14 November 1582 @?= firstValidDate     ,testCase "29-February-2000 + 1Y == 28-February-2001" $ modify (+1) year <$> leapFeb @?= calendarDate 28 February 2001+    ,testCase "15-October-1583 - 1Y == 15-October-1582" $ modify (subtract 1) year <$> calendarDate 15 October 1583 @?= firstValidDate+    ,testCase "14-October-1583 - 1Y == 15-October-1582 (clamped)" $ modify (subtract 1) year <$> calendarDate 14 October 1583 @?= firstValidDate     ,testCase "31-December-2000 + 1D == 1-January-2001" $ modify (+1) day <$> endYear @?= calendarDate 1 January 2001+    ,testCase "16-October-1583 - 1D == 15-October-1582" $ modify (subtract 1) day <$> calendarDate 16 October 1582 @?= firstValidDate+    ,testCase "15-October-1583 - 1D == 15-October-1582 (clamped)" $ modify (subtract 1) day <$> calendarDate 15 October 1582 @?= firstValidDate   ]     where       janEnd = calendarDate 31 January 2000       leapFeb = calendarDate 29 February 2000       endYear = calendarDate 31 December 2000+      firstValidDate = calendarDate 15 October 1582

@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}- module HodaTime.CalendarDateTimeTest (   calendarDateTimeTests@@ -13,8 +11,8 @@  import HodaTime.Util import Data.HodaTime.LocalTime (localTime, HasLocalTime(..))-import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek)-import Data.HodaTime.Calendar.Gregorian (calendarDate, Month(..), DayOfWeek(..), Gregorian)+import Data.HodaTime.CalendarDate (day, monthl, next, previous, dayOfWeek)+import Data.HodaTime.Calendar.Gregorian (calendarDate, Month(..)) import Data.HodaTime.CalendarDateTime (on, at)  calendarDateTimeTests :: TestTree@@ -45,18 +43,8 @@     _1 f (a,b,c) = (\a' -> (a',b,c)) <$> f a     _2 f (a,b,c) = (\b' -> (a,b',c)) <$> f b     _3 f (a,b,c) = (\c' -> (a,b,c')) <$> f c-    testGet l l' (Positive s, Positive m, Positive h) = h < 23 && s < 60 && m < 60 QC.==> get l (mkTime h m s) == get l' (s, m, h)-    testF f l l' g n (Positive s, Positive m, Positive h) = h < 23 - n && s < 60 - n && m < 60 - n QC.==> offsetEq (modify (g n) l' (s,m,h)) $ f n l (mkTime h m s)--instance Arbitrary (Month Gregorian) where-  arbitrary = do-    x <- choose (0,11)-    return $ toEnum x--instance Arbitrary (DayOfWeek Gregorian) where-  arbitrary = do-    x <- choose (0,6)-    return $ toEnum x+    testGet l l' (RandomTime h m s) = get l (mkTime h m s) == get l' (s, m, h)+    testF f l l' g n (RandomTime h m s) = h < 23 - n && s < 60 - n && m < 60 - n QC.==> offsetEq (modify (g n) l' (s,m,h)) $ f n l (mkTime h m s)  dateLensProps :: TestTree dateLensProps = testGroup "Date Lens"@@ -69,7 +57,7 @@   ]     where       mkcd d m y = fromJust $ on <$> localTime 10 10 10 0 <*> calendarDate d m y-      testMonthAdd d (Positive y) m add = y < 400 QC.==> get day (modify (+ add) monthl $ mkcd d m (y + 1900)) == d  -- NOTE: We fix the year so we don't run out of tests+      testMonthAdd d (CycleYear y) m add = get day (modify (+ add) monthl $ mkcd d m (y + 1900)) == d  -- NOTE: We fix the year so we don't run out of tests       testNextDoW dow (Positive n) = (dayOfWeek . next n dow $ epochDay) == dow       testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == modify (adjust $ n * 7) day epochDay       epochDay = mkcd 1 March 2000

@@ -7,11 +7,14 @@ import Test.Tasty import Test.Tasty.HUnit -import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch, fromInstant)+import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch)+import Data.HodaTime.TimeZone (utc)+import Data.HodaTime.ZonedDateTime (fromInstant, toLocalTime, ZonedDateTime)+import Data.HodaTime.Calendar.Gregorian (Gregorian) import Data.HodaTime.LocalTime (HasLocalTime(..))-import Control.Applicative (Const(..)) import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime) import Data.Time.LocalTime (todHour, todMin, todSec, hoursToTimeZone, utcToLocalTime, LocalTime(..))+import HodaTime.Util (get)  instantTests :: TestTree instantTests = testGroup "Instant Tests" [unitTests]@@ -22,14 +25,20 @@      testCase "test_fromSecondsSinceUnixEpoch" test_fromSecondsSinceUnixEpoch   ] +-- TODO: Make sure round-tripping Instant->ZoneDateTime->Instant ends up with the same number.  If it doesn't, it's a problem with leap seconds+ test_fromSecondsSinceUnixEpoch :: Assertion  -- TODO: this is temporary until we get the required infrastructure in place to properly test Instants (we can't now because there is no legal conversion, only the internal fromInstant function) test_fromSecondsSinceUnixEpoch = do   posT <- getPOSIXTime-  let secs = round posT-      lt = fromInstant . fromSecondsSinceUnixEpoch $ secs-      utc = posixSecondsToUTCTime posT-      (LocalTime _ tod) = utcToLocalTime (hoursToTimeZone 0) utc-      get l = getConst . l Const-  assertEqual "hours: " (get hour lt) (todHour tod)-  assertEqual "minutes: " (get minute lt) (todMin tod)-  assertEqual "seconds: " (get second lt) (round . todSec $ tod)+  tz <- utc+  let+    secs = round posT+    zdt :: ZonedDateTime Gregorian+    zdt = flip fromInstant tz . fromSecondsSinceUnixEpoch $ secs+    lt = toLocalTime zdt+    utcT = posixSecondsToUTCTime posT+    (LocalTime _ tod) = utcToLocalTime (hoursToTimeZone 0) utcT+    todT = (todHour tod, todMin tod, round . todSec $ tod)+    t = (get hour lt, get minute lt, get second lt)+    str = "time(" ++ show secs ++ "): "+  assertEqual str todT t

@@ -42,8 +42,8 @@     _1 f (a,b,c) = (\a' -> (a',b,c)) <$> f a     _2 f (a,b,c) = (\b' -> (a,b',c)) <$> f b     _3 f (a,b,c) = (\c' -> (a,b,c')) <$> f c-    testGet l l' (Positive s, Positive m, Positive h) = h < 23 && s < 60 && m < 60 QC.==> get l (mkTime h m s) == get l' (s, m, h)-    testF f l l' g n (Positive s, Positive m, Positive h) = h < 23 - n && s < 60 - n && m < 60 - n QC.==> offsetEq (modify (g n) l' (s,m,h)) $ f n l (mkTime h m s)+    testGet l l' (RandomTime h m s) = get l (mkTime h m s) == get l' (s, m, h)+    testF f l l' g n (RandomTime h m s) = h < 23 - n && s < 60 - n && m < 60 - n QC.==> offsetEq (modify (g n) l' (s,m,h)) $ f n l (mkTime h m s)  rolloverUnits :: TestTree rolloverUnits = testGroup "Rollover"

@@ -5,10 +5,10 @@ where  import Test.Tasty-import Test.Tasty.SmallCheck as SC+import qualified Test.Tasty.SmallCheck as SC import Test.Tasty.QuickCheck as QC import Test.Tasty.HUnit-+import HodaTime.Util import Data.HodaTime.Offset import Control.Applicative (Const(..)) import Data.Functor.Identity (Identity(..))@@ -32,10 +32,10 @@ -- properties  mathPropSC :: TestTree-mathPropSC = localOption (SmallCheckDepth 18) $ testGroup "Math"  -- NOTE: Max offset size is 18/-18 so we set the depth to make sure everything in that range is tested+mathPropSC = localOption (SC.SmallCheckDepth 18) $ testGroup "Math"  -- NOTE: Max offset size is 18/-18 so we set the depth to make sure everything in that range is tested   [-     SC.testProperty "fromHours x `add` fromHours y == fromHours (x+y)" $ test fromHours add (+)-    ,SC.testProperty "fromHours x `minus` fromHours y == fromHours (x-y)" $ test fromHours minus (-)+     SC.testProperty "fromHours x `addClamped` fromHours y == fromHours (x+y)" $ test fromHours addClamped (+)+    ,SC.testProperty "fromHours x `minusClamped` fromHours y == fromHours (x-y)" $ test fromHours minusClamped (-)   ]  secondProps :: TestTree@@ -52,10 +52,10 @@ mathProps :: TestTree mathProps = testGroup "Math"   [-     QC.testProperty "fromSeconds x `add` fromSeconds y == fromSeconds (x+y)" $ test fromSeconds add (+)-    ,QC.testProperty "fromSeconds x `minus` fromSeconds y == fromSeconds (x-y)" $ test fromSeconds minus (-)-    ,QC.testProperty "fromMinutes x `add` fromMinutes y == fromMinutes (x+y)" $ test fromMinutes add (+)-    ,QC.testProperty "fromMinutes x `minus` fromMinutes y == fromMinutes (x-y)" $ test fromMinutes minus (-)+     QC.testProperty "fromSeconds x `addClamped` fromSeconds y == fromSeconds (x+y)" $ test fromSeconds addClamped (+)+    ,QC.testProperty "fromSeconds x `minusClamped` fromSeconds y == fromSeconds (x-y)" $ test fromSeconds minusClamped (-)+    ,QC.testProperty "fromMinutes x `addClamped` fromMinutes y == fromMinutes (x+y)" $ test fromMinutes addClamped (+)+    ,QC.testProperty "fromMinutes x `minusClamped` fromMinutes y == fromMinutes (x-y)" $ test fromMinutes minusClamped (-)   ]  lensProps :: TestTree@@ -67,22 +67,19 @@     ,QC.testProperty "modify seconds offset" $ testF (modify . (+)) seconds _1 (+) 5     ,QC.testProperty "modify minutes offset" $ testF (modify . (+)) minutes _2 (+) 5     ,QC.testProperty "modify hours offset" $ testF (modify . (+)) hours _3 (+) 5-    ,QC.testProperty "set seconds offset" $ testF setL seconds _1 const 5-    ,QC.testProperty "set minutes offset" $ testF setL minutes _2 const 5-    ,QC.testProperty "set hours offset" $ testF setL hours _3 const 5+    ,QC.testProperty "set seconds offset" $ testF set seconds _1 const 5+    ,QC.testProperty "set minutes offset" $ testF set minutes _2 const 5+    ,QC.testProperty "set hours offset" $ testF set hours _3 const 5   ]   where     offset :: Int -> Int -> Int -> Offset   -- Only needed so the compiler can decide which concreate type to use-    offset s m h = fromSeconds s `add` fromMinutes m `add` fromHours h+    offset s m h = fromSeconds s `addClamped` fromMinutes m `addClamped` fromHours h     offsetEq (s, m, h) off = get seconds off == s && get minutes off == m && get hours off == h     _1 f (a,b,c) = (\a' -> (a',b,c)) <$> f a     _2 f (a,b,c) = (\b' -> (a,b',c)) <$> f b     _3 f (a,b,c) = (\c' -> (a,b,c')) <$> f c-    get l = getConst . l Const-    modify f l = runIdentity . l (Identity . f)-    setL v = modify (const v)-    testGet l l' (Positive s, Positive m, Positive h) = h < 18 && s < 60 && m < 60 QC.==> get l (offset s m h) == get l' (s, m, h)      -- TODO: Why no negative?-    testF f l l' g n (Positive s, Positive m, Positive h) = h < 18 - n && s < 60 - n && m < 60 - n QC.==> offsetEq (modify (g n) l' (s,m,h)) $ f n l (offset s m h)+    testGet l l' (RandomOffset h m s) = get l (offset s m h) == get l' (s, m, h)+    testF f l l' g n (RandomOffset h m s) = h < 18 - n && s < 60 - n && m < 60 - n QC.==> offsetEq (modify (g n) l' (s,m,h)) $ f n l (offset s m h)  -- helper functions 

@@ -1,13 +1,79 @@+{-# LANGUAGE FlexibleInstances #-} module HodaTime.Util (-   get+   RandomOffset(..)+  ,RandomTime(..)+  ,CycleYear(..)+  ,RandomStandardDate(..)+  ,get   ,modify   ,set ) where +import Test.Tasty.QuickCheck (Arbitrary(..), choose)+ import Control.Applicative (Const(..)) import Data.Functor.Identity (Identity(..))++import Data.HodaTime.Calendar.Gregorian (Month(..), DayOfWeek(..), Gregorian)++-- arbitrary data and instances++instance Arbitrary (Month Gregorian) where+  arbitrary = do+    x <- choose (0,11)+    return $ toEnum x++instance Arbitrary (DayOfWeek Gregorian) where+  arbitrary = do+    x <- choose (0,6)+    return $ toEnum x++data RandomOffset = RandomOffset Int Int Int+  deriving (Show)++instance Arbitrary RandomOffset where+  arbitrary = do+    h <- choose (-17,17)+    m <- choose (0,59)+    s <- choose (0,59)+    which <- choose (1,100)+    return (chosen which $ RandomOffset h m s)+      where+        chosen :: Int -> RandomOffset -> RandomOffset+        chosen n ro+          | n > 98     = RandomOffset 18 0 0+          | n > 96    = RandomOffset (-18) 0 0+          | otherwise = ro++data RandomTime = RandomTime Int Int Int+  deriving (Show)++instance Arbitrary RandomTime where+  arbitrary = do+    h <- choose (0,23)+    m <- choose (0,59)+    s <- choose (0,59)+    return $ RandomTime h m s++newtype CycleYear = CycleYear Int+  deriving (Show)++instance Arbitrary CycleYear where+  arbitrary = do+    y <- choose (0,399)+    return $ CycleYear y++data RandomStandardDate = RandomStandardDate Int Int Int+  deriving (Show)++instance Arbitrary RandomStandardDate where+  arbitrary = do+    y <- choose (1972,2040)+    m <- choose (0,11)+    d <- choose (1,28)+    return $ RandomStandardDate y m d  -- Lenses 

@@ -0,0 +1,113 @@+module HodaTime.ZonedDateTimeTest+(+  zonedDateTimeTests+)+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.QuickCheck.Monadic (monadicIO, run)+import qualified Test.QuickCheck.Monadic as QCM+import Test.Tasty.HUnit+import Control.Monad (join)+import qualified System.Info as SysInfo+import Data.Maybe (catMaybes)++import HodaTime.Util+import Data.HodaTime.ZonedDateTime (fromCalendarDateTimeStrictly, fromCalendarDateTimeLeniently, fromCalendarDateTimeAll, toCalendarDateTime, zoneAbbreviation, ZonedDateTime) -- remove ZonedDateTime+import Data.HodaTime.TimeZone (timeZone)+import Data.HodaTime.Calendar.Gregorian (Month(..))+import qualified Data.HodaTime.Calendar.Gregorian as G+import Data.HodaTime.LocalTime (localTime)+import Data.HodaTime.CalendarDateTime (at)++zonedDateTimeTests :: TestTree+zonedDateTimeTests = testGroup "ZonedDateTime Tests" [qcProps, unitTests]++-- top level tests++qcProps :: TestTree+qcProps = testGroup "(checked by QuickCheck)" [calDateProps]++unitTests :: TestTree+unitTests = testGroup "Unit tests"+  [+    lenientZoneTransitionUnits, allZoneTransitionUnits+  ]++-- properties++calDateProps :: TestTree+calDateProps = testGroup "CalendarDateTime conversion"+  [+     QC.testProperty "CalendarDateTime -> ZonedDateTime -> CalendarDateTime == id" $ testCalToZonedIdentity "UTC"+  ]+  where+    testCalToZonedIdentity zone (RandomStandardDate y mon d) (RandomTime h m s) = monadicIO $ do+      tz <- run (timeZone zone)+      let cdt = at <$> G.calendarDate d (toEnum mon) y <*> localTime h m s 0+      let zdt = join $ flip fromCalendarDateTimeStrictly tz <$> cdt+      let cdt' = toCalendarDateTime <$> zdt+      QCM.assert $ cdt == cdt'++lenientZoneTransitionUnits :: TestTree+lenientZoneTransitionUnits = testGroup "fromCalendarDateTimeLeniently"+  [+     testCase "March 26 2017 2:10:15.30 -> March 26 2017 3:10:15.30 CEST" $ ensureHour startZone resultZone 26 March 2017 3+    ,testCase "October 29 2017 2:10:15.30 -> October 29 2017 2:10:15.30 CEST" $ ensureHour startZone resultZone 29 October 2017 2+    ,testCase "March 27 2039 2:10:15.30 -> March 27 2039 3:10:15.30 CEST" $ ensureHour startZone resultZone 27 March 2039 3+    ,testCase "October 30 2039 2:10:15.30 -> October 30 2039 2:10:15.30 CEST" $ ensureHour startZone resultZone 30 October 2039 2+  ]+  where+    startZone = if SysInfo.os == "mingw32" then "W. Europe Standard Time" else "Europe/Zurich"+    resultZone = if SysInfo.os == "mingw32" then "W. Europe Summer Time" else "CEST"+    toLocalTime h = localTime h 10 15 30+    mkDate zone d m y = do+      tz <- timeZone zone+      let cdt = at <$> G.calendarDate d m y <*> toLocalTime 2+      return $ flip fromCalendarDateTimeLeniently tz <$> cdt+    ensureHour zone expectedAbbr d m y h = do+      zdt <- mkDate zone d m y+      let abbr = maybe "<INVALID>" zoneAbbreviation zdt+      let cdt = toCalendarDateTime <$> zdt+      let cdtExpected = at <$> G.calendarDate d m y <*> toLocalTime h+      assertEqual "Zone abbreviation" expectedAbbr abbr+      assertEqual "" cdtExpected cdt++allZoneTransitionUnits :: TestTree+allZoneTransitionUnits = testGroup "fromCalendarDateTimeAll"+  [+     testCase "March 26 2017 2:10:15.30 -> []" $ ensureHours startEuZone [] 26 March 2017 []+    ,testCase "October 29 2017 2:10:15.30 -> [October 29 2017: 2:10:15.30 CEST, 2:10:15.30 CET]" $ ensureHours startEuZone [summerEuZone, normEuZone] 29 October 2017 [2,2]+    ,testCase "March 27 2039 2:10:15.30 -> []" $ ensureHours startEuZone [] 27 March 2039 []+    ,testCase "October 30 2039 2:10:15.30 -> [October 30 2039: 2:10:15.30 CEST, 2:10:15.30 CET]" $ ensureHours startEuZone [summerEuZone, normEuZone] 30 October 2039 [2,2]++    ,testCase "April 3 2005 2:10:15.30 -> []" $ ensureHours startUsZone [] 3 April 2005 []+    ,testCase "October 30 2005 1:10:15.30 -> [October 30 2005: 1:10:15.30 CDT, 1:10:15.30 CST]" $ ensureHours' 1 startUsZone [summerUsZone, normUsZone] 30 October 2005 [1,1]+    ,testCase "April 2 2006 2:10:15.30 -> []" $ ensureHours startUsZone [] 2 April 2006 []+    ,testCase "October 29 2006 1:10:15.30 -> [October 29 2006: 1:10:15.30 CDT, 1:10:15.30 CST]" $ ensureHours' 1 startUsZone [summerUsZone, normUsZone] 29 October 2006 [1,1]+    ,testCase "March 11 2007 2:10:15.30 -> []" $ ensureHours startUsZone [] 11 March 2007 []+    ,testCase "November 4 2007 1:10:15.30 -> [November 4 2007: 1:10:15.30 CDT, 1:10:15.30 CST]" $ ensureHours' 1 startUsZone [summerUsZone, normUsZone] 4 November 2007 [1,1]+    ,testCase "March 9 2008 2:10:15.30 -> []" $ ensureHours startUsZone [] 9 March 2008 []+    ,testCase "November 2 2008 1:10:15.30 -> [November 2 2008: 1:10:15.30 CDT, 1:10:15.30 CST]" $ ensureHours' 1 startUsZone [summerUsZone, normUsZone] 2 November 2008 [1,1]+  ]+  where+    startEuZone = if SysInfo.os == "mingw32" then "W. Europe Standard Time" else "Europe/Zurich"+    startUsZone = if SysInfo.os == "mingw32" then "Central Standard Time" else "US/Central"+    normEuZone = if SysInfo.os == "mingw32" then "W. Europe Standard Time" else "CET"+    normUsZone = if SysInfo.os == "mingw32" then "Central Standard Time" else "CST"+    summerEuZone = if SysInfo.os == "mingw32" then "W. Europe Summer Time" else "CEST"+    summerUsZone = if SysInfo.os == "mingw32" then "Central Summer Time" else "CDT"+    toLocalTime h = localTime h 10 15 30+    mkDates h zone d m y = do+      tz <- timeZone zone+      let cdt = at <$> G.calendarDate d m y <*> toLocalTime h+      return $ flip fromCalendarDateTimeAll tz <$> cdt+    ensureHours zone expectedAbbrs d m y hs = ensureHours' 2 zone expectedAbbrs d m y hs+    ensureHours' hour zone expectedAbbrs d m y hs = do+      zdts <- mkDates hour zone d m y+      let abbrs = maybe [] (zoneAbbreviation <$>) zdts+      let cdts = maybe [] (toCalendarDateTime <$>) zdts+      let cdtExpecteds = catMaybes $ (\x -> at <$> G.calendarDate d m y <*> toLocalTime x) <$> hs+      assertEqual "Zone abbreviation" expectedAbbrs abbrs+      assertEqual "" cdtExpecteds cdts

@@ -6,12 +6,13 @@ import HodaTime.LocalTimeTest import HodaTime.Calendar.GregorianTest import HodaTime.CalendarDateTimeTest+import HodaTime.ZonedDateTimeTest  main :: IO () main = defaultMain tests  tests :: TestTree-tests = testGroup "Tests" [instantTests, durationTests, offsetTests, localTimeTests, gregorianTests, calendarDateTimeTests]+tests = testGroup "Tests" [instantTests, durationTests, offsetTests, localTimeTests, gregorianTests, calendarDateTimeTests, zonedDateTimeTests]  {- unitTests :: TestTree