Remove the dependency on legacy ansi-wl-pprint

compiler/src/Reporting/Doc.hs

@@ -45,8 +45,11 @@ module Reporting.Doc
 
 import Prelude hiding (cycle)
 import qualified Data.List as List
+import Data.Maybe (isJust)
 import qualified Data.Name as Name
-import qualified System.Console.ANSI.Types as Ansi
+import qualified Data.Text as Text
+import qualified Prettyprinter as P (SimpleDocStream(..))
+import qualified Prettyprinter.Render.Terminal.Internal as Ansi
 import qualified System.Info as Info
 import System.IO (Handle)
 import qualified Text.PrettyPrint.ANSI.Leijen as P
@@ -269,20 +272,15 @@ isWindows =
 
 encode :: P.Doc -> E.Value
 encode doc =
-  E.array (toJsonHelp noStyle [] (P.renderPretty 1 80 doc))
+  E.array (toJsonHelp noStyle [] [] (P.renderPretty 1 80 doc))
 
 
-data Style =
-  Style
-    { _bold :: Bool
-    , _underline :: Bool
-    , _color :: Maybe Color
-    }
+type Style = Ansi.AnsiStyle
 
 
 noStyle :: Style
 noStyle =
-  Style False False Nothing
+  mempty
 
 
 data Color
@@ -304,8 +302,8 @@ data Color
   | WHITE
 
 
-toJsonHelp :: Style -> [String] -> P.SimpleDoc -> [E.Value]
-toJsonHelp style revChunks simpleDoc =
+toJsonHelp :: Style -> [Style] -> [String] -> P.SimpleDoc -> [E.Value]
+toJsonHelp style styles revChunks simpleDoc =
   case simpleDoc of
     P.SFail ->
       error $
@@ -316,63 +314,34 @@ toJsonHelp style revChunks simpleDoc =
       [ encodeChunks style revChunks ]
 
     P.SChar char rest ->
-      toJsonHelp style ([char] : revChunks) rest
+      toJsonHelp style styles ([char] : revChunks) rest
 
-    P.SText _ string rest ->
-      toJsonHelp style (string : revChunks) rest
+    P.SText _ text rest ->
+      toJsonHelp style styles (Text.unpack text : revChunks) rest
 
     P.SLine indent rest ->
-      toJsonHelp style (replicate indent ' ' : "\n" : revChunks) rest
-
-    P.SSGR sgrs rest ->
-      encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
-
-
-sgrToStyle :: [Ansi.SGR] -> Style -> Style
-sgrToStyle sgrs style@(Style bold underline color) =
-  case sgrs of
-    [] ->
-      style
-
-    sgr : rest ->
-      sgrToStyle rest $
-        case sgr of
-          Ansi.Reset                         -> noStyle
-          Ansi.SetConsoleIntensity i         -> Style (isBold i) underline color
-          Ansi.SetItalicized _               -> style
-          Ansi.SetUnderlining u              -> Style bold (isUnderline u) color
-          Ansi.SetBlinkSpeed _               -> style
-          Ansi.SetVisible _                  -> style
-          Ansi.SetSwapForegroundBackground _ -> style
-          Ansi.SetColor l i c                -> Style bold underline (toColor l i c)
-          Ansi.SetRGBColor _ _               -> style
-          Ansi.SetPaletteColor _ _           -> style
-          Ansi.SetDefaultColor _             -> style
-
-
-isBold :: Ansi.ConsoleIntensity -> Bool
-isBold intensity =
-  case intensity of
-    Ansi.BoldIntensity -> True
-    Ansi.FaintIntensity -> False
-    Ansi.NormalIntensity -> False
-
-
-isUnderline :: Ansi.Underlining -> Bool
-isUnderline underlining =
-  case underlining of
-    Ansi.SingleUnderline -> True
-    Ansi.DoubleUnderline -> False
-    Ansi.NoUnderline -> False
-
-
-toColor :: Ansi.ConsoleLayer -> Ansi.ColorIntensity -> Ansi.Color -> Maybe Color
-toColor layer intensity color =
-  case layer of
-    Ansi.Background ->
+      toJsonHelp style styles (replicate indent ' ' : "\n" : revChunks) rest
+
+    -- Annotations inherit the current style and restore it when popped.
+    P.SAnnPush annotation rest ->
+      encodeChunks style revChunks : toJsonHelp (annotation <> style) (style : styles) [] rest
+
+    P.SAnnPop rest ->
+      case styles of
+        outer : others ->
+          encodeChunks style revChunks : toJsonHelp outer others [] rest
+
+        [] ->
+          error "unbalanced annotation in rendered document"
+
+
+toColor :: Maybe (Ansi.Intensity, Ansi.Color) -> Maybe Color
+toColor foreground =
+  case foreground of
+    Nothing ->
       Nothing
 
-    Ansi.Foreground ->
+    Just (intensity, color) ->
       let
         pick dull vivid =
           case intensity of
@@ -392,8 +361,11 @@ toColor layer intensity color =
 
 
 encodeChunks :: Style -> [String] -> E.Value
-encodeChunks (Style bold underline color) revChunks =
+encodeChunks style revChunks =
   let
+    bold = isJust (Ansi.ansiBold style)
+    underline = isJust (Ansi.ansiUnderlining style)
+    color = toColor (Ansi.ansiForeground style)
     chars = concat (reverse revChunks)
   in
   case color of

elm.cabal

@@ -17,9 +17,10 @@ executable elm
         -- add -eventlog for (elm make src/Main.elm +RTS -l; threadscope elm.eventlog)
         -- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/
 
+    -- The compatibility module is deprecated by design.
+    ghc-options: -Wno-error=deprecations
+
     build-depends:
-        ansi-terminal,
-        ansi-wl-pprint < 1,
         base,
         binary,
         bytestring,
@@ -38,12 +39,16 @@ executable elm
         mtl,
         network,
         parsec,
+        prettyprinter,
+        prettyprinter-ansi-terminal,
+        prettyprinter-compat-ansi-wl-pprint >= 1.1,
         process,
         scientific,
         SHA,
         snap-core,
         snap-server,
         template-haskell,
+        text,
         time,
         unordered-containers,
         utf8-string,

worker/elm.cabal

@@ -153,10 +153,11 @@ executable worker
         Bytes
         Literals
 
+    -- The compatibility module is deprecated by design.
+    ghc-options: -Wno-error=deprecations
+
     Build-depends:
         aeson,
-        ansi-terminal >= 0.8,
-        ansi-wl-pprint >= 0.6.8 && < 1,
         base >=4.11 && <5,
         base64-bytestring,
         binary >= 0.8,
@@ -178,6 +179,9 @@ executable worker
         network >= 2.4,
         network-uri,
         parsec,
+        prettyprinter,
+        prettyprinter-ansi-terminal,
+        prettyprinter-compat-ansi-wl-pprint >= 1.1,
         process,
         random,
         scientific,