Skip to content

Instantly share code, notes, and snippets.

@LSLeary
Forked from VictorTaelin/collapse_monad.hs
Last active November 19, 2024 09:08
Show Gist options
  • Save LSLeary/65b3b7e2ffbd5d613500ef120b9e361a to your computer and use it in GitHub Desktop.
Save LSLeary/65b3b7e2ffbd5d613500ef120b9e361a to your computer and use it in GitHub Desktop.
{-# LANGUAGE LambdaCase #-}
module Collapse where
-- base
import Data.Functor ((<&>))
import Data.Functor.Classes (Show1)
import Data.Foldable (toList)
import Control.Monad (ap)
-- containers
import Data.IntMap.Strict qualified as I
-- The 'Collapse' monad can be written as the free monad of the signature
-- functor 'Sup' with the handler 'collapse'; the non-determinism of 'sup'
-- is /algebraic/.
--
-- This implies 'Collapse' can be implemented efficiently via delimited
-- control primops.
data Sup s = Sup Int s s
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
sup :: Int -> Free Sup a -> Free Sup a -> Free Sup a
sup i l r = Op (Sup i l r)
collapse :: Free Sup a -> Free Sup a
collapse act = iter alg (const . pure <$> act) I.empty
where
alg :: Sup (I.IntMap Bool -> Free Sup a) -> I.IntMap Bool -> Free Sup a
alg (Sup i l r) m = case I.lookup i m of
Nothing -> sup i (l (I.insert i False m))
(r (I.insert i True m))
Just False -> l m
Just True -> r m
flatten :: Free Sup a -> [a]
flatten = toList
-----------------------------
-- free:Control.Monad.Free --
-----------------------------
data Free f a = Pure a | Op (f (Free f a))
deriving (Functor, Foldable, Traversable)
deriving instance (Show1 f, Show a) => Show (Free f a)
instance Functor f => Applicative (Free f) where
pure = Pure
(<*>) = ap
instance Functor f => Monad (Free f) where
Pure x >>= g = g x
Op fmx >>= g = Op (fmx <&> (>>= g))
iter :: Functor f => (f a -> a) -> Free f a -> a
iter alg = \case
Pure x -> x
Op fmx -> alg (fmx <&> iter alg)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment