lib/Data/Format.hs

    {-# 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 = isoMap toEnum fromEnum

    infixr 3 <**>, **>, <**

    class IsoVariant f => Productish f where
        pUnit :: f ()
        (<**>) :: f a -> f b -> f (a, b)
        (**>) :: f () -> f a -> f a
        fu **> fa = isoMap (\((), a) -> a) (\a -> ((), a)) $ fu <**> fa
        (<**) :: f a -> f () -> f a
        fa <** fu = isoMap (\(a, ()) -> a) (\a -> (a, ())) $ fa <**> 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 readp s =
        case [t | (t, "") <- readP_to_S readp s] of
            [t] -> return t
            [] -> fail $ "no parse of " ++ show s
            _ -> fail $ "multiple parses of " ++ show s

    -- | A text format for a type
    data Format t = MkFormat
        { formatShowM :: t -> Maybe String
            -- ^ Show a value in the format, if representable
        , 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 fmt t =
        case formatShowM fmt t of
            Just str -> str
            Nothing -> error "formatShow: bad value"

    -- | Parse a value in the format
    formatParseM :: (MonadFail m) => Format t -> String -> m t
    formatParseM format = parseReader $ formatReadP format

    instance IsoVariant Format where
        isoMap ab ba (MkFormat sa ra) = MkFormat (\b -> sa $ ba b) (fmap ab ra)

    mapMFormat :: (a -> Maybe b) -> (b -> Maybe a) -> Format a -> Format b
    mapMFormat amb bma (MkFormat sa ra) =
        MkFormat (\b -> bma b >>= sa) $ do
            a <- ra
            case amb a of
                Just b -> return b
                Nothing -> pfail

    filterFormat :: (a -> Bool) -> Format a -> Format a
    filterFormat test =
        mapMFormat
            (\a ->
                 if test a
                     then Just a
                     else Nothing)
            (\a ->
                 if test a
                     then Just a
                     else Nothing)

    -- | Limits are inclusive
    clipFormat :: Ord a => (a, a) -> Format a -> Format a
    clipFormat (lo, hi) = filterFormat (\a -> a >= lo && a <= hi)

    instance Productish Format where
        pUnit = MkFormat {formatShowM = \_ -> Just "", formatReadP = return ()}
        (<**>) (MkFormat sa ra) (MkFormat sb rb) = let
            sab (a, b) = do
                astr <- sa a
                bstr <- sb b
                return $ astr ++ bstr
            rab = do
                a <- ra
                b <- rb
                return (a, b)
            in MkFormat sab rab
        (MkFormat sa ra) **> (MkFormat sb rb) = let
            s b = do
                astr <- sa ()
                bstr <- sb b
                return $ astr ++ bstr
            r = do
                ra
                rb
            in MkFormat s r
        (MkFormat sa ra) <** (MkFormat sb rb) = let
            s a = do
                astr <- sa a
                bstr <- sb ()
                return $ astr ++ bstr
            r = do
                a <- ra
                rb
                return a
            in MkFormat s r

    instance Summish Format where
        pVoid = MkFormat absurd pfail
        (MkFormat sa ra) <++> (MkFormat sb rb) = let
            sab (Left a) = sa a
            sab (Right b) = sb b
            rab = (fmap Left ra) +++ (fmap Right rb)
            in MkFormat sab rab

    literalFormat :: String -> Format ()
    literalFormat s = MkFormat {formatShowM = \_ -> Just s, formatReadP = string s >> return ()}

    specialCaseShowFormat :: Eq a => (a, String) -> Format a -> Format a
    specialCaseShowFormat (val, str) (MkFormat s r) = let
        s' t
            | t == val = Just str
        s' t = s t
        in MkFormat s' r

    specialCaseFormat :: Eq a => (a, String) -> Format a -> Format a
    specialCaseFormat (val, str) (MkFormat s r) = let
        s' t
            | t == val = Just str
        s' t = s t
        r' = (string str >> return val) +++ r
        in MkFormat s' r'

    optionalFormat :: Eq a => a -> Format a -> Format a
    optionalFormat val = specialCaseFormat (val, "")

    casesFormat :: Eq a => [(a, String)] -> Format a
    casesFormat pairs = let
        s t = lookup t pairs
        r [] = pfail
        r ((v, str):pp) = (string str >> return v) <++ r pp
        in MkFormat s $ r pairs

    optionalSignFormat :: (Eq t, Num t) => Format t
    optionalSignFormat = casesFormat [(1, ""), (1, "+"), (0, ""), (-1, "-")]

    mandatorySignFormat :: (Eq t, Num t) => Format t
    mandatorySignFormat = casesFormat [(1, "+"), (0, "+"), (-1, "-")]

    data SignOption
        = NoSign
        | NegSign
        | PosNegSign

    readSign :: Num t => SignOption -> ReadP (t -> t)
    readSign NoSign = return id
    readSign NegSign = option id $ char '-' >> return negate
    readSign PosNegSign = (char '+' >> return id) +++ (char '-' >> return negate)

    readNumber :: (Num t, Read t) => SignOption -> Maybe Int -> Bool -> ReadP t
    readNumber signOpt mdigitcount allowDecimal = do
        sign <- readSign signOpt
        digits <-
            case mdigitcount of
                Just digitcount -> count digitcount $ satisfy isDigit
                Nothing -> many1 $ satisfy isDigit
        moredigits <-
            case allowDecimal of
                False -> return ""
                True ->
                    option "" $ do
                        _ <- char '.' +++ char ','
                        dd <- many1 (satisfy isDigit)
                        return $ '.' : dd
        return $ sign $ read $ digits ++ moredigits

    zeroPad :: Maybe Int -> String -> String
    zeroPad Nothing s = s
    zeroPad (Just i) s = replicate (i - length s) '0' ++ s

    trimTrailing :: String -> String
    trimTrailing "" = ""
    trimTrailing "." = ""
    trimTrailing s
        | last s == '0' = trimTrailing $ init s
    trimTrailing s = s

    showNumber :: Show t => SignOption -> Maybe Int -> t -> Maybe String
    showNumber signOpt mdigitcount t = let
        showIt str = let
            (intPart, decPart) = break ((==) '.') str
            in (zeroPad mdigitcount intPart) ++ trimTrailing decPart
        in case show t of
               ('-':str) ->
                   case signOpt of
                       NoSign -> Nothing
                       _ -> Just $ '-' : showIt str
               str ->
                   Just $
                   case signOpt of
                       PosNegSign -> '+' : showIt str
                       _ -> showIt str

    integerFormat :: (Show t, Read t, Num t) => SignOption -> Maybe Int -> Format t
    integerFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount False)

    decimalFormat :: (Show t, Read t, Num t) => SignOption -> Maybe Int -> Format t
    decimalFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount True)