diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,24 +1,24 @@ -Copyright (c) 2015-2019, Stack contributors -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 Stack nor the - names of its 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 STACK 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. +Copyright (c) 2015-2023, Stack contributors +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 Stack nor the + names of its 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 STACK 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/rio-prettyprint.cabal b/rio-prettyprint.cabal --- a/rio-prettyprint.cabal +++ b/rio-prettyprint.cabal @@ -1,50 +1,50 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.35.0. --- --- see: https://github.com/sol/hpack - -name: rio-prettyprint -version: 0.1.4.0 -synopsis: Pretty-printing for RIO -description: Combine RIO's log capabilities with pretty printing -category: Development -homepage: https://github.com/commercialhaskell/rio-prettyprint#readme -bug-reports: https://github.com/commercialhaskell/rio-prettyprint/issues -author: Michael Snoyman -maintainer: michael@snoyman.com -copyright: 2018-2019 FP Complete -license: BSD3 -license-file: LICENSE -build-type: Simple - -source-repository head - type: git - location: https://github.com/commercialhaskell/rio-prettyprint - -library - exposed-modules: - RIO.PrettyPrint - RIO.PrettyPrint.DefaultStyles - RIO.PrettyPrint.PrettyException - RIO.PrettyPrint.Simple - RIO.PrettyPrint.StylesUpdate - RIO.PrettyPrint.Types - Text.PrettyPrint.Leijen.Extended - other-modules: - Paths_rio_prettyprint - hs-source-dirs: - src/ - build-depends: - Cabal - , aeson - , annotated-wl-pprint - , ansi-terminal >=0.9 - , array - , base >=4.10 && <5 - , colour - , mtl - , path - , rio - , text - default-language: Haskell2010 +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.4. +-- +-- see: https://github.com/sol/hpack + +name: rio-prettyprint +version: 0.1.5.0 +synopsis: Pretty-printing for RIO +description: Combine RIO's log capabilities with pretty printing +category: Development +homepage: https://github.com/commercialhaskell/rio-prettyprint#readme +bug-reports: https://github.com/commercialhaskell/rio-prettyprint/issues +author: Michael Snoyman +maintainer: michael@snoyman.com +copyright: 2018-2019 FP Complete +license: BSD3 +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/commercialhaskell/rio-prettyprint + +library + exposed-modules: + RIO.PrettyPrint + RIO.PrettyPrint.DefaultStyles + RIO.PrettyPrint.PrettyException + RIO.PrettyPrint.Simple + RIO.PrettyPrint.StylesUpdate + RIO.PrettyPrint.Types + Text.PrettyPrint.Leijen.Extended + other-modules: + Paths_rio_prettyprint + hs-source-dirs: + src/ + build-depends: + Cabal + , aeson + , annotated-wl-pprint + , ansi-terminal >=0.9 + , array + , base >=4.10 && <5 + , colour + , mtl + , path >0.9.1 + , rio + , text + default-language: Haskell2010 diff --git a/src/RIO/PrettyPrint.hs b/src/RIO/PrettyPrint.hs --- a/src/RIO/PrettyPrint.hs +++ b/src/RIO/PrettyPrint.hs @@ -1,215 +1,271 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} - -module RIO.PrettyPrint - ( - -- * Type classes for optionally colored terminal output - HasTerm (..), HasStylesUpdate (..) - -- * Pretty printing functions - , displayPlain, displayWithColor - -- * Logging based on pretty-print typeclass - , prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent - , prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL - , prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS - -- * Semantic styling functions - -- | These are used rather than applying colors or other styling directly, - -- to provide consistency. - , style - , displayMilliseconds - , logLevelToStyle - -- * Formatting utils - , bulletedList - , mkNarrativeList - , spacedBulletedList - , debugBracket - -- * Re-exports from "Text.PrettyPrint.Leijen.Extended" - , Pretty (..), StyleDoc (..), StyleAnn (..) - , nest, line, linebreak, group, softline, softbreak - , align, hang, indent, encloseSep - , (<+>) - , hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate - , fill, fillBreak - , enclose, squotes, dquotes, parens, angles, braces, brackets - , string - , indentAfterLabel, wordDocs, flow - -- * Re-exports from "RIO.PrettyPrint.Types.PrettyPrint" - , Style (..) - ) where - -import Data.List (intersperse) -import RIO -import RIO.PrettyPrint.StylesUpdate (HasStylesUpdate (..)) -import RIO.PrettyPrint.Types (Style (..)) -import Text.PrettyPrint.Leijen.Extended (Pretty (pretty), - StyleAnn (..), StyleDoc, (<+>), align, - angles, braces, brackets, cat, - displayAnsi, displayPlain, dquotes, enclose, encloseSep, - fill, fillBreak, fillCat, fillSep, group, hang, hcat, hsep, - indent, line, linebreak, - nest, parens, punctuate, sep, softbreak, softline, squotes, - string, styleAnn, vcat, vsep) - -class (HasLogFunc env, HasStylesUpdate env) => HasTerm env where - useColorL :: Lens' env Bool - termWidthL :: Lens' env Int - -displayWithColor - :: (HasTerm env, Pretty a, MonadReader env m, HasCallStack) - => a -> m Utf8Builder -displayWithColor x = do - useAnsi <- view useColorL - termWidth <- view termWidthL - (if useAnsi then displayAnsi else displayPlain) termWidth x - --- TODO: switch to using implicit callstacks once 7.8 support is dropped - -prettyWith :: (HasTerm env, HasCallStack, Pretty b, - MonadReader env m, MonadIO m) - => LogLevel -> (a -> b) -> a -> m () -prettyWith level f = logGeneric "" level . RIO.display <=< displayWithColor . f - --- Note: I think keeping this section aligned helps spot errors, might be --- worth keeping the alignment in place. - -prettyDebugWith, prettyInfoWith, prettyNoteWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith - :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) - => (a -> StyleDoc) -> a -> m () -prettyDebugWith = prettyWith LevelDebug -prettyInfoWith = prettyWith LevelInfo -prettyNoteWith f = prettyWith LevelInfo - ((line <>) . (style Good "Note:" <+>) . - indentAfterLabel . f) -prettyWarnWith f = prettyWith LevelWarn - ((line <>) . (style Warning "Warning:" <+>) . - indentAfterLabel . f) -prettyErrorWith f = prettyWith LevelError - ((line <>) . (style Error "Error:" <+>) . - indentAfterLabel . f) -prettyWarnNoIndentWith f = prettyWith LevelWarn - ((line <>) . (style Warning "Warning:" <+>) . f) -prettyErrorNoIndentWith f = prettyWith LevelError - ((line <>) . (style Error "Error:" <+>) . f) - -prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent - :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) - => StyleDoc -> m () -prettyDebug = prettyDebugWith id -prettyInfo = prettyInfoWith id -prettyNote = prettyNoteWith id -prettyWarn = prettyWarnWith id -prettyError = prettyErrorWith id -prettyWarnNoIndent = prettyWarnNoIndentWith id -prettyErrorNoIndent = prettyErrorNoIndentWith id - -prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL - :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) - => [StyleDoc] -> m () -prettyDebugL = prettyDebugWith fillSep -prettyInfoL = prettyInfoWith fillSep -prettyNoteL = prettyNoteWith fillSep -prettyWarnL = prettyWarnWith fillSep -prettyErrorL = prettyErrorWith fillSep -prettyWarnNoIndentL = prettyWarnNoIndentWith fillSep -prettyErrorNoIndentL = prettyErrorNoIndentWith fillSep - -prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS - :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) - => String -> m () -prettyDebugS = prettyDebugWith flow -prettyInfoS = prettyInfoWith flow -prettyNoteS = prettyNoteWith flow -prettyWarnS = prettyWarnWith flow -prettyErrorS = prettyErrorWith flow -prettyWarnNoIndentS = prettyWarnNoIndentWith flow -prettyErrorNoIndentS = prettyErrorNoIndentWith flow - --- End of aligned section - --- | Use after a label and before the rest of what's being labelled for --- consistent spacing/indenting/etc. --- --- For example this is used after "Warning:" in warning messages. -indentAfterLabel :: StyleDoc -> StyleDoc -indentAfterLabel = align - --- | Make a 'Doc' from each word in a 'String' -wordDocs :: String -> [StyleDoc] -wordDocs = map fromString . words - --- | Wordwrap a 'String' -flow :: String -> StyleDoc -flow = fillSep . wordDocs - -debugBracket :: (HasCallStack, HasTerm env, MonadReader env m, - MonadIO m, MonadUnliftIO m) => StyleDoc -> m a -> m a -debugBracket msg f = do - let output = logDebug . RIO.display <=< displayWithColor - output $ "Start: " <> msg - start <- getMonotonicTime - x <- f `catch` \ex -> do - end <- getMonotonicTime - let diff = end - start - output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+> - msg <> line <> - "Exception thrown: " <> fromString (show ex) - throwIO (ex :: SomeException) - end <- getMonotonicTime - let diff = end - start - output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg - return x - --- |Annotate a 'StyleDoc' with a 'Style'. -style :: Style -> StyleDoc -> StyleDoc -style = styleAnn - --- Display milliseconds. -displayMilliseconds :: Double -> StyleDoc -displayMilliseconds t = style Good $ - fromString (show (round (t * 1000) :: Int)) <> "ms" - --- | Display a bulleted list of 'StyleDoc'. -bulletedList :: [StyleDoc] -> StyleDoc -bulletedList = mconcat . intersperse line . map (("*" <+>) . align) - --- | A helper function to yield a narrative list from a list of items, with a --- final fullstop. For example, helps produce the output --- @\"apple, ball and cat.\"@ (no serial comma) or @\"apple, ball, and cat.\"@ --- (serial comma) from @[\"apple\", \"ball\", \"cat\"]@. --- --- @since 0.1.4.0 -mkNarrativeList :: Pretty a - => Maybe Style - -- ^ Style the items in the list? - -> Bool - -- ^ Use a serial comma? - -> [a] - -> [StyleDoc] -mkNarrativeList _ _ [] = [] -mkNarrativeList mStyle _ [x] = [maybe id style mStyle (pretty x) <> "."] -mkNarrativeList mStyle useSerialComma [x1, x2] = - mStyle' (pretty x1) <> (if useSerialComma then "," else mempty) - : "and" - : mkNarrativeList mStyle useSerialComma [x2] - where - mStyle' = maybe id style mStyle -mkNarrativeList mStyle useSerialComma (x:xs) = - maybe id style mStyle (pretty x) <> "," - : mkNarrativeList mStyle useSerialComma xs - --- | Display a bulleted list of 'StyleDoc' with a blank line between --- each. -spacedBulletedList :: [StyleDoc] -> StyleDoc -spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align) - --- | The 'Style' intended to be associated with a 'LogLevel'. --- --- @since 0.1.1.0 -logLevelToStyle :: LogLevel -> Style -logLevelToStyle level = case level of - LevelDebug -> Debug - LevelInfo -> Info - LevelWarn -> Warning - LevelError -> Error - LevelOther _ -> OtherLevel +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module RIO.PrettyPrint + ( + -- * Type classes for optionally colored terminal output + HasTerm (..) + , HasStylesUpdate (..) + -- * Pretty printing functions + , displayPlain + , displayWithColor + -- * Logging based on pretty-print typeclass + , prettyDebug + , prettyInfo + , prettyNote + , prettyWarn + , prettyError + , prettyWarnNoIndent + , prettyErrorNoIndent + , prettyDebugL + , prettyInfoL + , prettyNoteL + , prettyWarnL + , prettyErrorL + , prettyWarnNoIndentL + , prettyErrorNoIndentL + , prettyDebugS + , prettyInfoS + , prettyNoteS + , prettyWarnS + , prettyErrorS + , prettyWarnNoIndentS + , prettyErrorNoIndentS + -- * Semantic styling functions + -- | These are used rather than applying colors or other styling directly, + -- to provide consistency. + , style + , displayMilliseconds + , logLevelToStyle + -- * Formatting utils + , bulletedList + , mkNarrativeList + , spacedBulletedList + , debugBracket + -- * Re-exports from "Text.PrettyPrint.Leijen.Extended" + , Pretty (..) + , StyleDoc (..) + , StyleAnn (..) + , nest + , line + , linebreak + , group + , softline + , softbreak + , align + , hang + , indent + , encloseSep + , (<+>) + , hsep + , vsep + , fillSep + , sep + , hcat + , vcat + , fillCat + , cat + , punctuate + , fill + , fillBreak + , enclose + , squotes + , dquotes + , parens + , angles + , braces + , brackets + , string + , indentAfterLabel + , wordDocs + , flow + -- * Re-exports from "RIO.PrettyPrint.Types.PrettyPrint" + , Style (..) + ) where + +import Data.List ( intersperse ) +import RIO +import RIO.PrettyPrint.StylesUpdate ( HasStylesUpdate (..) ) +import RIO.PrettyPrint.Types ( Style (..) ) +import Text.PrettyPrint.Leijen.Extended + ( Pretty (pretty), StyleAnn (..), StyleDoc, (<+>), align + , angles, braces, brackets, cat, displayAnsi, displayPlain + , dquotes, enclose, encloseSep, fill, fillBreak, fillCat + , fillSep, group, hang, hcat, hsep, indent, line, linebreak + , nest, parens, punctuate, sep, softbreak, softline, squotes + , string, styleAnn, vcat, vsep + ) + +class (HasLogFunc env, HasStylesUpdate env) => HasTerm env where + useColorL :: Lens' env Bool + termWidthL :: Lens' env Int + +displayWithColor :: + (HasTerm env, Pretty a, MonadReader env m, HasCallStack) + => a + -> m Utf8Builder +displayWithColor x = do + useAnsi <- view useColorL + termWidth <- view termWidthL + (if useAnsi then displayAnsi else displayPlain) termWidth x + +-- TODO: switch to using implicit callstacks once 7.8 support is dropped + +prettyWith :: + (HasTerm env, HasCallStack, Pretty b, MonadReader env m, MonadIO m) + => LogLevel + -> (a -> b) + -> a + -> m () +prettyWith level f = logGeneric "" level . RIO.display <=< displayWithColor . f + +-- Note: I think keeping this section aligned helps spot errors, might be +-- worth keeping the alignment in place. + +prettyDebugWith, prettyInfoWith, prettyNoteWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith + :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) + => (a -> StyleDoc) -> a -> m () +prettyDebugWith = prettyWith LevelDebug +prettyInfoWith = prettyWith LevelInfo +prettyNoteWith f = prettyWith LevelInfo + ((line <>) . (style Good "Note:" <+>) . + indentAfterLabel . f) +prettyWarnWith f = prettyWith LevelWarn + ((line <>) . (style Warning "Warning:" <+>) . + indentAfterLabel . f) +prettyErrorWith f = prettyWith LevelError + ((line <>) . (style Error "Error:" <+>) . + indentAfterLabel . f) +prettyWarnNoIndentWith f = prettyWith LevelWarn + ((line <>) . (style Warning "Warning:" <+>) . f) +prettyErrorNoIndentWith f = prettyWith LevelError + ((line <>) . (style Error "Error:" <+>) . f) + +prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent + :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) + => StyleDoc -> m () +prettyDebug = prettyDebugWith id +prettyInfo = prettyInfoWith id +prettyNote = prettyNoteWith id +prettyWarn = prettyWarnWith id +prettyError = prettyErrorWith id +prettyWarnNoIndent = prettyWarnNoIndentWith id +prettyErrorNoIndent = prettyErrorNoIndentWith id + +prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL + :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) + => [StyleDoc] -> m () +prettyDebugL = prettyDebugWith fillSep +prettyInfoL = prettyInfoWith fillSep +prettyNoteL = prettyNoteWith fillSep +prettyWarnL = prettyWarnWith fillSep +prettyErrorL = prettyErrorWith fillSep +prettyWarnNoIndentL = prettyWarnNoIndentWith fillSep +prettyErrorNoIndentL = prettyErrorNoIndentWith fillSep + +prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS + :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m) + => String -> m () +prettyDebugS = prettyDebugWith flow +prettyInfoS = prettyInfoWith flow +prettyNoteS = prettyNoteWith flow +prettyWarnS = prettyWarnWith flow +prettyErrorS = prettyErrorWith flow +prettyWarnNoIndentS = prettyWarnNoIndentWith flow +prettyErrorNoIndentS = prettyErrorNoIndentWith flow + +-- End of aligned section + +-- | Use after a label and before the rest of what's being labelled for +-- consistent spacing/indenting/etc. +-- +-- For example this is used after "Warning:" in warning messages. +indentAfterLabel :: StyleDoc -> StyleDoc +indentAfterLabel = align + +-- | Make a 'Doc' from each word in a 'String' +wordDocs :: String -> [StyleDoc] +wordDocs = map fromString . words + +-- | Wordwrap a 'String' +flow :: String -> StyleDoc +flow = fillSep . wordDocs + +debugBracket :: (HasCallStack, HasTerm env, MonadReader env m, + MonadIO m, MonadUnliftIO m) => StyleDoc -> m a -> m a +debugBracket msg f = do + let output = logDebug . RIO.display <=< displayWithColor + output $ "Start: " <> msg + start <- getMonotonicTime + x <- f `catch` \ex -> do + end <- getMonotonicTime + let diff = end - start + output $ + "Finished with exception in" + <+> displayMilliseconds diff <> ":" + <+> msg + <> line + <> "Exception thrown: " + <> fromString (show ex) + throwIO (ex :: SomeException) + end <- getMonotonicTime + let diff = end - start + output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg + return x + +-- |Annotate a 'StyleDoc' with a 'Style'. +style :: Style -> StyleDoc -> StyleDoc +style = styleAnn + +-- Display milliseconds. +displayMilliseconds :: Double -> StyleDoc +displayMilliseconds t = style Good $ + fromString (show (round (t * 1000) :: Int)) <> "ms" + +-- | Display a bulleted list of 'StyleDoc'. +bulletedList :: [StyleDoc] -> StyleDoc +bulletedList = mconcat . intersperse line . map (("*" <+>) . align) + +-- | A helper function to yield a narrative list from a list of items, with a +-- final fullstop. For example, helps produce the output +-- @\"apple, ball and cat.\"@ (no serial comma) or @\"apple, ball, and cat.\"@ +-- (serial comma) from @[\"apple\", \"ball\", \"cat\"]@. +-- +-- @since 0.1.4.0 +mkNarrativeList :: + Pretty a + => Maybe Style + -- ^ Style the items in the list? + -> Bool + -- ^ Use a serial comma? + -> [a] + -> [StyleDoc] +mkNarrativeList _ _ [] = [] +mkNarrativeList mStyle _ [x] = [maybe id style mStyle (pretty x) <> "."] +mkNarrativeList mStyle useSerialComma [x1, x2] = + mStyle' (pretty x1) <> (if useSerialComma then "," else mempty) + : "and" + : mkNarrativeList mStyle useSerialComma [x2] + where + mStyle' = maybe id style mStyle +mkNarrativeList mStyle useSerialComma (x:xs) = + maybe id style mStyle (pretty x) <> "," + : mkNarrativeList mStyle useSerialComma xs + +-- | Display a bulleted list of 'StyleDoc' with a blank line between +-- each. +spacedBulletedList :: [StyleDoc] -> StyleDoc +spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align) + +-- | The 'Style' intended to be associated with a 'LogLevel'. +-- +-- @since 0.1.1.0 +logLevelToStyle :: LogLevel -> Style +logLevelToStyle level = case level of + LevelDebug -> Debug + LevelInfo -> Info + LevelWarn -> Warning + LevelError -> Error + LevelOther _ -> OtherLevel diff --git a/src/RIO/PrettyPrint/DefaultStyles.hs b/src/RIO/PrettyPrint/DefaultStyles.hs --- a/src/RIO/PrettyPrint/DefaultStyles.hs +++ b/src/RIO/PrettyPrint/DefaultStyles.hs @@ -1,39 +1,40 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module RIO.PrettyPrint.DefaultStyles - ( - defaultStyles - ) where - -import Data.Array.IArray (array) -import RIO -import RIO.PrettyPrint.Types (Style (..), Styles) -import System.Console.ANSI.Codes (Color (..), ColorIntensity (..), - ConsoleIntensity (..), ConsoleLayer (..), SGR (..)) - --- | Default styles for rio-prettyprint output. -defaultStyles :: Styles -defaultStyles = array (minBound, maxBound) - [ (Error, ("error", [SetColor Foreground Vivid Red])) - , (Warning, ("warning", [SetColor Foreground Dull Yellow])) - , (Info, ("info", [SetColor Foreground Dull Blue])) - , (Debug, ("debug", [SetColor Foreground Dull Green])) - , (OtherLevel, ("other-level", [SetColor Foreground Dull Magenta])) - , (Good, ("good", [SetColor Foreground Vivid Green])) - , (Shell, ("shell", [SetColor Foreground Vivid Magenta])) - , (File, ("file", [SetColor Foreground Dull Cyan])) - -- For now 'Url' using the same style as 'File' - , (Url, ("url", [SetColor Foreground Dull Cyan])) - , (Dir, ("dir", [ SetConsoleIntensity BoldIntensity - , SetColor Foreground Vivid Blue ])) - , (Recommendation, ("recommendation", [ SetConsoleIntensity BoldIntensity - , SetColor Foreground Vivid Green])) - , (Current, ("current", [SetColor Foreground Dull Yellow])) - , (Target, ("target", [SetColor Foreground Vivid Cyan])) - -- TODO: what color should Module be? - , (Module, ("module", [SetColor Foreground Vivid Magenta])) - , (PkgComponent, ("package-component", [SetColor Foreground Vivid Cyan])) - , (Secondary, ("secondary", [SetColor Foreground Vivid Black])) - , (Highlight, ("highlight", [SetColor Foreground Vivid Green])) - ] +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module RIO.PrettyPrint.DefaultStyles + ( defaultStyles + ) where + +import Data.Array.IArray ( array ) +import RIO +import RIO.PrettyPrint.Types ( Style (..), Styles ) +import System.Console.ANSI.Codes + ( Color (..), ColorIntensity (..), ConsoleIntensity (..) + , ConsoleLayer (..), SGR (..) + ) + +-- | Default styles for rio-prettyprint output. +defaultStyles :: Styles +defaultStyles = array (minBound, maxBound) + [ (Error, ("error", [SetColor Foreground Vivid Red])) + , (Warning, ("warning", [SetColor Foreground Dull Yellow])) + , (Info, ("info", [SetColor Foreground Dull Blue])) + , (Debug, ("debug", [SetColor Foreground Dull Green])) + , (OtherLevel, ("other-level", [SetColor Foreground Dull Magenta])) + , (Good, ("good", [SetColor Foreground Vivid Green])) + , (Shell, ("shell", [SetColor Foreground Vivid Magenta])) + , (File, ("file", [SetColor Foreground Dull Cyan])) + -- For now 'Url' using the same style as 'File' + , (Url, ("url", [SetColor Foreground Dull Cyan])) + , (Dir, ("dir", [ SetConsoleIntensity BoldIntensity + , SetColor Foreground Vivid Blue ])) + , (Recommendation, ("recommendation", [ SetConsoleIntensity BoldIntensity + , SetColor Foreground Vivid Green])) + , (Current, ("current", [SetColor Foreground Dull Yellow])) + , (Target, ("target", [SetColor Foreground Vivid Cyan])) + -- TODO: what color should Module be? + , (Module, ("module", [SetColor Foreground Vivid Magenta])) + , (PkgComponent, ("package-component", [SetColor Foreground Vivid Cyan])) + , (Secondary, ("secondary", [SetColor Foreground Vivid Black])) + , (Highlight, ("highlight", [SetColor Foreground Vivid Green])) + ] diff --git a/src/RIO/PrettyPrint/PrettyException.hs b/src/RIO/PrettyPrint/PrettyException.hs --- a/src/RIO/PrettyPrint/PrettyException.hs +++ b/src/RIO/PrettyPrint/PrettyException.hs @@ -1,77 +1,77 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE StandaloneDeriving #-} - --- | This module provides a type representing pretty exceptions. It can be used --- as in the example below: --- --- > {-# LANGUAGE NoImplicitPrelude #-} --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > module Main (main) where --- > --- > import RIO --- > ( Exception, Handler (..), IO, RIO, Show, SomeException (..), Typeable --- > , ($), catches, displayException, exitFailure, fromString, logError --- > , mempty, throwIO --- > ) --- > import RIO.PrettyPrint --- > ( Pretty (..), Style (..), (<+>), prettyError, prettyInfo, style ) --- > import RIO.PrettyPrint.PrettyException ( PrettyException (..) ) --- > import RIO.PrettyPrint.Simple ( SimplePrettyApp, runSimplePrettyApp ) --- > --- > main :: IO () --- > main = runSimplePrettyApp 80 mempty (action `catches` handleExceptions) --- > where --- > action :: RIO SimplePrettyApp () --- > action = do --- > prettyInfo "Running action!" --- > throwIO (PrettyException MyPrettyException) --- > --- > handleExceptions :: [Handler (RIO SimplePrettyApp) ()] --- > handleExceptions = --- > [ Handler handlePrettyException --- > , Handler handleSomeException --- > ] --- > --- > handlePrettyException :: PrettyException -> RIO SimplePrettyApp () --- > handlePrettyException e = do --- > prettyError $ pretty e --- > exitFailure --- > --- > handleSomeException :: SomeException -> RIO SimplePrettyApp () --- > handleSomeException (SomeException e) = do --- > logError $ fromString $ displayException e --- > exitFailure --- > --- > data MyPrettyException --- > = MyPrettyException --- > deriving (Show, Typeable) --- > --- > instance Pretty MyPrettyException where --- > pretty MyPrettyException = --- > "My" <+> style Highlight "pretty" <+> "exception!" --- > --- > instance Exception MyPrettyException --- -module RIO.PrettyPrint.PrettyException - ( PrettyException (..) - ) where - -import RIO (Exception (..), Show, Typeable) -import Text.PrettyPrint.Leijen.Extended (Pretty (..)) - --- | Type representing pretty exceptions. --- --- @since 0.1.4.0 -data PrettyException - = forall e. (Exception e, Pretty e) => PrettyException e - deriving Typeable - -deriving instance Show PrettyException - -instance Pretty PrettyException where - pretty (PrettyException e) = pretty e - -instance Exception PrettyException where - displayException (PrettyException e) = displayException e +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | This module provides a type representing pretty exceptions. It can be used +-- as in the example below: +-- +-- > {-# LANGUAGE NoImplicitPrelude #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main (main) where +-- > +-- > import RIO +-- > ( Exception, Handler (..), IO, RIO, Show, SomeException (..), Typeable +-- > , ($), catches, displayException, exitFailure, fromString, logError +-- > , mempty, throwIO +-- > ) +-- > import RIO.PrettyPrint +-- > ( Pretty (..), Style (..), (<+>), prettyError, prettyInfo, style ) +-- > import RIO.PrettyPrint.PrettyException ( PrettyException (..) ) +-- > import RIO.PrettyPrint.Simple ( SimplePrettyApp, runSimplePrettyApp ) +-- > +-- > main :: IO () +-- > main = runSimplePrettyApp 80 mempty (action `catches` handleExceptions) +-- > where +-- > action :: RIO SimplePrettyApp () +-- > action = do +-- > prettyInfo "Running action!" +-- > throwIO (PrettyException MyPrettyException) +-- > +-- > handleExceptions :: [Handler (RIO SimplePrettyApp) ()] +-- > handleExceptions = +-- > [ Handler handlePrettyException +-- > , Handler handleSomeException +-- > ] +-- > +-- > handlePrettyException :: PrettyException -> RIO SimplePrettyApp () +-- > handlePrettyException e = do +-- > prettyError $ pretty e +-- > exitFailure +-- > +-- > handleSomeException :: SomeException -> RIO SimplePrettyApp () +-- > handleSomeException (SomeException e) = do +-- > logError $ fromString $ displayException e +-- > exitFailure +-- > +-- > data MyPrettyException +-- > = MyPrettyException +-- > deriving (Show, Typeable) +-- > +-- > instance Pretty MyPrettyException where +-- > pretty MyPrettyException = +-- > "My" <+> style Highlight "pretty" <+> "exception!" +-- > +-- > instance Exception MyPrettyException +-- +module RIO.PrettyPrint.PrettyException + ( PrettyException (..) + ) where + +import RIO ( Exception (..), Show, Typeable ) +import Text.PrettyPrint.Leijen.Extended ( Pretty (..) ) + +-- | Type representing pretty exceptions. +-- +-- @since 0.1.4.0 +data PrettyException + = forall e. (Exception e, Pretty e) => PrettyException e + deriving Typeable + +deriving instance Show PrettyException + +instance Pretty PrettyException where + pretty (PrettyException e) = pretty e + +instance Exception PrettyException where + displayException (PrettyException e) = displayException e diff --git a/src/RIO/PrettyPrint/Simple.hs b/src/RIO/PrettyPrint/Simple.hs --- a/src/RIO/PrettyPrint/Simple.hs +++ b/src/RIO/PrettyPrint/Simple.hs @@ -1,98 +1,100 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -{-| -This module exports a 'SimplePrettyApp' type, for providing a basic environment -including pretty printing functionality. --} -module RIO.PrettyPrint.Simple - ( SimplePrettyApp - , mkSimplePrettyApp - , runSimplePrettyApp - ) where - -import System.Environment (lookupEnv) - -import RIO - ( Bool (..), HasLogFunc (..), Int, LogFunc, Maybe (..), MonadIO, RIO - , ($), (<$>), isJust, lens, liftIO, logOptionsHandle, maybe, pure - , runRIO, setLogUseColor, stderr, withLogFunc - ) -import RIO.Process - ( HasProcessContext (..), ProcessContext, mkDefaultProcessContext ) - -import RIO.PrettyPrint (HasTerm (..)) -import RIO.PrettyPrint.StylesUpdate (HasStylesUpdate (..), StylesUpdate (..)) - --- | A simple, non-customizable environment type, which provides --- pretty printing functionality. --- --- @since 0.1.3.0 -data SimplePrettyApp = SimplePrettyApp - { spaLogFunc :: !LogFunc - , spaProcessContext :: !ProcessContext - , spaUseColor :: !Bool - , spaTermWidth :: !Int - , spaStylesUpdate :: !StylesUpdate - } - -instance HasLogFunc SimplePrettyApp where - logFuncL = lens spaLogFunc (\x y -> x { spaLogFunc = y }) - -instance HasProcessContext SimplePrettyApp where - processContextL = lens spaProcessContext (\x y -> x { spaProcessContext = y }) - -instance HasStylesUpdate SimplePrettyApp where - stylesUpdateL = lens spaStylesUpdate (\x y -> x { spaStylesUpdate = y }) - -instance HasTerm SimplePrettyApp where - useColorL = lens spaUseColor (\x y -> x { spaUseColor = y }) - termWidthL = lens spaTermWidth (\x y -> x { spaTermWidth = y }) - --- | Constructor for 'SimplePrettyApp'. If 'ProcessContext' is not supplied --- 'mkDefaultProcessContext' will be used to create it. --- --- @since 0.1.3.0 -mkSimplePrettyApp - :: MonadIO m - => LogFunc - -> Maybe ProcessContext - -> Bool - -- ^ Use color? - -> Int - -- ^ Terminal width - -> StylesUpdate - -> m SimplePrettyApp -mkSimplePrettyApp logFunc mProcessContext useColor termWidth stylesUpdate = do - processContext <- maybe mkDefaultProcessContext pure mProcessContext - pure $ SimplePrettyApp - { spaLogFunc = logFunc - , spaProcessContext = processContext - , spaUseColor = useColor - , spaTermWidth = termWidth - , spaStylesUpdate = stylesUpdate - } - --- | Run with a default configured @SimplePrettyApp@, consisting of: --- --- * Logging to 'stderr' --- --- * If the @RIO_VERBOSE@ environment variable is set, turns on verbose logging --- --- * Default process context --- --- * Logging using color --- --- @since 0.1.3.0 -runSimplePrettyApp - :: MonadIO m - => Int - -- ^ Terminal width - -> StylesUpdate - -> RIO SimplePrettyApp a - -> m a -runSimplePrettyApp termWidth stylesUpdate m = liftIO $ do - verbose <- isJust <$> lookupEnv "RIO_VERBOSE" - lo <- setLogUseColor True <$> logOptionsHandle stderr verbose - withLogFunc lo $ \lf -> do - simplePrettyApp <- mkSimplePrettyApp lf Nothing True termWidth stylesUpdate - runRIO simplePrettyApp m +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +This module exports a 'SimplePrettyApp' type, for providing a basic environment +including pretty printing functionality. +-} +module RIO.PrettyPrint.Simple + ( SimplePrettyApp + , mkSimplePrettyApp + , runSimplePrettyApp + ) where + +import RIO + ( Bool (..), HasLogFunc (..), Int, LogFunc, Maybe (..) + , MonadIO, RIO, ($), (<$>), isJust, lens, liftIO + , logOptionsHandle, maybe, pure, runRIO, setLogUseColor + , stderr, withLogFunc + ) +import RIO.PrettyPrint ( HasTerm (..) ) +import RIO.PrettyPrint.StylesUpdate + ( HasStylesUpdate (..), StylesUpdate (..) ) +import RIO.Process + ( HasProcessContext (..), ProcessContext + , mkDefaultProcessContext + ) +import System.Environment ( lookupEnv ) + +-- | A simple, non-customizable environment type, which provides +-- pretty printing functionality. +-- +-- @since 0.1.3.0 +data SimplePrettyApp = SimplePrettyApp + { spaLogFunc :: !LogFunc + , spaProcessContext :: !ProcessContext + , spaUseColor :: !Bool + , spaTermWidth :: !Int + , spaStylesUpdate :: !StylesUpdate + } + +instance HasLogFunc SimplePrettyApp where + logFuncL = lens spaLogFunc (\x y -> x { spaLogFunc = y }) + +instance HasProcessContext SimplePrettyApp where + processContextL = lens spaProcessContext (\x y -> x { spaProcessContext = y }) + +instance HasStylesUpdate SimplePrettyApp where + stylesUpdateL = lens spaStylesUpdate (\x y -> x { spaStylesUpdate = y }) + +instance HasTerm SimplePrettyApp where + useColorL = lens spaUseColor (\x y -> x { spaUseColor = y }) + termWidthL = lens spaTermWidth (\x y -> x { spaTermWidth = y }) + +-- | Constructor for 'SimplePrettyApp'. If 'ProcessContext' is not supplied +-- 'mkDefaultProcessContext' will be used to create it. +-- +-- @since 0.1.3.0 +mkSimplePrettyApp :: + MonadIO m + => LogFunc + -> Maybe ProcessContext + -> Bool + -- ^ Use color? + -> Int + -- ^ Terminal width + -> StylesUpdate + -> m SimplePrettyApp +mkSimplePrettyApp logFunc mProcessContext useColor termWidth stylesUpdate = do + processContext <- maybe mkDefaultProcessContext pure mProcessContext + pure $ SimplePrettyApp + { spaLogFunc = logFunc + , spaProcessContext = processContext + , spaUseColor = useColor + , spaTermWidth = termWidth + , spaStylesUpdate = stylesUpdate + } + +-- | Run with a default configured @SimplePrettyApp@, consisting of: +-- +-- * Logging to 'stderr' +-- +-- * If the @RIO_VERBOSE@ environment variable is set, turns on verbose logging +-- +-- * Default process context +-- +-- * Logging using color +-- +-- @since 0.1.3.0 +runSimplePrettyApp :: + MonadIO m + => Int + -- ^ Terminal width + -> StylesUpdate + -> RIO SimplePrettyApp a + -> m a +runSimplePrettyApp termWidth stylesUpdate m = liftIO $ do + verbose <- isJust <$> lookupEnv "RIO_VERBOSE" + lo <- setLogUseColor True <$> logOptionsHandle stderr verbose + withLogFunc lo $ \lf -> do + simplePrettyApp <- mkSimplePrettyApp lf Nothing True termWidth stylesUpdate + runRIO simplePrettyApp m diff --git a/src/RIO/PrettyPrint/StylesUpdate.hs b/src/RIO/PrettyPrint/StylesUpdate.hs --- a/src/RIO/PrettyPrint/StylesUpdate.hs +++ b/src/RIO/PrettyPrint/StylesUpdate.hs @@ -1,165 +1,166 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module RIO.PrettyPrint.StylesUpdate - ( - StylesUpdate (..) - , parseStylesUpdateFromString - , HasStylesUpdate (..) - ) where - -import Data.Aeson (FromJSON(..), withText) -import Data.Array.IArray (assocs) -import Data.Colour.SRGB (Colour, sRGB24) -import Data.Text as T (pack, unpack) -import RIO -import RIO.PrettyPrint.DefaultStyles (defaultStyles) -import RIO.PrettyPrint.Types (Style, StyleSpec) -import System.Console.ANSI.Types (BlinkSpeed (..), Color (..), - ColorIntensity (..), ConsoleIntensity (..), ConsoleLayer (..), - SGR (..), Underlining (..)) - --- |Updates to 'Styles' -newtype StylesUpdate = StylesUpdate { stylesUpdate :: [(Style, StyleSpec)] } - deriving (Eq, Show) - --- |The first styles update overrides the second one. -instance Semigroup StylesUpdate where - -- See module "Data.IArray.Array" of package @array@: this depends on GHC's - -- implementation of '(//)' being such that the last value specified for a - -- duplicated index is used. - StylesUpdate s1 <> StylesUpdate s2 = StylesUpdate (s2 <> s1) - -instance Monoid StylesUpdate where - mempty = StylesUpdate [] - mappend = (<>) -- This needs to be specified as, before package - -- @base-4.11.0.0@ (GHC 8.4.2, March 2018), the default is - -- 'mappend = (++)'. - -instance FromJSON StylesUpdate where - parseJSON = withText "StylesUpdate" $ - return . parseStylesUpdateFromString . T.unpack - --- |Parse a string that is a colon-delimited sequence of key=value, where 'key' --- is a style name and 'value' is a semicolon-delimited list of 'ANSI' SGR --- (Select Graphic Rendition) control codes (in decimal). Keys that are not --- present in 'defaultStyles' are ignored. Items in the semicolon-delimited --- list that are not recognised as valid control codes are ignored. -parseStylesUpdateFromString :: String -> StylesUpdate -parseStylesUpdateFromString s = StylesUpdate $ mapMaybe process table - where - table = do - w <- split ':' s - let (k, v') = break (== '=') w - case v' of - '=' : v -> return (T.pack k, parseCodes v) - _ -> [] - - process :: StyleSpec -> Maybe (Style, StyleSpec) - process (k, sgrs) = do - style <- lookup k styles - return (style, (k, sgrs)) - -styles :: [(Text, Style)] -styles = map (\(s, (k, _)) -> (k, s)) $ assocs defaultStyles - -parseCodes :: String -> [SGR] -parseCodes [] = [] -parseCodes s = parseCodes' c - where - s' = split ';' s - c :: [Word8] - c = mapMaybe readMaybe s' - -parseCodes' :: [Word8] -> [SGR] -parseCodes' c = case codeToSGR c of - (Nothing, []) -> [] - (Just sgr, []) -> [sgr] - (Nothing, cs) -> parseCodes' cs - (Just sgr, cs) -> sgr : parseCodes' cs - -split :: Char -> String -> [String] -split c s = case rest of - [] -> [chunk] - _:rest1 -> chunk : split c rest1 - where - (chunk, rest) = break (==c) s - --- |This function is, essentially, the inverse of 'sgrToCode' exported by --- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The --- \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for --- Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T --- Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information --- Technology – Open Document Architecture (ODA) and Interchange Format: --- Character Content Architectures\` (also published as ISO/IEC International --- Standard 8613-6); and (3) further extensions used by \'XTerm\', a terminal --- emulator for the X Window System. The escape codes are described in a --- Wikipedia article at and --- those codes supported on current versions of Windows at --- . -codeToSGR :: [Word8] -> (Maybe SGR, [Word8]) -codeToSGR [] = (Nothing, []) -codeToSGR (c:cs) - | c == 0 = (Just Reset, cs) - | c == 1 = (Just $ SetConsoleIntensity BoldIntensity, cs) - | c == 2 = (Just $ SetConsoleIntensity FaintIntensity, cs) - | c == 3 = (Just $ SetItalicized True, cs) - | c == 4 = (Just $ SetUnderlining SingleUnderline, cs) - | c == 5 = (Just $ SetBlinkSpeed SlowBlink, cs) - | c == 6 = (Just $ SetBlinkSpeed RapidBlink, cs) - | c == 7 = (Just $ SetSwapForegroundBackground True, cs) - | c == 8 = (Just $ SetVisible False, cs) - | c == 21 = (Just $ SetUnderlining DoubleUnderline, cs) - | c == 22 = (Just $ SetConsoleIntensity NormalIntensity, cs) - | c == 23 = (Just $ SetItalicized False, cs) - | c == 24 = (Just $ SetUnderlining NoUnderline, cs) - | c == 25 = (Just $ SetBlinkSpeed NoBlink, cs) - | c == 27 = (Just $ SetSwapForegroundBackground False, cs) - | c == 28 = (Just $ SetVisible True, cs) - | c >= 30 && c <= 37 = - (Just $ SetColor Foreground Dull $ codeToColor (c - 30), cs) - | c == 38 = case codeToRGB cs of - (Nothing, cs') -> (Nothing, cs') - (Just color, cs') -> (Just $ SetRGBColor Foreground color, cs') - | c >= 40 && c <= 47 = - (Just $ SetColor Background Dull $ codeToColor (c - 40), cs) - | c == 48 = case codeToRGB cs of - (Nothing, cs') -> (Nothing, cs') - (Just color, cs') -> (Just $ SetRGBColor Background color, cs') - | c >= 90 && c <= 97 = - (Just $ SetColor Foreground Vivid $ codeToColor (c - 90), cs) - | c >= 100 && c <= 107 = - (Just $ SetColor Background Vivid $ codeToColor (c - 100), cs) - | otherwise = (Nothing, cs) - --- |This function is, essentially, the inverse of 'colorToCode' exported by --- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The --- \'ANSI\' standards refer to eight named colours in a specific order. The code --- is a 0-based index of those colours. -codeToColor :: Word8 -> Color -codeToColor c - -- 'toEnum' is not used because the @ansi-terminal@ package does not - -- /guarantee/ the order of the data constructors of type 'Color' will be the - -- same as that of the \'ANSI\' standards (although it currently is). (The - -- 'colorToCode' function itself does not use 'fromEnum'.) - | c == 0 = Black - | c == 1 = Red - | c == 2 = Green - | c == 3 = Yellow - | c == 4 = Blue - | c == 5 = Magenta - | c == 6 = Cyan - | c == 7 = White - | otherwise = error "Error: codeToColor, code outside 0 to 7." - -codeToRGB :: [Word8] -> (Maybe (Colour Float), [Word8]) -codeToRGB [] = (Nothing, []) -codeToRGB (2:r:g:b:cs) = (Just $ sRGB24 r g b, cs) -codeToRGB cs = (Nothing, cs) - --- | Environment values with a styles update. --- --- @since 0.1.0.0 -class HasStylesUpdate env where - stylesUpdateL :: Lens' env StylesUpdate -instance HasStylesUpdate StylesUpdate where - stylesUpdateL = id +{-# LANGUAGE NoImplicitPrelude #-} + +module RIO.PrettyPrint.StylesUpdate + ( StylesUpdate (..) + , parseStylesUpdateFromString + , HasStylesUpdate (..) + ) where + +import Data.Aeson ( FromJSON (..), withText ) +import Data.Array.IArray ( assocs ) +import Data.Colour.SRGB ( Colour, sRGB24 ) +import Data.Text as T ( pack, unpack ) +import RIO +import RIO.PrettyPrint.DefaultStyles ( defaultStyles ) +import RIO.PrettyPrint.Types ( Style, StyleSpec ) +import System.Console.ANSI.Types + ( BlinkSpeed (..), Color (..), ColorIntensity (..) + , ConsoleIntensity (..), ConsoleLayer (..), SGR (..) + , Underlining (..) + ) + +-- | Updates to 'Styles' +newtype StylesUpdate = StylesUpdate { stylesUpdate :: [(Style, StyleSpec)] } + deriving (Eq, Show) + +-- | The first styles update overrides the second one. +instance Semigroup StylesUpdate where + -- See module "Data.IArray.Array" of package @array@: this depends on GHC's + -- implementation of '(//)' being such that the last value specified for a + -- duplicated index is used. + StylesUpdate s1 <> StylesUpdate s2 = StylesUpdate (s2 <> s1) + +instance Monoid StylesUpdate where + mempty = StylesUpdate [] + mappend = (<>) -- This needs to be specified as, before package + -- @base-4.11.0.0@ (GHC 8.4.2, March 2018), the default is + -- 'mappend = (++)'. + +instance FromJSON StylesUpdate where + parseJSON = withText "StylesUpdate" $ + return . parseStylesUpdateFromString . T.unpack + +-- |Parse a string that is a colon-delimited sequence of key=value, where 'key' +-- is a style name and 'value' is a semicolon-delimited list of 'ANSI' SGR +-- (Select Graphic Rendition) control codes (in decimal). Keys that are not +-- present in 'defaultStyles' are ignored. Items in the semicolon-delimited +-- list that are not recognised as valid control codes are ignored. +parseStylesUpdateFromString :: String -> StylesUpdate +parseStylesUpdateFromString s = StylesUpdate $ mapMaybe process table + where + table = do + w <- split ':' s + let (k, v') = break (== '=') w + case v' of + '=' : v -> return (T.pack k, parseCodes v) + _ -> [] + + process :: StyleSpec -> Maybe (Style, StyleSpec) + process (k, sgrs) = do + style <- lookup k styles + return (style, (k, sgrs)) + +styles :: [(Text, Style)] +styles = map (\(s, (k, _)) -> (k, s)) $ assocs defaultStyles + +parseCodes :: String -> [SGR] +parseCodes [] = [] +parseCodes s = parseCodes' c + where + s' = split ';' s + c :: [Word8] + c = mapMaybe readMaybe s' + +parseCodes' :: [Word8] -> [SGR] +parseCodes' c = case codeToSGR c of + (Nothing, []) -> [] + (Just sgr, []) -> [sgr] + (Nothing, cs) -> parseCodes' cs + (Just sgr, cs) -> sgr : parseCodes' cs + +split :: Char -> String -> [String] +split c s = case rest of + [] -> [chunk] + _:rest1 -> chunk : split c rest1 + where + (chunk, rest) = break (==c) s + +-- |This function is, essentially, the inverse of 'sgrToCode' exported by +-- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The +-- \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for +-- Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T +-- Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information +-- Technology – Open Document Architecture (ODA) and Interchange Format: +-- Character Content Architectures\` (also published as ISO/IEC International +-- Standard 8613-6); and (3) further extensions used by \'XTerm\', a terminal +-- emulator for the X Window System. The escape codes are described in a +-- Wikipedia article at and +-- those codes supported on current versions of Windows at +-- . +codeToSGR :: [Word8] -> (Maybe SGR, [Word8]) +codeToSGR [] = (Nothing, []) +codeToSGR (c:cs) + | c == 0 = (Just Reset, cs) + | c == 1 = (Just $ SetConsoleIntensity BoldIntensity, cs) + | c == 2 = (Just $ SetConsoleIntensity FaintIntensity, cs) + | c == 3 = (Just $ SetItalicized True, cs) + | c == 4 = (Just $ SetUnderlining SingleUnderline, cs) + | c == 5 = (Just $ SetBlinkSpeed SlowBlink, cs) + | c == 6 = (Just $ SetBlinkSpeed RapidBlink, cs) + | c == 7 = (Just $ SetSwapForegroundBackground True, cs) + | c == 8 = (Just $ SetVisible False, cs) + | c == 21 = (Just $ SetUnderlining DoubleUnderline, cs) + | c == 22 = (Just $ SetConsoleIntensity NormalIntensity, cs) + | c == 23 = (Just $ SetItalicized False, cs) + | c == 24 = (Just $ SetUnderlining NoUnderline, cs) + | c == 25 = (Just $ SetBlinkSpeed NoBlink, cs) + | c == 27 = (Just $ SetSwapForegroundBackground False, cs) + | c == 28 = (Just $ SetVisible True, cs) + | c >= 30 && c <= 37 = + (Just $ SetColor Foreground Dull $ codeToColor (c - 30), cs) + | c == 38 = case codeToRGB cs of + (Nothing, cs') -> (Nothing, cs') + (Just color, cs') -> (Just $ SetRGBColor Foreground color, cs') + | c >= 40 && c <= 47 = + (Just $ SetColor Background Dull $ codeToColor (c - 40), cs) + | c == 48 = case codeToRGB cs of + (Nothing, cs') -> (Nothing, cs') + (Just color, cs') -> (Just $ SetRGBColor Background color, cs') + | c >= 90 && c <= 97 = + (Just $ SetColor Foreground Vivid $ codeToColor (c - 90), cs) + | c >= 100 && c <= 107 = + (Just $ SetColor Background Vivid $ codeToColor (c - 100), cs) + | otherwise = (Nothing, cs) + +-- |This function is, essentially, the inverse of 'colorToCode' exported by +-- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The +-- \'ANSI\' standards refer to eight named colours in a specific order. The code +-- is a 0-based index of those colours. +codeToColor :: Word8 -> Color +codeToColor c + -- 'toEnum' is not used because the @ansi-terminal@ package does not + -- /guarantee/ the order of the data constructors of type 'Color' will be the + -- same as that of the \'ANSI\' standards (although it currently is). (The + -- 'colorToCode' function itself does not use 'fromEnum'.) + | c == 0 = Black + | c == 1 = Red + | c == 2 = Green + | c == 3 = Yellow + | c == 4 = Blue + | c == 5 = Magenta + | c == 6 = Cyan + | c == 7 = White + | otherwise = error "Error: codeToColor, code outside 0 to 7." + +codeToRGB :: [Word8] -> (Maybe (Colour Float), [Word8]) +codeToRGB [] = (Nothing, []) +codeToRGB (2:r:g:b:cs) = (Just $ sRGB24 r g b, cs) +codeToRGB cs = (Nothing, cs) + +-- | Environment values with a styles update. +-- +-- @since 0.1.0.0 +class HasStylesUpdate env where + stylesUpdateL :: Lens' env StylesUpdate +instance HasStylesUpdate StylesUpdate where + stylesUpdateL = id diff --git a/src/RIO/PrettyPrint/Types.hs b/src/RIO/PrettyPrint/Types.hs --- a/src/RIO/PrettyPrint/Types.hs +++ b/src/RIO/PrettyPrint/Types.hs @@ -1,70 +1,69 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-| -For the most part, the data constructors of 'Style' do not clash with other -names. When they do, import the module qualified. For example: - -> import qualified RIO.PrettyPrint.Types.PrettyPrint as PP --} -module RIO.PrettyPrint.Types - ( - Style (..) - , Styles - , StyleSpec - ) where - -import Data.Array.IArray (Array) -import Data.Ix (Ix) -import Data.Text (Text) -import RIO -import System.Console.ANSI.Types (SGR) - --- |A style of rio-prettyprint's output. -data Style - = Error -- Should be used sparingly, not to style entire long messages. - -- For example, it's used to style the "Error:" or "[error]" label - -- for an error message, not the entire message. - | Warning -- Should be used sparingly, not to style entire long messages. - -- For example, it's used to style the "Warning:" or "[warn]" - -- label for a warning message, not the entire message. - | Info -- Should be used sparingly, not to style entire long messages. - -- For example, it's used to style the "[info]" label for an info - -- message, not the entire message. - | Debug -- Should be used sparingly, not to style entire long messages. - -- For example, it's used to style the "[debug]" label for a debug - -- message, not the entire message. - | OtherLevel -- Should be used sparingly, not to style entire long - -- messages. For example, it's used to style the "[...]" - -- label for an other log level message, not the entire - -- message. - | Good -- Style in a way to emphasize that it is a particularly good - -- thing. - | Shell -- Style as a shell command, i.e. when suggesting something to the - -- user that should be typed in directly as written. - | File -- Style as a filename. See 'Dir' for directories. - | Url -- Style as a URL. - | Dir -- Style as a directory name. See 'File' for files. - | Recommendation -- Style used to highlight part of a recommended course of - -- action. - | Current -- Style in a way that emphasizes that it is related to a current - -- thing. For example, could be used when talking about the current - -- package we're processing when outputting the name of it. - | Target -- TODO: figure out how to describe this - | Module -- Style as a module name. - | PkgComponent -- Style used to highlight the named component of a package. - | Secondary -- Style for secondary content. For example, it's used to style - -- timestamps. - | Highlight -- Should be used sparingly, not to style entire long messages. - -- For example, it's used to style the duration in a "Finished - -- process in ... ms" message. - deriving (Bounded, Enum, Eq, Ix, Ord, Show) - --- |The first style overrides the second. -instance Semigroup Style where - s <> _ = s - --- |A style specification, pairing its \'key\' with the corresponding list of --- 'SGR' codes. -type StyleSpec = (Text, [SGR]) - --- |Style specifications indexed by the style. -type Styles = Array Style StyleSpec +{-# LANGUAGE NoImplicitPrelude #-} +{-| +For the most part, the data constructors of 'Style' do not clash with other +names. When they do, import the module qualified. For example: + +> import qualified RIO.PrettyPrint.Types.PrettyPrint as PP +-} +module RIO.PrettyPrint.Types + ( Style (..) + , Styles + , StyleSpec + ) where + +import Data.Array.IArray ( Array ) +import Data.Ix ( Ix ) +import Data.Text ( Text ) +import RIO +import System.Console.ANSI.Types ( SGR ) + +-- | A style of rio-prettyprint's output. +data Style + = Error -- Should be used sparingly, not to style entire long messages. + -- For example, it's used to style the "Error:" or "[error]" label + -- for an error message, not the entire message. + | Warning -- Should be used sparingly, not to style entire long messages. + -- For example, it's used to style the "Warning:" or "[warn]" + -- label for a warning message, not the entire message. + | Info -- Should be used sparingly, not to style entire long messages. + -- For example, it's used to style the "[info]" label for an info + -- message, not the entire message. + | Debug -- Should be used sparingly, not to style entire long messages. + -- For example, it's used to style the "[debug]" label for a debug + -- message, not the entire message. + | OtherLevel -- Should be used sparingly, not to style entire long + -- messages. For example, it's used to style the "[...]" + -- label for an other log level message, not the entire + -- message. + | Good -- Style in a way to emphasize that it is a particularly good + -- thing. + | Shell -- Style as a shell command, i.e. when suggesting something to the + -- user that should be typed in directly as written. + | File -- Style as a filename. See 'Dir' for directories. + | Url -- Style as a URL. + | Dir -- Style as a directory name. See 'File' for files. + | Recommendation -- Style used to highlight part of a recommended course of + -- action. + | Current -- Style in a way that emphasizes that it is related to a current + -- thing. For example, could be used when talking about the current + -- package we're processing when outputting the name of it. + | Target -- TODO: figure out how to describe this + | Module -- Style as a module name. + | PkgComponent -- Style used to highlight the named component of a package. + | Secondary -- Style for secondary content. For example, it's used to style + -- timestamps. + | Highlight -- Should be used sparingly, not to style entire long messages. + -- For example, it's used to style the duration in a "Finished + -- process in ... ms" message. + deriving (Bounded, Enum, Eq, Ix, Ord, Show) + +-- | The first style overrides the second. +instance Semigroup Style where + s <> _ = s + +-- | A style specification, pairing its \'key\' with the corresponding list of +-- 'SGR' codes. +type StyleSpec = (Text, [SGR]) + +-- | Style specifications indexed by the style. +type Styles = Array Style StyleSpec diff --git a/src/Text/PrettyPrint/Leijen/Extended.hs b/src/Text/PrettyPrint/Leijen/Extended.hs --- a/src/Text/PrettyPrint/Leijen/Extended.hs +++ b/src/Text/PrettyPrint/Leijen/Extended.hs @@ -1,466 +1,504 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} --- | This module re-exports some of the interface for --- "Text.PrettyPrint.Annotated.Leijen" along with additional definitions --- useful for stack. --- --- It defines a 'Monoid' instance for 'Doc'. -module Text.PrettyPrint.Leijen.Extended - ( - -- * Pretty-print typeclass - Pretty (..), - - -- * Ansi terminal Doc - -- - -- See "System.Console.ANSI" for 'SGR' values to use beyond the colors - -- provided. - StyleDoc (..), StyleAnn(..), - -- hDisplayAnsi, - displayAnsi, displayPlain, renderDefault, - - -- * Selective re-exports from "Text.PrettyPrint.Annotated.Leijen" - -- - -- Documentation of omissions up-to-date with @annotated-wl-pprint-0.7.0@ - - -- ** Documents, parametrized by their annotations - -- - -- Omitted compared to original: @putDoc, hPutDoc@ - -- Doc, - - -- ** Basic combinators - -- - -- Omitted compared to original: @empty, char, text, (<>)@ - -- - -- Instead of @text@ and @char@, use 'fromString'. - -- - -- Instead of @empty@, use 'mempty'. - nest, line, linebreak, group, softline, softbreak, - - -- ** Alignment - -- - -- The combinators in this section can not be described by Wadler's - -- original combinators. They align their output relative to the - -- current output position - in contrast to @nest@ which always - -- aligns to the current nesting level. This deprives these - -- combinators from being \`optimal\'. In practice however they - -- prove to be very useful. The combinators in this section should - -- be used with care, since they are more expensive than the other - -- combinators. For example, @align@ shouldn't be used to pretty - -- print all top-level declarations of a language, but using @hang@ - -- for let expressions is fine. - -- - -- Omitted compared to original: @list, tupled, semiBraces@ - align, hang, indent, encloseSep, - - -- ** Operators - -- - -- Omitted compared to original: @(<$>), (), (<$$>), ()@ - (<+>), - - -- ** List combinators - hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate, - - -- ** Fillers - fill, fillBreak, - - -- ** Bracketing combinators - enclose, squotes, dquotes, parens, angles, braces, brackets, - - -- ** Character documents - -- Entirely omitted: - -- - -- @ - -- lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket, - -- squote, dquote, semi, colon, comma, space, dot, backslash, equals, - -- pipe - -- @ - - -- ** Primitive type documents - -- Omitted compared to the original: - -- - -- @ - -- int, integer, float, double, rational, bool, - -- @ - string, - - -- ** Semantic annotations - annotate, noAnnotate, styleAnn - - -- ** Rendering - -- Original entirely omitted: - -- @ - -- SimpleDoc(..), renderPretty, renderCompact, displayDecorated, displayDecoratedA, display, displayS, displayIO, - -- SpanList(..), displaySpans - -- @ - - -- ** Undocumented - -- Entirely omitted: - -- @ - -- column, nesting, width - -- @ - ) where - -import Control.Monad.Reader (runReader, local) -import Data.Array.IArray ((!), (//)) -import qualified Data.Text as T -import Distribution.ModuleName (ModuleName) -import qualified Distribution.Text (display) -import Path -import RIO -import qualified RIO.Map as M -import RIO.PrettyPrint.DefaultStyles (defaultStyles) -import RIO.PrettyPrint.Types (Style (Dir, File), Styles) -import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..), HasStylesUpdate, stylesUpdateL) -import System.Console.ANSI (ConsoleLayer (..), SGR (..), setSGRCode) -import qualified Text.PrettyPrint.Annotated.Leijen as P -import Text.PrettyPrint.Annotated.Leijen - ( Doc, SimpleDoc (..) - ) - --- TODO: consider smashing together the code for wl-annotated-pprint and --- wl-pprint-text. The code here already handles doing the --- ansi-wl-pprint stuff (better!) atop wl-annotated-pprint. So the --- result would be a package unifying 3 different wl inspired packages. --- --- Perhaps it can still have native string support, by adding a type --- parameter to Doc? - -instance Semigroup StyleDoc where - StyleDoc x <> StyleDoc y = StyleDoc (x P.<> y) -instance Monoid StyleDoc where - mappend = (<>) - mempty = StyleDoc P.empty - --------------------------------------------------------------------------------- --- Pretty-Print class - -class Pretty a where - pretty :: a -> StyleDoc - default pretty :: Show a => a -> StyleDoc - pretty = StyleDoc . fromString . show - -instance Pretty StyleDoc where - pretty = id - -instance Pretty (Path b File) where - pretty = styleAnn File . StyleDoc . fromString . toFilePath - -instance Pretty (Path b Dir) where - pretty = styleAnn Dir . StyleDoc . fromString . toFilePath - -instance Pretty ModuleName where - pretty = StyleDoc . fromString . Distribution.Text.display - --------------------------------------------------------------------------------- --- Style Doc - --- |A style annotation. -newtype StyleAnn = StyleAnn (Maybe Style) - deriving (Eq, Show, Semigroup) - -instance Monoid StyleAnn where - mempty = StyleAnn Nothing - mappend = (<>) - --- |A document annotated by a style -newtype StyleDoc = StyleDoc { unStyleDoc :: Doc StyleAnn } - deriving (IsString, Show) - --- |An ANSI code(s) annotation. -newtype AnsiAnn = AnsiAnn [SGR] - deriving (Eq, Show, Semigroup, Monoid) - --- |Convert a 'SimpleDoc' annotated with 'StyleAnn' to one annotated with --- 'AnsiAnn', by reference to a 'Styles'. -toAnsiDoc :: Styles -> SimpleDoc StyleAnn -> SimpleDoc AnsiAnn -toAnsiDoc styles = go - where - go SEmpty = SEmpty - go (SChar c d) = SChar c (go d) - go (SText l s d) = SText l s (go d) - go (SLine i d) = SLine i (go d) - go (SAnnotStart (StyleAnn (Just s)) d) = - SAnnotStart (AnsiAnn (snd $ styles ! s)) (go d) - go (SAnnotStart (StyleAnn Nothing) d) = SAnnotStart (AnsiAnn []) (go d) - go (SAnnotStop d) = SAnnotStop (go d) - -displayPlain - :: (Pretty a, HasLogFunc env, HasStylesUpdate env, - MonadReader env m, HasCallStack) - => Int -> a -> m Utf8Builder -displayPlain w = - displayAnsiSimple . renderDefault w . fmap (const mempty) . unStyleDoc . pretty - --- TODO: tweak these settings more? --- TODO: options for settings if this is released as a lib - -renderDefault :: Int -> Doc a -> SimpleDoc a -renderDefault = P.renderPretty 1 - -displayAnsi - :: (Pretty a, HasLogFunc env, HasStylesUpdate env, - MonadReader env m, HasCallStack) - => Int -> a -> m Utf8Builder -displayAnsi w = - displayAnsiSimple . renderDefault w . unStyleDoc . pretty - -{- Not used -------------------------------------------------------------------- - -hDisplayAnsi - :: (Display a, HasAnsiAnn (Ann a), MonadIO m) - => Handle -> Int -> a -> m () -hDisplayAnsi h w x = liftIO $ do - useAnsi <- hSupportsANSI h - T.hPutStr h $ if useAnsi then displayAnsi w x else displayPlain w x - --} - -displayAnsiSimple - :: (HasLogFunc env, HasStylesUpdate env, MonadReader env m, HasCallStack) - => SimpleDoc StyleAnn -> m Utf8Builder -displayAnsiSimple doc = do - update <- view stylesUpdateL - let styles = defaultStyles // stylesUpdate update - doc' = toAnsiDoc styles doc - return $ - flip runReader mempty $ displayDecoratedWrap go doc' - where - go (AnsiAnn sgrs) inner = do - old <- ask - let sgrs' = mapMaybe (\sgr -> if sgr == Reset - then Nothing - else Just (getSGRTag sgr, sgr)) sgrs - new = if Reset `elem` sgrs - then M.fromList sgrs' - else foldl' (\mp (tag, sgr) -> M.insert tag sgr mp) old sgrs' - (extra, contents) <- local (const new) inner - return (extra, transitionCodes old new <> contents <> transitionCodes new old) - transitionCodes old new = - case (null removals, null additions) of - (True, True) -> mempty - (True, False) -> fromString (setSGRCode additions) - (False, _) -> fromString (setSGRCode (Reset : M.elems new)) - where - (removals, additions) = partitionEithers $ M.elems $ - M.mergeWithKey - (\_ o n -> if o == n then Nothing else Just (Right n)) - (fmap Left) - (fmap Right) - old - new - -displayDecoratedWrap - :: forall a m. Monad m - => (forall b. a -> m (b, Utf8Builder) -> m (b, Utf8Builder)) - -> SimpleDoc a - -> m Utf8Builder -displayDecoratedWrap f doc = do - (mafter, result) <- go doc - case mafter of - Just _ -> error "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStart for SAnnotStop." - Nothing -> return result - where - spaces n = display (T.replicate n " ") - - go :: SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder) - go SEmpty = return (Nothing, mempty) - go (SChar c x) = fmap (fmap (display c <>)) (go x) - -- NOTE: Could actually use the length to guess at an initial - -- allocation. Better yet would be to just use Text in pprint.. - go (SText _l s x) = fmap (fmap (fromString s <>)) (go x) - go (SLine n x) = fmap (fmap ((display '\n' <>) . (spaces n <>))) (go x) - go (SAnnotStart ann x) = do - (mafter, contents) <- f ann (go x) - case mafter of - Just after -> fmap (fmap (contents <>)) (go after) - Nothing -> error "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStop for SAnnotStart." - go (SAnnotStop x) = return (Just x, mempty) - -{- Not used -------------------------------------------------------------------- - --- Foreground color combinators - -black, red, green, yellow, blue, magenta, cyan, white, - dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite, - onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite, - ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite - :: Doc AnsiAnn -> Doc AnsiAnn -(black, dullblack, onblack, ondullblack) = colorFunctions Black -(red, dullred, onred, ondullred) = colorFunctions Red -(green, dullgreen, ongreen, ondullgreen) = colorFunctions Green -(yellow, dullyellow, onyellow, ondullyellow) = colorFunctions Yellow -(blue, dullblue, onblue, ondullblue) = colorFunctions Blue -(magenta, dullmagenta, onmagenta, ondullmagenta) = colorFunctions Magenta -(cyan, dullcyan, oncyan, ondullcyan) = colorFunctions Cyan -(white, dullwhite, onwhite, ondullwhite) = colorFunctions White - -type EndoAnsiDoc = Doc AnsiAnn -> Doc AnsiAnn - -colorFunctions :: Color -> (EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc) -colorFunctions color = - ( ansiAnn [SetColor Foreground Vivid color] - , ansiAnn [SetColor Foreground Dull color] - , ansiAnn [SetColor Background Vivid color] - , ansiAnn [SetColor Background Dull color] - ) - --} - -styleAnn :: Style -> StyleDoc -> StyleDoc -styleAnn s = StyleDoc . P.annotate (StyleAnn (Just s)) . unStyleDoc - -{- Not used -------------------------------------------------------------------- - --- Intensity combinators - -bold, faint, normal :: Doc AnsiAnn -> Doc AnsiAnn -bold = ansiAnn [SetConsoleIntensity BoldIntensity] -faint = ansiAnn [SetConsoleIntensity FaintIntensity] -normal = ansiAnn [SetConsoleIntensity NormalIntensity] - --} - --- | Tags for each field of state in SGR (Select Graphics Rendition). --- --- It's a bit of a hack that 'TagReset' is included. -data SGRTag - = TagReset - | TagConsoleIntensity - | TagItalicized - | TagUnderlining - | TagBlinkSpeed - | TagVisible - | TagSwapForegroundBackground - | TagColorForeground - | TagColorBackground - | TagRGBColor - | TagPaletteColor - deriving (Eq, Ord) - -getSGRTag :: SGR -> SGRTag -getSGRTag Reset{} = TagReset -getSGRTag SetConsoleIntensity{} = TagConsoleIntensity -getSGRTag SetItalicized{} = TagItalicized -getSGRTag SetUnderlining{} = TagUnderlining -getSGRTag SetBlinkSpeed{} = TagBlinkSpeed -getSGRTag SetVisible{} = TagVisible -getSGRTag SetSwapForegroundBackground{} = TagSwapForegroundBackground -getSGRTag (SetColor Foreground _ _) = TagColorForeground -getSGRTag (SetColor Background _ _) = TagColorBackground -getSGRTag SetRGBColor{} = TagRGBColor -getSGRTag SetPaletteColor{} = TagPaletteColor - -(<+>) :: StyleDoc -> StyleDoc -> StyleDoc -StyleDoc x <+> StyleDoc y = StyleDoc (x P.<+> y) - -align :: StyleDoc -> StyleDoc -align = StyleDoc . P.align . unStyleDoc - -noAnnotate :: StyleDoc -> StyleDoc -noAnnotate = StyleDoc . P.noAnnotate . unStyleDoc - -braces :: StyleDoc -> StyleDoc -braces = StyleDoc . P.braces . unStyleDoc - -angles :: StyleDoc -> StyleDoc -angles = StyleDoc . P.angles . unStyleDoc - -parens :: StyleDoc -> StyleDoc -parens = StyleDoc . P.parens . unStyleDoc - -dquotes :: StyleDoc -> StyleDoc -dquotes = StyleDoc . P.dquotes . unStyleDoc - -squotes :: StyleDoc -> StyleDoc -squotes = StyleDoc . P.squotes . unStyleDoc - -brackets :: StyleDoc -> StyleDoc -brackets = StyleDoc . P.brackets . unStyleDoc - --- | The document @string s@ concatenates all characters in @s@ using @line@ for --- newline characters and @char@ for all other characters. It is used whenever --- the text contains newline characters. --- --- @since 0.1.4.0 -string :: String -> StyleDoc -string "" = mempty -string ('\n':s) = line <> string s -string s = let (xs, ys) = span (/='\n') s - in fromString xs <> string ys - -annotate :: StyleAnn -> StyleDoc -> StyleDoc -annotate a = StyleDoc . P.annotate a . unStyleDoc - -nest :: Int -> StyleDoc -> StyleDoc -nest a = StyleDoc . P.nest a . unStyleDoc - -line :: StyleDoc -line = StyleDoc P.line - -linebreak :: StyleDoc -linebreak = StyleDoc P.linebreak - -fill :: Int -> StyleDoc -> StyleDoc -fill a = StyleDoc . P.fill a . unStyleDoc - -fillBreak :: Int -> StyleDoc -> StyleDoc -fillBreak a = StyleDoc . P.fillBreak a . unStyleDoc - -enclose :: StyleDoc -> StyleDoc -> StyleDoc -> StyleDoc -enclose l r x = l <> x <> r - -cat :: [StyleDoc] -> StyleDoc -cat = StyleDoc . P.cat . map unStyleDoc - -punctuate :: StyleDoc -> [StyleDoc] -> [StyleDoc] -punctuate (StyleDoc x) = map StyleDoc . P.punctuate x . map unStyleDoc - -fillCat :: [StyleDoc] -> StyleDoc -fillCat = StyleDoc . P.fillCat . map unStyleDoc - -hcat :: [StyleDoc] -> StyleDoc -hcat = StyleDoc . P.hcat . map unStyleDoc - -vcat :: [StyleDoc] -> StyleDoc -vcat = StyleDoc . P.vcat . map unStyleDoc - -sep :: [StyleDoc] -> StyleDoc -sep = StyleDoc . P.sep . map unStyleDoc - -vsep :: [StyleDoc] -> StyleDoc -vsep = StyleDoc . P.vsep . map unStyleDoc - -hsep :: [StyleDoc] -> StyleDoc -hsep = StyleDoc . P.hsep . map unStyleDoc - -fillSep :: [StyleDoc] -> StyleDoc -fillSep = StyleDoc . P.fillSep . map unStyleDoc - -encloseSep :: StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc -encloseSep (StyleDoc x) (StyleDoc y) (StyleDoc z) = - StyleDoc . P.encloseSep x y z . map unStyleDoc - -indent :: Int -> StyleDoc -> StyleDoc -indent a = StyleDoc . P.indent a . unStyleDoc - -hang :: Int -> StyleDoc -> StyleDoc -hang a = StyleDoc . P.hang a . unStyleDoc - -softbreak :: StyleDoc -softbreak = StyleDoc P.softbreak - -softline :: StyleDoc -softline = StyleDoc P.softline - -group :: StyleDoc -> StyleDoc -group = StyleDoc . P.group . unStyleDoc +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module re-exports some of the interface for +-- "Text.PrettyPrint.Annotated.Leijen" along with additional definitions +-- useful for stack. +-- +-- It defines a 'Monoid' instance for 'Doc'. +module Text.PrettyPrint.Leijen.Extended + ( + -- * Pretty-print typeclass + Pretty (..) + + -- * Ansi terminal Doc + -- + -- See "System.Console.ANSI" for 'SGR' values to use beyond the colors + -- provided. + , StyleDoc (..) + , StyleAnn(..) + -- hDisplayAnsi, + , displayAnsi + , displayPlain + , renderDefault + + -- * Selective re-exports from "Text.PrettyPrint.Annotated.Leijen" + -- + -- Documentation of omissions up-to-date with @annotated-wl-pprint-0.7.0@ + + -- ** Documents, parametrized by their annotations + -- + -- Omitted compared to original: @putDoc, hPutDoc@ + -- Doc, + + -- ** Basic combinators + -- + -- Omitted compared to original: @empty, char, text, (<>)@ + -- + -- Instead of @text@ and @char@, use 'fromString'. + -- + -- Instead of @empty@, use 'mempty'. + , nest + , line + , linebreak + , group + , softline + , softbreak + + -- ** Alignment + -- + -- The combinators in this section can not be described by Wadler's + -- original combinators. They align their output relative to the + -- current output position - in contrast to @nest@ which always + -- aligns to the current nesting level. This deprives these + -- combinators from being \`optimal\'. In practice however they + -- prove to be very useful. The combinators in this section should + -- be used with care, since they are more expensive than the other + -- combinators. For example, @align@ shouldn't be used to pretty + -- print all top-level declarations of a language, but using @hang@ + -- for let expressions is fine. + -- + -- Omitted compared to original: @list, tupled, semiBraces@ + , align + , hang + , indent + , encloseSep + + -- ** Operators + -- + -- Omitted compared to original: @(<$>), (), (<$$>), ()@ + , (<+>) + + -- ** List combinators + , hsep + , vsep + , fillSep + , sep + , hcat + , vcat + , fillCat + , cat + , punctuate + + -- ** Fillers + , fill + , fillBreak + + -- ** Bracketing combinators + , enclose + , squotes + , dquotes + , parens + , angles + , braces + , brackets + + -- ** Character documents + -- Entirely omitted: + -- + -- @ + -- lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket, + -- squote, dquote, semi, colon, comma, space, dot, backslash, equals, + -- pipe + -- @ + + -- ** Primitive type documents + -- Omitted compared to the original: + -- + -- @ + -- int, integer, float, double, rational, bool, + -- @ + , string + + -- ** Semantic annotations + , annotate + , noAnnotate + , styleAnn + + -- ** Rendering + -- Original entirely omitted: + -- @ + -- SimpleDoc(..), renderPretty, renderCompact, displayDecorated, displayDecoratedA, display, displayS, displayIO, + -- SpanList(..), displaySpans + -- @ + + -- ** Undocumented + -- Entirely omitted: + -- @ + -- column, nesting, width + -- @ + ) where + +import Control.Monad.Reader ( local, runReader ) +import Data.Array.IArray ( (!), (//) ) +import qualified Data.Text as T +import Distribution.ModuleName ( ModuleName ) +import qualified Distribution.Text ( display ) +import Path ( Dir, File, Path, SomeBase, prjSomeBase, toFilePath ) +import RIO +import qualified RIO.Map as M +import RIO.PrettyPrint.DefaultStyles ( defaultStyles ) +import RIO.PrettyPrint.Types ( Style (Dir, File), Styles ) +import RIO.PrettyPrint.StylesUpdate + ( HasStylesUpdate, StylesUpdate (..), stylesUpdateL ) +import System.Console.ANSI ( ConsoleLayer (..), SGR (..), setSGRCode ) +import qualified Text.PrettyPrint.Annotated.Leijen as P +import Text.PrettyPrint.Annotated.Leijen ( Doc, SimpleDoc (..) ) + +-- TODO: consider smashing together the code for wl-annotated-pprint and +-- wl-pprint-text. The code here already handles doing the +-- ansi-wl-pprint stuff (better!) atop wl-annotated-pprint. So the +-- result would be a package unifying 3 different wl inspired packages. +-- +-- Perhaps it can still have native string support, by adding a type +-- parameter to Doc? + +instance Semigroup StyleDoc where + StyleDoc x <> StyleDoc y = StyleDoc (x P.<> y) + +instance Monoid StyleDoc where + mappend = (<>) + mempty = StyleDoc P.empty + +-------------------------------------------------------------------------------- +-- Pretty-Print class + +class Pretty a where + pretty :: a -> StyleDoc + default pretty :: Show a => a -> StyleDoc + pretty = StyleDoc . fromString . show + +instance Pretty StyleDoc where + pretty = id + +instance Pretty (Path b File) where + pretty = styleAnn File . StyleDoc . fromString . toFilePath + +instance Pretty (Path b Dir) where + pretty = styleAnn Dir . StyleDoc . fromString . toFilePath + +instance Pretty (SomeBase File) where + pretty = prjSomeBase pretty + +instance Pretty (SomeBase Dir) where + pretty = prjSomeBase pretty + +instance Pretty ModuleName where + pretty = StyleDoc . fromString . Distribution.Text.display + +-------------------------------------------------------------------------------- +-- Style Doc + +-- |A style annotation. +newtype StyleAnn = StyleAnn (Maybe Style) + deriving (Eq, Show, Semigroup) + +instance Monoid StyleAnn where + mempty = StyleAnn Nothing + mappend = (<>) + +-- |A document annotated by a style +newtype StyleDoc = StyleDoc { unStyleDoc :: Doc StyleAnn } + deriving (IsString, Show) + +-- |An ANSI code(s) annotation. +newtype AnsiAnn = AnsiAnn [SGR] + deriving (Eq, Show, Semigroup, Monoid) + +-- |Convert a 'SimpleDoc' annotated with 'StyleAnn' to one annotated with +-- 'AnsiAnn', by reference to a 'Styles'. +toAnsiDoc :: Styles -> SimpleDoc StyleAnn -> SimpleDoc AnsiAnn +toAnsiDoc styles = go + where + go SEmpty = SEmpty + go (SChar c d) = SChar c (go d) + go (SText l s d) = SText l s (go d) + go (SLine i d) = SLine i (go d) + go (SAnnotStart (StyleAnn (Just s)) d) = + SAnnotStart (AnsiAnn (snd $ styles ! s)) (go d) + go (SAnnotStart (StyleAnn Nothing) d) = SAnnotStart (AnsiAnn []) (go d) + go (SAnnotStop d) = SAnnotStop (go d) + +displayPlain :: + ( Pretty a, HasLogFunc env, HasStylesUpdate env, MonadReader env m + , HasCallStack + ) + => Int -> a -> m Utf8Builder +displayPlain w = + displayAnsiSimple . renderDefault w . fmap (const mempty) . unStyleDoc . pretty + +-- TODO: tweak these settings more? +-- TODO: options for settings if this is released as a lib + +renderDefault :: Int -> Doc a -> SimpleDoc a +renderDefault = P.renderPretty 1 + +displayAnsi :: + ( Pretty a, HasLogFunc env, HasStylesUpdate env, MonadReader env m + , HasCallStack + ) + => Int -> a -> m Utf8Builder +displayAnsi w = + displayAnsiSimple . renderDefault w . unStyleDoc . pretty + +{- Not used -------------------------------------------------------------------- + +hDisplayAnsi + :: (Display a, HasAnsiAnn (Ann a), MonadIO m) + => Handle -> Int -> a -> m () +hDisplayAnsi h w x = liftIO $ do + useAnsi <- hSupportsANSI h + T.hPutStr h $ if useAnsi then displayAnsi w x else displayPlain w x + +-} + +displayAnsiSimple :: + (HasLogFunc env, HasStylesUpdate env, MonadReader env m, HasCallStack) + => SimpleDoc StyleAnn + -> m Utf8Builder +displayAnsiSimple doc = do + update <- view stylesUpdateL + let styles = defaultStyles // stylesUpdate update + doc' = toAnsiDoc styles doc + return $ flip runReader mempty $ displayDecoratedWrap go doc' + where + go (AnsiAnn sgrs) inner = do + old <- ask + let sgrs' = mapMaybe (\sgr -> if sgr == Reset + then Nothing + else Just (getSGRTag sgr, sgr)) sgrs + new = if Reset `elem` sgrs + then M.fromList sgrs' + else foldl' (\mp (tag, sgr) -> M.insert tag sgr mp) old sgrs' + (extra, contents) <- local (const new) inner + return (extra, transitionCodes old new <> contents <> transitionCodes new old) + transitionCodes old new = + case (null removals, null additions) of + (True, True) -> mempty + (True, False) -> fromString (setSGRCode additions) + (False, _) -> fromString (setSGRCode (Reset : M.elems new)) + where + (removals, additions) = partitionEithers $ M.elems $ + M.mergeWithKey + (\_ o n -> if o == n then Nothing else Just (Right n)) + (fmap Left) + (fmap Right) + old + new + +displayDecoratedWrap :: + forall a m. Monad m + => (forall b. a -> m (b, Utf8Builder) -> m (b, Utf8Builder)) + -> SimpleDoc a + -> m Utf8Builder +displayDecoratedWrap f doc = do + (mafter, result) <- go doc + case mafter of + Just _ -> error "Invariant violated by input to displayDecoratedWrap: no \ + \matching SAnnotStart for SAnnotStop." + Nothing -> return result + where + spaces n = display (T.replicate n " ") + + go :: SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder) + go SEmpty = return (Nothing, mempty) + go (SChar c x) = fmap (fmap (display c <>)) (go x) + -- NOTE: Could actually use the length to guess at an initial + -- allocation. Better yet would be to just use Text in pprint.. + go (SText _l s x) = fmap (fmap (fromString s <>)) (go x) + go (SLine n x) = fmap (fmap ((display '\n' <>) . (spaces n <>))) (go x) + go (SAnnotStart ann x) = do + (mafter, contents) <- f ann (go x) + case mafter of + Just after -> fmap (fmap (contents <>)) (go after) + Nothing -> error "Invariant violated by input to displayDecoratedWrap: \ + \no matching SAnnotStop for SAnnotStart." + go (SAnnotStop x) = return (Just x, mempty) + +{- Not used -------------------------------------------------------------------- + +-- Foreground color combinators + +black, red, green, yellow, blue, magenta, cyan, white, + dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite, + onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite, + ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite + :: Doc AnsiAnn -> Doc AnsiAnn +(black, dullblack, onblack, ondullblack) = colorFunctions Black +(red, dullred, onred, ondullred) = colorFunctions Red +(green, dullgreen, ongreen, ondullgreen) = colorFunctions Green +(yellow, dullyellow, onyellow, ondullyellow) = colorFunctions Yellow +(blue, dullblue, onblue, ondullblue) = colorFunctions Blue +(magenta, dullmagenta, onmagenta, ondullmagenta) = colorFunctions Magenta +(cyan, dullcyan, oncyan, ondullcyan) = colorFunctions Cyan +(white, dullwhite, onwhite, ondullwhite) = colorFunctions White + +type EndoAnsiDoc = Doc AnsiAnn -> Doc AnsiAnn + +colorFunctions :: Color -> (EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc) +colorFunctions color = + ( ansiAnn [SetColor Foreground Vivid color] + , ansiAnn [SetColor Foreground Dull color] + , ansiAnn [SetColor Background Vivid color] + , ansiAnn [SetColor Background Dull color] + ) + +-} + +styleAnn :: Style -> StyleDoc -> StyleDoc +styleAnn s = StyleDoc . P.annotate (StyleAnn (Just s)) . unStyleDoc + +{- Not used -------------------------------------------------------------------- + +-- Intensity combinators + +bold, faint, normal :: Doc AnsiAnn -> Doc AnsiAnn +bold = ansiAnn [SetConsoleIntensity BoldIntensity] +faint = ansiAnn [SetConsoleIntensity FaintIntensity] +normal = ansiAnn [SetConsoleIntensity NormalIntensity] + +-} + +-- | Tags for each field of state in SGR (Select Graphics Rendition). +-- +-- It's a bit of a hack that 'TagReset' is included. +data SGRTag + = TagReset + | TagConsoleIntensity + | TagItalicized + | TagUnderlining + | TagBlinkSpeed + | TagVisible + | TagSwapForegroundBackground + | TagColorForeground + | TagColorBackground + | TagRGBColor + | TagPaletteColor + deriving (Eq, Ord) + +getSGRTag :: SGR -> SGRTag +getSGRTag Reset{} = TagReset +getSGRTag SetConsoleIntensity{} = TagConsoleIntensity +getSGRTag SetItalicized{} = TagItalicized +getSGRTag SetUnderlining{} = TagUnderlining +getSGRTag SetBlinkSpeed{} = TagBlinkSpeed +getSGRTag SetVisible{} = TagVisible +getSGRTag SetSwapForegroundBackground{} = TagSwapForegroundBackground +getSGRTag (SetColor Foreground _ _) = TagColorForeground +getSGRTag (SetColor Background _ _) = TagColorBackground +getSGRTag SetRGBColor{} = TagRGBColor +getSGRTag SetPaletteColor{} = TagPaletteColor + +(<+>) :: StyleDoc -> StyleDoc -> StyleDoc +StyleDoc x <+> StyleDoc y = StyleDoc (x P.<+> y) + +align :: StyleDoc -> StyleDoc +align = StyleDoc . P.align . unStyleDoc + +noAnnotate :: StyleDoc -> StyleDoc +noAnnotate = StyleDoc . P.noAnnotate . unStyleDoc + +braces :: StyleDoc -> StyleDoc +braces = StyleDoc . P.braces . unStyleDoc + +angles :: StyleDoc -> StyleDoc +angles = StyleDoc . P.angles . unStyleDoc + +parens :: StyleDoc -> StyleDoc +parens = StyleDoc . P.parens . unStyleDoc + +dquotes :: StyleDoc -> StyleDoc +dquotes = StyleDoc . P.dquotes . unStyleDoc + +squotes :: StyleDoc -> StyleDoc +squotes = StyleDoc . P.squotes . unStyleDoc + +brackets :: StyleDoc -> StyleDoc +brackets = StyleDoc . P.brackets . unStyleDoc + +-- | The document @string s@ concatenates all characters in @s@ using @line@ for +-- newline characters and @char@ for all other characters. It is used whenever +-- the text contains newline characters. +-- +-- @since 0.1.4.0 +string :: String -> StyleDoc +string "" = mempty +string ('\n':s) = line <> string s +string s = let (xs, ys) = span (/='\n') s + in fromString xs <> string ys + +annotate :: StyleAnn -> StyleDoc -> StyleDoc +annotate a = StyleDoc . P.annotate a . unStyleDoc + +nest :: Int -> StyleDoc -> StyleDoc +nest a = StyleDoc . P.nest a . unStyleDoc + +line :: StyleDoc +line = StyleDoc P.line + +linebreak :: StyleDoc +linebreak = StyleDoc P.linebreak + +fill :: Int -> StyleDoc -> StyleDoc +fill a = StyleDoc . P.fill a . unStyleDoc + +fillBreak :: Int -> StyleDoc -> StyleDoc +fillBreak a = StyleDoc . P.fillBreak a . unStyleDoc + +enclose :: StyleDoc -> StyleDoc -> StyleDoc -> StyleDoc +enclose l r x = l <> x <> r + +cat :: [StyleDoc] -> StyleDoc +cat = StyleDoc . P.cat . map unStyleDoc + +punctuate :: StyleDoc -> [StyleDoc] -> [StyleDoc] +punctuate (StyleDoc x) = map StyleDoc . P.punctuate x . map unStyleDoc + +fillCat :: [StyleDoc] -> StyleDoc +fillCat = StyleDoc . P.fillCat . map unStyleDoc + +hcat :: [StyleDoc] -> StyleDoc +hcat = StyleDoc . P.hcat . map unStyleDoc + +vcat :: [StyleDoc] -> StyleDoc +vcat = StyleDoc . P.vcat . map unStyleDoc + +sep :: [StyleDoc] -> StyleDoc +sep = StyleDoc . P.sep . map unStyleDoc + +vsep :: [StyleDoc] -> StyleDoc +vsep = StyleDoc . P.vsep . map unStyleDoc + +hsep :: [StyleDoc] -> StyleDoc +hsep = StyleDoc . P.hsep . map unStyleDoc + +fillSep :: [StyleDoc] -> StyleDoc +fillSep = StyleDoc . P.fillSep . map unStyleDoc + +encloseSep :: StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc +encloseSep (StyleDoc x) (StyleDoc y) (StyleDoc z) = + StyleDoc . P.encloseSep x y z . map unStyleDoc + +indent :: Int -> StyleDoc -> StyleDoc +indent a = StyleDoc . P.indent a . unStyleDoc + +hang :: Int -> StyleDoc -> StyleDoc +hang a = StyleDoc . P.hang a . unStyleDoc + +softbreak :: StyleDoc +softbreak = StyleDoc P.softbreak + +softline :: StyleDoc +softline = StyleDoc P.softline + +group :: StyleDoc -> StyleDoc +group = StyleDoc . P.group . unStyleDoc