diff --git a/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs b/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs index 52e6692d9..abd4c7305 100644 --- a/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs +++ b/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs @@ -93,7 +93,14 @@ displayPretty pped terms typeOf eval types tm = go tm goConsole = \case DD.ConsoleTextPlain (Term.Text' txt) -> pure $ P.text txt DD.ConsoleTextForeground color txt -> goColor color <$> goConsole txt - DD.ConsoleTextBackground color txt -> goColor color <$> goConsole txt + DD.ConsoleTextBackground color txt -> do + txt <- goConsole txt + color <- pure $ goColor color + pure $ P.background color txt + DD.ConsoleTextBold txt -> P.bold <$> goConsole txt + DD.ConsoleTextUnderline txt -> P.underline <$> goConsole txt + DD.ConsoleTextInvert txt -> P.invert <$> goConsole txt + _ -> displayTerm pped terms typeOf eval types tm -- pattern DocBlob txt <- Term.App' (Term.Constructor' DocRef DocBlobId) (Term.Text' txt) diff --git a/parser-typechecker/src/Unison/Util/ColorText.hs b/parser-typechecker/src/Unison/Util/ColorText.hs index 51dedbb5f..0d4c1c364 100644 --- a/parser-typechecker/src/Unison/Util/ColorText.hs +++ b/parser-typechecker/src/Unison/Util/ColorText.hs @@ -3,7 +3,8 @@ module Unison.Util.ColorText ( ColorText, Color(..), style, toANSI, toPlain, toHTML, defaultColors, - black, red, green, yellow, blue, purple, cyan, white, hiBlack, hiRed, hiGreen, hiYellow, hiBlue, hiPurple, hiCyan, hiWhite, bold, underline, + black, red, green, yellow, blue, purple, cyan, white, hiBlack, hiRed, hiGreen, hiYellow, hiBlue, hiPurple, hiCyan, hiWhite, + bold, underline, invert, background, unstyled, module Unison.Util.AnnotatedText) where @@ -22,8 +23,8 @@ type ColorText = AnnotatedText Color data Color = Black | Red | Green | Yellow | Blue | Purple | Cyan | White | HiBlack| HiRed | HiGreen | HiYellow | HiBlue | HiPurple | HiCyan | HiWhite - | Bold | Underline - deriving (Eq, Ord, Bounded, Enum, Show, Read) + | Bold | Underline | Invert Color | Background Color Color | Default + deriving (Eq, Ord, Show, Read) black, red, green, yellow, blue, purple, cyan, white, hiBlack, hiRed, hiGreen, hiYellow, hiBlue, hiPurple, hiCyan, hiWhite, bold, underline :: ColorText -> ColorText black = style Black @@ -45,6 +46,15 @@ hiWhite = style HiWhite bold = style Bold underline = style Underline +unstyled :: ColorText -> ColorText +unstyled = style Default + +background :: Color -> ColorText -> ColorText +background c ct = ct <&> Background c + +invert :: ColorText -> ColorText +invert ct = ct <&> Invert + style :: Color -> ColorText -> ColorText style = annotate @@ -82,7 +92,16 @@ toANSI (AnnotatedText chunks) = ) resetANSI = pure . ANSI.setSGRCode $ [ANSI.Reset] toANSI :: Color -> Seq String - toANSI c = pure . ANSI.setSGRCode $ case c of + toANSI c = pure $ ANSI.setSGRCode (toANSI' c) + + toANSI' :: Color -> [ANSI.SGR] + toANSI' c = case c of + Default -> [] + Background c c2 -> (setBg <$> toANSI' c) <> toANSI' c2 where + setBg (ANSI.SetColor ANSI.Foreground intensity color) = + ANSI.SetColor ANSI.Background intensity color + setBg sgr = sgr + Invert c -> [ANSI.SetSwapForegroundBackground True] <> toANSI' c Black -> [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Black] Red -> [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red] Green -> [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Green] diff --git a/parser-typechecker/src/Unison/Util/Pretty.hs b/parser-typechecker/src/Unison/Util/Pretty.hs index ffb85f7b1..c1ec5bb84 100644 --- a/parser-typechecker/src/Unison/Util/Pretty.hs +++ b/parser-typechecker/src/Unison/Util/Pretty.hs @@ -8,6 +8,7 @@ module Unison.Util.Pretty ( align, align', alternations, + background, backticked, backticked', boxForkLeft, @@ -50,6 +51,7 @@ module Unison.Util.Pretty ( indentN, indentNonEmptyN, indentNAfterNewline, + invert, isMultiLine, leftPad, lines, @@ -114,6 +116,7 @@ import Data.Char ( isSpace ) import Data.List ( intersperse ) import Prelude hiding ( lines , map ) import Unison.Util.AnnotatedText ( annotateMaybe ) +import qualified Unison.Util.AnnotatedText as AT import qualified Unison.Util.ColorText as CT import qualified Unison.Util.SyntaxText as ST import Unison.Util.Monoid ( intercalateMap ) @@ -774,6 +777,18 @@ hiWhite = map CT.hiWhite bold = map CT.bold underline = map CT.underline +-- invert the foreground and background colors +invert :: Pretty CT.ColorText -> Pretty CT.ColorText +invert = map CT.invert + +-- set the background color, ex: `background hiBlue`, `background yellow` +background :: (Pretty CT.ColorText -> Pretty CT.ColorText) -> Pretty CT.ColorText -> Pretty CT.ColorText +background f p = + -- hack: discover the color of `f` by calling it on a dummy string + case f (Pretty mempty (Lit "-")) of + Pretty _ (Lit (AT.AnnotatedText (toList -> [AT.Segment _ (Just c)]))) -> map (CT.background c) p + _ -> p + plural :: Foldable f => f a -> Pretty ColorText -> Pretty ColorText plural f p = case length f of