vendor some modules from polysemy-zoo

Fixes #375.
disco-lang · Mar 15, 2024 · f72a7db · f72a7db
1 parent 5a694e3
commit f72a7db
Show file tree

Hide file tree

Showing 7 changed files with 422 additions and 20 deletions.
diff --git a/disco.cabal b/disco.cabal
@@ -460,11 +460,14 @@ library
                        Disco.Interactive.CmdLine
                        Disco.Interactive.Commands
                        Disco.Doc
+                       Polysemy.ConstraintAbsorber
+                       Polysemy.ConstraintAbsorber.MonadCatch
+                       Polysemy.Random
 
   other-modules:       Paths_disco
   autogen-modules:     Paths_disco
 
-  build-depends:       base >=4.8 && <4.18,
+  build-depends:       base >=4.8 && <4.20,
                        filepath,
                        directory,
                        mtl >=2.2 && <2.4,
@@ -480,7 +483,9 @@ 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,
+                       constraints >= 0.13 && < 0.15,
+                       reflection >= 2.1 && < 2.2,
+                       random >= 1.2 && < 1.3,
                        lens >= 4.14 && < 5.3,
                        exact-combinatorics >= 0.2 && < 0.3,
                        arithmoi >= 0.10 && < 0.14,

diff --git a/src/Disco/Effects/ConstraintAbsorber.hs b/src/Disco/Effects/ConstraintAbsorber.hs
@@ -0,0 +1,85 @@
+-- Copied from the polysemy-zoo package.
+{-
+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.
+-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+module Disco.Effects.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 (Sem)
+
+------------------------------------------------------------------------------
+
+-- | This function can be used to locally introduce typeclass instances for
+-- 'Sem'. See 'Polysemy.ConstraintAbsorber.MonadState' for an example of how to
+-- use it.
+--
+-- @since 0.3.0.0
+absorbWithSem ::
+  forall
+    -- Constraint to be absorbed
+    (p :: (Type -> Type) -> Constraint)
+    -- Wrapper to avoid orphan instances
+    (x :: (Type -> Type) -> Type -> Type -> Type)
+    d
+    r
+    a.
+  -- | 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 #-}
diff --git a/src/Disco/Effects/Fresh.hs b/src/Disco/Effects/Fresh.hs
@@ -2,10 +2,6 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
-
 -- |
 -- Module      :  Disco.Effects.Fresh
 -- Copyright   :  disco team and contributors

diff --git a/src/Disco/Interactive/CmdLine.hs b/src/Disco/Interactive/CmdLine.hs
@@ -1,7 +1,3 @@
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
-
 -- |
 -- Module      :  Disco.Interactive.CmdLine
 -- Copyright   :  disco team and contributors
@@ -27,20 +23,14 @@ import Paths_disco (version)
 
 import Control.Lens hiding (use)
 import Control.Monad (unless, when)
+import Control.Monad.Catch (SomeException)
 import qualified Control.Monad.Catch as CMC
 import Control.Monad.IO.Class (MonadIO (..))
 import Data.Foldable (forM_)
 import Data.List (isPrefixOf)
 import Data.Maybe (isJust)
-import System.Exit (
-  exitFailure,
-  exitSuccess,
- )
-
-import qualified Options.Applicative as O
-import System.Console.Haskeline as H
-
 import Disco.AST.Surface (emptyModule)
+import Disco.Effects.State
 import Disco.Error
 import Disco.Eval
 import Disco.Interactive.Commands
@@ -51,11 +41,15 @@ import Disco.Module (
  )
 import Disco.Names (ModuleName (REPLModule))
 import Disco.Pretty
-
-import Disco.Effects.State
+import qualified Options.Applicative as O
 import Polysemy
 import Polysemy.ConstraintAbsorber.MonadCatch
 import Polysemy.Error
+import System.Console.Haskeline as H
+import System.Exit (
+  exitFailure,
+  exitSuccess,
+ )
 
 ------------------------------------------------------------
 -- Command-line options parser

diff --git a/src/Polysemy/ConstraintAbsorber.hs b/src/Polysemy/ConstraintAbsorber.hs
@@ -0,0 +1,85 @@
+-- Copied from the polysemy-zoo package.
+{-
+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.
+-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+module Polysemy.ConstraintAbsorber (
+  -- * Absorb builder
+  absorbWithSem,
+
+  -- * Re-exports
+  Reifies,
+  (:-) (Sub),
+  Dict (Dict),
+  reflect,
+  Proxy (Proxy),
+) where
+
+import Data.Constraint (Dict (Dict), (:-) (Sub), (\\))
+import qualified Data.Constraint as C
+import qualified Data.Constraint.Unsafe as C
+import Data.Kind (Constraint, Type)
+import Data.Proxy (Proxy (..))
+import Data.Reflection (Reifies, reflect)
+import qualified Data.Reflection as R
+import Polysemy (Sem)
+
+------------------------------------------------------------------------------
+
+-- | This function can be used to locally introduce typeclass instances for
+-- 'Sem'. See 'Polysemy.ConstraintAbsorber.MonadState' for an example of how to
+-- use it.
+--
+-- @since 0.3.0.0
+absorbWithSem ::
+  forall
+    -- Constraint to be absorbed
+    (p :: (Type -> Type) -> Constraint)
+    -- Wrapper to avoid orphan instances
+    (x :: (Type -> Type) -> Type -> Type -> Type)
+    d
+    r
+    a.
+  -- | 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 #-}