effectful-zoo (empty) → 0.0.0.1
raw patch · 33 files changed
+1933/−0 lines, 33 filesdep +aesondep +aeson-prettydep +base
Dependencies added: aeson, aeson-pretty, base, bytestring, effectful, effectful-core, effectful-plugin, effectful-zoo, hedgehog, hw-prelude, tasty, tasty-hedgehog, text, time, transformers, yaml
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- components/core/Effectful/Zoo/Core.hs +7/−0
- components/datalog/Effectful/Zoo/DataLog/Api.hs +19/−0
- components/datalog/Effectful/Zoo/DataLog/Data/DataLogger.hs +24/−0
- components/datalog/Effectful/Zoo/DataLog/Data/LogEntry.hs +27/−0
- components/datalog/Effectful/Zoo/DataLog/Dynamic.hs +34/−0
- components/datalog/Effectful/Zoo/DataLog/Static.hs +103/−0
- components/hedgehog-test/Effectful/Zoo/Hedgehog/Test/HedgehogTest.hs +22/−0
- components/hedgehog-test/Main.hs +16/−0
- components/hedgehog/Effectful/Zoo/Hedgehog.hs +5/−0
- components/hedgehog/Effectful/Zoo/Hedgehog/Api.hs +15/−0
- components/hedgehog/Effectful/Zoo/Hedgehog/Api/Assert.hs +47/−0
- components/hedgehog/Effectful/Zoo/Hedgehog/Api/Classify.hs +20/−0
- components/hedgehog/Effectful/Zoo/Hedgehog/Api/Eval.hs +64/−0
- components/hedgehog/Effectful/Zoo/Hedgehog/Api/Failure.hs +74/−0
- components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs +531/−0
- components/hedgehog/Effectful/Zoo/Hedgehog/Api/Run.hs +47/−0
- components/hedgehog/Effectful/Zoo/Hedgehog/Dynamic.hs +67/−0
- components/hedgehog/Effectful/Zoo/Hedgehog/MonadTestProxy.hs +31/−0
- components/log/Effectful/Zoo/Log/Api.hs +13/−0
- components/log/Effectful/Zoo/Log/Api/Generic.hs +80/−0
- components/log/Effectful/Zoo/Log/Api/LazyText.hs +80/−0
- components/log/Effectful/Zoo/Log/Api/Render.hs +11/−0
- components/log/Effectful/Zoo/Log/Api/String.hs +80/−0
- components/log/Effectful/Zoo/Log/Api/Text.hs +80/−0
- components/log/Effectful/Zoo/Log/Data/LogMessage.hs +11/−0
- components/log/Effectful/Zoo/Log/Data/Logger.hs +25/−0
- components/log/Effectful/Zoo/Log/Data/Severity.hs +38/−0
- components/log/Effectful/Zoo/Log/Dynamic.hs +36/−0
- components/log/Effectful/Zoo/Log/Static.hs +112/−0
- effectful-zoo.cabal +180/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++* initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright John Ky (c) 2024++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 Author name here 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,1 @@+# About
+ components/core/Effectful/Zoo/Core.hs view
@@ -0,0 +1,7 @@+module Effectful.Zoo.Core+ ( type (<:)+ ) where++import Effectful ((:>))++type (<:) r e = (:>) e r
+ components/datalog/Effectful/Zoo/DataLog/Api.hs view
@@ -0,0 +1,19 @@+module Effectful.Zoo.DataLog.Api+ ( dataLog,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.DataLog.Dynamic+import HaskellWorks.Prelude hiding (log)++dataLog :: ()+ => HasCallStack+ => r <: DataLog i+ => i+ -> Eff r ()+dataLog i =+ withFrozenCallStack do+ send $ DataLog i+{-# inline dataLog #-}
+ components/datalog/Effectful/Zoo/DataLog/Data/DataLogger.hs view
@@ -0,0 +1,24 @@+module Effectful.Zoo.DataLog.Data.DataLogger+ ( DataLogger(..),+ mkDataLogger,+ ) where++import Effectful+import Effectful.Zoo.Core+import HaskellWorks.Prelude hiding (Floating(..))++newtype DataLogger i = DataLogger+ { run :: i -> IO ()+ } deriving stock Generic++instance Contravariant DataLogger where+ contramap f (DataLogger g) = DataLogger (g . f)++mkDataLogger :: ()+ => r <: IOE+ => UnliftStrategy+ -> (i -> Eff r ())+ -> Eff r (DataLogger i)+mkDataLogger strategy run =+ withEffToIO strategy $ \effToIO ->+ pure $ DataLogger $ effToIO . run
+ components/datalog/Effectful/Zoo/DataLog/Data/LogEntry.hs view
@@ -0,0 +1,27 @@+module Effectful.Zoo.DataLog.Data.LogEntry+ ( LogEntry(..),+ annotate,+ ) where++import Data.Time (UTCTime)+import Data.Time.Clock qualified as IO+import Effectful+import Effectful.Zoo.Core+import GHC.Stack qualified as GHC+import HaskellWorks.Prelude++data LogEntry a = LogEntry+ { message :: !a+ , time :: !UTCTime+ , source :: !CallStack+ }+ deriving stock (Generic, Show)++annotate :: ()+ => HasCallStack+ => r <: IOE+ => a+ -> Eff r (LogEntry a)+annotate msg = do+ time <- liftIO IO.getCurrentTime+ pure (LogEntry msg time GHC.callStack)
+ components/datalog/Effectful/Zoo/DataLog/Dynamic.hs view
@@ -0,0 +1,34 @@+module Effectful.Zoo.DataLog.Dynamic+ ( DataLog (..),+ runDataLog,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.DataLog.Static qualified as S+import HaskellWorks.Prelude++data DataLog a :: Effect where+ DataLog+ :: a+ -> DataLog a m ()++ Local+ :: (a -> a)+ -> m b+ -> DataLog a m b++type instance DispatchOf (DataLog a) = Dynamic++runDataLog :: ()+ => HasCallStack+ => r <: IOE+ => UnliftStrategy+ -> (HasCallStack => i -> Eff r ())+ -> Eff (DataLog i : r) a+ -> Eff r a+runDataLog s run =+ reinterpret (S.runDataLog s run) $ \env -> \case+ DataLog i -> S.log i+ Local f m -> localSeqUnlift env $ \unlift -> S.local f (unlift m)
+ components/datalog/Effectful/Zoo/DataLog/Static.hs view
@@ -0,0 +1,103 @@+module Effectful.Zoo.DataLog.Static+ ( DataLog,+ runDataLog,+ runDataLogTextToHandle,+ runDataLogTextToStdout,+ runDataLogTextToStderr,+ withDataLog,+ log,+ local,+ ) where++import Data.Text.IO qualified as T+import Data.Kind+import Effectful+import Effectful.Zoo.Core+import Effectful.Dispatch.Static+import Effectful.Zoo.DataLog.Data.DataLogger+import HaskellWorks.Prelude hiding (Floating(..))+import System.IO qualified as IO++data DataLog (i :: Type) :: Effect++type instance DispatchOf (DataLog i) = Static NoSideEffects++newtype instance StaticRep (DataLog i) = DataLog (DataLogger i)++runDataLog :: ()+ => r <: IOE+ => HasCallStack+ => UnliftStrategy+ -> (HasCallStack => i -> Eff r ())+ -> Eff (DataLog i : r) a+ -> Eff r a+runDataLog strategy run f = do+ s <- mkDataLogger strategy run+ evalStaticRep (DataLog s) f++runDataLogTextToHandle :: ()+ => HasCallStack+ => Handle+ -> Eff (DataLog Text : r) a+ -> Eff r a+runDataLogTextToHandle h =+ evalStaticRep $ DataLog $ DataLogger $ T.hPutStrLn h++runDataLogTextToStdout :: ()+ => HasCallStack+ => Eff (DataLog Text : r) a+ -> Eff r a+runDataLogTextToStdout =+ runDataLogTextToHandle IO.stdout++runDataLogTextToStderr :: ()+ => HasCallStack+ => Eff (DataLog Text : r) a+ -> Eff r a+runDataLogTextToStderr =+ runDataLogTextToHandle IO.stderr++withDataLogSerialiser :: ()+ => HasCallStack+ => (DataLogger i -> DataLogger o)+ -> Eff (DataLog o : r) a+ -> Eff (DataLog i : r) a+withDataLogSerialiser f m = do+ logger <- getDataLogger+ let _ = logger+ raise $ evalStaticRep (DataLog (f logger)) m++withDataLog :: ()+ => HasCallStack+ => (o -> i)+ -> Eff (DataLog o : r) a+ -> Eff (DataLog i : r) a+withDataLog =+ withDataLogSerialiser . contramap++getDataLogger :: ()+ => HasCallStack+ => r <: DataLog i+ => Eff r (DataLogger i)+getDataLogger = do+ DataLog i <- getStaticRep+ pure i++log :: ()+ => HasCallStack+ => r <: DataLog i+ => r <: IOE+ => i+ -> Eff r ()+log i = do+ dataLogger <- getDataLogger+ liftIO $ dataLogger.run i++local :: ()+ => HasCallStack+ => r <: DataLog i+ => (i -> i)+ -> Eff r a+ -> Eff r a+local f =+ localStaticRep $ \(DataLog s) -> DataLog (contramap f s)
+ components/hedgehog-test/Effectful/Zoo/Hedgehog/Test/HedgehogTest.hs view
@@ -0,0 +1,22 @@+module Effectful.Zoo.Hedgehog.Test.HedgehogTest where++import Effectful+import Effectful.Zoo.Core+import Effectful.Zoo.Log.Dynamic+import Effectful.Zoo.Log.Api.Text+import Effectful.Zoo.Hedgehog+import HaskellWorks.Prelude++foo :: ()+ => HasCallStack+ => r <: Log Text+ => Eff r ()+foo =+ info "This is a log"++test_simple :: UnitTest+test_simple =+ hedgehog do+ jot_ "This is a jot"++ foo
+ components/hedgehog-test/Main.hs view
@@ -0,0 +1,16 @@+module Main where++import Effectful.Zoo.Hedgehog (unitTest)+import Effectful.Zoo.Hedgehog.Test.HedgehogTest (test_simple)+import Test.Tasty (TestTree, defaultMain, testGroup)+import HaskellWorks.Prelude++tests :: TestTree+tests =+ testGroup "all" [+ unitTest "Simple test" test_simple+ ]++main :: IO ()+main =+ defaultMain tests
+ components/hedgehog/Effectful/Zoo/Hedgehog.hs view
@@ -0,0 +1,5 @@+module Effectful.Zoo.Hedgehog (+ module Effectful.Zoo.Hedgehog.Api,+) where++import Effectful.Zoo.Hedgehog.Api
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api.hs view
@@ -0,0 +1,15 @@+module Effectful.Zoo.Hedgehog.Api+ ( module Effectful.Zoo.Hedgehog.Api.Assert,+ module Effectful.Zoo.Hedgehog.Api.Classify,+ module Effectful.Zoo.Hedgehog.Api.Eval,+ module Effectful.Zoo.Hedgehog.Api.Failure,+ module Effectful.Zoo.Hedgehog.Api.Journal,+ module Effectful.Zoo.Hedgehog.Api.Run,+ ) where++import Effectful.Zoo.Hedgehog.Api.Assert+import Effectful.Zoo.Hedgehog.Api.Classify+import Effectful.Zoo.Hedgehog.Api.Eval+import Effectful.Zoo.Hedgehog.Api.Failure+import Effectful.Zoo.Hedgehog.Api.Journal+import Effectful.Zoo.Hedgehog.Api.Run
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Assert.hs view
@@ -0,0 +1,47 @@+module Effectful.Zoo.Hedgehog.Api.Assert+ ( assert,+ (===),+ (/==),+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.Hedgehog.Dynamic+import HaskellWorks.Prelude+import Hedgehog qualified as H++infix 4 ===, /==++assert :: forall r. ()+ => HasCallStack+ => r <: Hedgehog+ => Bool+ -> Eff r ()+assert condition =+ withFrozenCallStack $+ H.assert condition++(===) :: forall a r. ()+ => HasCallStack+ => Eq a+ => Show a+ => r <: Hedgehog+ => a+ -> a+ -> Eff r ()+(===) a b =+ withFrozenCallStack $+ a H.=== b++(/==) :: forall a r. ()+ => HasCallStack+ => Eq a+ => Show a+ => r <: Hedgehog+ => a+ -> a+ -> Eff r ()+(/==) a b =+ withFrozenCallStack $+ a H./== b
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Classify.hs view
@@ -0,0 +1,20 @@+module Effectful.Zoo.Hedgehog.Api.Classify+ ( classify,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.Hedgehog.Dynamic+import HaskellWorks.Prelude+import Hedgehog qualified as H++classify :: forall r. ()+ => HasCallStack+ => r <: Hedgehog+ => H.LabelName+ -> Bool+ -> Eff r ()+classify name b =+ withFrozenCallStack $+ H.classify name b
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Eval.hs view
@@ -0,0 +1,64 @@+module Effectful.Zoo.Hedgehog.Api.Eval+ ( eval,+ evalIO,+ evalM,++ evalEither,+ evalMaybe,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.Hedgehog.Dynamic+import HaskellWorks.Prelude+import Hedgehog qualified as H++eval :: forall a r. ()+ => HasCallStack+ => r <: Hedgehog+ => a+ -> Eff r a+eval a =+ withFrozenCallStack do+ H.eval a++-- |Embeds 'Hedgehog.evalEither'.+evalEither :: forall a e r. ()+ => HasCallStack+ => r <: Hedgehog+ => Show e+ => Either e a+ -> Eff r a+evalEither e =+ withFrozenCallStack do+ H.evalEither e++-- |Embeds 'Hedgehog.evalMaybe'.+evalMaybe :: forall a r. ()+ => HasCallStack+ => r <: Hedgehog+ => Maybe a+ -> Eff r a+evalMaybe e =+ withFrozenCallStack do+ H.evalMaybe e++evalIO :: forall a r. ()+ => HasCallStack+ => r <: IOE+ => r <: Hedgehog+ => IO a+ -> Eff r a+evalIO f =+ withFrozenCallStack do+ H.evalIO f++evalM :: forall a r. ()+ => HasCallStack+ => r <: Hedgehog+ => Eff r a+ -> Eff r a+evalM f =+ withFrozenCallStack do+ H.evalM f
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Failure.hs view
@@ -0,0 +1,74 @@+module Effectful.Zoo.Hedgehog.Api.Failure+ ( failure,+ failException,+ failWith,+ failWithCallStack,++ catchAssertion,+ throwAssertion,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Error.Static+import Effectful.Zoo.Core+import Effectful.Zoo.Hedgehog.Dynamic+import HaskellWorks.Prelude+import Hedgehog.Internal.Property qualified as H+import Hedgehog.Internal.Source qualified as H++failure :: forall a r. ()+ => HasCallStack+ => r <: Hedgehog+ => Eff r a+failure =+ withFrozenCallStack+ H.failure++failException :: forall a r. ()+ => HasCallStack+ => r <: Hedgehog+ => SomeException+ -> Eff r a+failException e =+ withFrozenCallStack $+ H.failException e++failWith :: forall a r. ()+ => HasCallStack+ => r <: Hedgehog+ => Maybe H.Diff+ -> String+ -> Eff r a+failWith diff msg =+ withFrozenCallStack $+ H.failWith diff msg++failWithCallStack :: forall a r. ()+ => r <: Hedgehog+ => CallStack+ -> Maybe H.Diff+ -> String+ -> Eff r a+failWithCallStack cs diff msg =+ withFrozenCallStack $+ throwAssertion (H.Failure (H.getCaller cs) msg diff)++catchAssertion :: forall a r. ()+ => HasCallStack+ => r <: Hedgehog+ => Eff r a + -> (H.Failure -> Eff r a) + -> Eff r a+catchAssertion m h =+ withFrozenCallStack $+ send $ CatchAssertion m h++throwAssertion :: forall a r. ()+ => HasCallStack+ => r <: Hedgehog+ => H.Failure+ -> Eff r a+throwAssertion e =+ withFrozenCallStack $+ send $ ThrowAssertion e
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs view
@@ -0,0 +1,531 @@+module Effectful.Zoo.Hedgehog.Api.Journal+ ( jot,+ jot_,+ + jotWithCallStack,++ jotText_,+ jotM,+ jotBsUtf8M,+ jotLbsUtf8M,+ jotM_,+ jotIO,+ jotIO_,+ jotShow,+ jotShow_,+ jotShowM,+ jotShowM_,+ jotShowIO,+ jotShowIO_,+ jotShowRead,+ jotJson,+ jotJson_,+ jotJsonM,+ jotJsonM_,+ jotJsonPretty,+ jotJsonPretty_,+ jotJsonPrettyM,+ jotJsonPrettyM_,+ jotYaml,+ jotYaml_,+ jotYamlM,+ jotYamlM_,+ jotEach,+ jotEach_,+ jotEachM,+ jotEachM_,+ jotEachIO,+ jotEachIO_,++ jotLogTextWithCallStack,++ writeLog,+ ) where++import Data.Aeson (ToJSON(..))+import Data.Aeson qualified as J+import Data.Aeson.Encode.Pretty qualified as J+import Data.ByteString.Lazy qualified as LBS+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Text.Lazy qualified as LT+import Data.Text.Lazy.Encoding qualified as LT+import Data.Traversable+import Data.Yaml qualified as Y+import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.Hedgehog.Api.Eval+import Effectful.Zoo.Hedgehog.Api.Failure+import Effectful.Zoo.Hedgehog.Dynamic+import Effectful.Zoo.Log.Data.Severity+import GHC.Stack qualified as GHC+import HaskellWorks.Prelude+import HaskellWorks.String+import HaskellWorks.ToText+import Hedgehog.Internal.Property qualified as H+import Hedgehog.Internal.Source qualified as H++-- | Annotate the given string at the context supplied by the callstack.+jotWithCallStack :: forall r. ()+ => r <: Hedgehog+ => CallStack+ -> String+ -> Eff r ()+jotWithCallStack cs a =+ writeLog $ H.Annotation (H.getCaller cs) a++-- | Annotate with the given string.+jot :: forall r. ()+ => r <: Hedgehog+ => HasCallStack+ => String+ -> Eff r String+jot a =+ withFrozenCallStack do+ !b <- eval a+ jotWithCallStack GHC.callStack b+ return b++-- | Annotate the given string returning unit.+jot_ :: forall r. ()+ => r <: Hedgehog+ => HasCallStack+ => Text+ -> Eff r ()+jot_ =+ withFrozenCallStack do+ jotText_++-- | Annotate the given text returning unit.+jotText_ :: forall r. ()+ => r <: Hedgehog+ => HasCallStack+ => Text+ -> Eff r ()+jotText_ a =+ withFrozenCallStack do+ jotWithCallStack GHC.callStack $ T.unpack a++-- | Annotate the given string in a monadic context.+jotM :: forall a r. ()+ => ToString a+ => r <: Hedgehog+ => HasCallStack+ => Eff r a+ -> Eff r a+jotM a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack $ toString b+ return b++jotBsUtf8M :: forall r. ()+ => r <: Hedgehog+ => HasCallStack+ => Eff r ByteString+ -> Eff r ByteString+jotBsUtf8M a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack $ T.unpack $ T.decodeUtf8 b+ return b++jotLbsUtf8M :: forall r. ()+ => r <: Hedgehog+ => HasCallStack+ => Eff r LBS.ByteString+ -> Eff r LBS.ByteString+jotLbsUtf8M a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack $ LT.unpack $ LT.decodeUtf8 b+ return b++-- | Annotate the given string in a monadic context returning unit.+jotM_ :: forall r. ()+ => r <: Hedgehog+ => HasCallStack+ => Eff r String+ -> Eff r ()+jotM_ a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack b+ return ()++-- | Annotate the given string in IO.+jotIO :: forall r. ()+ => r <: Hedgehog+ => r <: IOE+ => HasCallStack+ => IO String+ -> Eff r String+jotIO f =+ withFrozenCallStack do+ !a <- evalIO f+ jotWithCallStack GHC.callStack a+ return a++-- | Annotate the given string in IO returning unit.+jotIO_ :: forall r. ()+ => r <: Hedgehog+ => r <: IOE+ => HasCallStack+ => IO String+ -> Eff r ()+jotIO_ f =+ withFrozenCallStack do+ !a <- evalIO f+ jotWithCallStack GHC.callStack a+ return ()++-- | Annotate the given value.+jotShow :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => Show a+ => a+ -> Eff r a+jotShow a =+ withFrozenCallStack do+ !b <- eval a+ jotWithCallStack GHC.callStack (show b)+ return b++-- | Annotate the given value returning unit.+jotShow_ :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => Show a+ => a+ -> Eff r ()+jotShow_ a =+ withFrozenCallStack do+ jotWithCallStack GHC.callStack (show a)++-- | Annotate the given value in a monadic context.+jotShowM :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => Show a+ => Eff r a+ -> Eff r a+jotShowM a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack (show b)+ return b++-- | Annotate the given value in a monadic context returning unit.+jotShowM_ :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => Show a+ => Eff r a+ -> Eff r ()+jotShowM_ a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack (show b)+ return ()++-- | Annotate the given value in IO.+jotShowIO :: forall a r. ()+ => r <: Hedgehog+ => r <: IOE+ => HasCallStack+ => Show a+ => IO a+ -> Eff r a+jotShowIO f =+ withFrozenCallStack do+ !a <- evalIO f+ jotWithCallStack GHC.callStack (show a)+ return a++-- | Annotate the given value in IO returning unit.+jotShowIO_ :: forall a r. ()+ => r <: Hedgehog+ => r <: IOE+ => HasCallStack+ => Show a+ => IO a+ -> Eff r ()+jotShowIO_ f =+ withFrozenCallStack do+ !a <- evalIO f+ jotWithCallStack GHC.callStack (show a)+ return ()++-- | Annotate the given value.+jotShowRead :: forall a r. ()+ => HasCallStack+ => r <: Hedgehog+ => Read a+ => Show a+ => String+ -> Eff r a+jotShowRead s =+ withFrozenCallStack do+ !result <- eval (readEither @a s)+ case result of+ Left e -> failWith Nothing $ "Failed to parse: " <> show s <> " with error: " <> show e+ Right a -> do+ jotWithCallStack GHC.callStack (show a)+ return a++-- | Annotate the given value as JSON.+jotJson :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => a+ -> Eff r a+jotJson a =+ withFrozenCallStack do+ !b <- eval a+ jotWithCallStack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encode b+ return b++-- | Annotate the given value as JSON.+jotJson_ :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => a+ -> Eff r ()+jotJson_ a =+ withFrozenCallStack do+ !b <- eval a+ jotWithCallStack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encode b+ return ()++-- | Annotate the given value as JSON in a monadic context.+jotJsonM :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => Eff r a+ -> Eff r a+jotJsonM a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encode b+ return b++-- | Annotate the given value as JSON in a monadic context.+jotJsonM_ :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => Eff r a+ -> Eff r ()+jotJsonM_ a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encode b+ return ()++-- | Annotate the given value as JSON.+jotJsonPretty :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => a+ -> Eff r a+jotJsonPretty a =+ withFrozenCallStack do+ !b <- eval a+ jotWithCallStack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encodePretty b+ return b++-- | Annotate the given value as JSON.+jotJsonPretty_ :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => a+ -> Eff r ()+jotJsonPretty_ a =+ withFrozenCallStack do+ !b <- eval a+ jotWithCallStack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encodePretty b+ return ()++-- | Annotate the given value as JSON in a monadic context.+jotJsonPrettyM :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => Eff r a+ -> Eff r a+jotJsonPrettyM a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encodePretty b+ return b++-- | Annotate the given value as JSON in a monadic context.+jotJsonPrettyM_ :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => Eff r a+ -> Eff r ()+jotJsonPrettyM_ a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack $ LT.unpack $ LT.decodeUtf8 $ J.encodePretty b+ return ()++-- | Annotate the given value as JSON.+jotYaml :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => a+ -> Eff r a+jotYaml a =+ withFrozenCallStack do+ !b <- eval a+ jotWithCallStack GHC.callStack $ T.unpack $ T.decodeUtf8 $ Y.encode b+ return b++-- | Annotate the given value as JSON.+jotYaml_ :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => a+ -> Eff r ()+jotYaml_ a =+ withFrozenCallStack do+ !b <- eval a+ jotWithCallStack GHC.callStack $ T.unpack $ T.decodeUtf8 $ Y.encode b+ return ()++-- | Annotate the given value as JSON in a monadic context.+jotYamlM :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => Eff r a+ -> Eff r a+jotYamlM a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack $ T.unpack $ T.decodeUtf8 $ Y.encode b+ return b++-- | Annotate the given value as JSON in a monadic context.+jotYamlM_ :: forall a r. ()+ => r <: Hedgehog+ => HasCallStack+ => ToJSON a+ => Eff r a+ -> Eff r ()+jotYamlM_ a =+ withFrozenCallStack do+ !b <- evalM a+ jotWithCallStack GHC.callStack $ T.unpack $ T.decodeUtf8 $ Y.encode b+ return ()++-- | Annotate the each value in the given traversable.+jotEach :: forall a f r. ()+ => r <: Hedgehog+ => HasCallStack+ => Show a+ => Traversable f+ => f a+ -> Eff r (f a)+jotEach as =+ withFrozenCallStack do+ for_ as $ jotWithCallStack GHC.callStack . show+ return as++-- | Annotate the each value in the given traversable returning unit.+jotEach_ :: forall a f r. ()+ => r <: Hedgehog+ => HasCallStack+ => Show a+ => Traversable f+ => f a+ -> Eff r ()+jotEach_ as =+ withFrozenCallStack $ for_ as $ jotWithCallStack GHC.callStack . show++-- | Annotate the each value in the given traversable in a monadic context.+jotEachM :: forall a f r. ()+ => r <: Hedgehog+ => HasCallStack+ => Show a+ => Traversable f+ => Eff r (f a)+ -> Eff r (f a)+jotEachM f =+ withFrozenCallStack do+ !as <- f+ for_ as $ jotWithCallStack GHC.callStack . show+ return as++-- | Annotate the each value in the given traversable in a monadic context returning unit.+jotEachM_ :: forall a f r. ()+ => r <: Hedgehog+ => HasCallStack+ => Show a+ => Traversable f+ => Eff r (f a)+ -> Eff r ()+jotEachM_ f =+ withFrozenCallStack do+ !as <- f+ for_ as $ jotWithCallStack GHC.callStack . show++-- | Annotate the each value in the given traversable in IO.+jotEachIO :: forall a f r. ()+ => r <: Hedgehog+ => r <: IOE+ => HasCallStack+ => Show a+ => Traversable f+ => IO (f a)+ -> Eff r (f a)+jotEachIO f =+ withFrozenCallStack do+ !as <- evalIO f+ for_ as $ jotWithCallStack GHC.callStack . show+ return as++-- | Annotate the each value in the given traversable in IO returning unit.+jotEachIO_ :: forall a f r. ()+ => r <: Hedgehog+ => r <: IOE+ => HasCallStack+ => Show a+ => Traversable f+ => IO (f a)+ -> Eff r ()+jotEachIO_ f =+ withFrozenCallStack do+ !as <- evalIO f+ for_ as $ jotWithCallStack GHC.callStack . show++jotLogTextWithCallStack :: forall r. ()+ => r <: Hedgehog+ => CallStack+ -> Severity+ -> Text+ -> Eff r ()+jotLogTextWithCallStack cs severity a =+ withFrozenCallStack do+ jotWithCallStack cs $ T.unpack $ "[" <> toText severity <> "] " <> a++writeLog :: forall r. ()+ => HasCallStack+ => r <: Hedgehog+ => H.Log+ -> Eff r ()+writeLog message =+ withFrozenCallStack $+ H.writeLog message
+ components/hedgehog/Effectful/Zoo/Hedgehog/Api/Run.hs view
@@ -0,0 +1,47 @@+module Effectful.Zoo.Hedgehog.Api.Run+ ( UnitTest,++ hedgehog,+ unitTest,+ ) where++import Control.Monad.Trans.Writer.Lazy qualified as MTL+import Effectful+import Effectful.Error.Static+import Effectful.Writer.Static.Local+import Effectful.Zoo.Hedgehog.Api.Journal+import Effectful.Zoo.Hedgehog.Dynamic+import Effectful.Zoo.Log.Dynamic+import HaskellWorks.Prelude+import Hedgehog (TestT)+import Hedgehog qualified as H+import Hedgehog.Internal.Property (Failure, Journal)+import Hedgehog.Internal.Property qualified as H+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty)++type UnitTest = TestT IO ()++hedgehog :: forall a. ()+ => Eff+ [ Log Text+ , Hedgehog+ , Error Failure+ , Writer Journal+ , IOE+ ] a+ -> H.TestT IO a+hedgehog f =+ f+ & runLog (ConcUnlift Persistent Unlimited) jotLogTextWithCallStack+ & runHedgehogIO+ & MTL.WriterT+ & ExceptT+ & H.TestT++unitTest :: ()+ => TestName + -> UnitTest + -> TestTree+unitTest desc =+ testProperty desc . H.withTests 1 . H.property . H.test
+ components/hedgehog/Effectful/Zoo/Hedgehog/Dynamic.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Effectful.Zoo.Hedgehog.Dynamic+ ( Hedgehog(..),+ MonadTest(..),++ runHedgehogIO,+ runHedgehog,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Error.Static+import Effectful.Writer.Static.Local+import Effectful.Zoo.Core+import Effectful.Zoo.Hedgehog.MonadTestProxy+import HaskellWorks.Prelude+import Hedgehog (MonadTest(..))+import Hedgehog qualified as H+import Hedgehog.Internal.Property (Failure, Journal)+import Hedgehog.Internal.Property qualified as H++data Hedgehog :: Effect where+ CatchAssertion :: HasCallStack+ => m a+ -> (H.Failure -> m a)+ -> Hedgehog m a++ LiftTest :: HasCallStack+ => H.Test a+ -> Hedgehog m a++ ThrowAssertion :: HasCallStack+ => H.Failure+ -> Hedgehog m a++type instance DispatchOf Hedgehog = Dynamic++instance (r <: Hedgehog) => MonadTest (Eff r) where+ liftTest t = send $ LiftTest t++runHedgehogIO :: forall a. ()+ => Eff+ [ Hedgehog+ , Error Failure+ , Writer Journal+ , IOE+ ] a+ -> IO (Either Failure a, Journal)+runHedgehogIO f =+ f+ & runHedgehog+ & runError @H.Failure+ & runWriter @H.Journal+ & fmap (first (first snd))+ & runEff++runHedgehog :: forall a r. ()+ => r <: Error Failure+ => r <: Writer Journal+ => Eff (Hedgehog : r) a+ -> Eff r a+runHedgehog =+ interpret $ \env -> \case+ CatchAssertion f h -> localUnlift env SeqUnlift $ \unlift -> catchError (unlift f) (const (unlift . h))+ LiftTest f -> liftTestProxy f+ ThrowAssertion failure -> throwError failure
+ components/hedgehog/Effectful/Zoo/Hedgehog/MonadTestProxy.hs view
@@ -0,0 +1,31 @@+module Effectful.Zoo.Hedgehog.MonadTestProxy+ ( MonadTestProxy(..),+ ) where++import Control.Monad.Trans.Writer.Lazy qualified as MTL+import Data.Functor.Identity+import Effectful+import Effectful.Error.Static+import Effectful.Writer.Static.Local+import Effectful.Zoo.Core+import HaskellWorks.Prelude+import Hedgehog (MonadTest(..))+import Hedgehog.Internal.Property (Failure, Journal)+import Hedgehog.Internal.Property qualified as H++class Monad m => MonadTestProxy m where+ liftTestProxy :: H.Test a -> m a++instance MonadTestProxy (H.TestT IO) where+ liftTestProxy = liftTest++instance (r <: Error Failure, r <: Writer Journal) => MonadTestProxy (Eff r) where+ liftTestProxy = \case+ H.TestT m -> do+ let (result, journal) = runIdentity $ MTL.runWriterT $ runExceptT m+ tell journal+ case result of+ Left (H.Failure loc err diff) ->+ throwError (H.Failure loc err diff)+ Right a ->+ pure a
+ components/log/Effectful/Zoo/Log/Api.hs view
@@ -0,0 +1,13 @@+module Effectful.Zoo.Log.Api+ ( log,+ trace,+ debug,+ info,+ warn,+ error,+ crit,+ defaultRenderLogToText,+ ) where++import Effectful.Zoo.Log.Api.Render+import Effectful.Zoo.Log.Api.Text
+ components/log/Effectful/Zoo/Log/Api/Generic.hs view
@@ -0,0 +1,80 @@+module Effectful.Zoo.Log.Api.Generic+ ( log,+ trace,+ debug,+ info,+ warn,+ error,+ crit,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.Log.Data.Severity+import Effectful.Zoo.Log.Dynamic+import HaskellWorks.Prelude hiding (log)++log :: ()+ => HasCallStack+ => r <: Log i+ => Severity+ -> i+ -> Eff r ()+log severity message =+ withFrozenCallStack $+ send (Log severity message)++trace :: ()+ => HasCallStack+ => r <: Log i+ => i+ -> Eff r ()+trace =+ withFrozenCallStack $+ log Trace++debug :: ()+ => HasCallStack+ => r <: Log i+ => i+ -> Eff r ()+debug =+ withFrozenCallStack $+ log Debug++info :: ()+ => HasCallStack+ => r <: Log i+ => i+ -> Eff r ()+info =+ withFrozenCallStack $+ log Info++warn :: ()+ => HasCallStack+ => r <: Log i+ => i+ -> Eff r ()+warn =+ withFrozenCallStack $+ log Warn++error :: ()+ => HasCallStack+ => r <: Log i+ => i+ -> Eff r ()+error =+ withFrozenCallStack $+ log Error++crit :: ()+ => HasCallStack+ => r <: Log i+ => i+ -> Eff r ()+crit =+ withFrozenCallStack $+ log Crit
+ components/log/Effectful/Zoo/Log/Api/LazyText.hs view
@@ -0,0 +1,80 @@+module Effectful.Zoo.Log.Api.LazyText+ ( log,+ trace,+ debug,+ info,+ warn,+ error,+ crit,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.Log.Data.Severity+import Effectful.Zoo.Log.Dynamic+import HaskellWorks.Prelude hiding (log)++log :: ()+ => HasCallStack+ => r <: Log LazyText+ => Severity+ -> LazyText+ -> Eff r ()+log severity message =+ withFrozenCallStack $+ send (Log severity message)++trace :: ()+ => HasCallStack+ => r <: Log LazyText+ => LazyText+ -> Eff r ()+trace =+ withFrozenCallStack $+ log Trace++debug :: ()+ => HasCallStack+ => r <: Log LazyText+ => LazyText+ -> Eff r ()+debug =+ withFrozenCallStack $+ log Debug++info :: ()+ => HasCallStack+ => r <: Log LazyText+ => LazyText+ -> Eff r ()+info =+ withFrozenCallStack $+ log Info++warn :: ()+ => HasCallStack+ => r <: Log LazyText+ => LazyText+ -> Eff r ()+warn =+ withFrozenCallStack $+ log Warn++error :: ()+ => HasCallStack+ => r <: Log LazyText+ => LazyText+ -> Eff r ()+error =+ withFrozenCallStack $+ log Error++crit :: ()+ => HasCallStack+ => r <: Log LazyText+ => LazyText+ -> Eff r ()+crit =+ withFrozenCallStack $+ log Crit
+ components/log/Effectful/Zoo/Log/Api/Render.hs view
@@ -0,0 +1,11 @@+module Effectful.Zoo.Log.Api.Render+ ( defaultRenderLogToText,+ ) where++import Effectful.Zoo.Log.Data.Severity+import HaskellWorks.Prelude hiding (log)+import HaskellWorks.ToText++defaultRenderLogToText :: ToText i => Severity -> i -> Text+defaultRenderLogToText severity i =+ "[" <> toText severity <> "] " <> toText i
+ components/log/Effectful/Zoo/Log/Api/String.hs view
@@ -0,0 +1,80 @@+module Effectful.Zoo.Log.Api.String+ ( log,+ trace,+ debug,+ info,+ warn,+ error,+ crit,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.Log.Data.Severity+import Effectful.Zoo.Log.Dynamic+import HaskellWorks.Prelude hiding (log)++log :: ()+ => HasCallStack+ => r <: Log String+ => Severity+ -> String+ -> Eff r ()+log severity message =+ withFrozenCallStack $+ send (Log severity message)++trace :: ()+ => HasCallStack+ => r <: Log String+ => String+ -> Eff r ()+trace =+ withFrozenCallStack $+ log Trace++debug :: ()+ => HasCallStack+ => r <: Log String+ => String+ -> Eff r ()+debug =+ withFrozenCallStack $+ log Debug++info :: ()+ => HasCallStack+ => r <: Log String+ => String+ -> Eff r ()+info =+ withFrozenCallStack $+ log Info++warn :: ()+ => HasCallStack+ => r <: Log String+ => String+ -> Eff r ()+warn =+ withFrozenCallStack $+ log Warn++error :: ()+ => HasCallStack+ => r <: Log String+ => String+ -> Eff r ()+error =+ withFrozenCallStack $+ log Error++crit :: ()+ => HasCallStack+ => r <: Log String+ => String+ -> Eff r ()+crit =+ withFrozenCallStack $+ log Crit
+ components/log/Effectful/Zoo/Log/Api/Text.hs view
@@ -0,0 +1,80 @@+module Effectful.Zoo.Log.Api.Text+ ( log,+ trace,+ debug,+ info,+ warn,+ error,+ crit,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.Log.Data.Severity+import Effectful.Zoo.Log.Dynamic+import HaskellWorks.Prelude hiding (log)++log :: ()+ => HasCallStack+ => r <: Log Text+ => Severity+ -> Text+ -> Eff r ()+log severity message =+ withFrozenCallStack $+ send (Log severity message)++trace :: ()+ => HasCallStack+ => r <: Log Text+ => Text+ -> Eff r ()+trace =+ withFrozenCallStack $+ log Trace++debug :: ()+ => HasCallStack+ => r <: Log Text+ => Text+ -> Eff r ()+debug =+ withFrozenCallStack $+ log Debug++info :: ()+ => HasCallStack+ => r <: Log Text+ => Text+ -> Eff r ()+info =+ withFrozenCallStack $+ log Info++warn :: ()+ => HasCallStack+ => r <: Log Text+ => Text+ -> Eff r ()+warn =+ withFrozenCallStack $+ log Warn++error :: ()+ => HasCallStack+ => r <: Log Text+ => Text+ -> Eff r ()+error =+ withFrozenCallStack $+ log Error++crit :: ()+ => HasCallStack+ => r <: Log Text+ => Text+ -> Eff r ()+crit =+ withFrozenCallStack $+ log Crit
+ components/log/Effectful/Zoo/Log/Data/LogMessage.hs view
@@ -0,0 +1,11 @@+module Effectful.Zoo.Log.Data.LogMessage where++import Effectful.Zoo.Log.Data.Severity (Severity)+import HaskellWorks.Prelude++data LogMessage i =+ LogMessage+ { severity :: !Severity+ , message :: i+ }+ deriving stock (Eq, Generic, Show)
+ components/log/Effectful/Zoo/Log/Data/Logger.hs view
@@ -0,0 +1,25 @@+module Effectful.Zoo.Log.Data.Logger+ ( Logger(..),+ mkLogger,+ ) where++import Effectful+import Effectful.Zoo.Core+import Effectful.Zoo.Log.Data.Severity+import HaskellWorks.Prelude hiding (Floating(..))++newtype Logger i = Logger+ { run :: CallStack -> Severity -> i -> IO ()+ } deriving stock Generic++instance Contravariant Logger where+ contramap f (Logger g) = Logger \cs severity -> g cs severity . f++mkLogger :: ()+ => r <: IOE+ => UnliftStrategy+ -> (CallStack -> Severity -> i -> Eff r ())+ -> Eff r (Logger i)+mkLogger strategy run =+ withEffToIO strategy $ \effToIO ->+ pure $ Logger $ \cs severity i -> effToIO $ run cs severity i
+ components/log/Effectful/Zoo/Log/Data/Severity.hs view
@@ -0,0 +1,38 @@+module Effectful.Zoo.Log.Data.Severity+ ( Severity (..),+ parseSeverity,+ ) where++import GHC.Enum+import Data.Text qualified as T+import HaskellWorks.Prelude+import HaskellWorks.ToText++data Severity =+ Trace+ | Debug+ | Info+ | Warn+ | Error+ | Crit+ deriving stock (Enum, Eq, Generic, Ord, Show)++parseSeverity :: Text -> Maybe Severity+parseSeverity t =+ case T.toLower t of+ "trace" -> Just Trace+ "debug" -> Just Debug+ "info" -> Just Info+ "warn" -> Just Warn+ "error" -> Just Error+ "crit" -> Just Crit+ _ -> Nothing++instance ToText Severity where+ toText = \case+ Trace -> "trace"+ Debug -> "debug"+ Info -> "info"+ Warn -> "warn"+ Error -> "error"+ Crit -> "crit"
+ components/log/Effectful/Zoo/Log/Dynamic.hs view
@@ -0,0 +1,36 @@+module Effectful.Zoo.Log.Dynamic+ ( Log (..),+ runLog,+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Zoo.Core+import Effectful.Zoo.Log.Data.Severity+import Effectful.Zoo.Log.Static qualified as S+import HaskellWorks.Prelude++data Log i :: Effect where+ Log+ :: HasCallStack+ => Severity+ -> i+ -> Log i m ()++ Local+ :: (i -> i)+ -> m a+ -> Log i m a++type instance DispatchOf (Log a) = Dynamic++runLog :: ()+ => r <: IOE+ => UnliftStrategy+ -> (CallStack -> Severity -> i -> Eff r ())+ -> Eff (Log i : r) a+ -> Eff r a+runLog s run =+ reinterpret (S.runLog s run) $ \env -> \case+ Log severity i -> S.log severity i+ Local f m -> localSeqUnlift env $ \unlift -> S.local f (unlift m)
+ components/log/Effectful/Zoo/Log/Static.hs view
@@ -0,0 +1,112 @@+module Effectful.Zoo.Log.Static+ ( Log,+ runLog,+ runLogToHandle,+ runLogToStdout,+ runLogToStderr,+ withLog,+ log,+ local,+ ) where++import Data.Kind+import Data.Text.IO qualified as T+import Effectful+import Effectful.Dispatch.Static+import Effectful.Zoo.Core+import Effectful.Zoo.Log.Data.Logger+import Effectful.Zoo.Log.Data.Severity+import GHC.Stack qualified as GHC+import HaskellWorks.Prelude hiding (Floating(..))+import System.IO (Handle)+import System.IO qualified as IO++data Log (i :: Type) :: Effect++type instance DispatchOf (Log i) = Static NoSideEffects++newtype instance StaticRep (Log i) = Log (Logger i)++runLog :: ()+ => r <: IOE+ => HasCallStack+ => UnliftStrategy+ -> (CallStack -> Severity -> i -> Eff r ())+ -> Eff (Log i : r) a+ -> Eff r a+runLog strategy run f = do+ s <- mkLogger strategy run+ evalStaticRep (Log s) f++runLogToHandle :: ()+ => HasCallStack+ => Handle+ -> (Severity -> a -> Text)+ -> Eff (Log a : r) a+ -> Eff r a+runLogToHandle h f =+ evalStaticRep $ Log $ Logger $ \_ severity i ->+ T.hPutStrLn h $ f severity i++runLogToStdout :: ()+ => HasCallStack+ => (Severity -> a -> Text)+ -> Eff (Log a : r) a+ -> Eff r a+runLogToStdout =+ runLogToHandle IO.stdout++runLogToStderr :: ()+ => HasCallStack+ => (Severity -> a -> Text)+ -> Eff (Log a : r) a+ -> Eff r a+runLogToStderr =+ runLogToHandle IO.stderr++withDataLogSerialiser :: ()+ => HasCallStack+ => (Logger i -> Logger o)+ -> Eff (Log o : r) a+ -> Eff (Log i : r) a+withDataLogSerialiser f m = do+ logger <- getDataLogger+ let _ = logger+ raise $ evalStaticRep (Log (f logger)) m++withLog :: ()+ => HasCallStack+ => (o -> i)+ -> Eff (Log o : r) a+ -> Eff (Log i : r) a+withLog =+ withDataLogSerialiser . contramap++getDataLogger :: ()+ => HasCallStack+ => r <: Log i+ => Eff r (Logger i)+getDataLogger = do+ Log i <- getStaticRep+ pure i++log :: ()+ => HasCallStack+ => r <: Log i+ => r <: IOE+ => Severity+ -> i+ -> Eff r ()+log severity i =+ withFrozenCallStack do+ dataLogger <- getDataLogger+ liftIO $ dataLogger.run GHC.callStack severity i++local :: ()+ => HasCallStack+ => r <: Log i+ => (i -> i)+ -> Eff r a+ -> Eff r a+local f =+ localStaticRep $ \(Log s) -> Log (contramap f s)
+ effectful-zoo.cabal view
@@ -0,0 +1,180 @@+cabal-version: 3.4++name: effectful-zoo+version: 0.0.0.1+synopsis: Effectful effects for testing+description: See https://hackage.haskell.org/package/effectful-zoo/docs/effectful-zoo.html+category: Development+homepage: https://github.com/haskell-works/effectful-zoo#readme+bug-reports: https://github.com/haskell-works/effectful-zoo/issues+author: John Ky+maintainer: newhoggy@gmail.com+copyright: 2024 John Ky+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+extra-doc-files: README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/haskell-works/effectful-zoo++common base { build-depends: base >= 4.17.2.1 && < 4.20 }++common aeson { build-depends: aeson >= 2.2.3 && < 3 }+common aeson-pretty { build-depends: aeson-pretty >= 0.8.10 && < 1 }+common bytestring { build-depends: bytestring >= 0.11 && < 1 }+common effectful { build-depends: effectful >= 2.5 && < 3 }+common effectful-core { build-depends: effectful-core >= 2.5 && < 3 }+common effectful-plugin { build-depends: effectful-plugin >= 1.1.0.4 && < 2 }+common hedgehog { build-depends: hedgehog >= 1.5 && < 2 }+common hw-prelude { build-depends: hw-prelude >= 0.0.2.0 && < 0.2 }+common tasty { build-depends: tasty >= 1.4.3 && < 1.5 }+common tasty-hedgehog { build-depends: tasty-hedgehog >= 1.1.0.0 && < 1.5 }+common text { build-depends: text >= 2 && < 3 }+common time { build-depends: time >= 1.12 && < 2 }+common transformers { build-depends: transformers >= 0.5.6.2 && < 0.7 }+common yaml { build-depends: yaml >= 0.11.11.2 && < 1 }++common effectful-zoo-core { build-depends: effectful-zoo:core }+common effectful-zoo-hedgehog { build-depends: effectful-zoo:hedgehog }+common effectful-zoo-log { build-depends: effectful-zoo:log }++common project-config+ default-extensions: AllowAmbiguousTypes+ ApplicativeDo+ BlockArguments+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DerivingStrategies+ DerivingVia+ DisambiguateRecordFields+ DuplicateRecordFields+ FunctionalDependencies+ GADTs+ ImportQualifiedPost+ LambdaCase+ LiberalTypeSynonyms+ MonadComprehensions+ MultiWayIf+ NoFieldSelectors+ NoImplicitPrelude+ OverloadedLabels+ OverloadedLists+ OverloadedRecordDot+ OverloadedStrings+ PackageImports+ PartialTypeSignatures+ PatternSynonyms+ QuantifiedConstraints+ QuasiQuotes+ RecordWildCards+ RecursiveDo+ RoleAnnotations+ TemplateHaskell+ TypeFamilies+ TypeFamilyDependencies+ UndecidableInstances+ UnicodeSyntax+ ViewPatterns+ ghc-options: -Wall+ -Widentities+ -Wincomplete-uni-patterns+ -Wmissing-deriving-strategies+ -Wredundant-constraints+ -Wunused-packages+ default-language: GHC2021++library core+ import: project-config,+ effectful,+ visibility: public+ exposed-modules: Effectful.Zoo.Core+ hs-source-dirs: components/core++library datalog+ import: base, project-config,+ effectful-core,+ effectful-plugin,+ effectful-zoo-core,+ hw-prelude,+ text,+ time,+ visibility: public+ exposed-modules: Effectful.Zoo.DataLog.Api+ Effectful.Zoo.DataLog.Data.DataLogger+ Effectful.Zoo.DataLog.Data.LogEntry+ Effectful.Zoo.DataLog.Dynamic+ Effectful.Zoo.DataLog.Static+ ghc-options: -fplugin=Effectful.Plugin+ hs-source-dirs: components/datalog++library hedgehog+ import: base, project-config,+ aeson,+ aeson-pretty,+ bytestring,+ effectful-core,+ effectful-plugin,+ effectful-zoo-core,+ effectful-zoo-log,+ hedgehog,+ hw-prelude,+ tasty-hedgehog,+ tasty,+ text,+ transformers,+ yaml,+ visibility: public+ exposed-modules: Effectful.Zoo.Hedgehog+ Effectful.Zoo.Hedgehog.Api+ Effectful.Zoo.Hedgehog.Api.Assert+ Effectful.Zoo.Hedgehog.Api.Classify+ Effectful.Zoo.Hedgehog.Api.Eval+ Effectful.Zoo.Hedgehog.Api.Failure+ Effectful.Zoo.Hedgehog.Api.Journal+ Effectful.Zoo.Hedgehog.Api.Run+ Effectful.Zoo.Hedgehog.Dynamic+ Effectful.Zoo.Hedgehog.MonadTestProxy+ ghc-options: -fplugin=Effectful.Plugin+ hs-source-dirs: components/hedgehog++library log+ import: base, project-config,+ effectful-core,+ effectful-plugin,+ effectful-zoo-core,+ hw-prelude,+ text,+ visibility: public+ exposed-modules: Effectful.Zoo.Log.Api+ Effectful.Zoo.Log.Api.Generic+ Effectful.Zoo.Log.Api.LazyText+ Effectful.Zoo.Log.Api.Render+ Effectful.Zoo.Log.Api.String+ Effectful.Zoo.Log.Api.Text+ Effectful.Zoo.Log.Data.Logger+ Effectful.Zoo.Log.Data.LogMessage+ Effectful.Zoo.Log.Data.Severity+ Effectful.Zoo.Log.Dynamic+ Effectful.Zoo.Log.Static+ ghc-options: -fplugin=Effectful.Plugin+ hs-source-dirs: components/log++test-suite effectful-zoo-test+ import: project-config,+ effectful-core,+ effectful-zoo-core,+ effectful-zoo-hedgehog,+ effectful-zoo-log,+ hw-prelude,+ tasty,+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: Effectful.Zoo.Hedgehog.Test.HedgehogTest+ hs-source-dirs: components/hedgehog-test+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N