sandwich 0.1.0.10 → 0.1.0.11

raw patch · 19 files changed

+384/−95 lines, 19 filesdep −lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: lens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• LICENSE +1/−1
• sandwich.cabal +6/−8
• src/Test/Sandwich.hs +8/−2
• src/Test/Sandwich/ArgParsing.hs +17/−3
• src/Test/Sandwich/Formatters/MarkdownSummary.hs +2/−1
• src/Test/Sandwich/Formatters/Print/CallStacks.hs +0/−1
• src/Test/Sandwich/Formatters/Print/Color.hs +0/−1
• src/Test/Sandwich/Formatters/Print/Logs.hs +0/−1
• src/Test/Sandwich/Formatters/Print/Printing.hs +4/−3
• src/Test/Sandwich/Formatters/TerminalUI.hs +61/−20
• src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs +57/−47
• src/Test/Sandwich/Golden.hs +118/−0
• src/Test/Sandwich/Golden/Update.hs +67/−0
• src/Test/Sandwich/Internal/Running.hs +2/−0
• src/Test/Sandwich/TestTimer.hs +1/−1
• src/Test/Sandwich/Types/ArgParsing.hs +9/−0
• src/Test/Sandwich/Types/TestTimer.hs +7/−6
• src/Test/Sandwich/Types/TestTimer/LensRules.hs +20/−0

@@ -2,6 +2,10 @@  ## Unreleased changes +## 0.1.0.11++* Initial release Test.Sandwich.Golden for golden testing.+* Support Brick 1.x in addition to 0.x.  ## 0.1.0.10 

@@ -1,4 +1,4 @@-Copyright Tom McLaughlin (c) 2021+Copyright Tom McLaughlin (c) 2022  All rights reserved. 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 933d39e891051a78e2b2f7d00c6879128eb9fce0b3c31eb6f21cb663e0643f14+-- hash: eea544fa3b581852af314541fcc7874b15f46d425b1632e09e36eeaf60de11b3  name:           sandwich-version:        0.1.0.10+version:        0.1.0.11 synopsis:       Yet another test framework for Haskell description:    Please see the <https://codedownio.github.io/sandwich documentation>. category:       Testing@@ -15,7 +15,7 @@ bug-reports:    https://github.com/codedownio/sandwich/issues author:         Tom McLaughlin maintainer:     tom@codedown.io-copyright:      2021 Tom McLaughlin+copyright:      2022 Tom McLaughlin license:        BSD3 license-file:   LICENSE build-type:     Simple@@ -31,6 +31,7 @@       Test.Sandwich       Test.Sandwich.Contexts       Test.Sandwich.Expectations+      Test.Sandwich.Golden       Test.Sandwich.Logging       Test.Sandwich.Misc       Test.Sandwich.Nodes@@ -67,6 +68,7 @@       Test.Sandwich.Formatters.TerminalUI.Keys       Test.Sandwich.Formatters.TerminalUI.OpenInEditor       Test.Sandwich.Formatters.TerminalUI.Types+      Test.Sandwich.Golden.Update       Test.Sandwich.Internal.Formatters       Test.Sandwich.Internal.Running       Test.Sandwich.Interpreters.FilterTree@@ -87,6 +89,7 @@       Test.Sandwich.Types.RunTree       Test.Sandwich.Types.Spec       Test.Sandwich.Types.TestTimer+      Test.Sandwich.Types.TestTimer.LensRules       Test.Sandwich.Util       Paths_sandwich   hs-source-dirs:@@ -106,7 +109,6 @@     , filepath     , free     , haskell-src-exts-    , lens     , lifted-async     , microlens     , microlens-th@@ -152,7 +154,6 @@     , filepath     , free     , haskell-src-exts-    , lens     , lifted-async     , microlens     , microlens-th@@ -199,7 +200,6 @@     , filepath     , free     , haskell-src-exts-    , lens     , lifted-async     , microlens     , microlens-th@@ -251,7 +251,6 @@     , filepath     , free     , haskell-src-exts-    , lens     , lifted-async     , microlens     , microlens-th@@ -304,7 +303,6 @@     , filepath     , free     , haskell-src-exts-    , lens     , lifted-async     , microlens     , microlens-th

