registry 0.1.2.6 → 0.1.3.0

raw patch · 24 files changed

+322/−122 lines, 24 filesdep +generic-lensdep +multimapdep +template-haskelldep ~basedep ~containersdep ~exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: generic-lens, multimap, template-haskell, universum

Dependency ranges changed: base, containers, exceptions, hashable, mtl, protolude, resourcet, semigroupoids, semigroups, text, transformers-base

API changes (from Hackage documentation)

Files

• registry.cabal +28/−20
• src/Data/Registry/RIO.hs +6/−1
• src/Data/Registry/TH.hs +129/−0
• test/AutoDiscoveredSpecs.hs +1/−0
• test/Test/Data/Registry/DotSpec.hs +0/−5
• test/Test/Data/Registry/GenSpec.hs +3/−6
• test/Test/Data/Registry/Internal/CacheSpec.hs +0/−4
• test/Test/Data/Registry/Internal/DynamicSpec.hs +0/−4
• test/Test/Data/Registry/Internal/MakeSpec.hs +0/−5
• test/Test/Data/Registry/Internal/ReflectionSpec.hs +0/−5
• test/Test/Data/Registry/Internal/RegistrySpec.hs +0/−4
• test/Test/Data/Registry/Internal/TypesSpec.hs +0/−4
• test/Test/Data/Registry/Make/MakeSpec.hs +0/−4
• test/Test/Data/Registry/Make/MemoizeSpec.hs +0/−6
• test/Test/Data/Registry/Make/SpecializationSpec.hs +0/−4
• test/Test/Data/Registry/Make/TweakingSpec.hs +0/−4
• test/Test/Data/Registry/MonadRandomSpec.hs +0/−5
• test/Test/Data/Registry/RIOSpec.hs +0/−6
• test/Test/Data/Registry/RegistrySpec.hs +0/−4
• test/Test/Data/Registry/SmallExample.hs +2/−6
• test/Test/Data/Registry/THSpec.hs +52/−0
• test/Test/Data/Registry/WarmupSpec.hs +0/−4
• test/Test/Tasty/Extensions.hs +96/−20
• test/test.hs +5/−1

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 591911740b5ea4e2d73e6ab67dcec50fb357c1d1552a9c00dc26119c705c25ee+-- hash: 9a42dc0b45e4a76624b48f457789494c6d57502a863d3397c88a28a0e85d57cf  name:           registry-version:        0.1.2.6+version:        0.1.3.0 synopsis:       data structure for assembling components description:    This library provides a "Registry" which is a data structure containing a list of functions and values representing dependencies in a directed acyclic graph. A `make` function can then be used to create a value of a specific type out of the registry.                 You can start with the [README](https://github.com/etorreborre/registry/blob/master/README.md) for a full description of the library.@@ -40,6 +40,7 @@       Data.Registry.RIO       Data.Registry.Solver       Data.Registry.Statistics+      Data.Registry.TH       Data.Registry.Warmup   other-modules:       Paths_registry@@ -49,22 +50,24 @@   ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns   build-depends:       base >=4.7 && <5-    , containers <0.7-    , exceptions <0.11-    , hashable <1.3-    , mtl <3-    , protolude <0.3-    , resourcet <1.3-    , semigroupoids <5.4-    , semigroups <0.19-    , text <2-    , transformers-base <0.5+    , containers >=0.5 && <0.7+    , exceptions >=0.8 && <0.11+    , hashable >=1.2 && <1.3+    , mtl >=2.0 && <3+    , protolude >=0.2 && <0.3+    , resourcet >=1.1 && <1.3+    , semigroupoids >=5.0 && <5.4+    , semigroups >=0.15 && <0.19+    , template-haskell >=2.13 && <3.0+    , text >=1.1 && <2+    , transformers-base >=0.4 && <0.5   default-language: Haskell2010  test-suite spec   type: exitcode-stdio-1.0   main-is: test.hs   other-modules:+      AutoDiscoveredSpecs       Test.Data.Registry.DotSpec       Test.Data.Registry.GenSpec       Test.Data.Registry.Internal.CacheSpec@@ -83,6 +86,7 @@       Test.Data.Registry.RIOSpec       Test.Data.Registry.SimpleExamples       Test.Data.Registry.SmallExample+      Test.Data.Registry.THSpec       Test.Data.Registry.WarmupSpec       Test.Tasty.Extensions       Paths_registry@@ -94,23 +98,27 @@       MonadRandom <0.6     , async <2.3     , base >=4.7 && <5-    , containers <0.7-    , exceptions <0.11-    , hashable <1.3+    , containers >=0.5 && <0.7+    , exceptions >=0.8 && <0.11+    , generic-lens <2+    , hashable >=1.2 && <1.3     , hedgehog <0.7     , hedgehog-corpus <0.2     , io-memoize <1.2-    , mtl <3-    , protolude <0.3+    , mtl >=2.0 && <3+    , multimap <1.3+    , protolude >=0.2 && <0.3     , random <2.0     , registry-    , resourcet <1.3-    , semigroupoids <5.4+    , resourcet >=1.1 && <1.3+    , semigroupoids >=5.0 && <5.4     , semigroups <0.19     , tasty <1.3     , tasty-discover <4.3     , tasty-hedgehog <0.3     , tasty-th <0.2+    , template-haskell >=2.13 && <3.0     , text <2-    , transformers-base <0.5+    , transformers-base >=0.4 && <0.5+    , universum <2   default-language: Haskell2010

@@ -122,6 +122,12 @@  -- * For testing +-- | This runs a RIO value without closing down resources or executing startup actions+unsafeRunRIO :: (Typeable a, MonadIO m) => RIO a -> m a+unsafeRunRIO rio = liftIO $ do+  is <- createInternalState+  fst <$> runRIO rio (Stop is)+ -- | Use a RIO value and make sure that resources are closed --   Don't run the warmup withNoWarmupRIO :: (MonadIO m) => RIO a -> (a -> IO b) -> m b@@ -152,7 +158,6 @@   is <- liftIO createInternalState   (a, w) <- runRIO (make @(RIO a) registry) (Stop is)   pure (a, w, Stop is)-  -- | Instantiate the component but don't execute the warmup (it may take time) and lose a way to cleanu up resources -- | Almost no compilation time is spent on checking that component resolution is possible

@@ -0,0 +1,129 @@+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Registry.TH (+  TypeclassOptions+, makeTypeclass+, makeTypeclassWith+) where++import           Data.Text                  as T (drop, splitOn)+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax+import           Protolude                  hiding (Type, Strict)+++{-+  This module generates a typeclass for a given "record of functions". For this component:++data Logger m = Logger {+  _info :: Text -> m ()+, _error :: Text -> m ()+}++-- `makeTypeClass ''Logger` generates++class WithLogger m where+  info :: Text -> m ()+  error :: Text -> m ()++-- This requires the import of `Data.Generics.Product.Typed` from `generic-lens`+instance HasType (Logger m) s => WithLogger (ReaderT s m) where+  info t = ReaderT (\l -> _info (getTyped l) t)+  error t = ReaderT (\l -> _error (getType l) t)++-}++-- | Create the haskell code presented in the module description+makeTypeclass :: Name -> DecsQ+makeTypeclass = makeTypeclassWith (TypeclassOptions ("With" <>) (T.drop 1))++-- | These generation options can be used to tweak the generated names+data TypeclassOptions = TypeclassOptions {+  -- adjust the typeclass name based on the component constructor name+  _typeclassName :: Text -> Text+  -- adjust the typeclass function names based on the component function names+, _functionName  :: Text -> Text+}++-- | Make a typeclass using some specific generation options+makeTypeclassWith :: TypeclassOptions -> Name -> DecsQ+makeTypeclassWith (TypeclassOptions typeclassNameMaker functionNameMaker) componentType = do+  info <- reify componentType+  case info of+        TyConI (DataD _ name typeVars _ [RecC _ types] _) -> do+          readertInstance <- createReadertInstance typeclassNameMaker functionNameMaker name typeVars types+          pure $ createTypeclass typeclassNameMaker functionNameMaker name typeVars types+                 <> readertInstance++        TyConI (NewtypeD _ name typeVars _ (RecC _ types) _) -> do+          readertInstance <- createReadertInstance typeclassNameMaker functionNameMaker name typeVars types+          pure $ createTypeclass typeclassNameMaker functionNameMaker name typeVars types+                 <> readertInstance++        other -> do+          qReport True ("can only generate a typeclass for a record of functions, got: " <> show other)+          pure []+++createTypeclass :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> [Dec]+createTypeclass typeclassNameMaker functionNameMaker name typeVars types =+  let typeclassName = modifyName typeclassNameMaker (dropQualified name)+      functions = fmap (makeFunctionDeclaration functionNameMaker) types+  in [ClassD [] typeclassName typeVars [] functions]++-- | Create an instance definition using a ReaderT instance+--     instance WithLogger (ReaderT (Logger m) m) where ...+createReadertInstance :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> DecsQ+createReadertInstance typeclassNameMaker functionNameMaker name [tvar] types =+  let tvarName = case tvar of PlainTV v -> v; KindedTV v _ -> v+      typeclassName = modifyName typeclassNameMaker (dropQualified name)+      functions = fmap (makeFunctionInstance functionNameMaker (mkName "ReaderT")) types+      typeclassT = ConT typeclassName+      components = mkName "c"+      componentTypeT = ConT name+      componentsTypeT = VarT components+      readerT = ConT (mkName "ReaderT")+      hasTypeT = ConT (mkName "HasType")+      tvarT   = VarT tvarName+  in pure [InstanceD Nothing+            [AppT (AppT hasTypeT (AppT componentTypeT tvarT)) componentsTypeT]+            (AppT typeclassT (AppT (AppT readerT componentsTypeT) tvarT))+            functions]++createReadertInstance _ _ _ tvars _ = do+  qReport True ("can only generate a instance for a component typeclass when it has only one type variable, got: " <> show tvars)+  pure []++-- | Make the function declaration of the typeclass based on the function name in the "record of functions"+makeFunctionDeclaration :: (Text -> Text) -> VarBangType -> Dec+makeFunctionDeclaration functionNameMaker (name, _, type') =+  SigD (modifyName functionNameMaker (dropQualified name)) type'++-- | This produces: info p1 p2 = ReaderT (\component -> _info component p1 p2)+makeFunctionInstance :: (Text -> Text) -> Name -> VarBangType -> Dec+makeFunctionInstance functionNameMaker runnerName (name, _, functionType) =+  let functionName = modifyName functionNameMaker (dropQualified name)+      readerT = ConE runnerName+      component = mkName "component"+      numberOfParameters = countNumberOfParameters functionType+      parameterNames = (\i -> mkName ("p" <> show i)) <$> [1..numberOfParameters]+      parameters = VarP <$> parameterNames+      firstApplication = AppE (VarE name) (AppE (VarE (mkName "getTyped")) (VarE component))+      body = foldl' (\r p -> AppE r (VarE p)) firstApplication parameterNames+  in+    FunD functionName [Clause parameters (NormalB (AppE readerT (LamE [VarP component] body))) []]++-- | count the number of parameters for a function type+countNumberOfParameters :: Type -> Int+countNumberOfParameters (ForallT _ _ t) = countNumberOfParameters t+countNumberOfParameters (AppT (AppT ArrowT _) t) = 1 +  countNumberOfParameters t+countNumberOfParameters _ = 0++-- | Modify a template haskell name+modifyName :: (Text -> Text) -> Name -> Name+modifyName f n = mkName (toS . f . show $ n)++-- | Remove the module name from a qualified name+dropQualified :: Name -> Name+dropQualified name =  maybe name (mkName . toS) (lastMay (T.splitOn "." (show name)))

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=AutoDiscoveredSpecs #-}

@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell       #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Data.Registry.DotSpec where@@ -37,7 +36,3 @@       , "\"Test.Data.Registry.Make.SpecializationSpec.Supervisor-4\" -> \"Test.Data.Registry.Make.SpecializationSpec.SupervisorConfig-4\\nSupervisorConfig for sql in general\";"       , "}"       ]--------tests = $(testGroupGenerator)

@@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds             #-} {-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TemplateHaskell       #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  {-@@ -89,7 +88,7 @@   +: fun genDouble   +: end -test_company_with_one_employee = noShrink $ prop "generate just one employee" $ run $ do+test_company_with_one_employee = noShrink $ prop "generate just one employee" $ runR $ do   setMinimalCompany   company <- forall @Company   let allEmployees = company & departments >>= (& employees)@@ -127,10 +126,8 @@ tweakGen :: forall a m . (Typeable a, Monad m) => (Gen a -> Gen a) -> RegistryProperty m () tweakGen f = modify $ tweakUnsafe @(Gen a) f -run :: Monad m => RegistryProperty m a -> PropertyT m a-run = runWith registry+runR :: Monad m => RegistryProperty m a -> PropertyT m a+runR = runWith registry  runWith :: Monad m => Registry ins out -> RegistryProperty m a -> PropertyT m a runWith = flip evalStateT------tests = $(testGroupGenerator)

@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Data.Registry.Internal.CacheSpec where@@ -21,6 +20,3 @@     cachedAction    cached === 1-------tests = $(testGroupGenerator)

@@ -1,5 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-} {-# LANGUAGE TypeApplications    #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}@@ -46,6 +45,3 @@  dynType :: forall a . (Typeable a) => a -> SomeTypeRep dynType = dynTypeRep . toDyn-------tests = $(testGroupGenerator)

@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell     #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -29,7 +28,3 @@   case result of     Left e  -> annotateShow e >> "cycle detected!" `T.isPrefixOf` e === True     Right _ -> failure--------tests = $(testGroupGenerator)

@@ -1,6 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TypeApplications    #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -77,6 +75,3 @@  fun3 :: IO (Mod Int) -> IO Int fun3 = undefined-------tests = $(testGroupGenerator)

@@ -1,5 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-} {-# LANGUAGE TypeApplications    #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}@@ -85,6 +84,3 @@ -- *  fromValueDyn = fromDynamic . valueDyn-------tests = $(testGroupGenerator)

@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Data.Registry.Internal.TypesSpec where@@ -40,6 +39,3 @@ d = someTypeRep $ typeOf D e = someTypeRep $ typeOf E f = someTypeRep $ typeOf F-------tests = $(testGroupGenerator)

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds       #-}-{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Data.Registry.Make.MakeSpec where@@ -41,6 +40,3 @@ -- inverse of add1 (in terms of type signature) dda1 :: Text -> Int dda1 = T.length-------tests = $(testGroupGenerator)

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds        #-}-{-# LANGUAGE TemplateHaskell  #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Data.Registry.Make.MemoizeSpec where@@ -97,8 +96,3 @@   pure c  data App = App { a :: A, b :: B }---------tests = $(testGroupGenerator)

@@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds             #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE TemplateHaskell       #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} @@ -195,6 +194,3 @@ newStatsStore client sql supervisor = StatsStore {   statsStoreConfig = (twitterConfig client, sqlConfig sql, supervisorConfig supervisor) }-------tests = $(testGroupGenerator)

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds        #-}-{-# LANGUAGE TemplateHaskell  #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Data.Registry.Make.TweakingSpec where@@ -27,6 +26,3 @@  newtype UseConfig1 = UseConfig1 { printConfig1 :: Config } newUseConfig1 config = UseConfig1 { printConfig1 = config }-------tests = $(testGroupGenerator)

@@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds           #-} {-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE TemplateHaskell     #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  {-@@ -125,7 +124,3 @@    -- everytime we call the generator we get the same value   length (nub results) === 1--------tests = $(testGroupGenerator)

@@ -1,7 +1,4 @@-{-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TypeApplications    #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -35,6 +32,3 @@   ref <- liftIO $ withNoWarmupRIO rio $ \ref -> modifyIORef ref (<>["use"]) $> ref   content <- liftIO $ readIORef ref   content === ["start", "use", "close" :: Text]-------tests = $(testGroupGenerator)

@@ -1,6 +1,5 @@ {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-} {-# LANGUAGE TypeApplications    #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}@@ -35,6 +34,3 @@ registry =      fun newLogger   +: end-------tests = $(testGroupGenerator)

@@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds           #-} {-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE TemplateHaskell     #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  {-@@ -14,7 +13,7 @@ import           Data.Text             (splitOn) import           Data.Typeable         (Typeable) import           Protolude             as P-import           Test.Tasty.Extensions+import           Test.Tasty.Extensions hiding (run)  -- | Components of the application --     - a Logger@@ -68,7 +67,7 @@ registry =      funAs @IO (newS3 @IO)   +: funAs @IO (newApplication @IO)-  +: funTo @IO newLogger+  +: funTo @IO noLogging   +: funTo @IO newLinesCounter   +: valTo @IO (S3Config "bucket" "key")   +: end@@ -84,6 +83,3 @@   app <- liftIO createApplication -- nothing should crash!   r   <- liftIO $ (app & run) "hello\nworld"   r === 2-------tests = $(testGroupGenerator)

@@ -0,0 +1,52 @@+{-# LANGUAGE TemplateHaskell     #-}++module Test.Data.Registry.THSpec where++import           Data.Generics.Product.Typed+import           Data.Registry.TH+import           Protolude+import           Universum                   ((...))++-- | Example of TemplateHaskell usage++-- | We define 2 low-level components: Logger and Tracer+--   We make the corresponding typeclasses+data Logger m = Logger {+  -- a function taking 2 arguments+  _info  :: Text -> Text -> m ()+  -- a function having a constraint+, _error :: forall a . (Monoid a) => a -> Text -> m ()+}++makeTypeclass ''Logger++newtype Tracer m = Tracer {+  _traceIt :: Text -> m ()+}++makeTypeclass ''Tracer++-- | Now we make a component which is going to use both components+newtype Service m = Service {+  doIt :: Int -> Text -> m ()+}++newService :: Monad m => Logger m -> Tracer m -> Service m+newService logger tracer = Service {+  doIt = run ... implementService+} where+    -- the typeclass instances can be resolved by using a Reader containing+    --  a tuple with all the components+    run = flip runReaderT (logger, tracer)++-- | Implement the service using typeclasses+implementService ::+     Monad m+  => WithLogger m+  => WithTracer m+  => Int+  -> Text+  -> m ()+implementService n t = do+  info "doing it" t+  traceIt (show n)

@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell      #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}@@ -73,6 +72,3 @@ genEmpty  = pure Empty genFailed = failed <$> element simpsons genOk     = ok     <$> element colours-------tests = $(testGroupGenerator)

@@ -17,31 +17,40 @@   module Hedgehog , module Tasty , gotException+, groupByModuleName+, minTestsOk , noShrink , prop+, run+, runOnly , test-, minTestsOk , withSeed ) where -import           Data.Maybe          (fromJust)+import           Data.Maybe           (fromJust)+import           Data.MultiMap import           GHC.Stack-import           Hedgehog            as Hedgehog hiding (test)-import           Hedgehog.Corpus     as Hedgehog-import           Hedgehog.Gen        as Hedgehog hiding (discard, print)-import qualified Prelude             as Prelude-import           Protolude           hiding ((.&.))-import           Test.Tasty          as Tasty-import           Test.Tasty.Options  as Tasty-import           Test.Tasty.Hedgehog as Tasty-import           Test.Tasty.TH       as Tasty+import           Hedgehog             as Hedgehog hiding (test)+import           Hedgehog.Corpus      as Hedgehog+import           Hedgehog.Gen         as Hedgehog hiding (discard, print)+import qualified Prelude              as Prelude+import           Protolude            hiding (empty, toList, (.&.))+import           System.Environment+import           Test.Tasty           as Tasty+import           Test.Tasty.Hedgehog  as Tasty+import           Test.Tasty.Options   as Tasty+import           Test.Tasty.Providers as Tasty (singleTest)+import           Test.Tasty.Runners   as Tasty (foldSingle, foldTestTree, trivialFold, TestTree(..))  -- | Create a Tasty test from a Hedgehog property-prop :: HasCallStack => TestName -> PropertyT IO () -> [TestTree]-prop name p = [withFrozenCallStack $ testProperty name (Hedgehog.property p)]+prop :: HasCallStack => TestName -> PropertyT IO () -> TestTree+prop name p =+  let aModuleName = getModuleName+  in  withFrozenCallStack . localOption (ModuleName (toS aModuleName)) $+      testProperty name (Hedgehog.property p)  -- | Create a Tasty test from a Hedgehog property called only once-test :: HasCallStack => TestName -> PropertyT IO () -> [TestTree]+test :: HasCallStack => TestName -> PropertyT IO () -> TestTree test name p = withFrozenCallStack (minTestsOk 1 . noShrink $ prop name p)  gotException :: forall a . (HasCallStack, Show a) => a -> PropertyT IO ()@@ -53,11 +62,78 @@  -- * Parameters -minTestsOk :: Int -> [TestTree] -> [TestTree]-minTestsOk n = fmap (localOption (HedgehogTestLimit (Just (toEnum n :: TestLimit))))+minTestsOk :: Int -> TestTree -> TestTree+minTestsOk n = localOption (HedgehogTestLimit (Just (toEnum n :: TestLimit))) -noShrink :: [TestTree] -> [TestTree]-noShrink = fmap (localOption (HedgehogShrinkLimit (Just (0 :: ShrinkLimit))))+noShrink :: TestTree -> TestTree+noShrink = localOption (HedgehogShrinkLimit (Just (0 :: ShrinkLimit))) -withSeed :: Prelude.String -> [TestTree] -> [TestTree]-withSeed seed = fmap (localOption (fromJust (parseValue seed :: Maybe HedgehogReplay)))+withSeed :: Prelude.String -> TestTree -> TestTree+withSeed seed = localOption (fromJust (parseValue seed :: Maybe HedgehogReplay))++-- * GROUPING++-- | Extract the ModuleName option value for a given test and+--   group all the tests with that option into the same test group+groupByModuleName :: TestTree -> TestTree+groupByModuleName testTree =+  let grouped = assocs $ foldTestTree (trivialFold { foldSingle = \os n t ->+        let (ModuleName aModuleName) = lookupOption os :: ModuleName+        in insert (toS aModuleName) (setOptionSet os $ singleTest n t) empty+        }) mempty testTree+  in  TestGroup "All" (uncurry TestGroup <$> grouped)++instance (Ord k) => Semigroup (MultiMap k v) where+  (<>) m1 m2 = fromList (toList m1 <> toList m2)++instance (Ord k) => Monoid (MultiMap k v) where+  mempty = empty+  mappend = (<>)++-- | This is unfortunate. Due to the API for `foldTestTree` in Tasty+--   giving back the current `OptionSet` applicable to a single test+--   it is not possible to re-set those option values on that test+--   without listing them exhaustively. This means+--   that if other options are set on tests in that file, they need to be+--   added in that function+setOptionSet :: OptionSet -> TestTree -> TestTree+setOptionSet os =+  localOption (lookupOption os :: HedgehogTestLimit) .+  localOption (lookupOption os :: HedgehogShrinkLimit) .+  localOption (lookupOption os :: HedgehogReplay)++getModuleName :: HasCallStack => Prelude.String+getModuleName =+  case getCallStack  callStack of+    ((_, loc):_) -> srcLocModule loc+    _            -> "root"++-- | Option describing the current module name+newtype ModuleName = ModuleName Text deriving (Eq, Show)++-- | The option triggering the database tests is called 'postgres' for compatibility reasons+instance IsOption ModuleName where+  defaultValue = ModuleName "root"+  parseValue = fmap ModuleName . safeRead+  optionName = pure "module-name"+  optionHelp = pure "internal option used to group tests into the same module"+  optionCLParser = mkFlagCLParser mempty (ModuleName "root")++-- * GHCi run functions++run :: Runnable t => t -> IO ()+run tests = runIt tests >>= defaultMain . groupByModuleName++runOnly :: Runnable t => Text -> t -> IO ()+runOnly p tests = do+  setEnv "TASTY_PATTERN" (toS p)+  run tests `finally` unsetEnv "TASTY_PATTERN"++class Runnable t where+  runIt :: t -> IO TestTree++instance Runnable (IO TestTree) where+  runIt t = t++instance Runnable TestTree where+  runIt = pure

@@ -1,1 +1,5 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+import           AutoDiscoveredSpecs   (tests)+import           Protolude+import           Test.Tasty.Extensions++main = tests >>= defaultMain . groupByModuleName