packages feed

hs-hath 1.1.1 → 1.1.2

raw patch · 32 files changed

+3012/−67 lines, 32 filesdep +constraintsdep +contravariantdep +ghc-compactdep −polysemy-zoodep ~basedep ~bytestringdep ~containers

Dependencies added: constraints, contravariant, ghc-compact, random, reflection, streaming

Dependencies removed: polysemy-zoo

Dependency ranges changed: base, bytestring, containers, ghc-prim, network, optparse-applicative, text, tls, tls-session-manager, wai, warp

Files

CHANGELOG.md view
@@ -6,12 +6,19 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## [1.1.1] - 2026-01-26+## [1.1.2] - 2026-01-31 +### Changed+- Now vendors `minio-hs`, `placeholder`, `polysemy-zoo`, and `warp-tls` as internal libraries for finer version control and local modifications+- Update tested GHC version+- Increased presigned URL expiry from 10 to 20 minutes and adjusted local cache TTL to 10 minutes+- Removed custom keystamp-based rate limiting+- Updated to lts-24.27++## [1.1.1] - 2026-01-26 ### Added - R2 Object Storage support with client-side caching - Presigned URL generation for R2 redirects- ### Changed - Refactored time handling to use MonotonicTime for better precision - Fix rate limiting logic
hs-hath.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.38.1.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:           hs-hath-version:        1.1.1+version:        1.1.2 synopsis:       A Haskell implementation of the Hentai@Home client description:    Please see the README on GitHub at <https://github.com/pe200012/hs-hath#readme> category:       Web@@ -18,7 +18,7 @@ license-file:   LICENSE build-type:     Simple tested-with:-    GHC == 9.6.6+    GHC == 9.12.2 extra-source-files:     README.md extra-doc-files:@@ -94,6 +94,7 @@     , hex-text ==0.1.*     , hs-hath-minio     , hs-hath-placeholder+    , hs-hath-polysemy-zoo     , hs-hath-warp-tls     , http-client ==0.7.*     , http-client-tls ==0.3.*@@ -109,7 +110,6 @@     , network >=3.1 && <3.3     , optparse-applicative ==0.18.*     , polysemy ==1.9.*-    , polysemy-zoo ==0.8.*     , process ==1.6.*     , relude ==1.2.*     , resourcet ==1.3.*@@ -227,7 +227,6 @@     , network-uri ==2.*     , optparse-applicative ==0.18.*     , polysemy ==1.9.*-    , polysemy-zoo ==0.8.*     , process ==1.6.*     , relude ==1.*     , resourcet ==1.*@@ -311,7 +310,6 @@     , network >=3.1 && <3.3     , optparse-applicative ==0.18.*     , polysemy ==1.9.*-    , polysemy-zoo ==0.8.*     , process ==1.6.*     , relude ==1.2.*     , resourcet ==1.3.*@@ -339,6 +337,128 @@     , warp ==3.4.*   default-language: GHC2021 +library hs-hath-polysemy-zoo+  exposed-modules:+      Polysemy.Capture+      Polysemy.ConstraintAbsorber+      Polysemy.ConstraintAbsorber.MonadCatch+      Polysemy.ConstraintAbsorber.MonadCont+      Polysemy.ConstraintAbsorber.MonadError+      Polysemy.ConstraintAbsorber.MonadReader+      Polysemy.ConstraintAbsorber.MonadState+      Polysemy.ConstraintAbsorber.MonadWriter+      Polysemy.Cont+      Polysemy.Cont.Internal+      Polysemy.EndState+      Polysemy.Final.IO+      Polysemy.Final.IO.Internal+      Polysemy.Final.More+      Polysemy.Final.MTL+      Polysemy.Final.NonDet+      Polysemy.Floodgate+      Polysemy.Fresh+      Polysemy.Input.Streaming+      Polysemy.KVStore+      Polysemy.Operators+      Polysemy.Random+      Polysemy.Reader.Compact+      Polysemy.Reader.More+      Polysemy.RevState+      Polysemy.SetStore+      Polysemy.Several+      Polysemy.Shift+      Polysemy.Shift.Internal+  other-modules:+      Paths_hs_hath+  autogen-modules:+      Paths_hs_hath+  hs-source-dirs:+      vendor/polysemy-zoo-0.8.2.0/src+  default-extensions:+      DataKinds+      DeriveFunctor+      FlexibleContexts+      GADTs+      LambdaCase+      PolyKinds+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      TypeApplications+      TypeOperators+      TypeFamilies+      UnicodeSyntax+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wall+  build-depends:+      aeson >=2.1 && <2.3+    , async ==2.2.*+    , base ==4.21.*+    , base64 ==1.0.*+    , bytestring >=0.11 && <0.13+    , co-log >=0.6 && <0.8+    , co-log-core ==0.3.*+    , co-log-polysemy >=0.0.1.5 && <0.0.2+    , conduit ==1.3.*+    , constraints >=0.14 && <0.16+    , containers ==0.7.*+    , contravariant ==1.5.*+    , crypton ==1.0.*+    , crypton-connection ==0.4.*+    , crypton-x509 ==1.7.*+    , crypton-x509-store ==1.6.*+    , cryptostore ==0.3.*+    , dhall ==1.42.*+    , directory ==1.3.*+    , exceptions ==0.10.*+    , extra >=1.7 && <1.9+    , filepath >=1.4 && <1.6+    , ghc-compact ==0.1.*+    , ghc-prim ==0.13.*+    , hex-text ==0.1.*+    , http-client ==0.7.*+    , http-client-tls ==0.3.*+    , http-conduit ==2.3.*+    , http-media ==0.8.*+    , http-types ==0.12.*+    , lrucache ==1.2.*+    , mason >=0.2.6 && <0.3+    , memory ==0.18.*+    , monad-control ==1.0.*+    , monad-loops ==0.4.*+    , mtl ==2.3.*+    , network >=3.1 && <3.3+    , optparse-applicative >=0.18.1 && <0.19+    , polysemy ==1.9.*+    , process ==1.6.*+    , random ==1.3.*+    , reflection ==2.1.*+    , relude ==1.2.*+    , resourcet ==1.3.*+    , safe-exceptions ==0.1.*+    , servant >=0.20.2 && <0.21+    , servant-client >=0.20.2 && <0.21+    , servant-client-core >=0.20.2 && <0.21+    , servant-server >=0.20.2 && <0.21+    , sqlite-simple ==0.4.*+    , stm ==2.5.*+    , streaming ==0.2.*+    , string-interpolate ==0.3.*+    , suspend ==0.2.*+    , template-haskell >=2.19 && <2.24+    , text ==2.1.*+    , time >=1.12 && <1.15+    , timers ==0.2.*+    , tls >=2.0 && <2.4+    , tls-session-manager >=0.0.5 && <0.1+    , transformers ==0.6.*+    , unix ==2.8.*+    , unliftio ==0.2.*+    , unordered-containers ==0.2.*+    , wai ==3.2.*+    , wai-extra ==3.1.*+    , warp ==3.4.*+  default-language: GHC2021+ library hs-hath-warp-tls   exposed-modules:       Network.Wai.Handler.WarpTLS@@ -389,7 +509,6 @@     , network ==3.*     , optparse-applicative ==0.18.*     , polysemy ==1.9.*-    , polysemy-zoo ==0.8.*     , process ==1.6.*     , recv ==0.*     , relude ==1.2.*@@ -471,7 +590,6 @@     , network >=3.1 && <3.3     , optparse-applicative ==0.18.*     , polysemy ==1.9.*-    , polysemy-zoo ==0.8.*     , process ==1.6.*     , relude ==1.2.*     , resourcet ==1.3.*@@ -538,6 +656,7 @@     , hex-text ==0.1.*     , hs-hath     , hs-hath-minio+    , hs-hath-polysemy-zoo     , http-client ==0.7.*     , http-client-tls ==0.3.*     , http-conduit ==2.3.*@@ -552,7 +671,6 @@     , network >=3.1 && <3.3     , optparse-applicative     , polysemy ==1.9.*-    , polysemy-zoo ==0.8.*     , process ==1.6.*     , relude ==1.2.*     , resourcet ==1.3.*@@ -642,7 +760,6 @@     , network >=3.1 && <3.3     , optparse-applicative ==0.18.*     , polysemy ==1.9.*-    , polysemy-zoo ==0.8.*     , process ==1.6.*     , relude ==1.2.*     , resourcet ==1.3.*
src/Server.hs view
@@ -172,17 +172,6 @@ maxTimeDrift :: Int64 maxTimeDrift = 600 -{-# NOINLINE globalKeystampMap #-}-globalKeystampMap :: IORef KeystampMap-globalKeystampMap = unsafePerformIO $ newIORef HashMap.empty--{-# NOINLINE globalKeystampMapCounter #-}-globalKeystampMapCounter :: IORef Int-globalKeystampMapCounter = unsafePerformIO $ newIORef 0--maxSameKeystampRequests :: Int-maxSameKeystampRequests = 10- data ServerAction = Reload | Cert | GracefulShutdown  data GalleryTask = GalleryTask@@ -274,22 +263,19 @@       when (abs (timestamp - systemSeconds currentTime) > maxTimeDrift)         $ throw err403 { errBody = "Your time is out of sync. Please update your system time." }       when (answer /= challange cfg) $ throw err403 { errBody = "Invalid key." }-      isSimpleLimited <- checkKeystampRateLimit-      if isSimpleLimited-        then throw $ err429 { errBody = "Too Many Requests" }-        else locateResource-          LocateURI { locateURIFilename = filename, locateURI = uri, locateURIOptions = opts }-          >>= \case-            Nothing -> throw err404-            Just (Redirect url) -> throw-              $ err302-              { errHeaders = [ ( "Location", url ), ( "Cache-Control", "public, max-age=600" ) ] }-            Just (Record (fileRecordBytes -> bs)) -> do-              incServed-              addUpload (BS.length bs)-              return-                $ addHeader @"Content-Length" (BS.length bs)-                $ WithDynamicContentType mimeType bs+      locateResource+        LocateURI { locateURIFilename = filename, locateURI = uri, locateURIOptions = opts }+        >>= \case+          Nothing -> throw err404+          Just (Redirect url) -> throw+            $ err302+            { errHeaders = [ ( "Location", url ), ( "Cache-Control", "public, max-age=600" ) ] }+          Just (Record (fileRecordBytes -> bs)) -> do+            incServed+            addUpload (BS.length bs)+            return+              $ addHeader @"Content-Length" (BS.length bs)+              $ WithDynamicContentType mimeType bs       where         mimeType = case fileExt uri of           "jpg" -> "image/jpeg"@@ -308,7 +294,7 @@           = let               rs        = fromMaybe "" (Map.lookup "keystamp" opts)               ( t, rk ) = BSC.span (/= '-') rs-            in+            in                ( fromIntegral $ maybe 0 fst $ BSC.readInteger t, BS.tail rk )          {-# INLINE challange #-}@@ -325,31 +311,6 @@              <> BD.textUtf8 (key cfg)              <> "-hotlinkthis") -        -- return True if over limit-        checkKeystampRateLimit = embed @IO $ do-          cnt <- readIORef globalKeystampMapCounter-          if cnt > 100-            then do-              writeIORef globalKeystampMapCounter 0-              writeIORef globalKeystampMap HashMap.empty-              pure False-            else do-              writeIORef globalKeystampMapCounter (cnt + 1)-              now <- getMonotonicTime-              m <- readIORef globalKeystampMap-              let checkKey = fileid <> show timestamp-              case HashMap.lookup checkKey m of-                Nothing -> modifyIORef' globalKeystampMap (HashMap.insert checkKey ( 1, now ))-                  >> pure False-                Just ( times, stamp ) -> if now - stamp > timeWindow-                  then modifyIORef' globalKeystampMap (HashMap.delete checkKey) >> pure False-                  else if times >= maxSameKeystampRequests-                    then pure True-                    else modifyIORef'-                      globalKeystampMap-                      (HashMap.insert checkKey ( times + 1, stamp ))-                      >> pure False-     serverCmdHandler command (parseURLParams . encodeUtf8 -> additional) _time _key       = case command of         StillAlive        -> plainText "I feel FANTASTIC and I'm still alive"@@ -381,7 +342,7 @@                      <> BD.byteString testKey                      <> "/0")                 )-          in+          in              case args of               Nothing -> throw err403               Just ( testCount, testSize, url ) -> do@@ -402,7 +363,7 @@                 1000000                 (fromIntegral . fst)                 (BSC.readInteger =<< lookupParam "testsize" additional)-          in+          in              do               addDownload testSize               return
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Capture.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell, Trustworthy #-}+module Polysemy.Capture+  (-- * Effect+    Capture(..)++    -- * Actions+  , reify+  , reflect+  , delimit+  , delimit'+  , capture++    -- * Interpretations+  , runCapture+  , runCaptureWithC++  -- * Prompt types+  , Ref(..)+  ) where++import Control.Monad+import Control.Monad.Cont (ContT(..))++import Polysemy+import Polysemy.Internal+import Polysemy.Internal.Union++import Polysemy.Cont.Internal (Ref(..))++-----------------------------------------------------------------------------+-- | A less powerful variant of 'Polysemy.Shift.Shift' that may always be+-- interpreted safely. Unlike 'Polysemy.Shift.Shift',+-- continuations can't leave the scope in which they are provided.+--+-- __Note__: Any computation used in a higher-order effect will+-- be delimited.+--+-- Activating polysemy-plugin is highly recommended when using this effect+-- in order to avoid ambiguous types.+data Capture ref m a where+  Reify    :: (forall s. ref s a -> m s) -> Capture ref m a+  Reflect  :: ref s a -> a -> Capture ref m s+  Delimit  :: m a -> Capture ref m a+  Delimit' :: m a -> Capture ref m (Maybe a)++makeSem_ ''Capture++-----------------------------------------------------------------------------+-- | Reifies the current continuation in the form of a prompt, and passes it to+-- the first argument.+reify :: forall ref a r+      .  Member (Capture ref) r+      => (forall s. ref s a -> Sem r s)+      -> Sem r a++-----------------------------------------------------------------------------+-- | Provide an answer to a prompt, jumping to its reified continuation.+-- This will not abort the current continuation, and the+-- reified computation will return its final result when finished.+--+-- The provided continuation may fail locally in its subcontinuations.+-- It may sometimes become necessary to handle such cases. To do so,+-- use 'delimit'' together with 'reflect' (the reified continuation+-- is already delimited).+reflect :: forall ref s a r+        .  Member (Capture ref) r+        => ref s a+        -> a+        -> Sem r s++-----------------------------------------------------------------------------+-- | Delimits any continuations+delimit :: forall ref a r+        .  Member (Capture ref) r+        => Sem r a+        -> Sem r a++-----------------------------------------------------------------------------+-- | Delimits any continuations, and detects if any subcontinuation+-- has failed locally.+delimit' :: forall ref a r+         .  Member (Capture ref) r+         => Sem r a+         -> Sem r (Maybe a)++-----------------------------------------------------------------------------+-- | A restricted version of 'Polysemy.Shift.shift'.+-- Executing the provided continuation will not abort execution.+--+-- The provided continuation may fail locally in its subcontinuations.+-- It may sometimes become necessary to handle such cases, in+-- which case such failure may be detected by using 'delimit'' together+-- with the provided continuation (the provided continuation+-- is already delimited).+capture :: forall ref r a+         . Member (Capture ref) r+        => (forall s. (a -> Sem r s) -> Sem r s)+        -> Sem r a+capture cc = reify @ref (\ref -> cc (reflect ref))+{-# INLINE capture #-}++-----------------------------------------------------------------------------+-- | Runs a 'Capture' effect by providing @'pure' '.' 'Just'@ as the final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+runCapture :: Sem (Capture (Ref (Sem r))': r) a -> Sem r (Maybe a)+runCapture = runCaptureWithC (pure . Just)+{-# INLINE runCapture #-}++-----------------------------------------------------------------------------+-- | Runs a 'Capture' effect by explicitly providing a final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+runCaptureWithC :: (a -> Sem r (Maybe s))+                -> Sem (Capture (Ref (Sem r)) ': r) a+                -> Sem r (Maybe s)+runCaptureWithC c (Sem m) = (`runContT` c) $ m $ \u ->+    case decomp u of+      Right (Weaving e s wv ex ins) ->+        ContT $ \c' ->+          case e of+            Reflect ref a ->+                  runRef ref a+              >>= c' . ex . (<$ s)+            Reify main ->+              runCaptureWithC+                (pure . join . ins)+                (wv (main (Ref (c' . ex . (<$ s))) <$ s))+            Delimit main ->+                  runCaptureWithC+                    (pure . Just)+                    (wv (main <$ s))+              >>= maybe (pure Nothing) (c' . ex)+            Delimit' main ->+                  runCaptureWithC+                    (pure . Just)+                    (wv (main <$ s))+              >>= maybe (c' (ex (Nothing <$ s))) (c' . ex . fmap Just)+      Left g -> ContT $ \c' ->+            liftSem (weave (Just ()) (maybe (pure Nothing) runCapture) id g)+        >>= maybe (pure Nothing) c'+{-# INLINE runCaptureWithC #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE AllowAmbiguousTypes         #-}+{-# LANGUAGE ConstraintKinds             #-}++module Polysemy.ConstraintAbsorber+  ( -- * Absorb builder+    absorbWithSem++    -- * Re-exports+  , Reifies+  , (:-) (Sub)+  , Dict (Dict)+  , reflect+  , Proxy (Proxy)+  ) where++import           Data.Constraint (Dict(Dict), (:-)(Sub), (\\))+import qualified Data.Constraint as C+import qualified Data.Constraint.Unsafe as C+import           Data.Kind (Type, Constraint)+import           Data.Proxy (Proxy (..))+import           Data.Reflection (Reifies, reflect)+import qualified Data.Reflection as R+import           Polysemy++------------------------------------------------------------------------------+-- | This function can be used to locally introduce typeclass instances for+-- 'Sem'. See 'Polysemy.ConstraintAbsorber.MonadState' for an example of how to+-- use it.+--+-- @since 0.3.0.0+absorbWithSem+    :: forall -- Constraint to be absorbed+              (p :: (Type -> Type) -> Constraint)+              -- Wrapper to avoid orphan instances+              (x :: (Type -> Type) -> Type -> Type -> Type)+              d r a+     . d  -- ^ Reified dictionary+    -> (forall s. R.Reifies s d :- p (x (Sem r) s))  -- ^ This parameter should always be @'Sub' 'Dict'@+    -> (p (Sem r) => Sem r a)+    -> Sem r a+absorbWithSem d i m =  R.reify d $ \(_ :: Proxy (s :: Type)) -> m \\ C.trans+  (C.unsafeCoerceConstraint :: ((p (x m s) :- p m))) i+{-# INLINEABLE absorbWithSem #-}+
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadCatch.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE AllowAmbiguousTypes         #-}+{-# LANGUAGE FlexibleContexts            #-}+{-# LANGUAGE GADTs                       #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE RankNTypes                  #-}+{-# LANGUAGE ScopedTypeVariables         #-}+{-# LANGUAGE TypeApplications            #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadCatch+  (+    -- * Constraint Absorbers+    absorbMonadThrow+  , absorbMonadCatch+  -- * run helper+  , runMonadCatch+  , runMonadCatchAsText+    -- * Re-exports+  , Exception(..)+  , SomeException+  )+where++import qualified Control.Monad.Catch           as C+import           Control.Monad.Catch            ( Exception(..)+                                                , SomeException+                                                , toException+                                                )++import qualified Data.Text                     as T+import           Polysemy+import           Polysemy.ConstraintAbsorber+import qualified Polysemy.Error                as E+++------------------------------------------------------------------------------+-- | Like 'E.runError' but applies a given function from 'SomeException'+-- to some other type, typically something less opaque.+-- e.g.:+--  @runMonadCatch C.displayException@+-- +-- @since 0.7.0.0+runMonadCatch+  :: Exception e+  => (Maybe e -> e')+  -> Sem (E.Error C.SomeException : E.Error e' : r) a+  -> Sem r (Either e' a)+runMonadCatch f = E.runError . E.mapError (f . C.fromException)++runMonadCatchAsText+  :: Sem (E.Error C.SomeException : E.Error T.Text : r) a+  -> Sem r (Either T.Text a)+runMonadCatchAsText = E.runError . E.mapError (T.pack . C.displayException)++++-- | Introduce a local 'S.MonadCatch' constraint on 'Sem' --- allowing it to+-- interop nicely with exceptions+--+-- @since 0.7.0.0+absorbMonadCatch+  :: Member (E.Error C.SomeException) r+  => (C.MonadCatch (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'C.MonadCatch'+       -- or 'C.MonadThrow' for+       -- 'Sem'. This might be something with type @'C.MonadCatch' e m => m a@.+  -> Sem r a+absorbMonadCatch =+  absorbWithSem @C.MonadCatch @Action (CatchDict E.throw E.catch) (Sub Dict)+{-# INLINABLE absorbMonadCatch #-}++-- | Introduce a local 'S.MonadThrow' constraint on 'Sem' --- allowing it to+-- interop nicely with exceptions+--+-- @since 0.7.0.0+absorbMonadThrow+  :: Member (E.Error C.SomeException) r+  => (C.MonadThrow (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'C.MonadCatch'+       -- or 'C.MonadThrow' for+       -- 'Sem'. This might be something with type @'C.MonadCatch' e m => m a@.+  -> Sem r a+absorbMonadThrow main = absorbMonadCatch main+{-# INLINABLE absorbMonadThrow #-}++------------------------------------------------------------------------------+-- | A dictionary of the functions we need to supply+-- to make an instance of Error+data CatchDict m = CatchDict+  { throwM_ :: forall a. C.SomeException -> m a+  , catch_ :: forall a. m a -> (C.SomeException -> m a) -> m a+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom+-- type parameter for reflection.+-- Locally defined so that the instance we are going+-- to build with reflection must be coherent, that is+-- there cannot be orphans.+newtype Action m s' a = Action { action :: m a }+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl Error dictionary,+-- we can make an instance of @MonadError@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Reifies s' (CatchDict m)+         ) => C.MonadThrow (Action m s') where+  throwM e = Action $ throwM_ (reflect $ Proxy @s') (C.toException e)+  {-# INLINEABLE throwM #-}++instance ( Monad m+         , Reifies s' (CatchDict m)+         )  => C.MonadCatch (Action m s') where+  catch x f =+    let catchF = catch_ (reflect $ Proxy @s')+    in Action $ (action x) `catchF` \e -> case C.fromException e of+      Just e' -> action $ f e'+      _ -> throwM_ (reflect $ Proxy @s') (C.toException e)+  {-# INLINEABLE catch #-}++
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadCont.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE AllowAmbiguousTypes         #-}+{-# LANGUAGE FlexibleInstances           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses       #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadCont+  ( absorbCont+  ) where++import           Data.Coerce+import qualified Control.Monad.Cont.Class as C+import           Polysemy+import           Polysemy.ConstraintAbsorber+import           Polysemy.Cont+++------------------------------------------------------------------------------+-- | Introduce a local 'C.MonadCont' constraint on 'Sem' --- allowing it to+-- interop nicely with MTL.+--+-- @since 0.3.0.0+absorbCont+    :: forall ref r a+     . Member (Cont ref) r+    => (C.MonadCont (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'C.MonadCont' for+       -- 'Sem'. This might be something with type @'C.MonadCont' m => m a@.+    -> Sem r a+absorbCont = absorbWithSem @C.MonadCont @Action+  (ContDict (\main -> callCC @ref $ \exit -> main exit))+  (Sub Dict)+{-# INLINEABLE absorbCont #-}+++------------------------------------------------------------------------------+-- | A dictionary of the functions we need to supply+-- to make an instance of Cont+newtype ContDict m = ContDict+  { callCC_ :: forall a b. ((a -> m b) -> m a) -> m a+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom+-- type parameter for reflection.+-- Locally defined so that the instance we are going+-- to build with reflection must be coherent, that is+-- there cannot be orphans.+newtype Action m s' a = Action (m a)+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl Cont dictionary,+-- we can make an instance of @MonadCont@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Reifies s' (ContDict m)+         ) => C.MonadCont (Action m s') where+  callCC (cc :: (a -> Action m s' b) -> Action m s' a)+    = Action $ callCC_ (reflect $ Proxy @s') @a @b (coerce cc)+  {-# INLINEABLE callCC #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadError.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses       #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadError+  ( absorbError+  ) where++import qualified Control.Monad.Error.Class as S+import           Polysemy+import           Polysemy.ConstraintAbsorber+import           Polysemy.Error+++------------------------------------------------------------------------------+-- | Introduce a local 'S.MonadError' constraint on 'Sem' --- allowing it to+-- interop nicely with MTL.+--+-- @since 0.3.0.0+absorbError+    :: Member (Error e) r+    => (S.MonadError e (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'S.MonadError' for+       -- 'Sem'. This might be something with type @'S.MonadError' e m => m a@.+    -> Sem r a+absorbError = absorbWithSem @(S.MonadError _) @Action+  (ErrorDict throw catch)+  (Sub Dict)+{-# INLINEABLE absorbError #-}+++------------------------------------------------------------------------------+-- | A dictionary of the functions we need to supply+-- to make an instance of Error+data ErrorDict e m = ErrorDict+  { throwError_ :: forall a. e -> m a+  , catchError_ :: forall a. m a -> (e -> m a) -> m a+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom+-- type parameter for reflection.+-- Locally defined so that the instance we are going+-- to build with reflection must be coherent, that is+-- there cannot be orphans.+newtype Action m s' a = Action { action :: m a }+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl Error dictionary,+-- we can make an instance of @MonadError@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Reifies s' (ErrorDict e m)+         ) => S.MonadError e (Action m s') where+  throwError e = Action $ throwError_ (reflect $ Proxy @s') e+  {-# INLINEABLE throwError #-}+  catchError x f = Action $ catchError_ (reflect $ Proxy @s') (action x) (action . f)+  {-# INLINEABLE catchError #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadReader.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses       #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadReader+  ( absorbReader+  ) where++import qualified Control.Monad.Reader.Class as S+import           Polysemy+import           Polysemy.ConstraintAbsorber+import           Polysemy.Reader+++------------------------------------------------------------------------------+-- | Introduce a local 'S.MonadReader' constraint on 'Sem' --- allowing it to+-- interop nicely with MTL.+--+-- @since 0.3.0.0+absorbReader+    :: Member (Reader i) r+    => (S.MonadReader i (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'S.MonadReader' for+       -- 'Sem'. This might be something with type @'S.MonadReader' r m => m a@.+    -> Sem r a+absorbReader = absorbWithSem @(S.MonadReader _) @Action+  (ReaderDict ask local)+  (Sub Dict)+{-# INLINEABLE absorbReader #-}+++------------------------------------------------------------------------------+-- | A dictionary of the functions we need to supply+-- to make an instance of Reader+data ReaderDict i m = ReaderDict+  { ask_ :: m i+  , local_ :: forall a. (i -> i) -> m a -> m a+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom+-- type parameter for reflection.+-- Locally defined so that the instance we are going+-- to build with reflection must be coherent, that is+-- there cannot be orphans.+newtype Action m s a = Action { action :: m a }+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl Reader dictionary,+-- we can make an instance of @MonadReader@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Reifies s' (ReaderDict i m)+         ) => S.MonadReader i (Action m s') where+  ask = Action $ ask_ $ reflect $ Proxy @s'+  {-# INLINEABLE ask #-}+  local f m = Action $ local_ (reflect $ Proxy @s') f $ action m+  {-# INLINEABLE local #-}+
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadState.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses       #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadState+  ( absorbState+  ) where++import           Polysemy+import           Polysemy.ConstraintAbsorber+import           Polysemy.State+import qualified Control.Monad.State.Class as S+++------------------------------------------------------------------------------+-- | Introduce a local 'S.MonadState' constraint on 'Sem' --- allowing it to+-- interop nicely with MTL.+--+-- @since 0.3.0.0+absorbState+    :: Member (State s) r+    => (S.MonadState s (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'S.MonadState' for+       -- 'Sem'. This might be something with type @'S.MonadState' s m => m a@.+    -> Sem r a+absorbState = absorbWithSem @(S.MonadState _) @Action+  (StateDict get put)+  (Sub Dict)+{-# INLINEABLE absorbState #-}+++------------------------------------------------------------------------------+-- | A Dictionary of the functions we need to supply+-- to make an instance of State+data StateDict s m = StateDict+  { get_ :: m s+  , put_ :: s -> m ()+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom type parameter for reflection.++-- Locally defined so that the instance we are going to build with reflection+-- must be coherent, that is there cannot be orphans.+newtype Action m s' a = Action (m a)+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl State dictionary,+-- we can make an instance of @MonadState@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Reifies s' (StateDict s m)+         ) => S.MonadState s (Action m s') where+  get = Action $ get_ $ reflect $ Proxy @s'+  {-# INLINEABLE get #-}+  put s = Action $ put_ (reflect $ Proxy @s') s+  {-# INLINEABLE put #-}+
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadWriter.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleInstances           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses       #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadWriter+  ( absorbWriter+  ) where++import qualified Control.Monad.Writer.Class as S+import           Polysemy+import           Polysemy.ConstraintAbsorber+import           Polysemy.Writer+++------------------------------------------------------------------------------+-- | Introduce a local 'S.MonadWriter' constraint on 'Sem' --- allowing it to+-- interop nicely with MTL.+--+-- @since 0.3.0.0+absorbWriter+    :: forall w r a+     . ( Monoid w+       , Member (Writer w) r+       )+    => (S.MonadWriter w (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'S.MonadWriter' for+       -- 'Sem'. This might be something with type @'S.MonadWriter' w m => m a@.+    -> Sem r a+absorbWriter =+  let swapTuple (x,y) = (y,x)+      semTell = tell+      semListen :: Member (Writer w) r => Sem r b -> Sem r (b, w)+      semListen = fmap swapTuple . listen @w+      semPass :: Member (Writer w) r => Sem r (b, w -> w) -> Sem r b+      semPass = pass @w . fmap swapTuple+  in absorbWithSem @(S.MonadWriter _) @Action+     (WriterDict semTell semListen semPass)+     (Sub Dict)+{-# INLINEABLE absorbWriter #-}+++------------------------------------------------------------------------------+-- | A dictionary of the functions we need to supply+-- to make an instance of Writer+data WriterDict w m = WriterDict+  { tell_ :: w -> m ()+  , listen_ :: forall a. m a -> m (a, w)+  , pass_ :: forall a. m (a, w -> w) -> m a+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom+-- type parameter for reflection.+-- Locally defined so that the instance we are going+-- to build with reflection must be coherent, that is+-- there cannot be orphans.+newtype Action m s' a = Action { action :: m a }+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl Writer dictionary,+-- we can make an instance of @MonadWriter@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Monoid w+         , Reifies s' (WriterDict w m)+         ) => S.MonadWriter w (Action m s') where+  tell w = Action $ tell_ (reflect $ Proxy @s') w+  {-# INLINEABLE tell #-}+  listen x = Action $ listen_ (reflect $ Proxy @s') (action x)+  {-# INLINEABLE listen #-}+  pass x = Action $ pass_ (reflect $ Proxy @s') (action x)+  {-# INLINEABLE pass #-}+
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Cont.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE AllowAmbiguousTypes, Trustworthy #-}+module Polysemy.Cont+  (-- * Effect+    Cont(..)++    -- * Actions+  , jump+  , subst+  , callCC++    -- * Interpretations+  , runContPure+  , runContM+  , contToFinal++    -- * Experimental Interpretations+  , runContViaFresh++    -- * Unsafe Interpretations+  , runContUnsafe++  -- * Prompt types+  , Ref(..)+  , ExitRef(..)+  , ViaFreshRef+  ) where++import Data.Void++import Polysemy+import Polysemy.Final++import Polysemy.Cont.Internal++import Polysemy.Error+import Polysemy.Fresh++import Control.Monad.Cont (MonadCont(), ContT(..), runContT)+import qualified Control.Monad.Cont as C (callCC)++-----------------------------------------------------------------------------+-- | Call with current continuation.+-- Executing the provided continuation will abort execution.+--+-- Using the provided continuation+-- will rollback all local effectful state back to the point where+-- 'callCC' was invoked.+--+-- Higher-order effects do not interact with the continuation in any meaningful+-- way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does not affect+-- it, and 'Polysemy.Error.catch' will fail to catch any of its exceptions.+-- The only exception to this is if you interpret such effects /and/ 'Cont'+-- in terms of the final monad, and the final monad can perform such interactions+-- in a meaningful manner.+callCC :: forall ref r a+       .  Member (Cont ref) r+       => ((forall b. a -> Sem r b) -> Sem r a)+       -> Sem r a+callCC cc = subst @ref (\ref -> cc (jump ref)) pure+{-# INLINE callCC #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' effect by providing 'pure' as the final continuation.+--+-- This is a safe variant of 'runContUnsafe', as this may only be used+-- as the final interpreter before 'run'.+runContPure :: Sem '[Cont (Ref (Sem '[]) a)] a -> Sem '[] a+runContPure = runContUnsafe+{-# INLINE runContPure #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' effect by providing 'pure' as the final continuation.+--+-- This is a safe variant of 'runContUnsafe', as this may only be used+-- as the final interpreter before 'runM'.+runContM :: Sem '[Cont (Ref (Sem '[Embed m]) a), Embed m] a -> Sem '[Embed m] a+runContM = runContUnsafe+{-# INLINE runContM #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' effect in terms of a final 'MonadCont'+--+-- /Beware/: Effects that aren't interpreted in terms of the final monad+-- will have local state semantics in regards to 'Cont' effects+-- interpreted this way. See 'Final'.+contToFinal :: (Member (Final m) r, MonadCont m)+            => Sem (Cont (ExitRef m) ': r) a+            -> Sem r a+contToFinal = interpretFinal $ \case+  Jump ref a    -> pure $ enterExit ref a+  Subst main cb -> do+    main' <- bindS main+    cb'   <- bindS cb+    s     <- getInitialStateS+    pure $ C.callCC $ \exit ->+      main' (ExitRef (\a -> cb' (a <$ s) >>= vacuous . exit) <$ s)+{-# INLINE contToFinal #-}++-----------------------------------------------------------------------------+-- | A highly experimental 'Cont' interpreter that functions+-- through a combination of 'Error' and 'Fresh'. This may be used safely+-- anywhere in the effect stack.+--+-- 'runContViaFresh' is still under development.+-- You're encouraged to experiment with it, but don't rely on it.+-- For best results, use 'runContViaFresh' as the first interpreter you run,+-- such that all other effects are global in respect to it.+--+-- This interpreter may return 'Nothing' if the control flow becomes+-- split into separate, inconsistent parts,+-- such that backtracking fails when trying to invoke continuations.+-- For example, if you reify a continuation inside an+-- 'async':ed thread, and then have that thread return the reified+-- continuation back to the main thread through an 'await', then+-- 'runContViaFresh' will return 'Nothing' upon executing the continuation+-- in the main thread.+runContViaFresh :: forall uniq r a+                 . (Member (Fresh uniq) r, Eq uniq)+                => Sem (Cont (ViaFreshRef uniq) ': r) a+                -> Sem r (Maybe a)+runContViaFresh =+  let+    hush (Right a) = Just a+    hush _         = Nothing+  in+      fmap hush+    . runError+    . (`runContT` pure)+    . runContViaFreshInC+{-# INLINE runContViaFresh #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' effect by providing 'pure' as the final continuation.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runContUnsafe' only /after/ running all__+-- __interpreters for your higher-order effects.__+--+-- Note that 'Final' is a higher-order effect, and thus 'runContUnsafe' can't+-- safely be used together with 'runFinal'.+runContUnsafe :: Sem (Cont (Ref (Sem r) a) ': r) a -> Sem r a+runContUnsafe = runContWithCUnsafe pure+{-# INLINE runContUnsafe #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Cont/Internal.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE TemplateHaskell, Unsafe #-}+module Polysemy.Cont.Internal where++import Data.Functor.Contravariant++import Polysemy+import Polysemy.Internal+import Polysemy.Internal.Union+import Polysemy.Fresh+import Polysemy.Error++import Control.Monad+import Control.Monad.Trans.Cont hiding (Cont)++import Unsafe.Coerce+import GHC.Exts (Any)++-----------------------------------------------------------------------------+-- | An effect for abortive continuations.+--+-- Formulated à la Tom Schrijvers et al.+-- "Monad Transformers and Modular Algebraic Effects: What Binds Them Together"+-- (2016). <http://www.cs.kuleuven.be/publicaties/rapporten/cw/CW699.pdf>+--+-- Activating polysemy-plugin is highly recommended when using this effect+-- in order to avoid ambiguous types.+data Cont ref m a where+  Jump    :: ref a -> a -> Cont ref m b+  Subst   :: (ref a -> m b) -> (a -> m b) -> Cont ref m b++makeSem_ ''Cont++-----------------------------------------------------------------------------+-- | Provide an answer to a prompt, jumping to its reified continuation,+-- and aborting the current continuation.+--+-- Using 'jump' will rollback all effectful state back to the point where the+-- prompt was created, unless such state is interpreted in terms of the final+-- monad, /or/ the associated interpreter of the effectful state+-- is run after 'runContUnsafe', which may be done if the effect isn't+-- higher-order.+--+-- Higher-order effects do not interact with the continuation in any meaningful+-- way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does not affect+-- it, and 'Polysemy.Error.catch' will fail to catch any of its exceptions.+-- The only exception to this is if you interpret such effects /and/ 'Cont'+-- in terms of the final monad, and the final monad can perform such interactions+-- in a meaningful manner.+jump :: forall ref a b r.+        Member (Cont ref) r+     => ref a+     -> a+     -> Sem r b++-----------------------------------------------------------------------------+-- | Reifies the current continuation in the form of a prompt, and passes it to+-- the first argument. If the prompt becomes invoked via 'jump', then the+-- second argument will be run before the reified continuation, and otherwise+-- will not be called at all.+subst :: forall ref a b r+      .  Member (Cont ref) r+      => (ref a -> Sem r b)+      -> (a -> Sem r b)+      -> Sem r b++-----------------------------------------------------------------------------+-- | Runs a 'Cont' effect by providing a final continuation.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runContWithCUnsafe' /after/ running all interpreters+-- for your higher-order effects.__+runContWithCUnsafe :: (a -> Sem r s) -> Sem (Cont (Ref (Sem r) s) ': r) a -> Sem r s+runContWithCUnsafe c (Sem m) = (`runContT` c) $ m $ \u -> case decomp u of+  Right weaving -> runContWeaving runContWithCUnsafe weaving+  Left g -> ContT $ \c' -> embedSem g >>= runContWithCUnsafe c'+{-# INLINE runContWithCUnsafe #-}++runContWeaving :: Monad m+               => (forall x. (x -> m s) -> Sem r x -> m s)+               -> Weaving (Cont (Ref m s)) (Sem r) a+               -> ContT s m a+runContWeaving runW (Weaving e s wv ex _) =+    ContT $ \c ->+      case e of+        Jump ref a    -> runRef ref a+        Subst main cb ->+          let+            callback a = runW (c . ex) (wv (cb a <$ s))+          in+            runW (c . ex) (wv (main (Ref callback) <$ s))+{-# INLINE runContWeaving #-}++inspectSem :: Sem r a -> Maybe a+inspectSem (Sem m) = m (\_ -> Nothing)+{-# INLINE inspectSem #-}++embedSem :: Union r (Sem r') a -> Sem r (Sem r' a)+embedSem = liftSem . weave (pure ()) (pure . join) inspectSem+{-# INLINE embedSem #-}++newtype Ref m s a = Ref { runRef :: a -> m s }++instance Contravariant (Ref m s) where+  contramap f ref = Ref (runRef ref . f)++newtype ExitRef m a = ExitRef { enterExit :: forall b. a -> m b }++instance Contravariant (ExitRef m) where+  contramap f ref = ExitRef $ \a -> enterExit ref (f a)++data ViaFreshRef uniq a = ViaFreshRef { getBacktrackException :: a -> (uniq, Any) }++instance Contravariant (ViaFreshRef uniq) where+  contramap f ref = ViaFreshRef $ \a -> getBacktrackException ref (f a)++{-+  KingoftheHomeless: OK, so let's discuss how this works.+  The idea here is to instead of providing a monadic computation+  to the call of 'callCC' that simply short-circuits everything like+  'ContT' does, we fake that behaviour by instead providing an+  exception to 'callCC', and then try to 'catch' that exception+  on the continuation. If the exception is caught, then we run the+  continuation again. This way, we can get abortive continuations+  without having to scope over a result type variable, avoiding+  the problem that 'runContUnsafe' has, and making it possible+  to weave other effects through without breaking everything.++  Even with that solution, weaving effects through have more problems+  of their own; namely, if we simply lower a+  'forall s. ContT s (Sem r) a' to 'Sem r a', then we effectively+  delimit all higher-order computations. This is bad, because+  if a reified continuation produced within+  the higher-order computation escapes from it,+  then nothing can catch the underlying backtrack exception+  once it is thrown.++  The solution to this is anothor kludge: when weaving other effects through,+  we instead use 'runContViaFreshInCWeave'; this makes use 'ContFreshState'+  as its functorial state, which stores /handlers/ for backtrack exceptions.+  'runContViaFreshInCWeave', in addition to 'catch'ing exceptions on the continuation+  it is given, /also/ returns the handler it uses for the 'catch'.+  This handler is then used by 'runContViaFresh' to catch exceptions on the+  continuation /it/ gets, but can't provide to the higher-order computation.++  I'm astonished that this even remotely works, but it does have some rather+  weird behaviour I haven't completely figured out yet.++  I'm reasonably happy with how 'runContViaFreshInC' looks;+  I'm a lot less happy with 'runContViaFreshInCWeave', I just kinda threw+  it haphazardly. I figure most weirdness stem from issues in+  'runContViaFreshInCWeave', so I need to think it through some more.+-}+-- | Intermediary monadic interpretation used for running 'runContViaFresh'.+-- See source for a discussion on how this works.+runContViaFreshInC :: forall uniq s r a+                    . (Member (Fresh uniq) r, Eq uniq)+                   => Sem (Cont (ViaFreshRef uniq) ': r) a+                   -> ContT s (Sem (Error (uniq, Any) ': r)) a+runContViaFreshInC = usingSem $ \u -> ContT $ \c ->+  case decomp u of+    Right (Weaving e s wv ex _) ->+      case e of+        Subst main cn -> do+          ref <- fresh+          let+            main' = runContViaFreshInC . wv . fmap main . (<$ s)+            cn'   = runContViaFreshInC . wv . fmap cn . (<$ s)+            loop act =+              runContT (ex <$> act) c `catch` \ x@(ref', a') -> do+                if ref == ref' then+                  loop (cn' $ unsafeCoerce a')+                else+                  throw @(uniq, Any) x+          loop $ main' $ ViaFreshRef (\a -> (ref, unsafeCoerce a))+        Jump ref a -> throw (getBacktrackException ref a)+    Left g -> do+      ResAndHandler a rc <- liftSem $+        weave+          (ResAndHandler @uniq @r () throw)+          -- TODO(KingoftheHomeless): is this the distributive law we want?+          (\(ResAndHandler a rc) ->+            runContT+              (runContViaFreshInCWeave a)+              (\x -> pure $+                ResAndHandler+                  x+                  (rc >=> (`runContT` pure) . runContViaFreshInC)+              )+          )+          (Just . getResult)+          (weaken g)+      let loop x = c x `catch` (rc >=> loop)+      loop a++-- | A variant of 'runContViaFreshInC' which it uses when weaving other effects through.+runContViaFreshInCWeave :: forall uniq s r a+                         . (Member (Fresh uniq) r, Eq uniq)+                        => Sem (Cont (ViaFreshRef uniq) ': r) a+                        -> ContT (ContFreshState uniq r s)+                            (Sem (Error (uniq, Any) ': r))+                            a+runContViaFreshInCWeave = usingSem $ \u -> ContT $ \c ->+  case decomp u of+    Right (Weaving e s wv ex _) ->+      case e of+        Subst main cn -> do+          ref <- fresh+          let+            -- TODO(KingoftheHomeless): runContViaFreshInC?+            main' = runContViaFreshInCWeave . wv . fmap main . (<$ s)+            cn'   = runContViaFreshInCWeave . wv . fmap cn . (<$ s)+            loop act =+              runContT (ex <$> act) c `catch` \ x@(ref', a') -> do+                if ref == ref' then+                  loop (cn' $ unsafeCoerce a')+                else+                  throw @(uniq, Any) x+          ResAndHandler res h <-+            loop $ main' $ ViaFreshRef (\a -> (ref, unsafeCoerce a))+          return $ ResAndHandler res+              -- TODO(KingoftheHomeless): This handler is dubious.+            $ \x -> fmap getResult $ loop $ ContT $ \_ -> fmap (`ResAndHandler` h) (h x)+        Jump ref a -> throw (getBacktrackException ref a)+    Left g -> do+      ResAndHandler a h <- liftSem $+        weave+          (ResAndHandler @uniq @r () throw)+          (\(ResAndHandler a rc) ->+            runContT+              (runContViaFreshInCWeave a)+              (\x -> pure $+                ResAndHandler+                  x+                  (rc >=> (`runContT` pure) . runContViaFreshInC)+              )+          )+          (Just . getResult)+          (weaken g)+      let loop x = c x `catch` (h >=> loop)+      ResAndHandler res h' <- loop a+      -- TODO(KingoftheHomeless): This handler is dubious.+      return (ResAndHandler res $ \x -> (h' x `catch` (h >=> fmap getResult . loop)))++-- | This is the effectful state used by 'runContViaFreshInC' when weaving through+-- other effectful actions. The point of it is to avoid delimiting computations+-- in higher-order effects, by having them return a handler which may be used+-- to intercept backtrack exceptions of the current continuation.+data ContFreshState uniq r a = ResAndHandler {+    getResult :: a+  , getHandler :: (uniq, Any) -> Sem (Error (uniq, Any) ': r) a+  }+  deriving Functor
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/EndState.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell #-}+module Polysemy.EndState+  (-- * Effect+    EndState(..)++    -- * Actions+  , getEndState++    -- * Interpretations+  , runEndState+  , runEndAtomicState+  ) where++import Polysemy+import Polysemy.Fixpoint+import Polysemy.Reader+import Polysemy.Reader.More++import Polysemy.State+import Polysemy.AtomicState+++-----------------------------------------------------------------------------+-- | An effect for getting the end state of a computation in advance.+data EndState s m a where+  GetEndState :: EndState s m s++makeSem ''EndState++-----------------------------------------------------------------------------+-- | Runs an 'EndState' effect by getting the state after the computation+-- has finished, and providing it recursively back to calls of 'getEndState'.+runEndState :: forall s r a+             . (Member (State s) r, Member Fixpoint r)+            => Sem (EndState s ': r) a+            -> Sem r a+runEndState =+    runReaderFixSem (get @s)+  . reinterpret (\GetEndState -> ask)+++-----------------------------------------------------------------------------+-- | Like 'runEndState', but for 'AtomicState' rather than 'State'.+runEndAtomicState+  :: forall s r a+   . (Member (AtomicState s) r, Member Fixpoint r)+  => Sem (EndState s ': r) a+  -> Sem r a+runEndAtomicState =+    runReaderFixSem (atomicGet @s)+  . reinterpret (\GetEndState -> ask)
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/IO.hs view
@@ -0,0 +1,58 @@+module Polysemy.Final.IO+  (+    -- * Combinators for Interpreting to the Final Monad+    interpretFinalGlobal++    -- * Interpretations for other effects+  , asyncToIOFinalGlobal+  , resourceToIOFinalGlobal+  ) where++import qualified Control.Concurrent.Async as A+import qualified Control.Exception as X++import Polysemy+import Polysemy.Final+import Polysemy.Final.IO.Internal+import Polysemy.Async+import Polysemy.Resource++------------------------------------------------------------------------------+-- | 'asyncToIOFinal' implemented using 'interpretFinalGlobal'.+--+-- This behaves semantically very much like 'asyncToIO',+-- but doesn't need to spin up an interpreter thread, making it more+-- efficient (but not any more safe).+asyncToIOFinalGlobal :: Member (Final IO) r+                     => Sem (Async ': r) a+                     -> Sem r a+asyncToIOFinalGlobal = interpretFinalGlobal $ \case+  Async m -> do+    ins <- getInspectorS+    m'  <- runS m+    liftS $ A.async (inspect ins <$> m')+  Await a -> liftS (A.wait a)+  Cancel a -> liftS (A.cancel a)+{-# INLINE asyncToIOFinalGlobal #-}+------------------------------------------------------------------------------+-- | 'resourceToIOFinal' implemented using 'interpretFinalGlobal'.+--+-- This behaves semantically very much like 'resourceToIO',+-- but doesn't need to spin up an interpreter thread,+-- making it more efficient (but not any more safe).+resourceToIOFinalGlobal :: Member (Final IO) r+                        => Sem (Resource ': r) a+                        -> Sem r a+resourceToIOFinalGlobal = interpretFinalGlobal $ \case+  Bracket alloc dealloc use -> do+    a <- runS  alloc+    d <- bindS dealloc+    u <- bindS use+    pure $ X.bracket a d u++  BracketOnError alloc dealloc use -> do+    a <- runS  alloc+    d <- bindS dealloc+    u <- bindS use+    pure $ X.bracketOnError a d u+{-# INLINE resourceToIOFinalGlobal #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/IO/Internal.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE TemplateHaskell #-}+module Polysemy.Final.IO.Internal where++import Data.Functor.Compose+import Data.Maybe++import Control.Concurrent.MVar+import Control.Exception+import Control.Monad+import Control.Monad.Trans.Maybe++import Polysemy+import Polysemy.Final+import Polysemy.Internal+import Polysemy.Internal.Union+import Polysemy.Internal.Strategy++------------------------------------------------------------------------------+-- | Like 'interpretFinal' specialized to 'IO', but also tries very hard+-- to preserve state semantics dependant on the order interpreters are run,+-- adressing the primary issue with 'Final'.+--+-- Semantically, interpreters written using this behave very much as+-- though they were written using 'withLowerToIO'.+-- However, this does not need to spawn an interpreter thread, making+-- it more efficient (but not any more safe.)+--+-- 'interpretFinalGlobal' operates under the assumption that any effectful+-- state which can't be inspected using 'Polysemy.Inspector' can't contain any+-- values. For example, the effectful state for 'Polysemy.runError' is+-- @'Either' e a@. The inspector for this effectful state only fails if the+-- effectful state is a @'Left'@ value, which therefore doesn't contain any+-- values of @a@.+--+-- The assumption holds true for all interpreters featured in polysemy,+-- and is presumably always true for any properly implemented interpreter.+-- 'interpretFinalGlobal' may throw an exception if it is used together with an+-- interpreter that uses 'Polysemy.Internal.Union.weave' improperly.+interpretFinalGlobal+    :: forall e a r+     . Member (Final IO) r+    => (forall x n. e n x -> Strategic IO n x)+    -> Sem (e ': r) a+    -> Sem r a+interpretFinalGlobal f sem = withWeavingToFinal $ \s wv ins -> do+  st  <- newMVar s+  res <- runMaybeT $ runViaFinalGlobal st wv ins f sem+  s'  <- readMVar st+  return (fromMaybe bomb res <$ s')+{-# INLINE interpretFinalGlobal #-}++runViaFinalGlobal :: (Member (Final IO) r, Functor f)+                  => MVar (f ())+                  -> (forall x. f (Sem r x) -> IO (f x))+                  -> (forall x. f x -> Maybe x)+                  -> ( forall x n+                     . e n x+                    -> Strategic IO n x+                     )+                  -> Sem (e ': r) a+                  -> MaybeT IO a+runViaFinalGlobal st wv ins f = usingSem $ \u -> case decomp u of+  Right (Weaving e s' wv' ex ins') ->+    fmap ex $ MaybeT $ fmap getCompose $ runStrategy (f e)+          (Compose (Just s'))+          (  maybe+              (pure (Compose Nothing))+              (  fmap Compose+               . runMaybeT+               . runViaFinalGlobal st wv ins f+               . wv'+              )+           . getCompose+          )+          (getCompose >=> ins')+  Left g -> case prj g of+      Just (Weaving (WithWeavingToFinal wav) s' wv' ex' ins') ->+        MaybeT $ fmap (fmap ex' . getCompose) $+          wav+            (Compose (Just s'))+            (  maybe+                (pure (Compose Nothing))+                ( fmap Compose+                . runMaybeT+                . runViaFinalGlobal st wv ins f+                . wv'+                )+             . getCompose+            )+            (getCompose >=> ins')+      _ -> MaybeT $ mask $ \restore -> do+        -- TODO(KingoftheHomeless): Figure out a solution to polysemy issue #205.+        -- Although we're using a different mechanism, the exact same problem manifests+        -- here.+        s   <- takeMVar st+        res <- restore (wv (liftSem (hoist (interpretFinalGlobal f) g) <$ s))+          `onException` putMVar st s+        putMVar st (() <$ res)+        return $ ins res+{-# INLINE runViaFinalGlobal #-}++bomb :: a+bomb = error+  "interpretFinalGlobal: Uninspectable functorial state \+                        \still carried a result. You're likely using an interpreter \+                        \that uses 'weave' improperly. \+                        \See documentation for more information."
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/MTL.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+module Polysemy.Final.MTL+  (+    module Polysemy.Final+  , errorToFinal+  , readerToFinal+  , stateToEmbed+  , writerToFinal+  ) where++import Control.Monad.Error.Class hiding (Error)+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Writer.Class++import Polysemy+import Polysemy.Final+import Polysemy.Error hiding (throw, catch)+import Polysemy.Reader hiding (ask, local)+import Polysemy.State hiding (get, put)+import Polysemy.Writer hiding (tell, listen, pass)++-----------------------------------------------------------------------------+-- | Run an 'Error' effect through a final 'MonadError'+--+-- /Beware/: Effects that aren't interpreted in terms of the final+-- monad will have local state semantics in regards to 'Error' effects+-- interpreted this way. See 'Final'.+errorToFinal :: forall m e r a+              . (Member (Final m) r, MonadError e m)+             => Sem (Error e ': r) a+             -> Sem r a+errorToFinal = interpretFinal @m $ \case+  Throw e   -> pure $ throwError e+  Catch m h -> do+    m' <- runS m+    h' <- bindS h+    s  <- getInitialStateS+    pure $ m' `catchError` (h' . (<$ s))+{-# INLINE errorToFinal #-}++-----------------------------------------------------------------------------+-- | Run a 'Reader' effect through a final 'MonadReader'+--+-- /Beware/: Effects that aren't interpreted in terms of the final+-- monad will have local state semantics in regards to 'Reader' effects+-- interpreted this way. See 'Final'.+readerToFinal :: forall m i r a+               . (Member (Final m) r, MonadReader i m)+              => Sem (Reader i ': r) a+              -> Sem r a+readerToFinal = interpretFinal @m $ \case+  Ask       -> liftS ask+  Local f m -> do+    m' <- runS m+    pure $ local f m'+{-# INLINE readerToFinal #-}++-----------------------------------------------------------------------------+-- | Run a 'State' effect in terms of an underlying 'MonadState' instance+--+-- Although this is not a 'Final' interpreter, as the target monad need not+-- actually be the final monad, 'stateToEmbed' still possesses the+-- unusual semantics of interpreters that runs+-- effects by embedding them into another monad.+--+-- /Beware/: Effects that aren't interpreted in terms of the embedded+-- monad will have local state semantics in regards to 'State' effects+-- interpreted this way. See 'Final'.+stateToEmbed :: forall m s r a+              . (Member (Embed m) r, MonadState s m)+             => Sem (State s ': r) a+             -> Sem r a+stateToEmbed = interpret $ \case+  Get   -> embed @m get+  Put s -> embed @m (put s)+{-# INLINE stateToEmbed #-}++-----------------------------------------------------------------------------+-- | Run a 'Writer' effect through a final 'MonadWriter'+--+-- /Beware/: Effects that aren't interpreted in terms of the final+-- monad will have local state semantics in regards to 'Writer' effects+-- interpreted this way. See 'Final'.+writerToFinal :: forall m o r a+               . (Member (Final m) r, MonadWriter o m)+              => Sem (Writer o ': r) a+              -> Sem r a+writerToFinal = interpretFinal @m $ \case+  Tell s    -> liftS (tell s)+  Listen m -> do+    m' <- runS m+    pure $+      (\ ~(s, o) -> (,) o <$> s) <$> listen m'+  Pass m -> do+    m'  <- runS m+    ins <- getInspectorS+    pure $ pass $ do+      t <- m'+      let f = maybe id fst (inspect ins t)+      pure (fmap snd t, f)+{-# INLINE writerToFinal #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/More.hs view
@@ -0,0 +1,32 @@+module Polysemy.Final.More where++import Polysemy+import Polysemy.Internal+import Polysemy.Internal.Union+import Polysemy.Final++------------------------------------------------------------------------------+-- | Run a @'Final' ('Sem' r)@ effect if the remaining effect stack is @r@.+--+-- This is sometimes useful for interpreters that make use of+-- 'reinterpret', 'raiseUnder', or any of their friends.+runFinalSem :: Sem (Final (Sem r) ': r) a -> Sem r a+runFinalSem = usingSem $ \u -> case decomp u of+  Right (Weaving (WithWeavingToFinal wav) s wv ex ins) ->+    ex <$> wav s (runFinalSem . wv) ins+  Left g -> liftSem (hoist runFinalSem g)+{-# INLINE runFinalSem #-}++------------------------------------------------------------------------------+-- | Run a @'Final' m@ effect by providing an explicit lowering function.+--+-- /Beware/: The lowering function may be invoked multiple times, so+-- __don't do any initialization work inside the lowering function__:+-- it will be duplicated.+lowerFinal :: Member (Embed m) r+           => (forall x. Sem r x -> m x)+           -> Sem (Final m ': r) a+           -> Sem r a+-- TODO(KingoftheHomeless): Write everything out for efficiency?+lowerFinal f = runFinalSem . finalToFinal embed f . raiseUnder+{-# INLINE lowerFinal #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/NonDet.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+module Polysemy.Final.NonDet+  (+    module Polysemy.NonDet+  , nonDetToFinal+  ) where++import Control.Applicative++import Polysemy+import Polysemy.NonDet+import Polysemy.Final++-----------------------------------------------------------------------------+-- | Run an 'NonDet' effect through a final 'Alternative'+--+-- /Beware/: Effects that aren't interpreted in terms of the final+-- monad will have local state semantics in regards to 'NonDet' effects+-- interpreted this way. See 'Final'.+nonDetToFinal :: forall m r a+               . (Member (Final m) r, Alternative m)+              => Sem (NonDet ': r) a+              -> Sem r a+nonDetToFinal = interpretFinal @m $ \case+  Empty -> pure empty+  Choose left right -> do+    left'  <- runS left+    right' <- runS right+    pure $ left' <|> right'+{-# INLINE nonDetToFinal #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Floodgate.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Floodgate+  ( -- * Effect+    Floodgate (..)+    -- * Actions+  , hold+  , release++    -- * Interpretations+  , runFloodgate+  , runFloodgateDry+  ) where++import Control.Monad+import GHC.Types+import Polysemy+import Polysemy.State+import Unsafe.Coerce++------------------------------------------------------------------------------+-- |+--+-- @since 0.3.1.0+data Floodgate m a where+  Hold    :: m () -> Floodgate m ()+  Release :: Floodgate m ()++makeSem ''Floodgate+++------------------------------------------------------------------------------+-- |+--+-- @since 0.3.1.0+runFloodgate+    :: Sem (Floodgate ': r) a+    -> Sem r a+runFloodgate = fmap snd . runState @[Any] [] . reinterpretH+  ( \case+      Hold m -> do+        m' <- fmap void $ runT m+        -- These 'Any's are here because the monadic action references 'r', and+        -- if we exposed that, 'r' would be an infinite type+        modify (unsafeCoerce @_ @Any (raise $ runFloodgate m') :)+        getInitialStateT++      Release -> do+        ms' <- gets @[Any] (fmap unsafeCoerce . reverse)+        sequence_ ms'+        getInitialStateT+  )+++------------------------------------------------------------------------------+-- | Like 'runFloodgate', but will do a final flush to 'release' anything that+-- might still be behind the floodgate.+--+-- @since 0.3.1.0+runFloodgateDry+    :: Sem (Floodgate ': r) a+    -> Sem r a+runFloodgateDry m = runFloodgate $ m <* release+
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Fresh.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, TemplateHaskell, Trustworthy #-}+module Polysemy.Fresh+  (-- * Effect+    Fresh(..)++    -- * Actions+  , fresh++    -- * Interpretations+  , freshToIO++    -- * Unsafe Interpretations+  , runFreshEnumUnsafe+  , runFreshUnsafePerformIO+  ) where++import Data.Unique++import Polysemy.Internal+import Polysemy.Internal.Union+import System.IO.Unsafe (unsafePerformIO)+import Polysemy+import Polysemy.State++-----------------------------------------------------------------------------+-- | An effect for creating unique objects which may be used as references,+-- a la 'Unique'. Polymorphic code making use of 'Fresh' is expected+-- to place constraints upon @uniq@ as necessary.+--+-- Any interpreter for 'Fresh' has the responsibilty of ensuring+-- that any call to 'fresh' produces an object that /never/+-- compares equal to an object produced by a previous call to 'fresh'.+data Fresh uniq m a where+  Fresh :: Fresh uniq m uniq++makeSem ''Fresh++-----------------------------------------------------------------------------+-- | Runs a 'Fresh' effect through generating 'Unique's using 'IO'.+freshToIO :: Member (Embed IO) r+          => Sem (Fresh Unique ': r) a+          -> Sem r a+freshToIO = interpret $ \Fresh -> embed newUnique+{-# INLINE freshToIO #-}++-----------------------------------------------------------------------------+-- | Run a 'Fresh' effect purely by specifying an 'Enum' to be used as the+-- type of unique objects.+--+-- __Beware:__ This is safe only if:+--+--   1. This is run after all interpreters which may revert local state+--      or produce multiple, inconsistent instances of local state.+--      This includes interpreters that may backtrack or produce multiple results+--      (such as 'Polysemy.Error.runError' or 'Polysemy.NonDet.runNonDet').+--+--   2. You don't use any interpreter which may cause the final monad+--      to revert local state or produce multiple, inconsistent instances of local+--      state. This includes certain 'Polysemy.Final.Final'/@lower-@ interpeters+--      such as 'Polysemy.Error.lowerError' or 'Polysemy.Final.MTL.errorToFinal',+--      as well as interpreters for 'Polysemy.Async.Async'.+--+-- Prefer 'freshToIO' whenever possible.+-- If you can't use 'runFreshEnumUnsafe' safely, nor use 'freshToIO', consider+-- 'runFreshUnsafePerformIO'.+runFreshEnumUnsafe :: forall n a r+                    . Enum n+                   => Sem (Fresh n ': r) a+                   -> Sem r a+runFreshEnumUnsafe =+    (fmap snd .)+  $ (runState @n (toEnum 0) .)+  $ reinterpret+  $ \Fresh -> do+    s <- get+    put $! succ s+    return s+{-# INLINE runFreshEnumUnsafe #-}++-----------------------------------------------------------------------------+-- | Runs a 'Fresh' effect through generating 'Unique's using+-- 'unsafePerformIO'.+--+-- Ironically, despite the fact that this uses 'unsafePerformIO', and+-- 'runFreshUnsafe' uses no unsafe operations whatsoever, this is still+-- typically safer to use than 'runFreshUnsafe', although 'runFreshUnsafe'+-- is perhaps more efficient.+--+-- The worst thing that this particular use of 'unsafePerformIO' could result+-- in is the loss of referential transparency, as rerunning an interpreter stack+-- using 'runFreshUnsafePerformIO' will create different 'Unique's. This should+-- never matter.+--+-- This could be potentially be less efficient than 'runFreshUnsafe'.+--+-- If you ever observe that multiple invocations of 'fresh' produce the same+-- 'Unique' under 'runFreshUnsafePerformIO', then open an issue over at the+-- GitHub repository.+runFreshUnsafePerformIO :: Sem (Fresh Unique ': r) a+                        -> Sem r a+runFreshUnsafePerformIO = usingSem $ \u ->+  case decomp u of+    Right (Weaving Fresh s _ ex _) -> do+      let !uniq = unsafePerformIO (newUnique' u)+          {-# NOINLINE uniq #-}+      pure $ ex (uniq <$ s)+    Left g -> liftSem (hoist runFreshUnsafePerformIO g)+-- KingoftheHomeless: I've tried very hard to prevent optimizations from+-- sharing the call to 'unsafePerformIO'.+-- The inlining of 'interpret' is so that I can give+-- 'u' to 'newUnique'', and thus prevent 'uniq' from floating outside the+-- lambda. This interpreter might even be safe to INLINE, but I'm not taking+-- any chances.+{-# NOINLINE runFreshUnsafePerformIO #-}++newUnique' :: Union (Fresh Unique ': r) (Sem (Fresh Unique ': r)) a -> IO Unique+newUnique' (Union _ _) = newUnique+{-# NOINLINE newUnique' #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Input/Streaming.hs view
@@ -0,0 +1,86 @@+module Polysemy.Input.Streaming+  ( -- * Underlying Effect+    module Polysemy.Input++    -- * Actions+  , yieldInput+  , yieldRace+  , exhaust++    -- * Intepretations+  , runInputViaStream+  , runInputViaInfiniteStream+  ) where++import qualified Control.Concurrent.Async as A+import           Data.Functor.Of+import           Data.Void+import           Polysemy+import           Polysemy.Final+import           Polysemy.Input+import           Polysemy.State+import qualified Streaming as S+import qualified Streaming.Prelude as S++++runInputViaStream+    :: S.Stream (Of i) (Sem r) ()+    -> InterpreterFor (Input (Maybe i)) r+runInputViaStream stream+  = evalState (Just stream)+  . reinterpret ( \Input ->+      get >>= \case+        Nothing -> pure Nothing+        Just s ->+          raise (S.inspect s) >>= \case+            Left () -> pure Nothing+            Right (i :> s') -> do+              put $ Just s'+              pure $ Just i+  )+++runInputViaInfiniteStream+    :: forall i r+     . S.Stream (Of i) (Sem r) Void+    -> InterpreterFor (Input i) r+runInputViaInfiniteStream stream+  = evalState stream+  . reinterpret ( \Input -> do+      s <- get+      raise (S.inspect s) >>= \case+        Left g -> absurd g+        Right (i :> s') -> do+          put s'+          pure i+  )+++yieldRace+    :: Members+        '[ Final IO+         , Input i1+         , Input i2+         ] r+    => S.Stream (S.Of (Either i1 i2)) (Sem r) ()+yieldRace = do+  z <- S.lift $ withStrategicToFinal $ do+         input1 <- runS input+         input2 <- runS input+         pure $ fmap sequenceEither $ A.race input1 input2+  S.yield z+++sequenceEither :: Functor f => Either (f a) (f b) -> f (Either a b)+sequenceEither (Left fa) = Left <$> fa+sequenceEither (Right fb) = Right <$> fb+++yieldInput :: Member (Input i) r => S.Stream (Of i) (Sem r) ()+yieldInput = S.lift input >>= S.yield+++exhaust :: Member (Input i) r => S.Stream (Of i) (Sem r) a+exhaust = S.repeatM input+
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/KVStore.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-}++module Polysemy.KVStore+  ( -- * Effect+    KVStore (..)++    -- * Actions+  , lookupKV+  , lookupOrThrowKV+  , existsKV+  , writeKV+  , deleteKV+  , updateKV+  , modifyKV++    -- * Interpretations+  , runKVStoreAsState+  , runKVStorePurely+  ) where++import qualified Data.Map as M+import           Data.Maybe (isJust)+import           Polysemy+import           Polysemy.Error+import           Polysemy.State+++------------------------------------------------------------------------------+-- | Models things like Redis, HTTP GET/POST, etc. Things that are keyed, have+-- a value, and may or may not be there.+data KVStore k v m a where+  LookupKV :: k -> KVStore k v m (Maybe v)+  UpdateKV :: k -> Maybe v -> KVStore k v m ()++makeSem ''KVStore+++writeKV :: Member (KVStore k v) r => k -> v -> Sem r ()+writeKV k = updateKV k . Just+{-# INLINE writeKV #-}+++deleteKV :: forall k v r. Member (KVStore k v) r => k -> Sem r ()+deleteKV k = updateKV k (Nothing @v)+{-# INLINE deleteKV #-}+++------------------------------------------------------------------------------+-- |+--+-- @since 0.3.1.0+lookupOrThrowKV+    :: Members '[ KVStore k v+                , Error e+                ] r+    => (k -> e)+    -> k+    -> Sem r v+lookupOrThrowKV f k =+  fromEither . maybe (Left $ f k) Right =<< lookupKV k+++------------------------------------------------------------------------------+-- |+--+-- @since 0.3.1.0+existsKV :: forall k v r. Member (KVStore k v) r => k -> Sem r Bool+existsKV = fmap isJust . lookupKV @k @v+++------------------------------------------------------------------------------+-- |+--+-- @since 0.3.1.0+modifyKV+    :: Member (KVStore k v) r+    => v  -- ^ Default value if the key isn't present+    -> (v -> v)+    -> k+    -> Sem r ()+modifyKV d f k =+  lookupKV k >>= \case+    Just v  -> writeKV k $ f v+    Nothing -> writeKV k $ f d+++runKVStoreAsState :: Ord k => Sem (KVStore k v ': r) a -> Sem (State (M.Map k v) ': r) a+runKVStoreAsState = reinterpret $ \case+  LookupKV k   -> gets $ M.lookup k+  UpdateKV k v -> modify $ M.alter (const v) k+{-# INLINE runKVStoreAsState #-}+++runKVStorePurely+    :: Ord k+    => M.Map k v+    -> Sem (KVStore k v ': r) a+    -> Sem r (M.Map k v, a)+runKVStorePurely m = runState m . runKVStoreAsState+{-# INLINE runKVStorePurely #-}+
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Operators.hs view
@@ -0,0 +1,270 @@+-- | Operators meant as replacements for traditional 'Sem' type and 'Member' /+-- 'Members' constraints, that allow you to specify types of your actions and+-- interpreters in more concise way, without mentioning unnecessary details:+--+-- @+-- foo :: 'Member' ('Embed' 'IO') r => 'String' -> 'Int' -> 'Sem' r ()+-- @+--+-- can be written simply as:+--+-- @+-- foo :: 'String' -> 'Int' -> 'IO' '~@>' ()+-- @+--+-- Working example with operators:+--+-- @+-- import Data.Function+-- import Polysemy+-- import Polysemy.Operators+-- import Polysemy.Random+--+-- data ConsoleIO m a where+--   WriteStrLn ::           'String' -> ConsoleIO m ()+--   ReadStrLn  ::                     ConsoleIO m 'String'+--   ShowStrLn  :: 'Show' a => a      -> ConsoleIO m ()+--+-- 'makeSem' ''ConsoleIO+--+-- -- runConsoleIO :: Member (Embed IO) r => Sem (ConsoleIO : r) a -> Sem r a+-- runConsoleIO :: ConsoleIO : r '@>' a -> 'IO' '~@' r '@>' a+-- runConsoleIO = 'interpret' \\case+--   WriteStrLn s -> 'sendM' '$' 'putStrLn' s+--   ReadStrLn    -> 'sendM'   'getLine'+--   ShowStrLn  v -> 'sendM' '$' 'print' v+--+-- main :: 'IO' ()+-- main = program+--      'Data.Function.&' runConsoleIO+--      'Data.Function.&' 'Polysemy.Random.runRandomIO'+--      'Data.Function.&' 'runM'+--+-- -- program :: Members \'[Random, ConsoleIO] r => Sem r ()+-- program :: \'['Polysemy.Random', ConsoleIO] '>@>' ()+-- program = do+--   writeStrLn "It works! Write something:"+--   val <- readStrLn+--   writeStrLn '$' "Here it is!: " '++' val+--   num <- 'Polysemy.Random.random' \@'Int'+--   writeStrLn '$' "Some random number:"+--   showStrLn num+-- @+--+-- Please keep in mind that constraints created through these operators are+-- limited to the action they are being used on, for example:+--+-- @+-- foo :: (forall x. r '@>' x -> 'IO' x)+--     -> 'IO' (forall a. Foo : r '@>' a -> 'IO' '~@' r '@>' a)+-- @+--+-- The first argument in the signature above won't have access to the+-- @('IO' ~\@)@ constraint in the result - in such cases, use a normal+-- constraint instead:+--+-- @+-- foo :: 'Member' ('Embed' 'IO') r+--     => (forall x. r '@>' x -> 'IO' x)+--     -> 'IO' (forall a. Foo : r '@>' a -> r '@>' a)+-- @+--+-- See the documentation of specific operators for more details.++module Polysemy.Operators+  ( -- * 'Sem' operators+    type (@>)+  , type (@-)+  , type (@~)+    -- $SemOperators++  , -- * 'Member' operators+    type (>@)+  , type (-@)+  , type (~@)+    -- $MemberOperators++  , -- * Combined operators+    type (>@>)+  , type (-@>)+  , type (~@>)+    -- $CombinedOperators+  ) where++import Polysemy++-- Miscellaneous -------------------------------------------------------------+-- | Gets list of effects from 'Sem'.+type family SemList s where+  SemList (Sem r _) = r++-- Operators -----------------------------------------------------------------++-- $SemOperators+-- Infix equivalents of 'Sem' with versions for specifiying list of effects+-- ('@>'), single effect ('@-') and single monad ('@~') as effects of union.+-- Use ('>@>'), ('-@>') or ('~@>') instead if you are not making any+-- transformations on union and just want to use some members instead.+--+-- __Examples:__+--+-- 'Sem' with list of multiple effects:+--+-- @+-- foo :: 'Sem' ('Polysemy.State.State' 'Int' : r) ()+-- @+--+-- can be written as:+--+-- @+-- foo :: 'Polysemy.State.State' 'Int' : r '@>' ()+-- @+--+-- 'Sem' with list of one effect:+--+-- @+-- foo :: 'Sem' \'['Polysemy.State.State' 'Int'] ()+-- @+--+-- can be written as both (with the latter preferred):+--+-- @+-- foo :: \'['Polysemy.State.State' 'Int'] '@>' ()+-- @+--+-- and:+--+-- @+-- foo :: 'Polysemy.State.State' 'Int' '@-' ()+-- @+--+-- where effect without list gets put into one automatically.+--+-- 'Sem' with __exactly__ one, lifted monad:+--+-- @+-- foo :: 'Sem' \'['Embed' 'IO'] ()+-- @+--+-- can be written simply as:+--+-- @+-- foo :: 'IO' '@~' ()+-- @+--+-- and will be automatically lifted and put into list.+infix 2 @>, @-, @~++type (@>)   = Sem+type (@-) e = Sem '[e]+type (@~) m = Sem '[Embed m]++-- $MemberOperators+-- Infix equivalents of 'Member'(s) constraint used directly in /return/ type,+-- specifiying list of members ('>@'), single member ('-@') or single monad+-- ('~@'), meant to be paired with some of the 'Sem' operators (('@>'), ('@-')+-- and ('@~')). Use ('>@>'), ('-@>') or ('~@>') instead if you are not making+-- any transformations on union and just want to use some members instead.+--+-- __Examples:__+--+-- List of multiple members:+--+-- @+-- foo :: 'Members' \'['Polysemy.State.State' 'Int', 'Polysemy.Input.Input' 'String'] r => 'Sem' ('Polysemy.Output.Output' ['String'] : r) () -> 'Sem' r ()+-- @+--+-- can be written as:+--+-- @+-- foo :: 'Polysemy.Output.Output' ['String'] : r '@>' () -> \'['Polysemy.State.State' 'Int', 'Polysemy.Input.Input' 'String'] '>@' r '@>' ()+-- @+--+-- One member:+--+-- @+-- foo :: 'Member' ('Polysemy.State.State' 'Int') r => 'Sem' ('Polysemy.Output.Output' ['String'] : r) () -> 'Sem' r ()+-- @+--+-- can be written as both (with the latter preferred):+--+-- @+-- foo :: 'Polysemy.Output.Output' ['String'] : r '@>' () -> \'['Polysemy.State.State' 'Int'] '>@' r '@>' ()+-- @+--+-- and:+--+-- @+-- foo :: 'Polysemy.Output.Output' ['String'] : r '@>' () -> 'Polysemy.State.State' 'Int' '-@' r '@>' ()+-- @+--+-- __Exactly__ one, lifted monad as a member:+--+-- @+-- foo :: 'Member' ('Embed' 'IO') r => 'Sem' ('Polysemy.Output.Output' ['String'] : r) () -> 'Sem' r ()+-- @+--+-- can be written simply as:+--+-- @+-- foo :: 'Polysemy.Output.Output' ['String'] : r '@>' () -> 'IO' '~@' r '@>' ()+-- @+infix 1 >@, -@, ~@++type (>@) es s = Members es       (SemList s) => s+type (-@) e  s = Member  e        (SemList s) => s+type (~@) m  s = Member  (Embed m) (SemList s) => s++-- $CombinedOperators+-- Joined versions of one of ('>@'), ('-@'), ('~@') and ('@>') with implicit,+-- hidden list of effects in union --- suited for actions that only use one+-- 'Sem' in their type.+--+-- __Examples:__+--+-- List of members over some 'Sem':+--+-- @+-- foo :: 'Members' \'['Polysemy.State.State' 'String', 'Polysemy.Input.Input' 'Int'] r => 'String' -> 'Int' -> 'Sem' r ()+-- @+--+-- can be written as:+--+-- @+-- foo :: 'String' -> 'Int' -> \'['Polysemy.State.State' 'String', 'Polysemy.Input.Input' 'Int'] '>@>' ()+-- @+--+-- Single member:+--+-- @+-- foo :: 'Member' ('Polysemy.Input.Input' 'Int') r => 'String' -> 'Int' -> 'Sem' r ()+-- @+--+-- can be written as both (with the latter preferred):+--+-- @+-- foo :: 'String' -> 'Int' -> \'['Polysemy.Input.Input' 'Int'] '>@>' ()+-- @+--+-- and:+--+-- @+-- foo :: 'String' -> 'Int' -> 'Polysemy.Input.Input' 'Int' '-@>' ()+-- @+--+-- __Exactly__ one, lifted monad as a member:+--+-- @+-- foo :: 'Member' ('Embed' 'IO') r => 'Sem' r ()+-- @+--+-- can be written simply as:+--+-- @+-- foo :: 'IO' '~@>' ()+-- @+infix 1 >@>, -@>, ~@>++type (>@>) es a = forall r. Members es       r => Sem r a+type (-@>) e  a = forall r. Member  e        r => Sem r a+type (~@>) m  a = forall r. Member  (Embed m) r => Sem r a
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Random.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Random+  ( -- * Effect+    Random (..)++    -- * Actions+  , random+  , randomR++    -- * Interpretations+  , runRandom+  , runRandomIO+  ) where++import           Polysemy+import           Polysemy.State+import qualified System.Random as R++------------------------------------------------------------------------------+-- | An effect capable of providing 'R.Random' values.+data Random m a where+  Random :: R.Random x => Random m x+  RandomR :: R.Random x => (x, x) -> Random m x++makeSem ''Random+++------------------------------------------------------------------------------+-- | Run a 'Random' effect with an explicit 'R.RandomGen'.+runRandom+    :: forall q r a+     . R.RandomGen q+    => q+    -> Sem (Random ': r) a+    -> Sem r (q, a)+runRandom q = runState q . reinterpret (\case+  Random -> do+    ~(a, q') <- gets @q R.random+    put q'+    pure a+  RandomR r -> do+    ~(a, q') <- gets @q $ R.randomR r+    put q'+    pure a+                                       )+{-# INLINE runRandom #-}+++------------------------------------------------------------------------------+-- | Run a 'Random' effect by using the 'IO' random generator.+runRandomIO :: Member (Embed IO) r => Sem (Random ': r) a -> Sem r a+runRandomIO m = do+  q <- embed @IO R.newStdGen+  snd <$> runRandom q m+{-# INLINE runRandomIO #-}+
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Reader/Compact.hs view
@@ -0,0 +1,37 @@+module Polysemy.Reader.Compact where++import           Polysemy+import           Polysemy.Reader++import           GHC.Compact++-----------------------------------------------------------------------------+-- | Run a 'Reader' effect by compacting a value; otherwise behaves as normal.+-- Useful for 'Reader' effects which provide a large structure.+runReaderWithCompacted+    :: forall r i a+     . Member (Embed IO) r+    => i+    -> Sem (Reader i ': r) a+    -> Sem r a+runReaderWithCompacted i sem = do+    compacted <- embed (compactWithSharing i)+    runReaderWithExistingCompacted compacted sem+{-# INLINE runReaderWithCompacted #-}++-----------------------------------------------------------------------------+-- | Run a 'Reader' effect with a value in a compact region. Will not add +-- 'local' values to the existing region, but will create a new region for it.+runReaderWithExistingCompacted+    :: forall r i a+     . Member (Embed IO) r+    => Compact i+    -> Sem (Reader i ': r) a+    -> Sem r a+runReaderWithExistingCompacted i = interpretH $ \case+    Ask       -> pureT (getCompact i)+    Local f m -> do+        mm <- runT m+        let transformed = f (getCompact i)+        raise $ runReaderWithCompacted transformed mm+{-# INLINE runReaderWithExistingCompacted #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Reader/More.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE RecursiveDo #-}+module Polysemy.Reader.More+  (+    module Polysemy.Reader+    -- * Interpretations+  , runReaderFixSem+  ) where++import Polysemy+import Polysemy.Reader+import Polysemy.Fixpoint++------------------------------------------------------------------------------+-- | Runs a 'Reader' effect by running a monadic action /once/, after the+-- 'Sem' has completed, and then providing the result to each request+-- recursively.+runReaderFixSem :: forall i r a+                 . Member Fixpoint r+                => Sem r i+                -> Sem (Reader i ': r) a+                -> Sem r a+runReaderFixSem m sem = do+  rec+    a <- runReader i sem+    i <- m+  return a+{-# INLINE runReaderFixSem #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/RevState.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE RecursiveDo, TemplateHaskell #-}+module Polysemy.RevState+ ( -- * Effect+   RevState (..)++   -- * Actions+ , revState+ , revGet+ , revPut+ , revModify++   -- * Interpretations+ , runRevState+ , runLazyRevState+ ) where++import Control.Monad.Fix++import Polysemy+import Polysemy.Fixpoint+import Polysemy.Internal+import Polysemy.Internal.Union++------------------------------------------------------------------------------+-- | A 'Polysemy.State.State' effect for threading state /backwards/ instead+-- of forwards through a computation.+newtype RevState s m a where+  RevState :: (s -> (s, a)) -> RevState s m a++makeSem_ ''RevState+++------------------------------------------------------------------------------+-- | Gets the state as sent from the next call to 'revState'+-- \/ 'revPut' \/ 'revModify', use it, and send a new state into the past.+revState :: forall s a r+          . Member (RevState s) r+         => (s -> (s, a))+         -> Sem r a++------------------------------------------------------------------------------+-- | Gets the state as sent from the next call to 'revState' \/ 'revPut'+-- \/ 'revModify'.+revGet :: forall s r+        . Member (RevState s) r+       => Sem r s+revGet = revState $ \s -> (s, s)++------------------------------------------------------------------------------+-- | Sends a new state into the past.+revPut :: forall s r+        . Member (RevState s) r+       => s+       -> Sem r ()+revPut s = revState $ \_ -> (s, ())++------------------------------------------------------------------------------+-- | Gets the state as sent from the next call to 'revState'+-- \/ 'revModify' \/ 'revPut', modify it, and return it into the past.+revModify :: forall s r+           . Member (RevState s) r+          => (s -> s)+          -> Sem r ()+revModify f = revState $ \s -> (f s, ())+++------------------------------------------------------------------------------+-- | Run a 'RevState' effect with local state that is propagated /backwards/+-- through the computation, from last action to first.+runRevState :: Member Fixpoint r+            => s+            -> Sem (RevState s ': r) a+            -> Sem r (s, a)+runRevState s =+   (`runRevStateT` s)+  . runRevStateInC++------------------------------------------------------------------------------+-- | Run a 'RevState' effect with local state that is lazily propagated+-- /backwards/ through the computation, from last action to first.+runLazyRevState :: Member Fixpoint r+                => s+                -> Sem (RevState s ': r) a+                -> Sem r (s, a)+runLazyRevState s =+   (`runLazyRevStateT` s)+  . runLazyRevStateInC++newtype RevStateT s m a = RevStateT { runRevStateT :: s -> m (s, a) }+  deriving (Functor)++instance MonadFix m => Applicative (RevStateT s m) where+  pure a = RevStateT $ \s -> pure (s, a)+  ff <*> fa = RevStateT $ \s -> do+    rec+      (s'', f) <- runRevStateT ff s'+      (s',  a) <- runRevStateT fa s+    return (s'', f a)+  fa *> fb = fa >>= \_ -> fb++instance MonadFix m => Monad (RevStateT s m) where+  m >>= f = RevStateT $ \s -> do+    rec+      (s'', a) <- runRevStateT m s'+      (s',  b) <- runRevStateT (f a) s+    return (s'', b)++newtype LazyRevStateT s m a = LazyRevStateT { runLazyRevStateT :: s -> m (s, a) }+  deriving (Functor)++instance MonadFix m => Applicative (LazyRevStateT s m) where+  pure a = LazyRevStateT $ \s -> pure (s, a)+  ff <*> fa = LazyRevStateT $ \s -> do+    rec+      ~(s'', f) <- runLazyRevStateT ff s'+      ~(s',  a) <- runLazyRevStateT fa s+    return (s'', f a)+  fa *> fb = fa >>= \_ -> fb++instance MonadFix m => Monad (LazyRevStateT s m) where+  m >>= f = LazyRevStateT $ \s -> do+    rec+      ~(s'', a) <- runLazyRevStateT m s'+      ~(s',  b) <- runLazyRevStateT (f a) s+    return (s'', b)++runRevStateInC :: Member Fixpoint r+               => Sem (RevState s ': r) a+               -> RevStateT s (Sem r) a+runRevStateInC = usingSem $ \u -> RevStateT $ \s ->+  case decomp u of+    Right (Weaving (RevState f) st _ ex _) ->+      return $ (ex . (<$ st)) <$> f s+    Left g ->+      liftSem $+        weave+          (s, ())+          (uncurry runRevState)+          (Just . snd)+          g++runLazyRevStateInC :: Member Fixpoint r+                   => Sem (RevState s ': r) a+                   -> LazyRevStateT s (Sem r) a+runLazyRevStateInC = usingSem $ \u -> LazyRevStateT $ \s ->+  case decomp u of+    Right (Weaving (RevState f) st _ ex _) ->+      return $ (ex . (<$ st)) <$> f s+    Left g ->+      liftSem $+        weave+          (s, ())+          (uncurry runLazyRevState)+          (Just . snd)+          g
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/SetStore.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.SetStore where++import           Data.Foldable+import qualified Data.Set as S+import           Polysemy+import           Polysemy.KVStore++++data SetStore k v m a where+  AddS :: k -> v -> SetStore k v m ()+  DelS :: k -> v -> SetStore k v m ()+  MemberS :: k -> v -> SetStore k v m Bool++makeSem ''SetStore+++runSetStoreAsKVStore+    :: ( Member (KVStore k (S.Set v)) r+       , Ord v+       )+    => Sem (SetStore k v ': r) x -> Sem r x+runSetStoreAsKVStore = interpret $ \case+  AddS k v ->+    lookupKV k >>= \case+      Just s  -> writeKV k $ S.insert v s+      Nothing -> writeKV k $ S.singleton v+  DelS k v -> do+    ms <- lookupKV k+    for_ ms $ writeKV k . S.delete v+  MemberS k v ->+    pure . maybe False (S.member v) =<< lookupKV k+{-# INLINE runSetStoreAsKVStore #-}+
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Several.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Several+  ( -- * Data+    HList(..)+  , TypeMap+  , TypeConcat+  , runSeveral+  ) where++import Polysemy+import Data.Kind++------------------------------------------------------------------------------+-- | A list capable of storing values of different types. Like the Sem type,+-- it uses a type level list to keep track of what's stored inside. Creating an+-- HList looks like:+--+-- > 1 ::: "test" ::: True ::: HNil+infixr 5 :::+data HList a where+    HNil  :: HList '[]+    (:::) :: a -> HList (b :: [Type]) -> HList (a ': b)++------------------------------------------------------------------------------+-- | A map function over type level lists. For example, the following two+-- lines are equivalent:+--+-- > TypeMap Reader [Int, String, False]+-- > [Reader Int, Reader String, Reader Bool]+type family TypeMap (f :: a -> b) (xs :: [a]) where+    TypeMap _ '[]       = '[]+    TypeMap f (x ': xs) = f x ': TypeMap f xs++------------------------------------------------------------------------------+-- | Like ++ but at the type level. The following two lines are equivalent:+--+-- > TypeConcat [Int, String] [Bool]+-- > [Int, String, Bool]+type family TypeConcat (a :: [t]) (b :: [t]) where+    TypeConcat '[] b = b+    TypeConcat (a ': as) b = a ': TypeConcat as b++------------------------------------------------------------------------------+-- | A helper function for building new runners which accept HLists intsead of+-- individual elements. If you would normally write+--+-- > f 5 . f "Text" . f True+--+-- then this function can turn that into+--+-- > runSeveral f (True ::: "Text" ::: 5 ::: HNil)+--+-- For example, a runReaders function could be implemented as:+--+-- > runReaders :: HList t -> Sem (TypeConcat (TypeMap Reader t) r) a -> Sem r a+-- > runReaders = runSeveral runReader+--+-- Likewise, runStates could be the following if you didn't want the returned+-- state:+--+-- > runStates :: HList t -> Sem (TypeConcat (TypeMap State t) r) a -> Sem r a+-- > runStates = runSeveral (fmap (fmap snd) . runState)+runSeveral+    :: (forall r' k x. k -> Sem (e k ': r') x -> Sem r' x)+    -> HList t+    -> Sem (TypeConcat (TypeMap e t) r) a+    -> Sem r a+runSeveral f (a ::: as) = runSeveral f as . f a+runSeveral _ HNil       = id+
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Shift.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE AllowAmbiguousTypes, Trustworthy #-}+module Polysemy.Shift+  (+    module Polysemy.Cont+    -- * Effect+  , Shift(..)++    -- * Actions+  , trap+  , invoke+  , abort+  , reset+  , reset'+  , shift++    -- * Interpretations+  , runShiftPure+  , runShiftM+  , shiftToFinal+  , runShiftWithCPure+  , runShiftWithCM++  , runContShiftPure+  , runContShiftM+  , runContShiftWithCPure+  , runContShiftWithCM++    -- * Unsafe Interpretations+  , runShiftUnsafe+  , runShiftWithCUnsafe+  , runContShiftUnsafe+  , runContShiftWithCUnsafe+  ) where+++import Polysemy+import Polysemy.Cont+import Polysemy.Cont.Internal+import Polysemy.Shift.Internal+import Polysemy.Final+import Control.Monad.Cont (ContT(..))++import Polysemy.Internal+import Polysemy.Internal.Union+++-----------------------------------------------------------------------------+-- | A variant of 'callCC'.+-- Executing the provided continuation will not abort execution.+--+-- Any effectful state of effects which have been run before the interpreter for+-- 'Shift' will be embedded in the return value of the continuation,+-- and therefore the continuation won't have any apparent effects unless these+-- effects are interpreted in the final monad.+--+-- Any higher-order actions will also not interact with the continuation in any+-- meaningful way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does+-- not affect it, 'Polysemy.Error.catch' will fail to catch any of its exceptions,+-- and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- The provided continuation may fail locally in its subcontinuations.+-- It may sometimes become necessary to handle such cases, in+-- which case such failure may be detected by using 'reset\'' together+-- with the provided continuation.+shift :: forall ref s r a+       . Member (Shift ref s) r+      => ((a -> Sem r s) -> Sem r s)+      -> Sem r a+shift cc = trap @ref $ \ref -> cc (invoke ref)+{-# INLINE shift #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by providing @'pure' '.' 'Just'@ as the final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runShiftUnsafe', as this may only be used+-- as the final interpreter before 'run'.+runShiftPure :: Sem '[Shift (Ref (Sem '[]) (Maybe a)) a] a+             -> Sem '[] (Maybe a)+runShiftPure = runShiftUnsafe+{-# INLINE runShiftPure #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by providing @'pure' '.' 'Just'@ as the final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runShiftUnsafe', as this may only be used+-- as the final interpreter before 'runM'.+runShiftM :: Sem '[Shift (Ref (Sem '[Embed m]) (Maybe a)) a, Embed m] a+          -> Sem '[Embed m] (Maybe a)+runShiftM = runShiftUnsafe+{-# INLINE runShiftM #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect in terms of a final 'ContT'+--+-- /Beware/: Effects that aren't interpreted in terms of the final monad+-- will have local state semantics in regards to 'Shift' effects+-- interpreted this way. See 'Final'.+shiftToFinal :: forall s m a r+              .  (Member (Final (ContT (Maybe s) m)) r, Monad m)+              => Sem (Shift (Ref m (Maybe s)) s ': r) a+              -> Sem r a+shiftToFinal = interpretFinal $ \case+  Trap main -> do+    main'         <- bindS main+    s             <- getInitialStateS+    Inspector ins <- getInspectorS+    pure $ ContT $ \c ->+      runContT (main' (Ref (c . (<$ s)) <$ s)) (pure . ins)+  Invoke ref a -> liftS $ ContT $ \c -> runRef ref a >>= maybe (pure Nothing) c+  Abort s -> pure $ ContT $ \_ -> pure (Just s)+  Reset main -> do+    main'         <- runS main+    Inspector ins <- getInspectorS+    liftS $ ContT $ \c ->+      runContT main' (pure . ins) >>= maybe (pure Nothing) c+  Reset' main -> do+    main'         <- runS main+    Inspector ins <- getInspectorS+    liftS $ ContT $ \c ->+      runContT main' (pure . ins) >>= c+{-# INLINE shiftToFinal #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by explicitly providing a final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runShiftWithCUnsafe', as this may only be used+-- as the final interpreter before 'run'.+runShiftWithCPure :: (a -> Sem '[] (Maybe b))+                  -> Sem '[Shift (Ref (Sem '[]) (Maybe b)) b] a+                  -> Sem '[] (Maybe b)+runShiftWithCPure = runShiftWithCUnsafe+{-# INLINE runShiftWithCPure #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by explicitly providing a final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runShiftWithCUnsafe', as this may only be used+-- as the final interpreter before 'runM'.+runShiftWithCM :: (a -> Sem '[Embed m] (Maybe b))+               -> Sem '[Shift (Ref (Sem '[Embed m]) (Maybe b)) b, Embed m] a+               -> Sem '[Embed m] (Maybe b)+runShiftWithCM = runShiftWithCUnsafe+{-# INLINE runShiftWithCM #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by providing+-- @'pure' '.' 'Just'@ as the final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runContShiftUnsafe', as this may only be used+-- as the final interpreter before 'run'.+runContShiftPure :: Sem [ Cont (Ref (Sem '[]) (Maybe a))+                        , Shift (Ref (Sem '[]) (Maybe a)) a+                        ] a+                 -> Sem '[] (Maybe a)+runContShiftPure = runContShiftUnsafe+{-# INLINE runContShiftPure #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by providing+-- @'pure' '.' 'Just'@ as the final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runContShiftUnsafe', as this may only be used+-- as the final interpreter before 'runM'.+runContShiftM :: Sem [ Cont (Ref (Sem '[Embed m]) (Maybe a))+                     , Shift (Ref (Sem '[Embed m]) (Maybe a)) a+                     , Embed m+                     ] a+              -> Sem '[Embed m] (Maybe a)+runContShiftM = runContShiftUnsafe+{-# INLINE runContShiftM #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by explicitly providing+-- a final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runContShiftWithCUnsafe', as this may only be+-- used as the final interpreter before 'run'.+runContShiftWithCPure :: (a -> Sem '[] (Maybe s))+                      -> Sem [ Cont (Ref (Sem '[]) (Maybe s))+                             , Shift (Ref (Sem '[]) (Maybe s)) s+                             ] a+                      -> Sem '[] (Maybe s)+runContShiftWithCPure = runContShiftWithCUnsafe+{-# INLINE runContShiftWithCPure #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by explicitly providing+-- a final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runContShiftWithCUnsafe', as this may only be used+-- as the final interpreter before 'runM'.+runContShiftWithCM :: (a -> Sem '[Embed m] (Maybe s))+                   -> Sem [ Cont (Ref (Sem '[Embed m]) (Maybe s))+                          , Shift (Ref (Sem '[Embed m]) (Maybe s)) s+                          , Embed m+                          ] a+                   -> Sem '[Embed m] (Maybe s)+runContShiftWithCM = runContShiftWithCUnsafe+{-# INLINE runContShiftWithCM #-}+++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by providing @'pure' '.' 'Just'@+-- as the final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runShiftUnsafe' /after/ running all__+-- __interpreters for your higher-order effects.__+runShiftUnsafe :: Sem (Shift (Ref (Sem r) (Maybe a)) a ': r) a -> Sem r (Maybe a)+runShiftUnsafe = runShiftWithCUnsafe (pure . Just)+{-# INLINE runShiftUnsafe #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by explicitly providing a final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that any+-- continuation may fail locally.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runShiftWithCUnsafe' /after/ running all__+-- __interpreters for your higher-order effects.__+runShiftWithCUnsafe :: forall s a r.+                       (a -> Sem r (Maybe s))+                    -> Sem (Shift (Ref (Sem r) (Maybe s)) s ': r) a+                    -> Sem r (Maybe s)+runShiftWithCUnsafe c (Sem sem) = (`runContT` c) $ sem $ \u -> case decomp u of+  Right weaving -> runShiftWeaving runShiftWithCUnsafe weaving+  Left g -> ContT $ \c' -> embedSem g >>= runShiftWithCUnsafe c'+{-# INLINE runShiftWithCUnsafe #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by providing+-- @'pure' '.' 'Just'@ as the final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runContShiftUnsafe' /after/ running all__+-- __interpreters for your higher-order effects.__+runContShiftUnsafe :: Sem (   Cont (Ref (Sem r) (Maybe a))+                           ': Shift (Ref (Sem r) (Maybe a)) a+                           ': r) a+                   -> Sem r (Maybe a)+runContShiftUnsafe = runContShiftWithCUnsafe (pure . Just)+{-# INLINE runContShiftUnsafe #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by explicitly providing+-- a final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runContShiftWithCUnsafe' /after/ running all__+-- __interpreters for your higher-order effects.__+runContShiftWithCUnsafe :: forall s a r.+                           (a -> Sem r (Maybe s))+                        -> Sem (   Cont (Ref (Sem r) (Maybe s))+                                ': Shift (Ref (Sem r) (Maybe s)) s+                                ': r) a+                        -> Sem r (Maybe s)+runContShiftWithCUnsafe c (Sem m) = (`runContT` c) $ m $ \u -> case decomp u of+  Right weaving -> runContWeaving runContShiftWithCUnsafe weaving+  Left g -> case decomp g of+    Right weaving -> runShiftWeaving runContShiftWithCUnsafe weaving+    Left g'       -> ContT $ \c' -> embedSem g' >>= runContShiftWithCUnsafe c'+{-# INLINE runContShiftWithCUnsafe #-}
+ vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Shift/Internal.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-}+module Polysemy.Shift.Internal where++import Polysemy+import Polysemy.Internal.Union+import Polysemy.Cont.Internal (Ref(..))+import Control.Monad.Cont (ContT(..))++-----------------------------------------------------------------------------+-- | An effect for delimited continuations, formulated algebraically+-- through a variant of the 'Polysemy.Cont.Jump/'Polysemy.Cont.Subst'+-- formulation of abortive continuations.+--+-- Activating polysemy-plugin is highly recommended when using this effect+-- in order to avoid ambiguous types.+data Shift ref s m a where+  Trap    :: (ref a -> m s) -> Shift ref s m a+  Invoke  :: ref a -> a -> Shift ref s m s+  Abort   :: s   -> Shift ref s m a+  Reset   :: m s -> Shift ref s m s+  Reset'  :: m s -> Shift ref s m (Maybe s)++makeSem_ ''Shift++-----------------------------------------------------------------------------+-- | Reifies the current continuation in the form of a prompt, and passes it to+-- the first argument. Unlike 'subst', control will never return to the current+-- continuation unless the prompt is invoked via 'release'.+trap :: forall ref s a r+     .  Member (Shift ref s) r+     => (ref a -> Sem r s)+     -> Sem r a++-----------------------------------------------------------------------------+-- | Provide an answer to a prompt, jumping to its reified continuation.+-- Unlike 'jump', this will not abort the current continuation, and the+-- reified computation will instead return its final result when finished.+--+-- Any effectful state of effects which have been run before the interpreter for+-- 'Shift' will be embedded in the return value, and therefore the invocation+-- won't have any apparent effects unless these are interpreted in the final+-- monad.+--+-- Any higher-order actions will also not interact with the continuation in any+-- meaningful way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does+-- not affect it, 'Polysemy.Error.catch' will fail to catch any of its exceptions,+-- and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- The provided continuation may fail locally in its subcontinuations.+-- It may sometimes become necessary to handle such cases. To do so,+-- use 'reset\'' together with 'release'.+invoke :: forall ref s a r+       .  Member (Shift ref s) r+       => ref a+       -> a+       -> Sem r s+++-----------------------------------------------------------------------------+-- | Aborts the current continuation with a result.+abort :: forall ref s a r+      .  Member (Shift ref s) r+      => s+      -> Sem r a++-----------------------------------------------------------------------------+-- | Delimits any continuations and calls to 'abort'.+reset :: forall ref s r+      .  Member (Shift ref s) r+      => Sem r s+      -> Sem r s++-----------------------------------------------------------------------------+-- | Delimits any continuations and calls to 'abort', and detects if+-- any subcontinuation has failed locally.+reset' :: forall ref s r+       .  Member (Shift ref s) r+       => Sem r s+       -> Sem r (Maybe s)++runShiftWeaving :: Monad m+                => (forall x. (x -> m (Maybe s)) -> Sem r x -> m (Maybe s))+                -> Weaving (Shift (Ref m (Maybe s)) s) (Sem r) a+                -> ContT (Maybe s) m a+runShiftWeaving runW (Weaving e s wv ex ins) =+  fmap (ex . (<$ s)) $ ContT $ \c ->+    case e of+      Trap main ->+        runW (pure . ins) $ wv (main (Ref c) <$ s)+      Invoke ref a ->+        runRef ref a >>= maybe (pure Nothing) c+      Abort t -> pure (Just t)+      Reset main ->+        runW (pure . ins) (wv (main <$ s)) >>= maybe (pure Nothing) c+      Reset' main ->+        runW (pure . ins) (wv (main <$ s)) >>= c+{-# INLINE runShiftWeaving #-}