git.iko.soy/typeable/extra-time
on master help sign in
Create air-domain package with air travel data types (#4757)
ce18945Giorgio Marinelli
LICENSEnew file+1
compare with master
unifiedsplit
@@ -0,0 +1 @@
1+Copyright © 2020, Antorica LLC
README.mdnew file+1
@@ -0,0 +1 @@
1+# extra-time
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
extra-time.cabalnew file+52
@@ -0,0 +1,52 @@
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
10+
11+library
12+ hs-source-dirs: src
13+ default-language: Haskell2010
14+ default-extensions:
15+ DataKinds
16+ DeriveFunctor
17+ DeriveGeneric
18+ GeneralizedNewtypeDeriving
19+ KindSignatures
20+ OverloadedStrings
21+ RankNTypes
22+ ScopedTypeVariables
23+ StandaloneDeriving
24+ TemplateHaskell
25+ TypeApplications
26+ build-depends:
27+ -- | from ghc
28+ base >= 4.7 && < 5 ,
29+ binary ,
30+ deepseq ,
31+ mtl >= 2.2 ,
32+ text ,
33+ time ,
34+ -- | from hackage
35+ aeson ,
36+ dom-parser ,
37+ generic-arbitrary ,
38+ http-api-data ,
39+ lens >= 4.17 ,
40+ QuickCheck ,
41+ quickcheck-instances ,
42+ timezone-series ,
43+ xml-conduit-writer ,
44+ -- | internal packages
45+ missing-lens ,
46+ exposed-modules:
47+ Data.Time.Extra
48+ Data.Time.Fmt
49+ Data.Time.LocalTime.Short
50+ Data.Time.Utils
51+ other-modules:
52+ Data.Time.LocalTime.Instances
src/Data/Time/Extra.hsnew file+207
@@ -0,0 +1,207 @@
1+module Data.Time.Extra
2+ ( Minutes(..)
3+ , _Minutes
4+ , duration
5+ , durationLocal
6+ , minutesToNDF
7+ , UTCDate(..)
8+ , _UTCDate
9+ , UTCTime'(..)
10+ , _UTCTime'
11+ , mskTimeZone
12+ , toAPITimeMSK
13+ , apiDate
14+ , module Data.Time.LocalTime.Short
15+ , TimeFrame
16+ , mkTimeFrame
17+ , tfFrom
18+ , tfTo
19+ , tfType
20+ , TimeFrameType(..)
21+ , Hours(..)
22+ , _Hours
23+ , DateRange(..)
24+ , mkDateRange
25+ , drFromDate
26+ , drToDate
27+ , module Data.Time.Utils
28+ ) where
29+
30+import Control.DeepSeq
31+import Control.Lens
32+import Control.Monad
33+import Control.Monad.Fail
34+import Data.Aeson
35+import Data.Binary
36+import Data.Function (on)
37+import qualified Data.Text as T
38+import Data.Time
39+import Data.Time.LocalTime.Short
40+import Data.Time.Utils
41+import GHC.Generics (Generic)
42+import Test.QuickCheck
43+import Test.QuickCheck.Arbitrary.Generic
44+
45+
46+newtype Minutes
47+ = Minutes { unMinutes :: Int
48+ } deriving (Show, Eq, Ord, Arbitrary, Generic, FromJSON, ToJSON)
49+
50+instance NFData Minutes
51+
52+makePrisms ''Minutes
53+
54+newtype Hours
55+ = Hours { unHours :: Int
56+ } deriving (Show, Eq, Ord, Arbitrary, Generic, FromJSON, ToJSON)
57+
58+instance NFData Hours
59+
60+makePrisms ''Hours
61+
62+duration :: ShortZonedTime -> ShortZonedTime -> Minutes
63+duration t1 t2 = Minutes (timeDiff `div` 60)
64+ where
65+ calcDiff = diffUTCTime `on` zonedTimeToUTC . unShortZonedTime
66+ timeDiff = round (calcDiff t1 t2)
67+
68+durationLocal :: LocalTime -> LocalTime -> Minutes
69+durationLocal t1 t2 = Minutes (timeDiff `div` 60)
70+ where
71+ calcDiff = diffUTCTime `on` localTimeToUTC utc
72+ timeDiff = round (calcDiff t1 t2)
73+
74+minutesToNDF :: Minutes -> NominalDiffTime
75+minutesToNDF (Minutes mins) = 60 * realToFrac mins
76+
77+-- UTCTime with lexically correct show instance.
78+-- Motivation: using ppShow.
79+newtype UTCTime' = UTCTime' { unUTCTime' :: UTCTime }
80+ deriving (Eq, Ord, Generic, Binary, NFData)
81+
82+makePrisms ''UTCTime'
83+
84+instance Show UTCTime' where
85+ showsPrec n
86+ = showsPrec n
87+ . formatTime defaultTimeLocale (iso8601DateFormat Nothing)
88+ . unUTCTime'
89+
90+instance Arbitrary UTCTime' where
91+ arbitrary = UTCTime' <$> do
92+ UTCTime
93+ <$> (ModifiedJulianDay <$> choose (55000, 58000))
94+ <*> arbitrary
95+
96+-- TODO: do not store the time, only the date
97+newtype UTCDate
98+ = UTCDate
99+ { utcTime :: UTCTime
100+ } deriving (Eq, Ord)
101+
102+makePrisms ''UTCDate
103+
104+instance NFData UTCDate where
105+ rnf (UTCDate d) = d `seq` () -- NOTE: not very good
106+
107+instance Binary UTCDate where
108+ put (UTCDate t) = put d
109+ where
110+ UTCTime (ModifiedJulianDay d) _ = t
111+ get = do
112+ d <- get
113+ return $ UTCDate (UTCTime (ModifiedJulianDay d) 0)
114+
115+instance Show UTCDate where
116+-- I hope no code was depending on this instance!
117+-- show = formatTime defaultTimeLocale "%d-%B-%y" . utcTime
118+ showsPrec n
119+ = showsPrec n
120+ . formatTime defaultTimeLocale "%d-%B-%y"
121+ . utcTime
122+
123+instance ToJSON UTCDate where
124+ toJSON (UTCDate t) = String $ T.pack iso8601
125+ where iso8601 = formatTime defaultTimeLocale (iso8601DateFormat Nothing) t
126+
127+instance FromJSON UTCDate where
128+ parseJSON (String s) = return $ UTCDate date
129+ where
130+ date = parseTimeOrError True defaultTimeLocale format string
131+ format = iso8601DateFormat Nothing
132+ string = T.unpack s
133+ parseJSON _ = mzero
134+
135+instance Arbitrary UTCDate where
136+ arbitrary = do
137+ dayNum <- choose (55000, 58000)
138+ return(UTCDate $ UTCTime (ModifiedJulianDay dayNum) (secondsToDiffTime 0))
139+
140+toApiDate :: UTCDate -> T.Text
141+toApiDate (UTCDate t) = T.pack iso8601
142+ where
143+ iso8601 = formatTime defaultTimeLocale (iso8601DateFormat Nothing) t
144+
145+fromApiDate :: (MonadFail m) => T.Text -> m UTCDate
146+fromApiDate t = UTCDate <$> parseTimeM
147+ True
148+ defaultTimeLocale
149+ (iso8601DateFormat Nothing)
150+ (T.unpack t)
151+
152+apiDate :: Prism' T.Text UTCDate
153+apiDate = prism' toApiDate fromApiDate
154+
155+mskTimeZone :: TimeZone
156+mskTimeZone = TimeZone (3 * 60) False "MSK"
157+
158+toAPITimeMSK :: UTCTime -> ShortZonedTime
159+toAPITimeMSK = shortZonedTime . utcToZonedTime mskTimeZone
160+
161+data TimeFrameType
162+ = TimeOfArrival
163+ | TimeOfDeparture
164+ deriving (Eq, Show, Generic)
165+
166+instance Binary TimeFrameType
167+
168+instance Arbitrary TimeFrameType where
169+ arbitrary = genericArbitrary
170+ shrink = genericShrink
171+
172+data TimeFrame = TimeFrame
173+ { _tfFrom :: !TimeOfDay
174+ , _tfTo :: !TimeOfDay
175+ , _tfType :: !TimeFrameType
176+ }
177+ deriving (Eq, Show, Generic)
178+
179+makeLenses ''TimeFrame
180+
181+instance Binary TimeFrame
182+
183+instance Arbitrary TimeFrame where
184+ arbitrary = genericArbitrary
185+ shrink = genericShrink
186+
187+mkTimeFrame :: TimeOfDay -> TimeOfDay -> TimeFrameType -> Maybe TimeFrame
188+mkTimeFrame fromTof toTof tft = if toTof >= fromTof
189+ then Just $ TimeFrame fromTof toTof tft
190+ else Nothing
191+
192+data DateRange = DateRange
193+ { _drFromDate :: Day
194+ , _drToDate :: Day
195+ } deriving (Eq, Show, Read, Generic)
196+
197+makeLenses ''DateRange
198+
199+mkDateRange :: Day -> Day -> DateRange
200+mkDateRange a b | b < a = DateRange b a
201+mkDateRange a b = DateRange a b
202+
203+instance Arbitrary DateRange where
204+ arbitrary = mkDateRange <$> arbitrary <*> arbitrary
205+ shrink = genericShrink
206+
207+instance Binary DateRange
src/Data/Time/Fmt.hsnew file+95
@@ -0,0 +1,95 @@
1+module Data.Time.Fmt
2+ ( FmtTime(..)
3+ , _FmtTime
4+ , ZonedISO8601
5+ , ZonedISO8601NoMs
6+ , LocalISO8601
7+ , DateISO8601
8+ , TimeISO8601
9+ , fmtTimeToString
10+ , fmtTimeFromString
11+ ) where
12+
13+import Control.DeepSeq (NFData)
14+import Control.Lens
15+import Control.Monad
16+import Data.Aeson (FromJSON(..), ToJSON(..))
17+import Data.Binary (Binary)
18+import Data.Proxy
19+import Data.String
20+import qualified Data.Text as T
21+import Data.Time
22+import GHC.Generics (Generic)
23+import GHC.TypeLits
24+import Test.QuickCheck
25+import Text.XML.DOM.Parser
26+import Text.XML.Writer
27+import Web.HttpApiData
28+
29+
30+newtype FmtTime (fmt :: Symbol) a = FmtTime
31+ { unFmtTime :: a
32+ } deriving (NFData, Eq, Ord, Generic, Binary, Arbitrary, Functor, FormatTime)
33+
34+makePrisms ''FmtTime
35+
36+fmtTimeToString
37+ :: forall a fmt
38+ . (FormatTime a, KnownSymbol fmt)
39+ => FmtTime fmt a
40+ -> String
41+fmtTimeToString =
42+ formatTime defaultTimeLocale (symbolVal (Proxy @fmt)) . unFmtTime
43+
44+fmtTimeFromString
45+ :: forall a fmt m
46+ . (ParseTime a, KnownSymbol fmt, Monad m)
47+ => String
48+ -> m (FmtTime fmt a)
49+fmtTimeFromString =
50+ let fmt = symbolVal (Proxy @fmt)
51+ in pure . FmtTime <=< parseTimeM True defaultTimeLocale fmt
52+
53+instance (FormatTime a, KnownSymbol fmt) => Show (FmtTime fmt a) where
54+ showsPrec n = showsPrec n . fmtTimeToString
55+
56+instance (ParseTime a, KnownSymbol fmt) => IsString (FmtTime fmt a) where
57+ fromString =
58+ let fmt = symbolVal (Proxy @fmt)
59+ in FmtTime . parseTimeOrError True defaultTimeLocale fmt
60+
61+instance (FormatTime a, KnownSymbol fmt) => ToJSON (FmtTime fmt a) where
62+ toJSON = toJSON . fmtTimeToString
63+
64+instance (ParseTime a, KnownSymbol fmt) => FromJSON (FmtTime fmt a) where
65+ parseJSON = fmtTimeFromString <=< parseJSON
66+
67+instance (FormatTime a, KnownSymbol fmt) => ToHttpApiData (FmtTime fmt a) where
68+ toUrlPiece = T.pack . fmtTimeToString
69+
70+instance (ParseTime a, KnownSymbol fmt) => FromHttpApiData (FmtTime fmt a) where
71+ parseUrlPiece t = maybe err Right $ fmtTimeFromString $ T.unpack t
72+ where
73+ fmt = T.pack $ symbolVal (Proxy @fmt)
74+ err = Left $ "no parse " <> t <> " as " <> fmt
75+
76+instance (FormatTime a, KnownSymbol fmt) => ToXML (FmtTime fmt a) where
77+ toXML = toXML . T.pack . fmtTimeToString
78+
79+instance (ParseTime a, KnownSymbol fmt) => FromDom (FmtTime fmt a) where
80+ fromDom = do
81+ s <- fromDom
82+ case fmtTimeFromString s of
83+ Right a -> return a
84+ Left e -> throwParserError $
85+ PEContentWrongFormat (T.pack e)
86+
87+type ZonedISO8601 = ("%FT%T%Q%z" :: Symbol)
88+
89+type ZonedISO8601NoMs = ("%FT%T%z" :: Symbol)
90+
91+type LocalISO8601 = ("%FT%T%Q" :: Symbol)
92+
93+type DateISO8601 = ("%F" :: Symbol)
94+
95+type TimeISO8601 = ("%T" :: Symbol)
src/Data/Time/LocalTime/Instances.hsnew file+42
@@ -0,0 +1,42 @@
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+ (Day(..), LocalTime(..), TimeOfDay(..), TimeZone(..), ZonedTime(..))
9+import qualified Data.Time as T
10+import Data.Time.Clock
11+import GHC.Generics (Generic)
12+
13+
14+deriving instance Generic TimeZone
15+
16+instance Binary TimeZone
17+
18+deriving instance Generic Day
19+
20+instance Binary Day
21+
22+deriving instance Generic (Fixed a)
23+
24+deriving instance Generic TimeOfDay
25+
26+instance Binary TimeOfDay
27+
28+deriving instance Generic LocalTime
29+
30+instance Binary LocalTime
31+
32+deriving instance Generic ZonedTime
33+
34+instance Binary ZonedTime
35+
36+instance Binary DiffTime where
37+ put = put . toRational
38+ get = fromRational <$> get
39+
40+deriving instance Generic UTCTime
41+
42+instance Binary UTCTime
src/Data/Time/LocalTime/Short.hsnew file+142
@@ -0,0 +1,142 @@
1+module Data.Time.LocalTime.Short
2+ ( ShortZonedTime
3+ , shortZonedTime
4+ , unShortZonedTime
5+ , ShortLocalTime
6+ , shortLocalTime
7+ , unShortLocalTime
8+ , FmtShortZonedTime
9+ , FmtShortLocalTime
10+ , arbitraryShortZonedTimeAfterDay
11+ , arbitraryShortLocalTimeAfterDay
12+ , module Data.Time.Fmt
13+ , shortZonedLocalDay
14+ , shortZonedLocalTimeOfDay
15+ , shortZonedTimeZoneString
16+ ) where
17+
18+import Control.DeepSeq (NFData)
19+import Control.Lens
20+import Control.Lens.Missing
21+import Control.Monad.State
22+import Data.Aeson
23+import Data.Binary (Binary)
24+import Data.Coerce
25+import Data.Ord (comparing)
26+import qualified Data.Time as T
27+import Data.Time.Fmt
28+import Data.Time.Format
29+import Data.Time.LocalTime.Instances ()
30+import GHC.Generics (Generic)
31+import Test.QuickCheck (Arbitrary)
32+import qualified Test.QuickCheck as QC
33+import Test.QuickCheck.Instances ()
34+
35+
36+-- | @ZonedTime@ where seconds = 0.
37+-- The constructor is not exported to maintain the invariant.
38+newtype ShortZonedTime
39+ = ShortZonedTime
40+ { unShortZonedTime :: T.ZonedTime
41+ } deriving (FormatTime, NFData, Generic, FromJSON, ToJSON)
42+
43+shortZonedLocalDay :: ShortZonedTime -> T.Day
44+shortZonedLocalDay = T.localDay . T.zonedTimeToLocalTime . unShortZonedTime
45+
46+shortZonedLocalTimeOfDay :: ShortZonedTime -> T.TimeOfDay
47+shortZonedLocalTimeOfDay =
48+ T.localTimeOfDay . T.zonedTimeToLocalTime . unShortZonedTime
49+
50+shortZonedTimeZoneString :: ShortZonedTime -> String
51+shortZonedTimeZoneString =
52+ T.timeZoneOffsetString . T.zonedTimeZone . unShortZonedTime
53+
54+instance Binary ShortZonedTime
55+
56+-- | Set seconds to 0.
57+clipZonedTime :: T.ZonedTime -> T.ZonedTime
58+clipZonedTime = set (_zonedTimeToLocalTime . _localTimeOfDay . _todSec) 0
59+
60+-- | Smart constructor.
61+shortZonedTime :: T.ZonedTime -> ShortZonedTime
62+shortZonedTime = coerce . clipZonedTime
63+
64+instance ParseTime ShortZonedTime where
65+ buildTime tl ps = shortZonedTime <$> buildTime tl ps
66+
67+instance Show ShortZonedTime where
68+ -- Display as a string.
69+ showsPrec n = showsPrec n . show . unShortZonedTime
70+
71+instance Eq ShortZonedTime where
72+ a == b = compare a b == EQ
73+
74+instance Show ShortLocalTime where
75+ -- Display as a string.
76+ showsPrec n = showsPrec n . show . unShortLocalTime
77+
78+-- | Fuck time zones.
79+instance Ord ShortZonedTime where
80+ compare a b = foldMap (\f -> f a b)
81+ [ comparing (T.zonedTimeToUTC . unShortZonedTime)
82+ , comparing (T.timeZoneMinutes . T.zonedTimeZone . unShortZonedTime) ]
83+
84+-- | @LocalTime@ where seconds = 0.
85+-- The constructor is not exported to maintain the invariant.
86+newtype ShortLocalTime
87+ = ShortLocalTime
88+ { unShortLocalTime :: T.LocalTime
89+ } deriving (Eq, Ord, FormatTime, NFData, Generic)
90+
91+instance Binary ShortLocalTime
92+
93+-- | Set seconds to 0.
94+clipLocalTime :: T.LocalTime -> T.LocalTime
95+clipLocalTime = set (_localTimeOfDay . _todSec) 0
96+
97+-- | Smart constructor.
98+shortLocalTime :: T.LocalTime -> ShortLocalTime
99+shortLocalTime = coerce . clipLocalTime
100+
101+instance ParseTime ShortLocalTime where
102+ buildTime tl ps = shortLocalTime <$> buildTime tl ps
103+
104+type FmtShortZonedTime fmt = FmtTime fmt ShortZonedTime
105+
106+type FmtShortLocalTime fmt = FmtTime fmt ShortLocalTime
107+
108+-- | Fuck time zones. Really.
109+instance Arbitrary ShortZonedTime where
110+ arbitrary = evalStateT (arbitraryShortZonedTimeAfterDay 20000) 40000
111+
112+-- | May be used to generate sequential dates.
113+--
114+-- @
115+-- [a,b,c] <- replicateM 3 (arbitraryShortZonedTimeAfterDay 5)
116+-- @
117+arbitraryShortZonedTimeAfterDay
118+ :: Integer -- ^ Day range
119+ -> StateT Integer QC.Gen ShortZonedTime
120+arbitraryShortZonedTimeAfterDay m = StateT $ \n -> do
121+ let day = T.ModifiedJulianDay n
122+ localTime <- QC.arbitrary <&> _localDay .~ day
123+ let zonedTime = T.ZonedTime localTime T.utc
124+ n' <- QC.choose (n, n + m)
125+ return (shortZonedTime zonedTime, n' + 1)
126+
127+-- | May be used to generate sequential dates.
128+--
129+-- @
130+-- [a,b,c] <- replicateM 3 (arbitraryShortLocalTimeAfterDay 5)
131+-- @
132+arbitraryShortLocalTimeAfterDay
133+ :: Integer -- ^ Day range
134+ -> StateT Integer QC.Gen ShortLocalTime
135+arbitraryShortLocalTimeAfterDay m = StateT $ \n -> do
136+ let day = T.ModifiedJulianDay n
137+ localTime <- QC.arbitrary <&> _localDay .~ day
138+ n' <- QC.choose (n, n + m)
139+ return (shortLocalTime localTime, n' + 1)
140+
141+instance Arbitrary ShortLocalTime where
142+ arbitrary = evalStateT (arbitraryShortLocalTimeAfterDay 20000) 40000
src/Data/Time/Utils.hsnew file+29
@@ -0,0 +1,29 @@
1+module Data.Time.Utils
2+ ( the24h
3+ , oneHour
4+ , oneMinute
5+ , zoneLocalTime
6+ ) where
7+
8+import Data.Time
9+import Data.Time.LocalTime.TimeZone.Series
10+
11+
12+the24h :: NominalDiffTime
13+the24h = 24 * oneHour
14+
15+oneHour :: NominalDiffTime
16+oneHour = 60 * 60
17+
18+oneMinute :: NominalDiffTime
19+oneMinute = 60
20+
21+-- | Calculate TimeZone using TimeZoneSeries and construct ZonedTime
22+zoneLocalTime
23+ :: TimeZoneSeries
24+ -> LocalTime
25+ -> ZonedTime
26+zoneLocalTime tzs lt = let
27+ u = localTimeToUTC' tzs lt
28+ tz = timeZoneFromSeries tzs u
29+ in ZonedTime lt tz
test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}