diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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. diff --git a/rio-prettyprint.cabal b/rio-prettyprint.cabal new file mode 100644 --- /dev/null +++ b/rio-prettyprint.cabal @@ -0,0 +1,49 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 1d949118732b2fc99142bfdd103496c89c364dd299c30d2039eac2acea3de22b + +name: rio-prettyprint +version: 0.1.0.0 +synopsis: Pretty-printing for RIO +category: Development +homepage: https://github.com/commercialhaskell/stack#readme +bug-reports: https://github.com/commercialhaskell/stack/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/stack + +library + exposed-modules: + RIO.PrettyPrint + RIO.PrettyPrint.DefaultStyles + 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 + , array + , base >=4.10 && <5 + , colour + , mtl + , path + , rio + , text + default-language: Haskell2010 diff --git a/src/RIO/PrettyPrint.hs b/src/RIO/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/RIO/PrettyPrint.hs @@ -0,0 +1,176 @@ +{-# 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 + -- * Formatting utils + , bulletedList + , 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 + , 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, + 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) + +-- | Display a bulleted list of 'StyleDoc' with a blank line between +-- each. +spacedBulletedList :: [StyleDoc] -> StyleDoc +spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align) diff --git a/src/RIO/PrettyPrint/DefaultStyles.hs b/src/RIO/PrettyPrint/DefaultStyles.hs new file mode 100644 --- /dev/null +++ b/src/RIO/PrettyPrint/DefaultStyles.hs @@ -0,0 +1,33 @@ +{-# 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])) + , (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])) ] diff --git a/src/RIO/PrettyPrint/StylesUpdate.hs b/src/RIO/PrettyPrint/StylesUpdate.hs new file mode 100644 --- /dev/null +++ b/src/RIO/PrettyPrint/StylesUpdate.hs @@ -0,0 +1,165 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/RIO/PrettyPrint/Types.hs @@ -0,0 +1,55 @@ +{-# 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:" 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:" label for an error + -- 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. + 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 new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/Leijen/Extended.hs @@ -0,0 +1,454 @@ +{-# 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 + -- Entirely omitted: + -- + -- @ + -- string, int, integer, float, double, rational, bool, + -- @ + + -- ** 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 + +-- |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 = do + 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) = liftM (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) = liftM (fmap (fromString s <>)) (go x) + go (SLine n x) = liftM (fmap ((display '\n' <>) . (spaces n <>))) (go x) + go (SAnnotStart ann x) = do + (mafter, contents) <- f ann (go x) + case mafter of + Just after -> liftM (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 + +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