From 35e9c39ba2024ae95ffa43befc0bbf933d97a5b6 Mon Sep 17 00:00:00 2001 From: LeitMoth Date: Mon, 20 May 2024 10:57:20 -0500 Subject: [PATCH] Remove polysemy-zoo, and copy over needed code --- LICENSE | 36 +++++ disco.cabal | 10 +- src/Disco/Effects/Random.hs | 32 ----- src/Disco/Interpret/CESK.hs | 2 +- src/Disco/Property.hs | 2 +- src/Polysemy/ConstraintAbsorber.hs | 45 +++++++ src/Polysemy/ConstraintAbsorber/MonadCatch.hs | 125 ++++++++++++++++++ src/Polysemy/Random.hs | 60 +++++++++ stack.yaml | 1 - 9 files changed, 276 insertions(+), 37 deletions(-) delete mode 100644 src/Disco/Effects/Random.hs create mode 100644 src/Polysemy/ConstraintAbsorber.hs create mode 100644 src/Polysemy/ConstraintAbsorber/MonadCatch.hs create mode 100644 src/Polysemy/Random.hs diff --git a/LICENSE b/LICENSE index 9231520f..c22f4db6 100644 --- a/LICENSE +++ b/LICENSE @@ -29,3 +29,39 @@ 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. + + + +Licensing for polysemy-zoo code: +Portions of the code as noted are covered under the following license: + +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/disco.cabal b/disco.cabal index bc3f2fce..fc7cdd90 100644 --- a/disco.cabal +++ b/disco.cabal @@ -419,7 +419,6 @@ library Disco.Effects.Fresh Disco.Effects.Input Disco.Effects.LFresh - Disco.Effects.Random Disco.Effects.State Disco.Effects.Store Disco.AST.Core @@ -462,6 +461,10 @@ library Disco.Doc other-modules: Paths_disco + Polysemy.ConstraintAbsorber + Polysemy.ConstraintAbsorber.MonadCatch + Polysemy.Random + autogen-modules: Paths_disco build-depends: base >=4.8 && <4.18, @@ -480,7 +483,10 @@ library -- constraint, hence a breaking change polysemy >= 1.6.0.0 && < 1.10, polysemy-plugin >= 0.4 && < 0.5, - polysemy-zoo >= 0.7 && < 0.9, + reflection >= 2.1.7 && < 2.2, + random >= 1.2.1.1 && < 1.3, + constraints >= 0.13.4 && < 0.14, + text >= 2.0.2 && < 2.1, lens >= 4.14 && < 5.3, exact-combinatorics >= 0.2 && < 0.3, arithmoi >= 0.10 && < 0.14, diff --git a/src/Disco/Effects/Random.hs b/src/Disco/Effects/Random.hs deleted file mode 100644 index 37762b41..00000000 --- a/src/Disco/Effects/Random.hs +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------ - ------------------------------------------------------------------------------ - --- | --- Module : Disco.Effects.Random --- Copyright : disco team and contributors --- Maintainer : byorgey@gmail.com --- --- SPDX-License-Identifier: BSD-3-Clause --- --- Utility functions for random effect. -module Disco.Effects.Random ( - module Polysemy.Random, - runGen, -) -where - -import Polysemy -import Polysemy.Random -import qualified System.Random.SplitMix as SM -import qualified Test.QuickCheck.Gen as QC -import qualified Test.QuickCheck.Random as QCR - -import Data.Word (Word64) - --- | Run a QuickCheck generator using a 'Random' effect. -runGen :: Member Random r => QC.Gen a -> Sem r a -runGen g = do - n <- random @_ @Int - w <- random @_ @Word64 - return $ QC.unGen g (QCR.QCGen (SM.mkSMGen w)) n diff --git a/src/Disco/Interpret/CESK.hs b/src/Disco/Interpret/CESK.hs index a08e7ea5..45b4a1c1 100644 --- a/src/Disco/Interpret/CESK.hs +++ b/src/Disco/Interpret/CESK.hs @@ -58,10 +58,10 @@ import Math.NumberTheory.Primes.Testing (isPrime) import Disco.Effects.Fresh import Disco.Effects.Input -import Disco.Effects.Random import Polysemy import Polysemy.Error import Polysemy.State +import Polysemy.Random ------------------------------------------------------------ -- Utilities diff --git a/src/Disco/Property.hs b/src/Disco/Property.hs index c3edd902..7ad38073 100644 --- a/src/Disco/Property.hs +++ b/src/Disco/Property.hs @@ -28,7 +28,6 @@ import Prelude hiding ((<>)) import Data.Char (toLower) import qualified Data.Enumeration.Invertible as E -import Disco.Effects.Random import Polysemy import Disco.AST.Typed @@ -41,6 +40,7 @@ import Disco.Typecheck.Erase (eraseProperty) import Disco.Types (TyDefCtx) import Disco.Value import Polysemy.Reader +import Polysemy.Random -- | Toggles which outcome (finding or not finding the thing being -- searched for) qualifies as success, without changing the thing diff --git a/src/Polysemy/ConstraintAbsorber.hs b/src/Polysemy/ConstraintAbsorber.hs new file mode 100644 index 00000000..861e5919 --- /dev/null +++ b/src/Polysemy/ConstraintAbsorber.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} + +-- This module was copied from polysemy-zoo: +-- https://hackage.haskell.org/package/polysemy-zoo-0.8.2.0/docs/src/Polysemy.ConstraintAbsorber.html + +module Polysemy.ConstraintAbsorber + ( -- * Absorb builder + absorbWithSem + + -- * Re-exports + , Reifies + , (:-) (Sub) + , Dict (Dict) + , reflect + , Proxy (Proxy) + ) where + +import Data.Constraint (Dict(Dict), (:-)(Sub), (\\)) +import qualified Data.Constraint as C +import qualified Data.Constraint.Unsafe as C +import Data.Kind (Type, Constraint) +import Data.Proxy (Proxy (..)) +import Data.Reflection (Reifies, reflect) +import qualified Data.Reflection as R +import Polysemy + +------------------------------------------------------------------------------ +-- | This function can be used to locally introduce typeclass instances for +-- 'Sem'. See 'Polysemy.ConstraintAbsorber.MonadState' for an example of how to +-- use it. +absorbWithSem + :: forall -- Constraint to be absorbed + (p :: (Type -> Type) -> Constraint) + -- Wrapper to avoid orphan instances + (x :: (Type -> Type) -> Type -> Type -> Type) + d r a + . d -- ^ Reified dictionary + -> (forall s. R.Reifies s d :- p (x (Sem r) s)) -- ^ This parameter should always be @'Sub' 'Dict'@ + -> (p (Sem r) => Sem r a) + -> Sem r a +absorbWithSem d i m = R.reify d $ \(_ :: Proxy (s :: Type)) -> m \\ C.trans + (C.unsafeCoerceConstraint :: ((p (x m s) :- p m))) i +{-# INLINEABLE absorbWithSem #-} + diff --git a/src/Polysemy/ConstraintAbsorber/MonadCatch.hs b/src/Polysemy/ConstraintAbsorber/MonadCatch.hs new file mode 100644 index 00000000..99b655f1 --- /dev/null +++ b/src/Polysemy/ConstraintAbsorber/MonadCatch.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- This module was copied from polysemy-zoo: +-- https://hackage.haskell.org/package/polysemy-zoo-0.8.2.0/docs/src/Polysemy.ConstraintAbsorber.MonadCatch.html + +module Polysemy.ConstraintAbsorber.MonadCatch + ( + -- * Constraint Absorbers + absorbMonadThrow + , absorbMonadCatch + -- * run helper + , runMonadCatch + , runMonadCatchAsText + -- * Re-exports + , Exception(..) + , SomeException + ) +where + +import qualified Control.Monad.Catch as C +import Control.Monad.Catch ( Exception(..) + , SomeException + , toException + ) + +import qualified Data.Text as T +import Polysemy +import Polysemy.ConstraintAbsorber +import qualified Polysemy.Error as E + + +------------------------------------------------------------------------------ +-- | Like 'E.runError' but applies a given function from 'SomeException' +-- to some other type, typically something less opaque. +-- e.g.: +-- @runMonadCatch C.displayException@ +-- +runMonadCatch + :: Exception e + => (Maybe e -> e') + -> Sem (E.Error C.SomeException : E.Error e' : r) a + -> Sem r (Either e' a) +runMonadCatch f = E.runError . E.mapError (f . C.fromException) + +runMonadCatchAsText + :: Sem (E.Error C.SomeException : E.Error T.Text : r) a + -> Sem r (Either T.Text a) +runMonadCatchAsText = E.runError . E.mapError (T.pack . C.displayException) + + + +-- | Introduce a local 'S.MonadCatch' constraint on 'Sem' --- allowing it to +-- interop nicely with exceptions +-- +absorbMonadCatch + :: Member (E.Error C.SomeException) r + => (C.MonadCatch (Sem r) => Sem r a) + -- ^ A computation that requires an instance of 'C.MonadCatch' + -- or 'C.MonadThrow' for + -- 'Sem'. This might be something with type @'C.MonadCatch' e m => m a@. + -> Sem r a +absorbMonadCatch = + absorbWithSem @C.MonadCatch @Action (CatchDict E.throw E.catch) (Sub Dict) +{-# INLINABLE absorbMonadCatch #-} + +-- | Introduce a local 'S.MonadThrow' constraint on 'Sem' --- allowing it to +-- interop nicely with exceptions +-- +absorbMonadThrow + :: Member (E.Error C.SomeException) r + => (C.MonadThrow (Sem r) => Sem r a) + -- ^ A computation that requires an instance of 'C.MonadCatch' + -- or 'C.MonadThrow' for + -- 'Sem'. This might be something with type @'C.MonadCatch' e m => m a@. + -> Sem r a +absorbMonadThrow main = absorbMonadCatch main +{-# INLINABLE absorbMonadThrow #-} + +------------------------------------------------------------------------------ +-- | A dictionary of the functions we need to supply +-- to make an instance of Error +data CatchDict m = CatchDict + { throwM_ :: forall a. C.SomeException -> m a + , catch_ :: forall a. m a -> (C.SomeException -> m a) -> m a + } + + +------------------------------------------------------------------------------ +-- | Wrapper for a monadic action with phantom +-- type parameter for reflection. +-- Locally defined so that the instance we are going +-- to build with reflection must be coherent, that is +-- there cannot be orphans. +newtype Action m s' a = Action { action :: m a } + deriving (Functor, Applicative, Monad) + + +------------------------------------------------------------------------------ +-- | Given a reifiable mtl Error dictionary, +-- we can make an instance of @MonadError@ for the action +-- wrapped in @Action@. +instance ( Monad m + , Reifies s' (CatchDict m) + ) => C.MonadThrow (Action m s') where + throwM e = Action $ throwM_ (reflect $ Proxy @s') (C.toException e) + {-# INLINEABLE throwM #-} + +instance ( Monad m + , Reifies s' (CatchDict m) + ) => C.MonadCatch (Action m s') where + catch x f = + let catchF = catch_ (reflect $ Proxy @s') + in Action $ (action x) `catchF` \e -> case C.fromException e of + Just e' -> action $ f e' + _ -> throwM_ (reflect $ Proxy @s') (C.toException e) + {-# INLINEABLE catch #-} + + diff --git a/src/Polysemy/Random.hs b/src/Polysemy/Random.hs new file mode 100644 index 00000000..f02fdc4f --- /dev/null +++ b/src/Polysemy/Random.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This module was copied from polysemy-zoo: +-- https://hackage.haskell.org/package/polysemy-zoo-0.8.2.0/docs/src/Polysemy.Random.html + +module Polysemy.Random + ( -- * Effect + Random (..) + + -- * Actions + , random + , randomR + + -- * Interpretations + , runRandom + , runRandomIO + ) where + +import Polysemy +import Polysemy.State +import qualified System.Random as R + +------------------------------------------------------------------------------ +-- | An effect capable of providing 'R.Random' values. +data Random m a where + Random :: R.Random x => Random m x + RandomR :: R.Random x => (x, x) -> Random m x + +makeSem ''Random + + +------------------------------------------------------------------------------ +-- | Run a 'Random' effect with an explicit 'R.RandomGen'. +runRandom + :: forall q r a + . R.RandomGen q + => q + -> Sem (Random ': r) a + -> Sem r (q, a) +runRandom q = runState q . reinterpret (\case + Random -> do + ~(a, q') <- gets @q R.random + put q' + pure a + RandomR r -> do + ~(a, q') <- gets @q $ R.randomR r + put q' + pure a + ) +{-# INLINE runRandom #-} + + +------------------------------------------------------------------------------ +-- | Run a 'Random' effect by using the 'IO' random generator. +runRandomIO :: Member (Embed IO) r => Sem (Random ': r) a -> Sem r a +runRandomIO m = do + q <- embed @IO R.newStdGen + snd <$> runRandom q m +{-# INLINE runRandomIO #-} + diff --git a/stack.yaml b/stack.yaml index 32086270..38c33de6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,7 +13,6 @@ extra-deps: - unbound-generics-0.4.2 # unbound-generics-0.4.3 contains breaking changes (adding methods to Subst class) - simple-enumeration-0.2.1@sha256:8625b269c1650d3dd0e3887351c153049f4369853e0d525219e07480ea004b9f,1178 - - polysemy-zoo-0.8.2.0 # - HTTP-4000.3.16@sha256:6042643c15a0b43e522a6693f1e322f05000d519543a84149cb80aeffee34f71,5947 # HTTP-4000.3 needed for oeis-0.3.10