17fe3191ec17eb8254e9737a2a2f0d438c2798c2
[packages/time.git] / lib / Data / Format.hs
1 module Data.Format
2 ( Productish(..)
3 , Summish(..)
4 , parseReader
5 , Format(..)
6 , formatShow
7 , formatParseM
8 , isoMap
9 , mapMFormat
10 , filterFormat
11 , clipFormat
12 , enumMap
13 , literalFormat
14 , specialCaseShowFormat
15 , specialCaseFormat
16 , optionalFormat
17 , casesFormat
18 , optionalSignFormat
19 , mandatorySignFormat
20 , SignOption(..)
21 , integerFormat
22 , decimalFormat
23 ) where
24
25 #if MIN_VERSION_base(4,9,0)
26 import Control.Monad.Fail
27 import Prelude hiding (fail)
28 #endif
29 #if MIN_VERSION_base(4,8,0)
30 import Data.Void
31 #endif
32 import Data.Char
33 import Text.ParserCombinators.ReadP
34
35
36 #if MIN_VERSION_base(4,8,0)
37 #else
38 data Void
39 absurd :: Void -> a
40 absurd v = seq v $ error "absurd"
41 #endif
42
43 class IsoVariant f where
44 isoMap :: (a -> b) -> (b -> a) -> f a -> f b
45
46 enumMap :: (IsoVariant f,Enum a) => f Int -> f a
47 enumMap = isoMap toEnum fromEnum
48
49 infixr 3 <**>, **>, <**
50 class IsoVariant f => Productish f where
51 pUnit :: f ()
52 (<**>) :: f a -> f b -> f (a,b)
53 (**>) :: f () -> f a -> f a
54 fu **> fa = isoMap (\((),a) -> a) (\a -> ((),a)) $ fu <**> fa
55 (<**) :: f a -> f () -> f a
56 fa <** fu = isoMap (\(a,()) -> a) (\a -> (a,())) $ fa <**> fu
57
58 infixr 2 <++>
59 class IsoVariant f => Summish f where
60 pVoid :: f Void
61 (<++>) :: f a -> f b -> f (Either a b)
62
63
64 parseReader :: (
65 #if MIN_VERSION_base(4,9,0)
66 MonadFail m
67 #else
68 Monad m
69 #endif
70 ) => ReadP t -> String -> m t
71 parseReader readp s = case [ t | (t,"") <- readP_to_S readp s] of
72 [t] -> return t
73 [] -> fail $ "no parse of " ++ show s
74 _ -> fail $ "multiple parses of " ++ show s
75
76 -- | A text format for a type
77 data Format t = MkFormat
78 { formatShowM :: t -> Maybe String
79 -- ^ Show a value in the format, if representable
80 , formatReadP :: ReadP t
81 -- ^ Read a value in the format
82 }
83
84 -- | Show a value in the format, or error if unrepresentable
85 formatShow :: Format t -> t -> String
86 formatShow fmt t = case formatShowM fmt t of
87 Just str -> str
88 Nothing -> error "formatShow: bad value"
89
90 -- | Parse a value in the format
91 formatParseM :: (
92 #if MIN_VERSION_base(4,9,0)
93 MonadFail m
94 #else
95 Monad m
96 #endif
97 ) => Format t -> String -> m t
98 formatParseM format = parseReader $ formatReadP format
99
100 instance IsoVariant Format where
101 isoMap ab ba (MkFormat sa ra) = MkFormat (\b -> sa $ ba b) (fmap ab ra)
102
103 mapMFormat :: (a -> Maybe b) -> (b -> Maybe a) -> Format a -> Format b
104 mapMFormat amb bma (MkFormat sa ra) = MkFormat (\b -> bma b >>= sa) $ do
105 a <- ra
106 case amb a of
107 Just b -> return b
108 Nothing -> pfail
109
110 filterFormat :: (a -> Bool) -> Format a -> Format a
111 filterFormat test = mapMFormat (\a -> if test a then Just a else Nothing) (\a -> if test a then Just a else Nothing)
112
113 -- | Limits are inclusive
114 clipFormat :: Ord a => (a,a) -> Format a -> Format a
115 clipFormat (lo,hi) = filterFormat (\a -> a >= lo && a <= hi)
116
117 instance Productish Format where
118 pUnit = MkFormat {formatShowM = \_ -> Just "", formatReadP = return ()}
119 (<**>) (MkFormat sa ra) (MkFormat sb rb) = let
120 sab (a, b) = do
121 astr <- sa a
122 bstr <- sb b
123 return $ astr ++ bstr
124 rab = do
125 a <- ra
126 b <- rb
127 return (a, b)
128 in MkFormat sab rab
129 (MkFormat sa ra) **> (MkFormat sb rb) = let
130 s b = do
131 astr <- sa ()
132 bstr <- sb b
133 return $ astr ++ bstr
134 r = do
135 ra
136 rb
137 in MkFormat s r
138 (MkFormat sa ra) <** (MkFormat sb rb) = let
139 s a = do
140 astr <- sa a
141 bstr <- sb ()
142 return $ astr ++ bstr
143 r = do
144 a <- ra
145 rb
146 return a
147 in MkFormat s r
148
149 instance Summish Format where
150 pVoid = MkFormat absurd pfail
151 (MkFormat sa ra) <++> (MkFormat sb rb) = let
152 sab (Left a) = sa a
153 sab (Right b) = sb b
154 rab = (fmap Left ra) +++ (fmap Right rb)
155 in MkFormat sab rab
156
157 literalFormat :: String -> Format ()
158 literalFormat s = MkFormat {formatShowM = \_ -> Just s, formatReadP = string s >> return ()}
159
160 specialCaseShowFormat :: Eq a => (a,String) -> Format a -> Format a
161 specialCaseShowFormat (val,str) (MkFormat s r) = let
162 s' t | t == val = Just str
163 s' t = s t
164 in MkFormat s' r
165
166 specialCaseFormat :: Eq a => (a,String) -> Format a -> Format a
167 specialCaseFormat (val,str) (MkFormat s r) = let
168 s' t | t == val = Just str
169 s' t = s t
170 r' = (string str >> return val) +++ r
171 in MkFormat s' r'
172
173 optionalFormat :: Eq a => a -> Format a -> Format a
174 optionalFormat val = specialCaseFormat (val,"")
175
176 casesFormat :: Eq a => [(a,String)] -> Format a
177 casesFormat pairs = let
178 s t = lookup t pairs
179 r [] = pfail
180 r ((v,str):pp) = (string str >> return v) <++ r pp
181 in MkFormat s $ r pairs
182
183 optionalSignFormat :: (Eq t,Num t) => Format t
184 optionalSignFormat = casesFormat
185 [
186 (1,""),
187 (1,"+"),
188 (0,""),
189 (-1,"-")
190 ]
191
192 mandatorySignFormat :: (Eq t,Num t) => Format t
193 mandatorySignFormat = casesFormat
194 [
195 (1,"+"),
196 (0,"+"),
197 (-1,"-")
198 ]
199
200 data SignOption
201 = NoSign
202 | NegSign
203 | PosNegSign
204
205 readSign :: Num t => SignOption -> ReadP (t -> t)
206 readSign NoSign = return id
207 readSign NegSign = option id $ char '-' >> return negate
208 readSign PosNegSign = (char '+' >> return id) +++ (char '-' >> return negate)
209
210 readNumber :: (Num t, Read t) => SignOption -> Maybe Int -> Bool -> ReadP t
211 readNumber signOpt mdigitcount allowDecimal = do
212 sign <- readSign signOpt
213 digits <-
214 case mdigitcount of
215 Just digitcount -> count digitcount $ satisfy isDigit
216 Nothing -> many1 $ satisfy isDigit
217 moredigits <-
218 case allowDecimal of
219 False -> return ""
220 True ->
221 option "" $ do
222 _ <- char '.' +++ char ','
223 dd <- many1 (satisfy isDigit)
224 return $ '.' : dd
225 return $ sign $ read $ digits ++ moredigits
226
227 zeroPad :: Maybe Int -> String -> String
228 zeroPad Nothing s = s
229 zeroPad (Just i) s = replicate (i - length s) '0' ++ s
230
231 trimTrailing :: String -> String
232 trimTrailing "" = ""
233 trimTrailing "." = ""
234 trimTrailing s | last s == '0' = trimTrailing $ init s
235 trimTrailing s = s
236
237 showNumber :: Show t => SignOption -> Maybe Int -> t -> Maybe String
238 showNumber signOpt mdigitcount t = let
239 showIt str = let
240 (intPart, decPart) = break ((==) '.') str
241 in (zeroPad mdigitcount intPart) ++ trimTrailing decPart
242 in case show t of
243 ('-':str) ->
244 case signOpt of
245 NoSign -> Nothing
246 _ -> Just $ '-' : showIt str
247 str ->
248 Just $ case signOpt of
249 PosNegSign -> '+' : showIt str
250 _ -> showIt str
251
252 integerFormat :: (Show t,Read t,Num t) => SignOption -> Maybe Int -> Format t
253 integerFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount False)
254
255 decimalFormat :: (Show t,Read t,Num t) => SignOption -> Maybe Int -> Format t
256 decimalFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount True)