{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DefaultSignatures #-}

-- | XSD @dateTime@ data structure <http://www.w3.org/TR/xmlschema-2/#dateTime>
module Text.XML.XSD.DateTime
(
  DateTime(..)
, ManyDateTime(..)
, Many1DateTime(..)
, HasDateTime(..)
, AsDateTime(..)
, isoEither
, fromZonedTime
) where

import Control.Applicative (pure, (<$>), (*>), (<|>))
import Control.Monad (Monad(..), when)
import Control.Lens
import Data.Bool ( Bool(False, True), (&&), (||) )
import Data.Char (ord)
import Data.Either(Either(..), either)
import Data.Eq ( Eq(..) )
import Data.Fixed (Pico, showFixed)
import Data.Function((.), id, ($), const)
import Data.Functor.Apply(WrappedApplicative(WrapApplicative, unwrapApplicative))
import Data.Int ( Int )
import Data.Maybe (Maybe(Nothing, Just))
import Data.Ord ( Ord((>), (<)) )
import Data.Text(Text)
import Data.Text.Lazy as TL(toStrict)
import Data.Text.Lazy.Builder(Builder, toLazyText, fromString)
import Data.Text.Lazy.Builder.Int (decimal)
import qualified Data.Text.Read as TR(decimal)
import Data.Semigroup ((<>))
import Data.Time
    ( addDays,
      fromGregorian,
      toGregorian,
      isLeapYear,
      addUTCTime,
      utcToLocalTime,
      timeOfDayToTime,
      utc,
      zonedTimeToUTC,
      UTCTime(UTCTime),
      LocalTime(LocalTime),
      TimeOfDay(TimeOfDay),
      ZonedTime )
import Data.Time.Calendar.MonthDay (monthLength)
import GHC.Show(Show(show))
import GHC.Generics(Generic)
import Prelude(Num(negate, abs, (*), (+), (-)), Integer, read, fromIntegral, realToFrac)
import Text.Parsec(parse)
import Text.Parser.Char ( digit, CharParsing(char) )
import Text.Parser.Combinators ( many, Parsing(eof) )
import qualified Data.Text as Text(pack)

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Data.Functor(fmap)
-- >>> import Prelude(signum)
-- >>> import Control.Lens
-- >>> import Data.Time
-- >>> let mkLocal :: Integer -> Int -> Int -> Int -> Int -> Pico -> LocalTime; mkLocal y m d hh mm ss = LocalTime (fromGregorian y m d) (TimeOfDay hh mm ss)
-- >>> let mkUTC :: Integer -> Int -> Int -> Int -> Int -> Pico -> UTCTime; mkUTC y m d hh mm ss = localTimeToUTC utc (mkLocal y m d hh mm ss)
-- >>> let mkZoned :: Integer -> Int -> Int -> Int -> Int -> Pico -> Int -> Int -> ZonedTime; mkZoned y m d hh mm ss zh zm = ZonedTime (mkLocal y m d hh mm ss) (TimeZone offset False "") where offset = signum zh * (abs zh * 60 + zm)

-- | XSD @dateTime@ data structure
-- <http://www.w3.org/TR/xmlschema-2/#dateTime>. Briefly, a @dateTime@
-- uses the Gregorian calendar and may or may not have an associated
-- timezone. If it has a timezone, then the canonical representation
-- of that date time is in UTC.
--
-- Note, it is not possible to establish a total order on @dateTime@
-- since non-timezoned are considered to belong to some unspecified
-- timezone.
data DateTime =
  DtZoned UTCTime
  | DtUnzoned LocalTime
  deriving (Eq, Ord, Show, Generic)

class ManyDateTime a where
  _DateTime_ :: Traversal' a DateTime
  default _DateTime_ :: Many1DateTime a => Traversal' a DateTime
  _DateTime_ f = unwrapApplicative . _DateTime1_ (WrapApplicative . f)

instance ManyDateTime DateTime where

class Many1DateTime a where
  _DateTime1_ :: Traversal1' a DateTime
  default _DateTime1_ :: HasDateTime a => Traversal1' a DateTime
  _DateTime1_ = dateTime

instance Many1DateTime DateTime where

class HasDateTime a where
  dateTime :: Lens' a DateTime
  getDateTime :: a -> DateTime
  getDateTime = view dateTime

instance HasDateTime DateTime where
  dateTime = id

class AsDateTime a where
  _DateTime :: Prism' a DateTime
  _UTCDateTime :: Prism' a UTCTime
  _UTCDateTime = _DateTime . _UTCDateTime
  _LocalDateTime :: Prism' a LocalTime
  _LocalDateTime = _DateTime . _LocalDateTime

instance AsDateTime DateTime where
  _DateTime = id
  _UTCDateTime =
    prism'
      DtZoned
      (\case
        DtZoned x -> Just x
        _ -> Nothing
      )
  _LocalDateTime =
    prism'
      DtUnzoned
      (\case
        DtUnzoned x -> Just x
        _ -> Nothing
      )

  -- _LocalDateTime = undefined
-- | Internal helper that creates a date time. Note, if the given hour
-- is 24 then the minutes and seconds are assumed to be 0.
mkDateTime
  :: Integer           -- ^ Year
  -> Int               -- ^ Month
  -> Int               -- ^ Day
  -> Int               -- ^ Hours
  -> Int               -- ^ Minutes
  -> Pico              -- ^ Seconds
  -> Maybe Pico        -- ^ Time zone offset
  -> DateTime
mkDateTime y m d hh mm ss mz =
  case mz of
    Just z -> DtZoned $ addUTCTime (negate $ realToFrac z) uTime
    Nothing -> DtUnzoned lTime
  where
    day = addDays (if hh == 24 then 1 else 0) (fromGregorian y m d)
    tod = TimeOfDay (if hh == 24 then 0 else hh) mm ss
    lTime = LocalTime day tod
    uTime = UTCTime day (timeOfDayToTime tod)

-- | The isomorphism between a @DateTime@ and @Either UTCTime LocalTime@
isoEither ::
  Iso'
  (Either UTCTime LocalTime)
  DateTime
isoEither =
  iso (either DtZoned DtUnzoned) (\case DtZoned e -> Left e
                                        DtUnzoned q -> Right q)

-- | A prism that parses the string into a @DateTime@ and converts the
-- @DateTime@ into a string.
--
-- >>> "2009-10-10T03:10:10-05:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 2009-10-10 08:10:10 UTC)
--
-- >>> "2119-10-10T03:10:10.4-13:26" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 2119-10-10 16:36:10.4 UTC)
--
-- >>> "0009-10-10T03:10:10.783952+14:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 0009-10-09 13:10:10.783952 UTC)
--
-- >>> "2009-10-10T03:10:10Z" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 2009-10-10 03:10:10 UTC)
--
-- >>> "-2009-05-10T21:08:59+05:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned -2009-05-10 16:08:59 UTC)
--
-- >>> "-19399-12-31T13:10:10-14:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned -19398-01-01 03:10:10 UTC)
--
-- >>> "2009-12-31T13:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtUnzoned 2009-12-31 13:10:10)
--
-- >>> "2012-10-15T24:00:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtUnzoned 2012-10-16 00:00:00)
--
-- >>> "2002-10-10T12:00:00+05:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 2002-10-10 07:00:00 UTC)
--
-- >>> "2002-10-10T00:00:00+05:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 2002-10-09 19:00:00 UTC)
--
-- >>> "-0001-10-10T00:00:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtUnzoned -0001-10-10 00:00:00)
--
-- >>> "0001-10-10T00:00:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtUnzoned 0001-10-10 00:00:00)
--
-- >>> "2009-10-10T03:10:10-05" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-10T03:10:10+14:50" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-10T03:10:1" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-10T03:1:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-10T0:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-1T10:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-1-10T10:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "209-10-10T03:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-10T24:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "0000-01-01T00:00:00" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-13-01T00:00:00" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "+2009-10-01T04:20:40" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "002009-10-01T04:20:40" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> (_DateTime :: Prism' Text DateTime) # review _UTCDateTime (mkUTC 2119 10 10 16 36 10.4)
-- "2119-10-10T16:36:10.4Z"
--
-- >>> (_DateTime :: Prism' Text DateTime) # fromZonedTime (mkZoned 2010 04 07 13 47 20.001 2 0)
-- "2010-04-07T11:47:20.001Z"
--
-- >>> (_DateTime :: Prism' Text DateTime) # review _LocalDateTime (mkLocal 13 2 4 20 20 20)
-- "0013-02-04T20:20:20"
--
-- >>> (review (_DateTime :: Prism' Text DateTime)) `fmap` ("2010-04-07T13:47:20.001+02:00" ^? (_DateTime :: Prism' Text DateTime)) --  issue 2
-- Just "2010-04-07T11:47:20.001Z"
instance AsDateTime Text where
  _DateTime =
    let buildUInt2 ::
          Int
          -> Builder
        buildUInt2 x =
          (if x < 10 then ("0" <>) else id) $ decimal x
        buildInt4 ::
          Integer
          -> Builder
        buildInt4 year =
          let absYear = abs year
              k x = if absYear < x then ("0" <>) else id
          in  k 1000 . k 100 . k 10 $ decimal year
        toText ::
          DateTime
          -> Text
        toText =
          toStrict . toLazyText . dtBuilder
            where
              dtBuilder (DtZoned uTime) = ltBuilder (utcToLocalTime utc uTime) <> "Z"
              dtBuilder (DtUnzoned lTime) = ltBuilder lTime
              ltBuilder (LocalTime day (TimeOfDay hh mm sss)) =
                let (y, m, d) = toGregorian day
                in  buildInt4 y
                    <> "-"
                    <> buildUInt2 m
                    <> "-"
                    <> buildUInt2 d
                    <> "T"
                    <> buildUInt2 hh
                    <> ":"
                    <> buildUInt2 mm
                    <> ":"
                    <> buildSeconds sss
    in prism' toText (either (const Nothing) Just . parse (parseDateTime <|> fail "bad date time") "DateTime")

buildSeconds ::
  Pico
  -> Builder
buildSeconds secs =
  (if secs < 10 then ("0" <>) else id)
  $ fromString (showFixed True secs)

-- | Converts a zoned time to a @dateTime@.
fromZonedTime :: ZonedTime -> DateTime
fromZonedTime = review _UTCDateTime . zonedTimeToUTC

-- | Parser of the @dateTime@ lexical representation.
parseDateTime ::
  (CharParsing p, Monad p) =>
  p DateTime
parseDateTime =
  do yy <- yearParser
     _ <- char '-'
     mm <- p2imax 12
     _ <- char '-'
     dd <- p2imax (monthLength (isLeapYear $ fromIntegral yy) mm)
     _ <- char 'T'
     hhh <- p2imax 24
     _ <- char ':'
     mmm <- p2imax 59
     _ <- char ':'
     sss <- secondParser
     when (hhh == 24 && (mmm /= 0 || sss /= 0))
       $ fail "invalid time, past 24:00:00"
     o <- parseOffset
     return $ mkDateTime yy mm dd hhh mmm sss o

-- | Parse timezone offset.
parseOffset ::
  (Monad p, CharParsing p) =>
  p (Maybe Pico)
parseOffset =
  (eof *> pure Nothing)
  <|>
  (char 'Z' *> pure (Just 0))
   <|>
  (do sign <- (char '+' *> pure 1) <|> (char '-' *> pure (-1))
      hh <- fromIntegral <$> p2imax 14
      _ <- char ':'
      mm <- fromIntegral <$> p2imax (if hh == 14 then 0 else 59)
      return . Just $ sign * (hh * 3600 + mm * 60))

yearParser ::
  (Monad p, CharParsing p) =>
  p Integer
yearParser =
  let lengthLT4 (_:_:_:_:_) =
        False
      lengthLT4 _ =
        True
      lengthGT4_c1 c (x:_:_:_:_:_) =
        c == x
      lengthGT4_c1 _  _ =
        False
  in  do  sign <- (char '-' *> pure (-1)) <|> pure 1
          ds <- many digit
          when (lengthLT4 ds)
            $ fail "need at least four digits in year"
          when (lengthGT4_c1 '0' ds)
            $ fail "leading zero in year"
          let Right (absyear, _) = TR.decimal (Text.pack ds)
          when (absyear == 0)
            $ fail "year zero disallowed"
          return $ sign * absyear

secondParser ::
  (Monad p, CharParsing p) =>
  p Pico
secondParser =
  do d1 <- digit
     d2 <- digit
     frac <- readFrac <$> (char '.' *> many digit)
             <|> pure 0
     return (read [d1, d2] + frac)
    where
      readFrac ds = read $ '0' : '.' : ds

p2imax ::
  (Monad p, CharParsing p) =>
  Int
  -> p Int
p2imax m =
  do a <- digit
     b <- digit
     let n = 10 * val a + val b
     if n > m
       then fail $ "value " <> show n <> " exceeded maximum " <> show m
       else return n
    where
      val c = ord c - ord '0'