diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/hs-hath.cabal b/hs-hath.cabal --- a/hs-hath.cabal +++ b/hs-hath.cabal @@ -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 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.* diff --git a/src/Server.hs b/src/Server.hs --- a/src/Server.hs +++ b/src/Server.hs @@ -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 diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Capture.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Capture.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Capture.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber.hs @@ -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 #-} + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadCatch.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadCatch.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadCatch.hs @@ -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 #-} + + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadCont.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadCont.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadCont.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadError.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadError.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadError.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadReader.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadReader.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadReader.hs @@ -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 #-} + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadState.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadState.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadState.hs @@ -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 #-} + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadWriter.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadWriter.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/ConstraintAbsorber/MonadWriter.hs @@ -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 #-} + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Cont.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Cont.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Cont.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Cont/Internal.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Cont/Internal.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Cont/Internal.hs @@ -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). +-- +-- 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 diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/EndState.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/EndState.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/EndState.hs @@ -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) diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/IO.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/IO.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/IO.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/IO/Internal.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/IO/Internal.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/IO/Internal.hs @@ -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." diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/MTL.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/MTL.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/MTL.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/More.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/More.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/More.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/NonDet.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/NonDet.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Final/NonDet.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Floodgate.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Floodgate.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Floodgate.hs @@ -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 + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Fresh.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Fresh.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Fresh.hs @@ -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' #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Input/Streaming.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Input/Streaming.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Input/Streaming.hs @@ -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 + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/KVStore.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/KVStore.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/KVStore.hs @@ -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 #-} + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Operators.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Operators.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Operators.hs @@ -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 diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Random.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Random.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Random.hs @@ -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 #-} + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Reader/Compact.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Reader/Compact.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Reader/Compact.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Reader/More.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Reader/More.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Reader/More.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/RevState.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/RevState.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/RevState.hs @@ -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 diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/SetStore.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/SetStore.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/SetStore.hs @@ -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 #-} + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Several.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Several.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Several.hs @@ -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 + diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Shift.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Shift.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Shift.hs @@ -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 #-} diff --git a/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Shift/Internal.hs b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Shift/Internal.hs new file mode 100644 --- /dev/null +++ b/vendor/polysemy-zoo-0.8.2.0/src/Polysemy/Shift/Internal.hs @@ -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 #-}