diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,6 @@ # Changelog for vformat -## Unreleased changes +## V0.10.0 +- Rewrite error system & fix bugs +- Fix document +- Rewrite unit tests diff --git a/src/Text/Format.hs b/src/Text/Format.hs --- a/src/Text/Format.hs +++ b/src/Text/Format.hs @@ -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 diff --git a/src/Text/Format/ArgFmt.hs b/src/Text/Format/ArgFmt.hs --- a/src/Text/Format/ArgFmt.hs +++ b/src/Text/Format/ArgFmt.hs @@ -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 :: \ + @ + + * @#@ 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) diff --git a/src/Text/Format/ArgKey.hs b/src/Text/Format/ArgKey.hs --- a/src/Text/Format/ArgKey.hs +++ b/src/Text/Format/ArgKey.hs @@ -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) diff --git a/src/Text/Format/Class.hs b/src/Text/Format/Class.hs --- a/src/Text/Format/Class.hs +++ b/src/Text/Format/Class.hs @@ -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 diff --git a/src/Text/Format/Error.hs b/src/Text/Format/Error.hs new file mode 100644 --- /dev/null +++ b/src/Text/Format/Error.hs @@ -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 diff --git a/src/Text/Format/Format.hs b/src/Text/Format/Format.hs --- a/src/Text/Format/Format.hs +++ b/src/Text/Format/Format.hs @@ -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 :: \ + fmt :: \ + @ + + 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 + \ 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 :: \ + chars :: {char} + int :: \ + @ +-} 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', diff --git a/src/Text/Format/Internal.hs b/src/Text/Format/Internal.hs deleted file mode 100644 --- a/src/Text/Format/Internal.hs +++ /dev/null @@ -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" diff --git a/test/ArgFmtSpec.hs b/test/ArgFmtSpec.hs deleted file mode 100644 --- a/test/ArgFmtSpec.hs +++ /dev/null @@ -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" - ] diff --git a/test/ArgKeySpec.hs b/test/ArgKeySpec.hs deleted file mode 100644 --- a/test/ArgKeySpec.hs +++ /dev/null @@ -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) diff --git a/test/FormatSpec.hs b/test/FormatSpec.hs deleted file mode 100644 --- a/test/FormatSpec.hs +++ /dev/null @@ -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 ['{', '}']) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 "" + ) diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/vformat.cabal b/vformat.cabal --- a/vformat.cabal +++ b/vformat.cabal @@ -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