Add Semigroup instance for AnsiText (#2140)

`AnsiText` is a type that represents some text that can be printed with
`Ansi` formatting annotations, or as plain text. It is expected that it
should have a `Semigroup` instance. This pr adds that.

---------

Co-authored-by: Paul Cadman <git@paulcadman.dev>

app/Commands/Dev/Geb/Repl/Format.hs

@@ -37,4 +37,4 @@ normal :: Text -> Doc ReplStyle
 normal = annotate ReplNormal . pretty
 
 ppOutput :: Doc ReplStyle -> AnsiText
-ppOutput = AnsiText . ReplMessageDoc
+ppOutput = mkAnsiText . ReplMessageDoc

app/Commands/Format.hs

@@ -62,7 +62,7 @@ renderFormattedOutput target opts fInfo = do
   where
     outputResult :: FormatRenderMode -> Sem r ()
     outputResult = \case
-      EditInPlace i@(FormattedFileInfo {..}) ->
+      EditInPlace i@FormattedFileInfo {..} ->
         runTempFileIO $
           restoreFileOnError _formattedFileInfoPath $
             writeFile' _formattedFileInfoPath (i ^. formattedFileInfoContentsText)
@@ -80,5 +80,4 @@ runScopeFileApp = interpret $ \case
               _pathIsInput = False
             }
     runPipeline appFile upToScoping
-  ScopeStdin -> do
-    runPipelineNoFile upToScoping
+  ScopeStdin -> runPipelineNoFile upToScoping

app/Commands/Repl.hs

@@ -88,7 +88,7 @@ replError msg =
       }
 
 noFileLoadedErr :: Repl a
