vformat 0.9.1.0 → 0.10.0.0
raw patch · 14 files changed
+889/−746 lines, 14 filesdep +exceptions
Dependencies added: exceptions
Files
- ChangeLog.md +4/−1
- src/Text/Format.hs +50/−80
- src/Text/Format/ArgFmt.hs +186/−139
- src/Text/Format/ArgKey.hs +40/−42
- src/Text/Format/Class.hs +206/−127
- src/Text/Format/Error.hs +55/−0
- src/Text/Format/Format.hs +66/−53
- src/Text/Format/Internal.hs +0/−32
- test/ArgFmtSpec.hs +0/−101
- test/ArgKeySpec.hs +0/−56
- test/FormatSpec.hs +0/−107
- test/Main.hs +276/−0
- test/Spec.hs +0/−1
- vformat.cabal +6/−7
ChangeLog.md view
@@ -1,3 +1,6 @@ # Changelog for vformat -## Unreleased changes+## V0.10.0+- Rewrite error system & fix bugs+- Fix document+- Rewrite unit tests
src/Text/Format.hs view
@@ -6,100 +6,70 @@ 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"- @+This library is inspired by+Python's [str.format](https://docs.python.org/library/string.html) and+Haskell's [Text.Printf](http://hackage.haskell.org/package/base/docs/Text-Printf.html),+and most of the features are copied from these two libraries. -}- module Text.Format- ( format+ ( -- * Format functions+ format , format1- , module Text.Format.Class- , module Text.Format.Format- , module Text.Format.ArgKey- , module Text.Format.ArgFmt- , module Text.Format.Internal+ -- * Data types+ , FormatArg(formatArg)+ , FormatType(..)+ , Formatter+ , Format+ , Format1+ , ArgKey(..)+ , ArgFmt(..)+ , prettyArgFmt+ , FmtAlign(..)+ , FmtSign(..)+ , FmtNumSep(..)+ , (:=) (..)+ -- * Errors+ , ArgError(..)+ , errorArgKey+ , errorArgFmt+ , vferror ) where -import Data.Map (empty)+import Data.Map (empty) import Text.Format.ArgFmt import Text.Format.ArgKey import Text.Format.Class+import Text.Format.Error 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 a variable number of arguments with Python-style format string++>>> format "{:s}, {:d}, {:.4f}" "hello" 123 pi+"hello, 123, 3.1416"+>>> format "{1:s}, {0:d}, {2:.4f}" 123 "hello" pi+"hello, 123, 3.1416"+>>> format "{:s} {:d} {pi:.4f}" "hello" 123 ("pi" := pi)+"hello, 123, 3.1416"++See 'Format' to learn more about format string syntax.++See 'FormatArg' to learn how to derive FormatArg for your own data types.+-} 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 !---+{-| A variant of 'format', it takes only one positional argument++>>> :set -XDeriveGeneric+>>> import GHC.Generics+>>> data Triple = Triple String Int Double deriving Generic+>>> instance FormatArg Triple+>>> format "{0!0:s} {0!1:d} {0!2:.4f}" $ Triple "hello" 123 pi+"hello, 123, 3.1416"+>>> format1 "{0:s} {1:d} {2:.4f}" $ Triple "hello" 123 pi+"hello, 123, 3.1416"+-} format1 :: FormatArg a => Format1 -> a -> String format1 = format . Format . unFormat1
src/Text/Format/ArgFmt.hs view
@@ -1,155 +1,151 @@+{-# LANGUAGE RecordWildCards #-}+ module Text.Format.ArgFmt ( FmtAlign(..) , FmtSign(..) , FmtNumSep(..) , ArgFmt(..)+ , prettyArgFmt , formatText , formatNumber ) where import Control.Arrow-import Data.Char (isDigit)-import qualified Data.List as L+import Data.Char (isDigit)+import qualified Data.List as L import Numeric import Text.Format.ArgKey-import Text.Format.Internal+import Text.Format.Error --- | How to align argument------ Note: 'AlignNone' is equivalent to 'AlignLeft' unless--- number's sign aware enabled+-- | A data type indicates how to align arguments ---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+data FmtAlign = AlignNone -- ^ Not specified, equivalent to 'AlignLeft'+ -- unless number's sign aware enabled.+ | AlignLeft -- ^ Forces the argument to be left-aligned+ -- within the available space.+ | AlignRight -- ^ Forces the field to be right-aligned within+ -- the available space.+ | AlignCenter -- ^ Forces the field to be centered within the+ -- available space.+ | AlignSign -- ^ Number specified, forces the padding to be+ -- placed after the sign (if any) but before+ -- the digits. deriving (Show, Eq) --- | How to show number's sign+-- | A data type indicates 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+data FmtSign = SignNone -- ^ Not specified, equivalent to 'SignMinus'+ -- for signed numbers.+ | SignPlus -- ^ Sign should be used for both positive as well+ -- as negative numbers.+ | SignMinus -- ^ Sign should be used only for negative numbers+ | SignSpace -- ^ A leading space should be used on positive+ -- numbers, and a minus sign on negative numbers. deriving (Show, Eq) --- | Number separator-data FmtNumSep = NumSepNone -- ^ don't seprate- | NumSepDash -- ^ seprate by '_'- | NumSepComma -- ^ seprate by ','+-- | A data type indicates number separator+--+-- e.g. 20,200,101 20_200_202+data FmtNumSep = NumSepNone -- ^ Don't separate number+ | NumSepDash -- ^ Use dash as number separator+ | NumSepComma -- ^ Use comma as number separator 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---+{-| A data type indicates how to format an argument.++==== The format syntax++ @+ fmt :: [[pad] align][sign]["#"]["0"][width][sep]["." precision][specs]+ pad :: char+ align :: "\<" | "\>" | "^" | "="+ sign :: "+" | "-" | " "+ width :: int | ("{" key "}")+ sep :: "_" | ","+ precision :: int | ("{" key "}")+ specs :: chars+ key :: \<see 'ArgKey'\>+ @++ * @#@ will cause the "alternate form" to be used for integers.++ The alternate format is defined differently for different types.++ * add 0b prefix for binary+ * add 0o prefix for octal+ * add 0x prefix for hexadecimal++ * @with@ indicates minimum with of the field++ If omitted, the field width will be determined by the content.++ When align is omitted, preceding width by a zero character enables+ sign-aware zero-padding for numbers.+ This is equivalent to a pad of 0 with an align of =.++ * @precision@ indicates how many digits should be displayed after the decimal+ point for a floating point number, or maximum width for other types.++ When precision is omitted++ * preceding dot is present, indicates precision is 0+ * preceding dot is omitted too, indicates precision not set,+ default value (i.e. 6 for floating point numbers, 0 for others)+ will be used.++ * @specs@ indicates type specified options++ When specs is omitted, the default specs will be used.+ The default specs is defined differently from different types.++ Examples++ >>> read "*<30s" :: ArgFmt+ >>> read "<10.20s" :: ArgFmt+ >>> read "0=10_.20d" :: ArgFmt+ >>> read "#010_.20b" :: ArgFmt++==== String specs++ @+ s+ default s+ @++==== Integer specs++ @+ 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)+ default d+ @++==== Floating point number specs++ @+ 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+ default g+ @++See 'Text.Format.FormatArg' to learn how to define specs for your own types.+-} data ArgFmt = ArgFmt { fmtAlign :: FmtAlign , fmtPad :: Char , fmtSign :: FmtSign@@ -159,19 +155,28 @@ , fmtNumSep :: FmtNumSep , fmtPrecision :: Either Int ArgKey , fmtSpecs :: String+ , fmtRaw :: String -- ^ When reading from a string,+ -- different strings may produce+ -- the same 'ArgFmt', this field+ -- keeps the original string here+ -- in case it is use later. } 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, "")]+ let (fmtAlign, fmtPad, cs1) = parseAlign cs+ (fmtSign, cs2) = parseSign cs1+ (fmtAlternate, cs3) = parseAlternate cs2+ (fmtSignAware, cs4) = parseSignAware cs3+ (fmtWidth, cs5) = parseWidth cs4+ (fmtNumSep, cs6) = parseNumSep cs5+ (fmtPrecision, fmtSpecs) = parsePrecision cs6+ fmtRaw = cs+ in [ (ArgFmt{..}, "") ] where+ stack :: String -> String+ stack = reverse . (`drop` (reverse cs)) . length+ parseAlign (c : '<' : cs) = (AlignLeft, c, cs) parseAlign (c : '>' : cs) = (AlignRight, c, cs) parseAlign (c : '^' : cs) = (AlignCenter, c, cs)@@ -195,11 +200,11 @@ parseWidth ('{' : cs) = case L.break (== '}') cs of- ("", _) -> errorCloseTag (ks, '}' : cs1) -> (Right (read ks), cs1)+ _ -> errorCloseTag $ stack cs parseWidth cs = case L.break (not . isDigit) cs of- ("", cs1) -> (Left (-1), cs)+ ("", cs1) -> (Left 0, cs) (ds, cs1) -> (Left (read ds), cs1) parseNumSep ('_' : cs) = (NumSepDash, cs)@@ -208,14 +213,55 @@ parsePrecision ('.' : '{' : cs) = case L.break (== '}') cs of- ("", _) -> errorCloseTag (ks, '}' : cs1) -> (Right (read ks), cs1)+ _ -> errorCloseTag $ stack cs parsePrecision ('.' : cs) = case L.break (not . isDigit) cs of ("", cs1) -> (Left 0, cs) (ds, cs1) -> (Left (read ds), cs1) parsePrecision cs = (Left (-1), cs) ++prettyFmtAlign :: FmtAlign -> String+prettyFmtAlign AlignNone = ""+prettyFmtAlign AlignLeft = "<"+prettyFmtAlign AlignRight = ">"+prettyFmtAlign AlignCenter = "^"+prettyFmtAlign AlignSign = "="+++prettyFmtSign :: FmtSign -> String+prettyFmtSign SignNone = ""+prettyFmtSign SignPlus = "+"+prettyFmtSign SignMinus = "-"+prettyFmtSign SignSpace = " "+++prettyFmtNumSep :: FmtNumSep -> String+prettyFmtNumSep NumSepNone = ""+prettyFmtNumSep NumSepDash = "_"+prettyFmtNumSep NumSepComma = ","+++-- | Pretty showing 'ArgFmt'+--+-- Note: Don't create 'ArgFmt' manually, 'read' from a string, see 'ArgFmt'.+prettyArgFmt :: ArgFmt -> String+prettyArgFmt (ArgFmt{fmtRaw=raw@(_:_)}) = raw+prettyArgFmt (ArgFmt{..}) = concat $+ [pad, align, sign, alternate, aware, width, sep, ".", precision, fmtSpecs]+ where+ showInt i = if i == 0 then "" else show i+ pad = if fmtAlign == AlignNone then "" else [fmtPad]+ align = prettyFmtAlign fmtAlign+ sign = prettyFmtSign fmtSign+ alternate = if fmtAlternate then "#" else ""+ aware = if fmtSignAware then "0" else ""+ width = either showInt (('{' :) . (++ "}") . show) fmtWidth+ sep = prettyFmtNumSep fmtNumSep+ precision = either showInt (('{' :) . (++ "}") . show) fmtPrecision++ formatText :: ArgFmt -> ShowS formatText fmt@ArgFmt{fmtWidth=(Left minw), fmtPrecision=(Left maxw)} cs | padw > 0 = pad (fmtAlign fmt) padw (fmtPad fmt)@@ -231,8 +277,9 @@ pad AlignCenter n c = let ln = div n 2 in replicate ln c ++ cs1 ++ (replicate (n - ln) c)-formatText _ _ = errorArgFmt "this should never happen"+formatText fmt _ = errorNoParse $ prettyArgFmt fmt + formatNumber :: ArgFmt -> Bool -> Int -> Maybe Char -> ShowS formatNumber fmt signed sepWidth flag cs = uncurry (++) $ pad (fmtAlign fmt) (fmtPad fmt) (fmtSignAware fmt) $@@ -245,7 +292,7 @@ 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 c True (ps, cs) = pad AlignSign c False (ps, cs) pad AlignSign '0' False (ps, cs) = let cs1 = fixSep (fmtNumSep fmt) sepWidth (padw ps cs) cs in (ps, cs1)
src/Text/Format/ArgKey.hs view
@@ -1,53 +1,38 @@-module Text.Format.ArgKey ( ArgKey (..) ) where+module Text.Format.ArgKey ( ArgKey (..), emptyKey ) 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)+{-| A data type indicates key of format argument +==== The key syntax++ @+ key :: [(int | chars) {"!" (int | chars)}]+ @++ Note: See 'Format' to learn more about syntax description language++ Examples++ >>> read "0" :: ArgKey+ >>> read "country" :: ArgKey+ >>> read "coun!!try" :: ArgKey+ >>> read "country!name" :: ArgKey+ >>> read "country!cities!10!name" :: ArgKey+-}+data ArgKey = Index Int -- ^ Refers to a positional argument or+ -- index in a list like argument.+ | Name String -- ^ Refers to a named argument or a record+ -- name of an argument.+ | Nest ArgKey ArgKey -- ^ Refers to a attribute (index or name) of+ -- an argument.+ deriving (Eq, Ord)+ instance Read ArgKey where- readsPrec _ "" = [ (Index (-1), "") ]+ readsPrec _ "" = [ (emptyKey, "") ] readsPrec _ cs = [ parse cs ] where parse :: String -> (ArgKey, String)@@ -68,3 +53,16 @@ (cs1, "!") -> (cs1, "!") (cs1, '!' : '!' : cs2) -> first ((cs1 ++ "!") ++) (break cs2) (cs1, '!' : cs2) -> (cs1, cs2)++instance Show ArgKey where+ show k@(Index i) = if emptyKey == k then "" else show i+ show (Name s) = escape s+ where+ escape :: String -> String+ escape "" = ""+ escape ('!' : cs) = "!!" ++ escape cs+ escape (c : cs) = (c : escape cs)+ show (Nest k1 k2) = show k1 ++ "!" ++ show k2++emptyKey :: ArgKey+emptyKey = Index (-1)
src/Text/Format/Class.hs view
@@ -8,13 +8,16 @@ ( Formatter , FormatArg(..) , FormatType(..)+ , (:=) (..) ) where import Control.Applicative+import Control.Monad.Catch import Data.Char+import Data.Either import Data.Int-import Data.List ((!!))-import Data.Map hiding (map)+import Data.List ((!!))+import Data.Map hiding (map) import Data.Maybe import Data.Time.Format import Data.Word@@ -24,163 +27,211 @@ import Text.Format.ArgFmt import Text.Format.ArgKey+import Text.Format.Error import Text.Format.Format-import Text.Format.Internal -type Formatter = ArgKey -> ArgFmt -> String+type Formatter = ArgKey -> ArgFmt -> Either SomeException 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)--- @---+{-| Typeclass of formatable values.++The 'formatArg' method takes a value, a key and a field format descriptor and+either fails due to a 'ArgError' or produce a string as the result.+There is a default 'formatArg' for 'Generic' instances.++There are two reasons may cause formatting fail++ (1) Can not find argument for the given key.++ (2) The field format descriptor does not match the argument.++==== Extending to new types++Those format functions can be extended to format types other than those+provided by default. This is done by instantiating 'FormatArg'.++Examples++@+ \{\-\# LANGUAGE DeriveGeneric \#\-\}+ \{\-\# LANGUAGE OverloadedStrings \#\-\}++ import Control.Exception+ import GHC.Generics+ import Text.Format++ instance FormatArg () where+ formatArg x k fmt@(ArgFmt{fmtSpecs=\"U\"}) =+ let fmt' = fmt{fmtSpecs = \"\"}+ in formatArg (show x) k fmt'+ formatArg _ _ _ = Left ArgFmtError++ data Color = Red | Yellow | Blue deriving Generic++ instance FormatArg Color++ data Triple = Triple String Int Double deriving Generic++ instance FormatArg Triple++ data Student = Student { no :: Int+ , name :: String+ , age :: Int+ } deriving Generic++ instance FormatArg Student++ main :: IO ()+ main = do+ putStrLn $ format \"A unit {:U}\" ()+ putStrLn $ format \"I like {}.\" Blue+ putStrLn $ format \"Triple {0!0} {0!1} {0!2}\" $ Triple \"Hello\" 123 pi+ putStrLn $ format1 \"Student: {no} {name} {age}\" $ Student 1 \"neo\" 30+@+-} class FormatArg a where formatArg :: a -> Formatter default formatArg :: (Generic a, GFormatArg (Rep a)) => a -> Formatter- formatArg x = fromMaybe errorMissingArg . gformatArg (from x)+ formatArg x = gformatArg (from x) + -- | This method is used to get the key of a top-level argument.+ -- Top-level argument means argument that directly passed to format+ -- functions ('format', 'format1'). keyOf :: a -> ArgKey keyOf _ = Index (-1) +-- | Default specs is \"%Y-%m-%dT%H:%M:%S\", see 'formatTime'. instance {-# OVERLAPPABLE #-} FormatTime t => FormatArg t where- formatArg x _ fmt = formatTime defaultTimeLocale specs x- where- specs = case fmtSpecs fmt of "" -> "%Y-%m-%dT%H:%M:%S"; cs -> cs+ formatArg = throwIfNest $ \x k fmt ->+ let specs = fmtSpecs fmt <|> "%Y-%m-%dT%H:%M:%S"+ x' = formatTime defaultTimeLocale specs x+ fmt' = fmt{fmtSpecs=""}+ in formatArg x' k fmt' instance {-# OVERLAPPABLE #-} FormatArg a => FormatArg [a] where- formatArg x (Nest _ k@(Index i)) = formatArg (x !! i) k+ formatArg x (Nest _ k@(Index i)) = formatArg (x !! i) (Index (-1))+ formatArg x (Nest _ k@(Nest (Index i) _)) = formatArg (x !! i) k+ formatArg _ _ = const $ throwM ArgKeyError instance {-# OVERLAPPABLE #-} FormatArg a => FormatArg (Map String a) where- formatArg x (Nest _ k@(Name n)) = formatArg (x ! n) k+ formatArg x (Nest _ k@(Name n)) = formatArg (x ! n) (Index (-1))+ formatArg x (Nest _ k@(Nest (Name n) _)) = formatArg (x ! n) k+ formatArg _ _ = const $ throwM ArgKeyError 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+ formatArg x (Nest _ k@(Index i)) = formatArg (x ! i) (Index (-1))+ formatArg x (Nest _ k@(Nest (Index i) _)) = formatArg (x ! i) k+ formatArg _ _ = const $ throwM ArgKeyError instance FormatArg String where- formatArg = formatString+ formatArg = throwIfNest formatString instance FormatArg Char where- formatArg = formatInteger False . toInteger . ord+ formatArg = throwIfNest $ formatInteger False . toInteger . ord instance FormatArg Int where- formatArg = formatInteger True . toInteger+ formatArg = throwIfNest $ formatInteger True . toInteger instance FormatArg Int8 where- formatArg = formatInteger True . toInteger+ formatArg = throwIfNest $ formatInteger True . toInteger instance FormatArg Int16 where- formatArg = formatInteger True . toInteger+ formatArg = throwIfNest $ formatInteger True . toInteger instance FormatArg Int32 where- formatArg = formatInteger True . toInteger+ formatArg = throwIfNest $ formatInteger True . toInteger instance FormatArg Int64 where- formatArg = formatInteger True . toInteger+ formatArg = throwIfNest $ formatInteger True . toInteger instance FormatArg Word where- formatArg = formatInteger False . toInteger+ formatArg = throwIfNest $ formatInteger False . toInteger instance FormatArg Word8 where- formatArg = formatInteger False . toInteger+ formatArg = throwIfNest $ formatInteger False . toInteger instance FormatArg Word16 where- formatArg = formatInteger False . toInteger+ formatArg = throwIfNest $ formatInteger False . toInteger instance FormatArg Word32 where- formatArg = formatInteger False . toInteger+ formatArg = throwIfNest $ formatInteger False . toInteger instance FormatArg Word64 where- formatArg = formatInteger False . toInteger+ formatArg = throwIfNest $ formatInteger False . toInteger instance FormatArg Integer where- formatArg = formatInteger True+ formatArg = throwIfNest $ formatInteger True instance FormatArg Natural where- formatArg = formatInteger False . toInteger+ formatArg = throwIfNest $ formatInteger False . toInteger instance FormatArg Float where- formatArg = formatRealFloat+ formatArg = throwIfNest formatRealFloat instance FormatArg Double where- formatArg = formatRealFloat+ formatArg = throwIfNest formatRealFloat -------------------------------------------------------------------------------- class GFormatArg f where- gformatArg :: f p -> ArgKey -> Maybe (ArgFmt -> String)--instance GFormatArg V1 where- gformatArg _ _ = Nothing--instance GFormatArg U1 where- gformatArg _ _ = Nothing+ gformatArg :: f p -> ArgKey -> ArgFmt -> Either SomeException String -instance (FormatArg c) => GFormatArg (K1 i c) where- gformatArg (K1 c) = Just . formatArg c+-- Data type+instance GFormatArg f => GFormatArg (D1 c f) where+ gformatArg (M1 x) = gformatArg x +-- Choice between Sums instance (GFormatArg f, GFormatArg g) => GFormatArg (f :+: g) where gformatArg (L1 x) = gformatArg x gformatArg (R1 x) = gformatArg x +-- Constructor+-- e.g. data GreetTo = Hello { name :: String } | Hi { name :: String }+-- data GreetTo = Hello String | Hi String+-- data Greet = Hello | Hi+instance (Constructor c, GFormatArg f) => GFormatArg (C1 c f) where+ gformatArg c@(M1 x) = gformatArg x++-- Constructor without arguments+-- e.g. data Greet = Hello | Hi+instance {-# OVERLAPPING #-} Constructor c => GFormatArg (C1 c U1) where+ gformatArg _ (Nest _ _) = const $ throwM ArgKeyError+ gformatArg c k = formatArg (conName c) k++-- Try Products one by one instance (GFormatArg f, GFormatArg g) => GFormatArg (f :*: g) where- gformatArg (x :*: y) = (<|>) <$> gformatArg x <*> gformatArg y+ gformatArg (x :*: y) k fmt =+ gformatArg x k fmt <|> gformatArg y (dec1 k) fmt+ where+ x <|> y = catchIf isArgKeyError x $ const y -instance (GFormatArg f) => GFormatArg (D1 c f) where- gformatArg (M1 x) = gformatArg x+ dec1 :: ArgKey -> ArgKey+ dec1 (Index i) = Index (i - 1)+ dec1 (Nest p (Index i)) = Nest p (Index (i - 1))+ dec1 (Nest p (Nest (Index i) k)) = Nest p $ Nest (Index (i - 1)) k+ dec1 k = k -instance (GFormatArg f) => GFormatArg (C1 c f) where- gformatArg (M1 x) = gformatArg x+-- Selector (record and none record)+-- e.g. data GreetTo = Hello String | Hi String+-- data GreetTo = Hello { name :: String } | Hi { name :: String }+instance (Selector c, GFormatArg f) => GFormatArg (S1 c f) where+ gformatArg s@(M1 x) (Nest _ (Index 0))+ | selName s == "" = gformatArg x (Index (-1))+ gformatArg s@(M1 x) (Nest _ k@(Nest (Index 0) _))+ | selName s == "" = gformatArg x k+ gformatArg s@(M1 x) (Nest _ (Name record))+ | selName s == record = gformatArg x (Index (-1))+ gformatArg s@(M1 x) (Nest _ k@(Nest (Name record) _))+ | selName s == record = gformatArg x k+ gformatArg _ _ = const $ throwM ArgKeyError -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+-- FormatArg instance+instance (FormatArg c) => GFormatArg (K1 i c) where+ gformatArg (K1 c) = formatArg c +-------------------------------------------------------------------------------- -- | A typeclass provides the variable arguments magic for 'format' -- class FormatType t where@@ -190,8 +241,7 @@ 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 (Index (-1)) = Index $ length [n | Index n <- keys args] fixIndex k = k instance FormatType String where@@ -200,38 +250,54 @@ formats :: [FmtItem] -> String formats = concat . (map formats1) + onError :: (ArgKey, ArgFmt) -> SomeException -> String+ onError (key, fmt) = catchArgError (errorArgKey $ show key)+ (errorArgFmt $ prettyArgFmt $ fmt)+ formats1 :: FmtItem -> String formats1 (Lit cs) = cs- formats1 (Arg key ifmt) = (getFormatter key) key (fixArgFmt ifmt)+ formats1 (Arg key ifmt) =+ either (onError (key, ifmt)) id $ (getFormatter key) key (fixArgFmt ifmt) fixArgFmt :: ArgFmt -> ArgFmt- fixArgFmt ifmt@(ArgFmt _ _ _ _ _ (Right key) _ _ _) =+ fixArgFmt ifmt@(ArgFmt{fmtWidth=(Right key)}) = fixArgFmt $ ifmt {fmtWidth = Left $ formatWidth key}- fixArgFmt ifmt@(ArgFmt _ _ _ _ _ _ _ (Right key) _) =+ fixArgFmt ifmt@(ArgFmt{fmtPrecision=(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"+ formatWidth key =+ let fmt = read "0.0d"+ in read $ either (onError (key, fmt)) id $ (getFormatter key) key fmt formatPrecision = formatWidth getFormatter :: ArgKey -> Formatter getFormatter (Nest key _) = getFormatter key- getFormatter key@(Index _) = fromMaybe errorMissingArg $ args !? key- getFormatter key@(Name _) = fromMaybe errorMissingArg $ args !? key+ getFormatter key = fromMaybe (\_ _ -> throwM ArgKeyError) $ args !? key --------------------------------------------------------------------------------+-- | A type represents the top-level named key argument.+data (:=) a = String := a+infixr 6 :=++instance FormatArg a => FormatArg ((:=) a) where+ formatArg (_ := x) (Nest _ k) = formatArg x k+ formatArg (_ := x) _ = formatArg x (Index (-1))++ keyOf (ks := _) = Name ks+++-------------------------------------------------------------------------------- formatString :: String -> Formatter-formatString x _ fmt@(ArgFmt{fmtSpecs = ""}) = formatText fmt x-formatString x _ fmt@(ArgFmt{fmtSpecs = "s"}) = formatText fmt x-formatString _ _ _ = errorArgFmt "unknown specs"+formatString x _ fmt@(ArgFmt{fmtSpecs = ""}) = Right $ formatText fmt x+formatString x _ fmt@(ArgFmt{fmtSpecs = "s"}) = Right $ formatText fmt x+formatString _ _ _ = throwM ArgFmtError formatInteger :: Bool -> Integer -> Formatter formatInteger signed x _ fmt@ArgFmt{fmtSpecs=specs} =- formatNumber fmt signed (sepw specs) (flag specs) (showx specs x)+ formatNumber fmt signed (sepw specs) (flag specs) <$> (showx specs x) where sepw :: String -> Int sepw "b" = 4@@ -247,31 +313,44 @@ flag "X" = Just 'X' flag _ = Nothing - showx :: String -> Integer -> String- showx specs x | x < 0 = '-' : showx specs (-x)+ encodeSign :: [Char] -> [Char]+ encodeSign "+" = "++"+ encodeSign "-" = "--"+ encodeSign cs = cs++ showx :: String -> Integer -> Either SomeException 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"+ showx "b" x = Right $ showIntAtBase 2 intToDigit x ""+ showx "c" x = Right $ encodeSign $ [chr $ fromInteger x]+ showx "d" x = Right $ show x+ showx "o" x = Right $ showIntAtBase 8 intToDigit x ""+ showx "x" x = Right $ showIntAtBase 16 intToDigit x ""+ showx "X" x = map toUpper <$> showx "x" x+ showx _ _ = throwM ArgFmtError formatRealFloat :: RealFloat a => a -> Formatter formatRealFloat x _ fmt@ArgFmt{fmtSpecs=specs, fmtPrecision=prec} =- formatNumber fmt True 3 Nothing $ showx specs prec1 x+ 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+ prec1 = either (\i -> Just $ if i < 0 then 6 else i) (const $ Just 0) prec - showx :: RealFloat a => String -> Maybe Int -> a -> String- showx specs p x | x < 0 = '-' : showx specs p (-x)+ showx :: RealFloat a+ => String -> Maybe Int -> a -> Either SomeException 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"+ showx "e" p x = Right $ showEFloat p x ""+ showx "E" p x = map toUpper <$> showx "e" p x+ showx "f" p x = Right $ showFFloat p x ""+ showx "F" p x = map toUpper <$> showx "f" p x+ showx "g" p x = Right $ showGFloat p x ""+ showx "G" p x = map toUpper <$> showx "g" p x+ showx "%" p x = (++ "%") <$> (showx "f" p (x * 100))+ showx _ _ _ = throwM ArgFmtError+++throwIfNest :: (a -> Formatter) -> a -> Formatter+throwIfNest _ _ (Nest _ _) _ = throwM ArgKeyError+throwIfNest f x k fmt = f x k fmt
+ src/Text/Format/Error.hs view
@@ -0,0 +1,55 @@+module Text.Format.Error+ ( ArgError(..)+ , isArgKeyError+ , catchArgError+ , vferror+ , errorNoParse+ , errorCloseTag+ , errorArgKey+ , errorArgFmt+ ) where+++import Control.Exception+++-- | A data type indicates an arg error+data ArgError = ArgKeyError -- ^ Can not find argument for the given key+ | ArgFmtError -- ^ The field format descriptor+ -- does not match the argument+ deriving (Show, Eq)++instance Exception ArgError++isArgKeyError :: SomeException -> Bool+isArgKeyError = maybe False (== ArgKeyError) . fromException++catchArgError :: a -> a -> SomeException -> a+catchArgError key fmt e = maybe (throw e) handle (fromException e)+ where+ handle ArgKeyError = key+ handle ArgFmtError = fmt+++--------------------------------------------------------------------------------+-- | Raises an error with a vformat-specific prefix on the message string.+vferror :: String -> a+vferror = errorWithoutStackTrace . ("vformat: " ++)+++--------------------------------------------------------------------------------+-- *** Exception: vformat: no parse "xxx"+errorNoParse :: String -> a+errorNoParse = vferror . ("no parse " ++) . show++-- *** Exception: vformat: "xxx" close tag '}' missing+errorCloseTag :: String -> a+errorCloseTag = vferror . (++ " close tag '}' missing") . show++-- | Calls 'vferror' to indicate an arg key error for a given type.+errorArgKey :: String -> a+errorArgKey = vferror . ("bad arg key " ++) . show++-- | Calls 'vferror' to indicate an arg format error for a given type.+errorArgFmt :: String -> a+errorArgFmt = vferror . ("bad arg format " ++) . show
src/Text/Format/Format.hs view
@@ -6,67 +6,80 @@ import Control.Arrow-import Data.Char (isDigit)-import qualified Data.List as L+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+import Text.Format.Error 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"), ...})]---+{-| A data type indicates a format string++Format string contains "replacement fields" surrounded by curly braces {}.+Anything that is not contained in braces is considered literal text, which is+copied unchanged to the output. If you need to include a brace character in the+literal text, it can be escaped by doubling {{ and }}.+++==== Format string syntax++ @+ format :: {chars | ("{" [key][":"fmt] "}")}+ key :: \<see 'ArgKey'\>+ fmt :: \<see 'ArgFmt'\>+ @++ Note: This library use a description language to describe syntax,+ see next section.++ Note: A key can be omitted only if there is no explict index key before it,+ it will be automatically caculated and inserted to the format string+ according to its position in the omitted key sequence.++ Examples++ >>> "I like {coffee}, I drink it everyday." :: Format+ >>> "{no:<20} {name:<20} {age}" :: Format+ >>> "{{\"no\": {no}, \"name\": \"{name}\"}}" :: Format+++==== Syntax description language++ A syntax expr may contain a list of fields as followings++ @+ identifier identifier of an expr+ \<description\> use human language as an expr+ :: use right hand expr to describe identifier+ () a required field, may be omitted+ [] an optional field+ {} repeat any times of the field+ | logical or, choice between left and right+ "" literal text+ @++ Built-in exprs++ @+ char :: \<any character\>+ chars :: {char}+ int :: \<integer without sign\>+ @+-} newtype Format = Format { unFormat :: [FmtItem] } deriving (Show, Eq) instance IsString Format where- fromString = Format . (fixIndex 0) . parse+ fromString cs = Format $ fixIndex 0 $ parse cs where+ stack :: String -> String+ stack = reverse . (`drop` (reverse cs)) . length+ parse :: String -> [FmtItem] parse "" = [] parse cs =@@ -75,13 +88,13 @@ case parseArg cs of (cs1, Just cs2, cs3) -> (Arg (read cs1) (read cs2)) : (parse cs3)- _ -> error "format error"+ _ -> errorNoParse $ stack "" (ls, cs1) -> (Lit ls) : (parse cs1) parseLiteral :: String -> (String, String) parseLiteral "" = ("", "") parseLiteral ('{' : '{' : cs) = first ('{' :) (parseLiteral cs)- parseLiteral ('}' : '}' : cs) = first ('{' :) (parseLiteral cs)+ parseLiteral ('}' : '}' : cs) = first ('}' :) (parseLiteral cs) parseLiteral ('{' : cs) = ([], '{' : cs) parseLiteral ('}' : cs) = ([], '}' : cs) parseLiteral (c : cs) = first (c :) (parseLiteral cs)@@ -94,8 +107,8 @@ (cs1, ':' : cs2) -> case parseArgFmt 0 cs2 of (cs11, '}' : cs12) -> (cs1, Just cs11, cs12)- _ -> errorCloseTag- _ -> errorCloseTag+ _ -> errorCloseTag $ stack cs2+ _ -> errorCloseTag $ stack cs parseArgKey :: String -> (String, String) parseArgKey "" = ("", "")@@ -115,8 +128,8 @@ -- 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+ -- once there is an explict index arg key, auto-position args not working+ fixIndex next items@((Arg (Index _) _) : _) = items fixIndex next (item : items) = item : fixIndex next items -- | A variant of 'Format',
− src/Text/Format/Internal.hs
@@ -1,32 +0,0 @@-{-# 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
@@ -1,101 +0,0 @@-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
@@ -1,56 +0,0 @@-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
@@ -1,107 +0,0 @@-{-# 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) ++ "f}"- 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/Main.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main ( main ) where++import Data.Char+import Data.Int+import Data.List+import Data.String+import GHC.Generics+import Numeric hiding (showHex, showOct)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import Text.Format+++main :: IO ()+main = hspec $ do+ describe "ArgKey" $ do+ it "read and show empty arg key" $+ let key = Index (-1) in show key == "" && key == read ""+ prop "read and show none empy arg key" $ \key -> checkKey key (show key)++ describe "ArgFmt" $ do+ prop "read, show and pretty" $ \fmt ->+ let raw = prettyArgFmt fmt in fmt{fmtRaw=raw} == read raw++ describe "Format" $ do+ prop "normal way" $+ uncurry (==) . formatOrdered "{0:c}{1:g}{2:g}{3:d}{4:d}{5:d}{6:s}"+ prop "all keys are omitted" $+ uncurry (==) . formatOrdered "{:c}{:g}{:g}{:d}{:d}{:d}{:s}"+ prop "some keys are omitted" $+ uncurry (==) . formatOrdered "{:c}{:g}{:g}{:d}{:d}{5:d}{6:s}"+ prop "keys are disordered" $ uncurry (==) . formatDisordered+ prop "arg format is omitted" $+ uncurry (==) . formatOrdered "{:c}{}{}{}{}{}{}"+ it "escaped brace" $+ format "{{" == ['{'] && format "}}" == ['}']+ prop "alignment and padding" $ \(align, PadChar c, n) ->+ uncurry (==) (formatAlign align c $ max 3 n)+ prop "number sign" $ \(sign, n) -> uncurry (==) (formatSign sign n)+ prop "number alternate form" $+ \(alter, n) -> uncurry (==) (formatAlter alter n)+ prop "number sign aware" $ \n -> uncurry (==) (formatSignAware n)+ prop "max width" $ \cs -> format "{:.10s}" cs == take 10 (cs :: String)+ prop "number separation" $+ \(sep, alter, n) -> uncurry (==) (formatSep sep alter n)+ prop "number precision" $+ \(NonNegative p, n) -> uncurry (==) (formatPrec p n)+++instance Arbitrary ArgKey where+ arbitrary = sized $ genKey . min 10 . max 1+ where+ indexedKey = (Index . getNonNegative) <$> arbitrary+ namedKey = sized $ \n ->+ Name <$> (sequence $ replicate (max 1 n) arbitraryUnicodeChar)++ genKey 1 = oneof [indexedKey, namedKey]+ genKey n = Nest <$> (genKey 1) <*> (genKey (n - 1))+++instance Arbitrary FmtAlign where+ arbitrary = elements [AlignLeft, AlignRight, AlignCenter, AlignSign]+++instance Arbitrary FmtSign where+ arbitrary = elements [SignPlus, SignMinus, SignSpace]+++instance Arbitrary FmtNumSep where+ arbitrary = elements [NumSepDash, NumSepComma]+++instance Arbitrary ArgFmt where+ arbitrary = do+ (fmtPad, fmtAlign) <- genAlign+ fmtSign <- oneof [return SignNone, arbitrary]+ fmtAlternate <- choose (True, False)+ fmtSignAware <- choose (True, False)+ fmtWidth <- genWidth+ fmtNumSep <- oneof [return NumSepNone, arbitrary]+ fmtPrecision <- genWidth+ fmtSpecs <- getSpecs <$> arbitrary+ return $ let fmtRaw = "" in ArgFmt{..}+ where+ genAlign :: Gen (Char, FmtAlign)+ genAlign = do+ align <- oneof [return AlignNone, arbitrary]+ pad <- if align == AlignNone then return ' '+ else arbitraryPrintableChar+ return (pad, align)++ genWidth :: Gen (Either Int ArgKey)+ genWidth = oneof [ (Left . getNonNegative) <$> arbitrary+ , Right <$> arbitrary+ ]+++newtype Specs = Specs { getSpecs :: String } deriving Show++instance Arbitrary Specs where+ arbitrary = do+ cs <- elements [ "", "s", "%Y-%m-%d", "b", "c", "d", "o", "x", "X"+ , "e", "E", "f", "F", "g", "G", "%"+ ]+ return $ Specs cs+++newtype EmptyArgKey = EmptyArgKey { getEmptyArgKey :: ArgKey } deriving Show++instance Arbitrary EmptyArgKey where+ arbitrary = return $ EmptyArgKey $ Index (-1)+++data BasicArgs = BasicArgs { char :: Char+ , double :: Double+ , float :: Float+ , integer :: Integer+ , int :: Int+ , word :: Word+ , string :: String+ } deriving (Generic, Show)++instance FormatArg BasicArgs++instance Arbitrary BasicArgs where+ arbitrary = BasicArgs <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+++data PadChar = PadChar { getPadChar :: Char } deriving Show++instance Arbitrary PadChar where+ arbitrary = do+ c <- suchThat arbitraryUnicodeChar $ not . (`elem` ['{', '}'])+ return $ PadChar c+++data Alternate = Bin | Oct | Hex | HexU deriving (Show, Eq)++instance Arbitrary Alternate where+ arbitrary = elements [Bin, Oct, Hex, HexU]+++mkSign :: (Num a, Ord a) => a -> String -> String -> String+mkSign n minus other = if n < 0 then minus else other+++showBin, showOct, showHex :: Int -> String+showBin n = showIntAtBase 2 intToDigit (abs n) ""+showOct n = showIntAtBase 8 intToDigit (abs n) ""+showHex n = showIntAtBase 16 intToDigit (abs n) ""+++checkKey :: ArgKey -> String -> Bool+checkKey k@(Index _) cs = show k == cs && k == read cs+checkKey k@(Name _) cs = show k == cs && k == read cs+checkKey (Nest k1 k2) cs =+ let (cs1, cs2) = splitAt (length (show k1)) cs+ in checkKey k1 cs1 && head cs2 == '!' && checkKey k2 (tail cs2)+++formatOrdered :: Format -> BasicArgs -> (String, String)+formatOrdered fs (BasicArgs{..}) =+ ( format fs char double float integer int word string+ , char : double' ++ float' ++ integer' ++ int' ++ word' ++ string+ )+ where+ double' = showGFloat (Just 6) double ""+ float' = showGFloat (Just 6) float ""+ integer' = show integer+ int' = show int+ word' = show word+++formatDisordered :: BasicArgs -> (String, String)+formatDisordered (BasicArgs{..}) =+ ( format fs char double float integer int word string+ , string ++ integer' ++ float' ++ double' ++ int' ++ word' ++ [char]+ )+ where+ double' = showGFloat (Just 6) double ""+ float' = showGFloat (Just 6) float ""+ integer' = show integer+ int' = show int+ word' = show word+ fs = "{6:s}{3:d}{2:g}{1:g}{4:d}{5:d}{0:c}"+++formatAlign :: FmtAlign -> Char -> Int -> (String, String)+formatAlign align c n =+ ( format (fromString $ "{:" ++ [c] ++ (mkFmt align n) ++ "}") (-42 :: Int)+ , padding align (n - 3)+ )+ where+ mkFmt :: FmtAlign -> Int -> String+ mkFmt AlignLeft n = '<' : (show n)+ mkFmt AlignRight n = '>' : (show n)+ mkFmt AlignCenter n = '^' : (show n)+ mkFmt AlignSign n = '=' : (show n)++ padding AlignLeft n = "-42" ++ replicate n c+ padding AlignRight n = replicate n c ++ "-42"+ padding AlignCenter n =+ let ps1 = replicate (n `div` 2) c+ ps2 = replicate (n - (n `div` 2)) c+ in ps1 ++ "-42" ++ ps2+ padding AlignSign n = "-" ++ replicate n c ++ "42"+++formatSign :: FmtSign -> Int -> (String, String)+formatSign SignMinus n = (format "{:-}" n, show n)+formatSign SignPlus n = (format "{:+}" n, (mkSign n "" "+") ++ (show n))+formatSign SignSpace n = (format "{:< d}" n, (mkSign n "" " ") ++ (show n))+++formatAlter :: Alternate -> Int -> (String, String)+formatAlter Bin n = (format "{:#b}" n, (mkSign n "-" "") ++ "0b" ++ (showBin n))+formatAlter Oct n = (format "{:#o}" n, (mkSign n "-" "") ++ "0o" ++ (showOct n))+formatAlter Hex n = (format "{:#x}" n, (mkSign n "-" "") ++ "0x" ++ (showHex n))+formatAlter HexU n =+ ( format "{:#X}" n, (mkSign n "-" "") ++ "0X" ++ (map toUpper $ showHex n))+++formatSignAware :: Int8 -> (String, String)+formatSignAware n =+ let cs = if n == (-128) then "128" else show $ abs n+ len = length cs + if n < 0 then 1 else 0+ in (format "{:010}" n, (mkSign n "-" "") ++ (replicate (10 - len) '0') ++ cs)+++formatSep :: FmtNumSep -> Maybe Alternate -> Int -> (String, String)+formatSep sep alter n =+ ( format (fromString ("{:" ++ (mkFmt alter) ++ "}")) n+ , (mkSign n "-" "") ++ (intercalate [sepc] $ split altern $ showIt alter n)+ )+ where+ sepc = if sep == NumSepDash then '_' else ','+ altern = maybe 3 (const 4) alter++ showIt :: Maybe Alternate -> Int -> String+ showIt (Just Bin) = showBin . abs+ showIt (Just Oct) = showOct . abs+ showIt (Just _) = showHex . abs+ showIt _ = show . abs++ mkFmt :: Maybe Alternate -> String+ mkFmt (Just Bin) = mkFmt Nothing ++ "b"+ mkFmt (Just Oct) = mkFmt Nothing ++ "o"+ mkFmt (Just _) = mkFmt Nothing ++ "x"+ mkFmt _ = [sepc]++ splitAtEnd :: Int -> [a] -> ([a], [a])+ splitAtEnd n cs =+ let (cs1, cs2) = splitAt n (reverse cs) in (reverse cs2, reverse cs1)++ split :: Int -> [a] -> [[a]]+ split _ [] = []+ split n cs = let (cs1, cs2) = splitAtEnd n cs in split n cs1 ++ [cs2]+++formatPrec :: Int -> Double -> (String, String)+formatPrec p n =+ ( format (fromString $ "{:." ++ (if p == 0 then "" else show p) ++ "}") n+ , showGFloat (Just p) n ""+ )
− test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
vformat.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 1a0a896bcbb88748b1be2651144fc84ba8ab7f7550996444ff48d3df402b9165+-- hash: 5d5662a48ea62fc7081bff2ddcd8ec45db22cbbf6378456260cc0c35d0fbe73a name: vformat-version: 0.9.1.0+version: 0.10.0.0 synopsis: A Python str.format() like formatter description: Please see the http://hackage.haskell.org/package/vformat category: Text, Format@@ -33,24 +33,22 @@ Text.Format.ArgFmt Text.Format.ArgKey Text.Format.Class+ Text.Format.Error Text.Format.Format- Text.Format.Internal Paths_vformat hs-source-dirs: src build-depends: base >=4.7 && <5 , containers >=0.5.9 && <1.0+ , exceptions >=0.8 && <1.0 , time >=1.4 && <2.0 default-language: Haskell2010 test-suite vformat-test type: exitcode-stdio-1.0- main-is: Spec.hs+ main-is: Main.hs other-modules:- ArgFmtSpec- ArgKeySpec- FormatSpec Paths_vformat hs-source-dirs: test@@ -59,6 +57,7 @@ QuickCheck >=2.0 && <3.0 , base >=4.7 && <5 , containers >=0.5.9 && <1.0+ , exceptions >=0.8 && <1.0 , hspec >=2.1 && <3.0 , time >=1.4 && <2.0 , vformat