diff --git a/Data/Text/Format.hs b/Data/Text/Format.hs index 99e4682..ba8daf8 100644 --- a/Data/Text/Format.hs +++ b/Data/Text/Format.hs @@ -48,30 +48,46 @@ import qualified Data.Text.Buildable as B import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.IO as LT +-- Format strings are almost always constants, and they're expensive +-- to interpret (which we refer to as "cracking" here). We'd really +-- like to have GHC memoize the cracking of a known-constant format +-- string, so that it occurs at most once. +-- +-- To achieve this, we arrange to have the cracked version of a format +-- string let-floated out as a CAF, by inlining the definitions of +-- build and functions that invoke it. This works well with GHC 7. + -- | Render a format string and arguments to a 'Builder'. build :: Params ps => Format -> ps -> Builder -build (Format fmt) ps = zipParams (map fromText . ST.splitOn "{}" $ fmt) xs - where zipParams (f:fs) (y:ys) = f <> y <> zipParams fs ys - zipParams [f] [] = f - zipParams _ _ = error . LT.unpack $ format - "Data.Text.Format.build: {} sites, but {} parameters" - (ST.count "{}" fmt, length xs) - xs = buildParams ps +build fmt ps = zipParams fmt (crack fmt) (buildParams ps) +{-# INLINE build #-} + +zipParams :: Format -> [Builder] -> [Builder] -> Builder +zipParams fmt xs = go xs + where go (f:fs) (y:ys) = f <> y <> go fs ys + go [f] [] = f + go _ _ = error . LT.unpack $ format + "Data.Text.Format.build: {} sites, but {} parameters" + (ST.count "{}" (fromFormat fmt), length xs) + +crack :: Format -> [Builder] +crack = map fromText . ST.splitOn "{}" . fromFormat -- | Render a format string and arguments to a 'LT.Text'. format :: Params ps => Format -> ps -> LT.Text format fmt ps = toLazyText $ build fmt ps +{-# INLINE format #-} -- | Render a format string and arguments, then print the result. print :: (MonadIO m, Params ps) => Format -> ps -> m () -{-# SPECIALIZE print :: (Params ps) => Format -> ps -> IO () #-} print fmt ps = liftIO . LT.putStr . toLazyText $ build fmt ps +{-# INLINE print #-} -- | Render a format string and arguments, then print the result to -- the given file handle. hprint :: (MonadIO m, Params ps) => Handle -> Format -> ps -> m () -{-# SPECIALIZE hprint :: (Params ps) => Handle -> Format -> ps -> IO () #-} hprint h fmt ps = liftIO . LT.hPutStr h . toLazyText $ build fmt ps +{-# INLINE hprint #-} -- | Pad the left hand side of a string until it reaches @k@ -- characters wide, if necessary filling with character @c@. @@ -120,3 +136,4 @@ expt decs = B.build . C.toExponential decs . realToFrac -- is added.) hex :: Integral a => a -> Builder hex = B.build . Hex +{-# INLINE hex #-} diff --git a/Data/Text/Format/Types/Internal.hs b/Data/Text/Format/Types/Internal.hs index ee40143..6e52c1e 100644 --- a/Data/Text/Format/Types/Internal.hs +++ b/Data/Text/Format/Types/Internal.hs @@ -43,8 +43,8 @@ import Data.Typeable (Typeable) -- -- The underlying type is 'Text', so literal Haskell strings that -- contain Unicode characters will be correctly handled. -newtype Format = Format Text - deriving (Eq, Ord, Typeable) +newtype Format = Format { fromFormat :: Text } + deriving (Eq, Ord, Typeable, Show) instance Monoid Format where Format a `mappend` Format b = Format (a `mappend` b) diff --git a/benchmarks/Simple.hs b/benchmarks/Simple.hs index c39eb04..a7a2acb 100644 --- a/benchmarks/Simple.hs +++ b/benchmarks/Simple.hs @@ -3,6 +3,7 @@ --module Main (main) where import Control.Monad +import Data.Char import Data.Bits import System.Environment import Data.Text.Format as T @@ -41,28 +42,32 @@ p6 count = counting count $ \i x -> do L.putStr . encodeUtf8 $ t arg :: Int -> Text -arg i = T.replicate (i.&.4) "fnord" +arg i = "fnord" `T.append` (T.take (i `mod` 6) "foobar") {-# NOINLINE arg #-} one count = counting count $ \i x -> do - let t = T.format "hi mom {}\n" (Only (arg i)) + let k = arg i + let t = {-# SCC "one/format" #-} T.format "hi mom {}\n" (Only k) L.putStr . encodeUtf8 $ t two count = counting count $ \i x -> do - let t = T.format "hi mom {} {}\n" (arg i,arg (i+1)) + let k = arg i + let t = {-# SCC "two/format" #-} T.format "hi mom {} {}\n" (k,k) L.putStr . encodeUtf8 $ t three count = counting count $ \i x -> do - let t = T.format "hi mom {} {} {}\n" (arg i,arg (i+1),arg (i+2)) + let k = arg i + let t = {-# SCC "three/format" #-} T.format "hi mom {} {} {}\n" (k,k,k) L.putStr . encodeUtf8 $ t four count = counting count $ \i x -> do - let t = T.format "hi mom {} {} {} {}\n" (arg i,arg (i+1),arg (i+2),arg (i+3)) + let k = arg i + let t = {-# SCC "four/format" #-} T.format "hi mom {} {} {} {}\n" (k,k,k,k) L.putStr . encodeUtf8 $ t five count = counting count $ \i x -> do - let t = T.format "hi mom {} {} {} {} {}\n" - (arg i,arg (i+1),arg (i+2),arg (i+3),arg (i+4)) + let k = arg i + let t = {-# SCC "five/format" #-} T.format "hi mom {} {} {} {} {}\n" (k,k,k,k,k) L.putStr . encodeUtf8 $ t dpi :: Double