-noFileLoadedErr = replError (AnsiText @Text "No file loaded. Load a file using the `:load FILE` command.")
+noFileLoadedErr = replError (mkAnsiText @Text "No file loaded. Load a file using the `:load FILE` command.")
 
 welcomeMsg :: MonadIO m => m ()
 welcomeMsg = liftIO (putStrLn [i|Juvix REPL version #{versionTag}: https://juvix.org. Run :help for help|])
@@ -230,7 +230,7 @@ replParseIdentifiers input =
           _ -> err
           where
             err :: Repl a
-            err = replError (AnsiText @Text ":def expects one or more identifiers")
+            err = replError (mkAnsiText @Text ":def expects one or more identifiers")
 
 printDocumentation :: String -> Repl ()
 printDocumentation = replParseIdentifiers >=> printIdentifiers
@@ -257,7 +257,7 @@ printDocumentation = replParseIdentifiers >=> printIdentifiers
             printDoc = \case
               Nothing -> do
                 s' <- ppConcrete s
-                renderOut (AnsiText @Text "No documentation available for ")
+                renderOut (mkAnsiText @Text "No documentation available for ")
                 renderOutLn s'
               Just ju -> printConcrete ju
 
@@ -309,8 +309,7 @@ printDefinition = replParseIdentifiers >=> printIdentifiers
             printLocation def = do
               s' <- ppConcrete s
               let txt :: Text = " is " <> prettyText (nameKindWithArticle (getNameKind s)) <> " defined at " <> prettyText (getLoc def)
-              renderOut s'
-              renderOutLn (AnsiText txt)
+              renderOutLn (s' <> mkAnsiText txt)
 
             printFunction :: Scoped.NameId -> Repl ()
             printFunction fun = do

src/Juvix/Compiler/Abstract/Pretty.hs

@@ -10,10 +10,10 @@ import Juvix.Data.PPOutput
 import Juvix.Prelude
 
 ppOutDefault :: (PrettyCode c) => c -> AnsiText
-ppOutDefault = AnsiText . PPOutput . doc defaultOptions
+ppOutDefault = mkAnsiText . PPOutput . doc defaultOptions
 
 ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc (project o)
+ppOut o = mkAnsiText . PPOutput . doc (project o)
 
 ppTrace :: (PrettyCode c) => c -> Text
 ppTrace = toAnsiText True . ppOutDefault

src/Juvix/Compiler/Asm/Pretty.hs

@@ -13,10 +13,10 @@ import Juvix.Prelude
 import Prettyprinter.Render.Terminal qualified as Ansi
 
 ppOutDefault :: (PrettyCode c) => InfoTable -> c -> AnsiText
-ppOutDefault tab = AnsiText . PPOutput . doc (defaultOptions tab)
+ppOutDefault tab = mkAnsiText . PPOutput . doc (defaultOptions tab)
 
 ppOut :: (PrettyCode c) => Options -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc o
+ppOut o = mkAnsiText . PPOutput . doc o
 
 ppTrace' :: (PrettyCode c) => Options -> c -> Text
 ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc opts

src/Juvix/Compiler/Backend/Geb/Evaluator/Error.hs

@@ -27,7 +27,7 @@ instance ToGenericError EvalError where
     return
       GenericError
         { _genericErrorLoc = defaultLoc,
-          _genericErrorMessage = AnsiText (pack $ S.show e),
+          _genericErrorMessage = mkAnsiText (pack (S.show e)),
           _genericErrorIntervals = []
         }
 

src/Juvix/Compiler/Backend/Geb/Pretty.hs

@@ -13,10 +13,10 @@ import Juvix.Data.PPOutput
 import Prettyprinter.Render.Terminal qualified as Ansi
 
 ppOutDefault :: (HasAtomicity c, PrettyCode c) => c -> AnsiText
-ppOutDefault = AnsiText . PPOutput . doc defaultOptions
+ppOutDefault = mkAnsiText . PPOutput . doc defaultOptions
 
 ppOut :: (CanonicalProjection a Options, HasAtomicity c, PrettyCode c) => a -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc (project o)
+ppOut o = mkAnsiText . PPOutput . doc (project o)
 
 ppTrace' :: (CanonicalProjection a Options, HasAtomicity c, PrettyCode c) => a -> c -> Text
 ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc (project opts)
@@ -28,5 +28,5 @@ ppPrint :: (HasAtomicity c, PrettyCode c) => c -> Text
 ppPrint = show . ppOutDefault
 
 ppPrintLisp :: Text -> Text -> Morphism -> Object -> Text
-ppPrintLisp packageName entryName morph obj =
-  show $ AnsiText $ PPOutput $ docLisp defaultOptions packageName entryName morph obj
+ppPrintLisp packageName entryName morph =
+  show . mkAnsiText . PPOutput . docLisp defaultOptions packageName entryName morph

src/Juvix/Compiler/Backend/VampIR/Pretty.hs

@@ -13,10 +13,10 @@ import Juvix.Data.PPOutput
 import Prettyprinter.Render.Terminal qualified as Ansi
 
 ppOutDefault :: PrettyCode c => c -> AnsiText
-ppOutDefault = AnsiText . PPOutput . doc defaultOptions
+ppOutDefault = mkAnsiText . PPOutput . doc defaultOptions
 
 ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc (project o)
+ppOut o = mkAnsiText . PPOutput . doc (project o)
 
 ppTrace' :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> Text
 ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc (project opts)

src/Juvix/Compiler/Concrete/Pretty.hs

@@ -11,7 +11,7 @@ import Juvix.Data.PPOutput
 import Juvix.Prelude
 
 ppOutDefault :: (PrettyCode c) => c -> AnsiText
-ppOutDefault = AnsiText . PPOutput . doc defaultOptions
+ppOutDefault = mkAnsiText . PPOutput . doc defaultOptions
 
 ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc (project o)
+ppOut o = mkAnsiText . PPOutput . doc (project o)

src/Juvix/Compiler/Concrete/Print.hs

@@ -12,10 +12,10 @@ import Juvix.Data.PPOutput
 import Juvix.Prelude
 
 ppOutDefault :: (HasLoc c, PrettyPrint c) => Comments -> c -> AnsiText
-ppOutDefault cs = AnsiText . PPOutput . doc defaultOptions cs
+ppOutDefault cs = mkAnsiText . PPOutput . doc defaultOptions cs
 
 ppOut :: (CanonicalProjection a Options, PrettyPrint c, HasLoc c) => a -> Comments -> c -> AnsiText
-ppOut o cs = AnsiText . PPOutput . doc (project o) cs
+ppOut o cs = mkAnsiText . PPOutput . doc (project o) cs
 
 ppOutNoComments :: (CanonicalProjection a Options, PrettyPrint c, HasLoc c) => a -> c -> AnsiText
-ppOutNoComments o = AnsiText . PPOutput . doc (project o) emptyComments
+ppOutNoComments o = mkAnsiText . PPOutput . doc (project o) emptyComments

src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Pretty.hs

@@ -23,7 +23,7 @@ runPP :: Scoped.Options -> Sem '[Reader Scoped.Options] (Doc Scoped.Ann) -> Doc
 runPP opts = code . runPP' opts
 
 prettyError :: Doc Ann -> AnsiText
-prettyError = AnsiText . PPOutput
+prettyError = mkAnsiText . PPOutput
 
 ppSymbolT :: Text -> Doc Ann
 ppSymbolT = code . pretty

src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs

@@ -656,7 +656,7 @@ instance ToGenericError CaseBranchImplicitPattern where
     return
       GenericError
         { _genericErrorLoc = i,
-          _genericErrorMessage = AnsiText msg,
+          _genericErrorMessage = mkAnsiText msg,
           _genericErrorIntervals = [i]
         }
     where
@@ -681,7 +681,7 @@ instance ToGenericError ModuleDoesNotExportSymbol where
     return
       GenericError
         { _genericErrorLoc = i,
-          _genericErrorMessage = AnsiText msg,
+          _genericErrorMessage = mkAnsiText msg,
           _genericErrorIntervals = [i]
         }
     where
@@ -698,7 +698,7 @@ instance ToGenericError IteratorInitializer where
     return
       GenericError
         { _genericErrorLoc = i,
-          _genericErrorMessage = AnsiText ("Wrong number of iterator initializers" :: Doc Ann),
+          _genericErrorMessage = mkAnsiText ("Wrong number of iterator initializers" :: Doc Ann),
           _genericErrorIntervals = [i]
         }
     where
@@ -715,7 +715,7 @@ instance ToGenericError IteratorRange where
     return
       GenericError
         { _genericErrorLoc = i,
-          _genericErrorMessage = AnsiText ("Wrong number of iterator ranges" :: Doc Ann),
+          _genericErrorMessage = mkAnsiText ("Wrong number of iterator ranges" :: Doc Ann),
           _genericErrorIntervals = [i]
         }
     where
@@ -737,7 +737,7 @@ instance ToGenericError IteratorUndefined where
     return
       GenericError
         { _genericErrorLoc = i,
-          _genericErrorMessage = AnsiText msg,
+          _genericErrorMessage = mkAnsiText msg,
           _genericErrorIntervals = [i]
         }
     where

src/Juvix/Compiler/Core/Pretty.hs

@@ -13,10 +13,10 @@ import Juvix.Prelude
 import Prettyprinter.Render.Terminal qualified as Ansi
 
 ppOutDefault :: (PrettyCode c) => c -> AnsiText
-ppOutDefault = AnsiText . PPOutput . doc defaultOptions
+ppOutDefault = mkAnsiText . PPOutput . doc defaultOptions
 
 ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc (project o)
+ppOut o = mkAnsiText . PPOutput . doc (project o)
 
 ppTrace' :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> Text
 ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc (project opts)

src/Juvix/Compiler/Internal/Pretty.hs

@@ -14,10 +14,10 @@ import Prettyprinter.Render.Terminal qualified as Ansi
 import Prettyprinter.Render.Text (renderStrict)
 
 ppOutDefault :: (PrettyCode c) => c -> AnsiText
-ppOutDefault = AnsiText . PPOutput . doc defaultOptions
+ppOutDefault = mkAnsiText . PPOutput . doc defaultOptions
 
 ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
-ppOut o = AnsiText . PPOutput . doc (project o)
+ppOut o = mkAnsiText . PPOutput . doc (project o)
 
 ppTrace :: (PrettyCode c) => c -> Text
 ppTrace = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc traceOptions

src/Juvix/Data/PPOutput.hs

@@ -18,4 +18,4 @@ instance HasTextBackend PPOutput where
   toTextStream (PPOutput o) = layoutPretty defaultLayoutOptions (unAnnotate o)
 
 ppOutput :: Doc Ann -> AnsiText
-ppOutput = AnsiText . PPOutput
+ppOutput = mkAnsiText . PPOutput

src/Juvix/Parser/Error.hs

@@ -49,7 +49,7 @@ instance ToGenericError MegaparsecError where
     return
       GenericError
         { _genericErrorLoc = i,
-          _genericErrorMessage = AnsiText $ pretty @_ @AnsiStyle e,
+          _genericErrorMessage = mkAnsiText $ pretty @_ @AnsiStyle e,
           _genericErrorIntervals = [i]
         }
     where
@@ -67,7 +67,7 @@ instance ToGenericError TopModulePathError where
     return
       GenericError
         { _genericErrorLoc = i,
-          _genericErrorMessage = AnsiText msg,
+          _genericErrorMessage = mkAnsiText msg,
           _genericErrorIntervals = [i]
         }
     where
@@ -130,7 +130,7 @@ instance ToGenericError DanglingJudoc where
     return
       GenericError
         { _genericErrorLoc = i,
-          _genericErrorMessage = AnsiText msg,
+          _genericErrorMessage = mkAnsiText msg,
           _genericErrorIntervals = [i]
         }
     where

src/Juvix/Prelude/Pretty.hs

@@ -36,12 +36,25 @@ class HasTextBackend a where
 
   toTextDoc :: a -> Doc b
 
-data AnsiText = forall t.
+data AnsiTextAtom = forall t.
   (HasAnsiBackend t, HasTextBackend t) =>
-  AnsiText
-  { _ansiText :: t
+  AnsiTextAtom
+  { _ansiTextAtom :: t
   }
 
+newtype AnsiText = AnsiText
+  { _ansiTextAtoms :: [AnsiTextAtom]
+  }
+  deriving newtype (Semigroup, Monoid)
+
+mkAnsiText ::
+  (HasAnsiBackend t, HasTextBackend t) =>
+  t ->
+  AnsiText
+mkAnsiText = AnsiText . pure . AnsiTextAtom
+
+makeLenses ''AnsiText
+
 instance HasTextBackend Text where
   toTextStream = toTextStream . pretty
   toTextDoc = toTextDoc . pretty
@@ -49,13 +62,20 @@ instance HasTextBackend Text where
 instance HasAnsiBackend Text where
   toAnsiDoc = pretty
 
+instance HasTextBackend AnsiTextAtom where
+  toTextStream (AnsiTextAtom t) = toTextStream t
+  toTextDoc (AnsiTextAtom t) = toTextDoc t
+
+instance HasAnsiBackend AnsiTextAtom where
+  toAnsiStream (AnsiTextAtom t) = toAnsiStream t
+  toAnsiDoc (AnsiTextAtom t) = toAnsiDoc t
+
 instance HasTextBackend AnsiText where
-  toTextStream (AnsiText t) = toTextStream t
-  toTextDoc (AnsiText t) = toTextDoc t
+  toTextDoc :: AnsiText -> Doc b
+  toTextDoc (AnsiText l) = mconcatMap toTextDoc l
 
 instance HasAnsiBackend AnsiText where
-  toAnsiStream (AnsiText t) = toAnsiStream t
-  toAnsiDoc (AnsiText t) = toAnsiDoc t
+  toAnsiDoc (AnsiText l) = mconcatMap toAnsiDoc l
 
 instance HasTextBackend (Doc a) where
   toTextDoc = unAnnotate
@@ -65,11 +85,20 @@ instance HasAnsiBackend (Doc Ansi.AnsiStyle) where
   toAnsiDoc = id
   toAnsiStream = layoutPretty defaultLayoutOptions
 
+instance Show AnsiTextAtom where
+  show (AnsiTextAtom t) = unpack (Text.renderStrict (toTextStream t))
+
+instance Pretty AnsiTextAtom where
+  pretty (AnsiTextAtom t) = pretty (Text.renderStrict (toTextStream t))
+
+ansiTextToText :: AnsiText -> Text
+ansiTextToText = Text.renderStrict . layoutPretty defaultLayoutOptions . mconcatMap toAnsiDoc . (^. ansiTextAtoms)
+
 instance Show AnsiText where
-  show (AnsiText t) = unpack (Text.renderStrict (toTextStream t))
+  show = unpack . ansiTextToText
 
 instance Pretty AnsiText where
-  pretty (AnsiText t) = pretty (Text.renderStrict (toTextStream t))
+  pretty = pretty . ansiTextToText
 
 renderIO :: (HasAnsiBackend a, HasTextBackend a) => Bool -> a -> IO ()
 renderIO useColors = hRenderIO useColors stdout

test/Format.hs

@@ -20,7 +20,7 @@ root :: Path Abs Dir
 root = relToProject $(mkRelDir "tests/positive")
 
 renderCode :: (HasLoc a, P.PrettyPrint a) => P.Comments -> a -> Text
-renderCode c = prettyText . P.ppOutDefault c
+renderCode c = toPlainText . P.ppOutDefault c
 
 posTest :: String -> Path Rel Dir -> Path Rel File -> PosTest
 posTest _name rdir rfile =

test/Scope/Positive.hs

@@ -27,10 +27,10 @@ root :: Path Abs Dir
 root = relToProject $(mkRelDir "tests/positive")
 
 renderCodeOld :: M.PrettyCode c => c -> Text
-renderCodeOld = prettyText . M.ppOutDefault
+renderCodeOld = toPlainText . M.ppOutDefault
 
 renderCodeNew :: (HasLoc c, P.PrettyPrint c) => c -> Text
-renderCodeNew = prettyText . P.ppOutDefault emptyComments
+renderCodeNew = toPlainText . P.ppOutDefault emptyComments
 
 testDescr :: PosTest -> [TestDescr]
 testDescr PosTest {..} = helper renderCodeOld "" : [helper renderCodeNew " (with comments)"]