{-# LANGUAGE BangPatterns #-}

{-| Functions for decoding common time formats in RFC 8259 JSONs.
 -}

module Codec.JSON.Decoder.Time
  ( -- * Calendar
    year
  , quarter

    -- ** Month
  , month
  , monthDate

    -- ** Week
  , weekDate

    -- ** Ordinal
  , ordinalDate

    -- * Time of day
  , timeOfDay

    -- ** Local
  , localTime

    -- ** Zoned
  , timeZone
  , zonedTime
  ) where

import           Codec.JSON.Decoder
import           Codec.JSON.Decoder.Unsafe
import           Codec.JSON.Decoder.String.Internal

import           Data.Time.Calendar
import           Data.Time.Calendar.Month
import           Data.Time.Calendar.Quarter
import           Data.Time.LocalTime
import           Parser.Lathe
import qualified Parser.Lathe.Time as Lathe



oob :: String -> Error
oob :: String -> Error
oob String
name =
  Gravity -> String -> Error
Malformed Gravity
Benign (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
name String
" is out of bounds"


malformed :: String -> String -> Error
malformed :: String -> String -> Error
malformed String
name String
format =
  Gravity -> String -> Error
Malformed Gravity
Benign (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"Expected " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
name ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
" encoded as " String
format

trailing :: String -> Error
trailing :: String -> Error
trailing String
name =
  Gravity -> String -> Error
Malformed Gravity
Benign (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"Found trailing data after the " String
name



-- | Decode a JSON string as an RFC 3339 year, in the @yyyy@ format.
year :: Decoder Year
year :: Decoder Year
year =
  (Path -> Bitmask -> K -> Parser (Path, Error) Year) -> Decoder Year
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) Year)
 -> Decoder Year)
-> (Path -> Bitmask -> K -> Parser (Path, Error) Year)
-> Decoder Year
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int
-> Path -> Parser (Path, Error) Year -> Parser (Path, Error) Year
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) Year -> Parser (Path, Error) Year)
-> Parser (Path, Error) Year -> Parser (Path, Error) Year
forall a b. (a -> b) -> a -> b
$ do
             u <- (Path, Error) -> (Path, Error) -> Parser (Path, Error) Year
forall e. e -> e -> Parser e Year
Lathe.year (Path
path, String -> String -> Error
malformed String
"year" String
"yyyy") (Path
path, Error
AbruptEnd)
             end <- atEnd
             if end
               then pure u
               else err (path, trailing "year")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) Year
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)



-- | Decode a JSON string as a quarter, in the @yyyy-Qqq@ format.
--
--   Note that year quarters are not defined by ISO 8601, this is an informal convention.
quarter :: Decoder Quarter
quarter :: Decoder Quarter
quarter =
  (Path -> Bitmask -> K -> Parser (Path, Error) Quarter)
-> Decoder Quarter
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) Quarter)
 -> Decoder Quarter)
-> (Path -> Bitmask -> K -> Parser (Path, Error) Quarter)
-> Decoder Quarter
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int
-> Path
-> Parser (Path, Error) Quarter
-> Parser (Path, Error) Quarter
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) Quarter -> Parser (Path, Error) Quarter)
-> Parser (Path, Error) Quarter -> Parser (Path, Error) Quarter
forall a b. (a -> b) -> a -> b
$ do
             u <- (Path, Error)
-> (Path, Error) -> (Path, Error) -> Parser (Path, Error) Quarter
forall e. e -> e -> e -> Parser e Quarter
Lathe.quarter (Path
path, String -> Error
oob String
"Quarter")
                                (Path
path, String -> String -> Error
malformed String
"quarter" String
"yyyy-Qq")
                                (Path
path, Error
AbruptEnd)
             end <- atEnd
             if end
               then pure u
               else err (path, trailing "quarter")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) Quarter
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)



-- | Decode a JSON string as an RFC 3339 month, in the @yyyy-mm@ format.
month :: Decoder Month
month :: Decoder Month
month =
  (Path -> Bitmask -> K -> Parser (Path, Error) Month)
-> Decoder Month
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) Month)
 -> Decoder Month)
-> (Path -> Bitmask -> K -> Parser (Path, Error) Month)
-> Decoder Month
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int
-> Path -> Parser (Path, Error) Month -> Parser (Path, Error) Month
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) Month -> Parser (Path, Error) Month)
-> Parser (Path, Error) Month -> Parser (Path, Error) Month
forall a b. (a -> b) -> a -> b
$ do
             u <- (Path, Error)
-> (Path, Error) -> (Path, Error) -> Parser (Path, Error) Month
forall e. e -> e -> e -> Parser e Month
Lathe.month (Path
path, String -> Error
oob String
"Month")
                              (Path
path, String -> String -> Error
malformed String
"month" String
"yyyy-mm")
                              (Path
path, Error
AbruptEnd)
             end <- atEnd
             if end
               then pure u
               else err (path, trailing "month")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) Month
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)



