{-|
Module      : Gargantext.Core.Text.Corpus.Parsers.Date
Description : Some utils to parse dates
Copyright   : (c) CNRS 2017-present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}


module Gargantext.Core.Text.Corpus.Parsers.Date.Parsec
  where

import Data.Either (Either)
import Data.Fixed (Fixed (MkFixed))
import Data.String (String)
import Data.Text (Text, unpack)
import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..), TimeOfDay(..))
import Data.Time.Calendar (Day, fromGregorian)
import Gargantext.Prelude
import Prelude (toInteger, (++))
import Text.Parsec.Error (ParseError)
import Text.Parsec.Prim (Stream, ParsecT)
import Text.Parsec.String (Parser)
import Text.ParserCombinators.Parsec (many1, noneOf, anyChar, char, oneOf)
import Text.XML.HXT.DOM.Util (decimalStringToInt)
import qualified Text.ParserCombinators.Parsec (parse)

-- | Permit to transform a String to an Int in a monadic context
wrapDST :: Monad m => String -> m Int
wrapDST :: String -> m Int
wrapDST = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> (String -> Int) -> String -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
decimalStringToInt

-- | Generic parser which take at least one element not given in argument
many1NoneOf :: Stream s m Char => [Char] -> ParsecT s u m [Char]
many1NoneOf :: String -> ParsecT s u m String
many1NoneOf = (ParsecT s u m Char -> ParsecT s u m String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT s u m Char -> ParsecT s u m String)
-> (String -> ParsecT s u m Char) -> String -> ParsecT s u m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf)

getMultiplicator :: Int -> Int
getMultiplicator :: Int -> Int
getMultiplicator Int
a
  | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
a = Int
1
  | Bool
otherwise = Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int -> Int
getMultiplicator (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
a Int
10)

-- | Parser for date format y-m-d
parseGregorian :: Parser Day
parseGregorian :: Parser Day
parseGregorian  = do
        Int
y <- String -> ParsecT String () Identity Int
forall (m :: * -> *). Monad m => String -> m Int
wrapDST (String -> ParsecT String () Identity Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
many1NoneOf [Char
'-']
        Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-'
        Int
m <- String -> ParsecT String () Identity Int
forall (m :: * -> *). Monad m => String -> m Int
wrapDST (String -> ParsecT String () Identity Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
many1NoneOf [Char
'-']
        Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-'
        Int
d <- String -> ParsecT String () Identity Int
forall (m :: * -> *). Monad m => String -> m Int
wrapDST (String -> ParsecT String () Identity Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
many1NoneOf [Char
'T']
        Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'T'
        Day -> Parser Day
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> Parser Day) -> Day -> Parser Day
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
y) Int
m Int
d

---- | Parser for time format h:m:s
parseTimeOfDay :: Parser TimeOfDay
parseTimeOfDay :: Parser TimeOfDay
parseTimeOfDay = do
        Int
h <- String -> ParsecT String () Identity Int
forall (m :: * -> *). Monad m => String -> m Int
wrapDST (String -> ParsecT String () Identity Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
many1NoneOf [Char
':']
        Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
        Int
m <- String -> ParsecT String () Identity Int
forall (m :: * -> *). Monad m => String -> m Int
wrapDST (String -> ParsecT String () Identity Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
many1NoneOf [Char
':']
        Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
        String
r <- String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
many1NoneOf [Char
'.']
        Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
        String
dec <- String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
many1NoneOf [Char
'+', Char
'-']
        let (Int
nb, Int
l) = (String -> Int
decimalStringToInt (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dec, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
dec)
            seconds :: Int
seconds = Int
nb Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
12Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
l)
        TimeOfDay -> Parser TimeOfDay
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeOfDay -> Parser TimeOfDay) -> TimeOfDay -> Parser TimeOfDay
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
h Int
m (Integer -> Pico
forall k (a :: k). Integer -> Fixed a
MkFixed (Integer -> Pico) -> (Int -> Integer) -> Int -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Pico) -> Int -> Pico
forall a b. (a -> b) -> a -> b
$ Int
seconds)


-- | Parser for timezone format +hh:mm
parseTimeZone :: Parser TimeZone
parseTimeZone :: Parser TimeZone
parseTimeZone = do
        Char
sign <- String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf [Char
'+', Char
'-']
        Int
h <- String -> ParsecT String () Identity Int
forall (m :: * -> *). Monad m => String -> m Int
wrapDST (String -> ParsecT String () Identity Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
many1NoneOf [Char
':']
        Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
        Int
m <- String -> ParsecT String () Identity Int
forall (m :: * -> *). Monad m => String -> m Int
wrapDST (String -> ParsecT String () Identity Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String () Identity Char
 -> ParsecT String () Identity String)
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar)
        let timeInMinute :: Int
timeInMinute = if Char
sign Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' then Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m else -Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m
         in TimeZone -> Parser TimeZone
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeZone -> Parser TimeZone) -> TimeZone -> Parser TimeZone
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> String -> TimeZone
TimeZone Int
timeInMinute Bool
False String
"CET"

---- | Parser which use parseGregorian, parseTimeOfDay and parseTimeZone to create a ZonedTime
parseZonedTime :: Parser ZonedTime
parseZonedTime :: Parser ZonedTime
parseZonedTime= do
        Day
d <- Parser Day
parseGregorian
        TimeOfDay
tod <- Parser TimeOfDay
parseTimeOfDay
        TimeZone
tz <- Parser TimeZone
parseTimeZone
        ZonedTime -> Parser ZonedTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonedTime -> Parser ZonedTime) -> ZonedTime -> Parser ZonedTime
forall a b. (a -> b) -> a -> b
$ LocalTime -> TimeZone -> ZonedTime
ZonedTime (Day -> TimeOfDay -> LocalTime
LocalTime Day
d (TimeOfDay
tod)) TimeZone
tz

---- | Opposite of toRFC3339
fromRFC3339 :: Text -> Either ParseError ZonedTime
fromRFC3339 :: Text -> Either ParseError ZonedTime
fromRFC3339 Text
t = Parser ZonedTime -> String -> String -> Either ParseError ZonedTime
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
Text.ParserCombinators.Parsec.parse Parser ZonedTime
parseZonedTime String
"ERROR: Couldn't parse zoned time." String
input
        where input :: String
input = Text -> String
unpack Text
t