xsd 0.6.0 → 0.6.1
raw patch · 3 files changed
+129/−88 lines, 3 filesdep +semigroupoids
Dependencies added: semigroupoids
Files
- changelog.md +3/−0
- src/Text/XML/XSD/DateTime.hs +124/−87
- xsd.cabal +2/−1
changelog.md view
@@ -1,3 +1,6 @@+0.6.1 (2021)+ * Add classy optics.+ 0.6.0 (2021) * Refactoring. * Update version bounds.
src/Text/XML/XSD/DateTime.hs view
@@ -3,27 +3,30 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DefaultSignatures #-} -- | XSD @dateTime@ data structure <http://www.w3.org/TR/xmlschema-2/#dateTime> module Text.XML.XSD.DateTime- ( DateTime(..)- , isoEither- , _UTCTime- , _LocalTime- , dateTime- , fromZonedTime- ) where+(+ DateTime(..)+, ManyDateTime(..)+, Many1DateTime(..)+, HasDateTime(..)+, AsDateTime(..)+, isoEither+, fromZonedTime+) where import Control.Applicative (pure, (<$>), (*>), (<|>)) import Control.Monad (Monad(..), when) import Control.Lens- ( from, iso, _Left, _Right, prism', review, Iso', Prism' ) import Data.Bool ( Bool(False, True), (&&), (||) ) import Data.Char (ord) import Data.Either(Either(..), either) import Data.Eq ( Eq(..) ) import Data.Fixed (Pico, showFixed) import Data.Function((.), id, ($), const)+import Data.Functor.Apply(WrappedApplicative(WrapApplicative, unwrapApplicative)) import Data.Int ( Int ) import Data.Maybe (Maybe(Nothing, Just)) import Data.Ord ( Ord((>), (<)) )@@ -80,6 +83,53 @@ | DtUnzoned LocalTime deriving (Eq, Ord, Show, Generic) +class ManyDateTime a where+ _DateTime_ :: Traversal' a DateTime+ default _DateTime_ :: Many1DateTime a => Traversal' a DateTime+ _DateTime_ f = unwrapApplicative . _DateTime1_ (WrapApplicative . f)++instance ManyDateTime DateTime where++class Many1DateTime a where+ _DateTime1_ :: Traversal1' a DateTime+ default _DateTime1_ :: HasDateTime a => Traversal1' a DateTime+ _DateTime1_ = dateTime++instance Many1DateTime DateTime where++class HasDateTime a where+ dateTime :: Lens' a DateTime+ getDateTime :: a -> DateTime+ getDateTime = view dateTime++instance HasDateTime DateTime where+ dateTime = id++class AsDateTime a where+ _DateTime :: Prism' a DateTime+ _UTCDateTime :: Prism' a UTCTime+ _UTCDateTime = _DateTime . _UTCDateTime+ _LocalDateTime :: Prism' a LocalTime+ _LocalDateTime = _DateTime . _LocalDateTime++instance AsDateTime DateTime where+ _DateTime = id+ _UTCDateTime =+ prism'+ DtZoned+ (\case+ DtZoned x -> Just x+ _ -> Nothing+ )+ _LocalDateTime =+ prism'+ DtUnzoned+ (\case+ DtUnzoned x -> Just x+ _ -> Nothing+ )++ -- _LocalDateTime = undefined -- | Internal helper that creates a date time. Note, if the given hour -- is 24 then the minutes and seconds are assumed to be 0. mkDateTime@@ -110,144 +160,131 @@ iso (either DtZoned DtUnzoned) (\case DtZoned e -> Left e DtUnzoned q -> Right q) --- | A prism that views the @UTCTime@ component of a @DateTime@.-_UTCTime ::- Prism' DateTime UTCTime-_UTCTime =- from isoEither . _Left---- | A prism that views the @LocalTime@ component of a @DateTime@.-_LocalTime ::- Prism' DateTime LocalTime-_LocalTime =- from isoEither . _Right- -- | A prism that parses the string into a @DateTime@ and converts the -- @DateTime@ into a string. ----- >>> "2009-10-10T03:10:10-05:00" ^? dateTime+-- >>> "2009-10-10T03:10:10-05:00" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtZoned 2009-10-10 08:10:10 UTC) ----- >>> "2119-10-10T03:10:10.4-13:26" ^? dateTime+-- >>> "2119-10-10T03:10:10.4-13:26" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtZoned 2119-10-10 16:36:10.4 UTC) ----- >>> "0009-10-10T03:10:10.783952+14:00" ^? dateTime+-- >>> "0009-10-10T03:10:10.783952+14:00" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtZoned 0009-10-09 13:10:10.783952 UTC) ----- >>> "2009-10-10T03:10:10Z" ^? dateTime+-- >>> "2009-10-10T03:10:10Z" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtZoned 2009-10-10 03:10:10 UTC) ----- >>> "-2009-05-10T21:08:59+05:00" ^? dateTime+-- >>> "-2009-05-10T21:08:59+05:00" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtZoned -2009-05-10 16:08:59 UTC) ----- >>> "-19399-12-31T13:10:10-14:00" ^? dateTime+-- >>> "-19399-12-31T13:10:10-14:00" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtZoned -19398-01-01 03:10:10 UTC) ----- >>> "2009-12-31T13:10:10" ^? dateTime+-- >>> "2009-12-31T13:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtUnzoned 2009-12-31 13:10:10) ----- >>> "2012-10-15T24:00:00" ^? dateTime+-- >>> "2012-10-15T24:00:00" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtUnzoned 2012-10-16 00:00:00) ----- >>> "2002-10-10T12:00:00+05:00" ^? dateTime+-- >>> "2002-10-10T12:00:00+05:00" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtZoned 2002-10-10 07:00:00 UTC) ----- >>> "2002-10-10T00:00:00+05:00" ^? dateTime+-- >>> "2002-10-10T00:00:00+05:00" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtZoned 2002-10-09 19:00:00 UTC) ----- >>> "-0001-10-10T00:00:00" ^? dateTime+-- >>> "-0001-10-10T00:00:00" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtUnzoned -0001-10-10 00:00:00) ----- >>> "0001-10-10T00:00:00" ^? dateTime+-- >>> "0001-10-10T00:00:00" ^? (_DateTime :: Prism' Text DateTime) -- Just (DtUnzoned 0001-10-10 00:00:00) ----- >>> "2009-10-10T03:10:10-05" ^? dateTime+-- >>> "2009-10-10T03:10:10-05" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-10T03:10:10+14:50" ^? dateTime+-- >>> "2009-10-10T03:10:10+14:50" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-10T03:10:1" ^? dateTime+-- >>> "2009-10-10T03:10:1" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-10T03:1:10" ^? dateTime+-- >>> "2009-10-10T03:1:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-10T0:10:10" ^? dateTime+-- >>> "2009-10-10T0:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-1T10:10:10" ^? dateTime+-- >>> "2009-10-1T10:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-1-10T10:10:10" ^? dateTime+-- >>> "2009-1-10T10:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "209-10-10T03:10:10" ^? dateTime+-- >>> "209-10-10T03:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-10T24:10:10" ^? dateTime+-- >>> "2009-10-10T24:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "0000-01-01T00:00:00" ^? dateTime+-- >>> "0000-01-01T00:00:00" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-13-01T00:00:00" ^? dateTime+-- >>> "2009-13-01T00:00:00" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "+2009-10-01T04:20:40" ^? dateTime+-- >>> "+2009-10-01T04:20:40" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "002009-10-01T04:20:40" ^? dateTime+-- >>> "002009-10-01T04:20:40" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> dateTime # review _UTCTime (mkUTC 2119 10 10 16 36 10.4)+-- >>> (_DateTime :: Prism' Text DateTime) # review _UTCDateTime (mkUTC 2119 10 10 16 36 10.4) -- "2119-10-10T16:36:10.4Z" ----- >>> dateTime # fromZonedTime (mkZoned 2010 04 07 13 47 20.001 2 0)+-- >>> (_DateTime :: Prism' Text DateTime) # fromZonedTime (mkZoned 2010 04 07 13 47 20.001 2 0) -- "2010-04-07T11:47:20.001Z" ----- >>> dateTime # review _LocalTime (mkLocal 13 2 4 20 20 20)+-- >>> (_DateTime :: Prism' Text DateTime) # review _LocalDateTime (mkLocal 13 2 4 20 20 20) -- "0013-02-04T20:20:20" ----- >>> (dateTime #) `fmap` ("2010-04-07T13:47:20.001+02:00" ^? dateTime) -- issue 2+-- >>> (review (_DateTime :: Prism' Text DateTime)) `fmap` ("2010-04-07T13:47:20.001+02:00" ^? (_DateTime :: Prism' Text DateTime)) -- issue 2 -- Just "2010-04-07T11:47:20.001Z"-dateTime ::- Prism' Text DateTime-dateTime =- let buildUInt2 ::- Int- -> Builder- buildUInt2 x =- (if x < 10 then ("0" <>) else id) $ decimal x- buildInt4 ::- Integer- -> Builder- buildInt4 year =- let absYear = abs year- k x = if absYear < x then ("0" <>) else id- in k 1000 . k 100 . k 10 $ decimal year- toText ::- DateTime- -> Text- toText =- toStrict . toLazyText . dtBuilder- where- dtBuilder (DtZoned uTime) = ltBuilder (utcToLocalTime utc uTime) <> "Z"- dtBuilder (DtUnzoned lTime) = ltBuilder lTime- ltBuilder (LocalTime day (TimeOfDay hh mm sss)) =- let (y, m, d) = toGregorian day- in buildInt4 y- <> "-"- <> buildUInt2 m- <> "-"- <> buildUInt2 d- <> "T"- <> buildUInt2 hh- <> ":"- <> buildUInt2 mm- <> ":"- <> buildSeconds sss- in prism' toText (either (const Nothing) Just . parse (parseDateTime <|> fail "bad date time") "DateTime")+instance AsDateTime Text where+ _DateTime =+ let buildUInt2 ::+ Int+ -> Builder+ buildUInt2 x =+ (if x < 10 then ("0" <>) else id) $ decimal x+ buildInt4 ::+ Integer+ -> Builder+ buildInt4 year =+ let absYear = abs year+ k x = if absYear < x then ("0" <>) else id+ in k 1000 . k 100 . k 10 $ decimal year+ toText ::+ DateTime+ -> Text+ toText =+ toStrict . toLazyText . dtBuilder+ where+ dtBuilder (DtZoned uTime) = ltBuilder (utcToLocalTime utc uTime) <> "Z"+ dtBuilder (DtUnzoned lTime) = ltBuilder lTime+ ltBuilder (LocalTime day (TimeOfDay hh mm sss)) =+ let (y, m, d) = toGregorian day+ in buildInt4 y+ <> "-"+ <> buildUInt2 m+ <> "-"+ <> buildUInt2 d+ <> "T"+ <> buildUInt2 hh+ <> ":"+ <> buildUInt2 mm+ <> ":"+ <> buildSeconds sss+ in prism' toText (either (const Nothing) Just . parse (parseDateTime <|> fail "bad date time") "DateTime") buildSeconds :: Pico@@ -258,7 +295,7 @@ -- | Converts a zoned time to a @dateTime@. fromZonedTime :: ZonedTime -> DateTime-fromZonedTime = review _UTCTime . zonedTimeToUTC+fromZonedTime = review _UTCDateTime . zonedTimeToUTC -- | Parser of the @dateTime@ lexical representation. parseDateTime ::
xsd.cabal view
@@ -1,5 +1,5 @@ name: xsd-version: 0.6.0+version: 0.6.1 license: BSD3 license-file: LICENCE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ>@@ -28,6 +28,7 @@ , lens >= 4 && < 6 , parsec >= 3.1 && < 3.2 , parsers >= 0.12 && < 0.13+ , semigroupoids >= 5 && < 6 ghc-options: -Wall