vformat-0.9.0.0: src/Text/Format/ArgFmt.hs
module Text.Format.ArgFmt
( FmtAlign(..)
, FmtSign(..)
, FmtNumSep(..)
, ArgFmt(..)
, formatText
, formatNumber
) where
import Control.Arrow
import Data.Char (isDigit)
import qualified Data.List as L
import Numeric
import Text.Format.ArgKey
import Text.Format.Internal
-- | How to align argument
--
-- Note: 'AlignNone' is equivalent to 'AlignLeft' unless
-- number's sign aware enabled
--
data FmtAlign = AlignNone -- ^ alignment is not specified
| AlignLeft -- ^ pad chars before argument
| AlignRight -- ^ pad chars before argument
| AlignCenter -- ^ pad chars before and after argument
| AlignSign -- ^ number specified, pad between sign and digits
deriving (Show, Eq)
-- | How to show number's sign
--
-- Note: 'SignNone' is equivalent to 'SignMinus' for signed numbers
data FmtSign = SignNone -- ^ sign is not specified
| SignPlus -- ^ show \'+\' for positive and \'-\' for negative
| SignMinus -- ^ show negative's sign only
| SignSpace -- ^ show ' ' for positive and '-' for negative
deriving (Show, Eq)
-- | Number separator
data FmtNumSep = NumSepNone -- ^ don't seprate
| NumSepDash -- ^ seprate by '_'
| NumSepComma -- ^ seprate by ','
deriving (Show, Eq)
-- | Description of argument format options
--
-- When read from string, the sytax is as follows:
--
-- > [[pad]align][sign][#][0][width][separator][.precision][specs]
--
-- * __[]__ means an optional field (or filed group)
-- * __pad__ means char to be used for padding, it should be a literal 'Char',
-- default is space
-- * __align__ means align option
--
-- @
-- < AlignLeft
-- > AlignRight
-- ^ AlignCenter
-- = AlignSign
-- empty AlignNone
-- @
--
-- * __sign__ means number sign option
--
-- @
-- + SignPlus
-- - SignMinus
-- space SignSpace
-- empty SignNone
-- @
--
-- * __#__ means number alternate form option
--
-- * __0__ preceding __width__ option means sign-aware as well as zero-padding
--
-- @
-- number AlignNone & sign aware = AlignSign & pad '0'
-- other types means nothing
-- @
--
-- * __width__ means minimum argument width,
-- it may be an 'ArgKey' indicates it's value from another integer argument
--
-- @
-- integer minimum width
-- empty no minimum widht constrain
-- @
--
-- * __separator__ number separator option
--
-- @
-- _ NumSepDash
-- , NumSepComma
-- empty NumSepNone
-- @
--
-- * __precision__ (must leading with a dot)
-- number preceding or maximum with option
-- it may be an 'ArgKey' indicates it's value from another integer argument
--
-- @
-- for number (floating point) types number precision
-- for non-number types maximum widht
-- @
--
-- * __specs__ type specified options,
-- it determines how data should be presented,
-- see available type presentions below
--
--
-- == String presentions
-- @
-- s explicitly specified string type
-- empty implicitly specified string type
-- @
--
-- == Integer presentions
-- @
-- b binary format integer
-- c char point ('Char' will be trasformed by 'Char.ord' first)
-- d decimal format integer
-- o octal format integer
-- x hex format integer (use lower-case letters)
-- X hex format integer (use upper-case letters)
-- empty same as "d"
-- @
--
-- == Floating point number presentions
-- @
-- e exponent notation, see 'Numeric.showEFloat'
-- E same as "e", but use upper-case 'E' as separator
-- f fixed-point notation see 'Numeric.showFFloat'
-- F same as "f", but converts nan to NAN and inf to INF
-- g general format, see 'Numeric.showGFloat'
-- G same as "g", but use upper-case 'E' as separator and
-- converts nan to NAN and inf to INF
-- % percentage, same as "f" except multiplies 100 first and
-- followed by a percent sign
-- empty same as "g"
-- @
--
-- == Examples
-- >>> read "*<30s" :: ArgFmt
-- >>> read "<10.20s" :: ArgFmt
-- >>> read "0=10_.20d" :: ArgFmt
-- >>> read "#010_.20b" :: ArgFmt
--
data ArgFmt = ArgFmt { fmtAlign :: FmtAlign
, fmtPad :: Char
, fmtSign :: FmtSign
, fmtAlternate :: Bool
, fmtSignAware :: Bool
, fmtWidth :: Either Int ArgKey
, fmtNumSep :: FmtNumSep
, fmtPrecision :: Either Int ArgKey
, fmtSpecs :: String
} deriving (Show, Eq)
instance Read ArgFmt where
readsPrec _ cs =
let (align, pad, cs1) = parseAlign cs
(sign, cs2) = parseSign cs1
(alternate, cs3) = parseAlternate cs2
(aware, cs4) = parseSignAware cs3
(width, cs5) = parseWidth cs4
(sep, cs6) = parseNumSep cs5
(precision, specs) = parsePrecision cs6
in [(ArgFmt align pad sign alternate aware width sep precision specs, "")]
where
parseAlign (c : '<' : cs) = (AlignLeft, c, cs)
parseAlign (c : '>' : cs) = (AlignRight, c, cs)
parseAlign (c : '^' : cs) = (AlignCenter, c, cs)
parseAlign (c : '=' : cs) = (AlignSign, c, cs)
parseAlign ('<' : cs) = (AlignLeft, ' ', cs)
parseAlign ('>' : cs) = (AlignRight,' ', cs)
parseAlign ('^' : cs) = (AlignCenter, ' ', cs)
parseAlign ('=' : cs) = (AlignSign,' ', cs)
parseAlign cs = (AlignNone, ' ', cs)
parseSign ('+' : cs) = (SignPlus, cs)
parseSign ('-' : cs) = (SignMinus, cs)
parseSign (' ' : cs) = (SignSpace, cs)
parseSign cs = (SignNone, cs)
parseAlternate ('#' : cs) = (True, cs)
parseAlternate cs = (False, cs)
parseSignAware ('0' : cs) = (True, cs)
parseSignAware cs = (False, cs)
parseWidth ('{' : cs) =
case L.break (== '}') cs of
("", _) -> errorCloseTag
(ks, '}' : cs1) -> (Right (read ks), cs1)
parseWidth cs =
case L.break (not . isDigit) cs of
("", cs1) -> (Left (-1), cs)
(ds, cs1) -> (Left (read ds), cs1)
parseNumSep ('_' : cs) = (NumSepDash, cs)
parseNumSep (',' : cs) = (NumSepComma, cs)
parseNumSep cs = (NumSepNone, cs)
parsePrecision ('.' : '{' : cs) =
case L.break (== '}') cs of
("", _) -> errorCloseTag
(ks, '}' : cs1) -> (Right (read ks), cs1)
parsePrecision ('.' : cs) =
case L.break (not . isDigit) cs of
("", cs1) -> (Left 0, cs)
(ds, cs1) -> (Left (read ds), cs1)
parsePrecision cs = (Left (-1), cs)
formatText :: ArgFmt -> ShowS
formatText fmt@ArgFmt{fmtWidth=(Left minw), fmtPrecision=(Left maxw)} cs
| padw > 0 = pad (fmtAlign fmt) padw (fmtPad fmt)
| otherwise = cs1
where
cs1 = if maxw > 0 && maxw < length cs then take maxw cs else cs
padw = minw - (length cs1)
pad :: FmtAlign -> Int -> Char -> String
pad AlignNone n c = pad AlignLeft n c
pad AlignLeft n c = cs1 ++ replicate n c
pad AlignRight n c = replicate n c ++ cs1
pad AlignCenter n c =
let ln = div n 2
in replicate ln c ++ cs1 ++ (replicate (n - ln) c)
formatText _ _ = errorArgFmt "this should never happen"
formatNumber :: ArgFmt -> Bool -> Int -> Maybe Char -> ShowS
formatNumber fmt signed sepWidth flag cs = uncurry (++) $
pad (fmtAlign fmt) (fmtPad fmt) (fmtSignAware fmt) $
second (seperate (fmtNumSep fmt) sepWidth) $
sign (fmtSign fmt) signed $
alternate (fmtAlternate fmt) flag cs
where
pad :: FmtAlign -> Char -> Bool -> (String, String) -> (String, String)
pad AlignNone c False (ps, cs) = (ps, cs)
pad AlignNone c True (ps, cs) = pad AlignSign '0' False (ps, cs)
pad AlignLeft c _ (ps, cs) = (ps, cs ++ replicate (padw ps cs) c)
pad AlignRight c _ (ps, cs) = (replicate (padw ps cs) c ++ ps, cs)
pad AlignSign c True (ps, cs) = pad AlignSign c True (ps, cs)
pad AlignSign '0' False (ps, cs) =
let cs1 = fixSep (fmtNumSep fmt) sepWidth (padw ps cs) cs
in (ps, cs1)
pad AlignSign c False (ps, cs) = (ps, replicate (padw ps cs) c ++ cs)
pad AlignCenter c _ (ps, cs) =
let n = padw ps cs; ln = div n 2
in (replicate ln c ++ ps, cs ++ (replicate (n - ln) c))
padw :: String -> String -> Int
padw ps cs = max 0 $
case fmtWidth fmt of Left n -> n - (length ps) - (length cs); _ -> 0
fixSep :: FmtNumSep -> Int -> Int -> String -> String
fixSep NumSepNone _ n cs = replicate n '0' ++ cs
fixSep sep w n cs =
let sepChar = if sep == NumSepComma then ',' else '_'
(cs1, cs2) = L.break (== sepChar) cs
(wc, r) = divMod (n + length cs1) (w + 1)
n1 = n - wc + if r > 0 then 0 else 1
in rseperate sepChar w (reverse cs1 ++ replicate n1 '0') ++ cs2
seperate :: FmtNumSep -> Int -> String -> String
seperate NumSepNone _ cs = cs
seperate sep w cs =
let sepChar = if sep == NumSepComma then ',' else '_'
(cs1, cs2) = L.break (== '.') cs
in rseperate sepChar w $ reverse cs1
rseperate :: Char -> Int -> String -> String
rseperate sep w cs =
case L.splitAt w cs of
(cs1, "") -> reverse cs1
(cs1, cs2) -> rseperate sep w cs2 ++ (sep : reverse cs1)
sign :: FmtSign -> Bool -> (String, String) -> (String, String)
sign SignNone True (ps, cs) = sign SignMinus True (ps, cs)
sign SignPlus True (ps, '-' : cs) = ('-' : ps, cs)
sign SignPlus True (ps, '+' : cs) = ('+' : ps, cs)
sign SignPlus True (ps, cs) = ('+' : ps, cs)
sign SignMinus True (ps, '-': cs) = ('-' : ps, cs)
sign SignSpace True (ps, '+' : cs) = (' ' : ps, cs)
sign SignSpace True (ps, '-' : cs) = ('-' : ps, cs)
sign SignSpace True (ps, cs) = (' ' : ps, cs)
sign _ _ (ps, '+' : cs) = (ps, cs)
sign _ _ (ps, '-' : cs) = (ps, cs)
sign _ _ (ps, cs) = (ps, cs)
alternate :: Bool -> Maybe Char -> String -> (String, String)
alternate True (Just c) cs = (['0', c], cs)
alternate _ _ cs = ("", cs)