{-# LANGUAGE GADTs                #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE LambdaCase           #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

module Text.Enum.Text
  ( EnumText(..)
  , UsingEnumText(..)
  , TextParsable(..)
  , EnumTextConfig(..)
  , defaultEnumTextConfig
  ) where

import           Control.Monad                  (void)
import           Control.Monad.Fail             as CMF
import           Data.Array
import qualified Data.Attoparsec.Text           as AP
import qualified Data.ByteString.Char8          as B
import           Data.Coerce
import           Data.Hashable
import           Data.Possibly
import           Data.Scientific                (toBoundedInteger)
import qualified Data.HashMap.Strict            as HM
import qualified Data.Text                      as T
import qualified Data.Text.Encoding             as TE
import           Data.Text.Read
import           Data.Time
import           Fmt
import           Text.Read


{- | Our toolkit for enumerated types which should be defined as follows:

@
import Fmt
import Text.Enum.Text

data Foo = FOO_bar | FOO_bar_baz
  deriving (Bounded,Enum,Eq,Ord,Show)

instance EnumText     Foo
instance Buildable    Foo where build     = buildEnumText
instance TextParsable Foo where parseText = parseEnumText
@

With the @DeriveAnyClass@ language extension you can list @EnumText@ in the
@deriving@ clause, and with @DerivingVia@ (available from GHC 8.6.1) you can
derive @via@ @UsingEnumText@ as follows:


@
{\-\# LANGUAGE DeriveAnyClass    #-\}
{\-\# LANGUAGE DerivingVia       #-\}

import Fmt
import Text.Enum.Text

data Foo = FOO_bar | FOO_bar_baz
  deriving (Bounded,Enum,EnumText,Eq,Ord,Show)
  deriving (Buildable,TextParsable) via UsingEnumText Foo
@

-}
class ( Buildable     e
      , Bounded       e
      , Enum          e
      , Eq            e
      , Ord           e
      , Show          e
      , TextParsable  e
      ) => EnumText e where

  -- | Configures the textual representation of @e@ generated by renderEnumText.
  configEnumText :: e -> EnumTextConfig
  configEnumText e
_ = EnumTextConfig
defaultEnumTextConfig

  -- | Generate the standard textual representation according to
  -- 'configEnumText' by default.
  renderEnumText :: e -> T.Text
  renderEnumText e
e = Array (I e) Text
forall e. EnumText e => Array (I e) Text
enumTextArray Array (I e) Text -> I e -> Text
forall i e. Ix i => Array i e -> i -> e
! e -> I e
forall a. a -> I a
I e
e

  -- | Sames as 'renderEnumText', but generating a 'Builder'.
  buildEnumText :: e -> Builder
  buildEnumText = Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> (e -> Text) -> e -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Text
forall e. EnumText e => e -> Text
renderEnumText

  -- | Parses an @e@ according to the 'renderEnumText' render.
  parseEnumText :: T.Text -> Possibly e
  parseEnumText Text
txt = Possibly e -> (e -> Possibly e) -> Maybe e -> Possibly e
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Possibly e
forall a b. a -> Either a b
Left [Char]
msg) e -> Possibly e
forall a b. b -> Either a b
Right (Maybe e -> Possibly e) -> Maybe e -> Possibly e
forall a b. (a -> b) -> a -> b
$ Text -> HashMap Text e -> Maybe e
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
txt HashMap Text e
forall e. EnumText e => HashMap Text e
hashmap_t
    where
      msg :: [Char]
msg = [Char]
"parseEnumText: enumeration not recognised: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Text -> [Char]
forall a. Show a => a -> [Char]
show Text
txt

  -- | A cassava field encoder, using 'the renderEnumText' format.
  toFieldEnumText :: e -> B.ByteString
  toFieldEnumText e
e = Array (I e) ByteString
forall e. EnumText e => Array (I e) ByteString
enumByteStringArray Array (I e) ByteString -> I e -> ByteString
forall i e. Ix i => Array i e -> i -> e
! e -> I e
forall a. a -> I a
I e
e

  -- | A cassava field parser using the 'renderEnumText' format.
  fromFieldEnumText_ :: MonadFail m => B.ByteString -> m e
  fromFieldEnumText_ ByteString
bs = m e -> (e -> m e) -> Maybe e -> m e
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> m e
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
CMF.fail [Char]
msg) e -> m e
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe e -> m e) -> Maybe e -> m e
forall a b. (a -> b) -> a -> b
$ ByteString -> HashMap ByteString e -> Maybe e
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup ByteString
bs HashMap ByteString e
forall e. EnumText e => HashMap ByteString e
hashmap_b
    where
      msg :: [Char]
