diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,10 @@ ## Unreleased +## 0.1.3.1 + +* Support hedgehog-1.5 + ## 0.1.3.0 * Fix bug-reports URL diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Tom McLaughlin (c) 2023 +Copyright Tom McLaughlin (c) 2024 All rights reserved. diff --git a/sandwich-hedgehog.cabal b/sandwich-hedgehog.cabal --- a/sandwich-hedgehog.cabal +++ b/sandwich-hedgehog.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: sandwich-hedgehog -version: 0.1.3.0 +version: 0.1.3.1 synopsis: Sandwich integration with Hedgehog description: Please see the . category: Testing @@ -13,7 +13,7 @@ bug-reports: https://github.com/codedownio/sandwich/issues author: Tom McLaughlin maintainer: tom@codedown.io -copyright: 2023 Tom McLaughlin +copyright: 2024 Tom McLaughlin license: BSD3 license-file: LICENSE build-type: Simple @@ -28,6 +28,7 @@ exposed-modules: Test.Sandwich.Hedgehog other-modules: + Test.Sandwich.Hedgehog.Render Paths_sandwich_hedgehog hs-source-dirs: src @@ -42,25 +43,17 @@ LambdaCase build-depends: base <5 + , exceptions , free , hedgehog - , monad-control - , mtl - , safe-exceptions , sandwich >=0.1.0.4 , string-interpolate , text , time + , unliftio + , vty , wl-pprint-annotated default-language: Haskell2010 - if !os(windows) - build-depends: - vty - if !os(windows) - other-modules: - Test.Sandwich.Hedgehog.Render - hs-source-dirs: - unix-src test-suite sandwich-hedgehog-test type: exitcode-stdio-1.0 @@ -81,17 +74,14 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base <5 + , exceptions , free , hedgehog - , monad-control - , mtl - , safe-exceptions , sandwich >=0.1.0.4 , string-interpolate , text , time + , unliftio + , vty , wl-pprint-annotated default-language: Haskell2010 - if !os(windows) - build-depends: - vty diff --git a/src/Test/Sandwich/Hedgehog.hs b/src/Test/Sandwich/Hedgehog.hs --- a/src/Test/Sandwich/Hedgehog.hs +++ b/src/Test/Sandwich/Hedgehog.hs @@ -56,22 +56,21 @@ ) where import Control.Applicative -import Control.Exception.Safe +import Control.Monad.Catch (MonadCatch) import Control.Monad.Free import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.Trans.Control (MonadBaseControl) import Data.Maybe import Data.String.Interpolate import GHC.Stack import Hedgehog as H import Hedgehog.Internal.Config (UseColor (..)) -import Hedgehog.Internal.Property hiding (Label) -import Hedgehog.Internal.Report as H -import Hedgehog.Internal.Runner as HR -import Hedgehog.Internal.Seed as Seed +import Hedgehog.Internal.Property (PropertyConfig(..), TerminationCriteria, defaultConfig) +import Hedgehog.Internal.Report (Report(..), Result(..), ppResult, renderProgress, renderResult) +import Hedgehog.Internal.Runner (checkReport) +import Hedgehog.Internal.Seed (random) import Test.Sandwich import Test.Sandwich.Internal +import UnliftIO.Exception #ifndef mingw32_HOST_OS import Test.Sandwich.Hedgehog.Render @@ -97,6 +96,7 @@ #endif } deriving (Show) +defaultHedgehogParams :: HedgehogParams defaultHedgehogParams = HedgehogParams { hedgehogSize = Nothing , hedgehogSeed = Nothing @@ -111,41 +111,42 @@ newtype HedgehogContext = HedgehogContext HedgehogParams deriving Show -hedgehogContext = Label :: Label "hedgehogContext" HedgehogContext +hedgehogContext :: Label "hedgehogContext" HedgehogContext +hedgehogContext = Label type HasHedgehogContext context = HasLabel context "hedgehogContext" HedgehogContext -- | Same as 'introduceHedgehog'' but with default 'HedgehogParams'. -introduceHedgehog :: (MonadIO m, MonadBaseControl IO m) +introduceHedgehog :: (MonadIO m) => SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () introduceHedgehog = introduceHedgehog'' "Introduce Hedgehog context" defaultHedgehogParams -- | Same as 'introduceHedgehog''' but with a default message. -introduceHedgehog' :: (MonadIO m, MonadBaseControl IO m) +introduceHedgehog' :: (MonadIO m) => HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () introduceHedgehog' = introduceHedgehog'' "Introduce Hedgehog context" -- | Introduce 'HedgehogParams' with configurable message. -introduceHedgehog'' :: (MonadIO m, MonadBaseControl IO m) +introduceHedgehog'' :: (MonadIO m) => String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () introduceHedgehog'' msg params = introduce msg hedgehogContext (return $ HedgehogContext params) (const $ return ()) -- | Same as 'introduceHedgehogCommandLineOptions'' but with default 'HedgehogParams'. -introduceHedgehogCommandLineOptions :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m) +introduceHedgehogCommandLineOptions :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a)) => SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () introduceHedgehogCommandLineOptions = introduceHedgehogCommandLineOptions'' @a "Introduce Hedgehog context with command line options" defaultHedgehogParams -- | Same as 'introduceHedgehogCommandLineOptions''' but with a default message. -introduceHedgehogCommandLineOptions' :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m) +introduceHedgehogCommandLineOptions' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a)) => HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () introduceHedgehogCommandLineOptions' = introduceHedgehogCommandLineOptions'' @a "Introduce Hedgehog context with command line options" -- | Introduce 'HedgehogParams' with configurable message, overriding those parameters with any command line options passed. -introduceHedgehogCommandLineOptions'' :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m) +introduceHedgehogCommandLineOptions'' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a)) => String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () -introduceHedgehogCommandLineOptions'' msg args = introduce msg hedgehogContext getContext (const $ return ()) +introduceHedgehogCommandLineOptions'' msg args = introduce msg hedgehogContext getContext' (const $ return ()) where - getContext = do + getContext' = do clo <- getCommandLineOptions @a return $ HedgehogContext $ addCommandLineOptions clo args @@ -168,9 +169,9 @@ } let size = fromMaybe 0 hedgehogSize - seed <- maybe Seed.random return hedgehogSeed + seed <- maybe random return hedgehogSeed - finalReport <- checkReport config size seed p $ \progressReport@(Report {..}) -> do + finalReport <- checkReport config size seed p $ \progressReport@(Report {}) -> do -- image <- (return . renderHedgehogToImage) =<< ppProgress Nothing progressReport progress <- renderProgress DisableColor Nothing progressReport @@ -179,18 +180,18 @@ #ifdef mingw32_HOST_OS result <- renderResult EnableColor Nothing finalReport case reportStatus finalReport of - H.Failed fr -> throwIO $ Reason (Just callStack) result - H.GaveUp -> throwIO $ Reason (Just callStack) result - H.OK -> info [i|#{result}|] + Failed fr -> throwIO $ Reason (Just callStack) result + GaveUp -> throwIO $ Reason (Just callStack) result + OK -> info [i|#{result}|] #else image <- (return . renderHedgehogToImage) =<< ppResult Nothing finalReport -- Hedgehog naturally indents everything by 2. Remove this for the fallback text. resultText <- dedent 2 <$> renderResult EnableColor Nothing finalReport case reportStatus finalReport of - H.Failed _ -> throwIO $ RawImage (Just callStack) resultText image - H.GaveUp -> throwIO $ RawImage (Just callStack) resultText image - H.OK -> info [i|#{resultText}|] + Failed _ -> throwIO $ RawImage (Just callStack) resultText image + GaveUp -> throwIO $ RawImage (Just callStack) resultText image + OK -> info [i|#{resultText}|] #endif -- | Modify the 'HedgehogParams' for the given spec. diff --git a/src/Test/Sandwich/Hedgehog/Render.hs b/src/Test/Sandwich/Hedgehog/Render.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Hedgehog/Render.hs @@ -0,0 +1,114 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Test.Sandwich.Hedgehog.Render ( + renderHedgehogToImage + , renderHedgehogToTokens + + -- * Util + , dedent + ) where + +import Data.Function +import qualified Data.List as L +import qualified Data.Text as T +import Graphics.Vty.Attributes hiding (currentAttr) +import Graphics.Vty.Image +import Hedgehog.Internal.Report +import Text.PrettyPrint.Annotated.WL (Doc) +import qualified Text.PrettyPrint.Annotated.WL as WL + + +renderHedgehogToImage :: Doc Markup -> Image +renderHedgehogToImage doc = foldTokens emptyImage defaultAttr $ renderHedgehogToTokens doc + +foldTokens imageSoFar currentAttr ((Str "\n"):xs) = (if imageSoFar == emptyImage then text defaultAttr " " else imageSoFar) <-> foldTokens emptyImage currentAttr xs +foldTokens imageSoFar currentAttr ((Str s):xs) = foldTokens (imageSoFar <|> text' currentAttr s) currentAttr xs +foldTokens imageSoFar _currentAttr ((NewAttr attr):xs) = foldTokens imageSoFar attr xs +foldTokens imageSoFar _currentAttr [] = imageSoFar + +renderHedgehogToTokens :: Doc Markup -> [Token] +renderHedgehogToTokens doc = + WL.indent 0 doc + & WL.renderSmart 100 + & WL.displayDecorated (\x -> [NewAttr $ start x]) end (\x -> [Str (T.pack x)]) + & joinAdjacentStrings + & splitNewlines + where + joinAdjacentStrings ((Str s1):(Str s2):xs) = joinAdjacentStrings (Str (s1 <> s2) : xs) + joinAdjacentStrings (x:xs) = x : joinAdjacentStrings xs + joinAdjacentStrings [] = [] + + splitNewlines :: [Token] -> [Token] + splitNewlines ((Str s):xs) = [Str s' | s' <- parts, s' /= ""] <> splitNewlines xs + where parts = L.intersperse "\n" $ T.splitOn "\n" s + splitNewlines (x:xs) = x : splitNewlines xs + splitNewlines [] = [] + +data Token = Str T.Text + | NewAttr Attr + deriving (Show) + +dedent :: Int -> String -> String +dedent n s + | (replicate n ' ') `L.isPrefixOf` s = L.drop n s + | otherwise = s + +-- * This all is modeled after Hedgehog.Internal.Report + +defaultAttr = Attr Default Default Default Default +redVivid = withForeColor defaultAttr brightRed +redDull = withForeColor defaultAttr red +redVividBold = flip withStyle bold $ withForeColor defaultAttr brightRed +yellowDull = withForeColor defaultAttr yellow +magentaDull = withForeColor defaultAttr magenta +greenDull = withForeColor defaultAttr green +blackVivid = withForeColor defaultAttr brightBlack + +start = \case + WaitingIcon -> defaultAttr + WaitingHeader -> defaultAttr + RunningIcon -> defaultAttr + RunningHeader -> defaultAttr + ShrinkingIcon -> redVivid + ShrinkingHeader -> redVivid + FailedIcon -> redVivid + FailedText -> redVivid + GaveUpIcon -> yellowDull + GaveUpText -> yellowDull + SuccessIcon -> greenDull + SuccessText -> greenDull + CoverageIcon -> yellowDull + CoverageText -> yellowDull + CoverageFill -> blackVivid + + DeclarationLocation -> defaultAttr + + StyledLineNo StyleDefault -> defaultAttr + StyledSource StyleDefault -> defaultAttr + StyledBorder StyleDefault -> defaultAttr + + StyledLineNo StyleAnnotation -> magentaDull + StyledSource StyleAnnotation -> defaultAttr + StyledBorder StyleAnnotation -> defaultAttr + AnnotationGutter -> magentaDull + AnnotationValue -> magentaDull + + StyledLineNo StyleFailure -> redVivid + StyledSource StyleFailure -> redVividBold + StyledBorder StyleFailure -> defaultAttr + FailureArrows -> redVivid + FailureMessage -> defaultAttr + FailureGutter -> defaultAttr + + DiffPrefix -> defaultAttr + DiffInfix -> defaultAttr + DiffSuffix -> defaultAttr + DiffSame -> defaultAttr + DiffRemoved -> redDull + DiffAdded -> greenDull + + ReproduceHeader -> defaultAttr + ReproduceGutter -> defaultAttr + ReproduceSource -> defaultAttr + +end _ = [NewAttr defaultAttr] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,5 +12,5 @@ main = runSandwich options verySimple where options = defaultOptions { - optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime) + optionsTestArtifactsDirectory = defaultTestArtifactsDirectory } diff --git a/unix-src/Test/Sandwich/Hedgehog/Render.hs b/unix-src/Test/Sandwich/Hedgehog/Render.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Hedgehog/Render.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Test.Sandwich.Hedgehog.Render ( - renderHedgehogToImage - , renderHedgehogToTokens - - -- * Util - , dedent - ) where - -import Data.Function -import qualified Data.List as L -import qualified Data.Text as T -import Graphics.Vty.Attributes -import Graphics.Vty.Image -import Hedgehog.Internal.Report -import Text.PrettyPrint.Annotated.WL (Doc) -import qualified Text.PrettyPrint.Annotated.WL as WL - - -renderHedgehogToImage :: Doc Markup -> Image -renderHedgehogToImage doc = foldTokens emptyImage defaultAttr $ renderHedgehogToTokens doc - -foldTokens imageSoFar currentAttr ((Str "\n"):xs) = (if imageSoFar == emptyImage then text defaultAttr " " else imageSoFar) <-> foldTokens emptyImage currentAttr xs -foldTokens imageSoFar currentAttr ((Str s):xs) = foldTokens (imageSoFar <|> text' currentAttr s) currentAttr xs -foldTokens imageSoFar _currentAttr ((NewAttr attr):xs) = foldTokens imageSoFar attr xs -foldTokens imageSoFar _currentAttr [] = imageSoFar - -renderHedgehogToTokens :: Doc Markup -> [Token] -renderHedgehogToTokens doc = - WL.indent 0 doc - & WL.renderSmart 100 - & WL.displayDecorated (\x -> [NewAttr $ start x]) end (\x -> [Str (T.pack x)]) - & joinAdjacentStrings - & splitNewlines - where - joinAdjacentStrings ((Str s1):(Str s2):xs) = joinAdjacentStrings (Str (s1 <> s2) : xs) - joinAdjacentStrings (x:xs) = x : joinAdjacentStrings xs - joinAdjacentStrings [] = [] - - splitNewlines :: [Token] -> [Token] - splitNewlines ((Str s):xs) = [Str s | s <- parts, s /= ""] <> splitNewlines xs - where parts = L.intersperse "\n" $ T.splitOn "\n" s - splitNewlines (x:xs) = x : splitNewlines xs - splitNewlines [] = [] - -data Token = Str T.Text - | NewAttr Attr - deriving (Show) - -dedent :: Int -> String -> String -dedent n s - | (replicate n ' ') `L.isPrefixOf` s = L.drop n s - | otherwise = s - --- * This all is modeled after Hedgehog.Internal.Report - -defaultAttr = Attr Default Default Default Default -redVivid = withForeColor defaultAttr brightRed -redDull = withForeColor defaultAttr red -redVividBold = flip withStyle bold $ withForeColor defaultAttr brightRed -yellowDull = withForeColor defaultAttr yellow -magentaDull = withForeColor defaultAttr magenta -greenDull = withForeColor defaultAttr green -blackVivid = withForeColor defaultAttr brightBlack - -start = \case - WaitingIcon -> defaultAttr - WaitingHeader -> defaultAttr - RunningIcon -> defaultAttr - RunningHeader -> defaultAttr - ShrinkingIcon -> redVivid - ShrinkingHeader -> redVivid - FailedIcon -> redVivid - FailedText -> redVivid - GaveUpIcon -> yellowDull - GaveUpText -> yellowDull - SuccessIcon -> greenDull - SuccessText -> greenDull - CoverageIcon -> yellowDull - CoverageText -> yellowDull - CoverageFill -> blackVivid - - DeclarationLocation -> defaultAttr - - StyledLineNo StyleDefault -> defaultAttr - StyledSource StyleDefault -> defaultAttr - StyledBorder StyleDefault -> defaultAttr - - StyledLineNo StyleAnnotation -> magentaDull - StyledSource StyleAnnotation -> defaultAttr - StyledBorder StyleAnnotation -> defaultAttr - AnnotationGutter -> magentaDull - AnnotationValue -> magentaDull - - StyledLineNo StyleFailure -> redVivid - StyledSource StyleFailure -> redVividBold - StyledBorder StyleFailure -> defaultAttr - FailureArrows -> redVivid - FailureMessage -> defaultAttr - FailureGutter -> defaultAttr - - DiffPrefix -> defaultAttr - DiffInfix -> defaultAttr - DiffSuffix -> defaultAttr - DiffSame -> defaultAttr - DiffRemoved -> redDull - DiffAdded -> greenDull - - ReproduceHeader -> defaultAttr - ReproduceGutter -> defaultAttr - ReproduceSource -> defaultAttr - -end _ = [NewAttr defaultAttr]