Drop dependency on polysemy-zoo (#380)

Remove polysemy-zoo, and copy over needed code.

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.

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,

src/Disco/Interpret/CESK.hs

@@ -58,9 +58,9 @@ 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.Random
 import Polysemy.State
 
 ------------------------------------------------------------

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
@@ -40,6 +39,7 @@ import Disco.Syntax.Prims
 import Disco.Typecheck.Erase (eraseProperty)
 import Disco.Types (TyDefCtx)
 import Disco.Value
+import Polysemy.Random
 import Polysemy.Reader
 
 -- | Toggles which outcome (finding or not finding the thing being

src/Polysemy/ConstraintAbsorber.hs

@@ -0,0 +1,53 @@
+{-# 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 (Constraint, Type)
+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.
+  -- | Reified dictionary
+  d ->
+  -- | This parameter should always be @'Sub' 'Dict'@
+  (forall s. R.Reifies s d :- p (x (Sem r) s)) ->
+  (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 #-}

src/Polysemy/ConstraintAbsorber/MonadCatch.hs

@@ -0,0 +1,128 @@
+{-# 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 Control.Monad.Catch (
+  Exception (..),
+  SomeException,
+  toException,
+ )
+import qualified Control.Monad.Catch as C
+
+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 =>
+  -- | 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@.
+  (C.MonadCatch (Sem r) => Sem r a) ->
+  Sem r a
+absorbMonadCatch =
+  absorbWithSem @C.MonadCatch @Action (CatchDict E.throw E.catch) (Sub Dict)
+{-# INLINEABLE absorbMonadCatch #-}
+
+-- | Introduce a local 'S.MonadThrow' constraint on 'Sem' --- allowing it to
+-- interop nicely with exceptions
+absorbMonadThrow ::
+  Member (E.Error C.SomeException) r =>
+  -- | 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@.
+  (C.MonadThrow (Sem r) => Sem r a) ->
+  Sem r a
+absorbMonadThrow = absorbMonadCatch
+{-# INLINEABLE 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 #-}

src/Polysemy/Random.hs

@@ -0,0 +1,63 @@
+{-# 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 #-}

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