-- | Decode a JSON string as an RFC 3339 month date, in the @yyyy-mm-dd@ format.
monthDate :: Decoder Day
monthDate :: Decoder Day
monthDate =
  (Path -> Bitmask -> K -> Parser (Path, Error) Day) -> Decoder Day
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) Day) -> Decoder Day)
-> (Path -> Bitmask -> K -> Parser (Path, Error) Day)
-> Decoder Day
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int -> Path -> Parser (Path, Error) Day -> Parser (Path, Error) Day
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) Day -> Parser (Path, Error) Day)
-> Parser (Path, Error) Day -> Parser (Path, Error) Day
forall a b. (a -> b) -> a -> b
$ do
             u <- (Path, Error)
-> (Path, Error) -> (Path, Error) -> Parser (Path, Error) Day
forall e. e -> e -> e -> Parser e Day
Lathe.monthDate (Path
path, String -> Error
oob String
"Month")
                                  (Path
path, String -> String -> Error
malformed String
"month" String
"yyyy-mm-dd")
                                  (Path
path, Error
AbruptEnd)
             end <- atEnd
             if end
               then pure u
               else err (path, trailing "month date")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) Day
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)



-- | Decode a JSON string as an ISO 8601 week date, in the @yyyy-Www-d@ format.
weekDate :: Decoder Day
weekDate :: Decoder Day
weekDate =
  (Path -> Bitmask -> K -> Parser (Path, Error) Day) -> Decoder Day
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) Day) -> Decoder Day)
-> (Path -> Bitmask -> K -> Parser (Path, Error) Day)
-> Decoder Day
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int -> Path -> Parser (Path, Error) Day -> Parser (Path, Error) Day
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) Day -> Parser (Path, Error) Day)
-> Parser (Path, Error) Day -> Parser (Path, Error) Day
forall a b. (a -> b) -> a -> b
$ do
             u <- (Path, Error)
-> (Path, Error) -> (Path, Error) -> Parser (Path, Error) Day
forall e. e -> e -> e -> Parser e Day
Lathe.weekDate (Path
path, String -> Error
oob String
"Week date")
                                 (Path
path, String -> String -> Error
malformed String
"week date" String
"yyyy-Www-d")
                                 (Path
path, Error
AbruptEnd)
             end <- atEnd
             if end
               then pure u
               else err (path, trailing "week date")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) Day
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)



-- | Decode a JSON string as an ISO 8601 ordinal date, in the @yyyy-ddd@ format.
ordinalDate :: Decoder Day
ordinalDate :: Decoder Day
ordinalDate =
  (Path -> Bitmask -> K -> Parser (Path, Error) Day) -> Decoder Day
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) Day) -> Decoder Day)
-> (Path -> Bitmask -> K -> Parser (Path, Error) Day)
-> Decoder Day
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int -> Path -> Parser (Path, Error) Day -> Parser (Path, Error) Day
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) Day -> Parser (Path, Error) Day)
-> Parser (Path, Error) Day -> Parser (Path, Error) Day
forall a b. (a -> b) -> a -> b
$ do
             u <- (Path, Error)
-> (Path, Error) -> (Path, Error) -> Parser (Path, Error) Day
forall e. e -> e -> e -> Parser e Day
Lathe.ordinalDate (Path
path, String -> Error
oob String
"Ordinal date")
                                    (Path
path, String -> String -> Error
malformed String
"ordinal date" String
"yyyy-ddd")
                                    (Path
path, Error
AbruptEnd)
             end <- atEnd
             if end
               then pure u
               else err (path, trailing "ordinal date")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) Day
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)



-- | Decode a JSON string as an RFC 3339 time of day, in the @hh:mm:ss[.s…]@ format.
timeOfDay :: Decoder TimeOfDay
timeOfDay :: Decoder TimeOfDay
timeOfDay =
  (Path -> Bitmask -> K -> Parser (Path, Error) TimeOfDay)
-> Decoder TimeOfDay
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) TimeOfDay)
 -> Decoder TimeOfDay)
-> (Path -> Bitmask -> K -> Parser (Path, Error) TimeOfDay)
-> Decoder TimeOfDay
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int
-> Path
-> Parser (Path, Error) TimeOfDay
-> Parser (Path, Error) TimeOfDay
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) TimeOfDay -> Parser (Path, Error) TimeOfDay)
-> Parser (Path, Error) TimeOfDay -> Parser (Path, Error) TimeOfDay
forall a b. (a -> b) -> a -> b
$ do
             u <- (Path, Error)
