src/Gargantext/Parsers/Date.hs

   1 {-|
   2 Module      : Gargantext.Parsers.Date
   3 Description : Some utils to parse dates
   4 Copyright   : (c) CNRS 2017-present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 According to the language of the text, parseDate1 returns date as Text:
  11
  12 TODO : Add some tests
  13 import Gargantext.Parsers.Date as DGP
  14 DGP.parseDate1 DGP.FR "12 avril 2010" == "2010-04-12T00:00:00.000+00:00"
  15 -}
  16
  17 {-# LANGUAGE OverloadedStrings #-}
  18 {-# LANGUAGE FlexibleContexts #-}
  19 {-# LANGUAGE NoImplicitPrelude #-}
  20
  21 module Gargantext.Parsers.Date (parseDate1, Lang(FR, EN), parseDate, fromRFC3339, parseTimeOfDay, getMultiplicator) where
  22
  23 import Gargantext.Prelude
  24 import Prelude (toInteger, div, otherwise, (++))
  25 --import Gargantext.Types.Main as G
  26
  27 import Data.Time.Clock (UTCTime, getCurrentTime)
  28 import Data.Time.LocalTime.TimeZone.Series (zonedTimeToZoneSeriesTime)
  29 import Data.Time.LocalTime (utc)
  30 import Duckling.Resolve (fromUTC, Context(Context, referenceTime, locale)
  31                         , DucklingTime(DucklingTime)
  32                         )
  33 import Duckling.Core (makeLocale, Lang(FR,EN), Some(This), Dimension(Time))
  34 import Duckling.Types (jsonValue, Entity)
  35
  36 import Duckling.Api (analyze, parse)
  37 import qualified Data.HashSet as HashSet
  38 import qualified Data.Aeson   as Json
  39 import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..), TimeOfDay(..), getCurrentTimeZone)
  40 import Data.Time.Calendar (Day, fromGregorian)
  41 import Data.Fixed (Fixed (MkFixed))
  42 import Data.Foldable (length)
  43 import Data.HashMap.Strict as HM hiding (map)
  44
  45 import Control.Monad ((=<<))
  46 import Data.Either (Either)
  47 import Data.String (String)
  48 import Data.Text (Text, unpack)
  49 -- import Duckling.Engine (parseAndResolve)
  50 -- import Duckling.Rules (rulesFor)
  51 -- import Duckling.Debug as DB
  52
  53 import Duckling.Types (ResolvedToken)
  54 import Safe (headMay)
  55 import System.IO.Unsafe (unsafePerformIO)
  56
  57 import Text.Parsec.Error (ParseError)
  58 import Text.Parsec.String (Parser)
  59 import Text.Parsec.Prim (Stream, ParsecT)
  60 import qualified Text.ParserCombinators.Parsec (parse)
  61 import Text.ParserCombinators.Parsec (many1, noneOf, anyChar, char, oneOf)
  62
  63 import Text.XML.HXT.DOM.Util (decimalStringToInt)
  64 -- TODO add Paris at Duckling.Locale Region datatype
  65 -- | To get Homogeinity of the languages
  66 --   TODO : put this in a more generic place in the source code
  67 --parserLang :: G.Language -> Lang
  68 --parserLang G.FR = FR
  69 --parserLang G.EN = EN
  70
  71
  72 -- | Final Date parser API
  73 -- IO can be avoided here:
  74 -- currentContext :: Lang -> IO Context
  75 -- currentContext lang = localContext lang <$> utcToDucklingTime <$> getCurrentTime
  76 -- parseDate1 :: Context -> Text -> SomeErrorHandling Text
  77
  78 parseDate1 :: Lang -> Text -> IO Text
  79 parseDate1 lang text = do
  80     maybeJson <- map jsonValue <$> parseDateWithDuckling lang text
  81     case headMay maybeJson of
  82       Just (Json.Object object) -> case HM.lookup "value" object of
  83                                      Just (Json.String date) -> pure date
  84                                      Just _                  -> panic "ParseDate ERROR: should be a json String"
  85                                      Nothing                 -> panic "ParseDate ERROR: no date found"
  86       _                         -> panic "ParseDate ERROR: type error"
  87
  88
  89
  90 -- | Current Time in DucklingTime format
  91 -- TODO : get local Time in a more generic way
  92 utcToDucklingTime :: UTCTime -> DucklingTime
  93 utcToDucklingTime time = DucklingTime . zonedTimeToZoneSeriesTime $ fromUTC time utc
  94
  95 -- | Local Context which depends on Lang and Time
  96 localContext :: Lang -> DucklingTime -> Context
  97 localContext lang dt = Context {referenceTime = dt, locale = makeLocale lang Nothing}
  98
  99 -- | Date parser with Duckling
 100 parseDateWithDuckling :: Lang -> Text -> IO [ResolvedToken]
 101 parseDateWithDuckling lang input = do
 102     contxt <- localContext lang <$> utcToDucklingTime <$> getCurrentTime
 103     --pure $ parseAndResolve (rulesFor (locale ctx) (HashSet.fromList [(This Time)])) input ctx
 104     pure $ analyze input contxt $ HashSet.fromList [(This Time)]
 105
 106
 107 parseDate :: Lang -> Text -> IO [Entity]
 108 parseDate lang input = do
 109     context <- localContext lang <$> utcToDucklingTime <$> getCurrentTime
 110     pure $ parse input context [(This Time)]
 111
 112 -- | Permit to transform a String to an Int in a monadic context
 113 wrapDST :: Monad m => String -> m Int
 114 wrapDST = (return . decimalStringToInt)
 115
 116 -- | Generic parser which take at least one element not given in argument
 117 many1NoneOf :: Stream s m Char => [Char] -> ParsecT s u m [Char]
 118 many1NoneOf = (many1 . noneOf)
 119
 120 getMultiplicator :: Int -> Int
 121 getMultiplicator a
 122   | 0 >= a = 1
 123   | otherwise = 10 * (getMultiplicator $ div a 10)
 124
 125 -- | Parser for date format y-m-d
 126 parseGregorian :: Parser Day
 127 parseGregorian  = do
 128         y <- wrapDST =<< many1NoneOf ['-']
 129         _ <- char '-'
 130         m <- wrapDST =<< many1NoneOf ['-']
 131         _ <- char '-'
 132         d <- wrapDST =<< many1NoneOf ['T']
 133         _ <- char 'T'
 134         return $ fromGregorian (toInteger y) m d
 135
 136 -- | Parser for time format h:m:s
 137 parseTimeOfDay :: Parser TimeOfDay
 138 parseTimeOfDay = do
 139         h <- wrapDST =<< many1NoneOf [':']
 140         _ <- char ':'
 141         m <- wrapDST =<< many1NoneOf [':']
 142         _ <- char ':'
 143         r <- many1NoneOf ['.']
 144         _ <- char '.'
 145         dec <- many1NoneOf ['+', '-']
 146         let (nb, l) = (decimalStringToInt $ r ++ dec, length dec)
 147             seconds = nb * 10^(12-l)
 148         return $ TimeOfDay h m (MkFixed . toInteger $ seconds)
 149
 150
 151 -- | Parser for timezone format +hh:mm
 152 parseTimeZone :: Parser TimeZone
 153 parseTimeZone = do
 154         sign <- oneOf ['+', '-']
 155         h <- wrapDST =<< many1NoneOf [':']
 156         _ <- char ':'
 157         m <- wrapDST =<< (many1 $ anyChar)
 158         let (TimeZone _ s n) = unsafePerformIO getCurrentTimeZone
 159         let timeInMinute = if sign == '+' then h * 60 + m else -h * 60 - m
 160          in return $ TimeZone timeInMinute s n
 161
 162 -- | Parser which use parseGregorian, parseTimeOfDay and parseTimeZone to create a ZonedTime
 163 parseZonedTime :: Parser ZonedTime
 164 parseZonedTime= do
 165         d <- parseGregorian
 166         tod <- parseTimeOfDay
 167         tz <- parseTimeZone
 168         return $ ZonedTime (LocalTime d (tod)) tz
 169
 170 -- | Opposite of toRFC3339
 171 fromRFC3339 :: Text -> Either ParseError ZonedTime
 172 fromRFC3339 t = Text.ParserCombinators.Parsec.parse parseZonedTime "ERROR: Couldn't parse zoned time." input
 173         where input = unpack t