diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -4,3 +4,9 @@ - Rewrite error system & fix bugs - Fix document - Rewrite unit tests + +## V0.11.0 +- Simplify `ArgKey` +- Make generic instantiate FormatArg configurable +- Expose standard formatters +- Fix some issue and doc diff --git a/src/Text/Format.hs b/src/Text/Format.hs --- a/src/Text/Format.hs +++ b/src/Text/Format.hs @@ -15,19 +15,34 @@ ( -- * Format functions format , format1 - -- * Data types + -- * Classes , FormatArg(formatArg) , FormatType(..) + -- * Generic format arg and options + , Options + , defaultOptions + , fieldLabelModifier + , genericFormatArg + -- * Data types , Formatter , Format , Format1 , ArgKey(..) + , topKey + , popKey , ArgFmt(..) , prettyArgFmt , FmtAlign(..) , FmtSign(..) , FmtNumSep(..) , (:=) (..) + -- * Standard Formatters + , formatString + , formatChar + , formatInt + , formatWord + , formatInteger + , formatRealFloat -- * Errors , ArgError(..) , errorArgKey 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 @@ -61,15 +61,15 @@ ==== 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 :: \ + 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. @@ -113,35 +113,35 @@ ==== String specs @ - s - default s + 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 + 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 + 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. 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,18 +1,28 @@ -module Text.Format.ArgKey ( ArgKey (..), emptyKey ) where +{-# LANGUAGE CPP #-} +module Text.Format.ArgKey ( ArgKey (..), topKey, popKey ) where + import Control.Arrow -import Data.Char (isDigit) -import qualified Data.List as L +import Data.Char (isDigit) +import qualified Data.List as L +#if MIN_VERSION_base(4, 11, 0) +import Data.Semigroup +#endif +import Text.Format.Error + {-| A data type indicates key of format argument ==== The key syntax @ - key :: [(int | chars) {"!" (int | chars)}] + key -> [(int | chars) {"!" (int | chars)}] @ + Since the "!" is used to seprate keys, if you need to include a "!" in a + named key, it can be escaped by doubling "!!". + Note: See 'Format' to learn more about syntax description language Examples @@ -23,16 +33,32 @@ >>> 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. +data ArgKey = Index Int -- ^ Refers to a top-level positional + -- argument or an element in an list-like + -- data type. + | Name String -- ^ Refers to a top-level named argument or + -- a field of a record data type. + | Nest ArgKey ArgKey -- ^ For @Nest k1 k2@, k1 refers to a + -- top-level argument or an attribute + -- (element or field) of a data type, + -- k2 refers an attribute of the data + -- referenced by k1. deriving (Eq, Ord) +#if MIN_VERSION_base(4, 11, 0) +instance Semigroup ArgKey where + (<>) = associate +#endif + +instance Monoid ArgKey where + -- | @Index -1@ is used as an empty key + mempty = Index (-1) +#if !MIN_VERSION_base(4, 11, 0) + mappend = associate +#endif + instance Read ArgKey where - readsPrec _ "" = [ (emptyKey, "") ] + readsPrec _ "" = [ (mempty, "") ] readsPrec _ cs = [ parse cs ] where parse :: String -> (ArgKey, String) @@ -41,7 +67,7 @@ ("", cs1) -> (undefined, cs1) (_, "!") -> (undefined, "!") (cs1, "") -> (parse1 cs1, "") - (cs1, cs2) -> first (Nest $ parse1 cs1) (parse cs2) + (cs1, cs2) -> first (mappend $ parse1 cs1) (parse cs2) parse1 :: String -> ArgKey parse1 cs = if all isDigit cs then Index (read cs) else Name cs @@ -55,7 +81,7 @@ (cs1, '!' : cs2) -> (cs1, cs2) instance Show ArgKey where - show k@(Index i) = if emptyKey == k then "" else show i + show k@(Index i) = if mempty == k then "" else show i show (Name s) = escape s where escape :: String -> String @@ -64,5 +90,44 @@ escape (c : cs) = (c : escape cs) show (Nest k1 k2) = show k1 ++ "!" ++ show k2 -emptyKey :: ArgKey -emptyKey = Index (-1) + +associate :: ArgKey -> ArgKey -> ArgKey +associate k (Index (-1)) = k +associate (Index (-1)) k = k +associate (Nest k11 k12) k2 = associate k11 $ associate k12 k2 +associate k1 k2 = Nest k1 k2 + + +{-| Extract the topmost indexed or named key from a key + +>>> topKey (read "k1!k2!k3") == Name "k1" +True +>>> topKey (read "name") == Name "name" +True +>>> topKey (read "123") == Index 123 +True +>>> topKey mempty +*** Exception: vformat: empty arg key +-} +topKey :: ArgKey -> ArgKey +topKey (Nest k@(Nest _ _) _) = topKey k +topKey (Nest k _) = k +topKey k = if k == mempty then vferror "empty arg key" + else k + +{-| Remove the topmost indexed or named key from a key + +>>> popKey (read "k1!k2!k3") == read "k2!k3" +True +>>> popKey (read "name") == mempty +True +>>> popKey (read "123") == mempty +True +>>> popKey mempty +*** Exception: vformat: empty arg key +-} +popKey :: ArgKey -> ArgKey +popKey (Nest k1@(Nest _ _) k2) = mappend (popKey k1) k2 +popKey (Nest _ k) = k +popKey k = if k == mempty then vferror "empty arg key" + else mempty 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 @@ -1,6 +1,7 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -8,9 +9,19 @@ ( Formatter , FormatArg(..) , FormatType(..) + , Options(..) + , defaultOptions + , genericFormatArg , (:=) (..) + , formatString + , formatChar + , formatInt + , formatWord + , formatInteger + , formatRealFloat ) where + import Control.Applicative import Control.Monad.Catch import Data.Char @@ -30,6 +41,7 @@ import Text.Format.Error import Text.Format.Format + type Formatter = ArgKey -> ArgFmt -> Either SomeException String @@ -37,7 +49,8 @@ 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 is a default 'formatArg' for 'Generic' instances, which applies +'defaultOptions' to 'genericFormatArg'. There are two reasons may cause formatting fail @@ -53,129 +66,190 @@ Examples @ - \{\-\# LANGUAGE DeriveGeneric \#\-\} - \{\-\# LANGUAGE OverloadedStrings \#\-\} +\{\-\# LANGUAGE DeriveGeneric \#\-\} +\{\-\# LANGUAGE OverloadedStrings \#\-\} - import Control.Exception - import GHC.Generics - import Text.Format +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 +-- Manually extend to () +instance FormatArg () where + formatArg x k fmt@(ArgFmt{fmtSpecs=\"U\"}) = + let fmt' = fmt{fmtSpecs = \"\"} + in formatArg (show x) k fmt' + formatArg _ _ _ = Left $ toException ArgFmtError - data Color = Red | Yellow | Blue deriving Generic +-- Use default generic implementation for type with nullary data constructors. +data Color = Red | Yellow | Blue deriving Generic - instance FormatArg Color +instance FormatArg Color - data Triple = Triple String Int Double deriving Generic +-- Use default generic implementation for type with non-nullary data constructor. +data Triple = Triple String Int Double deriving Generic - instance FormatArg Triple +instance FormatArg Triple - data Student = Student { no :: Int - , name :: String - , age :: Int - } deriving Generic +-- Use default generic implementation for type using record syntax. +data Student = Student { no :: Int + , name :: String + , age :: Int + } deriving Generic - instance FormatArg Student +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 +-- Customize field names +data Book = Book { bookName :: String + , bookAuthor :: String + , bookPrice :: Double + } + +instance FormatArg Book where + formatArg x k fmt + | k == mempty = return $ format1 \"{name} {author} {price:.2f}\" x + | k == Name \"name\" = formatArg (bookName x) mempty fmt + | k == Name \"author\" = formatArg (bookAuthor x) mempty fmt + | k == Name \"price\" = formatArg (bookPrice x) mempty fmt + | otherwise = Left $ toException $ ArgKeyError + +\-\- A better way to customize field names +\-\- instance FormatArg Book where +\-\- formatArg = genericFormatArg $ +\-\- defaultOptions { fieldLabelModifier = drop 4 } + +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 + putStrLn $ format \"A book: {}\" $ Book \"Math\" \"nobody\" 99.99 + putStrLn $ format1 \"Book: {name}, Author: {author}, Price: {price:.2f}\" $ + Book \"Math\" \"nobody\" 99.99 @ -} class FormatArg a where formatArg :: a -> Formatter default formatArg :: (Generic a, GFormatArg (Rep a)) => a -> Formatter - formatArg x = gformatArg (from x) + formatArg = genericFormatArg defaultOptions + formatArgList :: [a] -> Formatter + formatArgList xs (Index i) = formatArg (xs !! i) mempty + formatArgList xs (Nest (Index i) k) = formatArg (xs !! i) k + formatArgList _ _ = const $ throwM ArgKeyError + -- | 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 = 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) (Index (-1)) - formatArg x (Nest _ k@(Nest (Index i) _)) = formatArg (x !! i) k - formatArg _ _ = const $ throwM ArgKeyError + keyOf _ = mempty -instance {-# OVERLAPPABLE #-} FormatArg a => FormatArg (Map String a) where - 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 FormatArg Bool -instance {-# OVERLAPPABLE #-} FormatArg a => FormatArg (Map Int a) where - 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 Char where + formatArg = formatChar + formatArgList = formatString -instance FormatArg String where - formatArg = throwIfNest formatString +instance FormatArg Float where + formatArg = formatRealFloat -instance FormatArg Char where - formatArg = throwIfNest $ formatInteger False . toInteger . ord +instance FormatArg Double where + formatArg = formatRealFloat instance FormatArg Int where - formatArg = throwIfNest $ formatInteger True . toInteger + formatArg = formatInt instance FormatArg Int8 where - formatArg = throwIfNest $ formatInteger True . toInteger + formatArg = formatInt instance FormatArg Int16 where - formatArg = throwIfNest $ formatInteger True . toInteger + formatArg = formatInt instance FormatArg Int32 where - formatArg = throwIfNest $ formatInteger True . toInteger + formatArg = formatInt instance FormatArg Int64 where - formatArg = throwIfNest $ formatInteger True . toInteger + formatArg = formatInt +instance FormatArg Integer where + formatArg = formatInteger + +instance FormatArg Natural where + formatArg = formatIntegral False . toInteger + instance FormatArg Word where - formatArg = throwIfNest $ formatInteger False . toInteger + formatArg = formatWord instance FormatArg Word8 where - formatArg = throwIfNest $ formatInteger False . toInteger + formatArg = formatWord instance FormatArg Word16 where - formatArg = throwIfNest $ formatInteger False . toInteger + formatArg = formatWord instance FormatArg Word32 where - formatArg = throwIfNest $ formatInteger False . toInteger + formatArg = formatWord instance FormatArg Word64 where - formatArg = throwIfNest $ formatInteger False . toInteger + formatArg = formatWord -instance FormatArg Integer where - formatArg = throwIfNest $ formatInteger True +-- | Default specs is \"%Y-%m-%dT%H:%M:%S\", see 'formatTime'. +instance {-# OVERLAPPABLE #-} FormatTime t => FormatArg t where + formatArg x k fmt = + let specs = fmtSpecs fmt <|> "%Y-%m-%dT%H:%M:%S" + x' = formatTime defaultTimeLocale specs x + in formatArg x' k $ fmt{fmtSpecs=""} -instance FormatArg Natural where - formatArg = throwIfNest $ formatInteger False . toInteger +instance {-# OVERLAPPABLE #-} FormatArg a => FormatArg [a] where + {-# SPECIALIZE instance FormatArg [Char] #-} + formatArg = formatArgList -instance FormatArg Float where - formatArg = throwIfNest formatRealFloat +instance FormatArg a => FormatArg (Map String a) where + formatArg x (Name n) = formatArg (x ! n) mempty + formatArg x (Nest (Name n) k) = formatArg (x ! n) k + formatArg _ _ = const $ throwM ArgKeyError -instance FormatArg Double where - formatArg = throwIfNest formatRealFloat +instance FormatArg a => FormatArg (Map Int a) where + formatArg x (Index i) = formatArg (x ! i) mempty + formatArg x (Nest (Index i) k) = formatArg (x ! i) k + formatArg _ _ = const $ throwM ArgKeyError -------------------------------------------------------------------------------- +{-| Options that specify how to format your datatype + +Options can be set using record syntax on defaultOptions with the fields below. + +@since 0.11.0 +-} +data Options = Options { fieldLabelModifier :: String -> String + } + +{-| Default format options + +@ +'Options' +{ 'fieldLabelModifier' = id +} +@ + +@since 0.11.0 +-} +defaultOptions = Options { fieldLabelModifier = id + } + + +{-| A configurable generic 'Formatter' creator. + +@since 0.11.0 +-} +genericFormatArg :: (Generic a, GFormatArg (Rep a)) => Options -> a -> Formatter +genericFormatArg opts x = gformatArg (from x) opts + + +-------------------------------------------------------------------------------- class GFormatArg f where - gformatArg :: f p -> ArgKey -> ArgFmt -> Either SomeException String + gformatArg :: f p -> Options -> Formatter -- Data type instance GFormatArg f => GFormatArg (D1 c f) where @@ -191,44 +265,42 @@ -- 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 + gformatArg (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 + gformatArg c _ = formatArg (conName c) -- Try Products one by one instance (GFormatArg f, GFormatArg g) => GFormatArg (f :*: g) where - gformatArg (x :*: y) k fmt = - gformatArg x k fmt <|> gformatArg y (dec1 k) fmt + gformatArg (x :*: y) opts k fmt = + gformatArg x opts k fmt <|> gformatArg y opts (dec1 k) fmt where x <|> y = catchIf isArgKeyError x $ const y 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 + dec1 (Index i) = Index (i - 1) + dec1 (Nest k1 k2) = mappend (dec1 k1) k2 + dec1 k = k -- 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 + gformatArg s@(M1 x) opts (Index 0) + | selName s == "" = gformatArg x opts mempty + gformatArg s@(M1 x) opts (Nest (Index 0) k) + | selName s == "" = gformatArg x opts k + gformatArg s@(M1 x) opts@(Options{..}) (Name record) + | (fieldLabelModifier $ selName s) == record = gformatArg x opts mempty + gformatArg s@(M1 x) opts@(Options{..}) (Nest (Name record) k) + | (fieldLabelModifier $ selName s) == record = gformatArg x opts k + gformatArg _ _ _ = const $ throwM ArgKeyError -- FormatArg instance instance (FormatArg c) => GFormatArg (K1 i c) where - gformatArg (K1 c) = formatArg c + gformatArg (K1 c) _ = formatArg c -------------------------------------------------------------------------------- @@ -241,8 +313,9 @@ sfmt fmt args = \arg -> sfmt fmt $ insert (fixIndex $ keyOf arg) (formatArg arg) args where - fixIndex (Index (-1)) = Index $ length [n | Index n <- keys args] - fixIndex k = k + fixIndex k + | k == mempty = Index $ length [n | Index n <- keys args] + | otherwise = k instance FormatType String where sfmt fmt args = formats (unFormat fmt) @@ -256,8 +329,8 @@ formats1 :: FmtItem -> String formats1 (Lit cs) = cs - formats1 (Arg key ifmt) = - either (onError (key, ifmt)) id $ (getFormatter key) key (fixArgFmt ifmt) + formats1 (Arg key ifmt) = either (onError (key, ifmt)) id $ + (getFormatter key) (popKey key) (fixArgFmt ifmt) fixArgFmt :: ArgFmt -> ArgFmt fixArgFmt ifmt@(ArgFmt{fmtWidth=(Right key)}) = @@ -273,8 +346,7 @@ formatPrecision = formatWidth getFormatter :: ArgKey -> Formatter - getFormatter (Nest key _) = getFormatter key - getFormatter key = fromMaybe (\_ _ -> throwM ArgKeyError) $ args !? key + getFormatter = maybe (\_ _ -> throwM ArgKeyError) id . (args !?) . topKey -------------------------------------------------------------------------------- @@ -283,20 +355,25 @@ infixr 6 := instance FormatArg a => FormatArg ((:=) a) where - formatArg (_ := x) (Nest _ k) = formatArg x k - formatArg (_ := x) _ = formatArg x (Index (-1)) - + formatArg (_ := x) k = formatArg x k keyOf (ks := _) = Name ks -------------------------------------------------------------------------------- +{-| Formatter for string values + +@since 0.11.0 +-} formatString :: String -> Formatter +formatString _ k _ | k /= mempty = throwM ArgKeyError 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} = + +formatIntegral :: Bool -> Integer -> Formatter +formatIntegral _ _ k _ | k /= mempty = throwM ArgKeyError +formatIntegral signed x _ fmt@ArgFmt{fmtSpecs=specs} = formatNumber fmt signed (sepw specs) (flag specs) <$> (showx specs x) where sepw :: String -> Int @@ -330,7 +407,44 @@ showx "X" x = map toUpper <$> showx "x" x showx _ _ = throwM ArgFmtError + +{-| Formatter for 'Char' values + +@since 0.11.0 +-} +formatChar :: Char -> Formatter +formatChar = formatWord . ord + +{-| Formatter for 'Int' values + +@since 0.11.0 + -} +formatInt :: (Integral a, Bounded a) => a -> Formatter +formatInt = formatIntegral True . toInteger + + +{-| Formatter for 'Word' values + +@since 0.11.0 + -} +formatWord :: (Integral a, Bounded a) => a -> Formatter +formatWord = formatIntegral False . toInteger + + +{-| Formatter for 'Integer' values + +@since 0.11.0 + -} +formatInteger :: Integer -> Formatter +formatInteger = formatIntegral True + + +{-| Formatter for 'RealFloat' values + +@since 0.11.0 + -} formatRealFloat :: RealFloat a => a -> Formatter +formatRealFloat _ k _ | k /= mempty = throwM ArgKeyError formatRealFloat x _ fmt@ArgFmt{fmtSpecs=specs, fmtPrecision=prec} = formatNumber fmt True 3 Nothing <$> showx specs prec1 x where @@ -349,8 +463,3 @@ 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/Format.hs b/src/Text/Format/Format.hs --- a/src/Text/Format/Format.hs +++ b/src/Text/Format/Format.hs @@ -30,9 +30,9 @@ ==== Format string syntax @ - format :: {chars | ("{" [key][":"fmt] "}")} - key :: \ - fmt :: \ + format -> {chars | ("{" [key][":"fmt] "}")} + key -> \ + fmt -> \ @ Note: This library use a description language to describe syntax, @@ -54,22 +54,22 @@ 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 + identifier identifier of an expr + \ use natural 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 :: \ + char -> \ + chars -> {char} + int -> \ @ -} newtype Format = Format { unFormat :: [FmtItem] } deriving (Show, Eq) @@ -125,12 +125,13 @@ fixIndex :: Int -> [FmtItem] -> [FmtItem] fixIndex _ [] = [] - -- auto-positioned arg - fixIndex next ((Arg (Index (-1)) fmt) : items) = - (Arg (Index next) fmt) : fixIndex (next + 1) items - -- once there is an explict index arg key, auto-position args not working + -- fixing empty key + fixIndex next ((Arg key fmt) : items) + | key == mempty = (Arg (Index next) fmt) : fixIndex (next + 1) items + -- once there is an explict indexed key, stop fixing fixIndex next items@((Arg (Index _) _) : _) = items fixIndex next (item : items) = item : fixIndex next items + -- | A variant of 'Format', -- it transforms all argument's key to __Nest (Index 0) key__ diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -38,6 +38,7 @@ prop "keys are disordered" $ uncurry (==) . formatDisordered prop "arg format is omitted" $ uncurry (==) . formatOrdered "{:c}{}{}{}{}{}{}" + prop "generic" $ uncurry (==) . formatGeneric it "escaped brace" $ format "{{" == ['{'] && format "}}" == ['}'] prop "alignment and padding" $ \(align, PadChar c, n) -> @@ -138,6 +139,31 @@ <*> arbitrary +data Color = Red | Yellow | Blue deriving (Generic, Show) + +instance FormatArg Color + + +data Flag = Flag Color Int Int deriving (Generic, Show) + +instance FormatArg Flag + + +data Country = Country { _name :: String + , _flag :: Flag + } deriving (Generic, Show) + +instance FormatArg Country where + formatArg = genericFormatArg $ defaultOptions { fieldLabelModifier = drop 1 } + +instance Arbitrary Country where + arbitrary = Country <$> genName <*> genFlag + where + genName = (:[]) <$> elements ['A'..'Z'] + genFlag = Flag <$> genColor <*> arbitrary <*> arbitrary + genColor = elements [Red, Yellow, Blue] + + data PadChar = PadChar { getPadChar :: Char } deriving Show instance Arbitrary PadChar where @@ -196,6 +222,12 @@ word' = show word fs = "{6:s}{3:d}{2:g}{1:g}{4:d}{5:d}{0:c}" + +formatGeneric :: Country -> (String, String) +formatGeneric country@(Country{_flag=(Flag color width height), ..}) = + ( format1 "{name} {flag!0} {flag!1} {flag!2}" country + , format "{} {} {} {}" _name color width height + ) formatAlign :: FmtAlign -> Char -> Int -> (String, String) formatAlign align c n = 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: 5d5662a48ea62fc7081bff2ddcd8ec45db22cbbf6378456260cc0c35d0fbe73a +-- hash: 2036e677feacc5509914e6f6268eeb9a780e00ef9f609f19d4b52d21728b7fc6 name: vformat -version: 0.10.0.0 +version: 0.11.0.0 synopsis: A Python str.format() like formatter description: Please see the http://hackage.haskell.org/package/vformat category: Text, Format