diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,6 @@ +0.6.1 (2021) + * Add classy optics. + 0.6.0 (2021) * Refactoring. * Update version bounds. diff --git a/src/Text/XML/XSD/DateTime.hs b/src/Text/XML/XSD/DateTime.hs --- a/src/Text/XML/XSD/DateTime.hs +++ b/src/Text/XML/XSD/DateTime.hs @@ -3,27 +3,30 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DefaultSignatures #-} -- | XSD @dateTime@ data structure 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 :: diff --git a/xsd.cabal b/xsd.cabal --- a/xsd.cabal +++ b/xsd.cabal @@ -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