Browse Source

Using ST! But interfaces died...

tags/0.1.0.0
Thomas Kerber 1 year ago
parent
commit
7e278cfe05
Signed by: Thomas Kerber <t.kerber@ed.ac.uk> GPG Key ID: 8489B911F9ED617B
2 changed files with 79 additions and 57 deletions
  1. +31
    -6
      src/Yggdrasil/Distribution.hs
  2. +48
    -51
      src/Yggdrasil/ExecutionModel.hs

+ 31
- 6
src/Yggdrasil/Distribution.hs View File

@@ -3,19 +3,22 @@
{-# LANGUAGE TupleSections #-}

module Yggdrasil.Distribution
( Distribution
( Distribution(Distribution)
, DistributionT(DistributionT, runDistT)
, Sampler
, sample
, sample'
, coin
, uniform
, liftDistribution
) where

import Control.Monad (ap)
import Crypto.Random (SystemDRG, randomBytesGenerate)
import Data.Bits ((.&.))
import qualified Data.ByteArray as B
import Data.Maybe (fromJust)
import Control.Monad (ap)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Crypto.Random (SystemDRG, randomBytesGenerate)
import Data.Bits ((.&.))
import qualified Data.ByteArray as B
import Data.Maybe (fromJust)

newtype Distribution b =
Distribution (forall s. Sampler s =>
@@ -36,6 +39,28 @@ instance Monad Distribution where
(b', s'') = sample s' (b a')
in (b', s''))

newtype DistributionT m b = DistributionT
{ runDistT :: forall s. Sampler s =>
s -> m (b, s)
}

instance Monad m => Functor (DistributionT m) where
fmap f x = pure f <*> x

instance Monad m => Applicative (DistributionT m) where
pure x = DistributionT $ pure . (x, )
(<*>) = ap

instance Monad m => Monad (DistributionT m) where
a >>= b =
DistributionT (\s -> (runDistT a) s >>= (\(a', s') -> (runDistT (b a')) s'))

instance MonadTrans DistributionT where
lift m = DistributionT $ \s -> (, s) <$> m

liftDistribution :: Monad m => Distribution b -> DistributionT m b
liftDistribution d = DistributionT $ \s -> return $ sample s d

class Sampler s where
sampleCoin :: s -> (Bool, s)


+ 48
- 51
src/Yggdrasil/ExecutionModel.hs View File

@@ -1,7 +1,8 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Yggdrasil.ExecutionModel
( Operation
@@ -9,46 +10,54 @@ module Yggdrasil.ExecutionModel
, Action
, Functionality(..)
, weaken
, abort
, interface
, interface'
, self
, doSample
, create
, run
) where

import Control.Monad (ap)
import Control.Monad.ST (ST)
import Data.STRef (STRef)
import Control.Monad.ST (ST, runST)
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)
import Data.STRef (STRef, newSTRef, readSTRef,
writeSTRef)
import Yggdrasil.Distribution (Distribution, DistributionT (DistributionT, runDistT),
liftDistribution)

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

data Functionality s b =
Functionality s
data Functionality s c b =
Functionality c
(Action s b)

data SendRef s a b = forall c. SendRef (STRef s c) (Operation s c a b)
type ID s = STRef s ()

data SendRef s a b =
forall c. SendRef (STRef s c)
(ID s)
(Operation s c a b)

data Ref s
= forall a. Ref (STRef s a)
(ID s)
| External

instance Eq (Ref s) where
External == External = True
Ref (r1::STRef s a) == Ref (r2::STRef s a) = r1 == r2
Ref _ a == Ref _ b = a == b
_ == _ = False

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

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)
data Action s b
= Abort
| Sample (Distribution b)
| forall a. Send (SendRef s a b)
a
| forall c. Create (Functionality s 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
@@ -58,7 +67,6 @@ data Action s b = Abort | Sample (Distribution b) | forall a. Send (SendRef s a
--
--interface' :: Typeable s => Operation s () b -> Action (Action b)
--interface' op = (\f -> f ()) <$> interface op

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

@@ -69,48 +77,20 @@ instance Applicative (Action s) 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)

--run :: Int -> Action b -> Distribution (Maybe b)
--run secparam 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) =
--run' wld slf Self = MaybeT $ return $ Just (wld, slf)
--run' wld _ (Sample d) = lift $ (wld, ) <$> d
--run' (World _ wid) _ (Send (SendRef (RealRef _ wid') _) _)
--run' wld@(World xs _) from (Send (SendRef to@(RealRef idx _) func) m) = do
--run' wld _ (Create (Functionality st a)) =
--run' wld from (Compose a f) = do
run :: (forall s. Action s b) -> DistributionT Maybe b
run a =
DistributionT $ \rng -> runST $ runMaybeT $ runDistT (run' External a) rng

run' :: Ref s -> Action s b -> DistributionT (MaybeT (ST s)) b
run' _ Abort = DistributionT $ \_ -> MaybeT $ return Nothing
run' _ (Sample d) = liftDistribution d
run' from (Send to@(SendRef (ptr :: STRef s c) _ op) msg) = do
c <- lift . lift $ readSTRef ptr
(c', b) <- run' (weaken to) (op c from msg)
lift . lift $ writeSTRef ptr c'
return b
run' _ (Create (Functionality c a)) = do
ptr <- lift . lift $ newSTRef c
id' <- lift . lift $ newSTRef ()
run' (Ref ptr id') a
run' from (Compose a f) = run' from a >>= run' from . f

Loading…
Cancel
Save