DateTime.purs

-- | This is a subset of common format/parse strings currently supported.
-- | 
-- | + `YYYY` - Full Year      (1999)
-- | + `YY`   - 2 digit year   (99)
-- | + `MMMM` - Full Month     (January)
-- | + `MMM`  - Short Month    (Jan)
-- | + `DD`   - Padded Day     (02)
-- | + `D`    - Day of month   (2)
-- | + `X`    - Unix Timestamp (1506875681)
-- | + `E`    - Day of Week    (2)
-- | + `dddd` - DOW Name       (Monday)
-- | + `ddd`  - DOW Name Short (Mon)
-- | + `HH`   - 24 Hour        (13)
-- | + `hh`   - 12 Hour        (1)
-- | + `a`    - Meridiem       (am/pm)
-- | + `mm`   - Minutes Padded (02)
-- | + `m`    - Minutes        (2)
-- | + `ss`   - Seconds Padded (02)
-- | + `s`    - Seconds        (2)
-- | + `S`    - MilliSeconds   (4)
-- | + `SS`   - MilliSeconds   (04)
-- | + `SSS`  - MilliSeconds   (004)
-- |
-- | Full list is defined [here](https://github.com/slamdata/purescript-formatters/blob/master/src/Data/Formatter/DateTime.purs)
module Data.Formatter.DateTime
  ( Formatter
  , FormatterCommand(..)
  , Meridiem
  , printFormatter
  , printFormatterCommand
  , parseFormatString
  , format
  , formatDateTime
  , unformat
  , unformatDateTime
  , unformatParser
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (class Alternative)
import Control.Apply (applySecond, lift2)
import Control.Lazy as Z
import Control.Monad.Reader.Trans (ReaderT, runReaderT, ask)
import Control.Monad.State (State, modify_, put, runState)
import Control.Monad.Trans.Class (lift)
import Data.Array as Array
import Data.Date as D
import Data.DateTime as DT
import Data.DateTime.Instant (instant, toDateTime, fromDateTime, unInstant)
import Data.Either (Either(..), either)
import Data.Enum (fromEnum, toEnum)
import Data.Foldable (foldMap, for_)
import Data.Formatter.Internal (foldDigits)
import Data.Formatter.Parser.Number (parseDigit)
import Data.Formatter.Parser.Utils (runP, oneOfAs)
import Data.Generic.Rep (class Generic)
import Data.Int as Int
import Data.List as List
import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe)
import Data.Newtype (unwrap)
import Data.Ord (abs)
import Data.Show.Generic (genericShow)
import Data.String as Str
import Data.String.CodeUnits as CU
import Data.Time as T
import Data.Time.Duration as Dur
import Data.Tuple (Tuple(..))
import Parsing as P
import Parsing.Combinators as PC
import Parsing.String as PS
import Parsing.String.Basic as PSB

-- | One part of a DateTime `Formatter`. Use `Placeholder` for 
-- | any static portion of the format, such as whitespace or separators `-` or `:`.
data FormatterCommand
  = YearFull
  | YearTwoDigits
  | YearAbsolute
  | MonthFull
  | MonthShort
  | MonthTwoDigits
  | DayOfMonthTwoDigits
  | DayOfMonth
  | UnixTimestamp
  | DayOfWeek
  | DayOfWeekName
  | DayOfWeekNameShort
  | Hours24
  | Hours12
  | Meridiem
  | Minutes
  | MinutesTwoDigits
  | Seconds
  | SecondsTwoDigits
  | Milliseconds
  | MillisecondsShort
  | MillisecondsTwoDigits
  | Placeholder String

derive instance eqFormatterCommand :: Eq FormatterCommand
derive instance ordFormatterCommand :: Ord FormatterCommand
derive instance genericFormatter :: Generic FormatterCommand _
instance showFormatter :: Show FormatterCommand where
  show = genericShow

-- | A description of a string format for dates and times.
-- | Functions such as `format` and `unformat` use a `Formatter` 
-- | such as `(YearFull : MonthTwoDigits : DayOfMonthTwoDigits : Nil)`
-- | in place of a format string such as `"YYYYMMDD"`.
type Formatter = List.List FormatterCommand

printFormatterCommand :: FormatterCommand -> String
printFormatterCommand = case _ of
  YearFull -> "YYYY"
  YearTwoDigits -> "YY"
  YearAbsolute -> "Y"
  MonthFull -> "MMMM"
  MonthShort -> "MMM"
  MonthTwoDigits -> "MM"
  DayOfMonthTwoDigits -> "DD"
  DayOfMonth -> "D"
  UnixTimestamp -> "X"
  DayOfWeek -> "E"
  DayOfWeekName -> "dddd"
  DayOfWeekNameShort -> "ddd"
  Hours24 -> "HH"
  Hours12 -> "hh"
  Meridiem -> "a"
  Minutes -> "m"
  MinutesTwoDigits -> "mm"
  Seconds -> "s"
  SecondsTwoDigits -> "ss"
  MillisecondsShort -> "S"
  MillisecondsTwoDigits -> "SS"
  Milliseconds -> "SSS"
  Placeholder s | needsEscaping s -> "[" <> s <> "]"
  Placeholder s -> s
  where
  needsEscaping = CU.toCharArray >>> Array.any (flip Array.elem formatCharacters)

formatCharacters :: Array Char
formatCharacters = CU.toCharArray "YMDEHhamsS"

-- | The format string representation of a `Formatter`.
-- | 
-- | `show (Hours24 : MinutesTwoDigits : Nil) = "(Hours24 : MinutesTwoDigits : Nil)"`
-- | 
-- | while `printFormatter (Hours24 : MinutesTwoDigits : Nil) = "HHmm"`.
printFormatter :: Formatter -> String
printFormatter = foldMap printFormatterCommand

-- | Attempt to parse a `String` as a `Formatter`. 
parseFormatString :: String -> Either String Formatter
parseFormatString = runP formatParser

escapedPlaceholderContent :: P.Parser String String
escapedPlaceholderContent = PC.between (PS.char '[') (PS.char ']') (anyStringUntil [ '[', ']' ])
  where
  anyStringUntil cs = Array.some (PSB.noneOf cs) <#> CU.fromCharArray

unEscapedPlaceholderContent :: P.Parser String String
unEscapedPlaceholderContent =
  (formatCharacters <> [ '[', ']' ])
    # PSB.noneOf
    # Array.some
    <#> CU.fromCharArray

placeholderContent :: P.Parser String String
placeholderContent =
  Array.fold <$> Array.some (PC.try escapedPlaceholderContent <|> unEscapedPlaceholderContent)

formatterCommandParser :: P.Parser String FormatterCommand
formatterCommandParser =
  (PC.try <<< PS.string) `oneOfAs`
    [ Tuple "YYYY" YearFull
    , Tuple "YY" YearTwoDigits
    , Tuple "Y" YearAbsolute
    , Tuple "MMMM" MonthFull
    , Tuple "MMM" MonthShort
    , Tuple "MM" MonthTwoDigits
    , Tuple "DD" DayOfMonthTwoDigits
    , Tuple "D" DayOfMonth
    , Tuple "E" DayOfWeek
    , Tuple "X" UnixTimestamp
    , Tuple "dddd" DayOfWeekName
    , Tuple "ddd" DayOfWeekNameShort
    , Tuple "HH" Hours24
    , Tuple "hh" Hours12
    , Tuple "a" Meridiem
    , Tuple "mm" MinutesTwoDigits
    , Tuple "m" Minutes
    , Tuple "ss" SecondsTwoDigits
    , Tuple "s" Seconds
    , Tuple "SSS" Milliseconds
    , Tuple "SS" MillisecondsTwoDigits
    , Tuple "S" MillisecondsShort
    ] <|> (Placeholder <$> placeholderContent)

formatParser :: P.Parser String Formatter
formatParser = List.some formatterCommandParser

-- | Formatting function that accepts a number that is a year,
-- | and strips away the non-significant digits, leaving only the
-- | ones and tens positions.
formatYearTwoDigits :: Int -> String
formatYearTwoDigits i = case dateLength of
  1 -> "0" <> dateString
  2 -> dateString
  _ -> Str.drop (dateLength - 2) dateString
  where
  dateString = show $ abs i
  dateLength = Str.length $ dateString

fix12 :: Int -> Int
fix12 h = if h == 0 then 12 else h

formatCommand :: DT.DateTime -> FormatterCommand -> String
formatCommand dt@(DT.DateTime d t) = case _ of
  YearFull -> padQuadrupleDigit $ fromEnum $ D.year d
  YearTwoDigits -> formatYearTwoDigits $ fromEnum $ D.year d
  YearAbsolute -> show $ fromEnum $ D.year d
  MonthFull -> show $ D.month d
  MonthShort -> printShortMonth $ D.month d
  MonthTwoDigits -> padSingleDigit $ fromEnum $ D.month d
  DayOfMonthTwoDigits -> padSingleDigit $ fromEnum $ D.day d
  DayOfMonth -> show $ fromEnum $ D.day d
  UnixTimestamp -> show $ Int.floor $ (_ / 1000.0) $ unwrap $ unInstant $ fromDateTime dt
  DayOfWeek -> show $ fromEnum $ D.weekday d
  DayOfWeekName -> show $ D.weekday d
  DayOfWeekNameShort -> Str.take 3 $ show $ D.weekday d
  Hours24 -> padSingleDigit (fromEnum $ T.hour t)
  Hours12 -> padSingleDigit $ fix12 $ (fromEnum $ T.hour t) `mod` 12
  Meridiem -> if (fromEnum $ T.hour t) >= 12 then "PM" else "AM"
  Minutes -> show $ fromEnum $ T.minute t
  MinutesTwoDigits -> padSingleDigit <<< fromEnum $ T.minute t
  Seconds -> show $ fromEnum $ T.second t
  SecondsTwoDigits -> padSingleDigit <<< fromEnum $ T.second t
  Milliseconds -> padDoubleDigit <<< fromEnum $ T.millisecond t
  MillisecondsShort -> show $ (_ / 100) $ fromEnum $ T.millisecond t
  MillisecondsTwoDigits -> padSingleDigit $ (_ / 10) $ fromEnum $ T.millisecond t
  Placeholder s -> s

padSingleDigit :: Int -> String
padSingleDigit i
  | i < 0 = "-" <> padSingleDigit (-i)
  | i < 10 = "0" <> (show i)
  | otherwise = show i

padDoubleDigit :: Int -> String
padDoubleDigit i
  | i < 0 = "-" <> padDoubleDigit (-i)
  | i < 10 = "00" <> (show i)
  | i < 100 = "0" <> (show i)
  | otherwise = show i

padQuadrupleDigit :: Int -> String
padQuadrupleDigit i
  | i < 0 = "-" <> padQuadrupleDigit (-i)
  | i < 10 = "000" <> (show i)
  | i < 100 = "00" <> (show i)
  | i < 1000 = "0" <> (show i)
  | otherwise = show i

-- | Format a DateTime according to the format defined in the given `Formatter`.
format :: Formatter -> DT.DateTime -> String
format f d = foldMap (formatCommand d) f

-- | Format a DateTime according to the format defined in the given format string.
-- | If the format string is empty or contains a reserved character such as a single "M" or "H", 
-- | will return a `Left` value. 
-- | Note that any non-reserved `Char` is treated as a placeholder, so while "yyyy-MM-dd" might
-- | not produce the format you want (since "yyyy" isn't a recognized format),
-- | it will still return a `Right` value.
formatDateTime :: String -> DT.DateTime -> Either String String
formatDateTime pattern datetime =
  parseFormatString pattern <#> (_ `format` datetime)

-- | Attempt to parse a String as a DateTime according to the format defined in the 
-- | given `Formatter`. 
unformat :: Formatter -> String -> Either String DT.DateTime
unformat = runP <<< unformatParser

-- | Before or after noon (AM/PM)
data Meridiem = AM | PM

derive instance eqMeridiem :: Eq Meridiem

type UnformatAccum =
  { year :: Maybe Int
  , month :: Maybe Int
  , day :: Maybe Int
  , hour :: Maybe Int
  , minute :: Maybe Int
  , second :: Maybe Int
  , millisecond :: Maybe Int
  , meridiem :: Maybe Meridiem
  }

initialAccum :: UnformatAccum
initialAccum =
  { year: Nothing
  , month: Nothing
  , day: Nothing
  , hour: Nothing
  , minute: Nothing
  , second: Nothing
  , millisecond: Nothing
  , meridiem: Nothing
  }

unformatAccumToDateTime :: UnformatAccum -> Either String DT.DateTime
unformatAccumToDateTime a = applySecond (validAccum a) $
  DT.DateTime
    <$>
      ( D.canonicalDate
          <$> (maybe (Left "Incorrect year") pure $ toEnum $ fromMaybe zero a.year)
          <*> (maybe (Left "Incorrect month") pure $ toEnum $ fromMaybe one a.month)
          <*> (maybe (Left "Incorrect day") pure $ toEnum $ adjustDay a.hour $ fromMaybe one a.day)
      )
    <*>
      ( T.Time
          <$> (maybe (Left "Incorrect hour") pure $ toEnum $ fromMaybe zero $ adjustMeridiem a.meridiem <$> a.hour)
          <*> (maybe (Left "Incorrect minute") pure $ toEnum $ fromMaybe zero a.minute)
          <*> (maybe (Left "Incorrect second") pure $ toEnum $ fromMaybe zero a.second)
          <*> (maybe (Left "Incorrect millisecond") pure $ toEnum $ fromMaybe zero a.millisecond)
      )

validAccum :: UnformatAccum -> Either String Unit
validAccum { hour, minute, second, millisecond } = case hour of
  Just 24 -> for_ [ minute, second, millisecond ] \val ->
    when (fromMaybe 0 val > 0) $ Left "When hour is 24, other time components must be 0"
  _ -> pure unit

adjustDay :: Maybe Int -> Int -> Int
adjustDay (Just 24) n = n + 1
adjustDay _ n = n

adjustMeridiem :: Maybe Meridiem -> Int -> Int
adjustMeridiem (Just AM) 12 = 0
adjustMeridiem (Just PM) 12 = 12
adjustMeridiem (Just PM) n = n + 12
adjustMeridiem (Just AM) n = n
adjustMeridiem Nothing 24 = 0
adjustMeridiem Nothing n = n

exactLength :: forall e. ReaderT { maxLength :: Int, length :: Int | e } (Either String) Unit
exactLength = ask >>= \({ maxLength, length }) -> lift
  if maxLength /= length then
    Left $ "Expected " <> (show maxLength) <> " digits but got " <> (show length)
  else
    Right unit

validateRange :: forall e. Int -> Int -> ReaderT { num :: Int | e } (Either String) Unit
validateRange min max = ask >>= \({ num }) -> lift
  if num < min || num > max then
    Left $ "Number is out of range [ " <> (show min) <> ", " <> (show max) <> " ]"
  else
    Right unit

-- NOTE related discussion: https://github.com/purescript-contrib/purescript-parsing/issues/57
-- | Attempt a computation `n` times, requiring at least one success.
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
takeSome :: forall f a. Alternative f => Z.Lazy (f (List.List a)) => Int -> f a -> f (List.List a)
takeSome 0 _ = pure List.Nil
takeSome n v = List.Cons <$> v <*> Z.defer (\_ -> takeMany (n - 1) v)

-- | Attempt a computation `n` times, returning as many successful results
-- | as possible (possibly zero).
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
takeMany :: forall f a. Alternative f => Z.Lazy (f (List.List a)) => Int -> f a -> f (List.List a)
takeMany 0 _ = pure List.Nil
takeMany n v = takeSome n v <|> pure List.Nil

parseSignedInt
  :: forall m
   . Monad m
  => Int
  -> ReaderT { length :: Int, num :: Int, maxLength :: Int } (Either String) Unit
  -> String
  -> P.ParserT String m Int
parseSignedInt maxLength validators errMsg = do
  isNegative <- isJust <$> PC.optionMaybe (PS.char '-')
  (if isNegative then negate else identity) <$> parseInt maxLength validators errMsg

parseInt
  :: forall m
   . Monad m
  => Int
  -> ReaderT { length :: Int, num :: Int, maxLength :: Int } (Either String) Unit
  -> String
  -> P.ParserT String m Int
parseInt maxLength validators errMsg = do
  ds <- takeSome maxLength parseDigit
  let
    length = List.length ds
    num = foldDigits ds
  case runReaderT validators { length, num, maxLength } of
    Left err -> P.fail $ errMsg <> "(" <> err <> ")"
    Right _ -> pure num

unformatCommandParser :: FormatterCommand -> P.ParserT String (State UnformatAccum) Unit
unformatCommandParser = case _ of
  YearFull -> _ { year = _ } `modifyWithParser`
    (parseSignedInt 4 exactLength "Incorrect full year")
  YearTwoDigits -> _ { year = _ } `modifyWithParser`
    (parseSignedInt 2 exactLength "Incorrect 2-digit year")
  YearAbsolute -> _ { year = _ } `modifyWithParser`
    ( lift2 (*)
        (PC.option 1 $ PC.try $ PS.string "-" <#> (const (-1)))
        (List.some parseDigit <#> foldDigits)
    )
  MonthFull -> _ { month = _ } `modifyWithParser`
    (fromEnum <$> parseMonth)
  MonthShort -> _ { month = _ } `modifyWithParser`
    (fromEnum <$> parseShortMonth)
  MonthTwoDigits -> _ { month = _ } `modifyWithParser`
    (parseInt 2 (validateRange 1 12 <> exactLength) "Incorrect 2-digit month")
  DayOfMonthTwoDigits -> _ { day = _ } `modifyWithParser`
    (parseInt 2 (validateRange 1 31 <> exactLength) "Incorrect day of month")
  DayOfMonth -> _ { day = _ } `modifyWithParser`
    (parseInt 2 (validateRange 1 31) "Incorrect day of month")
  UnixTimestamp -> do
    s <- map foldDigits $ List.some parseDigit
    case map toDateTime $ instant $ Dur.Milliseconds $ 1000.0 * Int.toNumber s of
      Nothing -> P.fail "Incorrect timestamp"
      Just (DT.DateTime d t) -> lift $ put
        { year: Just $ fromEnum $ D.year d
        , month: Just $ fromEnum $ D.month d
        , day: Just $ fromEnum $ D.day d
        , hour: Just $ fromEnum $ T.hour t
        , minute: Just $ fromEnum $ T.minute t
        , second: Just $ fromEnum $ T.second t
        , millisecond: Just $ fromEnum $ T.millisecond t
        , meridiem: Nothing
        }
  -- TODO we would need to use this value if we support date format using week number
  DayOfWeek -> void $ parseInt 1 (validateRange 1 7) "Incorrect day of week"
  DayOfWeekName -> _ { day = _ } `modifyWithParser`
    (fromEnum <$> parseDayOfWeekName)
  DayOfWeekNameShort -> _ { day = _ } `modifyWithParser`
    (fromEnum <$> parseDayOfWeekNameShort)
  Hours24 -> _ { hour = _ } `modifyWithParser`
    (parseInt 2 (validateRange 0 24 <> exactLength) "Incorrect 24 hour")
  Hours12 -> _ { hour = _ } `modifyWithParser`
    (parseInt 2 (validateRange 0 12 <> exactLength) "Incorrect 12 hour")
  Meridiem -> _ { meridiem = _ } `modifyWithParser` parseMeridiem
  MinutesTwoDigits -> _ { minute = _ } `modifyWithParser`
    (parseInt 2 (validateRange 0 59 <> exactLength) "Incorrect 2-digit minute")
  Minutes -> _ { minute = _ } `modifyWithParser`
    (parseInt 2 (validateRange 0 59) "Incorrect minute")
  SecondsTwoDigits -> _ { second = _ } `modifyWithParser`
    (parseInt 2 (validateRange 0 59 <> exactLength) "Incorrect 2-digit second")
  Seconds -> _ { second = _ } `modifyWithParser`
    (parseInt 2 (validateRange 0 59) "Incorrect second")
  Milliseconds -> _ { millisecond = _ } `modifyWithParser`
    (parseInt 3 exactLength "Incorrect millisecond")
  Placeholder s -> void $ PS.string s
  MillisecondsShort -> _ { millisecond = _ } `modifyWithParser`
    (parseInt 1 exactLength "Incorrect 1-digit millisecond" <#> (_ * 100))
  MillisecondsTwoDigits -> _ { millisecond = _ } `modifyWithParser`
    (parseInt 2 exactLength "Incorrect 2-digit millisecond" <#> (_ * 10))
  where
  modifyWithParser :: forall s' s x. (s -> Maybe x -> s) -> P.ParserT s' (State s) x -> P.ParserT s' (State s) Unit
  modifyWithParser f p = do
    v <- p
    lift $ modify_ (flip f (Just v))

-- | A `ParserT` for `String`s that parses a `DateTime` 
-- | according to the format defined in the given `Formatter`. 
unformatParser :: forall m. Monad m => Formatter -> P.ParserT String m DT.DateTime
unformatParser f = do
  acc <- P.mapParserT unState $ foldMap unformatCommandParser f
  either P.fail pure $ unformatAccumToDateTime acc
  where
  unState :: forall x y n. Monad n => State UnformatAccum (Tuple (Either y Unit) x) -> n (Tuple (Either y UnformatAccum) x)
  unState s = case runState s initialAccum of
    Tuple (Tuple e state) res -> pure (Tuple (e $> res) state)

-- | Attempt to parse a `String` as a `DateTime` according to the format defined in the 
-- | given format string. Returns a `Left` value if the given format string was empty, or
-- | if the date string fails to parse according to the format.
unformatDateTime :: String -> String -> Either String DT.DateTime
unformatDateTime pattern str =
  parseFormatString pattern >>= (_ `unformat` str)

parseMeridiem :: forall m. Monad m => P.ParserT String m Meridiem
parseMeridiem = (PC.try <<< PS.string) `oneOfAs`
  [ Tuple "am" AM
  , Tuple "AM" AM
  , Tuple "pm" PM
  , Tuple "PM" PM
  ]

parseDayOfWeekName :: forall m. Monad m => P.ParserT String m D.Weekday
parseDayOfWeekName = (PC.try <<< PS.string) `oneOfAs`
  [ Tuple "Monday" D.Monday
  , Tuple "Tuesday" D.Tuesday
  , Tuple "Wednesday" D.Wednesday
  , Tuple "Thursday" D.Thursday
  , Tuple "Friday" D.Friday
  , Tuple "Saturday" D.Saturday
  , Tuple "Sunday" D.Sunday
  ]

parseDayOfWeekNameShort :: forall m. Monad m => P.ParserT String m D.Weekday
parseDayOfWeekNameShort = (PC.try <<< PS.string) `oneOfAs`
  [ Tuple "Mon" D.Monday
  , Tuple "Tue" D.Tuesday
  , Tuple "Wed" D.Wednesday
  , Tuple "Thu" D.Thursday
  , Tuple "Fri" D.Friday
  , Tuple "Sat" D.Saturday
  , Tuple "Sun" D.Sunday
  ]

parseMonth :: forall m. Monad m => P.ParserT String m D.Month
parseMonth = (PC.try <<< PS.string) `oneOfAs`
  [ Tuple "January" D.January
  , Tuple "February" D.February
  , Tuple "March" D.March
  , Tuple "April" D.April
  , Tuple "May" D.May
  , Tuple "June" D.June
  , Tuple "July" D.July
  , Tuple "August" D.August
  , Tuple "September" D.September
  , Tuple "October" D.October
  , Tuple "November" D.November
  , Tuple "December" D.December
  ]

parseShortMonth :: forall m. Monad m => P.ParserT String m D.Month
parseShortMonth = (PC.try <<< PS.string) `oneOfAs`
  [ Tuple "Jan" D.January
  , Tuple "Feb" D.February
  , Tuple "Mar" D.March
  , Tuple "Apr" D.April
  , Tuple "May" D.May
  , Tuple "Jun" D.June
  , Tuple "Jul" D.July
  , Tuple "Aug" D.August
  , Tuple "Sep" D.September
  , Tuple "Oct" D.October
  , Tuple "Nov" D.November
  , Tuple "Dec" D.December
  ]

printShortMonth :: D.Month -> String
printShortMonth = case _ of
  D.January -> "Jan"
  D.February -> "Feb"
  D.March -> "Mar"
  D.April -> "Apr"
  D.May -> "May"
  D.June -> "Jun"
  D.July -> "Jul"
  D.August -> "Aug"
  D.September -> "Sep"
  D.October -> "Oct"
  D.November -> "Nov"
  D.December -> "Dec"