{-# 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

-- | A text format for a type
data Format t = MkFormat
    { forall t. Format t -> t -> Maybe String
formatShowM :: t -> Maybe String
        -- ^ Show a value in the format, if representable
    , forall t. Format t -> ReadP t
formatReadP :: ReadP t
        -- ^ Read a value in the format
    }

-- | Show a value in the format, or error if unrepresentable
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"

-- | Parse a value in the format
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)

-- | Limits are inclusive
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)