-> (Path, Error) -> (Path, Error) -> Parser (Path, Error) TimeOfDay
forall e. e -> e -> e -> Parser e TimeOfDay
Lathe.timeOfDay (Path
path, String -> Error
oob String
"Time of day")
                                  (Path
path, String -> String -> Error
malformed String
"time of day" String
"hh:mm:ss[.s…]")
                                  (Path
path, Error
AbruptEnd)
             end <- atEnd
             if end
               then pure u
               else err (path, trailing "time of day")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) TimeOfDay
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)



-- | Decode a JSON string as an RFC 3339 local time, in the @yyyy-mm-ddThh:mm:ss[.s…]@ format.
--
--   Either @t@ or space is accepted instead of @T@.
localTime :: Decoder LocalTime
localTime :: Decoder LocalTime
localTime =
  (Path -> Bitmask -> K -> Parser (Path, Error) LocalTime)
-> Decoder LocalTime
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) LocalTime)
 -> Decoder LocalTime)
-> (Path -> Bitmask -> K -> Parser (Path, Error) LocalTime)
-> Decoder LocalTime
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int
-> Path
-> Parser (Path, Error) LocalTime
-> Parser (Path, Error) LocalTime
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) LocalTime -> Parser (Path, Error) LocalTime)
-> Parser (Path, Error) LocalTime -> Parser (Path, Error) LocalTime
forall a b. (a -> b) -> a -> b
$ do
             u <- (Path, Error)
-> (Path, Error) -> (Path, Error) -> Parser (Path, Error) LocalTime
forall e. e -> e -> e -> Parser e LocalTime
Lathe.localTime (Path
path, String -> Error
oob String
"Local time")
                                  (Path
path, String -> String -> Error
malformed String
"local time" String
"yyyy-mm-ddThh:mm:ss[.s…]")
                                  (Path
path, Error
AbruptEnd)
             end <- atEnd
             if end
               then pure u
               else err (path, trailing "local time")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) LocalTime
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)



-- | Decode a JSON string as an RFC 3339 time zone, in either @Z@ or @±hh:mm@ format.
--
--   @z@ is accepted instead of @Z@.
timeZone :: Decoder TimeZone
timeZone :: Decoder TimeZone
timeZone =
  (Path -> Bitmask -> K -> Parser (Path, Error) TimeZone)
-> Decoder TimeZone
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) TimeZone)
 -> Decoder TimeZone)
-> (Path -> Bitmask -> K -> Parser (Path, Error) TimeZone)
-> Decoder TimeZone
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int
-> Path
-> Parser (Path, Error) TimeZone
-> Parser (Path, Error) TimeZone
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) TimeZone -> Parser (Path, Error) TimeZone)
-> Parser (Path, Error) TimeZone -> Parser (Path, Error) TimeZone
forall a b. (a -> b) -> a -> b
$ do
             u <- (Path, Error)
-> (Path, Error) -> (Path, Error) -> Parser (Path, Error) TimeZone
forall e. e -> e -> e -> Parser e TimeZone
Lathe.timeZone (Path
path, String -> Error
oob String
"Time zone")
                                 (Path
path, String -> String -> Error
malformed String
"time zone" String
"either Z or ±hh:mm")
                                 (Path
path, Error
AbruptEnd)
             end <- atEnd
             if end
               then pure u
               else err (path, trailing "time zone")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) TimeZone
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)




-- | Decode a JSON string as an RFC 3339 zoned time,
--   in the @yyyy-mm-ddThh:mm:ss[.s…]±hh:mm@ format.
--
--   Combines behaviors of both 'timeOfDay' and 'zonedTime'.
zonedTime :: Decoder ZonedTime
zonedTime :: Decoder ZonedTime
zonedTime =
  (Path -> Bitmask -> K -> Parser (Path, Error) ZonedTime)
-> Decoder ZonedTime
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) ZonedTime)
 -> Decoder ZonedTime)
-> (Path -> Bitmask -> K -> Parser (Path, Error) ZonedTime)
-> Decoder ZonedTime
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int
-> Path
-> Parser (Path, Error) ZonedTime
-> Parser (Path, Error) ZonedTime
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) ZonedTime -> Parser (Path, Error) ZonedTime)
-> Parser (Path, Error) ZonedTime -> Parser (Path, Error) ZonedTime
forall a b. (a -> b) -> a -> b
$ do
             u <- (Path, Error)
-> (Path, Error) -> (Path, Error) -> Parser (Path, Error) ZonedTime
forall e. e -> e -> e -> Parser e ZonedTime
Lathe.zonedTime (Path
path, String -> Error
oob String
"Zoned time")
                                  (Path
path, String -> String -> Error
malformed String
"zoned time" String
"yyyy-mm-ddThh:mm:ss[.s…]±hh:mm")
                                  (Path
path, Error
AbruptEnd)
             end <- atEnd
             if end
               then pure u
               else err (path, trailing "zoned time")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) ZonedTime
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)