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