diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ + +## 3.0.0.0 + +* pretty-simple now escapes non-printable characters by default. A field + called `outputOptionsEscapeNonPrintable` has been added to `OutputOptions` + to control this behavior. Implemented in + [#44](https://github.com/cdepillabout/pretty-simple/pull/44). Thanks + [dminuoso](https://github.com/dminuoso)! +* pretty-simple now checks the output `Handle` to determine whether to print + in color when using functions like `pPrint`. This makes it so that you + can redirect output to a file on disk and still be able to read the + output from `pPrint`! Implemented in + [#47](https://github.com/cdepillabout/pretty-simple/pull/47). Thanks + [metiulekm](https://github.com/metiulekm)! +* Add functions like `pHPrint` for specifying the `Handle` to output to. + Added in [#47](https://github.com/cdepillabout/pretty-simple/pull/47). + ## 2.2.0.1 * Fixed a [bug](https://github.com/cdepillabout/pretty-simple/pull/41) where the parser failed to parse escaped quotation marks in string literals. 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: 2.2.0.1 +version: 3.0.0.0 synopsis: pretty printer for data types with a 'Show' instance. description: Please see . homepage: https://github.com/cdepillabout/pretty-simple @@ -7,7 +7,7 @@ license-file: LICENSE author: Dennis Gosnell maintainer: cdep.illabout@gmail.com -copyright: 2017 Dennis Gosnell +copyright: 2017-2019 Dennis Gosnell category: Text build-type: Simple extra-source-files: CHANGELOG.md diff --git a/src/Debug/Pretty/Simple.hs b/src/Debug/Pretty/Simple.hs --- a/src/Debug/Pretty/Simple.hs +++ b/src/Debug/Pretty/Simple.hs @@ -16,6 +16,8 @@ module Debug.Pretty.Simple ( -- * Trace with color on dark background + -- This determines whether to print in color by looking at whether 'stderr' + -- is a TTY device. pTrace , pTraceId , pTraceShow @@ -28,6 +30,19 @@ , pTraceEventIO , pTraceMarker , pTraceMarkerIO + -- * Trace forcing color + , pTraceForceColor + , pTraceIdForceColor + , pTraceShowForceColor + , pTraceShowIdForceColor + , pTraceMForceColor + , pTraceShowMForceColor + , pTraceStackForceColor + , pTraceEventForceColor + , pTraceEventIOForceColor + , pTraceMarkerForceColor + , pTraceMarkerIOForceColor + , pTraceIOForceColor -- * Trace without color , pTraceNoColor , pTraceIdNoColor @@ -43,11 +58,17 @@ , pTraceIONoColor ) where -import Data.Text.Lazy (unpack) +import Control.Monad ((<=<)) +import Data.Text.Lazy (Text, unpack) import Debug.Trace (trace, traceEvent, traceEventIO, traceIO, traceM, traceMarker, traceMarkerIO, traceStack) -import Text.Pretty.Simple (pShow, pShowNoColor, pString, pStringNoColor) +import System.IO (stderr) +import System.IO.Unsafe (unsafePerformIO) +import Text.Pretty.Simple + (pShow, pShowNoColor, pString, pStringNoColor, pStringOpt, + defaultOutputOptionsDarkBg) +import Text.Pretty.Simple.Internal (hCheckTTY) #if __GLASGOW_HASKELL__ < 710 -- We don't need this import for GHC 7.10 as it exports all required functions @@ -62,7 +83,7 @@ @since 2.0.1.0 -} pTraceIO :: String -> IO () -pTraceIO = traceIO . unpack . pString +pTraceIO = traceIO . unpack <=< pStringTTYIO {-| The 'pTrace' function pretty prints the trace message given as its first @@ -80,7 +101,7 @@ @since 2.0.1.0 -} pTrace :: String -> a -> a -pTrace = trace . unpack . pString +pTrace = trace . unpack . pStringTTY {-| Like 'pTrace' but returns the message instead of a third value. @@ -106,7 +127,7 @@ @since 2.0.1.0 -} pTraceShow :: (Show a) => a -> b -> b -pTraceShow = trace . unpack . pShow +pTraceShow = trace . unpack . pShowTTY {-| Like 'pTraceShow' but returns the shown value instead of a third value. @@ -114,7 +135,7 @@ @since 2.0.1.0 -} pTraceShowId :: (Show a) => a -> a -pTraceShowId a = trace (unpack (pShow a)) a +pTraceShowId a = trace (unpack (pShowTTY a)) a {-| Like 'pTrace' but returning unit in an arbitrary 'Applicative' context. Allows @@ -140,7 +161,7 @@ #else pTraceM :: (Applicative f) => String -> f () #endif -pTraceM string = trace (unpack (pString string)) $ pure () +pTraceM string = trace (unpack (pStringTTY string)) $ pure () {-| Like 'pTraceM', but uses 'show' on the argument to convert it to a 'String'. @@ -158,7 +179,7 @@ #else pTraceShowM :: (Show a, Applicative f) => a -> f () #endif -pTraceShowM = traceM . unpack . pShow +pTraceShowM = traceM . unpack . pShowTTY {-| like 'pTrace', but additionally prints a call stack if one is @@ -173,7 +194,7 @@ @since 2.0.1.0 -} pTraceStack :: String -> a -> a -pTraceStack = traceStack . unpack . pString +pTraceStack = traceStack . unpack . pStringTTY {-| The 'pTraceEvent' function behaves like 'trace' with the difference that @@ -190,7 +211,7 @@ @since 2.0.1.0 -} pTraceEvent :: String -> a -> a -pTraceEvent = traceEvent . unpack . pString +pTraceEvent = traceEvent . unpack . pStringTTY {-| The 'pTraceEventIO' function emits a message to the eventlog, if eventlog @@ -202,7 +223,7 @@ @since 2.0.1.0 -} pTraceEventIO :: String -> IO () -pTraceEventIO = traceEventIO . unpack . pString +pTraceEventIO = traceEventIO . unpack <=< pStringTTYIO -- | The 'pTraceMarker' function emits a marker to the eventlog, if eventlog -- profiling is available and enabled at runtime. The @String@ is the name of @@ -218,7 +239,7 @@ -- -- @since 2.0.1.0 pTraceMarker :: String -> a -> a -pTraceMarker = traceMarker . unpack . pString +pTraceMarker = traceMarker . unpack . pStringTTY -- | The 'pTraceMarkerIO' function emits a marker to the eventlog, if eventlog -- profiling is available and enabled at runtime. @@ -228,9 +249,87 @@ -- -- @since 2.0.1.0 pTraceMarkerIO :: String -> IO () -pTraceMarkerIO = traceMarkerIO . unpack . pString +pTraceMarkerIO = traceMarkerIO . unpack <=< pStringTTYIO ------------------------------------------ +-- Helpers +------------------------------------------ + +pStringTTYIO :: String -> IO Text +pStringTTYIO v = do + realOutputOpts <- hCheckTTY stderr defaultOutputOptionsDarkBg + pure $ pStringOpt realOutputOpts v + +pStringTTY :: String -> Text +pStringTTY = unsafePerformIO . pStringTTYIO + +pShowTTYIO :: Show a => a -> IO Text +pShowTTYIO = pStringTTYIO . show + +pShowTTY :: Show a => a -> Text +pShowTTY = unsafePerformIO . pShowTTYIO + +------------------------------------------ +-- Traces forcing color +------------------------------------------ + +-- | Similar to 'pTrace', but forcing color. +pTraceForceColor :: String -> a -> a +pTraceForceColor = trace . unpack . pString + +-- | Similar to 'pTraceId', but forcing color. +pTraceIdForceColor :: String -> String +pTraceIdForceColor a = pTraceForceColor a a + +-- | Similar to 'pTraceShow', but forcing color. +pTraceShowForceColor :: (Show a) => a -> b -> b +pTraceShowForceColor = trace . unpack . pShow + +-- | Similar to 'pTraceShowId', but forcing color. +pTraceShowIdForceColor :: (Show a) => a -> a +pTraceShowIdForceColor a = trace (unpack (pShow a)) a + +-- | Similar to 'pTraceM', but forcing color. +#if __GLASGOW_HASKELL__ < 800 +pTraceMForceColor :: (Monad f) => String -> f () +#else +pTraceMForceColor :: (Applicative f) => String -> f () +#endif +pTraceMForceColor string = trace (unpack (pString string)) $ pure () + +-- | Similar to 'pTraceShowM', but forcing color. +#if __GLASGOW_HASKELL__ < 800 +pTraceShowMForceColor :: (Show a, Monad f) => a -> f () +#else +pTraceShowMForceColor :: (Show a, Applicative f) => a -> f () +#endif +pTraceShowMForceColor = traceM . unpack . pShow + +-- | Similar to 'pTraceStack', but forcing color. +pTraceStackForceColor :: String -> a -> a +pTraceStackForceColor = traceStack . unpack . pString + +-- | Similar to 'pTraceEvent', but forcing color. +pTraceEventForceColor :: String -> a -> a +pTraceEventForceColor = traceEvent . unpack . pString + +-- | Similar to 'pTraceEventIO', but forcing color. +pTraceEventIOForceColor :: String -> IO () +pTraceEventIOForceColor = traceEventIO . unpack . pString + +-- | Similar to 'pTraceMarker', but forcing color. +pTraceMarkerForceColor :: String -> a -> a +pTraceMarkerForceColor = traceMarker . unpack . pString + +-- | Similar to 'pTraceMarkerIO', but forcing color. +pTraceMarkerIOForceColor :: String -> IO () +pTraceMarkerIOForceColor = traceMarkerIO . unpack . pString + +-- | Similar to 'pTraceIO', but forcing color. +pTraceIOForceColor :: String -> IO () +pTraceIOForceColor = traceIO . unpack . pString + +------------------------------------------ -- Traces without color ------------------------------------------ @@ -300,7 +399,7 @@ #else pTraceMNoColor :: (Applicative f) => String -> f () #endif -pTraceMNoColor string = trace (unpack (pString string)) $ pure () +pTraceMNoColor string = trace (unpack (pStringNoColor string)) $ pure () -- | Similar to 'pTraceShowM', but without color. -- 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 @@ -39,22 +39,33 @@ ( -- * Output with color on dark background pPrint + , pHPrint + , pPrintForceColor + , pHPrintForceColor , pShow , pString -- * Aliases for output with color on dark background , pPrintDarkBg + , pHPrintDarkBg + , pPrintForceColorDarkBg + , pHPrintForceColorDarkBg , pShowDarkBg , pStringDarkBg -- * Output with color on light background , pPrintLightBg + , pHPrintLightBg + , pPrintForceColorLightBg + , pHPrintForceColorLightBg , pShowLightBg , pStringLightBg -- * Output with NO color , pPrintNoColor + , pHPrintNoColor , pShowNoColor , pStringNoColor -- * Output With 'OutputOptions' , pPrintOpt + , pHPrintOpt , pShowOpt , pStringOpt -- * 'OutputOptions' @@ -62,6 +73,7 @@ , defaultOutputOptionsDarkBg , defaultOutputOptionsLightBg , defaultOutputOptionsNoColor + , CheckColorTty(..) -- * 'ColorOptions' -- $colorOptions , defaultColorOptionsDarkBg @@ -78,15 +90,19 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Foldable (toList) -import Data.Text.Lazy (Text, pack, unpack) +import Data.Text.Lazy (Text) import Data.Text.Lazy.IO as LText +import System.IO (Handle, stdout) import Text.Pretty.Simple.Internal - (OutputOptions(..), defaultColorOptionsDarkBg, + (CheckColorTty(..), OutputOptions(..), defaultColorOptionsDarkBg, defaultColorOptionsLightBg, defaultOutputOptionsDarkBg, defaultOutputOptionsLightBg, defaultOutputOptionsNoColor, - expressionParse, expressionsToOutputs, render) + hCheckTTY, expressionParse, expressionsToOutputs, render) +-- $setup +-- >>> import Data.Text.Lazy (unpack) + ---------------------------------------------------------- -- functions for printing in color to a dark background -- ---------------------------------------------------------- @@ -100,12 +116,30 @@ -- pPrint :: Show a => a -> IO () -- @ -- --- This function is for printing to a dark background. +-- This function will only use colors if it detects it's printing to a TTY. +-- +-- This function is for printing to a dark background. Use 'pPrintLightBg' for +-- printing to a terminal with a light background. Different colors are used. +-- +-- Prints to 'stdout'. Use 'pHPrint' to print to a different 'Handle'. pPrint :: (MonadIO m, Show a) => a -> m () -pPrint = pPrintOpt defaultOutputOptionsDarkBg +pPrint = pPrintOpt CheckColorTty defaultOutputOptionsDarkBg --- | Similar to 'pPrint', but just return the resulting pretty-printed data --- type as a 'Text' instead of printing it to the screen. +-- | Similar to 'pPrint', but take a 'Handle' to print to. +pHPrint :: (MonadIO m, Show a) => Handle -> a -> m () +pHPrint = pHPrintOpt CheckColorTty defaultOutputOptionsDarkBg + +-- | Similar to 'pPrint', but print in color regardless of whether the output +-- goes to a TTY or not. +pPrintForceColor :: (MonadIO m, Show a) => a -> m () +pPrintForceColor = pPrintOpt NoCheckColorTty defaultOutputOptionsDarkBg + +-- | Similar to 'pPrintForceColor', but take a 'Handle' to print to. +pHPrintForceColor :: (MonadIO m, Show a) => Handle -> a -> m () +pHPrintForceColor = pHPrintOpt NoCheckColorTty defaultOutputOptionsDarkBg + +-- | Similar to 'pPrintForceColor', but just return the resulting pretty-printed +-- data type as a 'Text' instead of printing it to the screen. -- -- This function is for printing to a dark background. pShow :: Show a => a -> Text @@ -131,6 +165,18 @@ pPrintDarkBg :: (MonadIO m, Show a) => a -> m () pPrintDarkBg = pPrint +-- | Alias for 'pHPrint'. +pHPrintDarkBg :: (MonadIO m, Show a) => Handle -> a -> m () +pHPrintDarkBg = pHPrint + +-- | Alias for 'pPrintForceColor'. +pPrintForceColorDarkBg :: (MonadIO m, Show a) => a -> m () +pPrintForceColorDarkBg = pPrintForceColor + +-- | Alias for 'pHPrintForceColor'. +pHPrintForceColorDarkBg :: (MonadIO m, Show a) => Handle -> a -> m () +pHPrintForceColorDarkBg = pHPrintForceColor + -- | Alias for 'pShow'. pShowDarkBg :: Show a => a -> Text pShowDarkBg = pShow @@ -145,8 +191,22 @@ -- | Just like 'pPrintDarkBg', but for printing to a light background. pPrintLightBg :: (MonadIO m, Show a) => a -> m () -pPrintLightBg = pPrintOpt defaultOutputOptionsLightBg +pPrintLightBg = pPrintOpt CheckColorTty defaultOutputOptionsLightBg +-- | Just like 'pHPrintDarkBg', but for printing to a light background. +pHPrintLightBg :: (MonadIO m, Show a) => Handle -> a -> m () +pHPrintLightBg = pHPrintOpt CheckColorTty defaultOutputOptionsLightBg + +-- | Just like 'pPrintForceColorDarkBg', but for printing to a light +-- background. +pPrintForceColorLightBg :: (MonadIO m, Show a) => a -> m () +pPrintForceColorLightBg = pPrintOpt NoCheckColorTty defaultOutputOptionsLightBg + +-- | Just like 'pHPrintForceColorDarkBg', but for printing to a light +-- background. +pHPrintForceColorLightBg :: (MonadIO m, Show a) => Handle -> a -> m () +pHPrintForceColorLightBg = pHPrintOpt NoCheckColorTty defaultOutputOptionsLightBg + -- | Just like 'pShowDarkBg', but for printing to a light background. pShowLightBg :: Show a => a -> Text pShowLightBg = pShowOpt defaultOutputOptionsLightBg @@ -168,8 +228,12 @@ -- , "bye" -- ] pPrintNoColor :: (MonadIO m, Show a) => a -> m () -pPrintNoColor = pPrintOpt defaultOutputOptionsNoColor +pPrintNoColor = pPrintOpt NoCheckColorTty defaultOutputOptionsNoColor +-- | Like 'pPrintNoColor', but take a 'Handle' to determine where to print to. +pHPrintNoColor :: (MonadIO m, Show a) => Handle -> a -> m () +pHPrintNoColor = pHPrintOpt NoCheckColorTty defaultOutputOptionsNoColor + -- | Like 'pShow', but without color. pShowNoColor :: Show a => a -> Text pShowNoColor = pShowOpt defaultOutputOptionsNoColor @@ -190,7 +254,7 @@ -- -- This is what the normal indentation looks like: -- --- >>> pPrintOpt defaultOutputOptionsNoColor $ Just ("hello", "bye") +-- >>> pPrintOpt NoCheckColorTty defaultOutputOptionsNoColor $ Just ("hello", "bye") -- Just -- ( "hello" -- , "bye" @@ -199,7 +263,7 @@ -- This is what smaller indentation looks like: -- -- >>> let smallIndent = defaultOutputOptionsNoColor {outputOptionsIndentAmount = 1} --- >>> pPrintOpt smallIndent $ Just ("hello", "bye") +-- >>> pPrintOpt CheckColorTty smallIndent $ Just ("hello", "bye") -- Just -- ( "hello" -- , "bye" @@ -207,7 +271,7 @@ -- -- Lines in strings get indented -- --- >>> pPrintOpt defaultOutputOptionsNoColor (1, (2, "foo\nbar\nbaz", 3)) +-- >>> pPrintOpt NoCheckColorTty defaultOutputOptionsNoColor (1, (2, "foo\nbar\nbaz", 3)) -- ( 1 -- , -- ( 2 @@ -222,7 +286,7 @@ -- -- >>> data Foo = Foo -- >>> instance Show Foo where show _ = "foo\nbar\nbaz" --- >>> pPrintOpt defaultOutputOptionsNoColor (1, (2, Foo, 3)) +-- >>> pPrintOpt CheckColorTty defaultOutputOptionsNoColor (1, (2, Foo, 3)) -- ( 1 -- , -- ( 2 @@ -232,9 +296,39 @@ -- , 3 -- ) -- ) +-- +-- 'CheckColorTty' determines whether to test 'stdout' for whether or not it is +-- connected to a TTY. +-- +-- If set to 'NoCheckColorTty', then 'pPrintOpt' won't +-- check if 'stdout' is a TTY. It will print in color depending on the value +-- of 'outputOptionsColorOptions'. +-- +-- If set to 'CheckColorTty', then 'pPrintOpt' will check if 'stdout' is +-- conneted to a TTY. If 'stdout' is determined to be connected to a TTY, then +-- it will print in color depending on the value of +-- 'outputOptionsColorOptions'. If 'stdout' is determined to NOT be connected +-- to a TTY, then it will NOT print in color, regardless of the value of +-- 'outputOptionsColorOptions'. +pPrintOpt :: (MonadIO m, Show a) => CheckColorTty -> OutputOptions -> a -> m () +pPrintOpt checkColorTty outputOptions = + pHPrintOpt checkColorTty outputOptions stdout -pPrintOpt :: (MonadIO m, Show a) => OutputOptions -> a -> m () -pPrintOpt outputOptions = liftIO . LText.putStrLn . pShowOpt outputOptions +-- | Similar to 'pPrintOpt', but take a 'Handle' to determine where to print +-- to. +pHPrintOpt :: + (MonadIO m, Show a) + => CheckColorTty + -> OutputOptions + -> Handle + -> a + -> m () +pHPrintOpt checkColorTty outputOptions handle a = do + realOutputOpts <- + case checkColorTty of + CheckColorTty -> hCheckTTY handle outputOptions + NoCheckColorTty -> pure outputOptions + liftIO $ LText.hPutStrLn handle $ pShowOpt realOutputOpts a -- | Like 'pShow' but takes 'OutputOptions' to change how the -- pretty-printing is done. @@ -244,7 +338,8 @@ -- | Like 'pString' but takes 'OutputOptions' to change how the -- pretty-printing is done. pStringOpt :: OutputOptions -> String -> Text -pStringOpt outputOptions = render outputOptions . toList . expressionsToOutputs . expressionParse +pStringOpt outputOptions = + render outputOptions . toList . expressionsToOutputs . expressionParse -- $colorOptions -- @@ -256,22 +351,16 @@ -- Here are some examples of using 'pPrint' on different data types. You can -- look at these examples to get an idea of what 'pPrint' will output. -- --- The following examples are all using 'pPrintNoColor' instead of 'pPrint' --- because their output is being checked using --- . 'pPrint' outputs ANSI --- escape codes in order to produce color, so the following examples would be --- hard to read had 'pPrint' been used. --- -- __Simple Haskell data type__ -- -- >>> data Foo a = Foo a String deriving Show -- --- >>> pPrintNoColor $ Foo 3 "hello" +-- >>> pPrint $ Foo 3 "hello" -- Foo 3 "hello" -- -- __List__ -- --- >>> pPrintNoColor $ [1,2,3] +-- >>> pPrint $ [1,2,3] -- [ 1 -- , 2 -- , 3 @@ -279,14 +368,14 @@ -- -- __Slightly more complicated list__ -- --- >>> pPrintNoColor $ [ Foo [ (), () ] "hello" ] +-- >>> pPrint $ [ Foo [ (), () ] "hello" ] -- [ Foo -- [ () -- , () -- ] "hello" -- ] -- --- >>> pPrintNoColor $ [ Foo [ "bar", "baz" ] "hello", Foo [] "bye" ] +-- >>> pPrint $ [ Foo [ "bar", "baz" ] "hello", Foo [] "bye" ] -- [ Foo -- [ "bar" -- , "baz" @@ -304,7 +393,7 @@ -- } deriving Show -- :} -- --- >>> pPrintNoColor $ Bar 1 [10, 11] [Foo 1.1 "", Foo 2.2 "hello"] +-- >>> pPrint $ Bar 1 [10, 11] [Foo 1.1 "", Foo 2.2 "hello"] -- Bar -- { barInt = 1 -- , barA = @@ -321,7 +410,7 @@ -- -- >>> newtype Baz = Baz { unBaz :: [String] } deriving Show -- --- >>> pPrintNoColor $ Baz ["hello", "bye"] +-- >>> pPrint $ Baz ["hello", "bye"] -- Baz -- { unBaz = -- [ "hello" @@ -333,20 +422,20 @@ -- -- >>> data Foo = A | B Foo | C [Foo] [Foo] deriving Show -- --- >>> pPrintNoColor $ B ( B A ) +-- >>> pPrint $ B ( B A ) -- B ( B A ) -- --- >>> pPrintNoColor $ B ( B ( B A ) ) +-- >>> pPrint $ B ( B ( B A ) ) -- B -- ( B ( B A ) ) -- --- >>> pPrintNoColor $ B ( B ( B ( B A ) ) ) +-- >>> pPrint $ B ( B ( B ( B A ) ) ) -- B -- ( B -- ( B ( B A ) ) -- ) -- --- >>> pPrintNoColor $ B ( C [A, A] [B A, B (B (B A))] ) +-- >>> pPrint $ B ( C [A, A] [B A, B (B (B A))] ) -- B -- ( C -- [ A @@ -365,7 +454,7 @@ -- -- __Unicode__ -- --- >>> pPrintNoColor $ Baz ["猫", "犬", "ヤギ"] +-- >>> pPrint $ Baz ["猫", "犬", "ヤギ"] -- Baz -- { unBaz = -- [ "猫" @@ -376,9 +465,14 @@ -- -- __Other__ -- --- Making sure the spacing after a string is correct +-- Making sure the spacing after a string is correct. -- -- >>> data Foo = Foo String Int deriving Show -- --- >>> pPrintNoColor $ Foo "bar" 0 +-- >>> pPrint $ Foo "bar" 0 -- Foo "bar" 0 +-- +-- Non-printable characters will get escaped. +-- +-- >>> pPrint "this string has non-printable characters: \x8 and \x9" +-- "this string has non-printable characters: \x8 and \x9" diff --git a/src/Text/Pretty/Simple/Internal/ExprParser.hs b/src/Text/Pretty/Simple/Internal/ExprParser.hs --- a/src/Text/Pretty/Simple/Internal/ExprParser.hs +++ b/src/Text/Pretty/Simple/Internal/ExprParser.hs @@ -60,7 +60,7 @@ parseStringLit ('"':rest) = ("", rest) parseStringLit ('\\':c:cs) = ('\\':c:cs', rest) where (cs', rest) = parseStringLit cs -parseStringLit (c:cs) = (c:cs', rest) +parseStringLit (c:cs) = (c:cs', rest) where (cs', rest) = parseStringLit cs parseOther :: String -> (String, String) diff --git a/src/Text/Pretty/Simple/Internal/ExprToOutput.hs b/src/Text/Pretty/Simple/Internal/ExprToOutput.hs --- a/src/Text/Pretty/Simple/Internal/ExprToOutput.hs +++ b/src/Text/Pretty/Simple/Internal/ExprToOutput.hs @@ -143,7 +143,7 @@ isMultiLine (Braces commaSeparated) = isMultiLine' commaSeparated isMultiLine (Parens commaSeparated) = isMultiLine' commaSeparated isMultiLine _ = (False, False) - + isMultiLine' (CommaSeparated []) = (False, False) isMultiLine' (CommaSeparated [es]) = (True, fst $ thisAndNextMulti es) isMultiLine' _ = (True, True) @@ -215,7 +215,7 @@ modify (\printState -> printState {currLine = currLine printState + diff}) putExpression :: MonadState PrinterState m => Expr -> m [Output] -putExpression (Brackets commaSeparated) = +putExpression (Brackets commaSeparated) = putSurroundExpr OutputOpenBracket OutputCloseBracket commaSeparated putExpression (Braces commaSeparated) = putSurroundExpr OutputOpenBrace OutputCloseBrace commaSeparated 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 @@ -26,7 +26,10 @@ import Control.Applicative #endif -import Control.Monad.Reader (MonadReader(reader), runReader) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader(ask, reader), runReader) +import Data.Char (isPrint, ord) +import Numeric (showHex) import Data.Foldable (fold) import Data.Text.Lazy (Text) import Data.Text.Lazy.Builder (Builder, fromString, toLazyText) @@ -35,6 +38,7 @@ import Data.Maybe (fromMaybe) import Text.Read (readMaybe) import GHC.Generics (Generic) +import System.IO (Handle, hIsTerminalDevice) import Text.Pretty.Simple.Internal.Color (ColorOptions(..), colorReset, defaultColorOptionsDarkBg, @@ -42,6 +46,21 @@ import Text.Pretty.Simple.Internal.Output (NestLevel(..), Output(..), OutputType(..)) +-- | Determines whether pretty-simple should check if the output 'Handle' is a +-- TTY device. Normally, users only want to print in color if the output +-- 'Handle' is a TTY device. +data CheckColorTty + = CheckColorTty + -- ^ Check if the output 'Handle' is a TTY device. If the output 'Handle' is + -- a TTY device, determine whether to print in color based on + -- 'outputOptionsColorOptions'. If not, then set 'outputOptionsColorOptions' + -- to 'Nothing' so the output does not get colorized. + | NoCheckColorTty + -- ^ Don't check if the output 'Handle' is a TTY device. Determine whether to + -- colorize the output based solely on the value of + -- 'outputOptionsColorOptions'. + deriving (Eq, Generic, Show, Typeable) + -- | Data-type wrapping up all the options available when rendering the list -- of 'Output's. data OutputOptions = OutputOptions @@ -51,6 +70,10 @@ , outputOptionsColorOptions :: Maybe ColorOptions -- ^ If this is 'Nothing', then don't colorize the output. If this is -- @'Just' colorOptions@, then use @colorOptions@ to colorize the output. + -- + , outputOptionsEscapeNonPrintable :: Bool + -- ^ Whether to replace non-printable characters with hexadecimal escape + -- sequences. } deriving (Eq, Generic, Show, Typeable) -- | Default values for 'OutputOptions' when printing to a console with a dark @@ -61,6 +84,7 @@ OutputOptions { outputOptionsIndentAmount = 4 , outputOptionsColorOptions = Just defaultColorOptionsDarkBg + , outputOptionsEscapeNonPrintable = True } -- | Default values for 'OutputOptions' when printing to a console with a light @@ -71,6 +95,7 @@ OutputOptions { outputOptionsIndentAmount = 4 , outputOptionsColorOptions = Just defaultColorOptionsLightBg + , outputOptionsEscapeNonPrintable = True } -- | Default values for 'OutputOptions' when printing using using ANSI escape @@ -79,8 +104,23 @@ defaultOutputOptionsNoColor :: OutputOptions defaultOutputOptionsNoColor = OutputOptions - {outputOptionsIndentAmount = 4, outputOptionsColorOptions = Nothing} + { outputOptionsIndentAmount = 4 + , outputOptionsColorOptions = Nothing + , outputOptionsEscapeNonPrintable = True + } +-- | Given 'OutputOptions', disable colorful output if the given handle +-- is not connected to a TTY. +hCheckTTY :: MonadIO m => Handle -> OutputOptions -> m OutputOptions +hCheckTTY h options = liftIO $ conv <$> tty + where + conv :: Bool -> OutputOptions + conv True = options + conv False = options { outputOptionsColorOptions = Nothing } + + tty :: IO Bool + tty = hIsTerminalDevice h + -- | Given 'OutputOptions' and a list of 'Output', turn the 'Output' into a -- lazy 'Text'. render :: OutputOptions -> [Output] -> Text @@ -109,8 +149,7 @@ -- TODO: This probably shouldn't be a string to begin with. pure $ fromString $ indentSubsequentLinesWith spaces string renderOutput (Output _ (OutputStringLit string)) = do - indentSpaces <- reader outputOptionsIndentAmount - let spaces = replicate (indentSpaces + 2) ' ' + options <- ask sequenceFold [ useColorQuote @@ -118,14 +157,52 @@ , useColorReset , useColorString -- TODO: This probably shouldn't be a string to begin with. - , pure $ fromString $ indentSubsequentLinesWith spaces $ readStr string + , pure (fromString (process options string)) , useColorReset , useColorQuote , pure "\"" , useColorReset ] - where readStr s = fromMaybe s . readMaybe $ '"':s ++ "\"" + where + process :: OutputOptions -> String -> String + process opts = + if outputOptionsEscapeNonPrintable opts + then indentSubsequentLinesWith spaces . escapeNonPrintable . readStr + else indentSubsequentLinesWith spaces . readStr + where + spaces :: String + spaces = replicate (indentSpaces + 2) ' ' + indentSpaces :: Int + indentSpaces = outputOptionsIndentAmount opts + + readStr :: String -> String + readStr s = fromMaybe s . readMaybe $ '"':s ++ "\"" + +-- | Replace non-printable characters with hex escape sequences. +-- +-- >>> escapeNonPrintable "\x1\x2" +-- "\\x1\\x2" +-- +-- Newlines will not be escaped. +-- +-- >>> escapeNonPrintable "hello\nworld" +-- "hello\nworld" +-- +-- Printable characters will not be escaped. +-- +-- >>> escapeNonPrintable "h\101llo" +-- "hello" +escapeNonPrintable :: String -> String +escapeNonPrintable input = foldr escape "" input + +-- Replace an unprintable character except a newline +-- with a hex escape sequence. +escape :: Char -> ShowS +escape c + | isPrint c || c == '\n' = (c:) + | otherwise = ('\\':) . ('x':) . showHex (ord c) + -- | -- >>> indentSubsequentLinesWith " " "aaa" -- "aaa" @@ -139,7 +216,6 @@ indentSubsequentLinesWith indent input = intercalate "\n" $ (start ++) $ map (indent ++) $ end where (start, end) = splitAt 1 $ lines input - -- | Produce a 'Builder' corresponding to the ANSI escape sequence for the -- color for the @\"@, based on whether or not 'outputOptionsColorOptions' is