diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for vformat + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019 Version Cloud + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of QK.G nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# vformat + +Please see http://hackage.haskell.org/package/vformat diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Text/Format.hs b/src/Text/Format.hs new file mode 100644 --- /dev/null +++ b/src/Text/Format.hs @@ -0,0 +1,105 @@ +{-| +Module : Text.Format +Copyright : (c) 2019 Version Cloud +License : BSD3 +Maintainer : Jorah Gao +Stability : experimental +Portability : portable + +'Text.Format' vs [Text.Printf](http://hackage.haskell.org/package/base/docs/Text-Printf.html) + +* Printf is more ligth-weight +* Printf is more effective in basic formatting, e.g.: + + @ + printf "%s %d %f" "hello" 123 456.789 + format "{:s} {:d} {:f}" "hello" 123 456.789 + @ + +* Format is more effective in complex formatting, e.g.: + + @ + printf "%30s %30d %30f" "hello" 123 456.789 + format "{:>30s} {:>30d} {:>30f}" "hello" 123 456.789 + @ + +* Printf can only consume args in order, e.g.: + + @ + printf "%s %d %f" "hello" 123 456.789 + format "{2:s} {1:d} {0:f}" 456.789 123 "hello" + @ + +* Printf can only consume position args, e.g.: + + @ + printf "%s %d %f" "hello" 123 456.789 + format "{hello:s} {int:d} {float:f}" ("hello" := "hello") ("int" := 123) + ("float" := 456.789) + @ + +* Format is easier to implement for a new type, e.g.: + + @ + instance FormatArg UTCTime where + formatArg x _ fmt = formatTime defaultTimeLocale (fmtSpecs fmt) x + + format "{:%Y-%m-%d}" $ read "2019-01-01" :: UTCTime + @ + + @ + data Student = Student { name :: String + , age :: Int + , email :: String + } deriving Generic + + instance FormatArg Student + + format "{0!name:<20s} {0!age:<10d} {0!email:<20s}" $ + Student "Jorah Gao" 27 "jorah@version.cloud" + @ +-} + +module Text.Format + ( format + , format1 + , module Text.Format.Class + , module Text.Format.Format + , module Text.Format.ArgKey + , module Text.Format.ArgFmt + , module Text.Format.Internal + ) where + +import Data.Map (empty) + +import Text.Format.ArgFmt +import Text.Format.ArgKey +import Text.Format.Class +import Text.Format.Format +import Text.Format.Internal + + +-- | Format a variable number of argument with Python-style formatting string +-- +-- >>> format "hello {} {}" "world" "!" :: String +-- hello world ! +-- >>> format "hello {1} {0}" "!" "world" :: String +-- hello world ! +-- >>> format "hello {to} {bang}" ("to" := "world") ("bang" := "!") +-- hello world ! +-- +format :: FormatType r => Format -> r +format = flip sfmt empty + +-- | Format argument with Python-style formatting string +-- +-- >>> :set -XDeriveGeneric +-- >>> data Greeting = Greeting {to :: String, bang :: String} deriving Generic +-- >>> instance FormatArg Greeting +-- >>> format1 "hello {to} {bang}" (Greeting "world" "!") +-- hello world ! +-- >>> format "hello {0!to} {0!bang}" (Greeting "world" "!") +-- hello world ! +-- +format1 :: FormatArg a => Format1 -> a -> String +format1 = format . Format . unFormat1 diff --git a/src/Text/Format/ArgFmt.hs b/src/Text/Format/ArgFmt.hs new file mode 100644 --- /dev/null +++ b/src/Text/Format/ArgFmt.hs @@ -0,0 +1,298 @@ +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) diff --git a/src/Text/Format/ArgKey.hs b/src/Text/Format/ArgKey.hs new file mode 100644 --- /dev/null +++ b/src/Text/Format/ArgKey.hs @@ -0,0 +1,70 @@ +module Text.Format.ArgKey ( ArgKey (..) ) where + +import Control.Arrow +import Data.Char (isDigit) +import qualified Data.List as L + + +-- | ArgKey indicates a key of format argument +-- +-- There are two kinds of basic key, named and indexed, +-- and a composed key indicates a key which is a attribute of +-- an argument. +-- +-- When read from a String, the sytax is as followings: +-- +-- 1. if all chars are digits, it means an indexed key, +-- +-- 2. if there is a __"!"__, it means a nested key, +-- the chars before __"!"__ is parent key, +-- and the chars after are child key, +-- +-- 3. if you want to use literal __"!"__ in the key, you can write it doublely, +-- __"!!"__, +-- +-- 4. if there are not all digits, it's a named key. +-- +-- Examples: +-- +-- >>> read "country" :: ArgKey +-- Name "country" +-- +-- >>> read "123" :: ArgKey +-- Index 123 +-- +-- >>> read "country!name" :: ArgKey +-- Nest (Name "country") (Name "name") +-- +-- >>> read "country!cities!10" :: ArgKey +-- Nest (Name "country") (Nest (Name "cities") (Index 10)) +-- +-- >>> read "coun!!try" :: ArgKey +-- Name "coun!try" +-- +data ArgKey = Index Int + | Name String + | Nest ArgKey ArgKey + deriving (Show, Eq, Ord) + +instance Read ArgKey where + readsPrec _ "" = [ (Index (-1), "") ] + readsPrec _ cs = [ parse cs ] + where + parse :: String -> (ArgKey, String) + parse cs = + case break cs of + ("", cs1) -> (undefined, cs1) + (_, "!") -> (undefined, "!") + (cs1, "") -> (parse1 cs1, "") + (cs1, cs2) -> first (Nest $ parse1 cs1) (parse cs2) + + parse1 :: String -> ArgKey + parse1 cs = if all isDigit cs then Index (read cs) else Name cs + + break :: String -> (String, String) + break cs = + case L.break (== '!') cs of + (cs1, "") -> (cs1, "") + (cs1, "!") -> (cs1, "!") + (cs1, '!' : '!' : cs2) -> first ((cs1 ++ "!") ++) (break cs2) + (cs1, '!' : cs2) -> (cs1, cs2) diff --git a/src/Text/Format/Class.hs b/src/Text/Format/Class.hs new file mode 100644 --- /dev/null +++ b/src/Text/Format/Class.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Text.Format.Class + ( Formatter + , FormatArg(..) + , FormatType(..) + ) where + +import Control.Applicative +import Data.Char +import Data.Int +import Data.List ((!!)) +import Data.Map hiding (map) +import Data.Maybe +import Data.Time.Format +import Data.Word +import GHC.Generics +import Numeric +import Numeric.Natural + +import Text.Format.ArgFmt +import Text.Format.ArgKey +import Text.Format.Format +import Text.Format.Internal + +type Formatter = ArgKey -> ArgFmt -> String + + +-- | Typeclass of formatable values. +-- +-- Make an instance for your own data types: +-- +-- @ +-- data Coffe = Black | Latte | Other deriving Show +-- +-- instance FormatArg Coffe where +-- formatArg x k fmt = formatArg (show x) k fmt +-- @ +-- +-- @ +-- newtype Big a = Big { unBig :: a} +-- +-- instance FormatArg a => FormatArg (Big a) where +-- formatArg (Big x) k fmt = formatArg x k fmt +-- @ +-- +-- @ +-- data Student = Student { name :: String +-- , age :: Int +-- , email :: String +-- } deriving Generic +-- +-- instance FormatArg Student +-- @ +-- +-- @ +-- data Address = Address { country :: String +-- , city :: String +-- , street :: String +-- } +-- +-- instance FormatArg Address where +-- formatArg x k fmt = formatArg result k fmt +-- where +-- result :: String +-- result = format "{:s},{:s},{:s}" (street x) (city x) (country x) +-- @ +-- +class FormatArg a where + formatArg :: a -> Formatter + + default formatArg :: (Generic a, GFormatArg (Rep a)) => a -> Formatter + formatArg x = fromMaybe errorMissingArg . gformatArg (from x) + + keyOf :: a -> ArgKey + keyOf _ = Index (-1) + +instance {-# OVERLAPPABLE #-} FormatTime t => FormatArg t where + formatArg x _ fmt = formatTime defaultTimeLocale (fmtSpecs fmt) x + +instance {-# OVERLAPPABLE #-} FormatArg a => FormatArg [a] where + formatArg x (Nest _ k@(Index i)) = formatArg (x !! i) k + +instance {-# OVERLAPPABLE #-} FormatArg a => FormatArg (Map String a) where + formatArg x (Nest _ k@(Name n)) = formatArg (x ! n) k + +instance {-# OVERLAPPABLE #-} FormatArg a => FormatArg (Map Int a) where + formatArg x (Nest _ k@(Index i)) = formatArg (x ! i) k + +instance FormatArg a => FormatArg ((:=) a) where + formatArg (_ := x) = formatArg x + keyOf (ks := _) = Name ks + +instance FormatArg String where + formatArg = formatString + +instance FormatArg Char where + formatArg = formatInteger False . toInteger . ord + +instance FormatArg Int where + formatArg = formatInteger True . toInteger + +instance FormatArg Int8 where + formatArg = formatInteger True . toInteger + +instance FormatArg Int16 where + formatArg = formatInteger True . toInteger + +instance FormatArg Int32 where + formatArg = formatInteger True . toInteger + +instance FormatArg Int64 where + formatArg = formatInteger True . toInteger + +instance FormatArg Word where + formatArg = formatInteger False . toInteger + +instance FormatArg Word8 where + formatArg = formatInteger False . toInteger + +instance FormatArg Word16 where + formatArg = formatInteger False . toInteger + +instance FormatArg Word32 where + formatArg = formatInteger False . toInteger + +instance FormatArg Word64 where + formatArg = formatInteger False . toInteger + +instance FormatArg Integer where + formatArg = formatInteger True + +instance FormatArg Natural where + formatArg = formatInteger False . toInteger + +instance FormatArg Float where + formatArg = formatRealFloat + +instance FormatArg Double where + formatArg = formatRealFloat + + +-------------------------------------------------------------------------------- +class GFormatArg f where + gformatArg :: f p -> ArgKey -> Maybe (ArgFmt -> String) + +instance GFormatArg V1 where + gformatArg _ _ = Nothing + +instance GFormatArg U1 where + gformatArg _ _ = Nothing + +instance (FormatArg c) => GFormatArg (K1 i c) where + gformatArg (K1 c) = Just . formatArg c + +instance (GFormatArg f, GFormatArg g) => GFormatArg (f :+: g) where + gformatArg (L1 x) = gformatArg x + gformatArg (R1 x) = gformatArg x + +instance (GFormatArg f, GFormatArg g) => GFormatArg (f :*: g) where + gformatArg (x :*: y) = (<|>) <$> gformatArg x <*> gformatArg y + +instance (GFormatArg f) => GFormatArg (D1 c f) where + gformatArg (M1 x) = gformatArg x + +instance (GFormatArg f) => GFormatArg (C1 c f) where + gformatArg (M1 x) = gformatArg x + +instance (GFormatArg f, Selector c) => GFormatArg (S1 c f) where + gformatArg s@(M1 x) (Nest _ k@(Name field)) + | selName s == field = gformatArg x k + | otherwise = Nothing + gformatArg s@(M1 x) (Nest _ k@(Nest (Name field) _)) + | selName s == field = gformatArg x k + gformatArg _ _ = Nothing + + +-- | A typeclass provides the variable arguments magic for 'format' +-- +class FormatType t where + sfmt :: Format -> Map ArgKey Formatter -> t + +instance (FormatArg a, FormatType r) => FormatType (a -> r) where + sfmt fmt args = \arg -> sfmt fmt $ + insert (fixIndex $ keyOf arg) (formatArg arg) args + where + nextIndex = 1 + (maximum $ (-1) : [n | Index n <- keys args]) + fixIndex (Index (-1)) = Index nextIndex + fixIndex k = k + +instance FormatType String where + sfmt fmt args = formats (unFormat fmt) + where + formats :: [FmtItem] -> String + formats = concat . (map formats1) + + formats1 :: FmtItem -> String + formats1 (Lit cs) = cs + formats1 (Arg key ifmt) = (getFormatter key) key (fixArgFmt ifmt) + + fixArgFmt :: ArgFmt -> ArgFmt + fixArgFmt ifmt@(ArgFmt _ _ _ _ _ (Right key) _ _ _) = + fixArgFmt $ ifmt {fmtWidth = Left $ formatWidth key} + fixArgFmt ifmt@(ArgFmt _ _ _ _ _ _ _ (Right key) _) = + fixArgFmt $ ifmt {fmtPrecision = Left $ formatPrecision key} + fixArgFmt ifmt = ifmt + + formatWidth, formatPrecision :: ArgKey -> Int + formatWidth key = read $ (getFormatter key) key $ + ArgFmt AlignNone ' ' SignNone False False (Left 0) NumSepNone + (Left 0) "d" + formatPrecision = formatWidth + + getFormatter :: ArgKey -> Formatter + getFormatter (Nest key _) = getFormatter key + getFormatter key@(Index _) = fromMaybe errorMissingArg $ args !? key + getFormatter key@(Name _) = fromMaybe errorMissingArg $ args !? key + + +-------------------------------------------------------------------------------- +formatString :: String -> Formatter +formatString x _ fmt@(ArgFmt{fmtSpecs = ""}) = formatText fmt x +formatString x _ fmt@(ArgFmt{fmtSpecs = "s"}) = formatText fmt x +formatString _ _ _ = errorArgFmt "unknown specs" + +formatInteger :: Bool -> Integer -> Formatter +formatInteger signed x _ fmt@ArgFmt{fmtSpecs=specs} = + formatNumber fmt signed (sepw specs) (flag specs) (showx specs x) + where + sepw :: String -> Int + sepw "b" = 4 + sepw "o" = 4 + sepw "x" = 4 + sepw "X" = 4 + sepw _ = 3 + + flag :: String -> Maybe Char + flag "b" = Just 'b' + flag "o" = Just 'o' + flag "x" = Just 'x' + flag "X" = Just 'X' + flag _ = Nothing + + showx :: String -> Integer -> String + showx specs x | x < 0 = '-' : showx specs (-x) + showx "" x = showx "d" x + showx "b" x = showIntAtBase 2 intToDigit x "" + showx "c" x = [chr $ fromInteger x] + showx "d" x = show x + showx "o" x = showIntAtBase 8 intToDigit x "" + showx "x" x = showIntAtBase 16 intToDigit x "" + showx "X" x = map toUpper $ showx "x" x + showx _ _ = errorArgFmt "unknown spec" + +formatRealFloat :: RealFloat a => a -> Formatter +formatRealFloat x _ fmt@ArgFmt{fmtSpecs=specs, fmtPrecision=prec} = + formatNumber fmt True 3 Nothing $ showx specs prec1 x + where + prec1 = either (\n -> Just $ if n < 0 then 6 else n) (const $ Just 6) prec + + showx :: RealFloat a => String -> Maybe Int -> a -> String + showx specs p x | x < 0 = '-' : showx specs p (-x) + showx "" p x = showx "g" p x + showx "e" p x = showEFloat p x "" + showx "E" p x = map toUpper $ showx "e" p x + showx "f" p x = showFFloat p x "" + showx "F" p x = map toUpper $ showx "f" p x + showx "g" p x = showGFloat p x "" + showx "G" p x = map toUpper $ showx "g" p x + showx "%" p x = (showx "f" p (x * 100)) ++ "%" + showx _ _ _ = errorArgFmt "unknown specs" diff --git a/src/Text/Format/Format.hs b/src/Text/Format/Format.hs new file mode 100644 --- /dev/null +++ b/src/Text/Format/Format.hs @@ -0,0 +1,131 @@ +module Text.Format.Format + ( FmtItem(..) + , Format(..) + , Format1(..) + ) where + + +import Control.Arrow +import Data.Char (isDigit) +import qualified Data.List as L +import Data.String + +import Text.Format.ArgFmt +import Text.Format.ArgKey +import Text.Format.Internal + + +data FmtItem = Lit String + | Arg ArgKey ArgFmt + deriving (Show, Eq) + +-- | Format is a list of 'FmtItem' +-- +-- A format contains a variet of literal chars and arguments to be replaced, +-- argument sytax is as follows: +-- +-- > {[key][:fmt]} +-- +-- * __{}__ means it must be wraped in a pair of braces, +-- * __[]__ means an optional field (or field group), +-- * __key__ is argument's key, see 'ArgKey', +-- * __fmt__ (must leading with a colon) is argument's format, see 'ArgFmt'. +-- +-- If you need to include a brace character in the literal text, +-- it can be escaped by doubling: {{ and }}. +-- +-- if key is ommited, it means an automically positioned argument. +-- +-- Examples: +-- +-- >>> unFormat "a left brace {{" +-- [Lit "a left brace {"] +-- +-- >>> unFormat "hello {}" +-- [Lit "hello ", Arg (Index 0) (ArgFmt ...)] +-- +-- >>> unFormat "{} {}" +-- [Arg (Index 0) (ArgFmt ...), Arg (Index 1) (ArgFmt ...)] +-- +-- >>> unFormat "{1} {0}" +-- [Arg (Index 1) (ArgFmt ...), Arg (Index 0) (ArgFmt ...)] +-- +-- >>> unFormat "{gender} {age}" +-- [Arg (Name "gender") (ArgFmt ...), Arg (Name "age") (ArgFmt ...)] +-- +-- >>> unFormat "{0!gender}" +-- [Arg (Nest (Index 0) (Name "gender")) (ArgFmt ..)] +-- +-- >>> unFormat "{:<30s}" +-- [Arg (Index 0) (ArgFmt { fmtAlgin = AlignLeft, fmtWidth = Left 30, ...})] +-- +-- >>> unFormat "{:<{width}s}" +-- [Arg (Index 0) (ArgFmt {fmtWidth = Right (Name "width"), ...})] +-- +newtype Format = Format { unFormat :: [FmtItem] } deriving (Show, Eq) + +instance IsString Format where + fromString = Format . (fixIndex 0) . parse + where + parse :: String -> [FmtItem] + parse "" = [] + parse cs = + case parseLiteral cs of + ("", _) -> + case parseArg cs of + (cs1, Just cs2, cs3) -> + (Arg (read cs1) (read cs2)) : (parse cs3) + _ -> error "format error" + (ls, cs1) -> (Lit ls) : (parse cs1) + + parseLiteral :: String -> (String, String) + parseLiteral "" = ("", "") + parseLiteral ('{' : '{' : cs) = first ('{' :) (parseLiteral cs) + parseLiteral ('}' : '}' : cs) = first ('{' :) (parseLiteral cs) + parseLiteral ('{' : cs) = ([], '{' : cs) + parseLiteral ('}' : cs) = ([], '}' : cs) + parseLiteral (c : cs) = first (c :) (parseLiteral cs) + + parseArg :: String -> (String, Maybe String, String) + parseArg cs@('{' : '{' : _) = ("", Nothing, cs) + parseArg ('{' : cs) = + case parseArgKey cs of + (cs1, '}' : cs2) -> (cs1, Just "", cs2) + (cs1, ':' : cs2) -> + case parseArgFmt 0 cs2 of + (cs11, '}' : cs12) -> (cs1, Just cs11, cs12) + _ -> errorCloseTag + _ -> errorCloseTag + + parseArgKey :: String -> (String, String) + parseArgKey "" = ("", "") + parseArgKey cs@('}' : _) = ("", cs) + parseArgKey cs@(':' : _) = ("", cs) + parseArgKey (c : cs) = first (c :) (parseArgKey cs) + + parseArgFmt :: Int -> String -> (String, String) + parseArgFmt _ "" = ("", "") + parseArgFmt 0 cs@('}' : _) = ("", cs) + parseArgFmt n ('{' : cs) = first ('{' :) (parseArgFmt (n + 1) cs) + parseArgFmt n ('}' : cs) = first ('}' :) (parseArgFmt (n - 1) cs) + parseArgFmt n (c : cs) = first (c :) (parseArgFmt n cs) + + fixIndex :: Int -> [FmtItem] -> [FmtItem] + fixIndex _ [] = [] + -- auto-positioned arg + fixIndex next ((Arg (Index (-1)) fmt) : items) = + (Arg (Index next) fmt) : fixIndex (next + 1) items + -- once there is an explict arg key, auto-position args not working + fixIndex next items@((Arg _ _) : _) = items + fixIndex next (item : items) = item : fixIndex next items + +-- | A variant of 'Format', +-- it transforms all argument's key to __Nest (Index 0) key__ +newtype Format1 = Format1 { unFormat1 :: [FmtItem] } deriving (Show, Eq) + +instance IsString Format1 where + fromString = Format1 . map zeroKey . unFormat . fromString + where + zeroKey :: FmtItem -> FmtItem + zeroKey (Arg key fmt) = Arg (Nest (Index 0) key) fmt + zeroKey item = item diff --git a/src/Text/Format/Internal.hs b/src/Text/Format/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/Format/Internal.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TypeOperators #-} + +module Text.Format.Internal + ( (:=) (..) + , ferror + , errorArgFmt + , errorCloseTag + , errorTypeFmt + , errorMissingArg + ) where + + +-- | A type represent a named ArgKey and an another data +infixr 6 := +data (:=) a = String := a + + +-------------------------------------------------------------------------------- +ferror :: String -> a +ferror s = errorWithoutStackTrace $ "format: " ++ s + +errorArgFmt :: String -> a +errorArgFmt cs = ferror $ "bad arg format: " ++ cs + +errorCloseTag :: a +errorCloseTag = ferror $ "close tag '}' missing" + +errorTypeFmt :: String -> String -> a +errorTypeFmt ts cs = ferror $ ts ++ " not allowed for " ++ cs ++ " type(s)" + +errorMissingArg :: a +errorMissingArg = ferror "argument missing" diff --git a/test/ArgFmtSpec.hs b/test/ArgFmtSpec.hs new file mode 100644 --- /dev/null +++ b/test/ArgFmtSpec.hs @@ -0,0 +1,101 @@ +module ArgFmtSpec ( spec ) where + + +import Data.Maybe +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import Text.Format + + +spec :: Spec +spec = describe "read" $ do + prop "all" $ \(TestArgFmt (cs, fmt)) -> read cs == fmt + + +newtype TestArgFmt = TestArgFmt (String, ArgFmt) deriving Show + +instance Arbitrary TestArgFmt where + arbitrary = do + (pad, align) <- genAlign + sign <- genSign + alternate <- genAlternate + signAware <- genSignAware + width <- genWidth + sep <- genNumSep + precision <- genPrecision + specs <- genSpecs + + let cs1 = [x | (Just x) <- [ fst pad, fst align, fst sign, fst alternate + , fst signAware + ] + ] + cs2 = fromMaybe "" $ fst width + cs3 = fromMaybe "" $ sequence [fst sep] + cs4 = fromMaybe "" $ fst precision + cs = concat [cs1, cs2, cs3, cs4, specs] + fmt = ArgFmt (snd align) (snd pad) (snd sign) (snd alternate) + (snd signAware) (snd width) (snd sep) (snd precision) + specs + return $ TestArgFmt (cs, fmt) + where + genAlign :: Gen ((Maybe Char, Char), (Maybe Char, FmtAlign)) + genAlign = do + align <- elements [ (Nothing, AlignNone), (Just '<', AlignLeft) + , (Just '>', AlignRight), (Just '^', AlignCenter) + , (Just '=', AlignSign) + ] + c <- maybe (return Nothing) (\_ -> arbitrary) $ fst align + return (maybe (Nothing, ' ') (\c -> (Just c, c)) c, align) + + genPad :: Gen (Maybe Char, Char) + genPad = do + + oneof $ [ return (Nothing, ' ') + , (\c -> (Just c, c)) <$> arbitrary + ] + + genSign :: Gen (Maybe Char, FmtSign) + genSign = elements [ (Nothing, SignNone), (Just '+', SignPlus) + , (Just '-', SignMinus), (Just ' ', SignSpace) + ] + + genAlternate :: Gen (Maybe Char, Bool) + genAlternate = elements [(Nothing, False), (Just '#', True)] + + genSignAware :: Gen (Maybe Char, Bool) + genSignAware = elements [(Nothing, False), (Just '0', True)] + + genWidth :: Gen (Maybe String, Either Int ArgKey) + genWidth = oneof [genEmptyWP, genLeftWP False, genRightWP False] + + genNumSep :: Gen (Maybe Char, FmtNumSep) + genNumSep = elements [ (Nothing, NumSepNone), (Just '_', NumSepDash) + , (Just ',', NumSepComma) + ] + + genPrecision :: Gen (Maybe String, Either Int ArgKey) + genPrecision = oneof [genEmptyWP, genLeftWP True, genRightWP True] + + genEmptyWP :: Gen (Maybe String, Either Int ArgKey) + genEmptyWP = return (Nothing, Left (-1)) + + genLeftWP :: Bool -> Gen (Maybe String, Either Int ArgKey) + genLeftWP dot = do + Positive x <- arbitrary + let cs = if dot then ('.' : show x) else show x + return (Just cs, Left x) + + genRightWP :: Bool -> Gen (Maybe String, Either Int ArgKey) + genRightWP dot = do + cs <- ('x' :) <$> suchThat arbitrary (all (not . (flip elem "!{}"))) + let cs1 = (if dot then ".{" else "{") ++ cs ++ "}" + return (Just cs1, Right $ read cs) + + genSpecs :: Gen String + genSpecs = elements [ "", "s" + , "b", "c", "d", "o", "x", "X" + , "e", "E", "f", "F", "g", "G", "%" + , "%Y-%m-%d" + ] diff --git a/test/ArgKeySpec.hs b/test/ArgKeySpec.hs new file mode 100644 --- /dev/null +++ b/test/ArgKeySpec.hs @@ -0,0 +1,56 @@ +module ArgKeySpec ( spec ) where + + +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import Text.Format + + +spec :: Spec +spec = describe "read" $ do + prop "empty" $ read "" == Index (-1) + prop "index" $ \(NonNegative x) -> read (show x) == Index x + prop "name" $ \(NoSep cs) -> read cs == Name cs + prop "nest" $ \(OneSep (cs, cs1, cs2)) -> + read cs == Nest (read cs1) (read cs2) + prop "deep nest" $ \(TwoSep (cs, cs1, cs2, cs3)) -> + read cs == Nest (read cs1) (Nest (read cs2) (read cs3)) + prop "escaped" $ \(Escaped (cs, cs0)) -> read cs == Name cs0 + + +newtype NoSep = NoSep String deriving Show + +instance Arbitrary NoSep where + arbitrary = do + cs <- suchThat arbitrary (all (/= '!') . getNonEmpty) + return $ NoSep $ 'x' : getNonEmpty cs + + +newtype OneSep = OneSep (String, String, String) deriving Show + +instance Arbitrary OneSep where + arbitrary = do + (NoSep cs1) <- arbitrary + (NoSep cs2) <- arbitrary + return $ OneSep (cs1 ++ ('!' : cs2), cs1, cs2) + + +newtype TwoSep = TwoSep (String, String, String, String) deriving Show + +instance Arbitrary TwoSep where + arbitrary = do + (NoSep cs1) <- arbitrary + (NoSep cs2) <- arbitrary + (NoSep cs3) <- arbitrary + return $ TwoSep (cs1 ++ ('!' : cs2) ++ ('!' : cs3), cs1, cs2, cs3) + + +newtype Escaped = Escaped (String, String) deriving Show + +instance Arbitrary Escaped where + arbitrary = do + (NoSep cs1) <- arbitrary + (NoSep cs2) <- arbitrary + return $ Escaped (cs1 ++ "!!" ++ cs2, cs1 ++ "!" ++ cs2) diff --git a/test/FormatSpec.hs b/test/FormatSpec.hs new file mode 100644 --- /dev/null +++ b/test/FormatSpec.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} + +module FormatSpec ( spec ) where + +import Data.Char +import Data.String +import Numeric +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import Text.Format + + +spec :: Spec +spec = basicSpec >> alignSpec >> alternateSpec >> otherSpec + + +basicSpec :: Spec +basicSpec = describe "basic" $ do + prop "string" $ \cs -> format "{0:s}" cs == (cs :: String) + prop "integer" $ \i -> format "{0:d}" i == show (i :: Integer) + prop "float" $ \i -> format "{0:f}" i == showFFloat (Just 6) (i :: Float) "" + prop "auto index 1" $ \cs -> format "{}" cs == (cs :: String) + prop "auto index 2" $ \(cs, i) -> + format "{} {}" cs i == cs ++ " " ++ show (i :: Integer) + + +alignSpec :: Spec +alignSpec = describe "align" $ do + prop "left" $ \cs -> + let result = cs ++ replicate (30 - length cs) ' ' + in format "{:<30}" cs == result + prop "right" $ \cs -> + let result = replicate (30 - length cs) ' ' ++ cs + in format "{:>30}" cs == result + prop "center" $ \cs -> + let n = 30 - length cs + ln = div n 2 + result = replicate ln ' ' ++ cs ++ replicate (n - ln) ' ' + in format "{:^30}" cs == result + prop "sign" $ \i -> + let is = show (i :: Integer) + sign = if i < 0 then head is else '+' + digits = if i < 0 then tail is else is + result = sign : (replicate (29 - length digits) ' ' ++ digits) + in format "{:=+30}" i == result + prop "pad" $ \(PadChar c, cs) -> + let fmt = fromString $ "{:" ++ (c : "<30}") + result = cs ++ replicate (30 - length cs) c + in format fmt cs == result + + +signSpec :: Spec +signSpec = describe "sign" $ do + prop "plus" $ \i -> + let fn = if i < 0 then id else ('+' :) + in format "{:+d}" i == (fn $ show (i :: Integer)) + prop "minus" $ \i -> format "{:-d}" i == show (i :: Integer) + prop "space" $ \i -> + let fn = if i < 0 then id else (' ' :) + in format "{: d}" i == fn (show (i :: Integer)) + + +alternateSpec :: Spec +alternateSpec = describe "alternate" $ do + prop "binary" $ \i -> + let fn = (if i < 0 then ('-' :) else id) . ("0b" ++) + i1 = abs i + in format "{:#b}" i == fn (showIntAtBase 2 intToDigit (i1 :: Integer) "") + prop "octal" $ \i -> + let fn = (if i < 0 then ('-' :) else id) . ("0o" ++) + i1 = abs i + in format "{:#o}" i == fn (showIntAtBase 8 intToDigit (i1 :: Integer) "") + prop "hex" $ \i -> + let fn = (if i < 0 then ('-' :) else id) . ("0x" ++) + i1 = abs i + in format "{:#x}" i == fn (showIntAtBase 16 intToDigit (i1 :: Integer) "") + prop "HEX" $ \i -> + let fn = (if i < 0 then ('-' :) else id) . ("0X" ++) . (map toUpper) + i1 = abs i + in format "{:#X}" i == fn (showIntAtBase 16 intToDigit (i1 :: Integer) "") + + +otherSpec :: Spec +otherSpec = describe "others" $ do + prop "sign aware" $ \i -> + let fn = if i < 0 then ('-' :) else ('+' :) + is = show $ abs (i :: Integer) + in format "{:+030d}" i == fn (replicate (29 - length is) '0' ++ is) + prop "min width" $ \cs -> + length (format "{:30s}" cs :: String) == max 30 (length (cs :: String)) + prop "max width" $ \cs -> + length (format "{:.30s}" cs :: String) == min 30 (length (cs :: String)) + prop "number separation" $ \i -> + let fn = \cs -> if length cs > 3 then (head $ drop 3 cs) : (fn $ drop 4 cs) + else [] + in all (== '_') $ fn (format "{:_d}" (i :: Integer)) + prop "precision" $ \(i, NonNegative p) -> + let fmt = fromString $ "{:." ++ (show p) ++ "}" + in format fmt i == showFFloat (Just p) (i :: Double) "" + + +newtype PadChar = PadChar Char deriving Show + +instance Arbitrary PadChar where + arbitrary = PadChar <$> suchThat arbitrary (not . flip elem ['{', '}']) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/vformat.cabal b/vformat.cabal new file mode 100644 --- /dev/null +++ b/vformat.cabal @@ -0,0 +1,65 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: a5998fdb18cdaeb90e83607dfb209d143c8629ae337ff193558bb657de6b47cf + +name: vformat +version: 0.9.0.0 +synopsis: A Python str.format() like formatter +description: Please see the http://hackage.haskell.org/package/vformat +category: Text, Format +homepage: https://github.com/versioncloud/vformat#readme +bug-reports: https://github.com/versioncloud/vformat/issues +maintainer: Jorah Gao +copyright: (c) 2019 Version Cloud +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/versioncloud/vformat + +library + exposed-modules: + Text.Format + other-modules: + Text.Format.ArgFmt + Text.Format.ArgKey + Text.Format.Class + Text.Format.Format + Text.Format.Internal + Paths_vformat + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , containers >=0.5.9 && <1.0 + , time >=1.4 && <2.0 + default-language: Haskell2010 + +test-suite vformat-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + ArgFmtSpec + ArgKeySpec + FormatSpec + Paths_vformat + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck >=2.0 && <3.0 + , base >=4.7 && <5 + , containers >=0.5.9 && <1.0 + , hspec >=2.1 && <3.0 + , time >=1.4 && <2.0 + , vformat + default-language: Haskell2010