{-# LANGUAGE Safe #-}
module Data.Format
( Productish(..)
, Summish(..)
, parseReader
, Format(..)
, formatShow
, formatParseM
, isoMap
, mapMFormat
, filterFormat
, clipFormat
, enumMap
, literalFormat
, specialCaseShowFormat
, specialCaseFormat
, optionalFormat
, casesFormat
, optionalSignFormat
, mandatorySignFormat
, SignOption(..)
, integerFormat
, decimalFormat
) where
import Control.Monad.Fail
import Data.Char
import Data.Void
import Prelude hiding (fail)
import Text.ParserCombinators.ReadP
class IsoVariant f where
isoMap :: (a -> b) -> (b -> a) -> f a -> f b
enumMap :: (IsoVariant f, Enum a) => f Int -> f a
enumMap :: forall (f :: * -> *) a. (IsoVariant f, Enum a) => f Int -> f a
enumMap = forall (f :: * -> *) a b.
IsoVariant f =>
(a -> b) -> (b -> a) -> f a -> f b
isoMap forall a. Enum a => Int -> a
toEnum forall a. Enum a => a -> Int
fromEnum
infixr 3 <**>, **>, <**
class IsoVariant f => Productish f where
pUnit :: f ()
(<**>) :: f a -> f b -> f (a, b)
(**>) :: f () -> f a -> f a
f ()
fu **> f a
fa = forall (f :: * -> *) a b.
IsoVariant f =>
(a -> b) -> (b -> a) -> f a -> f b
isoMap (\((), a
a) -> a
a) (\a
a -> ((), a
a)) forall a b. (a -> b) -> a -> b
$ f ()
fu forall (f :: * -> *) a b. Productish f => f a -> f b -> f (a, b)
<**> f a
fa
(<**) :: f a -> f () -> f a
f a
fa <** f ()
fu = forall (f :: * -> *) a b.
IsoVariant f =>
(a -> b) -> (b -> a) -> f a -> f b
isoMap (\(a
a, ()) -> a
a) (\a
a -> (a
a, ())) forall a b. (a -> b) -> a -> b
$ f a
fa forall (f :: * -> *) a b. Productish f => f a -> f b -> f (a, b)
<**> f ()
fu
infixr 2 <++>
class IsoVariant f => Summish f where
pVoid :: f Void
(<++>) :: f a -> f b -> f (Either a b)
parseReader :: (MonadFail m) => ReadP t -> String -> m t
parseReader :: forall (m :: * -> *) t. MonadFail m => ReadP t -> String -> m t
parseReader ReadP t
readp String
s =
case [t
t | (t
t, String
"") <- forall a. ReadP a -> ReadS a
readP_to_S ReadP t
readp String
s] of
[t
t] -> forall (m :: * -> *) a. Monad m => a -> m a
return t
t
[] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"no parse of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s
[t]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"multiple parses of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s
data Format t = MkFormat
{ forall t. Format t -> t -> Maybe String
formatShowM :: t -> Maybe String
, forall t. Format t -> ReadP t
formatReadP :: ReadP t
}
formatShow :: Format t -> t -> String
formatShow :: forall t. Format t -> t -> String
formatShow Format t
fmt t
t =
case forall t. Format t -> t -> Maybe String
formatShowM Format t
fmt t
t of
Just String
str -> String
str
Maybe String
Nothing -> forall a. HasCallStack => String -> a
error String
"formatShow: bad value"
formatParseM :: (MonadFail m) => Format t -> String -> m t
formatParseM :: forall (m :: * -> *) t. MonadFail m => Format t -> String -> m t
formatParseM Format t
format = forall (m :: * -> *) t. MonadFail m => ReadP t -> String -> m t
parseReader forall a b. (a -> b) -> a -> b
$ forall t. Format t -> ReadP t
formatReadP Format t
format
instance IsoVariant Format where
isoMap :: forall a b. (a -> b) -> (b -> a) -> Format a -> Format b
isoMap a -> b
ab b -> a
ba (MkFormat a -> Maybe String
sa ReadP a
ra) = forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat (\b
b -> a -> Maybe String
sa forall a b. (a -> b) -> a -> b
$ b -> a
ba b
b) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
ab ReadP a
ra)
mapMFormat :: (a -> Maybe b) -> (b -> Maybe a) -> Format a -> Format b
mapMFormat :: forall a b.
(a -> Maybe b) -> (b -> Maybe a) -> Format a -> Format b
mapMFormat a -> Maybe b
amb b -> Maybe a
bma (MkFormat a -> Maybe String
sa ReadP a
ra) =
forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat (\b
b -> b -> Maybe a
bma b
b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Maybe String
sa) forall a b. (a -> b) -> a -> b
$ do
a
a <- ReadP a
ra
case a -> Maybe b
amb a
a of
Just b
b -> forall (m :: * -> *) a. Monad m => a -> m a
return b
b
Maybe b
Nothing -> forall a. ReadP a
pfail
filterFormat :: (a -> Bool) -> Format a -> Format a
filterFormat :: forall a. (a -> Bool) -> Format a -> Format a
filterFormat a -> Bool
test =
forall a b.
(a -> Maybe b) -> (b -> Maybe a) -> Format a -> Format b
mapMFormat
(\a
a ->
if a -> Bool
test a
a
then forall a. a -> Maybe a
Just a
a
else forall a. Maybe a
Nothing)
(\a
a ->
if a -> Bool
test a
a
then forall a. a -> Maybe a
Just a
a
else forall a. Maybe a
Nothing)
clipFormat :: Ord a => (a, a) -> Format a -> Format a
clipFormat :: forall a. Ord a => (a, a) -> Format a -> Format a
clipFormat (a
lo, a
hi) = forall a. (a -> Bool) -> Format a -> Format a
filterFormat (\a
a -> a
a forall a. Ord a => a -> a -> Bool
>= a
lo Bool -> Bool -> Bool
&& a
a forall a. Ord a => a -> a -> Bool
<= a
hi)
instance Productish Format where
pUnit :: Format ()
pUnit = MkFormat {formatShowM :: () -> Maybe String
formatShowM = \()
_ -> forall a. a -> Maybe a
Just String
"", formatReadP :: ReadP ()
formatReadP = forall (m :: * -> *) a. Monad m => a -> m a
return ()}
<**> :: forall a b. Format a -> Format b -> Format (a, b)
(<**>) (MkFormat a -> Maybe String
sa ReadP a
ra) (MkFormat b -> Maybe String
sb ReadP b
rb) = let
sab :: (a, b) -> Maybe String
sab (a
a, b
b) = do
String
astr <- a -> Maybe String
sa a
a
String
bstr <- b -> Maybe String
sb b
b
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
astr forall a. [a] -> [a] -> [a]
++ String
bstr
rab :: ReadP (a, b)
rab = do
a
a <- ReadP a
ra
b
b <- ReadP b
rb
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)
in forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat (a, b) -> Maybe String
sab ReadP (a, b)
rab
(MkFormat () -> Maybe String
sa ReadP ()
ra) **> :: forall a. Format () -> Format a -> Format a
**> (MkFormat a -> Maybe String
sb ReadP a
rb) = let
s :: a -> Maybe String
s a
b = do
String
astr <- () -> Maybe String
sa ()
String
bstr <- a -> Maybe String
sb a
b
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
astr forall a. [a] -> [a] -> [a]
++ String
bstr
r :: ReadP a
r = do
ReadP ()
ra
ReadP a
rb
in forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat a -> Maybe String
s ReadP a
r
(MkFormat a -> Maybe String
sa ReadP a
ra) <** :: forall a. Format a -> Format () -> Format a
<** (MkFormat () -> Maybe String
sb ReadP ()
rb) = let
s :: a -> Maybe String
s a
a = do
String
astr <- a -> Maybe String
sa a
a
String
bstr <- () -> Maybe String
sb ()
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
astr forall a. [a] -> [a] -> [a]
++ String
bstr
r :: ReadP a
r = do
a
a <- ReadP a
ra
ReadP ()
rb
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
in forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat a -> Maybe String
s ReadP a
r
instance Summish Format where
pVoid :: Format Void
pVoid = forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat forall a. Void -> a
absurd forall a. ReadP a
pfail
(MkFormat a -> Maybe String
sa ReadP a
ra) <++> :: forall a b. Format a -> Format b -> Format (Either a b)
<++> (MkFormat b -> Maybe String
sb ReadP b
rb) = let
sab :: Either a b -> Maybe String
sab (Left a
a) = a -> Maybe String
sa a
a
sab (Right b
b) = b -> Maybe String
sb b
b
rab :: ReadP (Either a b)
rab = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left ReadP a
ra) forall a. ReadP a -> ReadP a -> ReadP a
+++ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right ReadP b
rb)
in forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat Either a b -> Maybe String
sab ReadP (Either a b)
rab
literalFormat :: String -> Format ()
literalFormat :: String -> Format ()
literalFormat String
s = MkFormat {formatShowM :: () -> Maybe String
formatShowM = \()
_ -> forall a. a -> Maybe a
Just String
s, formatReadP :: ReadP ()
formatReadP = String -> ReadP String
string String
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()}
specialCaseShowFormat :: Eq a => (a, String) -> Format a -> Format a
specialCaseShowFormat :: forall a. Eq a => (a, String) -> Format a -> Format a
specialCaseShowFormat (a
val, String
str) (MkFormat a -> Maybe String
s ReadP a
r) = let
s' :: a -> Maybe String
s' a
t
| a
t forall a. Eq a => a -> a -> Bool
== a
val = forall a. a -> Maybe a
Just String
str
s' a
t = a -> Maybe String
s a
t
in forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat a -> Maybe String
s' ReadP a
r
specialCaseFormat :: Eq a => (a, String) -> Format a -> Format a
specialCaseFormat :: forall a. Eq a => (a, String) -> Format a -> Format a
specialCaseFormat (a
val, String
str) (MkFormat a -> Maybe String
s ReadP a
r) = let
s' :: a -> Maybe String
s' a
t
| a
t forall a. Eq a => a -> a -> Bool
== a
val = forall a. a -> Maybe a
Just String
str
s' a
t = a -> Maybe String
s a
t
r' :: ReadP a
r' = (String -> ReadP String
string String
str forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
val) forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP a
r
in forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat a -> Maybe String
s' ReadP a
r'
optionalFormat :: Eq a => a -> Format a -> Format a
optionalFormat :: forall a. Eq a => a -> Format a -> Format a
optionalFormat a
val = forall a. Eq a => (a, String) -> Format a -> Format a
specialCaseFormat (a
val, String
"")
casesFormat :: Eq a => [(a, String)] -> Format a
casesFormat :: forall a. Eq a => [(a, String)] -> Format a
casesFormat [(a, String)]
pairs = let
s :: a -> Maybe String
s a
t = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
t [(a, String)]
pairs
r :: [(a, String)] -> ReadP a
r [] = forall a. ReadP a
pfail
r ((a
v, String
str):[(a, String)]
pp) = (String -> ReadP String
string String
str forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
v) forall a. ReadP a -> ReadP a -> ReadP a
<++ [(a, String)] -> ReadP a
r [(a, String)]
pp
in forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat a -> Maybe String
s forall a b. (a -> b) -> a -> b
$ forall {a}. [(a, String)] -> ReadP a
r [(a, String)]
pairs
optionalSignFormat :: (Eq t, Num t) => Format t
optionalSignFormat :: forall t. (Eq t, Num t) => Format t
optionalSignFormat = forall a. Eq a => [(a, String)] -> Format a
casesFormat [(t
1, String
""), (t
1, String
"+"), (t
0, String
""), (-t
1, String
"-")]
mandatorySignFormat :: (Eq t, Num t) => Format t
mandatorySignFormat :: forall t. (Eq t, Num t) => Format t
mandatorySignFormat = forall a. Eq a => [(a, String)] -> Format a
casesFormat [(t
1, String
"+"), (t
0, String
"+"), (-t
1, String
"-")]
data SignOption
= NoSign
| NegSign
| PosNegSign
readSign :: Num t => SignOption -> ReadP (t -> t)
readSign :: forall t. Num t => SignOption -> ReadP (t -> t)
readSign SignOption
NoSign = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
readSign SignOption
NegSign = forall a. a -> ReadP a -> ReadP a
option forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Num a => a -> a
negate
readSign SignOption
PosNegSign = (Char -> ReadP Char
char Char
'+' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id) forall a. ReadP a -> ReadP a -> ReadP a
+++ (Char -> ReadP Char
char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Num a => a -> a
negate)
readNumber :: (Num t, Read t) => SignOption -> Maybe Int -> Bool -> ReadP t
readNumber :: forall t.
(Num t, Read t) =>
SignOption -> Maybe Int -> Bool -> ReadP t
readNumber SignOption
signOpt Maybe Int
mdigitcount Bool
allowDecimal = do
t -> t
sign <- forall t. Num t => SignOption -> ReadP (t -> t)
readSign SignOption
signOpt
String
digits <-
case Maybe Int
mdigitcount of
Just Int
digitcount -> forall a. Int -> ReadP a -> ReadP [a]
count Int
digitcount forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isDigit
Maybe Int
Nothing -> forall a. ReadP a -> ReadP [a]
many1 forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isDigit
String
moredigits <-
case Bool
allowDecimal of
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return String
""
Bool
True ->
forall a. a -> ReadP a -> ReadP a
option String
"" forall a b. (a -> b) -> a -> b
$ do
Char
_ <- Char -> ReadP Char
char Char
'.' forall a. ReadP a -> ReadP a -> ReadP a
+++ Char -> ReadP Char
char Char
','
String
dd <- forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isDigit)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Char
'.' forall a. a -> [a] -> [a]
: String
dd
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ t -> t
sign forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read forall a b. (a -> b) -> a -> b
$ String
digits forall a. [a] -> [a] -> [a]
++ String
moredigits
zeroPad :: Maybe Int -> String -> String
zeroPad :: Maybe Int -> String -> String
zeroPad Maybe Int
Nothing String
s = String
s
zeroPad (Just Int
i) String
s = forall a. Int -> a -> [a]
replicate (Int
i forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
'0' forall a. [a] -> [a] -> [a]
++ String
s
trimTrailing :: String -> String
trimTrailing :: String -> String
trimTrailing String
"" = String
""
trimTrailing String
"." = String
""
trimTrailing String
s
| forall a. [a] -> a
last String
s forall a. Eq a => a -> a -> Bool
== Char
'0' = String -> String
trimTrailing forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
init String
s
trimTrailing String
s = String
s
showNumber :: Show t => SignOption -> Maybe Int -> t -> Maybe String
showNumber :: forall t. Show t => SignOption -> Maybe Int -> t -> Maybe String
showNumber SignOption
signOpt Maybe Int
mdigitcount t
t = let
showIt :: String -> String
showIt String
str = let
(String
intPart, String
decPart) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
(==) Char
'.') String
str
in (Maybe Int -> String -> String
zeroPad Maybe Int
mdigitcount String
intPart) forall a. [a] -> [a] -> [a]
++ String -> String
trimTrailing String
decPart
in case forall a. Show a => a -> String
show t
t of
(Char
'-':String
str) ->
case SignOption
signOpt of
SignOption
NoSign -> forall a. Maybe a
Nothing
SignOption
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Char
'-' forall a. a -> [a] -> [a]
: String -> String
showIt String
str
String
str ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
case SignOption
signOpt of
SignOption
PosNegSign -> Char
'+' forall a. a -> [a] -> [a]
: String -> String
showIt String
str
SignOption
_ -> String -> String
showIt String
str
integerFormat :: (Show t, Read t, Num t) => SignOption -> Maybe Int -> Format t
integerFormat :: forall t.
(Show t, Read t, Num t) =>
SignOption -> Maybe Int -> Format t
integerFormat SignOption
signOpt Maybe Int
mdigitcount = forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat (forall t. Show t => SignOption -> Maybe Int -> t -> Maybe String
showNumber SignOption
signOpt Maybe Int
mdigitcount) (forall t.
(Num t, Read t) =>
SignOption -> Maybe Int -> Bool -> ReadP t
readNumber SignOption
signOpt Maybe Int
mdigitcount Bool
False)
decimalFormat :: (Show t, Read t, Num t) => SignOption -> Maybe Int -> Format t
decimalFormat :: forall t.
(Show t, Read t, Num t) =>
SignOption -> Maybe Int -> Format t
decimalFormat SignOption
signOpt Maybe Int
mdigitcount = forall t. (t -> Maybe String) -> ReadP t -> Format t
MkFormat (forall t. Show t => SignOption -> Maybe Int -> t -> Maybe String
showNumber SignOption
signOpt Maybe Int
mdigitcount) (forall t.
(Num t, Read t) =>
SignOption -> Maybe Int -> Bool -> ReadP t
readNumber SignOption
signOpt Maybe Int
mdigitcount Bool
True)