diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,15 @@ +ISC License + +Copyright (c) 2022 Gautier DI FOLCO + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY +AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM +LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR +OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. diff --git a/adhoc-fixtures-hspec.cabal b/adhoc-fixtures-hspec.cabal new file mode 100644 --- /dev/null +++ b/adhoc-fixtures-hspec.cabal @@ -0,0 +1,94 @@ +cabal-version: 3.0 +name: adhoc-fixtures-hspec +version: 0.1.0.0 +author: Gautier DI FOLCO +maintainer: gautier.difolco@gmail.com +category: Data +build-type: Simple +license: ISC +license-file: LICENSE +synopsis: Manage fine grained fixtures +description: Helps improves tests crafting per-test fixtures (hspec support) +Homepage: http://github.com/blackheaven/adhoc-fixtures-hspec +tested-with: GHC==9.2.4 + +library + default-language: Haskell2010 + build-depends: + base == 4.* + , adhoc-fixtures >= 0.1.0.0 && < 1 + , hspec >= 2.7.0 && < 2.11 + , yarl >= 0.1.0.0 && < 1 + hs-source-dirs: src + exposed-modules: + Data.Fixtures.Adhoc.Hspec + other-modules: + Paths_adhoc_fixtures_hspec + autogen-modules: + Paths_adhoc_fixtures_hspec + default-extensions: + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + GADTs + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + OverloadedLists + OverloadedStrings + OverloadedRecordDot + RankNTypes + RecordWildCards + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + +test-suite adhoc-fixtures-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Data.Fixtures.Adhoc.HspecSpec + Paths_adhoc_fixtures_hspec + autogen-modules: + Paths_adhoc_fixtures_hspec + default-extensions: + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + GADTs + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + OverloadedLists + OverloadedStrings + OverloadedRecordDot + RankNTypes + RecordWildCards + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + build-depends: + base + , adhoc-fixtures + , adhoc-fixtures-hspec + , hspec + , hspec-core + , hspec-discover + , safe-exceptions + , yarl + default-language: Haskell2010 diff --git a/src/Data/Fixtures/Adhoc/Hspec.hs b/src/Data/Fixtures/Adhoc/Hspec.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fixtures/Adhoc/Hspec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +-- | +-- Module : Data.Fixtures.Adhoc.Hspec +-- Copyright : Gautier DI FOLCO +-- License : ISC +-- +-- Maintainer : Gautier DI FOLCO +-- Stability : Unstable +-- Portability : not portable +-- +-- Fixtures builder and runner +-- +-- Example: +-- +-- > aroundAllWith (withFixtureAppendLift @"tracker" @_ @"box" boxFixture) $ do +-- > it "Tracker should have one key (added)" $ \fixture -> +-- > readIORef fixture.tracker `shouldReturn` [("box00", 42)] +module Data.Fixtures.Adhoc.Hspec + ( withFixtureAppendLift, + withFixtureAppend, + ) +where + +import Data.Fixtures.Adhoc +import Data.Records.Yarl.LinkedList +import GHC.TypeLits +import Test.Hspec + +-- | Fixture builder (should be used directly with care) +withFixtureAppendLift :: + forall (name :: Symbol) a (builderName :: Symbol) b. + HasNotField builderName '[Field name a] => + BuilderWith '[Field name a] IO builderName b -> + ActionWith (Record '[Field builderName b, Field name a]) -> + ActionWith a +withFixtureAppendLift builderWith runTest previousArgs = + runWithFixtures (builderWith &: build @name (return previousArgs) &: nullBuilder) runTest + +withFixtureAppend :: + forall (builderName :: Symbol) b items. + HasNotField builderName items => + BuilderWith items IO builderName b -> + ActionWith (Record (Field builderName b ': items)) -> + ActionWith (Record items) +withFixtureAppend builderWith runTest previousArgs = + runWithFixtures (builderWith &> previousArgs) runTest diff --git a/test/Data/Fixtures/Adhoc/HspecSpec.hs b/test/Data/Fixtures/Adhoc/HspecSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Fixtures/Adhoc/HspecSpec.hs @@ -0,0 +1,85 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Data.Fixtures.Adhoc.HspecSpec (main, spec) where + +import Control.Exception.Safe (bracket) +import Data.Fixtures.Adhoc +import Data.Fixtures.Adhoc.Hspec +import Data.IORef +import GHC.Exts (IsString (..)) +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = + describe "Adhoc fixtures" $ + aroundAll (withIORef @[(Key, Int)] mempty) $ do + it "Tracker should be empty (start blank)" $ \tracker -> + readIORef tracker `shouldReturn` [] + aroundAllWith (withFixtureAppendLift @"tracker" @_ @"box" boxFixture) $ do + it "Tracker should have one key (added)" $ \fixture -> + readIORef fixture.tracker `shouldReturn` [("box00", 42)] + aroundAllWith (withFixtureAppend @"book" bookFixture) $ do + it "Tracker should have two keys (added)" $ \fixture -> + readIORef fixture.tracker `shouldReturn` [("book00", 42), ("box00", 42)] + it "Tracker should have one key (cleaned)" $ \fixture -> + readIORef fixture.tracker `shouldReturn` [("box00", 42)] + it "Tracker should be empty (start cleaned)" $ \tracker -> + readIORef tracker `shouldReturn` [] + +newtype Key = Key {getKey :: String} + deriving stock (Eq, Ord, Show) + deriving newtype (IsString) + +data Box = Box + { boxId :: Int, + boxKey :: Key + } + deriving stock (Eq, Show) + +data Book = Book + { bookId :: Int, + bookBox :: Int, + bookKey :: Key + } + deriving stock (Eq, Show) + +type Tracker = IORef [(Key, Int)] + +addId :: Key -> Int -> Tracker -> IO () +addId k i t = modifyIORef' t ((k, i) :) + +rmId :: Key -> Tracker -> IO () +rmId k t = modifyIORef' t $ filter ((/= k) . fst) + +unsafeGetId :: Key -> Tracker -> IO Int +unsafeGetId k t = snd . head . filter ((== k) . fst) <$> readIORef t + +boxFixture :: + HasFixture items "tracker" Tracker => + BuilderWith items IO "box" Box +boxFixture = + buildWithClean + (\prev -> let box = Box 42 "box00" in addId box.boxKey box.boxId prev.tracker >> return box) + (\prev box -> rmId box.boxKey prev.tracker) + +bookFixture :: + (HasFixture items "tracker" Tracker, HasFixture items "box" Box) => + BuilderWith items IO "book" Book +bookFixture = + buildWithClean + ( \prev -> do + box <- unsafeGetId "book00" prev.tracker + let book = Book 42 box "book00" + addId book.bookKey book.bookId prev.tracker + return book + ) + (\prev book -> rmId book.bookKey prev.tracker) + +withIORef :: a -> (IORef a -> IO ()) -> IO () +withIORef x = + bracket + (newIORef x) + (const $ return ()) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}