packages feed

hedgehog-golden (empty) → 0.6.0

raw patch · 10 files changed

+501/−0 lines, 10 filesdep +Diffdep +aesondep +aeson-prettysetup-changed

Dependencies added: Diff, aeson, aeson-pretty, base, bytestring, containers, directory, extra, hedgehog, hedgehog-golden, text, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hedgehog-golden++## 1.0.0 -- 2019-11-29++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Felix Mulder++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 Felix Mulder 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.
+ README.md view
@@ -0,0 +1,35 @@+Hedgehog Golden+===============+A golden file extension to hedgehog++Hedgehog support+----------------+[Hedgehog](http://hackage.haskell.org/package/hedgehog-1.0) v1.x series is+supported by+[hedgehog-golden](https://hackage.haskell.org/package/hedgehog-golden-1.0.0)+v1.x series++[Hedgehog](http://hackage.haskell.org/package/hedgehog-0.6.1) v0.6.x series is+supported by+[hedgehog-golden](https://hackage.haskell.org/package/hedgehog-golden-0.6.0)+v0.6.x series++Example+-------++```haskell+{-# LANGUAGE TemplateHaskell #-}++import           Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Golden.Aeson as Aeson++-- | A golden test for characters in the hex range+prop_char_golden :: Property+prop_char_golden =+  Aeson.goldenProperty Gen.hexit++tests :: IO Bool+tests =+  checkParallel $$discover+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hedgehog-golden.cabal view
@@ -0,0 +1,89 @@+cabal-version: 2.4++version:+  0.6.0+name:+  hedgehog-golden+author:+  Felix Mulder+maintainer:+  felix.mulder@gmail.com+synopsis:+  Golden testing capabilities for hedgehog using Aeson+description:+  Golden testing capabilities for hedgehog using Aeson.+  Generates pretty output in cases of errors and uses+  Hedgehog to eat all your bugs!+homepage:+  https://github.com/felixmulder/hedgehog-golden+bug-reports:+  https://github.com/felixmulder/hedgehog-golden/issues+license:+  BSD-3-Clause+license-file:+  LICENSE+category:+  Testing+extra-source-files:+  CHANGELOG.md+  README.md++source-repository head+  type: git+  location: git://github.com/felixmulder/hedgehog-golden.git++common options+  default-language:+    Haskell2010+  ghc-options:+    -Wall -Wredundant-constraints -fhide-source-paths+  default-extensions:+    GeneralizedNewtypeDeriving+    LambdaCase+    NoImplicitPrelude+    OverloadedStrings+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    TupleSections+    TypeApplications+    ViewPatterns++library+  import:+    options+  hs-source-dirs:+    src+  exposed-modules:+    Hedgehog.Golden.Aeson+  other-modules:+    Hedgehog.Golden.Types+    Hedgehog.Golden.Sample+    Hedgehog.Golden.Internal.Source+  build-depends:+    , aeson ^>= 1.4.2.0+    , aeson-pretty ^>= 0.8.7+    , base ^>=4.12.0.0+    , bytestring ^>=0.10.8.0+    , containers ^>=0.6.0.1+    , Diff ^>=0.3.4+    , directory ^>=1.3.3.0+    , extra ^>= 1.6.0+    , hedgehog ^>= 0.6.1+    , text ^>=1.2.3.1+    , transformers ^>= 0.5.6.2++test-suite test+  import:+    options+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    test+  main-is:+    Main.hs+  other-modules:+  build-depends:+    , base ^>=4.12.0.0+    , hedgehog ^>= 0.6.1+    , hedgehog-golden
+ src/Hedgehog/Golden/Aeson.hs view
@@ -0,0 +1,214 @@+-- | This module can be used in order to create golden tests for Aeson+--   serializers and deserializers+--+--   @+--   {-\# LANGUAGE TemplateHaskell \#-}+--+--   import           Hedgehog+--   import qualified Hedgehog.Gen as Gen+--   import qualified Hedgehog.Golden.Aeson as Aeson+--+--   -- | A golden test for characters in the hex range+--   prop_char_golden :: Property+--   prop_char_golden = Aeson.goldenProperty Gen.hexit+--+--   tests :: IO Bool+--   tests = checkParallel $$discover+--   @+module Hedgehog.Golden.Aeson+  ( -- * Golden tests for generators+    goldenProperty+  , goldenProperty'+  ) where++import           Prelude++import           Control.Monad (forM_)+import           Control.Monad.IO.Class (MonadIO(..))+import           Data.Algorithm.Diff (Diff(..), getDiff)+import           Data.Aeson (FromJSON, ToJSON, (.=), (.:))+import qualified Data.Aeson as Aeson (eitherDecodeStrict)+import qualified Data.Aeson.Types as Aeson+import           Data.Aeson.Encode.Pretty (Config(..), Indent(..), encodePretty', defConfig)+import qualified Data.ByteString.Lazy as ByteString (toStrict)+import           Data.Proxy (Proxy(..))+import           Data.Sequence (Seq)+import           Data.Text (Text)+import qualified Data.Text as Text (intercalate, lines, pack, unpack)+import qualified Data.Text.Encoding as Text (decodeUtf8, encodeUtf8)+import qualified Data.Text.IO as Text (readFile, writeFile)+import           Data.Typeable (Typeable, typeRep)+import           Hedgehog (Gen, Property, PropertyT, Seed(..))+import           Hedgehog (success)+import qualified Hedgehog.Internal.Seed as Seed+import           Hedgehog.Internal.Source+import           Hedgehog.Internal.Property (Log(..), Property(..), PropertyConfig(..))+import           Hedgehog.Internal.Property (defaultConfig, evalM, failWith, writeLog)+import           Hedgehog.Golden.Sample (genSamples)+import           Hedgehog.Golden.Types (GoldenTest(..), ValueGenerator, ValueReader)+import qualified Hedgehog.Golden.Internal.Source as Source+import           System.Directory (createDirectoryIfMissing, doesFileExist)++-- | Run a golden test on the given generator+--+--   This will create a file in @golden/<TypeName>.json.new@ in case it does not+--   exist. If it does exist - the golden tests will be run against it+--+goldenProperty :: forall a+   . HasCallStack+  => Typeable a+  => FromJSON a+  => ToJSON a+  => Gen a -> Property+goldenProperty = withFrozenCallStack $ goldenProperty' "golden/"++-- | Same as 'goldenProperty' but allows specifying the directory+--+goldenProperty' :: forall a+   . HasCallStack+  => Typeable a+  => FromJSON a+  => ToJSON a+  => FilePath -> Gen a -> Property+goldenProperty' baseDir gen = withFrozenCallStack $+  Property defaultConfig { propertyTestLimit = 1, propertyShrinkLimit = 0 } . evalM $+    goldenTest baseDir gen >>= \case+      NewFile fileName valGen -> do+        newGoldenFile baseDir fileName valGen+      ExistingFile fileName valGen readerM ->+        existingGoldenFile baseDir fileName valGen readerM++newGoldenFile :: HasCallStack => FilePath -> FilePath -> ValueGenerator -> PropertyT IO ()+newGoldenFile basePath fileName gen = do+  seed <- Seed.random+  -- Create new file+  liftIO $ do+    createDirectoryIfMissing False basePath+    Text.writeFile (fileName <> ".new") . Text.intercalate "\n" . gen $ seed++  -- Annotate output+  writeLog . Footnote $ "New golden file generated in: " <> fileName+  failWith Nothing "No previous golden file exists"++existingGoldenFile ::+     HasCallStack+  => FilePath -> FilePath -> ValueGenerator -> Maybe ValueReader -> PropertyT IO ()+existingGoldenFile basePath fp gen reader = getSeedAndLines >>= \case+  Right (seed, existingLines) ->+    let+      comparison =+        getDiff existingLines $ gen seed++      hasDifference = any $ \case+        Both _ _ -> False+        First _  -> True+        Second _ -> True++      runDecodeTest = forM_ reader $ \r ->+        either+          (failWith Nothing . (<>) "Failed to deserialize with error: " . Text.unpack)+          (const success)+          (r . Text.intercalate "\n" $ existingLines)+    in+      if hasDifference comparison then do+        liftIO $ do+          createDirectoryIfMissing False basePath+          Text.writeFile (fp <> ".gen") . Text.intercalate "\n" . gen $ seed++        writeLog . Footnote $+          "Different file generated as: " <> fp <> ".gen"++        failWith Nothing . Text.unpack . Text.intercalate "\n" $+          [ "Failed in serialization comparison"+          , ""+          , Source.yellow "Difference when generating: " <> Text.pack fp+          , printDifference comparison+          ]+      else+        runDecodeTest+  Left err ->+    failWith Nothing $ "Couldn't read previous golden file (" <> fp <> ") because: " <> err+  where+    getSeedAndLines = liftIO $ do+      fileContents <- Text.readFile fp+      pure . fmap (, Text.lines fileContents) . decodeSeed $ fileContents++printDifference :: [Diff Text] -> Text+printDifference+  = Text.intercalate "\n"+  . Source.wrap Source.boxTop Source.boxBottom+  . addLineNumbers 1+  . renderDiff+  where+    renderDiff :: [Diff Text] -> [Diff Text]+    renderDiff =+      fmap $ \case+        Both text _ -> Both (" " <> text) (" " <> text)+        First text  -> First $ Source.red $ "-" <> text+        Second text -> Second $ Source.green $ "+" <> text++    addLineNumbers :: Int -> [Diff Text] -> [Text]+    addLineNumbers _ [] = []+    addLineNumbers i (d : ds) = case d of+      Both text _ ->+        Source.addLineNumber i text : addLineNumbers (i + 1) ds+      First text ->+        Source.addLineNumber i text : addLineNumbers i ds+      Second text ->+        Source.addLineNumber i text : addLineNumbers (i + 1) ds++goldenTest :: forall a m+   . Typeable a+  => FromJSON a+  => ToJSON a+  => MonadIO m+  => FilePath -> Gen a -> m GoldenTest+goldenTest prefix gen =+  let+    typeName = show . typeRep $ Proxy @a+    fileName = prefix <> typeName <> ".json"+    aesonValueGenerator seed = Text.lines . encodeGolden seed $ genSamples seed gen+    aesonValueReader t =+      either (Left . Text.pack) (const $ Right ()) $+        Aeson.eitherDecodeStrict (Text.encodeUtf8 t) >>= decodeGolden @a+  in liftIO $ do+    fileExists <- doesFileExist fileName+    pure $ if fileExists then+      ExistingFile fileName aesonValueGenerator (Just aesonValueReader)+    else+      NewFile fileName aesonValueGenerator++encodeGolden :: ToJSON a => Seed -> Seq a -> Text+encodeGolden seed samples =+  let+    aesonSeed (Seed value gamma) =+      Aeson.object [ "value" .= value, "gamma" .= gamma ]++    encodePretty =+      Text.decodeUtf8 . ByteString.toStrict . encodePretty' defConfig+        { confIndent = Spaces 2+        , confCompare = compare+        }+  in+    encodePretty $+      Aeson.object [ "seed" .= aesonSeed seed, "samples" .= Aeson.toJSON samples ]++decodeSeed :: Text -> Either String Seed+decodeSeed text =+  let+    getSeed :: Aeson.Object -> Either String Seed+    getSeed =+      Aeson.parseEither $ \obj -> do+        value <- obj .: "seed" >>= (.: "value")+        gamma <- obj .: "seed" >>= (.: "gamma")+        pure $ Seed value gamma+  in+    Aeson.eitherDecodeStrict (Text.encodeUtf8 text) >>= getSeed++decodeGolden :: FromJSON a => Aeson.Object -> Either String (Seed, Seq a)+decodeGolden = Aeson.parseEither $ \obj -> do+  value <- obj .: "seed" >>= (.: "value")+  gamma <- obj .: "seed" >>= (.: "gamma")+  samples <- obj .: "samples"+  pure (Seed value gamma, samples)+
+ src/Hedgehog/Golden/Internal/Source.hs view
@@ -0,0 +1,57 @@+module Hedgehog.Golden.Internal.Source+  ( -- * Functions for producing diff+    addLineNumber+  , addLineNumbers+  , added+  , boxBottom+  , boxTop+  , removed+  , wrap+  -- * Colors+  , green+  , red+  , white+  , yellow+  ) where++import           Prelude++import           Data.Text (Text)+import qualified Data.Text as Text++addLineNumbers :: [Text] -> [Text]+addLineNumbers =+  fmap (uncurry addLineNumber) . zip [1..]++addLineNumber :: Int -> Text -> Text+addLineNumber lineNumber line+  | lineNumber < 10 = "   " <> Text.pack (show lineNumber) <> " │" <> line+  | lineNumber < 100 = "  " <> Text.pack (show lineNumber) <> " │" <> line+  | otherwise = " " <> Text.pack (show lineNumber) <> " │" <> line++wrap :: Text -> Text -> [Text] -> [Text]+wrap start end mid = [start] ++ mid ++ [end]++boxTop :: Text+boxTop = Text.replicate 5 "─" <> "┬" <> Text.replicate 55 "─"++boxBottom :: Text+boxBottom = Text.replicate 5 "─" <> "┴" <> Text.replicate 55 "─"++red :: Text -> Text+red t = "\ESC[31;1m" <> t <> "\ESC[0m"++yellow :: Text -> Text+yellow t = "\ESC[33;1m" <> t <> "\ESC[0m"++green :: Text -> Text+green t = "\ESC[32;1m" <> t <> "\ESC[0m"++white :: Text -> Text+white t = "\ESC[37;1m" <> t <> "\ESC[0m"++added :: Text -> Text+added = green . ("+" <>)++removed :: Text -> Text+removed  = red . ("-" <>)
+ src/Hedgehog/Golden/Sample.hs view
@@ -0,0 +1,32 @@+module Hedgehog.Golden.Sample+  ( genSamples+  ) where++import           Prelude++import           Data.Functor.Identity (runIdentity)+import           Data.Sequence (Seq)+import           Hedgehog+import qualified Hedgehog.Internal.Gen as Gen+import qualified Hedgehog.Internal.Tree as Tree+import qualified Hedgehog.Range as Range+import           Control.Monad.Trans.Maybe (MaybeT(..))++-- | Generate a fixed Seq of @a@ from the given generator+genSamples :: Seed -> Gen a -> Seq a+genSamples seed gen =+  let+    loop n = \case+      Just tree -> tree+      Nothing ->+        if n < 0 then+          error "Too many discards - abandoned generating samples"+        else+          loop (n - 1)+            . fmap Tree.nodeValue+            . runIdentity+            . runMaybeT+            . Tree.runTree+            . Gen.runGenT 0 seed $ Gen.seq (Range.singleton 10) gen+  in+    loop (100 :: Int) Nothing
+ src/Hedgehog/Golden/Types.hs view
@@ -0,0 +1,14 @@+module Hedgehog.Golden.Types where++import           Prelude++import           Data.Text (Text)+import           Hedgehog (Seed)++type ValueGenerator = Seed -> [Text]++type ValueReader = Text -> Either Text ()++data GoldenTest+  = NewFile FilePath ValueGenerator+  | ExistingFile FilePath ValueGenerator (Maybe ValueReader)
+ test/Main.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}+module Main (main) where++import           Prelude++import           Control.Monad (unless)+import           Hedgehog (Property)+import           Hedgehog (checkParallel, discover)+import qualified Hedgehog.Golden.Aeson as Aeson+import qualified Hedgehog.Gen as Gen+import           System.Exit (exitFailure)++prop_hexit :: Property+prop_hexit = Aeson.goldenProperty Gen.hexit++prop_bool :: Property+prop_bool = Aeson.goldenProperty Gen.bool++tests :: IO Bool+tests = checkParallel $$discover++main :: IO ()+main = tests >>= flip unless exitFailure