@@ -95,6 +95,7 @@ import Test.Sandwich.Contexts import Test.Sandwich.Expectations import Test.Sandwich.Formatters.Common.Count+import Test.Sandwich.Golden.Update import Test.Sandwich.Internal.Running import Test.Sandwich.Interpreters.FilterTreeModule import Test.Sandwich.Interpreters.RunTree@@ -129,12 +130,15 @@   (clo, individualTestParser, modulesAndShorthands) <- parseCommandLineArgs' userOptionsParser spec   (options, repeatCount) <- liftIO $ addOptionsFromArgs baseOptions clo -  if | optPrintQuickCheckFlags clo == Just True -> do+  if | optPrintGoldenFlags clo == Just True -> do          void $ withArgs ["--help"] $-           OA.execParser quickCheckOptionsWithInfo+           OA.execParser goldenOptionsWithInfo      | optPrintHedgehogFlags clo == Just True -> do          void $ withArgs ["--help"] $            OA.execParser hedgehogOptionsWithInfo+     | optPrintQuickCheckFlags clo == Just True -> do+         void $ withArgs ["--help"] $+           OA.execParser quickCheckOptionsWithInfo      | optPrintSlackFlags clo == Just True -> do          void $ withArgs ["--help"] $            OA.execParser slackOptionsWithInfo@@ -146,6 +150,8 @@            OA.execParser $ OA.info (individualTestParser mempty <**> helper) $              fullDesc <> header "Pass one of these flags to run an individual test module."                       <> progDesc "If a module has a \"*\" next to its name, then we detected that it has its own main function. If you pass the option name suffixed by -main then we'll just directly invoke the main function."+     | optUpdateGolden (optGoldenOptions clo) == Just True -> do+         updateGolden (optGoldenDir (optGoldenOptions clo))      | otherwise -> do          -- Awkward, but we need a specific context type to call countItNodes          let totalTests = countItNodes (spec :: SpecFree (LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())

@@ -47,11 +47,11 @@     <> header "Sandwich test runner"   ) -quickCheckOptionsWithInfo :: ParserInfo CommandLineQuickCheckOptions-quickCheckOptionsWithInfo = OA.info (commandLineQuickCheckOptions mempty <**> helper)+goldenOptionsWithInfo :: ParserInfo CommandLineGoldenOptions+goldenOptionsWithInfo = OA.info (commandLineGoldenOptions mempty <**> helper)   (     briefDesc-    <> header "Special options used by sandwich-quickcheck.\n\nIf a flag is passed, it will override the value in the QuickCheck option configured in the code."+    <> header "Special options used for golden testing."   )  hedgehogOptionsWithInfo :: ParserInfo CommandLineHedgehogOptions@@ -61,6 +61,13 @@     <> header "Special options used by sandwich-hedgehog.\n\nIf a flag is passed, it will override the value in the Hedgehog option configured in the code."   ) +quickCheckOptionsWithInfo :: ParserInfo CommandLineQuickCheckOptions+quickCheckOptionsWithInfo = OA.info (commandLineQuickCheckOptions mempty <**> helper)+  (+    briefDesc+    <> header "Special options used by sandwich-quickcheck.\n\nIf a flag is passed, it will override the value in the QuickCheck option configured in the code."+  )+ slackOptionsWithInfo :: ParserInfo CommandLineSlackOptions slackOptionsWithInfo = OA.info (commandLineSlackOptions mempty <**> helper)   (@@ -88,6 +95,7 @@   <*> optional (strOption (long "markdown-summary" <> help "File path to write a Markdown summary of the results." <> metavar "STRING"))    <*> optional (flag False True (long "list-tests" <> help "List individual test modules"))+  <*> optional (flag False True (long "print-golden-flags" <> help "Print the additional golden testing flags"))   <*> optional (flag False True (long "print-quickcheck-flags" <> help "Print the additional QuickCheck flags"))   <*> optional (flag False True (long "print-hedgehog-flags" <> help "Print the additional Hedgehog flags"))   <*> optional (flag False True (long "print-slack-flags" <> help "Print the additional Slack flags"))@@ -95,6 +103,7 @@    <*> individualTestParser +  <*> commandLineGoldenOptions internal   <*> commandLineQuickCheckOptions internal   <*> commandLineHedgehogOptions internal   <*> commandLineSlackOptions internal@@ -135,6 +144,11 @@   flag' Current (long "current" <> help "Open browser in current display (default)" <> maybeInternal)   <|> flag' Headless (long "headless" <> help "Open browser in headless mode" <> maybeInternal)   <|> flag Current Xvfb (long "xvfb" <> help "Open browser in Xvfb session" <> maybeInternal)++commandLineGoldenOptions :: (forall f a. Mod f a) -> Parser CommandLineGoldenOptions+commandLineGoldenOptions maybeInternal = CommandLineGoldenOptions+  <$> optional (flag False True (long "golden-update" <> help "Update your golden files" <> maybeInternal))+  <*> optional (strOption (long "golden-dir" <> help "The directory where golden results are stored (defaults to \".golden\")" <> metavar "STRING" <> maybeInternal))  commandLineQuickCheckOptions :: (forall f a. Mod f a) -> Parser CommandLineQuickCheckOptions commandLineQuickCheckOptions maybeInternal = CommandLineQuickCheckOptions

@@ -72,11 +72,12 @@   fixedTree <- liftIO $ atomically $ mapM fixRunTree rts   let failed = countWhere isFailedItBlock fixedTree   let pending = countWhere isPendingItBlock fixedTree+  let succeeded = countWhere isSuccessItBlock fixedTree    liftIO $ withFile markdownSummaryPath AppendMode $ \h -> do     if | failed == 0 -> do            whenJust markdownSummarySuccessIcon (liftIO . (hPutStr h) . T.unpack)-           hPutStr h [i|All tests passed in #{timeDiff}.|]+           hPutStr h [i|All #{succeeded} tests passed in #{timeDiff}.|]        | otherwise -> do            whenJust markdownSummaryFailureIcon (liftIO . (hPutStr h) . T.unpack)            hPutStr h [i|#{failed} failed of #{total} in #{timeDiff}.|]

@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-}--- |  module Test.Sandwich.Formatters.Print.CallStacks where 

@@ -1,4 +1,3 @@--- |  module Test.Sandwich.Formatters.Print.Color where 

@@ -2,7 +2,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-}--- |  module Test.Sandwich.Formatters.Print.Logs where 

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+ -- | Utility functions for printing  module Test.Sandwich.Formatters.Print.Printing where@@ -31,12 +32,12 @@ pRedLn msg = printIndentedWithColor (Just (SetColor Foreground Dull Red)) (msg <> "\n") -- Tried solarizedRed here but it was too orange  printIndentedWithColor maybeColor msg = do-  (PrintFormatter {..}, indent, h) <- ask+  (PrintFormatter {}, indent, h) <- ask   liftIO $ hPutStr h $ L.replicate indent ' '   printWithColor maybeColor msg  printWithColor maybeColor msg = do-  (PrintFormatter {..}, _, h) <- ask+  (PrintFormatter {printFormatterUseColor}, _, h) <- ask   when (printFormatterUseColor) $ whenJust maybeColor $ \color -> liftIO $ setSGR [color]   liftIO $ hPutStr h msg   when (printFormatterUseColor) $ whenJust maybeColor $ \_ -> liftIO $ setSGR [Reset]

