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