{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Text.PrettyPrint.Leijen.Extended
(
Pretty (..),
StyleDoc, StyleAnn(..),
displayAnsi, displayPlain, renderDefault,
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,
annotate, noAnnotate, styleAnn
) 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 (..)
)
instance Semigroup StyleDoc where
StyleDoc x <> StyleDoc y = StyleDoc (x P.<> y)
instance Monoid StyleDoc where
mappend = (<>)
mempty = StyleDoc P.empty
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
newtype StyleAnn = StyleAnn (Maybe Style)
deriving (Eq, Show, Semigroup)
instance Monoid StyleAnn where
mempty = StyleAnn Nothing
mappend = (<>)
newtype StyleDoc = StyleDoc { unStyleDoc :: Doc StyleAnn }
deriving IsString
newtype AnsiAnn = AnsiAnn [SGR]
deriving (Eq, Show, Semigroup, Monoid)
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
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
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)
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)
styleAnn :: Style -> StyleDoc -> StyleDoc
styleAnn s = StyleDoc . P.annotate (StyleAnn (Just s)) . unStyleDoc
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