msg = [Char]
"fromFieldEnumText_: enumeration not recognised: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
bs

  -- | For hashing @e@ with the 'renderEnumText' representation.
  hashWithSaltEnumText :: Int -> e -> Int
  hashWithSaltEnumText Int
n = Int -> ByteString -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
n (ByteString -> Int) -> (e -> ByteString) -> e -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ByteString
forall e. EnumText e => e -> ByteString
toFieldEnumText

newtype UsingEnumText a = UsingEnumText { UsingEnumText a -> a
_UsingEnumText :: a }

instance EnumText a => Buildable (UsingEnumText a) where
  build :: UsingEnumText a -> Builder
build (UsingEnumText a
x) = a -> Builder
forall e. EnumText e => e -> Builder
buildEnumText a
x

instance EnumText a => TextParsable (UsingEnumText a) where
  parseText :: Text -> Possibly (UsingEnumText a)
parseText Text
x = a -> UsingEnumText a
forall a. a -> UsingEnumText a
UsingEnumText (a -> UsingEnumText a)
-> Either [Char] a -> Possibly (UsingEnumText a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either [Char] a
forall e. EnumText e => Text -> Possibly e
parseEnumText Text
x


-------------------------------------------------------------------------------
-- EnumTextConfig, defaultEnumTextConfig
-------------------------------------------------------------------------------

-- | Configures the default implementation of 'renderEnumText'
data EnumTextConfig =
  EnumTextConfig
    { EnumTextConfig -> Text -> Text
_etc_text_prep :: T.Text -> T.Text  -- ^ applied to the output of 'show'
                                          -- once converted to 'T.Text'; by
                                          -- default strips each data
                                          -- constructor up to and including
                                          -- the first '_'
    , EnumTextConfig -> Char -> Char
_etc_char_prep :: Char -> Char      -- ^ applied to each character of
                                          -- the outpout of '_etc_text_prep'
                                          -- (by default flips underscores (@_@)
                                          -- to dashes (@-@)
    }

-- | The default 'configEnumText' for 'EnumText':
--
--   *  '_etc_text_prep' removes the prefix up to and including the first
--      underscore ('_')
--   *  '_etc_char_prep' flips the underscores  (@_@) to dashes (@-@)
defaultEnumTextConfig :: EnumTextConfig
defaultEnumTextConfig :: EnumTextConfig
defaultEnumTextConfig =
  EnumTextConfig :: (Text -> Text) -> (Char -> Char) -> EnumTextConfig
EnumTextConfig
    { _etc_text_prep :: Text -> Text
_etc_text_prep = Text -> Text
defaultTextPrep
    , _etc_char_prep :: Char -> Char
_etc_char_prep = Char -> Char
defaultCharPrep
    }

defaultTextPrep :: T.Text -> T.Text
defaultTextPrep :: Text -> Text
defaultTextPrep Text
txt = case Text -> Maybe (Char, Text)
T.uncons (Text -> Maybe (Char, Text)) -> Text -> Maybe (Char, Text)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'_') Text
txt of
    Just (Char
_,Text
rst) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
rst -> Text
rst
    Maybe (Char, Text)
_ -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"defaultTextPrep: bad data constructor: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Text -> [Char]
T.unpack Text
txt

defaultCharPrep :: Char -> Char
defaultCharPrep :: Char -> Char
defaultCharPrep Char
c = case Char
c of
    Char
'_' -> Char
'-'
    Char
_   -> Char
c


-------------------------------------------------------------------------------
-- TextParsable
-------------------------------------------------------------------------------

-- | a class for 'T.Text' parsers.
class TextParsable a where
  parseText :: T.Text -> Possibly a

instance TextParsable T.Text          where parseText :: Text -> Possibly Text
parseText = Text -> Possibly Text
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Robust 'TextParsable' instance for 'UTCTime'.
--
-- Examples:
--
-- >>> show <$> parseText @UTCTime (T.pack "2020-01-01 10:12:30")
-- Right "2020-01-01 10:12:30 UTC"
--
-- >>> show <$> parseText @UTCTime (T.pack "2020-01-01T10:12:30")
-- Right "2020-01-01 10:12:30 UTC"
--
-- >>> show <$> parseText @UTCTime (T.pack "2020-01-01T10:12:30Z")
-- Right "2020-01-01 10:12:30 UTC"
--
instance TextParsable UTCTime         where parseText :: Text -> Possibly UTCTime
parseText = (Text -> Maybe UTCTime) -> [Char] -> Text -> Possibly UTCTime
forall a. (Text -> Maybe a) -> [Char] -> Text -> Possibly a
parseTextUsing Text -> Maybe UTCTime
parseUTC [Char]
"UTCTime"

instance TextParsable Day             where parseText :: Text -> Possibly Day
parseText = [Char] -> Text -> Possibly Day
forall a. Read a => [Char] -> Text -> Possibly a
parseTextRead [Char]
"Day"
instance TextParsable Int             where parseText :: Text -> Possibly Int
parseText = Text -> Possibly Int
parseDecimal
instance a ~ Char => TextParsable [a] where parseText :: Text -> Possibly [a]
parseText = [Char] -> Either [Char] [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Either [Char] [Char])
-> (Text -> [Char]) -> Text -> Either [Char] [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

instance TextParsable a => TextParsable (Maybe a) where
  parseText :: Text -> Possibly (Maybe a)
parseText = \case
    Text
"" -> Maybe a -> Possibly (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
    Text
s  -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either [Char] a -> Possibly (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either [Char] a
forall a. TextParsable a => Text -> Possibly a
parseText Text
s


-------------------------------------------------------------------------------
-- arrays
-------------------------------------------------------------------------------

newtype I a = I { I a -> a
_I :: a }
  deriving (I a -> I a -> Bool
(I a -> I a -> Bool) -> (I a -> I a -> Bool) -> Eq (I a)
forall a. Eq a => I a -> I a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: I a -> I a -> Bool
$c/= :: forall a. Eq a => I a -> I a -> Bool
== :: I a -> I a -> Bool
$c== :: forall a. Eq a => I a -> I a -> Bool
Eq,Eq (I a)
Eq (I a)
-> (I a -> I a -> Ordering)
-> (I a -> I a -> Bool)
-> (I a -> I a -> Bool)
-> (I a -> I a -> Bool)
-> (I a -> I a -> Bool)
-> (I a -> I a -> I a)
-> (I a -> I a -> I a)
-> Ord (I a)
I a -> I a -> Bool
I a -> I a -> Ordering
I a -> I a -> I a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (I a)
forall a. Ord a => I a -> I a -> Bool
forall a. Ord a => I a -> I a -> Ordering
forall a. Ord a => I a -> I a -> I a
min :: I a -> I a -> I a
$cmin :: forall a. Ord a => I a -> I a -> I a
max :: I a -> I a -> I a
$cmax :: forall a. Ord a => I a -> I a -> I a
>= :: I a -> I a -> Bool
$c>= :: forall a. Ord a => I a -> I a -> Bool
> :: I a -> I a -> Bool
$c> :: forall a. Ord a => I a -> I a -> Bool
<= :: I a -> I a -> Bool
$c<= :: forall a. Ord a => I a -> I a -> Bool
< :: I a -> I a -> Bool
$c< :: forall a. Ord a => I a -> I a -> Bool
compare :: I a -> I a -> Ordering
$ccompare :: forall a. Ord a => I a -> I a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (I a)
Ord)

instance EnumText e => Ix (I e) where
  range :: (I e, I e) -> [I e]
range   (I e
l,I e
h)   = [e] -> [I e]
coerce [I e -> e
forall a. I a -> a
_I I e
l..I e -> e
forall a. I a -> a
_I I e
h]
  index :: (I e, I e) -> I e -> Int
index   (I e
l,I e
_) I e
x = e -> Int
forall a. Enum a => a -> Int
fromEnum (I e -> e
forall a. I a -> a
_I I e
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
- e -> Int
forall a. Enum a => a -> Int
fromEnum (I e -> e
forall a. I a -> a
_I I e
l)
  inRange :: (I e, I e) -> I e -> Bool
inRange (I e
l,I e
h) I e
x = I e -> e
forall a. I a -> a
_I I e
l e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= I e -> e
forall a. I a -> a
_I I e
x Bool -> Bool -> Bool
&& I e -> e
forall a. I a -> a
_I I e
x e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= I e -> e
forall a. I a -> a
_I I e
h

-- | array of texts constructed with 'configEnumText'
enumTextArray :: forall e . EnumText e => Array (I e) T.Text
enumTextArray :: Array (I e) Text
enumTextArray =
    (I e, I e) -> [Text] -> Array (I e) Text
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (e -> I e
forall a. a -> I a
I e
forall a. Bounded a => a
minBound,e -> I e
forall a. a -> I a
I e
forall a. Bounded a => a
maxBound)
      [ (Char -> Char) -> Text -> Text
T.map Char -> Char
_etc_char_prep (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
_etc_text_prep (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ e -> [Char]
forall a. Show a => a -> [Char]
show e
e
        | e
e <- [e
forall a. Bounded a => a
minBound..e
forall a. Bounded a => a
maxBound :: e]
        ]
  where
    EnumTextConfig{Char -> Char
Text -> Text
_etc_text_prep :: Text -> Text
_etc_char_prep :: Char -> Char
_etc_char_prep :: EnumTextConfig -> Char -> Char
_etc_text_prep :: EnumTextConfig -> Text -> Text
..} = e -> EnumTextConfig
forall e. EnumText e => e -> EnumTextConfig
configEnumText (e
forall a. Bounded a => a
minBound :: e)

-- | array of 'B.ByteString' generated from 'renderEnumText'
enumByteStringArray :: forall e . EnumText e => Array (I e) B.ByteString
enumByteStringArray :: Array (I e) ByteString
enumByteStringArray = (I e, I e) -> [ByteString] -> Array (I e) ByteString
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (e -> I e
forall a. a -> I a
I e
forall a. Bounded a => a
minBound,e -> I e
forall a. a -> I a
I e
forall a. Bounded a => a
maxBound)
    [ Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ e -> Text
forall e. EnumText e => e -> Text
renderEnumText e
e
      | e
e <- [e
forall a. Bounded a => a
minBound..e
forall a. Bounded a => a
maxBound :: e]
      ]


-------------------------------------------------------------------------------
-- hashmaps
-------------------------------------------------------------------------------

-- | 'T.Text' 'HM.HashMap' based on 'renderEnumText' representation
hashmap_t :: EnumText e => HM.HashMap T.Text e
hashmap_t :: HashMap Text e
hashmap_t = [(Text, e)] -> HashMap Text e
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
    [ (e -> Text
forall e. EnumText e => e -> Text
renderEnumText e
c,e
c)
      | e
c <- [e
forall a. Bounded a => a
minBound..e
forall a. Bounded a => a
maxBound]
      ]

-- | 'B.ByteString' 'HM.HashMap' based on 'renderEnumText' representation
hashmap_b :: EnumText e => HM.HashMap B.ByteString e
hashmap_b :: HashMap ByteString e
hashmap_b = [(ByteString, e)] -> HashMap ByteString e
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
    [ (Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ e -> Text
forall e. EnumText e => e -> Text
renderEnumText e
c,e
c)
      | e
c <- [e
forall a. Bounded a => a
minBound..e
forall a. Bounded a => a
maxBound]
      ]


-------------------------------------------------------------------------------
-- internal parsers
-------------------------------------------------------------------------------

-- | parse a decimal integer using the "Text.Read" toolkit
parseDecimal :: T.Text -> Possibly Int
parseDecimal :: Text -> Possibly Int
parseDecimal Text
txt = ([Char] -> Possibly Int)
-> (Int -> Possibly Int) -> Possibly Int -> Possibly Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Possibly Int
forall a b. a -> Either a b
Left ([Char] -> Possibly Int)
-> ([Char] -> [Char]) -> [Char] -> Possibly Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
typeError [Char]
"integer") Int -> Possibly Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Possibly Int -> Possibly Int) -> Possibly Int -> Possibly Int
forall a b. (a -> b) -> a -> b
$ do
    (Int
x,Text
r) <- Reader Int -> Reader Int
forall a. Num a => Reader a -> Reader a
signed Reader Int
forall a. Integral a => Reader a
decimal Text
txt
    case Text -> Bool
T.null Text
r of
      Bool
True  -> Int -> Possibly Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
x
      Bool
False -> [Char] -> Possibly Int
forall a b. a -> Either a b
Left ([Char] -> Possibly Int) -> [Char] -> Possibly Int
forall a b. (a -> b) -> a -> b
$ [Char]
"residual input: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
r

-- | Convert a 'Read' parser into a 'TextParsable'
--
-- Examples:
--
-- >>> parseTextRead @Int "Int" (T.pack "10")
-- Right 10
--
-- >>> parseTextRead @Int "Int" (T.pack "a")
-- Left "failed to parse Int: \"a\""
--
parseTextRead :: Read a
              => String   -- ^ name of type bing parsed (for failure message)
              -> T.Text   -- ^ 'T.Text' to be parsed
              -> Possibly a
parseTextRead :: [Char] -> Text -> Possibly a
parseTextRead = (Text -> Maybe a) -> [Char] -> Text -> Possibly a
forall a. (Text -> Maybe a) -> [Char] -> Text -> Possibly a
parseTextUsing ([Char] -> Maybe a
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe a) -> (Text -> [Char]) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack)

-- | Use the given function to turn the input string into a 'TextParsable'
--
-- Examples:
--
-- >>> parseTextUsing @Int (readMaybe . T.unpack) "Int" (T.pack "10")
-- Right 10
--
-- >>> parseTextUsing @Int (readMaybe . T.unpack) "Int" (T.pack "a")
-- Left "failed to parse Int: \"a\""
--
parseTextUsing :: (T.Text -> Maybe a)
               -> String   -- ^ name of type bing parsed (for failure message)
               -> T.Text   -- ^ 'T.Text' to be parsed
               -> Possibly a
parseTextUsing :: (Text -> Maybe a) -> [Char] -> Text -> Possibly a
parseTextUsing Text -> Maybe a
maybeParser [Char]
ty_s Text
txt =
    Possibly a -> (a -> Possibly a) -> Maybe a -> Possibly a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Possibly a
forall a b. a -> Either a b
Left ([Char] -> Possibly a) -> [Char] -> Possibly a
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
typeError [Char]
ty_s ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
str) a -> Possibly a
forall a b. b -> Either a b
Right (Maybe a -> Possibly a) -> Maybe a -> Possibly a
forall a b. (a -> b) -> a -> b
$ Text -> Maybe a
maybeParser Text
txt
  where
    str :: [Char]
str = Text -> [Char]
T.unpack Text
txt

typeError :: String -> String -> String
typeError :: [Char] -> [Char] -> [Char]
typeError [Char]
ty_s [Char]
msg = [Char]
"failed to parse "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
ty_s[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
": "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
msg

-------------------------------------------------------------------------------
-- support for parsing UTCTime (see enum-text#1)
-------------------------------------------------------------------------------

-- The following has been cribbed from the \"Data.API.Time\" module from the
-- \"api-tools\" package.

-- | Parse text as a 'UTCTime' in ISO 8601 format or a number of slight
-- variations thereof (the @T@ may be replaced with a space, and the seconds,
-- milliseconds and/or @Z@ timezone indicator may optionally be omitted).
--
-- Time zone designations other than @Z@ for UTC are not currently supported.
parseUTC :: T.Text -> Maybe UTCTime
parseUTC :: Text -> Maybe UTCTime
parseUTC Text
t = case Parser UTCTime -> Text -> Possibly UTCTime
forall a. Parser a -> Text -> Either [Char] a
AP.parseOnly (Parser UTCTime
parserUTCTime Parser UTCTime -> Parser Text () -> Parser UTCTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
AP.endOfInput) Text
t of
    Left [Char]
_  -> Maybe UTCTime
forall a. Maybe a
Nothing
    Right UTCTime
r -> UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
r

parserUTCTime :: AP.Parser UTCTime
parserUTCTime :: Parser UTCTime
parserUTCTime = do
    Day
day <- Parser Day
parserDay
    Parser Text () -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text () -> Parser Text ())
-> Parser Text () -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Text ()
AP.skip (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'T')
    DiffTime
time <- Parser DiffTime
parserTime
    Maybe NominalDiffTime
mb_offset <- Parser (Maybe NominalDiffTime)
parserTimeZone
    UTCTime -> Parser UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((UTCTime -> UTCTime)
-> (NominalDiffTime -> UTCTime -> UTCTime)
-> Maybe NominalDiffTime
-> UTCTime
-> UTCTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTCTime -> UTCTime
forall a. a -> a
id NominalDiffTime -> UTCTime -> UTCTime
addUTCTime Maybe NominalDiffTime
mb_offset (UTCTime -> UTCTime) -> UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime Day
day DiffTime
time)

-- | Parser for @YYYY-MM-DD@ format.
parserDay :: AP.Parser Day
parserDay :: Parser Day
parserDay = do
    Int
y :: Int <- Parser Int
forall a. Integral a => Parser a
AP.decimal Parser Int -> Parser Text Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
AP.char Char
'-'
    Int
m :: Int <- Parser Int
forall a. Integral a => Parser a
AP.decimal Parser Int -> Parser Text Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
AP.char Char
'-'
    Int
d :: Int <- Parser Int
forall a. Integral a => Parser a
AP.decimal
    case Integer -> Int -> Int -> Maybe Day
fromGregorianValid (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) Int
m Int
d of
        Just Day
x  -> Day -> Parser Day
forall (f :: * -> *) a. Applicative f => a -> f a
pure Day
x
        Maybe Day
Nothing -> [Char] -> Parser Day
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid date"

-- | Parser for times in the format @HH:MM@, @HH:MM:SS@ or @HH:MM:SS.QQQ...@.
parserTime :: AP.Parser DiffTime
parserTime :: Parser DiffTime
parserTime = do
    Int
h :: Int <- Parser Int
forall a. Integral a => Parser a
AP.decimal
    Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
AP.char Char
':'
    Int
m :: Int <- Parser Int
forall a. Integral a => Parser a
AP.decimal
    Maybe Char
c <- Parser (Maybe Char)
AP.peekChar
    Scientific
s <- case Maybe Char
c of
           Just Char
':' -> Parser Text Char
AP.anyChar Parser Text Char
-> Parser Text Scientific -> Parser Text Scientific
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Scientific
AP.scientific
           Maybe Char
_        -> Scientific -> Parser Text Scientific
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
0
    case Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger (Scientific
10Scientific -> Int -> Scientific
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
12::Int) Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
* (Scientific
s Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
+ Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
60Int -> Int -> Int
forall a. Num a => a -> a -> a
*(Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
60Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
h)))) of
      Just Int
n -> DiffTime -> Parser DiffTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> DiffTime
picosecondsToDiffTime (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n :: Int)))
      Maybe Int
