diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for too-fast-too-free + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Sandy Maguire (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Sandy Maguire nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,158 @@ +# polysemy + +[![Build Status](https://api.travis-ci.org/isovector/polysemy.svg?branch=master)](https://travis-ci.org/isovector/polysemy) +[![Hackage](https://img.shields.io/hackage/v/polysemy.svg?logo=haskell)](https://hackage.haskell.org/package/polysemy) + +## Dedication + +> The word 'good' has many meanings. For example, if a man were to shoot his +> grandmother at a range of five hundred yards, I should call him a good shot, +> but not necessarily a good man. +> +> Gilbert K. Chesterton + + +## Overview + +`polysemy` is a library for writing high-power, low-boilerplate, zero-cost, +domain specific languages. It allows you to separate your business logic from +your implementation details. And in doing so, `polysemy` lets you turn your +implementation code into reusable library code. + +It's like `mtl` but composes better, requires less boilerplate, and avoids the +O(n^2) instances problem. + +It's like `freer-simple` but more powerful and 700x faster. + +It's like `fused-effects` but with an order of magnitude less boilerplate. + + +## Features + +* *Effects are higher-order,* meaning it's trivial to write `bracket` and `local` + as first-class effects. +* *Effects are low-boilerplate,* meaning you can create new effects in a + single-digit number of lines. New interpreters are nothing but functions and + pattern matching. +* *Effects are zero-cost,* meaning that GHC[1](#fn1) can optimize + away the entire abstraction at compile time. + + +1: Unfortunately this is not true in GHC 8.6.3, but +will be true as soon as [my patch](https://gitlab.haskell.org/ghc/ghc/merge_requests/668/) lands. + + +## Examples + +Console effect: + +```haskell +{-# LANGAUGE TemplateHaskell #-} + +import Polysemy + +data Console m a where + GetLine :: Console m String + PutLine :: String -> Console m () + +makeSemantic ''Console + +runConsoleIO :: Member (Lift IO) r => Semantic (Console ': r) a -> Semantic r a +runConsoleIO = interpret $ \case + GetLine -> sendM getLine + PutLine msg -> sendM $ putStrLn msg +``` + + +Resource effect: + +```haskell +{-# LANGUAGE TemplateHaskell #-} + +import qualified Control.Exception as X +import Polysemy + +data Resource m a where + Bracket :: m a -> (a -> m ()) -> (a -> m b) -> Resource m b + +makeSemantic ''Resource + +runResource + :: forall r a + . Member (Lift IO) r + => (∀ x. Semantic r x -> IO x) + -> Semantic (Resource ': r) a + -> Semantic r a +runResource finish = interpretH $ \case + Bracket alloc dealloc use -> do + a <- runT alloc + d <- bindT dealloc + u <- bindT use + + let runIt :: Semantic (Resource ': r) x -> IO x + runIt = finish .@ runResource + + sendM $ X.bracket (runIt a) (runIt . d) (runIt . u) +``` + +Easy. + + +## Friendly Error Messages + +Free monad libraries aren't well known for their ease-of-use. But following in +the shoes of `freer-simple`, `polysemy` takes a serious stance on providing +helpful error messages. + +For example, the library exposes both the `interpret` and `interpretH` +combinators. If you use the wrong one, the library's got your back: + +```haskell +runResource + :: forall r a + . Member (Lift IO) r + => (∀ x. Semantic r x -> IO x) + -> Semantic (Resource ': r) a + -> Semantic r a +runResource finish = interpret $ \case + ... +``` + +makes the helpful suggestion: + +``` + • 'Resource' is higher-order, but 'interpret' can help only + with first-order effects. + Fix: + use 'interpretH' instead. + • In the expression: + interpret + $ \case +``` + +Likewise it will give you tips on what to do if you forget a `TypeApplication` +or forget to handle an effect. + +Don't like helpful errors? That's OK too --- just flip the `error-messages` flag +and enjoy the raw, unadulterated fury of the typesystem. + + +## Necessary Language Extensions + +You're going to want to stick all of this into your `package.yaml` file. + +```yaml + ghc-options: -O2 -flate-specialise -fspecialise-aggressively + default-extensions: + - DataKinds + - FlexibleContexts + - GADTs + - LambdaCase + - PolyKinds + - RankNTypes + - ScopedTypeVariables + - TypeApplications + - TypeOperators + - TypeFamilies +``` + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Poly.hs b/bench/Poly.hs new file mode 100644 --- /dev/null +++ b/bench/Poly.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fwarn-all-missed-specializations #-} + +module Poly where + +import Polysemy +import Polysemy.Error +import Polysemy.Resource +import Polysemy.State + + +slowBeforeSpecialization :: Member (State Int) r => Semantic r Int +slowBeforeSpecialization = do + n <- get + if n <= 0 + then pure n + else do + put $ n - 1 + slowBeforeSpecialization + +{-# SPECIALIZE slowBeforeSpecialization :: Semantic '[State Int] Int #-} + + +countDown :: Int -> Int +countDown s = + fst . run . runState s $ slowBeforeSpecialization + +prog + :: Semantic '[ State Bool + , Error Bool + , Resource + , Lift IO + ] Bool +prog = catch @Bool (throw True) (pure . not) + +zoinks :: IO (Either Bool Bool) +zoinks = fmap (fmap snd) + . (runM .@ runResource .@@ runErrorInIO) + . runState False + $ prog + diff --git a/bench/countDown.hs b/bench/countDown.hs new file mode 100644 --- /dev/null +++ b/bench/countDown.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, GADTs, TypeOperators #-} +module Main (main) where + +import Control.Monad (replicateM_) + +import qualified Control.Monad.Except as MTL +import qualified Control.Monad.State as MTL +import qualified Control.Monad.Free as Free + +import Criterion (bench, bgroup, whnf) +import Criterion.Main (defaultMain) + +import Control.Monad.Freer (Member, Eff, run, send) +import Control.Monad.Freer.Internal (Eff(..), decomp, qApp, tsingleton) +import Control.Monad.Freer.Error (runError, throwError) +import Control.Monad.Freer.State (get, put, runState) + +import qualified Poly as P + +-------------------------------------------------------------------------------- + -- State Benchmarks -- +-------------------------------------------------------------------------------- + +oneGet :: Int -> (Int, Int) +oneGet n = run (runState n get) + +oneGetMTL :: Int -> (Int, Int) +oneGetMTL = MTL.runState MTL.get + +countDown :: Int -> (Int, Int) +countDown start = run (runState start go) + where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go) + +countDownMTL :: Int -> (Int, Int) +countDownMTL = MTL.runState go + where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go) + +-------------------------------------------------------------------------------- + -- Exception + State -- +-------------------------------------------------------------------------------- +countDownExc :: Int -> Either String (Int,Int) +countDownExc start = run $ runError (runState start go) + where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go) + +countDownExcMTL :: Int -> Either String (Int,Int) +countDownExcMTL = MTL.runStateT go + where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go) + +-------------------------------------------------------------------------------- + -- Freer: Interpreter -- +-------------------------------------------------------------------------------- +data Http out where + Open :: String -> Http () + Close :: Http () + Post :: String -> Http String + Get :: Http String + +open' :: Member Http r => String -> Eff r () +open' = send . Open + +close' :: Member Http r => Eff r () +close' = send Close + +post' :: Member Http r => String -> Eff r String +post' = send . Post + +get' :: Member Http r => Eff r String +get' = send Get + +runHttp :: Eff (Http ': r) w -> Eff r w +runHttp (Val x) = pure x +runHttp (E u q) = case decomp u of + Right (Open _) -> runHttp (qApp q ()) + Right Close -> runHttp (qApp q ()) + Right (Post d) -> runHttp (qApp q d) + Right Get -> runHttp (qApp q "") + Left u' -> E u' (tsingleton (runHttp . qApp q )) + +-------------------------------------------------------------------------------- + -- Free: Interpreter -- +-------------------------------------------------------------------------------- +data FHttpT x + = FOpen String x + | FClose x + | FPost String (String -> x) + | FGet (String -> x) + deriving Functor + +type FHttp = Free.Free FHttpT + +fopen' :: String -> FHttp () +fopen' s = Free.liftF $ FOpen s () + +fclose' :: FHttp () +fclose' = Free.liftF $ FClose () + +fpost' :: String -> FHttp String +fpost' s = Free.liftF $ FPost s id + +fget' :: FHttp String +fget' = Free.liftF $ FGet id + +runFHttp :: FHttp a -> Maybe a +runFHttp (Free.Pure x) = pure x +runFHttp (Free.Free (FOpen _ n)) = runFHttp n +runFHttp (Free.Free (FClose n)) = runFHttp n +runFHttp (Free.Free (FPost s n)) = pure s >>= runFHttp . n +runFHttp (Free.Free (FGet n)) = pure "" >>= runFHttp . n + +-------------------------------------------------------------------------------- + -- Benchmark Suite -- +-------------------------------------------------------------------------------- +prog :: Member Http r => Eff r () +prog = open' "cats" >> get' >> post' "cats" >> close' + +prog' :: FHttp () +prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose' + +p :: Member Http r => Int -> Eff r () +p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close' + +p' :: Int -> FHttp () +p' count = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose' + +main :: IO () +main = + defaultMain [ + bgroup "Countdown Bench" [ + bench "discount" $ whnf P.countDown 10000 + , bench "freer-simple" $ whnf countDown 10000 + , bench "mtl" $ whnf countDownMTL 10000 + ] + ] diff --git a/polysemy.cabal b/polysemy.cabal new file mode 100644 --- /dev/null +++ b/polysemy.cabal @@ -0,0 +1,123 @@ +cabal-version: 1.12 +name: polysemy +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +copyright: 2019 Sandy Maguire +maintainer: sandy@sandymaguire.me +author: Sandy Maguire +homepage: https://github.com/isovector/polysemy#readme +bug-reports: https://github.com/isovector/polysemy/issues +synopsis: Higher-order, low-boilerplate, zero-cost free monads. +description: + Please see the README on GitHub at +category: Language +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/isovector/polysemy + +flag dump-core + description: + Dump HTML for the core generated by GHC during compilation + default: False + manual: True + +flag error-messages + description: + Provide custom error messages + manual: True + +library + exposed-modules: + Polysemy + Polysemy.Error + Polysemy.Fixpoint + Polysemy.Input + Polysemy.Internal + Polysemy.Internal.Combinators + Polysemy.Internal.CustomErrors + Polysemy.Internal.Effect + Polysemy.Internal.Fixpoint + Polysemy.Internal.Lift + Polysemy.Internal.NonDet + Polysemy.Internal.Tactics + Polysemy.Internal.TH.Effect + Polysemy.Internal.TH.Performance + Polysemy.Internal.Union + Polysemy.NonDet + Polysemy.Output + Polysemy.Random + Polysemy.Reader + Polysemy.Resource + Polysemy.State + Polysemy.Trace + Polysemy.Writer + hs-source-dirs: src + other-modules: + Paths_polysemy + default-language: Haskell2010 + default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs + LambdaCase PolyKinds RankNTypes ScopedTypeVariables + StandaloneDeriving TypeApplications TypeOperators TypeFamilies + UnicodeSyntax + ghc-options: -O2 -Wall + build-depends: + base >=4.7 && <5, + mtl >=2.2.2 && <2.3, + random ==1.1.*, + syb ==0.7.*, + template-haskell >=2.14.0.0 && <2.15, + transformers >=0.5.5.0 && <0.6 + + if flag(dump-core) + ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html + build-depends: + dump-core >=0.1.3.2 && <0.2 + + if flag(error-messages) + cpp-options: -DERROR_MESSAGES + +test-suite polysemy-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: + FusionSpec + Paths_polysemy + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5, + hspec >=2.6.0 && <2.7, + inspection-testing >=0.4.1.1 && <0.5, + mtl >=2.2.2 && <2.3, + polysemy -any, + random ==1.1.*, + syb ==0.7.*, + template-haskell >=2.14.0.0 && <2.15, + transformers >=0.5.5.0 && <0.6 + +benchmark polysemy-bench + type: exitcode-stdio-1.0 + main-is: countDown.hs + hs-source-dirs: bench + other-modules: + Poly + Paths_polysemy + default-language: Haskell2010 + build-depends: + base >=4.7 && <5, + criterion >=1.5.3.0 && <1.6, + free ==5.1.*, + freer-simple >=1.2.1.0 && <1.3, + mtl >=2.2.2 && <2.3, + polysemy -any, + random ==1.1.*, + syb ==0.7.*, + template-haskell >=2.14.0.0 && <2.15, + transformers >=0.5.5.0 && <0.6 diff --git a/src/Polysemy.hs b/src/Polysemy.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy.hs @@ -0,0 +1,123 @@ +module Polysemy + ( -- * Core Types + Semantic () + , Member + + -- * Running Semantic + , run + , runM + + -- * Interoperating With Other Monads + , Lift () + , sendM + + -- * Lifting + , raise + + -- * Creating New Effects + -- | Effects should be defined as a GADT (enable @-XGADTs@), with kind @(* -> *) -> *@. + -- Every primitive action in the effect should be its own constructor of + -- the type. For example, we can model an effect which interacts with a tty + -- console as follows: + -- + -- @ + -- data Console m a where + -- WriteLine :: String -> Console m () + -- ReadLine :: Console m String + -- @ + -- + -- Notice that the 'a' parameter gets instataniated at the /desired return + -- type/ of the actions. Writing a line returns a '()', but reading one + -- returns 'String'. + -- + -- By enabling @-XTemplateHaskell@, we can use the 'makeSemantic' function + -- to generate smart constructors for the actions. These smart constructors + -- can be invoked directly inside of the 'Semantic' monad. + -- + -- >>> makeSemantic ''Console + -- + -- results in the following definitions: + -- + -- @ + -- writeLine :: 'Member' Console r => String -> 'Semantic' r () + -- readLine :: 'Member' Console r => 'Semantic' r String + -- @ + -- + -- Effects which don't make use of the @m@ parameter are known as + -- "first-order effects." + + -- ** Higher-Order Effects + -- | Every effect has access to the @m@ parameter, which corresponds to the + -- 'Semantic' monad it's used in. Using this parameter, we're capable of + -- writing effects which themselves contain subcomputations. + -- + -- For example, the definition of 'Polysemy.Error.Error' is + -- + -- @ + -- data 'Polysemy.Error.Error' e m a where + -- 'Polysemy.Error.Throw' :: e -> 'Polysemy.Error.Error' e m a + -- 'Polysemy.Error.Catch' :: m a -> (e -> m a) -> 'Polysemy.Error.Error' e m a + -- @ + -- + -- where 'Polysemy.Error.Catch' is an action that can run an exception + -- handler if its first argument calls 'Polysemy.Error.throw'. + -- + -- >>> makeSemantic ''Error + -- + -- @ + -- 'Polysemy.Error.throw' :: 'Member' ('Polysemy.Error.Error' e) r => e -> 'Semantic' r a + -- 'Polysemy.Error.catch' :: 'Member' ('Polysemy.Error.Error' e) r => 'Semantic' r a -> (e -> 'Semantic' r a) -> 'Semantic' r a + -- @ + -- + -- As you see, in the smart constructors, the @m@ parameter has become @'Semantic' r@. + , makeSemantic + , makeSemantic_ + + -- * Combinators for Interpreting First-Order Effects + , interpret + , intercept + , reinterpret + , reinterpret2 + , reinterpret3 + + -- * Combinators for Interpreting Higher-Order Effects + , interpretH + , interceptH + , reinterpretH + , reinterpret2H + , reinterpret3H + + -- * Improving Performance for Interpreters + , inlineRecursiveCalls + + -- * Composing IO-based Interpreters + , (.@) + , (.@@) + + -- * Tactics + -- | Higher-order effects need to explicitly thread /other effects'/ state + -- through themselves. Tactics are a domain-specific language for describing + -- exactly how this threading should take place. + -- + -- The first computation to be run should use 'runT', and subsequent + -- computations /in the same environment/ should use 'bindT'. Any + -- first-order constructors which appear in a higher-order context may use + -- 'pureT' to satisfy the typechecker. + , Tactical + , WithTactics + , getInitialStateT + , pureT + , runT + , bindT + + -- * Reexports + , Typeable + ) where + +import Data.Typeable +import Polysemy.Internal +import Polysemy.Internal.Combinators +import Polysemy.Internal.TH.Effect +import Polysemy.Internal.TH.Performance +import Polysemy.Internal.Tactics + diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Error.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.Error + ( -- * Effect + Error (..) + + -- * Actions + , throw + , catch + + -- * Interpretations + , runError + , runErrorInIO + ) where + +import qualified Control.Exception as X +import qualified Control.Monad.Trans.Except as E +import Data.Bifunctor (first) +import Data.Typeable +import Polysemy +import Polysemy.Internal +import Polysemy.Internal.Effect +import Polysemy.Internal.Union + + +data Error e m a where + Throw :: e -> Error e m a + Catch :: ∀ e m a. m a -> (e -> m a) -> Error e m a + +makeSemantic ''Error + + +------------------------------------------------------------------------------ +-- | Run an 'Error' effect in the style of +-- 'Control.Monad.Trans.Except.ExceptT'. +runError + :: Typeable e + => Semantic (Error e ': r) a + -> Semantic r (Either e a) +runError (Semantic m) = Semantic $ \k -> E.runExceptT $ m $ \u -> + case decomp u of + Left x -> E.ExceptT $ k $ + weave (Right ()) (either (pure . Left) runError_b) x + Right (Yo (Throw e) _ _ _) -> E.throwE e + Right (Yo (Catch try handle) s d y) -> + E.ExceptT $ usingSemantic k $ do + ma <- runError_b $ d $ try <$ s + case ma of + Right a -> pure . Right $ y a + Left e -> do + ma' <- runError_b $ d $ (<$ s) $ handle e + case ma' of + Left e' -> pure $ Left e' + Right a -> pure . Right $ y a +{-# INLINE runError #-} + +runError_b + :: Typeable e + => Semantic (Error e ': r) a + -> Semantic r (Either e a) +runError_b = runError +{-# NOINLINE runError_b #-} + + +newtype WrappedExc e = WrappedExc { unwrapExc :: e } + deriving (Typeable) + +instance Typeable e => Show (WrappedExc e) where + show = mappend "WrappedExc: " . show . typeRep + +instance (Typeable e) => X.Exception (WrappedExc e) + + +------------------------------------------------------------------------------ +-- | Run an 'Error' effect as an 'IO' 'X.Exception'. This interpretation is +-- significantly faster than 'runError', at the cost of being less flexible. +runErrorInIO + :: ( Typeable e + , Member (Lift IO) r + ) + => (∀ x. Semantic r x -> IO x) + -- ^ Strategy for lowering a 'Semantic' action down to 'IO'. This is + -- likely some combination of 'runM' and other interpters composed via + -- '.@'. + -> Semantic (Error e ': r) a + -> Semantic r (Either e a) +runErrorInIO lower + = sendM + . fmap (first unwrapExc) + . X.try + . (lower .@ runErrorAsExc) +{-# INLINE runErrorInIO #-} + + +runErrorAsExc + :: forall e r a. ( Typeable e + , Member (Lift IO) r + ) + => (∀ x. Semantic r x -> IO x) + -> Semantic (Error e ': r) a + -> Semantic r a +runErrorAsExc lower = interpretH $ \case + Throw e -> sendM $ X.throwIO $ WrappedExc e + Catch try handle -> do + is <- getInitialStateT + t <- runT try + h <- bindT handle + let runIt = lower . runErrorAsExc_b lower + sendM $ X.catch (runIt t) $ \(se :: WrappedExc e) -> + runIt $ h $ unwrapExc se <$ is +{-# INLINE runErrorAsExc #-} + + +runErrorAsExc_b + :: ( Typeable e + , Member (Lift IO) r + ) + => (∀ x. Semantic r x -> IO x) + -> Semantic (Error e ': r) a + -> Semantic r a +runErrorAsExc_b = runErrorAsExc +{-# NOINLINE runErrorAsExc_b #-} + diff --git a/src/Polysemy/Fixpoint.hs b/src/Polysemy/Fixpoint.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Fixpoint.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.Fixpoint + ( -- * Effect + Fixpoint (..) + + -- * Interpretations + , module Polysemy.Fixpoint + ) where + +import Control.Monad.Fix +import Polysemy +import Polysemy.Internal.Fixpoint + + +------------------------------------------------------------------------------ +-- | Run a 'Fixpoint' effect purely. +runFixpoint + :: (∀ x. Semantic r x -> x) + -> Semantic (Fixpoint ': r) a + -> Semantic r a +runFixpoint lower = interpretH $ \case + Fixpoint mf -> do + c <- bindT mf + pure $ fix $ lower . runFixpoint lower . c + + +------------------------------------------------------------------------------ +-- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance. +runFixpointM + :: ( MonadFix m + , Member (Lift m) r + ) + => (∀ x. Semantic r x -> m x) + -> Semantic (Fixpoint ': r) a + -> Semantic r a +runFixpointM lower = interpretH $ \case + Fixpoint mf -> do + c <- bindT mf + sendM $ mfix $ lower . runFixpointM lower . c + diff --git a/src/Polysemy/Input.hs b/src/Polysemy/Input.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Input.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.Input + ( -- * Effect + Input (..) + + -- * Actions + , input + + -- * Interpretations + , runConstInput + , runListInput + , runMonadicInput + ) where + +import Data.Foldable (for_) +import Data.List (uncons) +import Polysemy +import Polysemy.State + +------------------------------------------------------------------------------ +-- | An effect which can provide input to an application. Useful for dealing +-- with streaming input. +data Input i m a where + Input :: Input i m i + +makeSemantic ''Input + + +------------------------------------------------------------------------------ +-- | Run an 'Input' effect by always giving back the same value. +runConstInput :: i -> Semantic (Input i ': r) a -> Semantic r a +runConstInput c = interpret \case + Input -> pure c +{-# INLINE runConstInput #-} + + +------------------------------------------------------------------------------ +-- | Run an 'Input' effect by providing a different element of a list each +-- time. Returns 'Nothing' after the list is exhausted. +runListInput + :: Typeable i + => [i] + -> Semantic (Input (Maybe i) ': r) a + -> Semantic r a +runListInput is = fmap snd . runState is . reinterpret \case + Input -> do + s <- gets uncons + for_ s $ put . snd + pure $ fmap fst s +{-# INLINE runListInput #-} + + +------------------------------------------------------------------------------ +-- | Runs an 'Input' effect by evaluating a monadic action for each request. +runMonadicInput :: Semantic r i -> Semantic (Input i ': r) a -> Semantic r a +runMonadicInput m = interpret \case + Input -> m +{-# INLINE runMonadicInput #-} + diff --git a/src/Polysemy/Internal.hs b/src/Polysemy/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE UndecidableInstances #-} + +module Polysemy.Internal + ( Semantic (..) + , Member + , send + , sendM + , run + , runM + , raise + , Lift () + , usingSemantic + , liftSemantic + , hoistSemantic + , (.@) + , (.@@) + ) where + +import Control.Applicative +import Control.Monad.Fix +import Control.Monad.IO.Class +import Data.Functor.Identity +import Polysemy.Internal.Effect +import Polysemy.Internal.Fixpoint +import Polysemy.Internal.Lift +import Polysemy.Internal.NonDet +import Polysemy.Internal.Union + + +------------------------------------------------------------------------------ +-- | The 'Semantic' monad handles computations of arbitrary extensible effects. +-- A value of type @Semantic r@ describes a program with the capabilities of +-- @r@. For best results, @r@ should always be kept polymorphic, but you can +-- add capabilities via the 'Member' constraint. +-- +-- The value of the 'Semantic' monad is that it allows you to write programs +-- against a set of effects without a predefined meaning, and provide that +-- meaning later. For example, unlike with mtl, you can decide to interpret an +-- 'Polysemy.Error.Error' effect tradtionally as an 'Either', or instead +-- significantly faster as an 'IO' 'Control.Exception.Exception'. These +-- interpretations (and others that you might add) may be used interchangably +-- without needing to write any newtypes or 'Monad' instances. The only +-- change needed to swap interpretations is to change a call from +-- 'Polysemy.Error.runError' to 'Polysemy.Error.runErrorInIO'. +-- +-- The effect stack @r@ can contain arbitrary other monads inside of it. These +-- monads are lifted into effects via the 'Lift' effect. Monadic values can be +-- lifted into a 'Semantic' via 'sendM'. +-- +-- A 'Semantic' can be interpreted as a pure value (via 'run') or as any +-- traditional 'Monad' (via 'runM'). Each effect @E@ comes equipped with some +-- interpreters of the form: +-- +-- @ +-- runE :: 'Semantic' (E ': r) a -> 'Semantic' r a +-- @ +-- +-- which is responsible for removing the effect @E@ from the effect stack. It +-- is the order in which you call the interpreters that determines the +-- monomorphic representation of the @r@ parameter. +-- +-- After all of your effects are handled, you'll be left with either +-- a @'Semantic' '[] a@ or a @'Semantic' ('Lift' m) a@ value, which can be +-- consumed respectively by 'run' and 'runM'. +-- +-- ==== Examples +-- +-- As an example of keeping @r@ polymorphic, we can consider the type +-- +-- @ +-- 'Member' ('Polysemy.State' String) r => 'Semantic' r () +-- @ +-- +-- to be a program with access to +-- +-- @ +-- 'Polysemy.State.get' :: 'Semantic' r String +-- 'Polysemy.State.put' :: String -> 'Semantic' r () +-- @ +-- +-- methods. +-- +-- By also adding a +-- +-- @ +-- 'Member' ('Polysemy.Error' Bool) r +-- @ +-- +-- constraint on @r@, we gain access to the +-- +-- @ +-- 'Polysemy.Error.throw' :: Bool -> 'Semantic' r a +-- 'Polysemy.Error.catch' :: 'Semantic' r a -> (Bool -> 'Semantic' r a) -> 'Semantic' r a +-- @ +-- +-- functions as well. +-- +-- In this sense, a @'Member' ('Polysemy.State.State' s) r@ constraint is +-- analogous to mtl's @'Control.Monad.State.Class.MonadState' s m@ and should +-- be thought of as such. However, /unlike/ mtl, a 'Semantic' monad may have +-- an arbitrary number of the same effect. +-- +-- For example, we can write a 'Semantic' program which can output either +-- 'Int's or 'Bool's: +-- +-- @ +-- foo :: ( 'Member' ('Polysemy.Output.Output' Int) r +-- , 'Member' ('Polysemy.Output.Output' Bool) r +-- ) +-- => 'Semantic' r () +-- foo = do +-- 'Polysemy.Output.output' @Int 5 +-- 'Polysemy.Output.output' True +-- @ +-- +-- Notice that we must use @-XTypeApplications@ to specify that we'd like to +-- use the ('Polysemy.Output.Output' 'Int') effect. +newtype Semantic r a = Semantic + { runSemantic + :: ∀ m + . Monad m + => (∀ x. Union r (Semantic r) x -> m x) + -> m a + } + +------------------------------------------------------------------------------ +-- | Like 'runSemantic' but flipped for better ergonomics sometimes. +usingSemantic + :: Monad m + => (∀ x. Union r (Semantic r) x -> m x) + -> Semantic r a + -> m a +usingSemantic k m = runSemantic m k +{-# INLINE usingSemantic #-} + + +instance Functor (Semantic f) where + fmap f (Semantic m) = Semantic $ \k -> fmap f $ m k + {-# INLINE fmap #-} + + +instance Applicative (Semantic f) where + pure a = Semantic $ const $ pure a + {-# INLINE pure #-} + + Semantic f <*> Semantic a = Semantic $ \k -> f k <*> a k + {-# INLINE (<*>) #-} + + +instance Monad (Semantic f) where + return = pure + {-# INLINE return #-} + + Semantic ma >>= f = Semantic $ \k -> do + z <- ma k + runSemantic (f z) k + {-# INLINE (>>=) #-} + + +instance (Member NonDet r) => Alternative (Semantic r) where + empty = send Empty + a <|> b = do + send (Choose id) >>= \case + False -> a + True -> b + + +instance (Member (Lift IO) r) => MonadIO (Semantic r) where + liftIO = sendM + {-# INLINE liftIO #-} + +instance Member Fixpoint r => MonadFix (Semantic r) where + mfix f = send $ Fixpoint f + + +liftSemantic :: Union r (Semantic r) a -> Semantic r a +liftSemantic u = Semantic $ \k -> k u +{-# INLINE liftSemantic #-} + + +hoistSemantic + :: (∀ x. Union r (Semantic r) x -> Union r' (Semantic r') x) + -> Semantic r a + -> Semantic r' a +hoistSemantic nat (Semantic m) = Semantic $ \k -> m $ \u -> k $ nat u +{-# INLINE hoistSemantic #-} + + +------------------------------------------------------------------------------ +-- | Introduce an effect into 'Semantic'. Analogous to +-- 'Control.Monad.Class.Trans.lift' in the mtl ecosystem +raise :: ∀ e r a. Semantic r a -> Semantic (e ': r) a +raise = hoistSemantic $ hoist raise_b . weaken +{-# INLINE raise #-} + + +raise_b :: Semantic r a -> Semantic (e ': r) a +raise_b = raise +{-# NOINLINE raise_b #-} + + +------------------------------------------------------------------------------ +-- | Lift an effect into a 'Semantic'. This is used primarily via +-- 'Polysemy.makeSemantic' to implement smart constructors. +send :: Member e r => e (Semantic r) a -> Semantic r a +send = liftSemantic . inj +{-# INLINE[3] send #-} + + +------------------------------------------------------------------------------ +-- | Lift a monadic action @m@ into 'Semantic'. +sendM :: Member (Lift m) r => m a -> Semantic r a +sendM = send . Lift +{-# INLINE sendM #-} + + +------------------------------------------------------------------------------ +-- | Run a 'Semantic' containing no effects as a pure value. +run :: Semantic '[] a -> a +run (Semantic m) = runIdentity $ m absurdU +{-# INLINE run #-} + + +------------------------------------------------------------------------------ +-- | Lower a 'Semantic' containing only a single lifted 'Monad' into that +-- monad. +runM :: Monad m => Semantic '[Lift m] a -> m a +runM (Semantic m) = m $ \z -> + case extract z of + Yo e s _ f -> do + a <- unLift e + pure $ f $ a <$ s +{-# INLINE runM #-} + + +------------------------------------------------------------------------------ +-- | Some interpreters need to be able to lower down to the base monad (often +-- 'IO') in order to function properly --- some good examples of this are +-- 'Polysemy.Error.runErrorInIO' and 'Polysemy.Resource.runResource'. +-- +-- However, these interpreters don't compose particularly nicely; for example, +-- to run 'Polysemy.Resource.runResource', you must write: +-- +-- @ +-- runM . runErrorInIO runM +-- @ +-- +-- Notice that 'runM' is duplicated in two places here. The situation gets +-- exponentially worse the more intepreters you have that need to run in this +-- pattern. +-- +-- Instead, '.@' performs the composition we'd like. The above can be written as +-- +-- @ +-- (runM .@ runErrorInIO) +-- @ +-- +-- The parentheses here are important; without them you'll run into operator +-- precedence errors. +(.@) + :: Monad m + => (∀ x. Semantic r x -> m x) + -- ^ The lowering function, likely 'runM'. + -> (∀ y. (∀ x. Semantic r x -> m x) + -> Semantic (e ': r) y + -> Semantic r y) + -> Semantic (e ': r) z + -> m z +f .@ g = f . g f +infixl 9 .@ + + +------------------------------------------------------------------------------ +-- | Like '.@', but for interpreters which change the resulting type --- eg. +-- 'Polysemy.Error.runErrorInIO'. +(.@@) + :: Monad m + => (∀ x. Semantic r x -> m x) + -- ^ The lowering function, likely 'runM'. + -> (∀ y. (∀ x. Semantic r x -> m x) + -> Semantic (e ': r) y + -> Semantic r (f y)) + -> Semantic (e ': r) z + -> m (f z) +f .@@ g = f . g f +infixl 9 .@@ + diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Combinators.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuantifiedConstraints #-} + +module Polysemy.Internal.Combinators + ( -- * First order + interpret + , intercept + , reinterpret + , reinterpret2 + , reinterpret3 + -- * Higher order + , interpretH + , interceptH + , reinterpretH + , reinterpret2H + , reinterpret3H + -- * Statefulness + , stateful + , lazilyStateful + ) where + +import qualified Control.Monad.Trans.State.Lazy as LS +import qualified Control.Monad.Trans.State.Strict as S +import Data.Typeable +import Polysemy.Internal +import Polysemy.Internal.CustomErrors +import Polysemy.Internal.Effect +import Polysemy.Internal.Tactics +import Polysemy.Internal.Union + + +------------------------------------------------------------------------------ +-- | A lazier version of 'Data.Tuple.swap'. +swap :: (a, b) -> (b, a) +swap ~(a, b) = (b, a) + + + +------------------------------------------------------------------------------ +-- | The simplest way to produce an effect handler. Interprets an effect 'e' by +-- transforming it into other effects inside of 'r'. +interpret + :: FirstOrder e "interpret" + => (∀ x m. e m x -> Semantic r x) + -- ^ A natural transformation from the handled effect to other effects + -- already in 'Semantic'. + -> Semantic (e ': r) a + -> Semantic r a +-- TODO(sandy): could probably give a `coerce` impl for `runTactics` here +interpret f = interpretH $ \(e :: e m x) -> liftT @m $ f e + + +------------------------------------------------------------------------------ +-- | Like 'interpret', but for higher-order effects (ie. those which make use of +-- the 'm' parameter.) +-- +-- See the notes on 'Tactical' for how to use this function. +interpretH + :: (∀ x m . e m x -> Tactical e m r x) + -- ^ A natural transformation from the handled effect to other effects + -- already in 'Semantic'. + -> Semantic (e ': r) a + -> Semantic r a +interpretH f (Semantic m) = m $ \u -> + case decomp u of + Left x -> liftSemantic $ hoist (interpretH_b f) x + Right (Yo e s d y) -> do + a <- runTactics s (raise . interpretH_b f . d) (f e) + pure $ y a +{-# INLINE interpretH #-} + +------------------------------------------------------------------------------ +-- | A highly-performant combinator for interpreting an effect statefully. See +-- 'stateful' for a more user-friendly variety of this function. +interpretInStateT + :: Typeable s + => (∀ x m. e m x -> S.StateT s (Semantic r) x) + -> s + -> Semantic (e ': r) a + -> Semantic r (s, a) +interpretInStateT f s (Semantic m) = Semantic $ \k -> + fmap swap $ flip S.runStateT s $ m $ \u -> + case decomp u of + Left x -> S.StateT $ \s' -> + k . fmap swap + . weave (s', ()) (uncurry $ interpretInStateT_b f) + $ x + Right (Yo e z _ y) -> + fmap (y . (<$ z)) $ S.mapStateT (usingSemantic k) $ f e +{-# INLINE interpretInStateT #-} + +------------------------------------------------------------------------------ +-- | A highly-performant combinator for interpreting an effect statefully. See +-- 'stateful' for a more user-friendly variety of this function. +interpretInLazyStateT + :: Typeable s + => (∀ x m. e m x -> LS.StateT s (Semantic r) x) + -> s + -> Semantic (e ': r) a + -> Semantic r (s, a) +interpretInLazyStateT f s (Semantic m) = Semantic $ \k -> + fmap swap $ flip LS.runStateT s $ m $ \u -> + case decomp u of + Left x -> LS.StateT $ \s' -> + k . fmap swap + . weave (s', ()) (uncurry $ interpretInLazyStateT_b f) + $ x + Right (Yo e z _ y) -> + fmap (y . (<$ z)) $ LS.mapStateT (usingSemantic k) $ f e +{-# INLINE interpretInLazyStateT #-} + +------------------------------------------------------------------------------ +-- | Like 'interpret', but with access to an intermediate state @s@. +stateful + :: Typeable s + => (∀ x m. e m x -> s -> Semantic r (s, x)) + -> s + -> Semantic (e ': r) a + -> Semantic r (s, a) +stateful f = interpretInStateT $ \e -> S.StateT $ fmap swap . f e +{-# INLINE[3] stateful #-} + + +------------------------------------------------------------------------------ +-- | Like 'interpret', but with access to an intermediate state @s@. +lazilyStateful + :: Typeable s + => (∀ x m. e m x -> s -> Semantic r (s, x)) + -> s + -> Semantic (e ': r) a + -> Semantic r (s, a) +lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap swap . f e +{-# INLINE[3] lazilyStateful #-} + + +------------------------------------------------------------------------------ +-- | Like 'reinterpret', but for higher-order effects. +-- +-- See the notes on 'Tactical' for how to use this function. +reinterpretH + :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': r) x) + -- ^ A natural transformation from the handled effect to the new effect. + -> Semantic (e1 ': r) a + -> Semantic (e2 ': r) a +reinterpretH f (Semantic m) = Semantic $ \k -> m $ \u -> + case decompCoerce u of + Left x -> k $ hoist (reinterpretH_b f) $ x + Right (Yo e s d y) -> do + a <- usingSemantic k $ runTactics s (raise . reinterpretH_b f . d) $ f e + pure $ y a +{-# INLINE[3] reinterpretH #-} +-- TODO(sandy): Make this fuse in with 'stateful' directly. + + +------------------------------------------------------------------------------ +-- | Like 'interpret', but instead of removing the effect @e@, reencodes it in +-- some new effect @f@. This function will fuse when followed by +-- 'Polysemy.State.runState', meaning it's free to 'reinterpret' in terms of +-- the 'Polysemy.State.State' effect and immediately run it. +reinterpret + :: FirstOrder e1 "reinterpret" + => (∀ m x. e1 m x -> Semantic (e2 ': r) x) + -- ^ A natural transformation from the handled effect to the new effect. + -> Semantic (e1 ': r) a + -> Semantic (e2 ': r) a +reinterpret f = reinterpretH $ \(e :: e m x) -> liftT @m $ f e +{-# INLINE[3] reinterpret #-} +-- TODO(sandy): Make this fuse in with 'stateful' directly. + + +------------------------------------------------------------------------------ +-- | Like 'reinterpret2', but for higher-order effects. +-- +-- See the notes on 'Tactical' for how to use this function. +reinterpret2H + :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': r) x) + -- ^ A natural transformation from the handled effect to the new effects. + -> Semantic (e1 ': r) a + -> Semantic (e2 ': e3 ': r) a +reinterpret2H f (Semantic m) = Semantic $ \k -> m $ \u -> + case decompCoerce u of + Left x -> k $ weaken $ hoist (reinterpret2H_b f) $ x + Right (Yo e s d y) -> do + a <- usingSemantic k $ runTactics s (raise . reinterpret2H_b f . d) $ f e + pure $ y a +{-# INLINE[3] reinterpret2H #-} + + +------------------------------------------------------------------------------ +-- | Like 'reinterpret', but introduces /two/ intermediary effects. +reinterpret2 + :: FirstOrder e1 "reinterpret2" + => (∀ m x. e1 m x -> Semantic (e2 ': e3 ': r) x) + -- ^ A natural transformation from the handled effect to the new effects. + -> Semantic (e1 ': r) a + -> Semantic (e2 ': e3 ': r) a +reinterpret2 f = reinterpret2H $ \(e :: e m x) -> liftT @m $ f e +{-# INLINE[3] reinterpret2 #-} + + +------------------------------------------------------------------------------ +-- | Like 'reinterpret3', but for higher-order effects. +-- +-- See the notes on 'Tactical' for how to use this function. +reinterpret3H + :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': e4 ': r) x) + -- ^ A natural transformation from the handled effect to the new effects. + -> Semantic (e1 ': r) a + -> Semantic (e2 ': e3 ': e4 ': r) a +reinterpret3H f (Semantic m) = Semantic $ \k -> m $ \u -> + case decompCoerce u of + Left x -> k . weaken . weaken . hoist (reinterpret3H_b f) $ x + Right (Yo e s d y) -> do + a <- usingSemantic k $ runTactics s (raise . reinterpret3H_b f . d) $ f e + pure $ y a +{-# INLINE[3] reinterpret3H #-} + + +------------------------------------------------------------------------------ +-- | Like 'reinterpret', but introduces /three/ intermediary effects. +reinterpret3 + :: FirstOrder e1 "reinterpret2" + => (∀ m x. e1 m x -> Semantic (e2 ': e3 ': e4 ': r) x) + -- ^ A natural transformation from the handled effect to the new effects. + -> Semantic (e1 ': r) a + -> Semantic (e2 ': e3 ': e4 ': r) a +reinterpret3 f = reinterpret3H $ \(e :: e m x) -> liftT @m $ f e +{-# INLINE[3] reinterpret3 #-} + + +------------------------------------------------------------------------------ +-- | Like 'interpret', but instead of handling the effect, allows responding to +-- the effect while leaving it unhandled. This allows you, for example, to +-- intercept other effects and insert logic around them. +intercept + :: ( Member e r + , FirstOrder e "intercept" + ) + => (∀ x m. e m x -> Semantic r x) + -- ^ A natural transformation from the handled effect to other effects + -- already in 'Semantic'. + -> Semantic r a + -- ^ Unlike 'interpret', 'intercept' does not consume any effects. + -> Semantic r a +intercept f = interceptH $ \(e :: e m x) -> liftT @m $ f e +{-# INLINE intercept #-} + + +------------------------------------------------------------------------------ +-- | Like 'interceptH', but for higher-order effects. +-- +-- See the notes on 'Tactical' for how to use this function. +interceptH + :: Member e r + => (∀ x m. e m x -> Tactical e m r x) + -- ^ A natural transformation from the handled effect to other effects + -- already in 'Semantic'. + -> Semantic r a + -- ^ Unlike 'interpretH', 'interceptH' does not consume any effects. + -> Semantic r a +interceptH f (Semantic m) = Semantic $ \k -> m $ \u -> + case prj u of + Just (Yo e s d y) -> + usingSemantic k $ fmap y $ runTactics s (raise . d) $ f e + Nothing -> k u +{-# INLINE interceptH #-} + + +------------------------------------------------------------------------------ +-- Loop breakers +interpretH_b + :: (∀ x m . e m x -> Tactical e m r x) + -> Semantic (e ': r) a + -> Semantic r a +interpretH_b = interpretH +{-# NOINLINE interpretH_b #-} + + +interpretInStateT_b + :: Typeable s + => (∀ x m. e m x -> S.StateT s (Semantic r) x) + -> s + -> Semantic (e ': r) a + -> Semantic r (s, a) +interpretInStateT_b = interpretInStateT +{-# NOINLINE interpretInStateT_b #-} + + +interpretInLazyStateT_b + :: Typeable s + => (∀ x m. e m x -> LS.StateT s (Semantic r) x) + -> s + -> Semantic (e ': r) a + -> Semantic r (s, a) +interpretInLazyStateT_b = interpretInLazyStateT +{-# NOINLINE interpretInLazyStateT_b #-} + + +reinterpretH_b + :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': r) x) + -> Semantic (e1 ': r) a + -> Semantic (e2 ': r) a +reinterpretH_b = reinterpretH +{-# NOINLINE reinterpretH_b #-} + + +reinterpret2H_b + :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': r) x) + -> Semantic (e1 ': r) a + -> Semantic (e2 ': e3 ': r) a +reinterpret2H_b = reinterpret2H +{-# NOINLINE reinterpret2H_b #-} + + +reinterpret3H_b + :: (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': e4 ': r) x) + -> Semantic (e1 ': r) a + -> Semantic (e2 ': e3 ': e4 ': r) a +reinterpret3H_b = reinterpret3H +{-# NOINLINE reinterpret3H_b #-} + diff --git a/src/Polysemy/Internal/CustomErrors.hs b/src/Polysemy/Internal/CustomErrors.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/CustomErrors.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Polysemy.Internal.CustomErrors + ( AmbiguousSend + , Break + , FirstOrder + , UnhandledEffect + , DefiningModule + , DefiningModuleForEffect + ) where + +import Data.Coerce +import Data.Kind +import GHC.TypeLits + + +type family DefiningModule (t :: k) :: Symbol + +type family DefiningModuleForEffect (e :: k) :: Symbol where + DefiningModuleForEffect (e a) = DefiningModuleForEffect e + DefiningModuleForEffect e = DefiningModule e + + + +data T1 m a + +type family Break (c :: Constraint) + (rep :: (* -> *) -> * -> *) :: Constraint where + Break _ T1 = ((), ()) + Break _ c = () + + + +type AmbigousEffectMessage r e t vs = + ( 'Text "Ambiguous use of effect '" + ':<>: 'ShowType e + ':<>: 'Text "'" + ':$$: 'Text "Possible fix:" + ':$$: 'Text " add (Member (" + ':<>: 'ShowType t + ':<>: 'Text ") " + ':<>: 'ShowType r + ':<>: 'Text ") to the context of " + ':$$: 'Text " the type signature" + ':$$: 'Text "If you already have the constraint you want, instead" + ':$$: 'Text " add a type application to specify" + ':$$: 'Text " " + ':<>: PrettyPrint vs + ':<>: 'Text " directly" + ) + +type family PrettyPrint (vs :: [k]) where + PrettyPrint '[a] = + 'Text "'" ':<>: 'ShowType a ':<>: 'Text "'" + PrettyPrint '[a, b] = + 'Text "'" ':<>: 'ShowType a ':<>: 'Text "', and " + ':<>: + 'Text "'" ':<>: 'ShowType b ':<>: 'Text "'" + PrettyPrint (a ': vs) = + 'Text "'" ':<>: 'ShowType a ':<>: 'Text "', " + ':<>: PrettyPrint vs + + +type family AmbiguousSend r e where + AmbiguousSend r (e a b c d f) = + TypeError (AmbigousEffectMessage r e (e a b c d f) '[a, b c d f]) + + AmbiguousSend r (e a b c d) = + TypeError (AmbigousEffectMessage r e (e a b c d) '[a, b c d]) + + AmbiguousSend r (e a b c) = + TypeError (AmbigousEffectMessage r e (e a b c) '[a, b c]) + + AmbiguousSend r (e a b) = + TypeError (AmbigousEffectMessage r e (e a b) '[a, b]) + + AmbiguousSend r (e a) = + TypeError (AmbigousEffectMessage r e (e a) '[a]) + + AmbiguousSend r e = + TypeError + ( 'Text "Could not deduce: (Member " + ':<>: 'ShowType e + ':<>: 'Text " " + ':<>: 'ShowType r + ':<>: 'Text ") " + ':$$: 'Text "Fix:" + ':$$: 'Text " add (Member " + ':<>: 'ShowType e + ':<>: 'Text " " + ':<>: 'ShowType r + ':<>: 'Text ") to the context of" + ':$$: 'Text " the type signature" + ) + + + + + +type family FirstOrderError e (fn :: Symbol) :: k where + FirstOrderError e fn = + TypeError ( 'Text "'" + ':<>: 'ShowType e + ':<>: 'Text "' is higher-order, but '" + ':<>: 'Text fn + ':<>: 'Text "' can help only" + ':$$: 'Text "with first-order effects." + ':$$: 'Text "Fix:" + ':$$: 'Text " use '" + ':<>: 'Text fn + ':<>: 'Text "H' instead." + ) + +------------------------------------------------------------------------------ +-- | This constraint gives helpful error messages if you attempt to use a +-- first-order combinator with a higher-order type. +type FirstOrder e fn = ∀ m. Coercible (e m) (e (FirstOrderError e fn)) + + +------------------------------------------------------------------------------ +-- | Unhandled effects +type UnhandledEffectMsg e + = 'Text "Unhandled effect '" + ':<>: 'ShowType e + ':<>: 'Text "'" + ':$$: 'Text "Probable fix:" + ':$$: 'Text " add an interpretation for '" + ':<>: 'ShowType e + ':<>: 'Text "'" + +type CheckDocumentation e + = 'Text " If you are looking for inspiration, try consulting" + ':$$: 'Text " the documentation for module '" + ':<>: 'Text (DefiningModuleForEffect e) + ':<>: 'Text "'" + +type family BreakSym (z :: k -> k) e (c :: Constraint) + (rep :: Symbol) :: k where + BreakSym _ e _ "" = TypeError (UnhandledEffectMsg e ':$$: CheckDocumentation e) + BreakSym z e _ c = z (TypeError (UnhandledEffectMsg e ':$$: CheckDocumentation e)) + +type family UnhandledEffect z e where + UnhandledEffect z e = + BreakSym z e (TypeError (UnhandledEffectMsg e)) (DefiningModuleForEffect e) + diff --git a/src/Polysemy/Internal/Effect.hs b/src/Polysemy/Internal/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Effect.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} + +module Polysemy.Internal.Effect where + +import Data.Coerce +import Data.Functor.Identity +import Data.Kind (Constraint) +import Data.Typeable + + +type Typeable1 f = (∀ y. Typeable y => Typeable (f y) :: Constraint) + +------------------------------------------------------------------------------ +-- | The class for semantic effects. +-- +-- An effect @e@ is a type @e m a@, where the other types are given by: +-- +-- * The @m@ type variable corresponds to a monad, which will eventually be +-- instantiated at 'Polysemy.Semantic'---meaning it is capable of encoding +-- arbitrary other effects. +-- +-- * The @a@ type is handled automatically and uninteresting. +-- +-- The type @e m@ must be a 'Functor', but this instance can always be given +-- for free via the @-XDeriveFunctor@ language extension. Often this instance +-- must be derived as a standalone (@-XStandaloneDeriving@): +-- +-- @ +-- deriving instance Functor (MyEffect m) +-- @ +-- +-- If the effect doesn't use @m@ whatsoever it is said to be /first-order/. +-- First-order effects can be given an instance of 'Effect' for free with +-- @-XDeriveAnyClass@. +-- +-- @ +-- deriving instance Effect MyEffect +-- @ +class (∀ m. Functor m => Functor (e m)) => Effect e where + -- | Higher-order effects require the ability to distribute state from other + -- effects throughout themselves. This state is given by an initial piece of + -- state @s ()@, and a distributive law that describes how to move the state + -- through an effect. + -- + -- When the effect @e@ has multiple computations in the @m@ monad, 'weave' + -- defines the semantics for how these computations will view with the state: + -- + -- * If the resulting state from one computation is fed to another, the second + -- computation will see the state that results from the first computation. + -- + -- * If instead it is given the intial state, both computations will see the + -- same state, but the result of (at least) one will necessarily be ignored. + weave + :: (Functor s, Functor m, Functor n, Typeable1 s, Typeable s) + => s () + -> (∀ x. s (m x) -> n (s x)) + -> e m a + -> e n (s a) + + -- | When @e@ is first order, 'weave' can be given for free. + default weave + :: ( Coercible (e m (s a)) (e n (s a)) + , Typeable1 s + , Typeable s + , Functor s + , Functor m + , Functor n + ) + => s () + -> (∀ x. s (m x) -> n (s x)) + -> e m a + -> e n (s a) + weave s _ = coerce . fmap (<$ s) + {-# INLINE weave #-} + + -- | Lift a natural transformation from @m@ to @n@ over the effect. 'hoist' + -- should be defined as 'defaultHoist', but can be hand-written if the + -- default performance isn't sufficient. + hoist + :: ( Functor m + , Functor n + ) + => (∀ x. m x -> n x) + -> e m a + -> e n a + + -- | When @e@ is first order, 'hoist' be given for free. + default hoist + :: ( Coercible (e m a) (e n a) + , Functor m + ) + => (∀ x. m x -> n x) + -> e m a + -> e n a + hoist _ = coerce + {-# INLINE hoist #-} + + +------------------------------------------------------------------------------ +-- | A default implementation of 'hoist'. Particularly performance-sensitive +-- effects should give a hand-written their own implementation of 'hoist'. +defaultHoist + :: ( Functor m + , Functor n + , Effect e + ) + => (∀ x. m x -> n x) + -> e m a + -> e n a +defaultHoist f + = fmap runIdentity + . weave (Identity ()) + (fmap Identity . f . runIdentity) +{-# INLINE defaultHoist #-} + diff --git a/src/Polysemy/Internal/Fixpoint.hs b/src/Polysemy/Internal/Fixpoint.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Fixpoint.hs @@ -0,0 +1,7 @@ +module Polysemy.Internal.Fixpoint where + +------------------------------------------------------------------------------ +-- | An effect for providing 'Control.Monad.Fix.mfix'. +data Fixpoint m a where + Fixpoint :: (a -> m a) -> Fixpoint m a + diff --git a/src/Polysemy/Internal/Lift.hs b/src/Polysemy/Internal/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Lift.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoPolyKinds #-} + +module Polysemy.Internal.Lift where + + +------------------------------------------------------------------------------ +-- | An effect which allows a regular 'Monad' @m@ into the 'Polysemy.Semantic' +-- ecosystem. Monadic actions in @m@ can be lifted into 'Polysemy.Semantic' via +-- 'Polysemy.sendM'. +-- +-- For example, you can use this effect to lift 'IO' actions directly into +-- 'Polysemy.Semantic': +-- +-- @ +-- 'Polysemy.sendM' (putStrLn "hello") :: 'Polysemy.Member' ('Polysemy.Lift' IO) r => 'Polysemy.Semantic' r () +-- @ +-- +-- That being said, you lose out on a significant amount of the benefits of +-- 'Polysemy.Semantic' by using 'sendM' directly in application code; doing so +-- will tie your application code directly to the underlying monad, and prevent +-- you from interpreting it differently. For best results, only use 'Lift' in +-- your effect interpreters. +-- +-- Consider using 'Polysemy.Trace.trace' and 'Polysemy.Trace.runTraceIO' as +-- a substitute for using 'putStrLn' directly. +newtype Lift m (z :: * -> *) a = Lift + { unLift :: m a + } + diff --git a/src/Polysemy/Internal/NonDet.hs b/src/Polysemy/Internal/NonDet.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/NonDet.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE NoPolyKinds #-} + +module Polysemy.Internal.NonDet where + +------------------------------------------------------------------------------ +-- | An effect corresponding to the 'Control.Applicative.Alternative' typeclass. +data NonDet (m :: * -> *) a + = Empty + | Choose (Bool -> a) + diff --git a/src/Polysemy/Internal/TH/Effect.hs b/src/Polysemy/Internal/TH/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/TH/Effect.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- Originally ported from code written by Sandy Maguire (@isovector), available +-- at https://github.com/IxpertaSolutions/freer-effects/pull/28. + +{-| +This module provides Template Haskell functions for automatically generating +effect operation functions (that is, functions that use 'send') from a given +effect algebra. For example, using the @FileSystem@ effect from the example in +the module documentation for "Polysemy", we can write the following: + +@ +data FileSystem m a where + ReadFile :: 'FilePath' -> FileSystem 'String' + WriteFile :: 'FilePath' -> 'String' -> FileSystem () +'makeSemantic' ''FileSystem +@ + +This will automatically generate the following functions: + +@ +readFile :: 'Member' FileSystem r => 'FilePath' -> 'Semantic' r 'String' +readFile a = 'send' (ReadFile a) + +writeFile :: 'Member' FileSystem r => 'FilePath' -> 'String' -> 'Semantic' r () +writeFile a b = 'send' (WriteFile a b) +@ +-} +module Polysemy.Internal.TH.Effect + ( makeSemantic + , makeSemantic_ + ) +where + +import Control.Monad (join, forM, unless) +import Data.Char (toLower) +import Data.List +import Generics.SYB +import Language.Haskell.TH +import Polysemy.Internal (send, Member, Semantic) +import Polysemy.Internal.CustomErrors (DefiningModule) + + +-- | If @T@ is a GADT representing an effect algebra, as described in the module +-- documentation for "Polysemy", @$('makeSemantic' ''T)@ automatically +-- generates a smart constructor for every data constructor of @T@. +makeSemantic :: Name -> Q [Dec] +makeSemantic = genFreer True + +-- | Like 'makeSemantic', but does not provide type signatures. This can be used +-- to attach Haddock comments to individual arguments for each generated +-- function. +-- +-- @ +-- data Lang m a where +-- Output :: String -> Lang () +-- +-- makeSemantic_ ''Lang +-- +-- -- | Output a string. +-- output :: Member Lang r +-- => String -- ^ String to output. +-- -> Semantic r () -- ^ No result. +-- @ +-- +-- Note that 'makeEffect_' must be used /before/ the explicit type signatures. +makeSemantic_ :: Name -> Q [Dec] +makeSemantic_ = genFreer False + +-- | Generates declarations and possibly signatures for functions to lift GADT +-- constructors into 'Semantic' actions. +genFreer :: Bool -> Name -> Q [Dec] +genFreer makeSigs tcName = do + -- The signatures for the generated definitions require FlexibleContexts. + isExtEnabled FlexibleContexts + >>= flip unless (fail "makeSemantic requires FlexibleContexts to be enabled") + hasTyFams <- isExtEnabled TypeFamilies + + reify tcName >>= \case + TyConI (DataD _ _ _ _ cons _) -> do + sigs <- filter (const makeSigs) <$> mapM genSig cons + decs <- join <$> mapM genDecl cons + loc <- location + + return $ + [ TySynInstD ''DefiningModule + . TySynEqn [ConT tcName] + . LitT + . StrTyLit + $ loc_module loc + | hasTyFams + ] ++ sigs ++ decs + + _ -> fail "makeSemantic expects a type constructor" + +-- | Given the name of a GADT constructor, return the name of the corresponding +-- lifted function. +getDeclName :: Name -> Name +getDeclName = mkName . overFirst toLower . nameBase + where + overFirst f (a : as) = f a : as + overFirst _ as = as + +-- | Builds a function definition of the form @x a b c = send $ X a b c@. +genDecl :: Con -> Q [Dec] +genDecl (ForallC _ _ con) = genDecl con +genDecl (GadtC [cName] tArgs _ ) = do + let fnName = getDeclName cName + let arity = length tArgs - 1 + dTypeVars <- forM [0 .. arity] $ const $ newName "a" + pure $ + [PragmaD (InlineP fnName Inlinable ConLike AllPhases) + , FunD fnName . pure $ Clause + (VarP <$> dTypeVars) + (NormalB . AppE (VarE 'send) $ foldl + (\b -> AppE b . VarE) + (ConE cName) + dTypeVars + ) + [] + ] +genDecl _ = fail "genDecl expects a GADT constructor" + +tyVarBndrName :: TyVarBndr -> Name +tyVarBndrName (PlainTV n) = n +tyVarBndrName (KindedTV n _) = n + +tyVarBndrKind :: TyVarBndr -> Maybe Type +tyVarBndrKind (PlainTV _) = Nothing +tyVarBndrKind (KindedTV _ k) = Just k + +-- | Generates a function type from the corresponding GADT type constructor +-- @x :: Member (Effect e) r => a -> b -> c -> Semantic r r@. +genType :: Con -> Q (Type, Maybe Name, Maybe Type) +genType (ForallC tyVarBindings conCtx con) = do + (t, mn, _) <- genType con + let k = do n <- mn + z <- find ((== n) . tyVarBndrName) tyVarBindings + tyVarBndrKind z + free = everything mappend freeVars t + pure ( ForallT (filter (flip elem free . tyVarBndrName) tyVarBindings) conCtx t + , mn + , k + ) +genType (GadtC _ tArgs' (eff `AppT` m `AppT` tRet)) = do + r <- newName "r" + let + tArgs = fmap snd tArgs' + memberConstraint = ConT ''Member `AppT` eff `AppT` VarT r + resultType = ConT ''Semantic `AppT` VarT r `AppT` tRet + + replaceMType t | t == m = ConT ''Semantic `AppT` VarT r + | otherwise = t + ts = everywhere (mkT replaceMType) tArgs + tn = case tRet of + VarT n -> Just n + _ -> Nothing + + pure + . (, tn, Nothing) + . ForallT [PlainTV r] [memberConstraint] + . foldArrows + $ ts + ++ [resultType] +-- TODO: Although this should never happen, we obviously need a better error message below. +genType _ = fail "genSig expects a GADT constructor" + +-- | Turn all (KindedTV tv StarT) into (PlainTV tv) in the given type +-- This can prevent the need for KindSignatures +simplifyBndrs :: Maybe Type -> Type -> Type +simplifyBndrs star = everywhere (mkT $ simplifyBndr star) + +-- | Turn TvVarBndrs of the form (KindedTV tv StarT) into (PlainTV tv) +-- This can prevent the need for KindSignatures +simplifyBndr :: Maybe Type -> TyVarBndr -> TyVarBndr +simplifyBndr (Just star) (KindedTV tv k) | star == k = PlainTV tv +simplifyBndr _ (KindedTV tv StarT) = PlainTV tv +simplifyBndr _ bndr = bndr + +-- | Generates a type signature of the form +-- @x :: Member (Effect e) r => a -> b -> c -> Semantic r r@. +genSig :: Con -> Q Dec +genSig con = do + let + getConName (ForallC _ _ c) = getConName c + getConName (GadtC [n] _ _) = pure n + getConName c = fail $ "failed to get GADT name from " ++ show c + conName <- getConName con + (t, _, k) <- genType con + pure $ SigD (getDeclName conName) $ simplifyBndrs k t + +-- | Folds a list of 'Type's into a right-associative arrow 'Type'. +foldArrows :: [Type] -> Type +foldArrows = foldr1 (AppT . AppT ArrowT) + + +freeVars :: Data a => a -> [Name] +freeVars = mkQ [] $ \case + VarT n -> [n] + _ -> [] + diff --git a/src/Polysemy/Internal/TH/Performance.hs b/src/Polysemy/Internal/TH/Performance.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/TH/Performance.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.Internal.TH.Performance + ( inlineRecursiveCalls + ) where + +import Control.Monad +import Data.Bool +import Data.Maybe (maybeToList, mapMaybe) +import Data.Monoid (Any (..)) +import Generics.SYB +import Language.Haskell.TH + +------------------------------------------------------------------------------ +-- | GHC has a really hard time inlining recursive calls---such as those used in +-- interpreters for higher-order effects. This can have disastrous repercussions +-- for your performance. +-- +-- Fortunately there's a solution, but it's ugly boilerplate. You can enable +-- @-XTemplateHaskell@ and use 'inlineRecursiveCalls' to convince GHC to make +-- these functions fast again. +-- +-- @ +-- 'inlineRecursiveCalls' [d| +-- 'Polysemy.Reader.runReader' :: i -> 'Polysemy.Semantic' ('Polysemy.Reader.Reader' i ': r) a -> 'Polysemy.Semantic' r a +-- 'Polysemy.Reader.runReader' i = 'Polysemy.interpretH' $ \\case +-- 'Polysemy.Reader.Ask' -> 'Polysemy.pureT' i +-- 'Polysemy.Reader.Local' f m -> do +-- mm <- 'Polysemy.runT' m +-- 'Polysemy.raise' $ 'Polysemy.Reader.runReader' (f i) mm +-- |] +-- @ +inlineRecursiveCalls :: Q [Dec] -> Q [Dec] +inlineRecursiveCalls m = do + decs <- m + let types = mapMaybe getType decs + inlines = mapMaybe hasInline decs + fmap join $ traverse (loopbreaker types inlines) decs + + +isRecursive :: Name -> [Clause] -> Bool +isRecursive n cs = + getAny $ + everything + (<>) + (mkQ (Any False) $ withRec (const $ Any False) (Any True) n) + cs + + +withRec :: (Exp -> a) -> a -> Name -> Exp -> a +withRec unmatched matched n = \case + VarE n' | n == n' -> matched + a -> unmatched a + + +getType :: Dec -> Maybe (Name, Type) +getType (SigD n t) = Just (n, t) +getType _ = Nothing + + +hasInline :: Dec -> Maybe (Name) +hasInline (PragmaD (InlineP n Inline _ _)) = Just n +hasInline _ = Nothing + + +loopbreaker :: [(Name, Type)] -> [Name] -> Dec -> Q [Dec] +loopbreaker types inlined (FunD n cs) + | isRecursive n cs = do + nLB <- newName $ mconcat + [ "___" + , nameBase n + , "___loop_breaker" + ] + pure $ + [ FunD n $ everywhere (mkT $ withRec id (VarE nLB) n) cs + , FunD nLB [Clause [] (NormalB $ VarE n) []] + , PragmaD $ InlineP nLB NoInline FunLike AllPhases + ] ++ maybeToList (fmap (SigD nLB) $ lookup n types) + ++ bool [PragmaD $ InlineP n Inline FunLike AllPhases] + [] + (elem n inlined) +loopbreaker _ _ z = pure [z] + diff --git a/src/Polysemy/Internal/Tactics.hs b/src/Polysemy/Internal/Tactics.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Tactics.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuantifiedConstraints #-} + +module Polysemy.Internal.Tactics + ( Tactics (..) + , getInitialStateT + , runT + , bindT + , pureT + , liftT + , runTactics + , Tactical + , WithTactics + ) where + +import Polysemy.Internal +import Polysemy.Internal.Effect +import Polysemy.Internal.Union + + +------------------------------------------------------------------------------ +-- | 'Tactical' is an environment in which you're capable of explicitly +-- threading higher-order effect states. This is provided by the (internal) +-- effect @Tactics@, which is capable of rewriting monadic actions so they run +-- in the correct stateful environment. +-- +-- Inside a 'Tactical', you're capable of running 'pureT', 'runT' and 'bindT' +-- which are the main tools for rewriting monadic stateful environments. +-- +-- For example, consider trying to write an interpreter for +-- 'Polysemy.Resource.Resource', whose effect is defined as: +-- +-- @ +-- data 'Polysemy.Resource.Resource' m a where +-- 'Polysemy.Resource.Bracket' :: m a -> (a -> m ()) -> (a -> m b) -> 'Polysemy.Resource.Resource' m b +-- @ +-- +-- Here we have an @m a@ which clearly needs to be run first, and then +-- subsequently call the @a -> m ()@ and @a -> m b@ arguments. In a 'Tactical' +-- environment, we can write the threading code thusly: +-- +-- @ +-- 'Polysemy.Resource.Bracket' alloc dealloc use -> do +-- alloc' <- 'runT' alloc +-- dealloc' <- 'bindT' dealloc +-- use' <- 'bindT' use +-- @ +-- +-- where +-- +-- @ +-- alloc' :: 'Polysemy.Semantic' ('Polysemy.Resource.Resource' ': r) (f a1) +-- dealloc' :: f a1 -> 'Polysemy.Semantic' ('Polysemy.Resource.Resource' ': r) (f ()) +-- use' :: f a1 -> 'Polysemy.Semantic' ('Polysemy.Resource.Resource' ': r) (f x) +-- @ +-- +-- The @f@ type here is existential and corresponds to "whatever +-- state the other effects want to keep track of." @f@ is always +-- a 'Functor'. +-- +-- @alloc'@, @dealloc'@ and @use'@ are now in a form that can be +-- easily consumed by your interpreter. At this point, simply bind +-- them in the desired order and continue on your merry way. +-- +-- We can see from the types of @dealloc'@ and @use'@ that since they both +-- consume a @f a1@, they must run in the same stateful environment. This +-- means, for illustration, any 'Polysemy.State.put's run inside the @use@ +-- block will not be visible inside of the @dealloc@ block. +-- +-- Power users may explicitly use 'getInitialStateT' and 'bindT' to construct +-- whatever data flow they'd like; although this is usually necessary. +type Tactical e m r x = ∀ f. (Functor f, Typeable1 f) + => Semantic (WithTactics e f m r) (f x) + +type WithTactics e f m r = Tactics f m (e ': r) ': r + +data Tactics f n r m a where + GetInitialState :: Tactics f n r m (f ()) + HoistInterpretation :: (a -> n b) -> Tactics f n r m (f a -> Semantic r (f b)) + + +------------------------------------------------------------------------------ +-- | Get the stateful environment of the world at the moment the effect @e@ is +-- to be run. Prefer 'pureT', 'runT' or 'bindT' instead of using this function +-- directly. +getInitialStateT :: forall f m r e. Semantic (WithTactics e f m r) (f ()) +getInitialStateT = send @(Tactics _ m (e ': r)) GetInitialState + + +------------------------------------------------------------------------------ +-- | Lift a value into 'Tactical'. +pureT :: a -> Tactical e m r a +pureT a = do + istate <- getInitialStateT + pure $ a <$ istate + + +------------------------------------------------------------------------------ +-- | Run a monadic action in a 'Tactical' environment. The stateful environment +-- used will be the same one that the effect is initally run in. Use 'bindT' if +-- you'd prefer to explicitly manage your stateful environment. +runT + :: m a + -- ^ The monadic action to lift. This is usually a parameter in your + -- effect. + -> Semantic (WithTactics e f m r) + (Semantic (e ': r) (f a)) +runT na = do + istate <- getInitialStateT + na' <- bindT (const na) + pure $ na' istate +{-# INLINE runT #-} + + +------------------------------------------------------------------------------ +-- | Lift a kleisli action into the stateful environment. You can use +-- 'bindT' to get an effect parameter of the form @a -> m b@ into something +-- that can be used after calling 'runT' on an effect parameter @m a@. +bindT + :: (a -> m b) + -- ^ The monadic continuation to lift. This is usually a parameter in + -- your effect. + -- + -- Continuations lifted via 'bindT' will run in the same environment + -- which produced the 'a'. + -> Semantic (WithTactics e f m r) + (f a -> Semantic (e ': r) (f b)) +bindT f = send $ HoistInterpretation f +{-# INLINE bindT #-} + + +------------------------------------------------------------------------------ +-- | Internal function to create first-order interpreter combinators out of +-- higher-order ones. +liftT + :: forall m f r e a + . ( Functor f + , Typeable1 f + ) + => Semantic r a + -> Semantic (WithTactics e f m r) (f a) +liftT m = do + a <- raise m + pureT a +{-# INLINE liftT #-} + + +------------------------------------------------------------------------------ +-- | Run the 'Tactics' effect. +runTactics + :: Functor f + => f () + -> (∀ x. f (m x) -> Semantic r2 (f x)) + -> Semantic (Tactics f m r2 ': r) a + -> Semantic r a +runTactics s d (Semantic m) = m $ \u -> + case decomp u of + Left x -> liftSemantic $ hoist (runTactics_b s d) x + Right (Yo GetInitialState s' _ y) -> + pure $ y $ s <$ s' + Right (Yo (HoistInterpretation na) s' _ y) -> do + pure $ y $ (d . fmap na) <$ s' +{-# INLINE runTactics #-} + + +runTactics_b + :: Functor f + => f () + -> (∀ x. f (m x) -> Semantic r2 (f x)) + -> Semantic (Tactics f m r2 ': r) a + -> Semantic r a +runTactics_b = runTactics +{-# NOINLINE runTactics_b #-} + diff --git a/src/Polysemy/Internal/Union.hs b/src/Polysemy/Internal/Union.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Union.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Polysemy.Internal.Union + ( Union (..) + , Yo (..) + , liftYo + , Member + -- * Building Unions + , inj + , weaken + -- * Using Unions + , decomp + , prj + , extract + , absurdU + , decompCoerce + -- * Witnesses + , SNat (..) + , Nat (..) + ) where + +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Typeable +import Polysemy.Internal.Effect + +#ifdef ERROR_MESSAGES +import Polysemy.Internal.CustomErrors +#endif + + +------------------------------------------------------------------------------ +-- | An extensible, type-safe union. The @r@ type parameter is a type-level +-- list of effects, any one of which may be held within the 'Union'. +data Union (r :: [(* -> *) -> * -> *]) (m :: * -> *) a where + Union + :: SNat n + -- ^ A proof that the effect is actually in @r@. + -> Yo (IndexOf r n) m a + -- ^ The effect to wrap. The functions 'prj' and 'decomp' can help + -- retrieve this value later. + -> Union r m a + + + +data Yo e m a where + Yo :: (Functor f, Typeable1 f, Typeable f) + => e m a + -> f () + -> (forall x. f (m x) -> n (f x)) + -> (f a -> b) + -> Yo e n b + +instance Functor (Yo e m) where + fmap f (Yo e s d f') = Yo e s d (f . f') + {-# INLINE fmap #-} + +instance Effect (Yo e) where + weave s' d (Yo e s nt f) = + Yo e (Compose $ s <$ s') + (fmap Compose . d . fmap nt . getCompose) + (fmap f . getCompose) + {-# INLINE weave #-} + + hoist = defaultHoist + {-# INLINE hoist #-} + +liftYo :: Functor m => e m a -> Yo e m a +liftYo e = Yo e (Identity ()) (fmap Identity . runIdentity) runIdentity +{-# INLINE liftYo #-} + + +instance (Functor m) => Functor (Union r m) where + fmap f (Union w t) = Union w $ fmap' f t + where + -- This is necessary to delay the interaction between the type family + -- 'IndexOf' and the quantified superclass constraint on 'Effect'. + fmap' :: (Functor m, Effect f) => (a -> b) -> f m a -> f m b + fmap' = fmap + {-# INLINE fmap' #-} + {-# INLINE fmap #-} + + +instance Effect (Union r) where + weave s f (Union w e) = Union w $ weave s f e + {-# INLINE weave #-} + + hoist f (Union w e) = Union w $ hoist f e + {-# INLINE hoist #-} + + +------------------------------------------------------------------------------ +-- | A proof that the effect 'e' is available somewhere inside of the effect +-- stack 'r'. +type Member e r = Member' e r + +type Member' e r = + ( Find r e + , e ~ IndexOf r (Found r e) +#ifdef ERROR_MESSAGES + , Break (AmbiguousSend r e) (IndexOf r (Found r e)) +#endif + ) + + +data Dict c where Dict :: c => Dict c + + +induceTypeable :: SNat n -> Dict (Typeable n) +induceTypeable SZ = Dict +induceTypeable (SS _) = Dict +{-# INLINE induceTypeable #-} + + +------------------------------------------------------------------------------ +-- | The kind of type-level natural numbers. +data Nat = Z | S Nat + deriving Typeable + + +------------------------------------------------------------------------------ +-- | A singleton for 'Nat'. +data SNat :: Nat -> * where + SZ :: SNat 'Z + SS :: Typeable n => SNat n -> SNat ('S n) + deriving Typeable + + +type family IndexOf (ts :: [k]) (n :: Nat) :: k where + IndexOf (k ': ks) 'Z = k + IndexOf (k ': ks) ('S n) = IndexOf ks n + + +type family Found (ts :: [k]) (t :: k) :: Nat where +#ifdef ERROR_MESSAGES + Found '[] t = UnhandledEffect 'S t +#endif + Found (t ': ts) t = 'Z + Found (u ': ts) t = 'S (Found ts t) + + +class Typeable (Found r t) => Find (r :: [k]) (t :: k) where + finder :: SNat (Found r t) + +instance {-# OVERLAPPING #-} Find (t ': z) t where + finder = SZ + {-# INLINE finder #-} + +instance ( Find z t + , Found (_1 ': z) t ~ 'S (Found z t) + ) => Find (_1 ': z) t where + finder = SS $ finder @_ @z @t + {-# INLINE finder #-} + + +------------------------------------------------------------------------------ +-- | Decompose a 'Union'. Either this union contains an effect @e@---the head +-- of the @r@ list---or it doesn't. +decomp :: Union (e ': r) m a -> Either (Union r m a) (Yo e m a) +decomp (Union p a) = + case p of + SZ -> Right a + SS n -> Left $ Union n a +{-# INLINE decomp #-} + + +------------------------------------------------------------------------------ +-- | Retrieve the last effect in a 'Union'. +extract :: Union '[e] m a -> Yo e m a +extract (Union SZ a) = a +extract _ = error "impossible" +{-# INLINE extract #-} + + +------------------------------------------------------------------------------ +-- | An empty union contains nothing, so this function is uncallable. +absurdU :: Union '[] m a -> b +absurdU = absurdU + + +------------------------------------------------------------------------------ +-- | Weaken a 'Union' so it is capable of storing a new sort of effect. +weaken :: Union r m a -> Union (e ': r) m a +weaken (Union n a) = + case induceTypeable n of + Dict -> Union (SS n) a +{-# INLINE weaken #-} + + +------------------------------------------------------------------------------ +-- | Lift an effect @e@ into a 'Union' capable of holding it. +inj :: forall r e a m. (Functor m , Member e r) => e m a -> Union r m a +inj e = Union (finder @_ @r @e) $ liftYo e +{-# INLINE inj #-} + + +------------------------------------------------------------------------------ +-- | Attempt to take an @e@ effect out of a 'Union'. +prj :: forall e r a m + . ( Member e r + ) + => Union r m a + -> Maybe (Yo e m a) +prj (Union (s :: SNat n) a) = + case induceTypeable s of + Dict -> + case eqT @n @(Found r e) of + Just Refl -> Just a + Nothing -> Nothing +{-# INLINE prj #-} + + +------------------------------------------------------------------------------ +-- | Like 'decomp', but allows for a more efficient +-- 'Polysemy.Interpretation.reinterpret' function. +decompCoerce + :: Union (e ': r) m a + -> Either (Union (f ': r) m a) (Yo e m a) +decompCoerce (Union p a) = + case p of + SZ -> Right a + SS n -> Left (Union (SS n) a) +{-# INLINE decompCoerce #-} + + diff --git a/src/Polysemy/NonDet.hs b/src/Polysemy/NonDet.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/NonDet.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.NonDet + ( -- * Effect + NonDet (..) + + -- * Interpretations + , runNonDet + ) where + +import Control.Applicative +import Polysemy.Internal +import Polysemy.Internal.NonDet +import Polysemy.Internal.Union +import Polysemy.Internal.Effect + + +-------------------------------------------------------------------------------- +-- This stuff is lifted from 'fused-effects'. Thanks guys! +runNonDetC :: (Alternative f, Applicative m) => NonDetC m a -> m (f a) +runNonDetC (NonDetC m) = m (fmap . (<|>) . pure) (pure empty) +{-# INLINE runNonDetC #-} + + +newtype NonDetC m a = NonDetC + { -- | A higher-order function receiving two parameters: a function to combine + -- each solution with the rest of the solutions, and an action to run when no + -- results are produced. + unNonDetC :: forall b . (a -> m b -> m b) -> m b -> m b + } + deriving (Functor) + +instance Applicative (NonDetC m) where + pure a = NonDetC (\ cons -> cons a) + {-# INLINE pure #-} + + NonDetC f <*> NonDetC a = NonDetC $ \ cons -> + f (\ f' -> a (cons . f')) + {-# INLINE (<*>) #-} + +instance Alternative (NonDetC m) where + empty = NonDetC (\ _ nil -> nil) + {-# INLINE empty #-} + + NonDetC l <|> NonDetC r = NonDetC $ \ cons -> l cons . r cons + {-# INLINE (<|>) #-} + +instance Monad (NonDetC m) where + NonDetC a >>= f = NonDetC $ \ cons -> + a (\ a' -> unNonDetC (f a') cons) + {-# INLINE (>>=) #-} + + +------------------------------------------------------------------------------ +-- | Run a 'NonDet' effect in terms of some underlying 'Alternative' @f@. +runNonDet :: Alternative f => Semantic (NonDet ': r) a -> Semantic r (f a) +runNonDet (Semantic m) = Semantic $ \k -> runNonDetC $ m $ \u -> + case decomp u of + Left x -> NonDetC $ \cons nil -> do + z <- k $ weave [()] (fmap concat . traverse runNonDet) x + foldr cons nil z + Right (Yo Empty _ _ _) -> empty + Right (Yo (Choose ek) s _ y) -> do + z <- pure (ek True) <|> pure (ek False) + pure $ y $ z <$ s + diff --git a/src/Polysemy/Output.hs b/src/Polysemy/Output.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Output.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.Output + ( -- * Effect + Output (..) + + -- * Actions + , output + + -- * Interpretations + , runFoldMapOutput + , runIgnoringOutput + ) where + +import Polysemy +import Polysemy.State + + +------------------------------------------------------------------------------ +-- | An effect capable of sending messages. Useful for streaming output and for +-- logging. +data Output o m a where + Output :: o -> Output o m () + +makeSemantic ''Output + + +------------------------------------------------------------------------------ +-- | Run an 'Output' effect by transforming it into a monoid. +runFoldMapOutput + :: forall o m r a + . (Typeable m, Monoid m) + => (o -> m) + -> Semantic (Output o ': r) a + -> Semantic r (m, a) +runFoldMapOutput f = runState mempty . reinterpret \case + Output o -> modify (<> f o) +{-# INLINE runFoldMapOutput #-} + + +------------------------------------------------------------------------------ +-- | Run an 'Ouput' effect by ignoring it. +runIgnoringOutput :: Semantic (Output o ': r) a -> Semantic r a +runIgnoringOutput = interpret \case + Output _ -> pure () +{-# INLINE runIgnoringOutput #-} + diff --git a/src/Polysemy/Random.hs b/src/Polysemy/Random.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Random.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE BlockArguments #-} +{-# 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 + +makeSemantic ''Random + + +------------------------------------------------------------------------------ +-- | Run a 'Random' effect with an explicit 'R.RandomGen'. +runRandom + :: forall q r a + . ( Typeable q + , R.RandomGen q + ) + => q + -> Semantic (Random ': r) a + -> Semantic 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 (Lift IO) r => Semantic (Random ': r) a -> Semantic r a +runRandomIO m = do + q <- sendM R.newStdGen + snd <$> runRandom q m +{-# INLINE runRandomIO #-} + diff --git a/src/Polysemy/Reader.hs b/src/Polysemy/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Reader.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.Reader + ( -- * Effect + Reader (..) + + -- * Actions + , ask + , asks + , local + + -- * Interpretations + , runReader + , runInputAsReader + ) where + +import Polysemy +import Polysemy.Input + + +------------------------------------------------------------------------------ +-- | An effect corresponding to 'Control.Monad.Trans.Reader.ReaderT'. +data Reader i m a where + Ask :: Reader i m i + Local :: (i -> i) -> m a -> Reader i m a + +makeSemantic ''Reader + + +asks :: Member (Reader i) r => (i -> j) -> Semantic r j +asks f = f <$> ask +{-# INLINABLE asks #-} + + +------------------------------------------------------------------------------ +-- | Run a 'Reader' effect with a constant value. +runReader :: i -> Semantic (Reader i ': r) a -> Semantic r a +runReader i = interpretH $ \case + Ask -> pureT i + Local f m -> do + mm <- runT m + raise $ runReader_b (f i) mm +{-# INLINE runReader #-} + +runReader_b :: i -> Semantic (Reader i ': r) a -> Semantic r a +runReader_b = runReader +{-# NOINLINE runReader_b #-} + + +------------------------------------------------------------------------------ +-- | Transform an 'Input' effect into a 'Reader' effect. +runInputAsReader :: Semantic (Input i ': r) a -> Semantic (Reader i ': r) a +runInputAsReader = reinterpret $ \case + Input -> ask +{-# INLINE runInputAsReader #-} + diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Resource.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.Resource + ( -- * Effect + Resource (..) + + -- * Actions + , bracket + + -- * Interpretations + , runResource + ) where + +import qualified Control.Exception as X +import Polysemy + + +------------------------------------------------------------------------------ +-- | An effect capable of providing 'X.bracket' semantic. Interpreters for this +-- will successfully run the deallocation action even in the presence of other +-- short-circuiting effects. +data Resource m a where + Bracket + :: m a + -- ^ Action to allocate a resource. + -> (a -> m ()) + -- ^ Action to cleanup the resource. This is guaranteed to be + -- called. + -> (a -> m b) + -- ^ Action which uses the resource. + -> Resource m b + +makeSemantic ''Resource + + +------------------------------------------------------------------------------ +-- | Run a 'Resource' effect via in terms of 'X.bracket'. +runResource + :: forall r a + . Member (Lift IO) r + => (∀ x. Semantic r x -> IO x) + -- ^ Strategy for lowering a 'Semantic' action down to 'IO'. This is + -- likely some combination of 'runM' and other interpters composed via + -- '.@'. + -> Semantic (Resource ': r) a + -> Semantic r a +runResource finish = interpretH $ \case + Bracket alloc dealloc use -> do + a <- runT alloc + d <- bindT dealloc + u <- bindT use + + let runIt :: Semantic (Resource ': r) x -> IO x + runIt = finish .@ runResource + + sendM $ X.bracket (runIt a) (runIt . d) (runIt . u) + diff --git a/src/Polysemy/State.hs b/src/Polysemy/State.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/State.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.State + ( -- * Effect + State (..) + + -- * Actions + , get + , gets + , put + , modify + + -- * Interpretations + , runState + , runLazyState + ) where + +import Polysemy +import Polysemy.Internal.Combinators + + +------------------------------------------------------------------------------ +-- | An effect for providing statefulness. Note that unlike mtl's +-- 'Control.Monad.Trans.State.StateT', there is no restriction that the 'State' +-- effect corresponds necessarily to /local/ state. It could could just as well +-- be interrpeted in terms of HTTP requests or database access. +-- +-- Interpreters which require statefulness can 'Polysemy.reinterpret' +-- themselves in terms of 'State', and subsequently call 'runState'. +data State s m a where + Get :: State s m s + Put :: s -> State s m () + +makeSemantic ''State + + +gets :: Member (State s) r => (s -> a) -> Semantic r a +gets f = fmap f get +{-# INLINABLE gets #-} + + +modify :: Member (State s) r => (s -> s) -> Semantic r () +modify f = do + s <- get + put $ f s +{-# INLINABLE modify #-} + + +------------------------------------------------------------------------------ +-- | Run a 'State' effect with local state. +runState :: Typeable s => s -> Semantic (State s ': r) a -> Semantic r (s, a) +runState = stateful $ \case + Get -> \s -> pure (s, s) + Put s -> const $ pure (s, ()) +{-# INLINE[3] runState #-} + + +------------------------------------------------------------------------------ +-- | Run a 'State' effect with local state, lazily. +runLazyState :: Typeable s => s -> Semantic (State s ': r) a -> Semantic r (s, a) +runLazyState = lazilyStateful $ \case + Get -> \s -> pure (s, s) + Put s -> const $ pure (s, ()) +{-# INLINE[3] runLazyState #-} + + +{-# RULES "runState/reinterpret" + forall s e (f :: forall m x. e m x -> Semantic (State s ': r) x). + runState s (reinterpret f e) = stateful (\x s' -> runState s' $ f x) s e + #-} + +{-# RULES "runLazyState/reinterpret" + forall s e (f :: forall m x. e m x -> Semantic (State s ': r) x). + runLazyState s (reinterpret f e) = lazilyStateful (\x s' -> runLazyState s' $ f x) s e + #-} + diff --git a/src/Polysemy/Trace.hs b/src/Polysemy/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Trace.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.Trace + ( -- * Effect + Trace (..) + + -- * Actions + , trace + + -- * Interpretations + , runTraceIO + , runIgnoringTrace + , runTraceAsOutput + ) where + +import Polysemy +import Polysemy.Output + + +------------------------------------------------------------------------------ +-- | An effect for logging strings. +data Trace m a where + Trace :: String -> Trace m () + +makeSemantic ''Trace + + +------------------------------------------------------------------------------ +-- | Run a 'Trace' effect by printing the messages to stdout. +runTraceIO :: Member (Lift IO) r => Semantic (Trace ': r) a -> Semantic r a +runTraceIO = interpret $ \case + Trace m -> sendM $ putStrLn m +{-# INLINE runTraceIO #-} + + +------------------------------------------------------------------------------ +-- | Run a 'Trace' effect by ignoring all of its messages. +runIgnoringTrace :: Member (Lift IO) r => Semantic (Trace ': r) a -> Semantic r a +runIgnoringTrace = interpret $ \case + Trace _ -> pure () +{-# INLINE runIgnoringTrace #-} + + +------------------------------------------------------------------------------ +-- | Transform a 'Trace' effect into a 'Output' 'String' effect. +runTraceAsOutput :: Semantic (Trace ': r) a -> Semantic (Output String ': r) a +runTraceAsOutput = reinterpret $ \case + Trace m -> output m +{-# INLINE runTraceAsOutput #-} + diff --git a/src/Polysemy/Writer.hs b/src/Polysemy/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Writer.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Polysemy.Writer + ( -- * Effect + Writer (..) + + -- * Actions + , tell + , listen + , censor + + -- * Interpretations + , runOutputAsWriter + , runWriter + ) where + +import Polysemy +import Polysemy.Output +import Polysemy.State + +------------------------------------------------------------------------------ +-- | An effect capable of emitting and intercepting messages. +data Writer o m a where + Tell :: o -> Writer o m () + Listen :: ∀ o m a. m a -> Writer o m (o, a) + Censor :: (o -> o) -> m a -> Writer o m a + +makeSemantic ''Writer + + +------------------------------------------------------------------------------ +-- | Transform an 'Output' effect into a 'Writer' effect. +runOutputAsWriter :: Semantic (Output o ': r) a -> Semantic (Writer o ': r) a +runOutputAsWriter = reinterpret \case + Output o -> tell o +{-# INLINE runOutputAsWriter #-} + + +------------------------------------------------------------------------------ +-- | Run a 'Writer' effect in the style of 'Control.Monad.Trans.Writer.WriterT' +-- (but without the nasty space leak!) +runWriter + :: (Monoid o, Typeable o) + => Semantic (Writer o ': r) a + -> Semantic r (o, a) +runWriter = runState mempty . reinterpretH \case + Tell o -> do + modify (<> o) >>= pureT + Listen m -> do + mm <- runT m + -- TODO(sandy): this is fucking stupid + (o, fa) <- raise $ runWriter mm + pure $ fmap (o, ) fa + Censor f m -> do + mm <- runT m + ~(o, a) <- raise $ runWriter mm + modify (<> f o) + pure a + diff --git a/test/FusionSpec.hs b/test/FusionSpec.hs new file mode 100644 --- /dev/null +++ b/test/FusionSpec.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -O2 #-} + +module FusionSpec where + +import qualified Control.Monad.Trans.Except as E +import qualified Control.Monad.Trans.State.Strict as S +import Polysemy.Error +import Polysemy.Internal +import Polysemy.Internal.Combinators +import Polysemy.Internal.Effect +import Polysemy.Internal.Union +import Polysemy.State +import Test.Hspec +import Test.Inspection + + +isSuccess :: Result -> Bool +isSuccess (Success _) = True +isSuccess (Failure e) = error e + +shouldSucceed :: Result -> Expectation +shouldSucceed r = r `shouldSatisfy` isSuccess + + +spec :: Spec +spec = do + describe "fusion" $ do + it "Union proofs should simplify" $ do + shouldSucceed $(inspectTest $ 'countDown `hasNoType` ''SNat) + + it "internal uses of StateT should simplify" $ do + shouldSucceed $(inspectTest $ 'countDown `doesNotUse` ''S.StateT) + shouldSucceed $(inspectTest $ 'jank `doesNotUse` ''S.StateT) + + it "internal uses of ExceptT should simplify" $ do + shouldSucceed $(inspectTest $ 'tryIt `doesNotUse` ''E.ExceptT) + + it "`runState . reinterpret` should fuse" $ do + shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'reinterpret) + shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'hoist) + + it "who needs Sematic even?" $ do + shouldSucceed $(inspectTest $ 'countDown `doesNotUse` 'Semantic) + shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'Semantic) + shouldSucceed $(inspectTest $ 'tryIt `doesNotUse` 'Semantic) + + +go :: Semantic '[State Int] Int +go = do + n <- get + if n <= 0 + then pure n + else do + put (n-1) + go + + +tryIt :: Either Bool String +tryIt = run . runError @Bool $ do + catch @Bool + do + throw False + \_ -> pure "hello" + + +countDown :: Int -> Int +countDown start = fst $ run $ runState start go + + +jank :: Int -> Int +jank start = fst $ run $ runState start $ go + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}