{-# LANGUAGE FlexibleContexts #-}
module Hcompta.Filter.Date.Read where

import           Control.Monad (Monad(..))
import           Data.Bool
import           Data.Char (Char)
import           Data.Eq (Eq(..))
import           Data.Functor ((<$>))
import           Data.Maybe (Maybe(..), maybe)
import qualified Data.Time.Calendar  as Time
import qualified Data.Time.LocalTime as Time
import           Data.Time.LocalTime (TimeZone(..))
import           Data.Typeable ()
import qualified Text.Parsec as R hiding
                  ( char
                  , anyChar
                  , crlf
                  , newline
                  , noneOf
                  , oneOf
                  , satisfy
                  , space
                  , spaces
                  , string
                  )
import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import           Prelude (($), Int, Integer, Num(..), Show(..), id)

import           Hcompta.Date (Date)
import qualified Hcompta.Lib.Parsec as R

data Error
 =   Error_year_or_day_is_missing
 |   Error_invalid_date (Integer, Int, Int)
 |   Error_invalid_time_of_day (Int, Int, Integer)
 deriving (Eq, Show)

-- | Read a 'Date' in @[YYYY\/]MM\/DD[_HH:MM[:SS][TZ]]@ format.
date
 :: (Stream s (R.Error_State e m) Char, Monad m)
 => (Error -> e) -> Maybe Integer -> ParsecT s u (R.Error_State e m) Date
date err def_year = (do
	let read_2_or_1_digits = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
	n0 <- R.many1 R.digit
	day_sep <- date_separator
	n1 <- read_2_or_1_digits
	n2 <- R.option Nothing $ R.try $ do
		_ <- R.char day_sep
		Just <$> read_2_or_1_digits
	(year, m, d) <-
		case (n2, def_year) of
		 (Nothing, Nothing) -> R.fail_with "date" (err $ Error_year_or_day_is_missing)
		 (Nothing, Just year) -> return (year, n0, n1)
		 (Just d, _)  -> return (R.integer_of_digits 10 n0, n1, d)
	let month = fromInteger $ R.integer_of_digits 10 m
	let dom   = fromInteger $ R.integer_of_digits 10 d
	day <- case Time.fromGregorianValid year month dom of
	 Nothing  -> R.fail_with "date" (err $ Error_invalid_date (year, month, dom))
	 Just day -> return day
	(hour, minu, sec, tz) <-
		R.option (0, 0, 0, Time.utc) $ R.try $ do
			_ <- R.char '_'
			hour <- read_2_or_1_digits
			sep <- hour_separator
			minu <- read_2_or_1_digits
			sec <- R.option Nothing $ R.try $ do
				_ <- R.char sep
				Just <$> read_2_or_1_digits
			tz <- R.option Time.utc $ R.try $ do
				-- R.skipMany $ R.space_horizontal
				time_zone
			return
			 ( fromInteger $ R.integer_of_digits 10 hour
			 , fromInteger $ R.integer_of_digits 10 minu
			 , maybe 0      (R.integer_of_digits 10) sec
			 , tz )
	tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
	 Nothing  -> R.fail_with "date" (err $ Error_invalid_time_of_day (hour, minu, sec))
	 Just tod -> return tod
	return $ Time.localTimeToUTC tz (Time.LocalTime day tod)
	) <?> "date"

-- | Parse the year, month and day separator: "/" or "-".
date_separator :: Stream s m Char => ParsecT s u m Char
date_separator = R.satisfy (\c -> c == '/' || c == '-')

-- | Parse the hour, minute and second separator: ":".
hour_separator :: Stream s m Char => ParsecT s u m Char
hour_separator = R.char ':'

-- | Parse either "-" into 'negate', or "+" or "" into 'id'.
sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
sign =
	    (R.char '-' >> return negate)
	<|> (R.char '+' >> return id)
	<|> return id

time_zone :: Stream s m Char => ParsecT s u m TimeZone
time_zone =
	-- DOC: http://www.timeanddate.com/time/zones/
	-- TODO: only a few time zones are suported below.
	-- TODO: check the timeZoneSummerOnly values
	R.choice
	 [ R.char 'A' >> R.choice
		 [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
		 , R.string "DT" >> return (TimeZone ((-3) * 60) True  "ADT")
		 , return (TimeZone ((-1) * 60) False "A")
		 ]
	 , R.char 'B' >> R.choice
		 [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
		 , R.string "DT" >> return (TimeZone ((-10) * 60) True  "BDT")
		 ]
	 , R.char 'C' >> R.choice
		 [ R.char 'E' >> R.choice
			 [ R.string "T"  >> return (TimeZone ((1) * 60) True  "CET")
			 , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
			 ]
		 , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
		 , R.string "DT" >> return (TimeZone ((-5) * 60) True  "CDT")
		 ]
	 , R.char 'E' >> R.choice
		 [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
		 , R.string "DT" >> return (TimeZone ((-4) * 60) True  "EDT")
		 ]
	 , R.string "GMT" >> return (TimeZone 0 False "GMT")
	 , R.char 'H' >> R.choice
		 [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
		 , R.string "DT" >> return (TimeZone (( -9) * 60) True  "HDT")
		 ]
	 , R.char 'M' >> R.choice
		 [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
		 , R.string "DT" >> return (TimeZone ((-6) * 60) True  "MDT")
		 , return (TimeZone ((-12) * 60) False "M")
		 ]
	 , R.char 'N' >> R.choice
		 [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
		 , return (TimeZone (1 * 60) False "N")
		 ]
	 , R.char 'P' >> R.choice
		 [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
		 , R.string "DT" >> return (TimeZone ((-7) * 60) True  "PDT")
		 ]
	 , R.char 'Y' >> R.choice
		 [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
		 , R.string "DT" >> return (TimeZone ((-8) * 60) True  "YDT")
		 , return (TimeZone (12 * 60) False "Y")
		 ]
	 , R.char 'Z' >> return (TimeZone 0 False "Z")
	 , time_zone_digits
	 ]

time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
{-# INLINEABLE time_zone_digits #-}
time_zone_digits = do
	sign_ <- sign
	hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
	_ <- R.option ':' (R.char ':')
	minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
	let tz = TimeZone
		 { timeZoneMinutes    = sign_ (fromInteger hour * 60 + fromInteger minute)
		 , timeZoneSummerOnly = False
		 , timeZoneName       = Time.timeZoneOffsetString tz
		 }
	return tz