format everything with hindent
[packages/time.git] / lib / Data / Time / Format / Parse / Class.hs
1 module Data.Time.Format.Parse.Class
2 (
3 -- * Parsing
4 ParseNumericPadding(..)
5 , ParseTime(..)
6 , parseSpecifiers
7 , timeSubstituteTimeSpecifier
8 , timeParseTimeSpecifier
9 , durationParseTimeSpecifier
10 ) where
11
12 import Control.Applicative hiding (many, optional)
13 import Data.Char
14 import Data.Maybe
15 import Data.Time.Format.Locale
16 import Text.ParserCombinators.ReadP
17
18 data ParseNumericPadding
19 = NoPadding
20 | SpacePadding
21 | ZeroPadding
22
23 -- | The class of types which can be parsed given a UNIX-style time format
24 -- string.
25 class ParseTime t where
26 -- | @since 1.9.1
27 substituteTimeSpecifier :: proxy t -> TimeLocale -> Char -> Maybe String
28 substituteTimeSpecifier _ _ _ = Nothing
29 -- | Get the string corresponding to the given format specifier.
30 --
31 -- @since 1.9.1
32 parseTimeSpecifier :: proxy t -> TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String
33 -- | Builds a time value from a parsed input string.
34 -- If the input does not include all the information needed to
35 -- construct a complete value, any missing parts should be taken
36 -- from 1970-01-01 00:00:00 +0000 (which was a Thursday).
37 -- In the absence of @%C@ or @%Y@, century is 1969 - 2068.
38 --
39 -- @since 1.9.1
40 buildTime ::
41 TimeLocale -- ^ The time locale.
42 -> [(Char, String)] -- ^ Pairs of format characters and the
43 -- corresponding part of the input.
44 -> Maybe t
45
46 -- | Case-insensitive version of 'Text.ParserCombinators.ReadP.char'.
47 charCI :: Char -> ReadP Char
48 charCI c = satisfy (\x -> toUpper c == toUpper x)
49
50 -- | Case-insensitive version of 'Text.ParserCombinators.ReadP.string'.
51 stringCI :: String -> ReadP String
52 stringCI this = do
53 let
54 scan [] _ = return this
55 scan (x:xs) (y:ys)
56 | toUpper x == toUpper y = do
57 _ <- get
58 scan xs ys
59 scan _ _ = pfail
60 s <- look
61 scan this s
62
63 parseSpecifiers :: ParseTime t => proxy t -> TimeLocale -> String -> ReadP [(Char, String)]
64 parseSpecifiers pt locale = let
65 parse :: String -> ReadP [(Char, String)]
66 parse [] = return []
67 parse ('%':cs) = parse1 cs
68 parse (c:cs)
69 | isSpace c = do
70 _ <- satisfy isSpace
71 case cs of
72 (c':_)
73 | isSpace c' -> return ()
74 _ -> skipSpaces
75 parse cs
76 parse (c:cs) = do
77 _ <- charCI c
78 parse cs
79 parse1 :: String -> ReadP [(Char, String)]
80 parse1 ('-':cs) = parse2 (Just NoPadding) cs
81 parse1 ('_':cs) = parse2 (Just SpacePadding) cs
82 parse1 ('0':cs) = parse2 (Just ZeroPadding) cs
83 parse1 cs = parse2 Nothing cs
84 parse2 :: Maybe ParseNumericPadding -> String -> ReadP [(Char, String)]
85 parse2 mpad ('E':cs) = parse3 mpad True cs
86 parse2 mpad cs = parse3 mpad False cs
87 parse3 :: Maybe ParseNumericPadding -> Bool -> String -> ReadP [(Char, String)]
88 parse3 _ _ ('%':cs) = do
89 _ <- char '%'
90 parse cs
91 parse3 _ _ (c:cs)
92 | Just s <- substituteTimeSpecifier pt locale c = parse $ s ++ cs
93 parse3 mpad _alt (c:cs) = do
94 str <- parseTimeSpecifier pt locale mpad c
95 specs <- parse cs
96 return $ (c, str) : specs
97 parse3 _ _ [] = return []
98 in parse
99
100 parsePaddedDigits :: ParseNumericPadding -> Int -> ReadP String
101 parsePaddedDigits ZeroPadding n = count n (satisfy isDigit)
102 parsePaddedDigits SpacePadding _n = skipSpaces >> many1 (satisfy isDigit)
103 parsePaddedDigits NoPadding _n = many1 (satisfy isDigit)
104
105 parsePaddedSignedDigits :: ParseNumericPadding -> Int -> ReadP String
106 parsePaddedSignedDigits pad n = do
107 sign <- option "" $ char '-' >> return "-"
108 digits <- parsePaddedDigits pad n
109 return $ sign ++ digits
110
111 parseSignedDecimal :: ReadP String
112 parseSignedDecimal = do
113 sign <- option "" $ char '-' >> return "-"
114 skipSpaces
115 digits <- many1 $ satisfy isDigit
116 decimaldigits <-
117 option "" $ do
118 _ <- char '.'
119 dd <- many $ satisfy isDigit
120 return $ '.' : dd
121 return $ sign ++ digits ++ decimaldigits
122
123 timeParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String
124 timeParseTimeSpecifier l mpad c = let
125 digits pad = parsePaddedDigits (fromMaybe pad mpad)
126 oneOf = choice . map stringCI
127 numericTZ = do
128 s <- choice [char '+', char '-']
129 h <- parsePaddedDigits ZeroPadding 2
130 optional (char ':')
131 m <- parsePaddedDigits ZeroPadding 2
132 return (s : h ++ m)
133 in case c of
134 -- century
135 'C' -> digits SpacePadding 2
136 'f' -> digits SpacePadding 2
137 -- year
138 'Y' -> digits SpacePadding 4
139 'G' -> digits SpacePadding 4
140 -- year of century
141 'y' -> digits ZeroPadding 2
142 'g' -> digits ZeroPadding 2
143 -- month of year
144 'B' -> oneOf (map fst (months l))
145 'b' -> oneOf (map snd (months l))
146 'm' -> digits ZeroPadding 2
147 -- day of month
148 'd' -> digits ZeroPadding 2
149 'e' -> digits SpacePadding 2
150 -- week of year
151 'V' -> digits ZeroPadding 2
152 'U' -> digits ZeroPadding 2
153 'W' -> digits ZeroPadding 2
154 -- day of week
155 'u' -> oneOf $ map (: []) ['1' .. '7']
156 'a' -> oneOf (map snd (wDays l))
157 'A' -> oneOf (map fst (wDays l))
158 'w' -> oneOf $ map (: []) ['0' .. '6']
159 -- day of year
160 'j' -> digits ZeroPadding 3
161 -- dayhalf of day (i.e. AM or PM)
162 'P' ->
163 oneOf
164 (let
165 (am, pm) = amPm l
166 in [am, pm])
167 'p' ->
168 oneOf
169 (let
170 (am, pm) = amPm l
171 in [am, pm])
172 -- hour of day (i.e. 24h)
173 'H' -> digits ZeroPadding 2
174 'k' -> digits SpacePadding 2
175 -- hour of dayhalf (i.e. 12h)
176 'I' -> digits ZeroPadding 2
177 'l' -> digits SpacePadding 2
178 -- minute of hour
179 'M' -> digits ZeroPadding 2
180 -- second of minute
181 'S' -> digits ZeroPadding 2
182 -- picosecond of second
183 'q' -> digits ZeroPadding 12
184 'Q' -> liftA2 (:) (char '.') (munch isDigit) <++ return ""
185 -- time zone
186 'z' -> numericTZ
187 'Z' -> munch1 isAlpha <++ numericTZ
188 -- seconds since epoch
189 's' -> (char '-' >> fmap ('-' :) (munch1 isDigit)) <++ munch1 isDigit
190 _ -> fail $ "Unknown format character: " ++ show c
191
192 timeSubstituteTimeSpecifier :: TimeLocale -> Char -> Maybe String
193 timeSubstituteTimeSpecifier l 'c' = Just $ dateTimeFmt l
194 timeSubstituteTimeSpecifier _ 'R' = Just "%H:%M"
195 timeSubstituteTimeSpecifier _ 'T' = Just "%H:%M:%S"
196 timeSubstituteTimeSpecifier l 'X' = Just $ timeFmt l
197 timeSubstituteTimeSpecifier l 'r' = Just $ time12Fmt l
198 timeSubstituteTimeSpecifier _ 'D' = Just "%m/%d/%y"
199 timeSubstituteTimeSpecifier _ 'F' = Just "%Y-%m-%d"
200 timeSubstituteTimeSpecifier l 'x' = Just $ dateFmt l
201 timeSubstituteTimeSpecifier _ 'h' = Just "%b"
202 timeSubstituteTimeSpecifier _ _ = Nothing
203
204 durationParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String
205 durationParseTimeSpecifier _ mpad c = let
206 padopt = parsePaddedSignedDigits $ fromMaybe NoPadding mpad
207 in case c of
208 'y' -> padopt 1
209 'b' -> padopt 1
210 'B' -> padopt 2
211 'w' -> padopt 1
212 'd' -> padopt 1
213 'D' -> padopt 1
214 'h' -> padopt 1
215 'H' -> padopt 2
216 'm' -> padopt 1
217 'M' -> padopt 2
218 's' -> parseSignedDecimal
219 'S' -> parseSignedDecimal
220 _ -> fail $ "Unknown format character: " ++ show c