sandwich-hedgehog 0.1.0.10 → 0.1.1.0
raw patch · 6 files changed
+145/−121 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- LICENSE +1/−1
- sandwich-hedgehog.cabal +13/−5
- src/Test/Sandwich/Hedgehog.hs +13/−1
- src/Test/Sandwich/Hedgehog/Render.hs +0/−114
- unix-src/Test/Sandwich/Hedgehog/Render.hs +114/−0
ChangeLog.md view
@@ -3,6 +3,10 @@ ## Unreleased changes +## 0.1.1.0++* Windows support.+ ## 0.1.0.10 * Initial release.
LICENSE view
@@ -1,4 +1,4 @@-Copyright Tom McLaughlin (c) 2021+Copyright Tom McLaughlin (c) 2022 All rights reserved.
sandwich-hedgehog.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sandwich-hedgehog-version: 0.1.0.10+version: 0.1.1.0 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-hedgehog/issues author: Tom McLaughlin maintainer: tom@codedown.io-copyright: 2021 Tom McLaughlin+copyright: 2022 Tom McLaughlin license: BSD3 license-file: LICENSE build-type: Simple@@ -28,7 +28,6 @@ exposed-modules: Test.Sandwich.Hedgehog other-modules:- Test.Sandwich.Hedgehog.Render Paths_sandwich_hedgehog hs-source-dirs: src@@ -52,8 +51,15 @@ , string-interpolate , text , time- , vty , wl-pprint-annotated+ if !os(windows)+ build-depends:+ vty+ if !os(windows)+ other-modules:+ Test.Sandwich.Hedgehog.Render+ hs-source-dirs:+ unix-src default-language: Haskell2010 test-suite sandwich-hedgehog-test@@ -84,6 +90,8 @@ , string-interpolate , text , time- , vty , wl-pprint-annotated+ if !os(windows)+ build-depends:+ vty default-language: Haskell2010
src/Test/Sandwich/Hedgehog.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE CPP #-} module Test.Sandwich.Hedgehog ( -- * Introducing a Hedgehog context@@ -64,10 +65,13 @@ import Hedgehog.Internal.Runner as HR import Hedgehog.Internal.Seed as Seed import Test.Sandwich-import Test.Sandwich.Hedgehog.Render import Test.Sandwich.Internal +#ifndef mingw32_HOST_OS+import Test.Sandwich.Hedgehog.Render+#endif + data HedgehogParams = HedgehogParams { -- | Random number generator seed. hedgehogSeed :: Maybe Seed@@ -154,6 +158,13 @@ progress <- renderProgress DisableColor Nothing progressReport debug [i|#{progress}|] +#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}|]+#else image <- (return . renderHedgehogToImage) =<< ppResult Nothing finalReport -- Hedgehog naturally indents everything by 2. Remove this for the fallback text.@@ -162,6 +173,7 @@ H.Failed _ -> throwIO $ RawImage (Just callStack) resultText image H.GaveUp -> throwIO $ RawImage (Just callStack) resultText image H.OK -> info [i|#{resultText}|]+#endif -- | Modify the 'HedgehogParams' for the given spec. modifyArgs :: (
− src/Test/Sandwich/Hedgehog/Render.hs
@@ -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]
+ unix-src/Test/Sandwich/Hedgehog/Render.hs view
@@ -0,0 +1,114 @@+{-# 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]