From 88c5dabb6d1c73372056d7d7925384acc46c1d4b Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 31 May 2023 09:53:08 +0200 Subject: [PATCH] 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 --- app/Commands/Dev/Geb/Repl/Format.hs | 2 +- app/Commands/Format.hs | 5 +- app/Commands/Repl.hs | 9 ++-- src/Juvix/Compiler/Abstract/Pretty.hs | 4 +- src/Juvix/Compiler/Asm/Pretty.hs | 4 +- .../Compiler/Backend/Geb/Evaluator/Error.hs | 2 +- src/Juvix/Compiler/Backend/Geb/Pretty.hs | 8 ++-- src/Juvix/Compiler/Backend/VampIR/Pretty.hs | 4 +- src/Juvix/Compiler/Concrete/Pretty.hs | 4 +- src/Juvix/Compiler/Concrete/Print.hs | 6 +-- .../Analysis/Scoping/Error/Pretty.hs | 2 +- .../Analysis/Scoping/Error/Types.hs | 10 ++-- src/Juvix/Compiler/Core/Pretty.hs | 4 +- src/Juvix/Compiler/Internal/Pretty.hs | 4 +- src/Juvix/Data/PPOutput.hs | 2 +- src/Juvix/Parser/Error.hs | 6 +-- src/Juvix/Prelude/Pretty.hs | 47 +++++++++++++++---- test/Format.hs | 2 +- test/Scope/Positive.hs | 4 +- 19 files changed, 78 insertions(+), 51 deletions(-) diff --git a/app/Commands/Dev/Geb/Repl/Format.hs b/app/Commands/Dev/Geb/Repl/Format.hs index 63593d1e7..c7a3282b9 100644 --- a/app/Commands/Dev/Geb/Repl/Format.hs +++ b/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 diff --git a/app/Commands/Format.hs b/app/Commands/Format.hs index 4c84e122b..83a487b5e 100644 --- a/app/Commands/Format.hs +++ b/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 diff --git a/app/Commands/Repl.hs b/app/Commands/Repl.hs index a55f26ca1..73721a30b 100644 --- a/app/Commands/Repl.hs +++ b/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 diff --git a/src/Juvix/Compiler/Abstract/Pretty.hs b/src/Juvix/Compiler/Abstract/Pretty.hs index 06f4e28af..90bd6a2ac 100644 --- a/src/Juvix/Compiler/Abstract/Pretty.hs +++ b/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 diff --git a/src/Juvix/Compiler/Asm/Pretty.hs b/src/Juvix/Compiler/Asm/Pretty.hs index c1c80ad7a..9fa1d33f5 100644 --- a/src/Juvix/Compiler/Asm/Pretty.hs +++ b/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 diff --git a/src/Juvix/Compiler/Backend/Geb/Evaluator/Error.hs b/src/Juvix/Compiler/Backend/Geb/Evaluator/Error.hs index 9c6da4e17..d8eb66f21 100644 --- a/src/Juvix/Compiler/Backend/Geb/Evaluator/Error.hs +++ b/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 = [] } diff --git a/src/Juvix/Compiler/Backend/Geb/Pretty.hs b/src/Juvix/Compiler/Backend/Geb/Pretty.hs index 51681bc14..bd4491fda 100644 --- a/src/Juvix/Compiler/Backend/Geb/Pretty.hs +++ b/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 diff --git a/src/Juvix/Compiler/Backend/VampIR/Pretty.hs b/src/Juvix/Compiler/Backend/VampIR/Pretty.hs index e42ff25aa..c226f8257 100644 --- a/src/Juvix/Compiler/Backend/VampIR/Pretty.hs +++ b/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) diff --git a/src/Juvix/Compiler/Concrete/Pretty.hs b/src/Juvix/Compiler/Concrete/Pretty.hs index d946c44fe..7b68f73a0 100644 --- a/src/Juvix/Compiler/Concrete/Pretty.hs +++ b/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) diff --git a/src/Juvix/Compiler/Concrete/Print.hs b/src/Juvix/Compiler/Concrete/Print.hs index 022a58558..0e43ace8b 100644 --- a/src/Juvix/Compiler/Concrete/Print.hs +++ b/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 diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Pretty.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Pretty.hs index 464de01bf..302efca00 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Pretty.hs +++ b/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 diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs index 700f695bf..42079432d 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs +++ b/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 diff --git a/src/Juvix/Compiler/Core/Pretty.hs b/src/Juvix/Compiler/Core/Pretty.hs index 36c5eb057..832120cd7 100644 --- a/src/Juvix/Compiler/Core/Pretty.hs +++ b/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) diff --git a/src/Juvix/Compiler/Internal/Pretty.hs b/src/Juvix/Compiler/Internal/Pretty.hs index 07508dce0..1601c6836 100644 --- a/src/Juvix/Compiler/Internal/Pretty.hs +++ b/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 diff --git a/src/Juvix/Data/PPOutput.hs b/src/Juvix/Data/PPOutput.hs index 7db77c5bb..86643bce1 100644 --- a/src/Juvix/Data/PPOutput.hs +++ b/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 diff --git a/src/Juvix/Parser/Error.hs b/src/Juvix/Parser/Error.hs index 82485ea66..319304dda 100644 --- a/src/Juvix/Parser/Error.hs +++ b/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 diff --git a/src/Juvix/Prelude/Pretty.hs b/src/Juvix/Prelude/Pretty.hs index 790e2c1bd..4e71d82e8 100644 --- a/src/Juvix/Prelude/Pretty.hs +++ b/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 diff --git a/test/Format.hs b/test/Format.hs index 74efde3b9..245e9cf3d 100644 --- a/test/Format.hs +++ b/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 = diff --git a/test/Scope/Positive.hs b/test/Scope/Positive.hs index f06003fd1..9b2e31cb3 100644 --- a/test/Scope/Positive.hs +++ b/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)"]