Nothing -> [Char] -> Parser DiffTime
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"seconds out of range"

-- | Parser for time zone indications such as @Z@, @ UTC@ or an explicit offset
-- like @+HH:MM@ or @-HH@.  Returns 'Nothing' for UTC.  Local times (without a
-- timezone designator) are assumed to be UTC.  If there is an explicit offset,
-- returns its negation.
parserTimeZone :: AP.Parser (Maybe NominalDiffTime)
parserTimeZone :: Parser (Maybe NominalDiffTime)
parserTimeZone = do
    Char
c <- Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
AP.option Char
'Z' Parser Text Char
AP.anyChar
    case Char
c of
      Char
'Z' -> Maybe NominalDiffTime -> Parser (Maybe NominalDiffTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NominalDiffTime
forall a. Maybe a
Nothing
      Char
' ' -> Parser Text Text
"UTC" Parser Text Text
-> Parser (Maybe NominalDiffTime) -> Parser (Maybe NominalDiffTime)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe NominalDiffTime -> Parser (Maybe NominalDiffTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NominalDiffTime
forall a. Maybe a
Nothing
      Char
'+' -> Bool -> Parser (Maybe NominalDiffTime)
forall a. Num a => Bool -> Parser Text (Maybe a)
parse_offset Bool
True
      Char
'-' -> Bool -> Parser (Maybe NominalDiffTime)
forall a. Num a => Bool -> Parser Text (Maybe a)
parse_offset Bool
False
      Char
_   -> [Char] -> Parser (Maybe NominalDiffTime)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"unexpected time zone character"
  where
    parse_offset :: Bool -> Parser Text (Maybe a)
parse_offset Bool
pos = do
      Int
hh :: Int <- [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> Parser Text [Char] -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser Text Char -> Parser Text [Char]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
AP.count Int
2 Parser Text Char
AP.digit
      () -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
AP.option () ((Char -> Bool) -> Parser Text ()
AP.skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'))
      Int
mm :: Int <- Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
AP.option Int
0 ([Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> Parser Text [Char] -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser Text Char -> Parser Text [Char]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
AP.count Int
2 Parser Text Char
AP.digit)
      let v :: Int
v = (if Bool
pos then Int -> Int
forall a. Num a => a -> a
negate else Int -> Int
forall a. a -> a
id) ((Int
hhInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mm) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60)
      Maybe a -> Parser Text (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v))