diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for text-format-heavy + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/Data/Text/Format/Heavy.hs b/Data/Text/Format/Heavy.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Format/Heavy.hs @@ -0,0 +1,42 @@ +-- | This is the main module of @text-format-heavy@ library. +-- +-- In most cases, you need to import only this module, and probably also the +-- Data.Text.Format.Heavy.Time module, if you want to format time/date values. +-- +-- This package exports the @format@ function and @Format@ data type. +-- The Format type implements the instance of IsString, so in the code you may +-- use formatting strings as literals, if you enable @OverloadedStrings@ extension. +-- +-- Formatting strings syntax is based on Python's string.format() syntax. +-- +-- The simple usage example is +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings #\-} +-- module Main where +-- +-- import Data.Time +-- import qualified Data.Text.Lazy.IO as TLIO +-- import Data.Text.Format.Heavy +-- import Data.Text.Format.Heavy.Time +-- +-- main :: IO () +-- main = do +-- name <- getLine +-- time <- getZonedTime +-- TLIO.putStrLn $ format "Hello, {}! It is {:%H:%M:%S} now." (name, time) +-- @ +-- +module Data.Text.Format.Heavy + ( + module Data.Text.Format.Heavy.Types, + module Data.Text.Format.Heavy.Formats, + module Data.Text.Format.Heavy.Build, + module Data.Text.Format.Heavy.Instances + ) where + +import Data.Text.Format.Heavy.Types +import Data.Text.Format.Heavy.Formats +import Data.Text.Format.Heavy.Build (format) +import Data.Text.Format.Heavy.Instances (Single (..), Shown (..)) + diff --git a/Data/Text/Format/Heavy/Build.hs b/Data/Text/Format/Heavy/Build.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Format/Heavy/Build.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Text.Format.Heavy.Build + (format, formatEither, + makeBuilder, + -- * Formatters building utilities + align, applySign, applySharp, + formatInt, formatStr, formatFloat, formatBool + ) where + +import Control.Monad +import Data.Monoid +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as B +import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) +import Data.Text.Lazy.Builder.RealFloat + +import Data.Text.Format.Heavy.Types +import Data.Text.Format.Heavy.Formats + +makeBuilder :: VarContainer c => Format -> c -> Either String B.Builder +makeBuilder (Format items) vars = mconcat `fmap` mapM go items + where + go (FString s) = Right $ B.fromLazyText s + go (FVariable name fmt) = + case lookupVar name vars of + Nothing -> Left $ "Parameter not found: " ++ TL.unpack name + Just var -> formatVar fmt var +{-# INLINE makeBuilder #-} + +-- | The main formatting function. +-- This function throws @error@ if some error detected during format string parsing or formatting itself. +format :: VarContainer vars => Format -> vars -> TL.Text +format fmt vars = either error id $ formatEither fmt vars + +-- | The main formatting function. +-- This version returns @Left@ value with error description in case of error in +-- format string or error during formatting. +formatEither :: VarContainer vars => Format -> vars -> Either String TL.Text +formatEither fmt vars = either Left (Right . B.toLazyText) $ makeBuilder fmt vars + +align' :: Int -> Align -> Char -> B.Builder -> B.Builder +align' width AlignLeft fill text = + B.fromLazyText $ TL.justifyLeft (fromIntegral width) fill $ B.toLazyText text +align' width AlignRight fill text = + B.fromLazyText $ TL.justifyRight (fromIntegral width) fill $ B.toLazyText text +align' width AlignCenter fill text = + B.fromLazyText $ TL.center (fromIntegral width) fill $ B.toLazyText text + +-- | Align text within available width according to format +align :: GenericFormat -> B.Builder -> B.Builder +align fmt text = + case (gfAlign fmt, gfWidth fmt) of + (Just a, Just w) -> align' w a (gfFillChar fmt) text + _ -> text + +-- | Add @+/-@ sign to the number representation, if required +applySign :: (Num a, Ord a) => Sign -> a -> B.Builder -> B.Builder +applySign Always x text = + if x >= 0 + then B.singleton '+' <> text + else B.singleton '-' <> text +applySign OnlyNegative x text = + if x >= 0 + then text + else B.singleton '-' <> text +applySign SpaceForPositive x text = + if x >= 0 + then B.singleton ' ' <> text + else B.singleton '-' <> text + +-- | Add @0x@ to the number representation, if required +applySharp :: Bool -> Radix -> B.Builder -> B.Builder +applySharp False _ text = text +applySharp True Decimal text = text +applySharp True Hexadecimal text = B.fromLazyText "0x" <> text + +-- | Format integer number according to GenericFormat +formatInt :: Integral a => GenericFormat -> a -> B.Builder +formatInt fmt x = align fmt $ applySign (gfSign fmt) x $ applySharp (gfLeading0x fmt) radix $ inRadix + where + radix = fromMaybe Decimal (gfRadix fmt) + inRadix = case radix of + Decimal -> decimal (abs x) + Hexadecimal -> hexadecimal (abs x) + +-- | Format floating-point number according to GenericFormat +formatFloat :: RealFloat a => GenericFormat -> a -> B.Builder +formatFloat fmt x = + align fmt $ applySign (gfSign fmt) x $ formatRealFloat Fixed (gfPrecision fmt) $ abs x + +-- | Format Text according to GenericFormat. +formatStr :: GenericFormat -> TL.Text -> B.Builder +formatStr fmt text = align fmt $ B.fromLazyText text + +-- | Format boolean value. +formatBool :: BoolFormat -> Bool -> B.Builder +formatBool fmt True = B.fromLazyText $ bfTrue fmt +formatBool fmt False = B.fromLazyText $ bfFalse fmt + diff --git a/Data/Text/Format/Heavy/Formats.hs b/Data/Text/Format/Heavy/Formats.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Format/Heavy/Formats.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module contains format descriptions for most used variable types. +module Data.Text.Format.Heavy.Formats where + +import Data.Default +import qualified Data.Text.Lazy as TL + +import Data.Text.Format.Heavy.Types + +-- | Alignment of string within specified width +data Align = AlignLeft | AlignRight | AlignCenter + deriving (Eq, Show) + +-- | Whether to show the sign of number +data Sign = Always | OnlyNegative | SpaceForPositive + deriving (Eq, Show) + +-- | Number base +data Radix = Decimal | Hexadecimal + deriving (Eq, Show) + +-- | Generic format description. This is usable for integers, floats and strings. +data GenericFormat = GenericFormat { + gfFillChar :: Char + , gfAlign :: Maybe Align + , gfSign :: Sign + , gfLeading0x :: Bool + , gfWidth :: Maybe Int + , gfPrecision :: Maybe Int + , gfRadix :: Maybe Radix + } + deriving (Eq, Show) + +instance Default GenericFormat where + def = GenericFormat { + gfFillChar = ' ' + , gfAlign = Nothing + , gfSign = OnlyNegative + , gfLeading0x = False + , gfWidth = Nothing + , gfPrecision = Nothing + , gfRadix = Nothing + } + +data BoolFormat = BoolFormat { + bfTrue :: TL.Text + , bfFalse :: TL.Text + } + deriving (Eq, Show) + +instance Default BoolFormat where + def = BoolFormat "true" "false" + diff --git a/Data/Text/Format/Heavy/Instances.hs b/Data/Text/Format/Heavy/Instances.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Format/Heavy/Instances.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances #-} +-- | This module contains Formatable and VarContainer instances for most used types. +module Data.Text.Format.Heavy.Instances + (-- * Utility data types + Single (..), Shown (..), + -- * Generic formatters + genericIntFormat, genericFloatFormat + ) where + +import Data.String +import Data.Char +import Data.Default +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as B +import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) + +import Data.Text.Format.Heavy.Types +import Data.Text.Format.Heavy.Formats +import Data.Text.Format.Heavy.Parse +import Data.Text.Format.Heavy.Build + +instance IsString Format where + fromString str = parseFormat' (fromString str) + +----------------------- IsVarFormat instances -------------------------------------- + +instance IsVarFormat GenericFormat where + parseVarFormat text = either (Left . show) Right $ parseGenericFormat text + + + +---------------------- Generic formatters ------------------------------------------- + +-- | Generic formatter for integer types +genericIntFormat :: Integral a => VarFormat -> a -> Either String B.Builder +genericIntFormat Nothing x = Right $ formatInt def x +genericIntFormat (Just fmtStr) x = + case parseGenericFormat fmtStr of + Left err -> Left $ show err + Right fmt -> Right $ formatInt fmt x + +-- | Generic formatter for floating-point types +genericFloatFormat :: RealFloat a => VarFormat -> a -> Either String B.Builder +genericFloatFormat Nothing x = Right $ formatFloat def x +genericFloatFormat (Just fmtStr) x = + case parseGenericFormat fmtStr of + Left err -> Left $ show err + Right fmt -> Right $ formatFloat fmt x + +------------------------ Formatable instances ------------------------------------------- + +instance Formatable Int where + formatVar fmt x = genericIntFormat fmt x + +instance Formatable Integer where + formatVar fmt x = genericIntFormat fmt x + +instance Formatable Float where + formatVar fmt x = genericFloatFormat fmt x + +instance Formatable Double where + formatVar fmt x = genericFloatFormat fmt x + +instance Formatable String where + formatVar Nothing text = Right $ formatStr def (fromString text) + formatVar (Just fmtStr) text = + case parseGenericFormat fmtStr of + Left err -> Left $ show err + Right fmt -> Right $ formatStr fmt (fromString text) + +instance Formatable T.Text where + formatVar Nothing text = Right $ formatStr def $ TL.fromStrict text + formatVar (Just fmtStr) text = + case parseGenericFormat fmtStr of + Left err -> Left $ show err + Right fmt -> Right $ formatStr fmt $ TL.fromStrict text + +instance Formatable TL.Text where + formatVar Nothing text = Right $ formatStr def text + formatVar (Just fmtStr) text = + case parseGenericFormat fmtStr of + Left err -> Left $ show err + Right fmt -> Right $ formatStr fmt text + +instance Formatable Bool where + formatVar Nothing x = Right $ formatBool def x + formatVar (Just fmtStr) x = + case parseBoolFormat fmtStr of + Left err -> Left $ show err + Right fmt -> Right $ formatBool fmt x + +-- | Container for single parameter. +-- Example usage: +-- +-- @ +-- format "Hello, {}!" (Single name) +-- @ +data Single a = Single {getSingle :: a} + deriving (Eq, Show) + +instance Formatable a => Formatable (Single a) where + formatVar fmt (Single x) = formatVar fmt x + +-- | Values packed in Shown will be formatted using their Show instance. +-- +-- For example, +-- +-- @ +-- formatText "values: {}." (Shown (True, False)) ==> "values: (True, False)." +-- @ +data Shown a = Shown { shown :: a } + deriving (Eq) + +instance Show a => Show (Shown a) where + show (Shown x) = show x + +instance Show a => Formatable (Shown a) where + formatVar _ (Shown x) = Right $ B.fromLazyText $ TL.pack $ show x + +instance Formatable a => Formatable (Maybe a) where + formatVar Nothing Nothing = Right mempty + formatVar fmt (Just x) = formatVar fmt x + +instance (Formatable a, Formatable b) => Formatable (Either a b) where + formatVar fmt (Left x) = formatVar fmt x + formatVar fmt (Right y) = formatVar fmt y + +------------------------------- VarContainer instances ------------------------------------- + +instance Formatable a => VarContainer (Single a) where + lookupVar "0" (Single x) = Just $ Variable x + lookupVar _ _ = Nothing + +instance VarContainer () where + lookupVar _ _ = Nothing + +instance (Formatable a, Formatable b) => VarContainer (a, b) where + lookupVar "0" (a,_) = Just $ Variable a + lookupVar "1" (_,b) = Just $ Variable b + lookupVar _ _ = Nothing + +instance (Formatable a, Formatable b, Formatable c) => VarContainer (a, b, c) where + lookupVar "0" (a,_,_) = Just $ Variable a + lookupVar "1" (_,b,_) = Just $ Variable b + lookupVar "2" (_,_,c) = Just $ Variable c + lookupVar _ _ = Nothing + +instance (Formatable a, Formatable b, Formatable c, Formatable d) => VarContainer (a, b, c, d) where + lookupVar "0" (a,_,_,_) = Just $ Variable a + lookupVar "1" (_,b,_,_) = Just $ Variable b + lookupVar "2" (_,_,c,_) = Just $ Variable c + lookupVar "3" (_,_,_,d) = Just $ Variable d + lookupVar _ _ = Nothing + +instance (Formatable a, Formatable b, Formatable c, Formatable d, Formatable e) + => VarContainer (a, b, c, d, e) where + lookupVar "0" (a,_,_,_,_) = Just $ Variable a + lookupVar "1" (_,b,_,_,_) = Just $ Variable b + lookupVar "2" (_,_,c,_,_) = Just $ Variable c + lookupVar "3" (_,_,_,d,_) = Just $ Variable d + lookupVar "4" (_,_,_,_,e) = Just $ Variable e + lookupVar _ _ = Nothing + +instance (Formatable a, Formatable b, Formatable c, Formatable d, Formatable e, Formatable f) + => VarContainer (a, b, c, d, e, f) where + lookupVar "0" (a,_,_,_,_,_) = Just $ Variable a + lookupVar "1" (_,b,_,_,_,_) = Just $ Variable b + lookupVar "2" (_,_,c,_,_,_) = Just $ Variable c + lookupVar "3" (_,_,_,d,_,_) = Just $ Variable d + lookupVar "4" (_,_,_,_,e,_) = Just $ Variable e + lookupVar "5" (_,_,_,_,_,f) = Just $ Variable f + lookupVar _ _ = Nothing + +instance (Formatable a, Formatable b, Formatable c, Formatable d, Formatable e, Formatable f, Formatable g) + => VarContainer (a, b, c, d, e, f, g) where + lookupVar "0" (a,_,_,_,_,_,_) = Just $ Variable a + lookupVar "1" (_,b,_,_,_,_,_) = Just $ Variable b + lookupVar "2" (_,_,c,_,_,_,_) = Just $ Variable c + lookupVar "3" (_,_,_,d,_,_,_) = Just $ Variable d + lookupVar "4" (_,_,_,_,e,_,_) = Just $ Variable e + lookupVar "5" (_,_,_,_,_,f,_) = Just $ Variable f + lookupVar "6" (_,_,_,_,_,_,g) = Just $ Variable g + lookupVar _ _ = Nothing + +instance Formatable a => VarContainer [a] where + lookupVar name lst = + if not $ TL.all isDigit name + then Nothing + else let n = read (TL.unpack name) + in if n >= length lst + then Nothing + else Just $ Variable (lst !! n) + +instance Formatable x => VarContainer [(TL.Text, x)] where + lookupVar name pairs = Variable `fmap` lookup name pairs + +instance Formatable x => VarContainer (M.Map TL.Text x) where + lookupVar name pairs = Variable `fmap` M.lookup name pairs + diff --git a/Data/Text/Format/Heavy/Parse.hs b/Data/Text/Format/Heavy/Parse.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Format/Heavy/Parse.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module contains parsers for formatting strings. +-- We have to deal with two kinds of strings: +-- +-- * String formats. This is the whole construct like @"Hello, {}! Your account balance is {1:+8.4}."@. +-- * Variable formats. This is only part after colon in braces, i.e. the @+8.4@ thing in previous example. +-- +-- The string format syntax is supposed to be very stable and simple. It is basically defined by phrase +-- "any part in braces is variable substitution". +-- +-- Variable formats syntax depends on type of data which we are going to format. These formats can be +-- pretty complex, for example they can include alignment, rounding, and so on. +-- +module Data.Text.Format.Heavy.Parse + (-- * Parse functions + parseFormat, parseFormat', + parseGenericFormat, parseBoolFormat, + -- * Parsec functions + pFormat, pGenericFormat, pBoolFormat, + -- * Utility types + Parser, ParserState (..), initParserState + ) where + +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as B +import Text.Parsec + +import Data.Text.Format.Heavy.Types +import Data.Text.Format.Heavy.Formats + +data ParserState = ParserState { + psNextIndex :: Int + } + deriving (Eq, Show) + +initParserState :: ParserState +initParserState = ParserState 0 + +type Parser a = Parsec TL.Text ParserState a + +-- TODO: proper handling of escaping +anyChar' :: Parser Char +anyChar' = + noneOf "{}" <|> try ('{' <$ string "\\{") <|> try ('}' <$ string "\\}") + +pVerbatim :: Parser FormatItem +pVerbatim = (FString . TL.pack) `fmap` many1 anyChar' + +pVariable :: Parser FormatItem +pVariable = do + (name, fmt) <- between (char '{') (char '}') variable + return $ FVariable (TL.pack name) fmt + where + variable = do + name <- many alphaNum + mbColon <- optionMaybe $ char ':' + fmt <- case mbColon of + Nothing -> return Nothing + Just _ -> do + fmtStr <- many anyChar' + return $ Just $ TL.pack fmtStr + name' <- if null name + then do + st <- getState + let n = psNextIndex st + modifyState $ \st -> st {psNextIndex = psNextIndex st + 1} + return $ show n + else return name + return (name', fmt) + +-- | Parsec parser for string format. +pFormat :: Parser Format +pFormat = Format `fmap` many (try pVariable <|> pVerbatim) + +-- | Parse string format definition. +parseFormat :: TL.Text -> Either ParseError Format +parseFormat text = runParser pFormat initParserState "" text + +-- | Version of parseFormat which throws @error@ in case of syntax error in the formatting string. +parseFormat' :: TL.Text -> Format +parseFormat' text = either (error . show) id $ parseFormat text + +-- | Parsec parser for generic (Python-like) variable format. +pGenericFormat :: Parsec TL.Text st GenericFormat +pGenericFormat = do + mbFillAlign <- optionMaybe (try pFillAlign "fill and align specification") + let fill = fromMaybe ' ' $ fst `fmap` mbFillAlign + let align = snd `fmap` mbFillAlign + mbSign <- optionMaybe (pSign "sign specification") + let sign = fromMaybe OnlyNegative mbSign + mbLeading0x <- optionMaybe (pLeading0x "leading 0x specification") + let leading0x = fromMaybe False mbLeading0x + mbWidth <- optionMaybe (pWidth "width specification") + mbPrecision <- optionMaybe (pPrecision "precision specification") + mbRadix <- optionMaybe (pRadix "radix specification") + return $ GenericFormat { + gfFillChar = fill + , gfAlign = align + , gfSign = sign + , gfLeading0x = leading0x + , gfWidth = mbWidth + , gfPrecision = mbPrecision + , gfRadix = mbRadix + } + where + pAlign :: Parsec TL.Text st Align + pAlign = do + alignChar <- oneOf "<>^" + align <- case alignChar of + '<' -> return AlignLeft + '>' -> return AlignRight + '^' -> return AlignCenter + _ -> fail $ "Unexpected align char: " ++ [alignChar] + return align + + pAlignWithFill :: Parsec TL.Text st (Char, Align) + pAlignWithFill = do + fill <- noneOf "<>=^" + align <- pAlign + return (fill, align) + + pAlignWithoutFill :: Parsec TL.Text st (Char, Align) + pAlignWithoutFill = do + align <- pAlign + return (' ', align) + + pFillAlign :: Parsec TL.Text st (Char, Align) + pFillAlign = do + try pAlignWithoutFill <|> pAlignWithFill + + pSign :: Parsec TL.Text st Sign + pSign = do + signChar <- oneOf "+- " + sign <- case signChar of + '+' -> return Always + '-' -> return OnlyNegative + ' ' -> return SpaceForPositive + _ -> fail $ "Unexpected sign char: " ++ [signChar] + return sign + + pLeading0x :: Parsec TL.Text st Bool + pLeading0x = do + mbSharp <- optionMaybe $ char '#' + case mbSharp of + Nothing -> return False + Just _ -> return True + + natural :: Parsec TL.Text st Int + natural = do + ws <- many1 $ oneOf "0123456789" + return $ read ws + + pWidth :: Parsec TL.Text st Int + pWidth = natural + + pPrecision :: Parsec TL.Text st Int + pPrecision = do + char '.' + natural + + pRadix :: Parsec TL.Text st Radix + pRadix = do + rc <- oneOf "xhd" + case rc of + 'x' -> return Hexadecimal + 'h' -> return Hexadecimal + 'd' -> return Decimal + +-- | Parse generic variable format. +-- +-- Syntax is: +-- +-- @ +-- [[fill]align][sign][#][width][.precision][radix] +-- @ +-- +-- where: +-- +-- * fill - padding character (space by default) +-- * align - alignment indicator (@<@, @>@, or @^@) +-- * sign - when to show number's sign (@+@, @-@, or space) +-- * @#@ - if specified, then for hexadecimal numbers the leading @0x@ will be added +-- * width - minimum length of the field +-- * precision - number of decimal places after point, for floatting-point numbers +-- * radix - @h@ or @x@ for hexadecimal, @d@ for decimal (default). +-- +parseGenericFormat :: TL.Text -> Either ParseError GenericFormat +parseGenericFormat text = runParser pGenericFormat () "" text + +-- | Parsec parser for Bool format +pBoolFormat :: Parsec TL.Text st BoolFormat +pBoolFormat = do + true <- many $ noneOf ":,;" + oneOf ":,;" + false <- many $ anyChar + return $ BoolFormat (TL.pack true) (TL.pack false) + +-- | Parse Bool format. +-- +-- Syntax is: +-- +-- @ +-- TRUE:FALSE +-- @ +-- +-- Colon can be replaced with comma or semicolon. +-- +-- For example, valid format specifications are @true:false@ (the default one), +-- @True:False@, @yes:no@, and so on. +-- +parseBoolFormat :: TL.Text -> Either ParseError BoolFormat +parseBoolFormat text = runParser pBoolFormat () "" text + diff --git a/Data/Text/Format/Heavy/Time.hs b/Data/Text/Format/Heavy/Time.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Format/Heavy/Time.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances #-} +-- | This module contains Formatable instances for time/date values, +-- which use Data.Time.Format notation for formats (like @%H:%M@). +-- Default date/time format is RFC 822. +-- +-- This module is not re-exported by Data.Text.Format.Heavy by default, +-- because it defines only one of possible time formatting strings syntaxes. +-- One may like other syntax for some reason; if we re-exported this module by +-- default, it would be impossible to hide these instances to implement other. +-- +module Data.Text.Format.Heavy.Time where + +import Data.String +import Data.Char +import Data.Default +import Data.Time +import Data.Time.Format +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as B + +import Data.Text.Format.Heavy.Types +import Data.Text.Format.Heavy.Parse +import Data.Text.Format.Heavy.Build + +-- | Generic time formatter, using Data.Time.Format +genericTimeFormat :: FormatTime t => VarFormat -> t -> Either String B.Builder +genericTimeFormat Nothing x = Right $ B.fromString $ formatTime defaultTimeLocale rfc822DateFormat x +genericTimeFormat (Just fmtStr) x = + Right $ B.fromString $ formatTime defaultTimeLocale (TL.unpack fmtStr) x + +------------------------ Formatable instances ------------------------------------------- + +-- instance Formatable UniversalTime where +-- formatVar fmt x = genericTimeFormat fmt x + +instance Formatable Day where + formatVar fmt x = genericTimeFormat fmt x + +instance Formatable UTCTime where + formatVar fmt x = genericTimeFormat fmt x + +instance Formatable TimeZone where + formatVar fmt x = genericTimeFormat fmt x + +instance Formatable TimeOfDay where + formatVar fmt x = genericTimeFormat fmt x + +instance Formatable LocalTime where + formatVar fmt x = genericTimeFormat fmt x + +instance Formatable ZonedTime where + formatVar fmt x = genericTimeFormat fmt x + diff --git a/Data/Text/Format/Heavy/Types.hs b/Data/Text/Format/Heavy/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Format/Heavy/Types.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ExistentialQuantification, TypeFamilies, FlexibleContexts, OverloadedStrings #-} +-- | This module contains basic type definitions +module Data.Text.Format.Heavy.Types where + +import Data.Default +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as B + +-- | Variable name +type VarName = TL.Text + +-- | Variable format in text form. Nothing means default format. +type VarFormat = Maybe TL.Text + +-- | String format item. +data FormatItem = + FString TL.Text -- ^ Verbatim text + | FVariable { + vName :: VarName -- ^ Variable name + , vFormat :: VarFormat -- ^ Variable format + } + deriving (Show) + +-- | String format +data Format = Format [FormatItem] + deriving (Show) + +-- | Can be used for different data types describing formats of specific types. +class (Default f, Show f) => IsVarFormat f where + -- | Left for errors. + parseVarFormat :: TL.Text -> Either String f + +instance IsVarFormat () where + parseVarFormat "" = Right () + parseVarFormat fmt = Left $ "Unsupported format: " ++ TL.unpack fmt + +-- | Value that can be formatted to be substituted into format string. +class Formatable a where + -- | Format variable according to format specification. + -- This function should usually parse format specification by itself. + formatVar :: VarFormat -- ^ Variable format specification in text form. Nothing is for default format. + -> a -- ^ Variable value. + -> Either String B.Builder -- ^ Left for errors in variable format syntax, or errors during formatting. + +-- | Any variable that can be substituted. +-- This type may be also used to construct heterogeneous lists: +-- @[Variable 1, Variable "x"] :: [Variable]@. +data Variable = forall a. Formatable a => Variable a + +instance Formatable Variable where + formatVar fmt (Variable x) = formatVar fmt x + +-- | Format one variable according to format specification. +formatAnyVar :: VarFormat -> Variable -> Either String B.Builder +formatAnyVar fmt (Variable v) = formatVar fmt v + +-- | Data structure that contains some number of variables. +class VarContainer c where + lookupVar :: VarName -> c -> Maybe Variable + +------------------------------------------------------------------------------ + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Ilya Portnov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ilya Portnov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Benchmarks.hs b/examples/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/examples/Benchmarks.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Criterion.Main +import Data.Text.Format.Heavy +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Text.Printf as P + +printf1 :: (P.PrintfArg a) => String -> a -> String +printf1 f a = P.printf f a + +printf2 :: (P.PrintfArg a, P.PrintfArg b) => String -> (a,b) -> String +printf2 f (a,b) = P.printf f a b + +printf3 :: (P.PrintfArg a, P.PrintfArg b, P.PrintfArg c) => + String -> (a,b,c) -> String +printf3 f (a,b,c) = P.printf f a b c + +main = defaultMain [ + bgroup "arity" [ + bench "0" $ nf (format "hi") () + , bench "1" $ nf (format "hi {}") (Single $ T.pack "mom") + , bench "2" $ nf (format "hi {}, how are {}") + (T.pack "mom", T.pack "you") + , bench "3" $ nf (format "hi {}, how are {} keeping {}") + (T.pack "mom", T.pack "you", T.pack "now") + , bench "4" $ nf (format "hi {}, {} - how are {} keeping {}") + (T.pack "mom", T.pack "hey", T.pack "you", T.pack "now") + ] + , bgroup "comparison" [ + bench "format1" $ nf (format "hi mom {}\n") (Single (pi::Double)) + , bench "printf1" $ nf (printf1 "hi mom %f\n") (pi::Double) + , bench "show1" $ nf (\d -> "hi mom " ++ show d ++ "\n") (pi::Double) + , bench "format2" $ nf (format "hi mom {} {}\n") (pi::Double, "yeah"::T.Text) + , bench "printf2" $ nf (printf2 "hi mom %f %s\n") (pi::Double, "yeah"::String) + , bench "show2" $ nf (\(d,s) -> "hi mom " ++ show d ++ " " ++ show s ++ "\n") (pi::Double, "yeah"::String) + , bench "format3" $ nf (format "hi mom {} {} {}\n") (pi::Double, "yeah"::T.Text, 21212121::Int) + , bench "printf3" $ nf (printf3 "hi mom %f %s %d\n") (pi::Double, "yeah"::String, 21212121::Int) + , bench "show3" $ nf (\(d,s,i) -> "hi mom " ++ show d ++ " " ++ show s ++ "\n") (pi::Double, "yeah"::String, 21212121::Int) + ] + , bgroup "types" [ + bench "unit" $ nf (format "hi") () + , bgroup "int" [ + bench "small" $ nf (format "hi {}") (Single (1::Int)) + , bench "medium" $ nf (format "hi {}") (Single (1234::Int)) + , bench "large" $ nf (format "hi {}") (Single (0x7fffffff::Int)) + ] + , bgroup "float" [ + bench "small" $ nf (format "hi {}") (Single (1::Float)) + , bench "medium" $ nf (format "hi {}") (Single (pi::Float)) + , bench "large" $ nf (format "hi {}") (Single (pi*1e37::Float)) + ] + , bgroup "double" [ + bench "small" $ nf (format "hi {}") (Single (1::Double)) + , bench "medium" $ nf (format "hi {}") (Single (pi::Double)) + , bench "large" $ nf (format "hi {}") (Single (pi*1e37::Double)) + ] + , bgroup "string" [ + bench "small" $ nf (format "hi {}") (Single ("mom" :: String)) + , bench "medium" $ nf (format "hi {}") + (Single . concat . replicate 64 $ ("mom" :: String)) + , bench "large" $ nf (format "hi {}") + (Single . concat . replicate 1024 $ ("mom" :: String)) + ] + , bgroup "text" [ + bench "small" $ nf (format "hi {}") (Single (T.pack "mom")) + , bench "medium" $ nf (format "hi {}") (Single (T.replicate 64 "mom")) + , bench "large" $ nf (format "hi {}") (Single (T.replicate 1024 "mom")) + ] + , bgroup "lazytext" [ + bench "small" $ nf (format "hi {}") (Single (L.pack "mom")) + , bench "medium" $ nf (format "hi {}") + (Single . L.fromChunks . replicate 64 $ "mom") + , bench "large" $ nf (format "hi {}") + (Single . L.fromChunks . replicate 1024 $ "mom") + ] + ] + ] diff --git a/examples/test.hs b/examples/test.hs new file mode 100644 --- /dev/null +++ b/examples/test.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Data.Time +import qualified Data.Text.Lazy.IO as TLIO +import Data.Text.Format.Heavy +import Data.Text.Format.Heavy.Time + +main :: IO () +main = do + let template = "x: {:#x}, y: <{:^10}>, z: {:+6.4}, x(d): {0}, t: {}, y: {}, r: {}; bool: {:yes:no}." + -- xs = [Variable (18 :: Int), Variable ("hello" :: String), Variable (3 :: Int)] + rt = (Right 7) :: Either String Int + xs = (18 :: Int, "hello" :: String, 2.718281828 :: Double, Shown (Just (7 :: Int)), Just (8 :: Int), rt, True) + TLIO.putStrLn $ format template xs + time <- getZonedTime + TLIO.putStrLn $ format "Hello, {}! It is {:%H:%M:%S} now." $ ("Ilya" :: String, time) + + diff --git a/text-format-heavy.cabal b/text-format-heavy.cabal new file mode 100644 --- /dev/null +++ b/text-format-heavy.cabal @@ -0,0 +1,58 @@ +name: text-format-heavy +version: 0.1.0.0 +synopsis: Full-weight string formatting library, analog of Python's string.format +description: This package contains full-featured string formatting function, similar to + Python's string.format. Features include: + . + * Automatically numbered variable placeholders; + . + * Positional variable placeholders; + . + * Named variable placeholders; + . + * Placeholders can be used in any order; one variable can be used several + times or not used at all. + . + * Specific format can be used for each variable substitution. + . + This package prefers functionality over "light weight" and (probably) performance. + It also exposes all required interfaces to extend and customize it. + . + For more details, please refer to . + See also the @examples/@ directory. + +license: BSD3 +license-file: LICENSE +author: Ilya Portnov +maintainer: portnov84@rambler.ru +-- copyright: +category: Text +build-type: Simple +extra-source-files: ChangeLog.md, + examples/test.hs, + examples/Benchmarks.hs +cabal-version: >=1.10 + +library + exposed-modules: Data.Text.Format.Heavy, + Data.Text.Format.Heavy.Parse, + Data.Text.Format.Heavy.Build, + Data.Text.Format.Heavy.Types, + Data.Text.Format.Heavy.Formats, + Data.Text.Format.Heavy.Instances, + Data.Text.Format.Heavy.Time + -- other-modules: + other-extensions: ExistentialQuantification + build-depends: base >=4.8 && <5, + text >=1.2 && <1.3, + parsec >=3.1 && <3.2, + containers >= 0.5, + data-default >= 0.7, + time >= 1.5 + -- hs-source-dirs: + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/portnov/text-format-heavy.git +