vformat (empty) → 0.9.0.0
raw patch · 15 files changed
+1279/−0 lines, 15 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, hspec, time, vformat
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +3/−0
- Setup.hs +2/−0
- src/Text/Format.hs +105/−0
- src/Text/Format/ArgFmt.hs +298/−0
- src/Text/Format/ArgKey.hs +70/−0
- src/Text/Format/Class.hs +275/−0
- src/Text/Format/Format.hs +131/−0
- src/Text/Format/Internal.hs +32/−0
- test/ArgFmtSpec.hs +101/−0
- test/ArgKeySpec.hs +56/−0
- test/FormatSpec.hs +107/−0
- test/Spec.hs +1/−0
- vformat.cabal +65/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for vformat++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,3 @@+# vformat++Please see http://hackage.haskell.org/package/vformat
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Text/Format.hs view
@@ -0,0 +1,105 @@+{-|+Module : Text.Format+Copyright : (c) 2019 Version Cloud+License : BSD3+Maintainer : Jorah Gao <jorah@version.cloud>+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
+ src/Text/Format/ArgFmt.hs view
@@ -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)
+ src/Text/Format/ArgKey.hs view
@@ -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)
+ src/Text/Format/Class.hs view
@@ -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"
+ src/Text/Format/Format.hs view
@@ -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
+ src/Text/Format/Internal.hs view
@@ -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"
+ test/ArgFmtSpec.hs view
@@ -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"+ ]
+ test/ArgKeySpec.hs view
@@ -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)
+ test/FormatSpec.hs view
@@ -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 ['{', '}'])
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ vformat.cabal view
@@ -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 <jorah@version.cloud>+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