{-# LANGUAGE Safe #-}

module Data.Time.Format.Parse.Class (
    -- * Parsing
    ParseNumericPadding (..),
    ParseTime (..),
    parseSpecifiers,
    timeSubstituteTimeSpecifier,
    timeParseTimeSpecifier,
    durationParseTimeSpecifier,
) where

import Data.Char
import Data.Maybe
import Data.Proxy
import Data.Time.Format.Locale
import Text.ParserCombinators.ReadP

data ParseNumericPadding
    = NoPadding
    | SpacePadding
    | ZeroPadding

-- | The class of types which can be parsed given a UNIX-style time format
-- string.
class ParseTime t where
    -- | @since 1.9.1
    substituteTimeSpecifier :: Proxy t -> TimeLocale -> Char -> Maybe String
    substituteTimeSpecifier _ _ _ = Nothing

    -- | Get the string corresponding to the given format specifier.
    --
    -- @since 1.9.1
    parseTimeSpecifier :: Proxy t -> TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String

    -- | Builds a time value from a parsed input string.
    -- If the input does not include all the information needed to
    -- construct a complete value, any missing parts should be taken
    -- from 1970-01-01 00:00:00 +0000 (which was a Thursday).
    -- In the absence of @%C@ or @%Y@, century is 1969 - 2068.
    --
    -- @since 1.9.1
    buildTime ::
        -- | The time locale.
        TimeLocale ->
        -- | Pairs of format characters and the
        -- corresponding part of the input.
        [(Char, String)] ->
        Maybe t

-- | Case-insensitive version of 'Text.ParserCombinators.ReadP.char'.
charCI :: Char -> ReadP Char
charCI c = satisfy (\x -> toUpper c == toUpper x)

-- | Case-insensitive version of 'Text.ParserCombinators.ReadP.string'.
stringCI :: String -> ReadP String
stringCI this = do
    let
        scan [] _ = return this
        scan (x : xs) (y : ys)
            | toUpper x == toUpper y = do
                _ <- get
                scan xs ys
        scan _ _ = pfail
    s <- look
    scan this s

parseSpecifiers :: ParseTime t => Proxy t -> TimeLocale -> String -> ReadP [(Char, String)]
parseSpecifiers pt locale = let
    parse :: String -> ReadP [(Char, String)]
    parse [] = return []
    parse ('%' : cs) = parse1 cs
    parse (c : cs) | isSpace c = do
        _ <- satisfy isSpace
        case cs of
            (c' : _) | isSpace c' -> return ()
            _ -> skipSpaces
        parse cs
    parse (c : cs) = do
        _ <- charCI c
        parse cs
    parse1 :: String -> ReadP [(Char, String)]
    parse1 ('-' : cs) = parse2 (Just NoPadding) cs
    parse1 ('_' : cs) = parse2 (Just SpacePadding) cs
    parse1 ('0' : cs) = parse2 (Just ZeroPadding) cs
    parse1 cs = parse2 Nothing cs
    parse2 :: Maybe ParseNumericPadding -> String -> ReadP [(Char, String)]
    parse2 mpad ('E' : cs) = parse3 mpad True cs
    parse2 mpad cs = parse3 mpad False cs
    parse3 :: Maybe ParseNumericPadding -> Bool -> String -> ReadP [(Char, String)]
    parse3 _ _ ('%' : cs) = do
        _ <- char '%'
        parse cs
    parse3 _ _ (c : cs) | Just s <- substituteTimeSpecifier pt locale c = parse $ s ++ cs
    parse3 mpad _alt (c : cs) = do
        str <- parseTimeSpecifier pt locale mpad c
        specs <- parse cs
        return $ (c, str) : specs
    parse3 _ _ [] = return []
    in parse

data PaddingSide
    = PrePadding
    | PostPadding

allowEmptyParser :: Bool -> ReadP String
allowEmptyParser False = many1 (satisfy isDigit)
allowEmptyParser True = many (satisfy isDigit)

parsePaddedDigits :: PaddingSide -> ParseNumericPadding -> Bool -> Int -> ReadP String
parsePaddedDigits _ ZeroPadding _ n = count n (satisfy isDigit)
parsePaddedDigits PrePadding SpacePadding allowEmpty _n = skipSpaces >> allowEmptyParser allowEmpty
parsePaddedDigits PostPadding SpacePadding allowEmpty _n = do
    r <- allowEmptyParser allowEmpty
    skipSpaces
    return r
parsePaddedDigits _ NoPadding False _n = many1 (satisfy isDigit)
parsePaddedDigits _ NoPadding True _n = many (satisfy isDigit)

parsePaddedSignedDigits :: ParseNumericPadding -> Int -> ReadP String
parsePaddedSignedDigits pad n = do
    sign <- option "" $ char '-' >> return "-"
    digits <- parsePaddedDigits PrePadding pad False n
    return $ sign ++ digits

parseSignedDecimal :: ReadP String
parseSignedDecimal = do
    sign <- option "" $ char '-' >> return "-"
    skipSpaces
    digits <- many1 $ satisfy isDigit
    decimaldigits <-
        option "" $ do
            _ <- char '.'
            dd <- many $ satisfy isDigit
            return $ '.' : dd
    return $ sign ++ digits ++ decimaldigits

timeParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String
timeParseTimeSpecifier l mpad c = let
    digits' ps pad = parsePaddedDigits ps (fromMaybe pad mpad)
    digits pad = digits' PrePadding pad False
    oneOf = choice . map stringCI
    numericTZ = do
        s <- choice [char '+', char '-']
        h <- parsePaddedDigits PrePadding ZeroPadding False 2
        optional (char ':')
        m <- parsePaddedDigits PrePadding ZeroPadding False 2
        return (s : h ++ m)
    allowNegative :: ReadP String -> ReadP String
    allowNegative p = (char '-' >> fmap ('-' :) p) <++ p
    in case c of
        -- century
        'C' -> allowNegative $ digits SpacePadding 2
        'f' -> allowNegative $ digits SpacePadding 2
        -- year
        'Y' -> allowNegative $ digits SpacePadding 4
        'G' -> allowNegative $ digits SpacePadding 4
        -- year of century
        'y' -> digits ZeroPadding 2
        'g' -> digits ZeroPadding 2
        -- month of year
        'B' -> oneOf (map fst (months l))
        'b' -> oneOf (map snd (months l))
        'm' -> digits ZeroPadding 2
        -- day of month
        'd' -> digits ZeroPadding 2
        'e' -> digits SpacePadding 2
        -- week of year
        'V' -> digits ZeroPadding 2
        'U' -> digits ZeroPadding 2
        'W' -> digits ZeroPadding 2
        -- day of week
        'u' -> oneOf $ map (: []) ['1' .. '7']
        'a' -> oneOf (map snd (wDays l))
        'A' -> oneOf (map fst (wDays l))
        'w' -> oneOf $ map (: []) ['0' .. '6']
        -- day of year
        'j' -> digits ZeroPadding 3
        -- dayhalf of day (i.e. AM or PM)
        'P' ->
            oneOf
                ( let
                    (am, pm) = amPm l
                    in [am, pm]
                )
        'p' ->
            oneOf
                ( let
                    (am, pm) = amPm l
                    in [am, pm]
                )
        -- hour of day (i.e. 24h)
        'H' -> digits ZeroPadding 2
        'k' -> digits SpacePadding 2
        -- hour of dayhalf (i.e. 12h)
        'I' -> digits ZeroPadding 2
        'l' -> digits SpacePadding 2
        -- minute of hour
        'M' -> digits ZeroPadding 2
        -- second of minute
        'S' -> digits ZeroPadding 2
        -- picosecond of second
        'q' -> digits' PostPadding ZeroPadding True 12
        'Q' -> (char '.' >> digits' PostPadding NoPadding True 12) <++ return ""
        -- time zone
        'z' -> numericTZ
        'Z' -> munch1 isAlpha <++ numericTZ
        -- seconds since epoch
        's' -> (char '-' >> fmap ('-' :) (munch1 isDigit)) <++ munch1 isDigit
        _ -> fail $ "Unknown format character: " ++ show c

timeSubstituteTimeSpecifier :: TimeLocale -> Char -> Maybe String
timeSubstituteTimeSpecifier l 'c' = Just $ dateTimeFmt l
timeSubstituteTimeSpecifier _ 'R' = Just "%H:%M"
timeSubstituteTimeSpecifier _ 'T' = Just "%H:%M:%S"
timeSubstituteTimeSpecifier l 'X' = Just $ timeFmt l
timeSubstituteTimeSpecifier l 'r' = Just $ time12Fmt l
timeSubstituteTimeSpecifier _ 'D' = Just "%m/%d/%y"
timeSubstituteTimeSpecifier _ 'F' = Just "%Y-%m-%d"
timeSubstituteTimeSpecifier l 'x' = Just $ dateFmt l
timeSubstituteTimeSpecifier _ 'h' = Just "%b"
timeSubstituteTimeSpecifier _ _ = Nothing

durationParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String
durationParseTimeSpecifier _ mpad c = let
    padopt = parsePaddedSignedDigits $ fromMaybe NoPadding mpad
    in case c of
        'y' -> padopt 1
        'b' -> padopt 1
        'B' -> padopt 2
        'w' -> padopt 1
        'd' -> padopt 1
        'D' -> padopt 1
        'h' -> padopt 1
        'H' -> padopt 2
        'm' -> padopt 1
        'M' -> padopt 2
        's' -> parseSignedDecimal
        'S' -> parseSignedDecimal
        _ -> fail $ "Unknown format character: " ++ show c
