git.iko.soy/typeable/extra-time
on master help sign in
8 files changed+170−86
since splitsnapshots
unifiedsplit
extra-time.cabal+42−39 src/Data/Time/Extra.hs+7 src/Data/Time/FastSeries.hs+85 src/Data/Time/Holidays.hs+1−1 src/Data/Time/LocalTime/Instances.hs−39 src/Data/Time/LocalTime/Short.hs+1−1 src/Data/Time/Utils.hs+6−6 src/Holidays/EDay.hs+28
extra-time.cabal+42−39
@@ -1,64 +1,67 @@
1−cabal-version: 2.4
2−
3−name: extra-time
4−version: 0.0.0.0
5−license-file: LICENSE
6−author: typeable.io
7−maintainer: giorgio@marinel.li
8−build-type: Simple
9−extra-source-files: README.md, data/opm-holidays.csv
1+cabal-version: 2.4
2+name: extra-time
3+version: 0.0.0.0
4+license-file: LICENSE
5+author: typeable.io
6+maintainer: giorgio@marinel.li
7+build-type: Simple
8+extra-source-files:
9+ data/opm-holidays.csv
10+ README.md
1011
1112library
1213 hs-source-dirs: src
1314 default-language: Haskell2010
1415 default-extensions:
16+ BangPatterns
1517 DataKinds
1618 DeriveFunctor
1719 DeriveGeneric
1820 DerivingStrategies
1921 GeneralizedNewtypeDeriving
20− ImportQualifiedPost
2122 KindSignatures
23+ NamedFieldPuns
2224 OverloadedStrings
2325 RankNTypes
2426 ScopedTypeVariables
2527 StandaloneDeriving
2628 TemplateHaskell
2729 TypeApplications
30+
2831 build-depends:
29− -- | from ghc
30− base >= 4.7 && < 5 ,
31− binary ,
32− bytestring ,
33− containers ,
34− cassava ,
35− cassava-embed ,
36− file-embed ,
37− deepseq ,
38− mtl >= 2.2 ,
39− template-haskell ,
40− text ,
41− th-lift ,
42− time,
43− -- | from hackage
44− aeson ,
45− generic-arbitrary ,
46− http-api-data ,
47− lens >= 4.17 ,
48− QuickCheck ,
49− quickcheck-instances ,
50− timezone-series ,
51− vector ,
52− if !impl(ghcjs)
32+ , aeson
33+ , base >=4.11 && <5
34+ , binary
35+ , binary-instances
36+ , bytestring
37+ , cassava
38+ , cassava-embed
39+ , containers >=0.5.8
40+ , deepseq
41+ , file-embed >=0.0.10
42+ , generic-arbitrary
43+ , http-api-data
44+ , lens >=4.17
45+ , mtl >=2.2
46+ , QuickCheck
47+ , quickcheck-instances
48+ , text
49+ , th-lift
50+ , time >=1.6
51+ , timezone-series
52+ , vector
53+
54+ if !(impl(ghcjs) || arch(javascript) || arch(wasm32))
5355 build-depends:
54− dom-parser ,
55− xml-conduit-writer ,
56+ , dom-parser >=2.0
57+ , xml-conduit-writer
58+
5659 exposed-modules:
5760 Data.Time.Extra
61+ Data.Time.FastSeries
5862 Data.Time.Fmt
5963 Data.Time.Holidays
6064 Data.Time.LocalTime.Short
6165 Data.Time.Utils
62− other-modules:
63− Data.Time.LocalTime.Instances
64− Holidays.EDay
66+
67+ other-modules: Holidays.EDay
src/Data/Time/Extra.hs+7
@@ -4,6 +4,7 @@ module Data.Time.Extra
44 , _Minutes
55 , duration
66 , durationLocal
7+ , durationUTC
78 , minutesToNDF
89 , UTCDate(..)
910 , _UTCDate
@@ -84,6 +85,12 @@ durationLocal t1 t2 = Minutes (timeDiff `div` 60)
8485 calcDiff = diffUTCTime `on` localTimeToUTC utc
8586 timeDiff = round (calcDiff t1 t2)
8687
88+durationUTC :: UTCTime -> UTCTime -> Minutes
89+durationUTC t1 t2 = Minutes (timeDiff `div` 60)
90+ where
91+ calcDiff = diffUTCTime
92+ timeDiff = round (calcDiff t1 t2)
93+
8794minutesToNDF :: Minutes -> NominalDiffTime
8895minutesToNDF (Minutes mins) = 60 * realToFrac mins
8996
src/Data/Time/FastSeries.hsnew file+85
@@ -0,0 +1,85 @@
1+module Data.Time.FastSeries
2+ ( TimeZoneSeries
3+ , toTimeZoneSeries
4+ , fromTimeZoneSeries
5+ , timeZoneFromSeries
6+ , timeZoneFromSeriesLocal
7+ , utcToLocalTime'
8+ , localTimeToUTC'
9+ ) where
10+
11+import Data.Map.Strict (Map)
12+import qualified Data.Map as Map
13+import Data.Time
14+import qualified Data.Time.LocalTime.TimeZone.Series as Series
15+
16+
17+-- | Contains the same data as 'Series.TimeZoneSeries' but precomputes some data
18+-- for faster conversion.
19+data TimeZoneSeries = TimeZoneSeries
20+ { fallback :: !TimeZone
21+ , transitionsUTC :: !(Map UTCTime TimeZone)
22+ -- ^ UTC -> Local wants to know the last transition that happened before a
23+ -- given 'UTCTime'
24+ , transitionsLocal :: !(Map LocalTime TimeZone)
25+ -- ^ Local -> UTC wants to know the largest transition @t@ into timezone
26+ -- @tz@ such that @t <= localTimeToUTC tz lt@ where @lt@ is a given
27+ -- 'LocalTime'. For a given TZ and valid time arguments, 'localTimeToUTC'
28+ -- and 'utcToLocalTime' are inverses. Hence this is equivalent to
29+ -- @utcToLocalTime t tz <= lt@.
30+ }
31+
32+toTimeZoneSeries :: Series.TimeZoneSeries -> TimeZoneSeries
33+toTimeZoneSeries
34+ Series.TimeZoneSeries { Series.tzsTimeZone, Series.tzsTransitions }
35+ = TimeZoneSeries
36+ { fallback = tzsTimeZone
37+ , transitionsUTC = Map.fromDescList tzsTransitions
38+ , transitionsLocal = Map.fromList
39+ [(utcToLocalTime tz u, tz) | (u, tz) <- tzsTransitions]
40+ }
41+
42+fromTimeZoneSeries :: TimeZoneSeries -> Series.TimeZoneSeries
43+fromTimeZoneSeries TimeZoneSeries { fallback, transitionsUTC }
44+ = Series.TimeZoneSeries
45+ { Series.tzsTimeZone = fallback
46+ , Series.tzsTransitions = Map.toList transitionsUTC
47+ }
48+
49+timeZoneFromSeries :: TimeZoneSeries -> UTCTime -> TimeZone
50+timeZoneFromSeries TimeZoneSeries { fallback, transitionsUTC } t
51+ = maybe fallback snd $ Map.lookupLE t transitionsUTC
52+
53+-- | See caveat on 'localTimeToUTC''.
54+timeZoneFromSeriesLocal :: TimeZoneSeries -> LocalTime -> TimeZone
55+timeZoneFromSeriesLocal TimeZoneSeries { fallback, transitionsLocal } lt
56+ = maybe fallback snd $ Map.lookupLE lt transitionsLocal
57+
58+utcToLocalTime' :: TimeZoneSeries -> UTCTime -> LocalTime
59+utcToLocalTime' tzsf t = utcToLocalTime tz t
60+ where !tz = timeZoneFromSeries tzsf t
61+
62+-- | This conversion is not actually always well defined.
63+--
64+-- At the moment of switching to summer time, there is a range of 'LocalTime's
65+-- that are skipped. For these, 'Series.isValidLocalTime' returns 'False'. This
66+-- function converts them to 'UTCTime' as if the switch didn't happen.
67+--
68+-- Around the moment of switching away from summer time, there is a range of
69+-- 'LocalTime's that happen twice: first before the switch, then once again
70+-- after the switch. For these, 'Series.isRedundantLocalTime' returns 'True'.
71+-- In such ambiguous cases, this function always picks the occurrence after the
72+-- switch.
73+--
74+-- The handling of these corner cases matches exactly to that of
75+-- 'Series.localTimeToUTC''
76+--
77+-- This means the equation
78+-- @lt == utcToLocalTime' tzsf (localTimeToUTC' tzsf lt)@ does not hold for @lt@
79+-- that were skipped. And the equation
80+-- @t == localTimeToUTC' tzsf (utcToLocalTime' tzsf t)@ does not hold for @t@
81+-- that come just before switching awya from summer time. For other arguments
82+-- these equations are assumed to hold.
83+localTimeToUTC' :: TimeZoneSeries -> LocalTime -> UTCTime
84+localTimeToUTC' tzsf lt = localTimeToUTC tz lt
85+ where !tz = timeZoneFromSeriesLocal tzsf lt
src/Data/Time/Holidays.hs+1−1
@@ -7,7 +7,7 @@ import Data.Proxy
77import qualified Data.Set as S
88import Data.Time
99import Data.Time.Calendar.OrdinalDate
10−import Data.Time.LocalTime.TimeZone.Series
10+import Data.Time.FastSeries
1111import Data.FileEmbed (makeRelativeToProject)
1212import Data.Csv.Embed (embedRecords)
1313import Holidays.EDay (eDayToDay, EDay)
src/Data/Time/LocalTime/Instances.hsdeleted−39
@@ -1,39 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2−
3−module Data.Time.LocalTime.Instances where
4−
5−import Data.Binary (Binary(..))
6−import Data.Fixed (Fixed(..))
7−import Data.Time
8−import GHC.Generics (Generic)
9−
10−
11−deriving instance Generic TimeZone
12−
13−instance Binary TimeZone
14−
15−deriving instance Generic Day
16−
17−instance Binary Day
18−
19−deriving instance Generic (Fixed a)
20−
21−deriving instance Generic TimeOfDay
22−
23−instance Binary TimeOfDay
24−
25−deriving instance Generic LocalTime
26−
27−instance Binary LocalTime
28−
29−deriving instance Generic ZonedTime
30−
31−instance Binary ZonedTime
32−
33−instance Binary DiffTime where
34− put = put . toRational
35− get = fromRational <$> get
36−
37−deriving instance Generic UTCTime
38−
39−instance Binary UTCTime
src/Data/Time/LocalTime/Short.hs+1−1
@@ -21,11 +21,11 @@ import Control.Lens
2121import Control.Monad.State
2222import Data.Aeson
2323import Data.Binary (Binary)
24+import Data.Binary.Instances.Time ()
2425import Data.Coerce
2526import Data.Ord (comparing)
2627import Data.Time as T
2728import Data.Time.Fmt
28−import Data.Time.LocalTime.Instances ()
2929import Data.Time.Utils
3030import GHC.Generics (Generic)
3131import Test.QuickCheck (Arbitrary)
src/Data/Time/Utils.hs+6−6
@@ -13,7 +13,7 @@ module Data.Time.Utils
1313
1414import Control.Lens
1515import Data.Time
16−import Data.Time.LocalTime.TimeZone.Series
16+import Data.Time.FastSeries
1717
1818
1919the24h :: NominalDiffTime
@@ -25,15 +25,15 @@ oneHour = 60 * 60
2525oneMinute :: NominalDiffTime
2626oneMinute = 60
2727
28−-- | Calculate TimeZone using TimeZoneSeries and construct ZonedTime
28+-- | Calculate 'TimeZone' using 'TimeZoneSeries' and construct 'ZonedTime'.
29+--
30+-- See caveats on 'localTimeToUTC''.
2931zoneLocalTime
3032 :: TimeZoneSeries
3133 -> LocalTime
3234 -> ZonedTime
33−zoneLocalTime tzs lt = let
34− u = localTimeToUTC' tzs lt
35− tz = timeZoneFromSeries tzs u
36− in ZonedTime lt tz
35+zoneLocalTime tzsf lt = ZonedTime lt tz
36+ where !tz = timeZoneFromSeriesLocal tzsf lt
3737
3838makeLensesFor
3939 [("zonedTimeToLocalTime", "_zonedTimeToLocalTime")] ''ZonedTime
src/Holidays/EDay.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# OPTIONS -Wno-orphans #-}
2+{-# LANGUAGE DeriveLift #-}
3+
4+module Holidays.EDay (EDay, eDayToDay) where
5+
6+import Data.ByteString.Char8
7+import Data.Csv
8+import Data.Time
9+import Data.Time.Calendar.OrdinalDate
10+import qualified Data.Vector as V
11+import Language.Haskell.TH.Lift
12+
13+data EDay = EDay {edYear :: Integer, edDay :: Int}
14+ deriving stock (Eq,Ord,Show,Lift)
15+
16+eDayToDay :: EDay -> Day
17+eDayToDay (EDay y d) = fromOrdinalDate y d
18+
19+instance FromField EDay where
20+ parseField f = mkEDay <$> parseTimeM False defaultTimeLocale (iso8601DateFormat Nothing) (unpack f)
21+ where mkEDay d = let (theYear,theDay) = toOrdinalDate d in EDay theYear theDay
22+
23+instance FromRecord EDay where
24+ parseRecord v
25+ | n == 1 = unsafeIndex v 0
26+ | otherwise = fail "Expected single field for a day"
27+ where
28+ n = V.length v