packages feed

adhoc-fixtures (empty) → 0.1.0.0

raw patch · 5 files changed

+265/−0 lines, 5 filesdep +adhoc-fixturesdep +basedep +hspec

Dependencies added: adhoc-fixtures, base, hspec, hspec-core, hspec-discover, safe-exceptions, yarl

Files

+ LICENSE view
@@ -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.
+ adhoc-fixtures.cabal view
@@ -0,0 +1,92 @@+cabal-version:       3.0+name:                adhoc-fixtures+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+Homepage:            http://github.com/blackheaven/adhoc-fixtures+tested-with:         GHC==9.2.4++library+  default-language:   Haskell2010+  build-depends:+      base == 4.*+    , safe-exceptions == 0.1.*+    , yarl >= 0.1.1 && < 0.2+  hs-source-dirs: src+  exposed-modules:+      Data.Fixtures.Adhoc+  other-modules:+      Paths_adhoc_fixtures+  autogen-modules:+      Paths_adhoc_fixtures+  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.AdhocSpec+      Paths_adhoc_fixtures+  autogen-modules:+      Paths_adhoc_fixtures+  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+    , hspec+    , hspec-core+    , hspec-discover+    , safe-exceptions+    , yarl+  default-language: Haskell2010
+ src/Data/Fixtures/Adhoc.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- |+-- Module        : Data.Fixtures.Adhoc+-- Copyright     : Gautier DI FOLCO+-- License       : ISC+--+-- Maintainer    : Gautier DI FOLCO <gautier.difolco@gmail.com>+-- Stability     : Unstable+-- Portability   : not portable+--+-- Fixtures builder and runner+--+-- Example:+--+-- > 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)+module Data.Fixtures.Adhoc+  ( Builder (..),+    BuilderWith,+    HasFixture,+    buildWith,+    buildWithClean,+    build,+    buildClean,+    nullBuilder,+    pureBuilder,+    (&:),+    (&>),+    runWithFixtures,+    createFixtures,+  )+where++import Control.Exception.Safe (MonadMask, bracket)+import Data.Records.Yarl.LinkedList+import GHC.TypeLits++-- | Fixture builder (should be used directly with care)+data Builder m items = Builder+  { create :: m (Record items),+    clean :: Record items -> m ()+  }++-- | Builder relying on other builder(s)+type BuilderWith items m (name :: Symbol) a =+  HasNotField name items =>+  Builder m items ->+  Builder m (Field name a ': items)++-- | Helper around 'HasRecord'+type HasFixture items (name :: Symbol) a = HasField name (Record items) a++-- | Simple builder, no clean operation+buildWith ::+  forall (name :: Symbol) a m items.+  (Monad m, HasNotField name items) =>+  (Record items -> m a) ->+  BuilderWith items m name a+buildWith f = buildWithClean f $ \_ _ -> return ()++-- | Builder with cleaning operation+buildWithClean ::+  forall (name :: Symbol) a m items.+  (Monad m, HasNotField name items) =>+  (Record items -> m a) ->+  (Record items -> a -> m ()) ->+  BuilderWith items m name a+buildWithClean create' clean' previous =+  Builder+    { create = do+        xs <- previous.create+        x <- create' xs+        return $ Field x :> xs,+      clean =+        \(Field x :> xs) ->+          clean' xs x >> previous.clean xs+    }++-- | Simple builder without dependency, no clean operation+build ::+  forall (name :: Symbol) a m items.+  (Monad m, HasNotField name items) =>+  m a ->+  BuilderWith items m name a+build f = buildClean f $ const $ return ()++-- | Builder without dependency with cleaning operation+buildClean ::+  forall (name :: Symbol) a m items.+  (Monad m, HasNotField name items) =>+  m a ->+  (a -> m ()) ->+  BuilderWith items m name a+buildClean create' clean' previous =+  Builder+    { create = do+        xs <- previous.create+        x <- create'+        return $ Field x :> xs,+      clean =+        \(Field x :> xs) ->+          clean' x >> previous.clean xs+    }++-- | Base builder+nullBuilder :: Monad m => Builder m '[]+nullBuilder =+  Builder+    { create = return RNil,+      clean = const $ return ()+    }++-- | Pure builder+pureBuilder :: Monad m => Record items -> Builder m items+pureBuilder built =+  Builder+    { create = return built,+      clean = const $ return ()+    }++-- | Chain builders+(&:) :: HasNotField name items => BuilderWith items m name a -> Builder m items -> Builder m (Field name a ': items)+(&:) = ($)++infixr 5 &:++-- | Nest builders+(&>) :: (HasNotField name items, Monad m) => BuilderWith items m name a -> Record items -> Builder m (Field name a ': items)+(&>) builderWith built = builderWith &: pureBuilder built++infixr 5 &>++-- | Run fixtures with clean up (bracket)+runWithFixtures :: MonadMask m => Builder m items -> (Record items -> m a) -> m a+runWithFixtures builder = bracket builder.create builder.clean++-- | Create fixtures (no clean up)+createFixtures :: Monad m => Builder m items -> (Record items -> m a) -> m a+createFixtures builder act = builder.create >>= act
+ test/Data/Fixtures/AdhocSpec.hs view
@@ -0,0 +1,11 @@+module Data.Fixtures.AdhocSpec (main, spec) where++import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec =+  describe "Adhoc fixtures" $+    return ()
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}