@@ -7,6 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}  module Test.Sandwich.Formatters.TerminalUI (   -- | The terminal UI formatter produces an interactive UI for running tests and inspecting their results.@@ -142,12 +143,36 @@ app = App {   appDraw = drawUI   , appChooseCursor = showFirstCursor+#if MIN_VERSION_brick(1,0,0)+  , appHandleEvent = \event -> get >>= \s -> appEvent s event+  , appStartEvent = return ()+#else   , appHandleEvent = appEvent   , appStartEvent = return+#endif   , appAttrMap = const mainAttrMap   } +#if MIN_VERSION_brick(1,0,0)+continue :: AppState -> EventM ClickableName AppState ()+continue = put++continueNoChange :: AppState -> EventM ClickableName AppState ()+continueNoChange _ = return ()++doHalt _ = halt+#else+continueNoChange :: AppState -> EventM ClickableName (Next AppState)+continueNoChange = continue++doHalt = halt+#endif++#if MIN_VERSION_brick(1,0,0)+appEvent :: AppState -> BrickEvent ClickableName AppEvent -> EventM ClickableName AppState ()+#else appEvent :: AppState -> BrickEvent ClickableName AppEvent -> EventM ClickableName (Next AppState)+#endif appEvent s (AppEvent (RunTreeUpdated newTree)) = do   now <- liftIO getCurrentTime   continue $ s@@ -170,10 +195,10 @@  appEvent s (MouseDown (ListRow _i) V.BScrollUp _ _) = do   vScrollBy (viewportScroll MainList) (-1)-  continue s+  continueNoChange s appEvent s (MouseDown (ListRow _i) V.BScrollDown _ _) = do   vScrollBy (viewportScroll MainList) 1-  continue s+  continueNoChange s appEvent s (MouseDown (ListRow i) V.BLeft _ _) = do   continue (s & appMainList %~ (listMoveTo i)) appEvent s (VtyEvent e) =@@ -207,29 +232,29 @@      -- Scrolling in toggled items     -- Wanted to make these uniformly Ctrl+whatever, but Ctrl+PageUp/PageDown was causing it to get KEsc and exit (?)-    V.EvKey V.KUp [V.MCtrl] -> withScroll s $ flip vScrollBy (-1)-    V.EvKey (V.KChar 'p') [V.MCtrl] -> withScroll s $ flip vScrollBy (-1)-    V.EvKey V.KDown [V.MCtrl] -> withScroll s $ flip vScrollBy 1-    V.EvKey (V.KChar 'n') [V.MCtrl] -> withScroll s $ flip vScrollBy 1-    V.EvKey (V.KChar 'v') [V.MMeta] -> withScroll s $ flip vScrollPage Up-    V.EvKey (V.KChar 'v') [V.MCtrl] -> withScroll s $ flip vScrollPage Down-    V.EvKey V.KHome [V.MCtrl] -> withScroll s vScrollToBeginning-    V.EvKey V.KEnd [V.MCtrl] -> withScroll s vScrollToEnd+    V.EvKey V.KUp [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp (-1)+    V.EvKey (V.KChar 'p') [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp (-1)+    V.EvKey V.KDown [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp 1+    V.EvKey (V.KChar 'n') [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp 1+    V.EvKey (V.KChar 'v') [V.MMeta] -> withScroll s $ \vp -> vScrollPage vp Up+    V.EvKey (V.KChar 'v') [V.MCtrl] -> withScroll s $ \vp -> vScrollPage vp Down+    V.EvKey V.KHome [V.MCtrl] -> withScroll s $ \vp -> vScrollToBeginning vp+    V.EvKey V.KEnd [V.MCtrl] -> withScroll s $ \vp -> vScrollToEnd vp      -- Column 2     V.EvKey c [] | c == cancelAllKey -> do       liftIO $ mapM_ cancelNode (s ^. appRunTreeBase)       continue s-    V.EvKey c [] | c == cancelSelectedKey -> withContinueS $ do+    V.EvKey c [] | c == cancelSelectedKey -> withContinueS s $ do       whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> liftIO $         (readTVarIO $ runTreeStatus node) >>= \case           Running {..} -> cancel statusAsync           _ -> return ()-    V.EvKey c [] | c == runAllKey -> withContinueS $ do+    V.EvKey c [] | c == runAllKey -> withContinueS s $ do       when (all (not . isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)) $ liftIO $ do         mapM_ clearRecursively (s ^. appRunTreeBase)         void $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) (s ^. appBaseContext)-    V.EvKey c [] | c == runSelectedKey -> withContinueS $+    V.EvKey c [] | c == runSelectedKey -> withContinueS s $       whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> case status of         Running {} -> return ()         _ -> do@@ -244,18 +269,18 @@               -- Start a run for all affected nodes               let bc = (s ^. appBaseContext) { baseContextOnlyRunIds = Just allIds }               void $ liftIO $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) bc-    V.EvKey c [] | c == clearSelectedKey -> withContinueS $ do+    V.EvKey c [] | c == clearSelectedKey -> withContinueS s $ do       whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> case status of         Running {} -> return ()         _ -> case findRunNodeChildrenById ident (s ^. appRunTree) of           Nothing -> return ()           Just childIds -> liftIO $ mapM_ (clearRecursivelyWhere (\x -> runTreeId x `S.member` childIds)) (s ^. appRunTreeBase)-    V.EvKey c [] | c == clearAllKey -> withContinueS $ do+    V.EvKey c [] | c == clearAllKey -> withContinueS s $ do       liftIO $ mapM_ clearRecursively (s ^. appRunTreeBase)-    V.EvKey c [] | c == openSelectedFolderInFileExplorer -> withContinueS $ do+    V.EvKey c [] | c == openSelectedFolderInFileExplorer -> withContinueS s $ do       whenJust (listSelectedElement (s ^. appMainList)) $ \(_i, MainListElem {folderPath}) ->         whenJust folderPath $ liftIO . openFileExplorerFolderPortable-    V.EvKey c [] | c == openTestRootKey -> withContinueS $+    V.EvKey c [] | c == openTestRootKey -> withContinueS s $       whenJust (baseContextRunRoot (s ^. appBaseContext)) $ liftIO . openFileExplorerFolderPortable     V.EvKey c [] | c == openTestInEditorKey -> case listSelectedElement (s ^. appMainList) of       Just (_i, MainListElem {node=(runTreeLoc -> Just loc)}) -> openSrcLoc s loc@@ -282,7 +307,8 @@      -- Column 3     V.EvKey c [] | c == cycleVisibilityThresholdKey -> do-      let newVisibilityThreshold =  case [(i, x) | (i, x) <- zip [0..] (s ^. appVisibilityThresholdSteps), x > s ^. appVisibilityThreshold] of+      let newVisibilityThreshold =  case [(i, x) | (i, x) <- zip [0..] (s ^. appVisibilityThresholdSteps)+                                                 , x > s ^. appVisibilityThreshold] of             [] -> 0             xs -> minimum $ fmap snd xs       continue $ s@@ -298,16 +324,24 @@       -- Cancel everything and wait for cleanups       liftIO $ mapM_ cancelNode (s ^. appRunTreeBase)       forM_ (s ^. appRunTreeBase) (liftIO . waitForTree)-      halt s+      doHalt s     V.EvKey c [] | c == debugKey -> continue (s & appLogLevel ?~ LevelDebug)     V.EvKey c [] | c == infoKey -> continue (s & appLogLevel ?~ LevelInfo)     V.EvKey c [] | c == warnKey -> continue (s & appLogLevel ?~ LevelWarn)     V.EvKey c [] | c == errorKey -> continue (s & appLogLevel ?~ LevelError) +#if MIN_VERSION_brick(1,0,0)+    ev -> zoom appMainList $ handleListEvent ev+#else     ev -> handleEventLensed s appMainList handleListEvent ev >>= continue+#endif -  where withContinueS action = action >> continue s+  where withContinueS s action = action >> continue s+#if MIN_VERSION_brick(1,0,0)+appEvent _ _ = return ()+#else appEvent s _ = continue s+#endif  modifyToggled s f = case listSelectedElement (s ^. appMainList) of   Nothing -> continue s@@ -387,6 +421,11 @@ findRunNodeChildrenById' ident (RunNodeIntroduceWith {..}) = findRunNodeChildrenById ident runNodeChildrenAugmented findRunNodeChildrenById' ident node = findRunNodeChildrenById ident (runNodeChildren node) +#if MIN_VERSION_brick(1,0,0)+withScroll :: AppState -> (forall s. ViewportScroll ClickableName -> EventM n s ()) -> EventM n AppState ()+#else+withScroll :: AppState -> (ViewportScroll ClickableName -> EventM n ()) -> EventM n (Next AppState)+#endif withScroll s action = do   case listSelectedElement (s ^. appMainList) of     Nothing -> return ()@@ -394,7 +433,9 @@       let scroll = viewportScroll (InnerViewport [i|viewport_#{ident}|])       action scroll +#if !MIN_VERSION_brick(1,0,0)   continue s+#endif  openSrcLoc s loc' = do   -- Try to make the file path in the SrcLoc absolute

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}--- |+{-# LANGUAGE CPP #-}  module Test.Sandwich.Formatters.TerminalUI.AttrMap where @@ -9,7 +9,17 @@ import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec +#if MIN_VERSION_brick(1,0,0)+mkAttrName :: String -> AttrName+mkAttrName = attrName+#else+import Data.String +mkAttrName :: String -> AttrName+mkAttrName = fromString+#endif++ mainAttrMap :: AttrMap mainAttrMap = attrMap V.defAttr [   -- (listAttr, V.white `on` V.blue)@@ -80,46 +90,46 @@ -- selectedAttr = "list_line_selected"  visibilityThresholdNotSelectedAttr :: AttrName-visibilityThresholdNotSelectedAttr = "visibility_threshold_not_selected"+visibilityThresholdNotSelectedAttr = mkAttrName "visibility_threshold_not_selected"  visibilityThresholdSelectedAttr :: AttrName-visibilityThresholdSelectedAttr = "visibility_threshold_selected"+visibilityThresholdSelectedAttr = mkAttrName "visibility_threshold_selected"  runningAttr :: AttrName-runningAttr = "running"+runningAttr = mkAttrName "running"  notStartedAttr :: AttrName-notStartedAttr = "not_started"+notStartedAttr = mkAttrName "not_started"  pendingAttr :: AttrName-pendingAttr = "pending"+pendingAttr = mkAttrName "pending"  totalAttr :: AttrName-totalAttr = "total"+totalAttr = mkAttrName "total"  successAttr :: AttrName-successAttr = "success"+successAttr = mkAttrName "success"  failureAttr :: AttrName-failureAttr = "failure"+failureAttr = mkAttrName "failure"  toggleMarkerAttr :: AttrName-toggleMarkerAttr = "toggleMarker"+toggleMarkerAttr = mkAttrName "toggleMarker"  openMarkerAttr :: AttrName-openMarkerAttr = "openMarker"+openMarkerAttr = mkAttrName "openMarker"  visibilityThresholdIndicatorAttr :: AttrName-visibilityThresholdIndicatorAttr = "visibilityThresholdIndicator"+visibilityThresholdIndicatorAttr = mkAttrName "visibilityThresholdIndicator"  visibilityThresholdIndicatorMutedAttr :: AttrName-visibilityThresholdIndicatorMutedAttr = "visibilityThresholdMutedIndicator"+visibilityThresholdIndicatorMutedAttr = mkAttrName "visibilityThresholdMutedIndicator"  hotkeyAttr, disabledHotkeyAttr, hotkeyMessageAttr, disabledHotkeyMessageAttr :: AttrName-hotkeyAttr = "hotkey"-disabledHotkeyAttr = "disableHotkey"-hotkeyMessageAttr = "hotkeyMessage"-disabledHotkeyMessageAttr = "disabledHotkeyMessage"+hotkeyAttr = mkAttrName "hotkey"+disabledHotkeyAttr = mkAttrName "disableHotkey"+hotkeyMessageAttr = mkAttrName "hotkeyMessage"+disabledHotkeyMessageAttr = mkAttrName "disabledHotkeyMessage"  chooseAttr :: Status -> AttrName chooseAttr NotStarted = notStartedAttr@@ -133,47 +143,47 @@ -- * Logging and callstacks  debugAttr, infoAttr, warnAttr, errorAttr, otherAttr :: AttrName-debugAttr = "log_debug"-infoAttr = "log_info"-warnAttr = "log_warn"-errorAttr = "log_error"-otherAttr = "log_other"+debugAttr = attrName"log_debug"+infoAttr = attrName"log_info"+warnAttr = attrName"log_warn"+errorAttr = attrName"log_error"+otherAttr = mkAttrName "log_other"  logTimestampAttr :: AttrName-logTimestampAttr = "log_timestamp"+logTimestampAttr = mkAttrName "log_timestamp"  logFilenameAttr, logModuleAttr, logPackageAttr, logLineAttr, logChAttr :: AttrName-logFilenameAttr = "logFilename"-logModuleAttr = "logModule"-logPackageAttr = "logPackage"-logLineAttr = "logLine"-logChAttr = "logCh"-logFunctionAttr = "logFunction"+logFilenameAttr = mkAttrName "logFilename"+logModuleAttr = mkAttrName "logModule"+logPackageAttr = mkAttrName "logPackage"+logLineAttr = mkAttrName "logLine"+logChAttr = mkAttrName "logCh"+logFunctionAttr = mkAttrName "logFunction"  -- * Exceptions and pretty printing  expectedAttr, sawAttr :: AttrName-expectedAttr = "expected"-sawAttr = "saw"+expectedAttr = mkAttrName "expected"+sawAttr = mkAttrName "saw"  integerAttr, timeAttr, dateAttr, stringAttr, charAttr, floatAttr, quoteAttr, slashAttr, negAttr :: AttrName listBracketAttr, tupleBracketAttr, braceAttr, ellipsesAttr, recordNameAttr, fieldNameAttr, constructorNameAttr :: AttrName-integerAttr = "integer"-floatAttr = "float"-charAttr = "char"-stringAttr = "string"-dateAttr = "date"-timeAttr = "time"-quoteAttr = "quote"-slashAttr = "slash"-negAttr = "neg"-listBracketAttr = "listBracket"-tupleBracketAttr = "tupleBracket"-braceAttr = "brace"-ellipsesAttr = "ellipses"-recordNameAttr = "recordName"-fieldNameAttr = "fieldName"-constructorNameAttr = "fieldName"+integerAttr = mkAttrName "integer"+floatAttr = mkAttrName "float"+charAttr = mkAttrName "char"+stringAttr = mkAttrName "string"+dateAttr = mkAttrName "date"+timeAttr = mkAttrName "time"+quoteAttr = mkAttrName "quote"+slashAttr = mkAttrName "slash"+negAttr = mkAttrName "neg"+listBracketAttr = mkAttrName "listBracket"+tupleBracketAttr = mkAttrName "tupleBracket"+braceAttr = mkAttrName "brace"+ellipsesAttr = mkAttrName "ellipses"+recordNameAttr = mkAttrName "recordName"+fieldNameAttr = mkAttrName "fieldName"+constructorNameAttr = mkAttrName "fieldName"  -- * Colors 

@@ -0,0 +1,118 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE LambdaCase #-}++-- This module is based on Test.Hspec.Golden from hspec-golden-0.2.0.0, which is MIT licensed.++module Test.Sandwich.Golden (+  -- * Main test function+  golden++  -- * Built-in Goldens.+  , goldenText+  , goldenString+  , goldenJSON+  , goldenShowable+  , mkGolden++  -- * Parameters for a 'Golden'.+  , goldenOutput+  , goldenWriteToFile+  , goldenReadFromFile+  , goldenFile+  , goldenActualFile+  , goldenFailFirstTime+  ) where++import Control.Exception.Safe+import Control.Monad+import Control.Monad.Free+import Control.Monad.IO.Class+import Data.Aeson as A+import qualified Data.ByteString.Lazy as BL+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Text.IO as T+import GHC.Stack+import System.Directory+import System.FilePath+import Test.Sandwich+import Test.Sandwich.Golden.Update+import Test.Sandwich.Types.Spec+++data Golden a = Golden {+  -- | Name+  goldenName :: String+  -- | Expected output.+  , goldenOutput :: a+  -- | How to write into the golden file the file.+  , goldenWriteToFile :: FilePath -> a -> IO ()+  -- | How to read the file.+  , goldenReadFromFile :: FilePath -> IO a+  -- | Where to read/write the golden file for this test.+  , goldenFile :: FilePath+  -- | Where to save the actual file for this test. If it is @Nothing@ then no file is written.+  , goldenActualFile :: Maybe FilePath+  -- | Whether to record a failure the first time this test is run.+  , goldenFailFirstTime :: Bool+  }+++-- | Make your own 'Golden' constructor by providing 'goldenWriteToFile' and 'goldenReadFromFile'.+mkGolden :: (FilePath -> a -> IO ()) -> (FilePath -> IO a) -> String -> a -> Golden a+mkGolden goldenWriteToFile goldenReadFromFile name output = Golden {+  goldenName = name+  , goldenOutput = output+  , goldenWriteToFile = goldenWriteToFile+  , goldenReadFromFile = goldenReadFromFile+  , goldenFile = defaultDirGoldenTest </> name </> "golden"+  , goldenActualFile = Just (defaultDirGoldenTest </> name </> "actual")+  , goldenFailFirstTime = False+  }++-- | Golden for a 'T.Text'.+goldenText :: String -> T.Text -> Golden T.Text+goldenText = mkGolden T.writeFile T.readFile++-- | Golden for a 'String'.+goldenString :: String -> String -> Golden String+goldenString = mkGolden writeFile readFile++-- | Golden for an Aeson value ('ToJSON'/'FromJSON').+goldenJSON :: (A.ToJSON a, A.FromJSON a) => String -> a -> Golden a+goldenJSON = mkGolden (\f x -> BL.writeFile f $ A.encode x) $ \f ->+  eitherDecodeFileStrict' f >>= \case+    Left err -> expectationFailure [i|Failed to decode JSON value in #{f}: #{err}|]+    Right x -> return x++-- | Golden for a general 'Show'/'Read' type.+goldenShowable :: (Show a, Read a) => String -> a -> Golden a+goldenShowable = mkGolden (\f x -> writeFile f (show x)) ((read <$>) . readFile)++-- | Runs a Golden test.++golden :: (MonadIO m, MonadThrow m, Eq str, Show str) => Golden str -> Free (SpecCommand context m) ()+golden (Golden {..}) = it goldenName $ do+  let goldenTestDir = takeDirectory goldenFile+  liftIO $ createDirectoryIfMissing True goldenTestDir+  goldenFileExist <- liftIO $ doesFileExist goldenFile++  case goldenActualFile of+    Nothing -> return ()+    Just actual -> do+      -- It is recommended to always write the actual file+      let actualDir = takeDirectory actual+      liftIO $ createDirectoryIfMissing True actualDir+      liftIO $ goldenWriteToFile actual goldenOutput++  if not goldenFileExist+    then do+        liftIO $ goldenWriteToFile goldenFile goldenOutput+        when goldenFailFirstTime $ expectationFailure [i|Failed due to first execution and goldenFailFirstTime=True.|]+    else do+       liftIO (goldenReadFromFile goldenFile) >>= \case+         x | x == goldenOutput -> return ()+         x -> throwIO $ ExpectedButGot (Just callStack) (SEB x) (SEB goldenOutput)

@@ -0,0 +1,67 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE LambdaCase #-}++{-| This module is based on hgold from hspec-golden-0.2.0.0, which is MIT licensed -}++module Test.Sandwich.Golden.Update (+  updateGolden+  , defaultDirGoldenTest+  ) where++import Control.Exception.Safe+import Control.Monad+import Data.Maybe+import Data.String.Interpolate+import System.Console.ANSI+import System.Directory+import System.Environment+++defaultDirGoldenTest :: FilePath+defaultDirGoldenTest = ".golden"++updateGolden :: Maybe FilePath -> IO ()+updateGolden (fromMaybe defaultDirGoldenTest -> dir) = do+  enableColor <- lookupEnv "NO_COLOR" >>= \case+    Nothing -> return EnableColor+    Just _ -> return DisableColor++  putStrLnColor enableColor green "Replacing golden with actual..."+  go enableColor dir+  putStrLnColor enableColor green "Done!"++  where+    go enableColor dir = listDirectory dir >>= mapM_ (processEntry enableColor)++    processEntry enableColor (((dir ++ "/") ++) -> entryInDir) = do+      isDir <- doesDirectoryExist entryInDir+      when isDir $ do+        mvActualToGolden enableColor entryInDir+        go enableColor entryInDir++mvActualToGolden :: EnableColor -> FilePath -> IO ()+mvActualToGolden enableColor testPath = do+  let actualFilePath = testPath ++ "/actual"+  let goldenFilePath = testPath ++ "/golden"++  exists <- doesFileExist actualFilePath+  when exists $ do+    putStr [i|  #{goldenFilePath}|]+    putStrColor enableColor magenta " <-- "+    putStrLnColor enableColor red [i|#{actualFilePath}|]++    renameFile actualFilePath goldenFilePath++green, red, magenta :: SGR+green = SetColor Foreground Dull Green+red = SetColor Foreground Dull Red+magenta = SetColor Foreground Dull Magenta++putStrColor EnableColor color s = bracket_ (setSGR [color]) (setSGR [Reset]) (putStr s)+putStrColor DisableColor _ s = putStr s++putStrLnColor EnableColor color s = bracket_ (setSGR [color]) (setSGR [Reset]) (putStrLn s)+putStrLnColor DisableColor _ s = putStrLn s++data EnableColor = EnableColor | DisableColor

@@ -145,6 +145,8 @@   , "fixed-root"   , "list-tests" +  , "print-golden-flags"+  , "print-hedgehog-flags"   , "print-quickcheck-flags"   , "print-slack-flags"   , "print-webdriver-flags"

@@ -13,7 +13,6 @@  import Control.Concurrent import Control.Exception.Safe-import Control.Lens import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.State@@ -25,6 +24,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time.Clock.POSIX+import Lens.Micro import System.Directory import System.FilePath import System.IO

@@ -54,6 +54,7 @@   , optMarkdownSummaryPath :: Maybe FilePath    , optListAvailableTests :: Maybe Bool+  , optPrintGoldenFlags :: Maybe Bool   , optPrintQuickCheckFlags :: Maybe Bool   , optPrintHedgehogFlags :: Maybe Bool   , optPrintSlackFlags :: Maybe Bool@@ -61,6 +62,7 @@    , optIndividualTestModule :: Maybe IndividualTestModule +  , optGoldenOptions :: CommandLineGoldenOptions   , optQuickCheckOptions :: CommandLineQuickCheckOptions   , optHedgehogOptions :: CommandLineHedgehogOptions   , optSlackOptions :: CommandLineSlackOptions@@ -75,6 +77,13 @@ instance Show IndividualTestModule where   show (IndividualTestModuleName moduleName) = moduleName   show (IndividualTestMainFn _) = "<main function>"++-- * golden options++data CommandLineGoldenOptions = CommandLineGoldenOptions {+  optUpdateGolden :: Maybe Bool+  , optGoldenDir :: Maybe FilePath+  } deriving Show  -- * sandwich-quickcheck options 

@@ -13,15 +13,16 @@ module Test.Sandwich.Types.TestTimer where  import Control.Concurrent-import Control.Lens import Data.Aeson as A import Data.Aeson.TH as A import qualified Data.List as L import Data.Sequence import qualified Data.Text as T import Data.Time.Clock.POSIX+import Lens.Micro.TH import System.IO import Test.Sandwich.Types.Spec+import Test.Sandwich.Types.TestTimer.LensRules (testTimerLensRules)   -- * SpeedScope types@@ -33,7 +34,7 @@                  A.fieldLabelModifier = L.drop 1                  , A.sumEncoding = A.UntaggedValue                  }) ''SpeedScopeFrame)-$(makeFieldsNoPrefix ''SpeedScopeFrame)+$(makeLensesWith testTimerLensRules ''SpeedScopeFrame)  data SpeedScopeShared = SpeedScopeShared {   _frames :: Seq SpeedScopeFrame@@ -42,7 +43,7 @@                  A.fieldLabelModifier = L.drop 1                  , A.sumEncoding = A.UntaggedValue                  }) ''SpeedScopeShared)-$(makeFieldsNoPrefix ''SpeedScopeShared)+$(makeLensesWith testTimerLensRules ''SpeedScopeShared)  data SpeedScopeEventType = SpeedScopeEventTypeOpen | SpeedScopeEventTypeClose   deriving (Show, Eq)@@ -62,7 +63,7 @@                      _ -> L.drop 1 x                  , A.sumEncoding = A.UntaggedValue                  }) ''SpeedScopeEvent)-$(makeFieldsNoPrefix ''SpeedScopeEvent)+$(makeLensesWith testTimerLensRules ''SpeedScopeEvent)  data SpeedScopeProfile = SpeedScopeProfile {   _typ :: T.Text@@ -78,7 +79,7 @@                      _ -> L.drop 1 x                  , A.sumEncoding = A.UntaggedValue                  }) ''SpeedScopeProfile)-$(makeFieldsNoPrefix ''SpeedScopeProfile)+$(makeLensesWith testTimerLensRules ''SpeedScopeProfile)  data SpeedScopeFile = SpeedScopeFile {   _exporter :: T.Text@@ -94,7 +95,7 @@                      _ -> L.drop 1 x                  , A.sumEncoding = A.UntaggedValue                  }) ''SpeedScopeFile)-$(makeFieldsNoPrefix ''SpeedScopeFile)+$(makeLensesWith testTimerLensRules ''SpeedScopeFile)  emptySpeedScopeFile =   SpeedScopeFile {

@@ -0,0 +1,20 @@++module Test.Sandwich.Types.TestTimer.LensRules (+  testTimerLensRules+  ) where++import Data.Char (toLower, toUpper)+import Language.Haskell.TH+import Lens.Micro+import Lens.Micro.TH+++testTimerLensRules :: LensRules+testTimerLensRules = camelCaseFields+  & lensField .~ underscoreNoPrefixNamer++underscoreNoPrefixNamer :: Name -> [Name] -> Name -> [DefName]+underscoreNoPrefixNamer _ _ n =+  case nameBase n of+    '_':x:xs -> [MethodName (mkName ("Has" ++ (toUpper x:xs))) (mkName (toLower x:xs))]+    _        -> []