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