{-# 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 ::
           TimeLocale -- ^ The time locale.
        -> [(Char, String)] -- ^ Pairs of format characters and the
                                 -- corresponding part of the input.
        -> 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)
    in case c of
        -- century
           'C' -> (char '-' >> fmap ('-' :) (digits SpacePadding 2)) <++ digits SpacePadding 2
           'f' -> digits SpacePadding 2
        -- year
           'Y' -> (char '-' >> fmap ('-' :) (digits SpacePadding 4)) <++ digits SpacePadding 4
           'G' -> 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