packages feed

sandwich-hedgehog (empty) → 0.1.0.10

raw patch · 7 files changed

+468/−0 lines, 7 filesdep +basedep +freedep +hedgehogsetup-changed

Dependencies added: base, free, hedgehog, monad-control, mtl, safe-exceptions, sandwich, string-interpolate, text, time, vty, wl-pprint-annotated

Files

+ ChangeLog.md view
@@ -0,0 +1,8 @@+# Changelog for sandwich-hedgehog++## Unreleased changes+++## 0.1.0.10++* Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tom McLaughlin (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tom McLaughlin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sandwich-hedgehog.cabal view
@@ -0,0 +1,89 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           sandwich-hedgehog+version:        0.1.0.10+synopsis:       Sandwich integration with Hedgehog+description:    Please see the <https://codedownio.github.io/sandwich/docs/extensions/sandwich-hedgehog documentation>.+category:       Testing+homepage:       https://codedownio.github.io/sandwich+bug-reports:    https://github.com/codedownio/sandwich-hedgehog/issues+author:         Tom McLaughlin+maintainer:     tom@codedown.io+copyright:      2021 Tom McLaughlin+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/codedownio/sandwich-hedgehog++library+  exposed-modules:+      Test.Sandwich.Hedgehog+  other-modules:+      Test.Sandwich.Hedgehog.Render+      Paths_sandwich_hedgehog+  hs-source-dirs:+      src+  default-extensions:+      OverloadedStrings+      QuasiQuotes+      NamedFieldPuns+      RecordWildCards+      ScopedTypeVariables+      FlexibleContexts+      FlexibleInstances+      LambdaCase+  build-depends:+      base <5+    , free+    , hedgehog+    , monad-control+    , mtl+    , safe-exceptions+    , sandwich >=0.1.0.4+    , string-interpolate+    , text+    , time+    , vty+    , wl-pprint-annotated+  default-language: Haskell2010++test-suite sandwich-hedgehog-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_sandwich_hedgehog+  hs-source-dirs:+      test+  default-extensions:+      OverloadedStrings+      QuasiQuotes+      NamedFieldPuns+      RecordWildCards+      ScopedTypeVariables+      FlexibleContexts+      FlexibleInstances+      LambdaCase+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base <5+    , free+    , hedgehog+    , monad-control+    , mtl+    , safe-exceptions+    , sandwich >=0.1.0.4+    , string-interpolate+    , text+    , time+    , vty+    , wl-pprint-annotated+  default-language: Haskell2010
+ src/Test/Sandwich/Hedgehog.hs view
@@ -0,0 +1,209 @@+-- | Functions for introducing Hedgehog tests into a Sandwich test tree. Modelled after Hspec's version.+--+-- Documentation can be found <https://codedownio.github.io/sandwich/docs/extensions/sandwich-hedgehog here>.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}++module Test.Sandwich.Hedgehog (+  -- * Introducing a Hedgehog context+  -- Any tests that use Hedgehog should be wrapped in one of these.+  introduceHedgehog+  , introduceHedgehog'+  , introduceHedgehog''++  -- * Prop+  , prop++  -- * Params+  , HedgehogParams+  , defaultHedgehogParams+  , hedgehogDiscardLimit+  , hedgehogShrinkLimit+  , hedgehogShrinkRetries+  , hedgehogTerminationCriteria+  , hedgehogSize+  , hedgehogSeed++  -- * Versions that can be configured with built-in command line arguments.+  -- Pass --print-hedgehog-flags to list them.+  , introduceHedgehogCommandLineOptions+  , introduceHedgehogCommandLineOptions'+  , introduceHedgehogCommandLineOptions''+  , addCommandLineOptions++  -- * Modifying Hedgehog args+  , modifyArgs+  , modifyDiscardLimit+  , modifyShrinkLimit+  , modifyShrinkRetries+  , modifyTerminationCriteria+  , modifySize+  , modifySeed++  -- * Misc+  , HasHedgehogContext+  ) where++import Control.Applicative+import Control.Exception.Safe+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 Test.Sandwich+import Test.Sandwich.Hedgehog.Render+import Test.Sandwich.Internal+++data HedgehogParams = HedgehogParams {+  -- | Random number generator seed.+  hedgehogSeed :: Maybe Seed+  -- | Size of the randomly-generated data.+  , hedgehogSize :: Maybe Size+  -- | The number of times a property is allowed to discard before the test runner gives up.+  , hedgehogDiscardLimit :: Maybe DiscardLimit+  -- | The number of times a property is allowed to shrink before the test runner gives up and prints the counterexample.+  , hedgehogShrinkLimit :: Maybe ShrinkLimit+  -- | The number of times to re-run a test during shrinking.+  , hedgehogShrinkRetries :: Maybe ShrinkRetries+  -- | Control when the test runner should terminate.+  , hedgehogTerminationCriteria :: Maybe TerminationCriteria+  } deriving (Show)++defaultHedgehogParams = HedgehogParams {+  hedgehogSize = Nothing+  , hedgehogSeed = Nothing+  , hedgehogDiscardLimit = Nothing+  , hedgehogShrinkLimit = Nothing+  , hedgehogShrinkRetries = Nothing+  , hedgehogTerminationCriteria = Nothing+  }++newtype HedgehogContext = HedgehogContext HedgehogParams+  deriving Show+hedgehogContext = Label :: Label "hedgehogContext" HedgehogContext+type HasHedgehogContext context = HasLabel context "hedgehogContext" HedgehogContext++-- | Same as 'introduceHedgehog'' but with default 'HedgehogParams'.+introduceHedgehog :: (MonadIO m, MonadBaseControl IO 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)+  => 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)+  => 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)+  => 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)+  => 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)+  => String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()+introduceHedgehogCommandLineOptions'' msg args = introduce msg hedgehogContext getContext (const $ return ())+  where+    getContext = do+      clo <- getCommandLineOptions @a+      return $ HedgehogContext $ addCommandLineOptions clo args+++-- | Similar to 'it'. Runs the given propery with Hedgehog using the currently introduced 'HedgehogParams'. Throws an appropriate exception on failure.+prop :: (HasCallStack, HasHedgehogContext context, MonadIO m, MonadCatch m) => String -> PropertyT (ExampleT context m) () -> Free (SpecCommand context m) ()+prop msg p = it msg $ do+  HedgehogContext (HedgehogParams {..}) <- getContext hedgehogContext++  let config = PropertyConfig {+        propertyDiscardLimit = fromMaybe (propertyDiscardLimit defaultConfig) hedgehogDiscardLimit+        , propertyShrinkLimit = fromMaybe (propertyShrinkLimit defaultConfig) hedgehogShrinkLimit+        , propertyShrinkRetries = fromMaybe (propertyShrinkRetries defaultConfig) hedgehogShrinkRetries+        , propertyTerminationCriteria = fromMaybe (propertyTerminationCriteria defaultConfig) hedgehogTerminationCriteria+        }++  let size = fromMaybe 0 hedgehogSize+  seed <- maybe Seed.random return hedgehogSeed++  finalReport <- checkReport config size seed p $ \progressReport@(Report {..}) -> do+    -- image <- (return . renderHedgehogToImage) =<< ppProgress Nothing progressReport++    progress <- renderProgress DisableColor Nothing progressReport+    debug [i|#{progress}|]++  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}|]++-- | Modify the 'HedgehogParams' for the given spec.+modifyArgs :: (+  HasHedgehogContext context, Monad m+  ) => (HedgehogParams -> HedgehogParams) -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()+modifyArgs f = introduce "Modified Hedgehog context" hedgehogContext acquire (const $ return ())+  where+    acquire = do+       HedgehogContext params <- getContext hedgehogContext+       return $ HedgehogContext (f params)++type HedgehogContextLabel context = LabelValue "hedgehogContext" HedgehogContext :> context++-- | Modify the 'Seed' for the given spec.+modifySeed :: (HasHedgehogContext context, Monad m) => (Maybe Seed -> Maybe Seed) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()+modifySeed f = modifyArgs $ \args -> args { hedgehogSeed = f (hedgehogSeed args) }++-- | Modify the 'Size' for the given spec.+modifySize :: (HasHedgehogContext context, Monad m) => (Maybe Size -> Maybe Size) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()+modifySize f = modifyArgs $ \args -> args { hedgehogSize = f (hedgehogSize args) }++-- | Modify the 'DiscardLimit' for the given spec.+modifyDiscardLimit :: (HasHedgehogContext context, Monad m) => (Maybe DiscardLimit -> Maybe DiscardLimit) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()+modifyDiscardLimit f = modifyArgs $ \args -> args { hedgehogDiscardLimit = f (hedgehogDiscardLimit args) }++-- | Modify the 'ShrinkLimit' for the given spec.+modifyShrinkLimit :: (HasHedgehogContext context, Monad m) => (Maybe ShrinkLimit -> Maybe ShrinkLimit) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()+modifyShrinkLimit f = modifyArgs $ \args -> args { hedgehogShrinkLimit = f (hedgehogShrinkLimit args) }++-- | Modify the 'ShrinkRetries' for the given spec.+modifyShrinkRetries :: (HasHedgehogContext context, Monad m) => (Maybe ShrinkRetries -> Maybe ShrinkRetries) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()+modifyShrinkRetries f = modifyArgs $ \args -> args { hedgehogShrinkRetries = f (hedgehogShrinkRetries args) }++-- | Modify the 'TerminationCriteria' for the given spec.+modifyTerminationCriteria :: (HasHedgehogContext context, Monad m) => (Maybe TerminationCriteria -> Maybe TerminationCriteria) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()+modifyTerminationCriteria f = modifyArgs $ \args -> args { hedgehogTerminationCriteria = f (hedgehogTerminationCriteria args) }++addCommandLineOptions :: CommandLineOptions a -> HedgehogParams -> HedgehogParams+addCommandLineOptions (CommandLineOptions {optHedgehogOptions=(CommandLineHedgehogOptions {..})}) baseHedgehogParams@(HedgehogParams {..}) = baseHedgehogParams {+  hedgehogSeed = (read <$> optHedgehogSeed) <|> hedgehogSeed+  , hedgehogSize = (fromIntegral <$> optHedgehogSize) <|> hedgehogSize+  , hedgehogDiscardLimit = (fromIntegral <$> optHedgehogDiscardLimit) <|> hedgehogDiscardLimit+  , hedgehogShrinkLimit = (fromIntegral <$> optHedgehogShrinkLimit) <|> hedgehogShrinkLimit+  , hedgehogShrinkRetries = (fromIntegral <$> optHedgehogShrinkRetries) <|> hedgehogShrinkRetries+  }
+ 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]
+ test/Spec.hs view
@@ -0,0 +1,16 @@++import Test.Sandwich+import Data.Time.Clock+import Test.Sandwich.Formatters.Print+++verySimple :: TopSpec+verySimple = do+  it "succeeds" (return ())++main :: IO ()+main = runSandwich options verySimple+  where+    options = defaultOptions {+      optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime)+      }