{-# LANGUAGE OverloadedStrings #-}

-- | This code is adapted from sqlite-simple package
module Data.Text.Time.Parse
    ( parseISODateTime
    , parseUTCTimeOrError
    ) where

import           Control.Applicative
import           Control.Monad (when)
import qualified Data.Attoparsec.Text as A
import           Data.Bits ((.&.))
import           Data.Char (isDigit, ord)
import qualified Data.Text as T
import           Data.Time ( Day
                           , TimeOfDay
                           , UTCTime(..)
                           , fromGregorian
                           , fromGregorianValid
                           , makeTimeOfDayValid
                           , midnight
                           , timeOfDayToTime
                           )


-- | Parse ISO date. If date can't be parsed then this function will return default value instead of error
parseISODateTime :: T.Text -> UTCTime
parseISODateTime :: Text -> UTCTime
parseISODateTime Text
str =
    case Text -> Either String UTCTime
parseUTCTimeOrError Text
str of
        Left String
_ -> UTCTime
defaultUTCTime
        Right UTCTime
dt -> UTCTime
dt


-- | Default time if date can't be parsed
defaultUTCTime :: UTCTime
defaultUTCTime :: UTCTime
defaultUTCTime = Day -> DiffTime -> UTCTime
UTCTime (Year -> Int -> Int -> Day
fromGregorian Year
1 Int
1 Int
1) DiffTime
0


parseUTCTimeOrError :: T.Text -> Either String UTCTime
parseUTCTimeOrError :: Text -> Either String UTCTime
parseUTCTimeOrError = forall a. Parser a -> Text -> Either String a
A.parseOnly Parser UTCTime
getUTCTime

-- | Create UTCTime parser for ISO date time
-- This code is based on code from sqlite-simple package
--
getUTCTime :: A.Parser UTCTime
getUTCTime :: Parser UTCTime
getUTCTime = do
    Day
day  <- Parser Day
getDay
    TimeOfDay
time <- ((Char -> Parser Text Char
A.char Char
' ' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Char
A.char Char
'T') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text TimeOfDay
getTimeOfDay) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeOfDay
midnight
    let time' :: DiffTime
time' = TimeOfDay -> DiffTime
timeOfDayToTime TimeOfDay
time
    forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> DiffTime -> UTCTime
UTCTime Day
day DiffTime
time')


-- | Date parser
getDay :: A.Parser Day
getDay :: Parser Day
getDay = do
    Text
yearStr <- (Char -> Bool) -> Parser Text
A.takeWhile Char -> Bool
isDigit

    let year :: Year
year = forall n. Num n => Text -> n
toNum Text
yearStr
    Int
month <- (Char -> Parser Text Char
A.char Char
'-' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall n. Num n => String -> Parser n
digits String
"month") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
    Int
day   <- (Char -> Parser Text Char
A.char Char
'-' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall n. Num n => String -> Parser n
digits String
"day") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
    case Year -> Int -> Int -> Maybe Day
fromGregorianValid Year
year Int
month Int
day of
      Maybe Day
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid date"
      Just Day
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Day
x


getTimeOfDay :: A.Parser TimeOfDay
getTimeOfDay :: Parser Text TimeOfDay
getTimeOfDay = do
    Int
hour   <- forall n. Num n => String -> Parser n
digits String
"hours"
    Char
_      <- Char -> Parser Text Char
A.char Char
':'
    Int
minute <- forall n. Num n => String -> Parser n
digits String
"minutes"
    -- Allow omission of seconds.  If seconds is omitted, don't try to
    -- parse the sub-second part.
    (Pico
sec,Pico
subsec)
           <- ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Text Char
A.char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall n. Num n => String -> Parser n
digits String
"seconds") forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Pico
fract) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pico
0,Pico
0)

    let picos' :: Pico
picos' = Pico
sec forall a. Num a => a -> a -> a
+ Pico
subsec

    case Int -> Int -> Pico -> Maybe TimeOfDay
makeTimeOfDayValid Int
hour Int
minute Pico
picos' of
      Maybe TimeOfDay
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid time of day"
      Just TimeOfDay
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! TimeOfDay
x

    where
      fract :: Parser Text Pico
fract =
        (Char -> Parser Text Char
A.char Char
'.' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall a. Fractional a => Text -> a
decimal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
A.takeWhile1 Char -> Bool
isDigit)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pico
0


toNum :: Num n => T.Text -> n
toNum :: forall n. Num n => Text -> n
toNum = forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' (\n
a Char
c -> n
10forall a. Num a => a -> a -> a
*n
a forall a. Num a => a -> a -> a
+ forall n. Num n => Char -> n
digit Char
c) n
0
{-# INLINE toNum #-}

digit :: Num n => Char -> n
digit :: forall n. Num n => Char -> n
digit Char
c = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c forall a. Bits a => a -> a -> a
.&. Int
0x0f)
{-# INLINE digit #-}

digits :: Num n => String -> A.Parser n
digits :: forall n. Num n => String -> Parser n
digits String
msg = do
  Char
x <- Parser Text Char
A.anyChar
  Char
y <- Parser Text Char
A.anyChar
  if Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
y
  then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (n
10 forall a. Num a => a -> a -> a
* forall n. Num n => Char -> n
digit Char
x forall a. Num a => a -> a -> a
+ forall n. Num n => Char -> n
digit Char
y)
  else forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
msg forall a. [a] -> [a] -> [a]
++ String
" is not 2 digits")
{-# INLINE digits #-}

decimal :: Fractional a => T.Text -> a
decimal :: forall a. Fractional a => Text -> a
decimal Text
str = forall n. Num n => Text -> n
toNum Text
str forall a. Fractional a => a -> a -> a
/ a
10forall a b. (Num a, Integral b) => a -> b -> a
^(Text -> Int
T.length Text
str)
{-# INLINE decimal #-}