Created
November 18, 2025 09:51
-
-
Save noughtmare/88316046b35ff396c651ecb078973eea to your computer and use it in GitHub Desktop.
Scoped Effects without Scope
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE LambdaCase #-} | |
| {-# OPTIONS_GHC -Wall -Wno-name-shadowing #-} | |
| import Control.Monad (ap) | |
| data Free f a = Pure a | Op (f (Free f a)) deriving Functor | |
| -- We do not enforce that the end references must be used, so this can be used "unsafely" in | |
| -- the sense that one or both of the scoped computations end with Pure and thus are not | |
| -- really scoped, but semantically that never changes the meaning. It only means that any | |
| -- operations that occur afterwards may be duplicated. | |
| -- | |
| -- To avoid this we could perhaps use linear types to enforce that the reference must be used | |
| -- and the only way to use the reference is to apply it to the end marker or throw operations. | |
| data Exc e ref1 ref2 f = Catch (ref1 -> f) (ref2 -> e -> f) f | Throw e ref1 | End1 ref1 | End2 ref2 | |
| deriving Functor | |
| data State f = Put Int f | Get (Int -> f) deriving Functor | |
| instance Functor f => Applicative (Free f) where | |
| pure = Pure | |
| (<*>) = ap | |
| instance Functor f => Monad (Free f) where | |
| Pure x >>= k = k x | |
| Op m >>= k = Op (fmap (>>= k) m) | |
| data (f + g) a = L (f a) | R (g a) deriving Functor | |
| data Empty a deriving Functor | |
| decr :: ref1 -> Free (State + (Exc () ref1 ref2 + Empty)) () | |
| decr r = Op $ L $ Get $ \x -> if x > 0 then (Op $ L $ Put (x - 1) $ Pure ()) else (Op $ R $ L $ Throw () r) | |
| tripleDecr :: ref1 -> Free (State + (Exc () ref1 ref2 + Empty)) () | |
| tripleDecr r = decr r >> (Op $ R $ L $ Catch (\r -> decr r >> decr r >> (Op $ R $ L $ End1 r)) (\r () -> Op $ R $ L $ End2 r) $ Pure ()) | |
| com :: (Functor f, Functor g, Functor h) => Free (f + (g + h)) a -> Free (g + (f + h)) a | |
| com (Pure x) = Pure x | |
| com (Op (L x)) = Op (R (L (fmap com x))) | |
| com (Op (R (L x))) = Op (L (fmap com x)) | |
| com (Op (R (R x))) = Op (R (R (fmap com x))) | |
| type ExcM e f a = Free f (Either e a) | |
| type ExcH e f a = Exc e (Maybe e -> ExcM e f a) (ExcM e f a) | |
| runExc :: Functor f => Free (ExcH e f a + f) a -> ExcM e f a | |
| runExc (Pure x) = Pure (Right x) | |
| runExc (Op (L (Catch a b c))) = runExc $ a $ \case | |
| Nothing -> runExc c | |
| Just x -> runExc (b (runExc c) x) | |
| runExc (Op (L (Throw x r))) = r (Just x) | |
| runExc (Op (L (End1 r))) = r Nothing | |
| runExc (Op (L (End2 r))) = r | |
| runExc (Op (R x)) = Op (fmap runExc x) | |
| type StateM f a = Int -> Free f (Int, a) | |
| type StateH f a = State | |
| runState :: Functor f => Free (StateH f a + f) a -> StateM f a | |
| runState (Pure x) s = Pure (s, x) | |
| runState (Op (L (Put s' k))) _ = runState k s' | |
| runState (Op (L (Get k))) s = runState (k s) s | |
| runState (Op (R x)) s = Op (fmap (\y -> runState y s) x) | |
| run :: Free Empty a -> a | |
| run (Pure x) = x | |
| run (Op x) = case x of {} | |
| main :: IO () | |
| main = do | |
| print (run (runExc (runState (tripleDecr (\_ -> pure (Left ()))) 2))) | |
| print (run (runState (runExc (com (tripleDecr (\_ -> pure (Left ()))))) 2)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment