diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,18 @@ + +module Main where + +import Criterion.Main (bench, bgroup, defaultMain, nf) +import Text.Pretty.Simple (pShow) + +import Example.Data (foo, bar, baz) + +main :: IO () +main = + defaultMain + [ bgroup + "pShow" + [ bench "Foo" $ nf pShow foo + , bench "Bar" $ nf pShow bar + , bench "Baz" $ nf pShow baz + ] + ] diff --git a/example/Example.hs b/example/Example.hs new file mode 100644 --- /dev/null +++ b/example/Example.hs @@ -0,0 +1,13 @@ + +module Main where + +import Text.Pretty.Simple (pPrint) + +import Example.Data (bar) + +main :: IO () +main = do + putStrLn "\nThe following normal \"print\" output:\n" + print bar + putStrLn "\ngets turned into this (using \"Text.Pretty.Simple.pPrint\"):\n" + pPrint bar diff --git a/example/Example/Data.hs b/example/Example/Data.hs new file mode 100644 --- /dev/null +++ b/example/Example/Data.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Example.Data where + +import Data.Data (Data) +import Data.Typeable (Typeable) + +data Foo = Foo + { foo1 :: Integer + , foo2 :: [String] + , foo3 :: Double + } deriving (Data, Eq, Read, Show, Typeable) + +data Bar = Bar + { bar1 :: Integer + , bar2 :: [Foo] + , bar3 :: Double + } deriving (Data, Eq, Read, Show, Typeable) + +data Baz = Baz + { baz1 :: Bar + , baz2 :: [Baz] + } deriving (Data, Eq, Read, Show, Typeable) + +foo :: Foo +foo = Foo 3 fooList 3.3 + +bar :: Bar +bar = Bar 10 (replicate 2 foo) 10.55 + +bazLevel1 :: Baz +bazLevel1 = Baz bar [] + +bazLevel2 :: Baz +bazLevel2 = Baz bar $ replicate 5 bazLevel1 + +baz :: Baz +baz = Baz bar $ replicate 5 bazLevel2 + +fooList :: [String] +fooList = + [ "hello" + , "goodbye" + , "dog" + , "cat" + , "fox" + , "beaver" + ] + diff --git a/pretty-simple.cabal b/pretty-simple.cabal --- a/pretty-simple.cabal +++ b/pretty-simple.cabal @@ -1,5 +1,5 @@ name: pretty-simple -version: 0.3.0.0 +version: 1.0.0.0 synopsis: Simple pretty printer for any datatype with a 'Show' instance. description: Please see README.md homepage: https://github.com/cdepillabout/pretty-simple @@ -13,6 +13,10 @@ extra-source-files: README.md cabal-version: >=1.10 +flag buildexample + description: Build a small example program showing how to use the pPrint function + default: False + library hs-source-dirs: src exposed-modules: Text.Pretty.Simple @@ -29,11 +33,26 @@ , mtl , parsec , semigroups + , text , transformers default-language: Haskell2010 ghc-options: -Wall other-extensions: TemplateHaskell +executable pretty-simple-example + main-is: Example.hs + other-modules: Example.Data + hs-source-dirs: example + build-depends: base + , pretty-simple + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + + if flag(buildexample) + buildable: True + if !flag(buildexample) + buildable: False + test-suite pretty-simple-doctest type: exitcode-stdio-1.0 main-is: DocTest.hs @@ -41,6 +60,18 @@ build-depends: base , doctest , Glob + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +benchmark pretty-simple-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + other-modules: Example.Data + hs-source-dirs: bench + , example + build-depends: base + , criterion + , pretty-simple default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Text/Pretty/Simple.hs b/src/Text/Pretty/Simple.hs --- a/src/Text/Pretty/Simple.hs +++ b/src/Text/Pretty/Simple.hs @@ -44,42 +44,56 @@ #endif import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Text.Lazy (Text, pack) +import Data.Text.Lazy.IO as LText import Text.Pretty.Simple.Internal (OutputOptions(..), UseColor(..), defaultOutputOptions, expressionParse, expressionsToOutputs, render) +------------------------------ +-- normal (color) functions -- +------------------------------ + pPrint :: (MonadIO m, Show a) => a -> m () pPrint = pPrintOpt defaultOutputOptions -pShow :: Show a => a -> String +pShow :: Show a => a -> Text pShow = pShowOpt defaultOutputOptions -pString :: String -> String +pString :: String -> Text pString = pStringOpt defaultOutputOptions +------------------------ +-- no-color functions -- +------------------------ + pPrintNoColor :: (MonadIO m, Show a) => a -> m () pPrintNoColor = pPrintOpt noColorOutputOptions -pShowNoColor :: Show a => a -> String +pShowNoColor :: Show a => a -> Text pShowNoColor = pShowOpt noColorOutputOptions -pStringNoColor :: String -> String +pStringNoColor :: String -> Text pStringNoColor = pStringOpt noColorOutputOptions noColorOutputOptions :: OutputOptions noColorOutputOptions = defaultOutputOptions {_useColor = NoColor} +--------------------------------- +-- functions that take options -- +--------------------------------- + pPrintOpt :: (MonadIO m, Show a) => OutputOptions -> a -> m () -pPrintOpt outputOptions = liftIO . putStrLn . pShowOpt outputOptions +pPrintOpt outputOptions = liftIO . LText.putStrLn . pShowOpt outputOptions -pShowOpt :: Show a => OutputOptions -> a -> String +pShowOpt :: Show a => OutputOptions -> a -> Text pShowOpt outputOptions = pStringOpt outputOptions . show -pStringOpt :: OutputOptions -> String -> String +pStringOpt :: OutputOptions -> String -> Text pStringOpt outputOptions string = case expressionParse string of - Left _ -> string + Left _ -> pack string Right expressions -> render outputOptions $ expressionsToOutputs expressions diff --git a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs b/src/Text/Pretty/Simple/Internal/OutputPrinter.hs --- a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs +++ b/src/Text/Pretty/Simple/Internal/OutputPrinter.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -30,6 +31,8 @@ import Data.Data (Data) import Data.Foldable (fold, foldlM) import Data.Semigroup ((<>)) +import Data.Text.Lazy (Text) +import Data.Text.Lazy.Builder (Builder, fromString, toLazyText) import Data.Typeable (Typeable) import GHC.Generics (Generic) import System.Console.ANSI @@ -62,43 +65,46 @@ defaultOutputOptions :: OutputOptions defaultOutputOptions = OutputOptions {_indentAmount = 4, _useColor = UseColor} -render :: OutputOptions -> [Output] -> String -render options outputs = runReader (renderOutputs outputs) options +render :: OutputOptions -> [Output] -> Text +render options outputs = toLazyText $ runReader (renderOutputs outputs) options renderOutputs :: forall m. MonadReader OutputOptions m - => [Output] -> m String + => [Output] -> m Builder renderOutputs = foldlM foldFunc "" . modificationsOutputList where - foldFunc :: String -> Output -> m String + foldFunc :: Builder -> Output -> m Builder foldFunc accum output = mappend accum <$> renderOutput output renderRaibowParenFor :: MonadReader OutputOptions m - => NestLevel -> String -> m String + => NestLevel -> Builder -> m Builder renderRaibowParenFor nest string = sequenceFold [rainbowParen nest, pure string, colorReset] -renderOutput :: MonadReader OutputOptions m => Output -> m String +renderOutput :: MonadReader OutputOptions m => Output -> m Builder renderOutput (Output nest OutputCloseBrace) = renderRaibowParenFor nest "}" renderOutput (Output nest OutputCloseBracket) = renderRaibowParenFor nest "]" renderOutput (Output nest OutputCloseParen) = renderRaibowParenFor nest ")" renderOutput (Output nest OutputComma) = renderRaibowParenFor nest "," renderOutput (Output _ OutputIndent) = do indentSpaces <- view indentAmount - pure $ replicate indentSpaces ' ' + pure . mconcat $ replicate indentSpaces " " renderOutput (Output _ OutputNewLine) = pure "\n" renderOutput (Output nest OutputOpenBrace) = renderRaibowParenFor nest "{" renderOutput (Output nest OutputOpenBracket) = renderRaibowParenFor nest "[" renderOutput (Output nest OutputOpenParen) = renderRaibowParenFor nest "(" -renderOutput (Output _ (OutputOther string)) = pure string +renderOutput (Output _ (OutputOther string)) = + -- TODO: This probably shouldn't be a string to begin with. + pure $ fromString string renderOutput (Output _ (OutputStringLit string)) = do sequenceFold [ colorQuote , pure "\"" , colorString - , pure string + -- TODO: This probably shouldn't be a string to begin with. + , pure $ fromString string , colorQuote , pure "\"" , colorReset @@ -156,27 +162,27 @@ -- High-level colors -- ----------------------- -colorQuote :: MonadReader OutputOptions m => m String +colorQuote :: MonadReader OutputOptions m => m Builder colorQuote = appendColors colorBold colorVividWhite -colorString :: MonadReader OutputOptions m => m String +colorString :: MonadReader OutputOptions m => m Builder colorString = appendColors colorBold colorVividBlue -colorError :: MonadReader OutputOptions m => m String +colorError :: MonadReader OutputOptions m => m Builder colorError = appendColors colorBold colorVividRed -colorNum :: MonadReader OutputOptions m => m String +colorNum :: MonadReader OutputOptions m => m Builder colorNum = appendColors colorBold colorVividGreen rainbowParen :: forall m. MonadReader OutputOptions m - => NestLevel -> m String + => NestLevel -> m Builder rainbowParen (NestLevel nestLevel) = let choicesLen = length rainbowParenChoices in rainbowParenChoices !! (nestLevel `mod` choicesLen) where - rainbowParenChoices :: [m String] + rainbowParenChoices :: [m Builder] rainbowParenChoices = [ appendColors colorBold colorVividMagenta , appendColors colorBold colorVividCyan @@ -201,36 +207,39 @@ True -> pure thenValue False -> pure elseValue -colorBold :: MonadReader OutputOptions m => m String -colorBold = ifM canUseColor (setSGRCode [SetConsoleIntensity BoldIntensity]) "" +colorBold :: MonadReader OutputOptions m => m Builder +colorBold = ifM canUseColor (setSGRCodeBuilder [SetConsoleIntensity BoldIntensity]) "" -colorReset :: MonadReader OutputOptions m => m String -colorReset = ifM canUseColor (setSGRCode [Reset]) "" +colorReset :: MonadReader OutputOptions m => m Builder +colorReset = ifM canUseColor (setSGRCodeBuilder [Reset]) "" -colorVividBlue :: MonadReader OutputOptions m => m String +colorVividBlue :: MonadReader OutputOptions m => m Builder colorVividBlue = colorHelper Vivid Blue -colorVividCyan :: MonadReader OutputOptions m => m String +colorVividCyan :: MonadReader OutputOptions m => m Builder colorVividCyan = colorHelper Vivid Cyan -colorVividGreen :: MonadReader OutputOptions m => m String +colorVividGreen :: MonadReader OutputOptions m => m Builder colorVividGreen = colorHelper Vivid Green -colorVividMagenta :: MonadReader OutputOptions m => m String +colorVividMagenta :: MonadReader OutputOptions m => m Builder colorVividMagenta = colorHelper Vivid Magenta -colorVividRed :: MonadReader OutputOptions m => m String +colorVividRed :: MonadReader OutputOptions m => m Builder colorVividRed = colorHelper Vivid Red -colorVividWhite :: MonadReader OutputOptions m => m String +colorVividWhite :: MonadReader OutputOptions m => m Builder colorVividWhite = colorHelper Vivid White -colorVividYellow :: MonadReader OutputOptions m => m String +colorVividYellow :: MonadReader OutputOptions m => m Builder colorVividYellow = colorHelper Vivid Yellow -colorHelper :: MonadReader OutputOptions m => ColorIntensity -> Color -> m String +colorHelper :: MonadReader OutputOptions m => ColorIntensity -> Color -> m Builder colorHelper colorIntensity color = - ifM canUseColor (setSGRCode [SetColor Foreground colorIntensity color]) "" + ifM canUseColor (setSGRCodeBuilder [SetColor Foreground colorIntensity color]) "" -appendColors :: MonadReader OutputOptions m => m String -> m String -> m String +appendColors :: MonadReader OutputOptions m => m Builder -> m Builder -> m Builder appendColors color1 color2 = mappend <$> color1 <*> color2 + +setSGRCodeBuilder :: [SGR] -> Builder +setSGRCodeBuilder = fromString . setSGRCode