Browse Source

Start trying to use the ST monad. Currently very broken.

tags/0.1.0.0
Thomas Kerber 1 year ago
parent
commit
6d91e7a9f0
Signed by: tk <tk@drwx.org> GPG Key ID: 8489B911F9ED617B
1 changed files with 65 additions and 104 deletions
  1. +65
    -104
      src/Yggdrasil/ExecutionModel.hs

+ 65
- 104
src/Yggdrasil/ExecutionModel.hs View File

@@ -19,143 +19,98 @@ module Yggdrasil.ExecutionModel
) where

import Control.Monad (ap)
import Control.Monad.ST (ST)
import Data.STRef (STRef)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
import Data.Dynamic (Dynamic, Typeable, fromDynamic,
toDyn)
import Yggdrasil.Distribution (Distribution, coin)

data World =
World [Dynamic]
[Bool]

-- | An operation is a stateful function of @('Ref, a) -> 'Action' b@ over
-- the state @s@.
type Operation s a b = (s, Ref, a) -> Action (s, b)
type Operation s c a b = (c, Ref s, a) -> Action s (c, b)

data Functionality s b =
Functionality s
(Action b)

data SendRef a b where
SendRef :: Typeable s => RealRef -> Operation s a b -> SendRef a b
(Action s b)

data RealRef =
RealRef Int
[Bool]
deriving (Eq)
data SendRef s a b = forall c. SendRef (STRef s c) (Operation s c a b)

data Ref
= Ref RealRef
data Ref s
= forall a. Ref (STRef s a)
| External
deriving (Eq)

weaken :: SendRef a b -> Ref
instance Eq (Ref s) where
External == External = True
Ref (r1::STRef s a) == Ref (r2::STRef s a) = r1 == r2

weaken :: SendRef s a b -> Ref s
weaken (SendRef ref _) = Ref ref

strengthen ::
Typeable s => World -> RealRef -> Operation s a b -> Maybe (SendRef a b)
strengthen (World [] _) _ _ = Nothing
strengthen (World _ wid) (RealRef _ wid') _
| wid /= wid' = Nothing
strengthen (World (x:_) _) ref@(RealRef 0 _) (f :: Operation s a b) = do
_ :: s <- fromDynamic x
return $ SendRef ref f
strengthen (World (_:xs) wid) wref f = do
(SendRef (RealRef i w) f') <- strengthen (World xs wid) wref f
return $ SendRef (RealRef (i + 1) w) f'

new :: Typeable s => World -> s -> (World, Ref)
new (World xs wid) s =
(World (xs ++ [toDyn s]) wid, Ref (RealRef (length xs) wid))

safeIdx :: [a] -> Int -> Maybe a
safeIdx [] _ = Nothing
safeIdx (x:_) 0 = Just x
safeIdx _ i
| i < 0 = Nothing
safeIdx (_:xs) i = safeIdx xs (i - 1)

safeWriteIdx :: [a] -> Int -> a -> Maybe [a]
safeWriteIdx [] _ _ = Nothing
safeWriteIdx (_:xs) 0 x' = Just (x' : xs)
safeWriteIdx _ i _
| i < 0 = Nothing
safeWriteIdx (x:xs) i x' = (:) x <$> safeWriteIdx xs (i - 1) x'

data Action b where
Abort :: Action b
StrengthenSelf :: Typeable s => Operation s a b -> Action (a -> Action b)
Self :: Action Ref
Sample :: Distribution b -> Action b
Send :: SendRef a b -> a -> Action b
Create :: Typeable s => Functionality s b -> Action b
Compose :: Action c -> (c -> Action b) -> Action b

abort :: Action b
abort = Abort
data Action s b = Abort | Sample (Distribution b) | forall a. Send (SendRef s a b) a | forall c. Create (Functionality c b) | forall c. Compose (Action s c) (c -> Action s b)

-- | Attempts to add a new operation on ourselves.
-- This action will fail (effectively aborting) if our state is not of type
-- 's'.
interface :: Typeable s => Operation s a b -> Action (a -> Action b)
interface = StrengthenSelf
interface' :: Typeable s => Operation s () b -> Action (Action b)
interface' op = (\f -> f ()) <$> interface op
--interface :: Operation s c a b -> Action (a -> Action b)
--interface = StrengthenSelf
--
--interface' :: Typeable s => Operation s () b -> Action (Action b)
--interface' op = (\f -> f ()) <$> interface op

self :: Action Ref
self = Self

doSample :: Distribution b -> Action b
doSample = Sample

create :: Typeable s => Functionality s b -> Action b
create = Create

instance Functor Action where
instance Functor (Action s) where
fmap f x = pure f <*> x

instance Applicative Action where
instance Applicative (Action s) where
pure = Sample . pure
(<*>) = ap

instance Monad Action where
instance Monad (Action s) where
a >>= b = Compose a b

run' :: Ref s -> Action s b -> ST s (MaybeT Distribution b)
run' _ Abort = return MaybeT $ return Nothing
run' _ (Sample d) = return $ lift d
run' from (Send (SendRef to op) msg) = do
c <- readSTRef to
(c', b) <- run' (weaken to) (op (c, from, msg))
writeSTRef to c'
return b
run' from (Create (Functionality c act)) = do
ref <- newSTRef c
run' (Ref ref) act
run' from (Compose a f) = do
c <- run' from a
run' from (f c)

-- | Execute a top-level action in the Yggdrasil execution model.
run :: Int -> Action b -> Distribution (Maybe b)
run secparam a =
runMaybeT
(do wid <- (lift . sequence) $ map (const coin) [0 .. secparam]
snd <$> run' (World [] wid) External a)

run' :: World -> Ref -> Action b -> MaybeT Distribution (World, b)
run' _ _ Abort = MaybeT $ return Nothing
run' _ External (StrengthenSelf _) = MaybeT $ return Nothing
run' wld (Ref slf) (StrengthenSelf f) =
MaybeT $ return $ (wld, ) . Send <$> strengthen wld slf f
run' wld slf Self = MaybeT $ return $ Just (wld, slf)
run' wld _ (Sample d) = lift $ (wld, ) <$> d
run' (World _ wid) _ (Send (SendRef (RealRef _ wid') _) _)
| wid /= wid' = MaybeT $ return Nothing
run' wld@(World xs _) from (Send (SendRef to@(RealRef idx _) func) m) = do
dyns <- MaybeT $ return $ safeIdx xs idx
st <- MaybeT $ return $ fromDynamic dyns
let action = func (st, from, m)
(World xs' wid', (st', y)) <- run' wld (Ref to) action
xs'' <- MaybeT $ return $ safeWriteIdx xs' idx (toDyn st')
return (World xs'' wid', y)
-- Note: This could cause a re-entrancy style bug!
run' wld _ (Create (Functionality st a)) =
let (wld', from') = new wld st
in run' wld' from' a
run' wld from (Compose a f) = do
(wld', b) <- run' wld from a
run' wld' from (f b)
--run :: Int -> Action b -> Distribution (Maybe b)
--run secparam a =
-- runMaybeT
-- (do wid <- (lift . sequence) $ map (const coin) [0 .. secparam]
-- snd <$> run' (World [] wid) External a)
--run' :: World -> Ref -> Action b -> MaybeT Distribution (World, b)
--run' _ _ Abort = MaybeT $ return Nothing
--run' _ External (StrengthenSelf _) = MaybeT $ return Nothing
--run' wld (Ref slf) (StrengthenSelf f) =
-- MaybeT $ return $ (wld, ) . Send <$> strengthen wld slf f
--run' wld slf Self = MaybeT $ return $ Just (wld, slf)
--run' wld _ (Sample d) = lift $ (wld, ) <$> d
--run' (World _ wid) _ (Send (SendRef (RealRef _ wid') _) _)
-- | wid /= wid' = MaybeT $ return Nothing
--run' wld@(World xs _) from (Send (SendRef to@(RealRef idx _) func) m) = do
-- dyns <- MaybeT $ return $ safeIdx xs idx
-- st <- MaybeT $ return $ fromDynamic dyns
-- let action = func (st, from, m)
-- (World xs' wid', (st', y)) <- run' wld (Ref to) action
-- xs'' <- MaybeT $ return $ safeWriteIdx xs' idx (toDyn st')
-- return (World xs'' wid', y)
-- -- Note: This could cause a re-entrancy style bug!
--run' wld _ (Create (Functionality st a)) =
-- let (wld', from') = new wld st
-- in run' wld' from' a
--run' wld from (Compose a f) = do
-- (wld', b) <- run' wld from a
-- run' wld' from (f b)

Loading…
Cancel
Save