From 4328872ebe8c230be020f1c1310e071ca9094a4d Mon Sep 17 00:00:00 2001
From: Andrei Borzenkov <andreyborzenkov2002@gmail.com>
Date: Fri, 5 May 2023 20:57:49 +0400
Subject: [PATCH] Update Eff to make it work with GHC 9.6

Problem:
    Delcont api used in the library incompalible with the one
    implemented in upstream GHC, so eff just doesn't compile

Solution:
    Previous primitive semantic was build in that each control0#
    captures continuation to nearest prompt#, so having one PromptTag#
    for all prompt#'s seems to be a simple drop-in replacement.
---
 cabal.project                      | 16 ----------------
 eff/src/Control/Effect/Internal.hs | 15 +++++++++++----
 2 files changed, 11 insertions(+), 20 deletions(-)

diff --git a/cabal.project b/cabal.project
index b94de9e..acb1742 100644
--- a/cabal.project
+++ b/cabal.project
@@ -1,22 +1,6 @@
 packages: eff
 jobs: $ncpus
 
-repository head.hackage.ghc.haskell.org
-  url: https://ghc.gitlab.haskell.org/head.hackage/
-  secure: True
-  key-threshold: 3
-  root-keys:
-    f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89
-    26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
-    7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d
-
-allow-newer:
-  primitive-0.7.0.1:base
-  splitmix-0.0.5:base
-
-constraints:
-  primitive ==0.7.0.1,
-  QuickCheck ==2.13.2 || ==2.14
 
 package *
   optimization: 2
diff --git a/eff/src/Control/Effect/Internal.hs b/eff/src/Control/Effect/Internal.hs
index a9ec395..e5849dd 100644
--- a/eff/src/Control/Effect/Internal.hs
+++ b/eff/src/Control/Effect/Internal.hs
@@ -23,9 +23,9 @@ import Data.IORef
 import Data.Kind (Constraint, Type)
 import Data.Type.Coercion (Coercion(..), gcoerceWith)
 import Data.Type.Equality ((:~:)(..), gcastWith)
-import GHC.Exts (Any, Int(..), Int#, RealWorld, RuntimeRep(..), SmallArray#, State#, TYPE, prompt#, control0#)
+import GHC.Exts (Any, Int(..), Int#, RealWorld, RuntimeRep(..), SmallArray#, State#, TYPE, prompt#, control0#, PromptTag#, newPromptTag#)
 import GHC.Types (IO(..))
-import System.IO.Unsafe (unsafeDupablePerformIO)
+import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO)
 import Unsafe.Coerce (unsafeCoerce)
 
 import Control.Effect.Internal.Debug
@@ -268,6 +268,13 @@ captureVM a = gcoerceWith (Coercion.sym $ anyCo @a) $
   IO.throwIO $! UnwindControl (coerce a)
 {-# INLINE captureVM #-}
 
+data PromptTag a = MkPromptTag {unPromptTag :: PromptTag# a}
+
+globalPromptTag :: PromptTag a
+globalPromptTag = unsafePerformIO $ IO \s1 -> case newPromptTag# s1 of
+  (# s2, pt #) -> (#s2, MkPromptTag pt #)
+{-# NOINLINE globalPromptTag #-}
+
 -- | Runs an 'EVM' action with a new prompt installed. The arguments specify
 -- what happens when control exits the action.
 promptVM
@@ -283,7 +290,7 @@ promptVM
 promptVM m onReturn onAbort onControl = IO.handle handleUnwind do
   -- TODO: Explain why it is crucial that the exception handler is installed
   -- outside of the frame where we replace the registers!
-  Result _ a <- IO (prompt# (unIO (packIOResult m)))
+  Result _ a <- IO (prompt# (unPromptTag globalPromptTag) (unIO (packIOResult m)))
   onReturn a
   where
     handleUnwind (UnwindAbort pid a) = onAbort pid a
@@ -307,7 +314,7 @@ promptVM_ m rs onCapture = promptVM m onReturn rethrowAbort onCapture where
 {-# INLINE promptVM_ #-}
 
 controlVM :: ((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
-controlVM f = IO (control0# f#) <&> \(Result rs a) -> (BoxRegisters rs, a) where
+controlVM f = IO (control0# (unPromptTag globalPromptTag) f#) <&> \(Result rs a) -> (BoxRegisters rs, a) where
   f# k# = unIO (f k <&> \(BoxRegisters rs, a) -> Result rs a) where
     k a = EVM# \rs -> IO $ k# \s -> (# s, Result rs a #)
 {-# INLINE controlVM #-}