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

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

    import Control.Applicative hiding (optional,many)
    import Data.Char
    import Data.Maybe
    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

    parsePaddedDigits :: ParseNumericPadding -> Int -> ReadP String
    parsePaddedDigits ZeroPadding n = count n (satisfy isDigit)
    parsePaddedDigits SpacePadding _n = skipSpaces >> many1 (satisfy isDigit)
    parsePaddedDigits NoPadding _n = many1 (satisfy isDigit)

    parsePaddedSignedDigits :: ParseNumericPadding -> Int -> ReadP String
    parsePaddedSignedDigits pad n = do
        sign <- option "" $ char '-' >> return "-"
        digits <- parsePaddedDigits pad 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 pad = parsePaddedDigits (fromMaybe pad mpad)
        oneOf = choice . map stringCI
        numericTZ = do
            s <- choice [char '+', char '-']
            h <- parsePaddedDigits ZeroPadding 2
            optional (char ':')
            m <- parsePaddedDigits ZeroPadding 2
            return (s:h++m)
        in case c of
            -- century
            'C' -> digits SpacePadding 2
            'f' -> digits SpacePadding 2

            -- year
            'Y' -> 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 ZeroPadding 12
            'Q' -> liftA2 (:) (char '.') (munch isDigit) <++ 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