{-# LANGUAGE OverloadedStrings #-}
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
)
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
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
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')
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"
(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 #-}