diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -3,6 +3,10 @@ ## Unreleased changes +## 0.1.1.0 + +* Windows support. + ## 0.1.0.10 * Initial release. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Tom McLaughlin (c) 2021 +Copyright Tom McLaughlin (c) 2022 All rights reserved. diff --git a/sandwich-hedgehog.cabal b/sandwich-hedgehog.cabal --- a/sandwich-hedgehog.cabal +++ b/sandwich-hedgehog.cabal @@ -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 . 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 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 @@ -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 :: ( diff --git a/src/Test/Sandwich/Hedgehog/Render.hs b/src/Test/Sandwich/Hedgehog/Render.hs deleted file mode 100644 --- a/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] diff --git a/unix-src/Test/Sandwich/Hedgehog/Render.hs b/unix-src/Test/Sandwich/Hedgehog/Render.hs new file mode 100644 --- /dev/null +++ b/unix-src/Test/Sandwich/Hedgehog/Render.hs @@ -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]