lib/Data/Time/Format/Parse/Class.hs

    {-# 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