From 1333b40152d55317a76a636e1317e2793912556d Mon Sep 17 00:00:00 2001 From: Tommy Bidne Date: Wed, 29 May 2024 10:11:09 -0400 Subject: [PATCH] Swap Log's Text for UnlinedText --- src/Shrun.hs | 11 ++-- .../Data/ConsoleLogging/TimerFormat.hs | 16 ++++-- src/Shrun/Data/Text.hs | 54 +++++++++++++++++-- src/Shrun/IO.hs | 2 +- src/Shrun/Logging/Formatting.hs | 30 ++++++----- src/Shrun/Logging/Types.hs | 13 ++--- src/Shrun/Notify.hs | 11 ++-- src/Shrun/Notify/MonadAppleScript.hs | 4 +- src/Shrun/Notify/MonadDBus.hs | 4 +- src/Shrun/Notify/MonadNotify.hs | 13 ++--- src/Shrun/Notify/MonadNotifySend.hs | 4 +- src/Shrun/Utils.hs | 39 ++++---------- test/unit/Unit/Generators.hs | 6 +++ test/unit/Unit/Shrun/Logging/Formatting.hs | 46 ++++++++++------ test/unit/Unit/Shrun/Logging/Generators.hs | 8 +-- test/unit/Unit/Shrun/Utils.hs | 4 +- 16 files changed, 162 insertions(+), 103 deletions(-) diff --git a/src/Shrun.hs b/src/Shrun.hs index acef8863..aefaaeb5 100644 --- a/src/Shrun.hs +++ b/src/Shrun.hs @@ -9,7 +9,6 @@ where import DBus.Notify (UrgencyLevel (Critical, Normal)) import Data.HashSet qualified as Set -import Data.Text qualified as T import Effects.Concurrent.Async qualified as Async import Effects.Concurrent.Thread as X (microsleep, sleep) import Effects.Time (TimeSpec, withTiming) @@ -177,7 +176,8 @@ runCommand cmd = do -- see NOTE: [Text Line Concatentation] for how we combine the -- multiple texts back into a single err. CommandFailure t (MkStderr errs) -> - (Critical, ": " <> ShrunText.toText errs, LevelError, t) + let errMsg = ShrunText.concat errs + in (Critical, ": " <> errMsg, LevelError, t) CommandSuccess t -> (Normal, "", LevelSuccess, t) timeMsg = TimerFormat.formatRelativeTime timerFormat timeElapsed <> msg' @@ -225,7 +225,7 @@ printFinalResult totalTime result = withRegion Linear $ \r -> do mconcat [ "Encountered an exception. This is likely not an error in any ", "of the commands run but rather an error in Shrun itself: ", - displayExceptiont ex + ShrunText.fromTextReplace $ displayExceptiont ex ] fatalLog = MkLog @@ -351,7 +351,10 @@ keepRunning region timer mto = do allCmdsSet = Set.fromList $ toList allCmds incompleteCmds = Set.difference allCmdsSet completedCommandsSet toTxtList acc cmd = LogFmt.displayCmd cmd keyHide : acc - unfinishedCmds = T.intercalate ", " $ foldl' toTxtList [] incompleteCmds + + unfinishedCmds = + ShrunText.intercalate ", " + $ foldl' toTxtList [] incompleteCmds Logging.putRegionLog region $ MkLog diff --git a/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs b/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs index b3ffa1b7..16fc9f65 100644 --- a/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs +++ b/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs @@ -26,6 +26,7 @@ import Data.Time.Relative ) import Data.Time.Relative qualified as RT import Shrun.Configuration.Default (Default (def)) +import Shrun.Data.Text (UnlinedText (UnsafeUnlinedText)) import Shrun.Prelude -- | Determines how to format the timer. @@ -56,15 +57,22 @@ parseTimerFormat getTxt = timerFormatStr :: (IsString a) => a timerFormatStr = "(digital_compact | digital_full | prose_compact | prose_full)" +-- NOTE: Time formatting does not include newlines, so using UnsafeUnlinedText +-- is safe. We use the constructor rather than unsafeUnlinedText. + -- | Formats a relative time. -formatRelativeTime :: TimerFormat -> RelativeTime -> Text +formatRelativeTime :: TimerFormat -> RelativeTime -> UnlinedText formatRelativeTime fmt = - T.pack . RT.formatRelativeTime (toRelativeTimeFormat fmt) + UnsafeUnlinedText + . T.pack + . RT.formatRelativeTime (toRelativeTimeFormat fmt) -- | Formats a relative time seconds. -formatSeconds :: TimerFormat -> Natural -> Text +formatSeconds :: TimerFormat -> Natural -> UnlinedText formatSeconds fmt = - T.pack . RT.formatSeconds (toRelativeTimeFormat fmt) + UnsafeUnlinedText + . T.pack + . RT.formatSeconds (toRelativeTimeFormat fmt) toRelativeTimeFormat :: TimerFormat -> Format toRelativeTimeFormat DigitalCompact = MkFormat FormatStyleDigital FormatVerbosityCompact diff --git a/src/Shrun/Data/Text.hs b/src/Shrun/Data/Text.hs index 3bc5325c..e41fa151 100644 --- a/src/Shrun/Data/Text.hs +++ b/src/Shrun/Data/Text.hs @@ -2,11 +2,23 @@ module Shrun.Data.Text ( UnlinedText (..), + + -- * Creation fromText, + fromTextReplace, + unsafeUnlinedText, + + -- * Elimination toText, + + -- * Functions + concat, + intercalate, + reallyUnsafeLiftUnlined, ) where +import Data.String (IsString (fromString)) import Data.Text qualified as T import Shrun.Prelude @@ -17,12 +29,19 @@ import Shrun.Prelude -- separately. -- -- In exceptional cases (e.g. command names), we may choose to combine the --- list back into a single text, according to some logic. This is also handled --- here via the pattern synonym. +-- list back into a single text, according to some logic. +-- +-- The constructor 'UnsafeUnlinedText' should only be used when we __know__ +-- the text has no newlines and performance means a branch is undesirable +-- (e.g. streaming). If there is no performance impact, consider +-- 'unsafeUnlinedText' instead. newtype UnlinedText = UnsafeUnlinedText {unUnlinedText :: Text} deriving stock (Eq, Show) deriving (Monoid, Semigroup) via Text +instance IsString UnlinedText where + fromString = fromTextReplace . pack + instance ( k ~ A_Getter, a ~ Text, @@ -33,10 +52,23 @@ instance labelOptic = to (\(UnsafeUnlinedText ts) -> ts) {-# INLINE labelOptic #-} +-- | Creates a list of 'UnlinedText'. fromText :: Text -> List UnlinedText fromText = fmap UnsafeUnlinedText . T.lines --- NOTE: [Text Line Concatentation] +-- | Creates a single 'UnlinedText' by replacing newlines with +-- whitespace. +fromTextReplace :: Text -> UnlinedText +fromTextReplace = UnsafeUnlinedText . T.replace "\n" " " + +-- | Unsafe creation that throws error when the text contains newline(s). +unsafeUnlinedText :: (HasCallStack) => Text -> UnlinedText +unsafeUnlinedText txt = + if '\n' `T.elem` txt + then error $ "Unwanted newline in text: " <> unpack txt + else UnsafeUnlinedText txt + +-- NOTE: [Text Line Concatenation] -- -- Normally, we log multiple newlines separately. However in at least one -- case, we want a single log: final error message. Why? Because we want @@ -51,3 +83,19 @@ fromText = fmap UnsafeUnlinedText . T.lines -- in the final output. toText :: List UnlinedText -> Text toText = T.intercalate " " . fmap (view #unUnlinedText) + +-- | Concats via 'toText'. +concat :: List UnlinedText -> UnlinedText +concat = UnsafeUnlinedText . toText + +intercalate :: UnlinedText -> List UnlinedText -> UnlinedText +intercalate (UnsafeUnlinedText d) = + UnsafeUnlinedText + . T.intercalate d + . fmap (view #unUnlinedText) + +-- | Lifts a 'Text' function to 'UnlinedText'. Very unsafe in that we do not +-- check for errors i.e. if the parameter function introduces any newlines, +-- then this will silently succeed. This exists for performance. +reallyUnsafeLiftUnlined :: (Text -> Text) -> UnlinedText -> UnlinedText +reallyUnsafeLiftUnlined f (UnsafeUnlinedText t) = UnsafeUnlinedText (f t) diff --git a/src/Shrun/IO.hs b/src/Shrun/IO.hs index 1a939f94..49442657 100644 --- a/src/Shrun/IO.hs +++ b/src/Shrun/IO.hs @@ -389,7 +389,7 @@ writeLogHelper logFn cmd lastReadRef handleResult messages = do logFn $ MkLog { cmd = Just cmd, - msg = msg ^. #unUnlinedText, + msg, lvl = LevelCommand, mode = LogModeSet } diff --git a/src/Shrun/Logging/Formatting.hs b/src/Shrun/Logging/Formatting.hs index f4d057b3..da4fd551 100644 --- a/src/Shrun/Logging/Formatting.hs +++ b/src/Shrun/Logging/Formatting.hs @@ -38,6 +38,8 @@ import Shrun.Configuration.Data.Truncation Truncation (MkTruncation), ) import Shrun.Data.Command (CommandP (MkCommandP), CommandP1) +import Shrun.Data.Text (UnlinedText) +import Shrun.Data.Text qualified as ShrunText import Shrun.Logging.Types ( Log, LogLevel @@ -150,7 +152,7 @@ coreFormatting :: Log -> Text coreFormatting mLineTrunc mCommandNameTrunc stripControl keyHide log = - concatWithLineTrunc mLineTrunc prefix msgStripped + concatWithLineTrunc mLineTrunc prefix (msgStripped ^. #unUnlinedText) where -- prefix is something like "[Success] " or "[Command][some cmd] ". -- Notice this does not include ANSI codes or a timestamp. @@ -164,7 +166,7 @@ coreFormatting mLineTrunc mCommandNameTrunc stripControl keyHide log = cmd in mconcat [ brackets False logPrefix, - cmd' + cmd' ^. #unUnlinedText ] msgStripped = stripChars (log ^. #msg) stripControl @@ -174,13 +176,13 @@ formatCommand :: KeyHideSwitch -> Maybe (Truncation TruncCommandName) -> CommandP1 -> - Text -formatCommand keyHide commandNameTrunc com = brackets True (truncateNameFn cmdName) + UnlinedText +formatCommand keyHide commandNameTrunc com = + ShrunText.reallyUnsafeLiftUnlined (brackets True . truncateNameFn) cmdName where -- Get cmd name to display. Always strip control sequences. Futhermore, -- strip leading/trailing whitespace. - cmdName = - formatCommandText $ displayCmd com keyHide + cmdName = displayCmd com keyHide -- truncate cmd/name if necessary truncateNameFn = @@ -190,11 +192,11 @@ formatCommand keyHide commandNameTrunc com = brackets True (truncateNameFn cmdNa -- | Replace newlines with whitespace before stripping, so any strings -- separated by newlines do not get smashed together. -formatCommandText :: Text -> Text +formatCommandText :: Text -> UnlinedText formatCommandText = - T.strip + ShrunText.reallyUnsafeLiftUnlined T.strip . Utils.stripControlAll - . T.replace "\n" " " + . ShrunText.fromTextReplace -- | Combines a prefix @p@ and msg @m@ with possible line truncation. If no -- truncation is given then concatWithLineTrunc is equivalent to @p <> m@. @@ -240,20 +242,20 @@ concatWithLineTrunc (Just (MkTruncation lineTrunc, mPrefixLen)) prefix msg = -- -- >>> displayCmd (MkCommandP (Just "long") "some long command") KeyHideOff -- "long" -displayCmd :: CommandP1 -> KeyHideSwitch -> Text -displayCmd (MkCommandP (Just key) _) KeyHideOff = key -displayCmd (MkCommandP _ cmd) _ = cmd +displayCmd :: CommandP1 -> KeyHideSwitch -> UnlinedText +displayCmd (MkCommandP (Just key) _) KeyHideOff = formatCommandText key +displayCmd (MkCommandP _ cmd) _ = formatCommandText cmd -- | Applies the given 'StripControl' to the 'Text'. -- -- * 'StripControlAll': Strips whitespace + all control chars. -- * 'StripControlSmart': Strips whitespace + 'ansi control' chars. -- * 'StripControlNone': Strips whitespace. -stripChars :: Text -> StripControl t -> Text +stripChars :: UnlinedText -> StripControl t -> UnlinedText stripChars txt = \case StripControlAll -> Utils.stripControlAll txt -- whitespace - StripControlNone -> T.strip txt + StripControlNone -> ShrunText.reallyUnsafeLiftUnlined T.strip txt StripControlSmart -> Utils.stripControlSmart txt {-# INLINE stripChars #-} diff --git a/src/Shrun/Logging/Types.hs b/src/Shrun/Logging/Types.hs index a1dfcfb4..ebcc4e43 100644 --- a/src/Shrun/Logging/Types.hs +++ b/src/Shrun/Logging/Types.hs @@ -17,6 +17,7 @@ module Shrun.Logging.Types where import Shrun.Data.Command (CommandP1) +import Shrun.Data.Text (UnlinedText) import Shrun.Logging.Types.Internal ( ConsoleLog, FileLog, @@ -46,19 +47,13 @@ data LogRegion r | -- | Log without region. LogNoRegion ConsoleLog --- NOTE: [Log UnlinedText] --- --- It would be nice if msg was UnlinedText, so then formatting --- could share the proof that lines have been stripped. Unfortunately this is --- non-trivial. See NOTE: [StripControl Newlines]. - -- | Captures the relevant information concerning a specific log -- (i.e. command, text, level, and mode). data Log = MkLog { -- | Optional command that produced this log. cmd :: Maybe CommandP1, -- | The 'Text' for a given log. - msg :: Text, + msg :: UnlinedText, -- | The 'LogLevel' for a given log. lvl :: LogLevel, -- | The 'LogMode' for a given log. @@ -84,8 +79,8 @@ instance instance ( k ~ A_Lens, - a ~ Text, - b ~ Text + a ~ UnlinedText, + b ~ UnlinedText ) => LabelOptic "msg" k Log Log a b where diff --git a/src/Shrun/Notify.hs b/src/Shrun/Notify.hs index bec5d9bb..195f25ce 100644 --- a/src/Shrun/Notify.hs +++ b/src/Shrun/Notify.hs @@ -5,7 +5,6 @@ module Shrun.Notify where import DBus.Notify (UrgencyLevel) -import Data.Text qualified as T import Shrun.Configuration.Env.Types ( HasAnyError, HasCommonLogging, @@ -14,6 +13,8 @@ import Shrun.Configuration.Env.Types HasNotifyConfig (getNotifyConfig), setAnyErrorTrue, ) +import Shrun.Data.Text (UnlinedText) +import Shrun.Data.Text qualified as ShrunText import Shrun.Logging qualified as Logging import Shrun.Logging.MonadRegionLogger (MonadRegionLogger (Region, withRegion)) import Shrun.Logging.Types @@ -43,9 +44,9 @@ sendNotif :: MonadTime m ) => -- | Notif summary - Text -> + UnlinedText -> -- | Notif body - Text -> + UnlinedText -> -- | Notif urgency UrgencyLevel -> m () @@ -64,7 +65,9 @@ sendNotif summary body urgency = do Logging.putRegionLog r $ MkLog { cmd = Nothing, - msg = "Could not send notification: " <> T.pack (displayException ex), + msg = + "Could not send notification: " + <> ShrunText.fromTextReplace (pack (displayException ex)), lvl = LevelError, mode = LogModeFinish } diff --git a/src/Shrun/Notify/MonadAppleScript.hs b/src/Shrun/Notify/MonadAppleScript.hs index 5b749495..a3e45864 100644 --- a/src/Shrun/Notify/MonadAppleScript.hs +++ b/src/Shrun/Notify/MonadAppleScript.hs @@ -46,10 +46,10 @@ shrunToAppleScript shrunNote = txt txt = mconcat [ "osascript -e 'display notification ", - withDoubleQuotes (shrunNote ^. #body), + withDoubleQuotes (shrunNote ^. #body % #unUnlinedText), " with title \"Shrun\" ", " subtitle ", - withDoubleQuotes (shrunNote ^. #summary), + withDoubleQuotes (shrunNote ^. #summary % #unUnlinedText), "'" ] diff --git a/src/Shrun/Notify/MonadDBus.hs b/src/Shrun/Notify/MonadDBus.hs index 4acd5e44..dabcb266 100644 --- a/src/Shrun/Notify/MonadDBus.hs +++ b/src/Shrun/Notify/MonadDBus.hs @@ -54,8 +54,8 @@ shrunToDBus :: ShrunNote -> Note shrunToDBus shrunNote = DBusN.Note { appName = "Shrun", - summary = unpack $ shrunNote ^. #summary, - body = Just . DBusN.Text . T.unpack $ shrunNote ^. #body, + summary = unpack $ shrunNote ^. #summary % #unUnlinedText, + body = Just . DBusN.Text . T.unpack $ shrunNote ^. #body % #unUnlinedText, appImage = Nothing, hints = [Urgency (shrunNote ^. #urgency)], expiry, diff --git a/src/Shrun/Notify/MonadNotify.hs b/src/Shrun/Notify/MonadNotify.hs index b02975cb..78d30d51 100644 --- a/src/Shrun/Notify/MonadNotify.hs +++ b/src/Shrun/Notify/MonadNotify.hs @@ -12,6 +12,7 @@ where import DBus.Notify (UrgencyLevel) import Data.ByteString.Lazy qualified as BSL import Data.Text qualified as T +import Shrun.Data.Text (UnlinedText) import Shrun.Notify.Types ( NotifySystemMerged, NotifyTimeout, @@ -21,8 +22,8 @@ import Shrun.Prelude -- | Holds notification data. data ShrunNote = MkShrunNote - { summary :: Text, - body :: Text, + { summary :: UnlinedText, + body :: UnlinedText, urgency :: UrgencyLevel, timeout :: NotifyTimeout } @@ -30,8 +31,8 @@ data ShrunNote = MkShrunNote instance ( k ~ A_Lens, - a ~ Text, - b ~ Text + a ~ UnlinedText, + b ~ UnlinedText ) => LabelOptic "summary" k ShrunNote ShrunNote a b where @@ -78,8 +79,8 @@ instance instance ( k ~ A_Lens, - a ~ Text, - b ~ Text + a ~ UnlinedText, + b ~ UnlinedText ) => LabelOptic "body" k ShrunNote ShrunNote a b where diff --git a/src/Shrun/Notify/MonadNotifySend.hs b/src/Shrun/Notify/MonadNotifySend.hs index 4f07247b..420b6ba0 100644 --- a/src/Shrun/Notify/MonadNotifySend.hs +++ b/src/Shrun/Notify/MonadNotifySend.hs @@ -75,8 +75,8 @@ shrunToNotifySend shrunNote = txt -- -- only required escaping the summary, but we do the same to the body out -- of paranoia. - summary = Utils.escapeDoubleQuotes $ shrunNote ^. #summary - body = Utils.escapeDoubleQuotes $ shrunNote ^. #body + summary = Utils.escapeDoubleQuotes $ shrunNote ^. #summary % #unUnlinedText + body = Utils.escapeDoubleQuotes $ shrunNote ^. #body % #unUnlinedText ulToNS Low = " --urgency low " ulToNS Normal = " --urgency normal " diff --git a/src/Shrun/Utils.hs b/src/Shrun/Utils.hs index 19c9d56c..80bd5982 100644 --- a/src/Shrun/Utils.hs +++ b/src/Shrun/Utils.hs @@ -36,6 +36,8 @@ import Data.Text.Lazy.Builder qualified as TLB import Data.Time.Relative (RelativeTime, fromSeconds) import Effects.Time (TimeSpec, diffTimeSpec) import GHC.Exts (IsList (fromList)) +import Shrun.Data.Text (UnlinedText) +import Shrun.Data.Text qualified as ShrunText import Shrun.Prelude import Text.Read (Read) import Text.Read qualified as TR @@ -143,35 +145,15 @@ n2i = unsafeConvertIntegral -- -- Applying stripControl to text that has newlines in it can produce poorly -- formatted text. This is due to newlines being stripped, so e.g. t1\nt2 --- becomes t1t2. We could instead perform a first pass that at least replaces --- newlines with whitespace. So why don't we? --- --- Because we should already be handling newlines elsewhere. When streaming --- command logs, we split logs on newlines and then log each newline-free --- log separately. Morally these are UnlinedText from Shrun.Data.Text. --- It would be really nice if we could make the input here UnlinedText, so we --- get actual proof that we are maintaining this invariant. Alas, this would --- require changing the Log type from Text to UnlinedText, which is quite --- invasive. This is probably worth doing, but for now we just make a note of --- it. See NOTE: [Log UnlinedText]. --- --- Note that there is one instance where the text-to-strip is not morally --- UnlinedText: the final error message in: --- --- [Error][cmd] 2 seconds: some error message --- --- 'some error message' is (List UnlinedText) that is recombined with --- whitespace so it _should_ be newline free. But again, it would be nice --- to carry the UnlinedText proof around. +-- becomes t1t2. Hence we require 'UnlinedText'. --- | Strips all control chars, including ansi escape sequences. Leading --- and trailing whitespace is also stripped. +-- | Strips all control chars, including ansi escape sequences. -- -- ==== __Examples__ -- -- >>> stripControlAll "foo\ESC[0;3Abar \n baz" -- "foobar baz" -stripControlAll :: Text -> Text +stripControlAll :: UnlinedText -> UnlinedText stripControlAll = -- The ansi stripping must come first. For example, if we strip control -- chars from "\ESC[0;3mfoo" we get "0;3mfoo", and then stripAnsiAll will @@ -180,11 +162,10 @@ stripControlAll = -- -- By performing stripAnsiAll first, we remove entire ansi sequences, -- then remove other control chars (e.g. newlines, tabs). - T.filter (not . isControl) . stripAnsiAll + ShrunText.reallyUnsafeLiftUnlined (T.filter (not . isControl) . stripAnsiAll) --- | Strips control chars, including most ansi escape sequences. Leading and --- trailing whitespace is also stripped. We leave behind SGR ansi escape --- sequences e.g. text coloring. See +-- | Strips control chars, including most ansi escape sequences. We leave +-- behind SGR ansi escape sequences e.g. text coloring. See -- https://en.wikipedia.org/wiki/ANSI_escape_code#SGR_(Select_Graphic_Rendition)_parameters. -- -- ==== __Examples__ @@ -194,12 +175,12 @@ stripControlAll = -- -- >>> stripControlSmart "foo\ESC[0;3mbar \n baz" -- "foo\ESC[0;3mbar baz" -stripControlSmart :: Text -> Text +stripControlSmart :: UnlinedText -> UnlinedText stripControlSmart = -- Like 'stripControlAll', we need to handle the ansi sequences first. -- Because we actually leave some sequences behind, we need to be more -- surgical removing the rest of the control chars (e.g. newline, tabs). - T.filter ctrlToFilter . stripAnsiControl + ShrunText.reallyUnsafeLiftUnlined (T.filter ctrlToFilter . stripAnsiControl) where -- stripAnsiControl should be handling all \ESC sequences, so we should -- be safe to ignore these, accomplishing our goal of preserving the SGR diff --git a/test/unit/Unit/Generators.hs b/test/unit/Unit/Generators.hs index 87905f1d..6de315d2 100644 --- a/test/unit/Unit/Generators.hs +++ b/test/unit/Unit/Generators.hs @@ -5,6 +5,7 @@ module Unit.Generators genTimeSpec, genInt, genText, + genUnlinedText, getNonEmptyText, ) where @@ -12,6 +13,8 @@ where import Effects.Time (TimeSpec (MkTimeSpec)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range +import Shrun.Data.Text (UnlinedText) +import Shrun.Data.Text qualified as ShrunText import Unit.Prelude -- | Generates 'NonNegative' in [0, 1_000_000]. @@ -41,6 +44,9 @@ genText = Gen.text range Gen.latin1 where range = Range.linearFrom 0 0 30 +genUnlinedText :: Gen UnlinedText +genUnlinedText = ShrunText.fromTextReplace <$> genText + -- | Generates latin1 text with 1-30 characters. getNonEmptyText :: Gen Text getNonEmptyText = Gen.text range Gen.latin1 diff --git a/test/unit/Unit/Shrun/Logging/Formatting.hs b/test/unit/Unit/Shrun/Logging/Formatting.hs index 5352c3c1..441e220a 100644 --- a/test/unit/Unit/Shrun/Logging/Formatting.hs +++ b/test/unit/Unit/Shrun/Logging/Formatting.hs @@ -58,6 +58,8 @@ import Shrun.Configuration.Data.StripControl ), ) import Shrun.Data.Command (CommandP (MkCommandP, command, key)) +import Shrun.Data.Text (UnlinedText) +import Shrun.Data.Text qualified as ShrunText import Shrun.Logging.Formatting qualified as Formatting import Shrun.Logging.Types ( Log (MkLog, cmd, lvl, mode, msg), @@ -101,8 +103,11 @@ testFormatsCLNoCmd = testPropertyNamed desc "testFormatsConsoleLogNoCmd" $ prope for_ (L.zip3 lvls prefixes suffixes) $ \(lvl, prefix, suffix) -> do let log = set' #lvl lvl baseLog - -- StripControlNone -> T.strip (whitespace) - expected = prefix <> T.strip (log ^. #msg) <> suffix + -- NOTE: Convoluted, so here's an explanation. The msg <> suffix is + -- an UnlinedText. In order for it to match the expectation, it needs + -- to go through the usual process i.e. strip. Then we need to + -- eliminate to Text, to compare against the result. + expected = (prefix <> (stripUnlined (log ^. #msg) <> suffix)) ^. #unUnlinedText result = fmt log ^. #unConsoleLog expected === result where @@ -119,6 +124,9 @@ testFormatsCLNoCmd = testPropertyNamed desc "testFormatsConsoleLogNoCmd" $ prope ] suffixes = L.repeat "\ESC[0m" + stripUnlined :: UnlinedText -> UnlinedText + stripUnlined = ShrunText.reallyUnsafeLiftUnlined T.strip + testFormatsCLCmdKey :: TestTree testFormatsCLCmdKey = testPropertyNamed desc "testFormatsCLCmdKey" $ property $ do baseLog <- forAll LGens.genLogNoCmd @@ -143,9 +151,9 @@ testFormatsCLCmdKey = testPropertyNamed desc "testFormatsCLCmdKey" $ property $ expectedKeyHideOff = mconcat [ prefix, - Formatting.formatCommandText cmdKey, + Formatting.formatCommandText cmdKey ^. #unUnlinedText, "] ", - T.strip (log ^. #msg), + T.strip (log ^. #msg % #unUnlinedText), suffix ] resultKeyHideOff = fmtKeyHideOff log ^. #unConsoleLog @@ -153,9 +161,9 @@ testFormatsCLCmdKey = testPropertyNamed desc "testFormatsCLCmdKey" $ property $ expectedKeyHideOn = mconcat [ prefix, - Formatting.formatCommandText command, + Formatting.formatCommandText command ^. #unUnlinedText, "] ", - T.strip (log ^. #msg), + T.strip (log ^. #msg % #unUnlinedText), suffix ] resultKeyHideOn = fmtKeyHideOn log ^. #unConsoleLog @@ -199,9 +207,9 @@ testFormatsCLCmdNoKey = testPropertyNamed desc "testFormatsCLCmdNoKey" $ propert expected = mconcat [ prefix, - Formatting.formatCommandText command, + Formatting.formatCommandText command ^. #unUnlinedText, "] ", - T.strip (log ^. #msg), + T.strip (log ^. #msg % #unUnlinedText), suffix ] result = fmt log ^. #unConsoleLog @@ -322,7 +330,7 @@ testFormatsFLNoCmd = testPropertyNamed desc "testFormatsFLNoCmd" $ property $ do for_ (L.zip3 lvls prefixes suffixes) $ \(lvl, prefix, suffix) -> do let log = set' #lvl lvl baseLog -- StripControlNone -> T.strip (whitespace) - expected = prefix <> T.strip (log ^. #msg) <> suffix + expected = prefix <> T.strip (log ^. #msg % #unUnlinedText) <> suffix result = fmt log expected === result where @@ -365,9 +373,9 @@ testFormatsFLCmdKey = testPropertyNamed desc "testFormatsFLCmdKey" $ property $ expectedKeyHideOff = mconcat [ prefix, - Formatting.formatCommandText cmdKey, + Formatting.formatCommandText cmdKey ^. #unUnlinedText, "] ", - T.strip (log ^. #msg), + T.strip (log ^. #msg % #unUnlinedText), suffix ] resultKeyHideOff = fmtKeyHideOff log @@ -375,9 +383,9 @@ testFormatsFLCmdKey = testPropertyNamed desc "testFormatsFLCmdKey" $ property $ expectedKeyHideOn = mconcat [ prefix, - Formatting.formatCommandText command, + Formatting.formatCommandText command ^. #unUnlinedText, "] ", - T.strip (log ^. #msg), + T.strip (log ^. #msg % #unUnlinedText), suffix ] resultKeyHideOn = fmtKeyHideOn log @@ -422,9 +430,9 @@ testFormatsFLCmdNoKey = testPropertyNamed desc "testFormatsFLCmdNoKey" $ propert expected = mconcat [ prefix, - Formatting.formatCommandText command, + Formatting.formatCommandText command ^. #unUnlinedText, "] ", - T.strip (log ^. #msg), + T.strip (log ^. #msg % #unUnlinedText), suffix ] result = fmt log @@ -570,11 +578,15 @@ stripNone = where stripNone' = flip Formatting.stripChars StripControlNone +-- NOTE: For the below instances, the RHS is UnlinedText, so it uses its +-- IsString instance. That instance replaces newlines with whitespace, hence, +-- for instance, " \n " transforming to 3 spaces " ". + stripAll :: TestTree stripAll = testCase "StripControlAll should strip whitespace + all control" $ do "" @=? stripAll' "" - " oo bar baz " @=? stripAll' " \n \ESC[ foo \ESC[A \ESC[K bar \n baz \t " + " oo bar baz " @=? stripAll' " \n \ESC[ foo \ESC[A \ESC[K bar \n baz \t " where stripAll' = flip Formatting.stripChars StripControlAll @@ -582,6 +594,6 @@ stripSmart :: TestTree stripSmart = testCase "StripControlSmart should strip whitespace + some control" $ do "" @=? stripSmart' "" - " foo \ESC[m bar baz " @=? stripSmart' " \n \ESC[G foo \ESC[m \ESC[X bar \n baz \t " + " foo \ESC[m bar baz " @=? stripSmart' " \n \ESC[G foo \ESC[m \ESC[X bar \n baz \t " where stripSmart' = flip Formatting.stripChars StripControlSmart diff --git a/test/unit/Unit/Shrun/Logging/Generators.hs b/test/unit/Unit/Shrun/Logging/Generators.hs index eae0480f..bfe1804a 100644 --- a/test/unit/Unit/Shrun/Logging/Generators.hs +++ b/test/unit/Unit/Shrun/Logging/Generators.hs @@ -29,7 +29,7 @@ import Unit.Prelude genLog :: Gen Log genLog = do cmd <- HGen.choice [pure Nothing, fmap Just genCommand] - msg <- PGens.genText + msg <- PGens.genUnlinedText lvl <- genLogLevel mode <- genLogMode pure @@ -43,7 +43,7 @@ genLog = do genLogWithCmd :: Gen Log genLogWithCmd = do cmd <- Just <$> genCommand - msg <- PGens.genText + msg <- PGens.genUnlinedText lvl <- genLogLevel mode <- genLogMode pure @@ -57,7 +57,7 @@ genLogWithCmd = do genLogWithCmdKey :: Gen Log genLogWithCmdKey = do cmd <- Just <$> genCommandWithKey - msg <- PGens.genText + msg <- PGens.genUnlinedText lvl <- genLogLevel mode <- genLogMode pure @@ -70,7 +70,7 @@ genLogWithCmdKey = do genLogNoCmd :: Gen Log genLogNoCmd = do - msg <- PGens.genText + msg <- PGens.genUnlinedText lvl <- genLogLevel mode <- genLogMode pure diff --git a/test/unit/Unit/Shrun/Utils.hs b/test/unit/Unit/Shrun/Utils.hs index e6af4bc7..ec2f7499 100644 --- a/test/unit/Unit/Shrun/Utils.hs +++ b/test/unit/Unit/Shrun/Utils.hs @@ -90,7 +90,7 @@ allControlStripped = "" @=? U.stripControlAll "\ESC[A" "foo" @=? U.stripControlAll "foo\ESC[A" "bar" @=? U.stripControlAll "\ESC[Abar" - " foobarbaz " @=? U.stripControlAll "\t foo\ESC[Abar\ESC[1m\n\ESC[0Kbaz \v" + " foobar baz " @=? U.stripControlAll "\t foo\ESC[Abar\ESC[1m\n\ESC[0Kbaz \v" someControlStripped :: TestTree someControlStripped = @@ -98,7 +98,7 @@ someControlStripped = "" @=? U.stripControlSmart "\ESC[A" "foo" @=? U.stripControlSmart "foo\ESC[A" "bar" @=? U.stripControlSmart "\ESC[Abar" - " foobar\ESC[1mbaz " @=? U.stripControlSmart "\t foo\ESC[Abar\ESC[1m\n\ESC[0Kbaz \v" + " foobar\ESC[1m baz " @=? U.stripControlSmart "\t foo\ESC[Abar\ESC[1m\n\ESC[0Kbaz \v" "\ESC[0mfoo" @=? U.stripControlSmart "\ESC[0mfoo" "foo\ESC[0mbar" @=? U.stripControlSmart "foo\ESC[0mbar"