sandwich-hedgehog 0.1.3.0 → 0.1.3.1

raw patch · 7 files changed

+155/−160 lines, 7 filesdep +exceptionsdep +unliftiodep −monad-controldep −mtldep −safe-exceptionsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: exceptions, unliftio

Dependencies removed: monad-control, mtl, safe-exceptions

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• LICENSE +1/−1
• sandwich-hedgehog.cabal +10/−20
• src/Test/Sandwich/Hedgehog.hs +25/−24
• src/Test/Sandwich/Hedgehog/Render.hs +114/−0
• test/Spec.hs +1/−1
• unix-src/Test/Sandwich/Hedgehog/Render.hs +0/−114

@@ -2,6 +2,10 @@  ## Unreleased +## 0.1.3.1++* Support hedgehog-1.5+ ## 0.1.3.0  * Fix bug-reports URL

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

@@ -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 <https://codedownio.github.io/sandwich/docs/extensions/sandwich-hedgehog documentation>. 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

@@ -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.

@@ -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]

@@ -12,5 +12,5 @@ main = runSandwich options verySimple   where     options = defaultOptions {-      optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime)+      optionsTestArtifactsDirectory = defaultTestArtifactsDirectory       }

@@ -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]