FreeSTInterpreter.purs

module Main where

import Prelude

import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Control.Monad.ST.Internal (STRef)
import Control.Monad.ST.Internal as STRef
import Data.Exists (Exists, mkExists, runExists)
import Effect (Effect)
import Effect.Console (log)
import Run (Run, lift, match, runRec)
import Run as Run
import Type.Proxy (Proxy(..))
import Type.Row (type (+))

---------------------------------------------------------------

data NewF' region cb a = New' a (STRef region a -> cb)

data NewF region cb = New (Exists (NewF' region cb))

instance Functor (NewF region) where
  map fn (New ex) = runExists (\(New' a cb) -> New $ mkExists $ New' a (fn <$> cb)) ex

type NEW region r = (new :: NewF region | r)

_new = Proxy :: Proxy "new"

new :: forall a r region. a -> Run (NEW region + r) (STRef region a)
new a = Run.lift _new (New $ mkExists (New' a identity))

---------------------------------------------------------------

data ReadF' region cb a = Read' (STRef region a) (a -> cb)

data ReadF region cb = Read (Exists (ReadF' region cb))

instance Functor (ReadF region) where
  map fn (Read ex) = runExists (\(Read' ref cb) -> Read $ mkExists $ Read' ref (fn <$> cb)) ex

type READ region r = (read :: ReadF region | r)

_read = Proxy :: Proxy "read"

read :: forall a r region. STRef region a -> Run (READ region + r) a
read ref = Run.lift _read (Read $ mkExists (Read' ref identity))

---------------------------------------------------------------

data ModifyF' region cb a = Modify' (a -> a) (STRef region a) (a -> cb)

data ModifyF region cb = Modify (Exists (ModifyF' region cb))

instance Functor (ModifyF region) where
  map fn (Modify ex) = runExists (\(Modify' modfn ref cb) -> Modify $ mkExists $ Modify' modfn ref (fn <$> cb)) ex

type MODIFY region r = (modify :: ModifyF region | r)

_modify = Proxy :: Proxy "modify"

modify :: forall a r region. (a -> a) -> STRef region a -> Run (MODIFY region + r) a
modify modifyFn ref = Run.lift _modify (Modify $ mkExists (Modify' modifyFn ref identity))

---------------------------------------------------------------
handleNew :: forall region r. NewF region ~> Run (STEFFECT region + r)
handleNew (New ex) = runExists (\(New' a cb) -> cb <$> (liftST $ STRef.new a)) ex

handleRead :: forall region r. ReadF region ~> Run (STEFFECT region + r)
handleRead (Read ex) =  runExists (\(Read' ref cb) -> cb <$> (liftST $ STRef.read ref)) ex

handleModify :: forall region r. ModifyF region ~> Run (STEFFECT region + r)
handleModify (Modify ex) = runExists (\(Modify' fn ref cb) -> cb <$> (liftST $ STRef.modify fn ref)) ex

---------------------------------------------------------------

program :: forall region. Run (NEW region + READ region + MODIFY region + ()) Int
program = do
  a <- new 5
  modify (\x -> x + 5) a

interpretProgram :: forall region. Run (NEW region + READ region + MODIFY region + ()) ~> Run (STEFFECT region + ())
interpretProgram prog = prog # runRec go
  where
  go = match
    { new: handleNew
    , read: handleRead
    , modify: handleModify
    }

---------------------------------------------------------------

type STEFFECT region r = (stEffect :: ST region | r)

liftST :: forall region r. ST region ~> Run (STEFFECT region + r)
liftST = lift (Proxy :: Proxy "stEffect")

runSTEffect :: forall region. Run (STEFFECT region + ()) ~> ST region
runSTEffect = runRec $ match { stEffect: \a -> a }

interpretSTEffect :: forall a. (forall region. Run (STEFFECT region + ()) a) -> a
interpretSTEffect prog = ST.run (runSTEffect prog)

----------------------------------------------------------------

main :: Effect Unit
main = do
  log $ show $ (interpretSTEffect (interpretProgram program))