Browse Source

Hlint.

tags/0.1.0.0
Thomas Kerber 1 year ago
parent
commit
489b9a2c1e
Signed by: Thomas Kerber <tk@drwx.org> GPG Key ID: 8489B911F9ED617B
4 changed files with 20 additions and 12 deletions
  1. +5
    -2
      src/Yggdrasil/Distribution.hs
  2. +12
    -7
      src/Yggdrasil/ExecutionModel.hs
  3. +2
    -2
      src/Yggdrasil/Functionalities.hs
  4. +1
    -1
      tests/ExecTests.hs

+ 5
- 2
src/Yggdrasil/Distribution.hs View File

@@ -1,4 +1,7 @@
{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses,
ExistentialQuantification,
Rank2Types,
TupleSections #-}

module Yggdrasil.Distribution (Distribution, sample) where

@@ -13,7 +16,7 @@ sample g (Distribution f) = f g
instance Functor Distribution where
fmap f x = pure f <*> x
instance Applicative Distribution where
pure x = Distribution (\g -> (x, g))
pure x = Distribution (x,)
(<*>) = ap
instance Monad Distribution where
a >>= b = Distribution (\g ->

+ 12
- 7
src/Yggdrasil/ExecutionModel.hs View File

@@ -1,4 +1,9 @@
{-# LANGUAGE TypeFamilies, GADTs, FlexibleContexts, ConstraintKinds, ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies,
GADTs,
FlexibleContexts,
ConstraintKinds,
ScopedTypeVariables,
TupleSections #-}

module Yggdrasil.ExecutionModel (
Operation, TypOperation, TypFunctionality, Ref, WeakRef, Action,
@@ -68,7 +73,7 @@ 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' = fmap ((:) x) $ safeWriteIdx xs (i-1) x'
safeWriteIdx (x:xs) i x' = (:) x <$> safeWriteIdx xs (i-1) x'

data Action b where
Abort :: Action b
@@ -113,22 +118,22 @@ instance Monad Action where

-- | Execute a top-level action in the Yggdrasil execution model.
run :: RandomGen g => g -> Action b -> Maybe (b, g)
run g a = fmap (\(_, b, g') -> (b, g')) $ run' g (World []) external a
run g a = (\(_, b, g') -> (b, g')) <$> run' g (World []) external a

run' :: RandomGen g =>
g -> World -> WeakRef -> Action b -> Maybe (World, b, g)
run' _ _ _ Abort = Nothing
run' g wld slf (StrengthenSelf f) =
fmap (\r -> (wld, r, g)) (strengthen wld slf f)
(wld, , g) <$> strengthen wld slf f
run' g wld slf Self = Just (wld, slf, g)
run' g wld _ (Sample d) = let (y, g') = sample g d in Just (wld, y, g')
run' g (World xs) from (Send to m) = do
dyns <- safeIdx xs (index to)
s <- fromDynamic dyns
let action = (func to) (s, from, m)
(World (xs'), (s', y), g') <- run' g (World xs) (weaken to) action
let action = func to (s, from, m)
(World xs', (s', y), g') <- run' g (World xs) (weaken to) action
xs'' <- safeWriteIdx xs' (index to) (toDyn s')
return $ (World xs'', y, g')
return (World xs'', y, g')
-- Note: This could cause a re-entrancy style bug!
run' g wld _ (Create (Functionality s a)) =
let (wld', from') = new wld s in run' g wld' from' a

+ 2
- 2
src/Yggdrasil/Functionalities.hs View File

@@ -9,8 +9,8 @@ import Yggdrasil.Distribution

type CRSState b = Maybe b
crsOp :: Distribution b -> Operation (CRSState b) () b
crsOp _ ((Just x), _, ()) = return (Just x, x)
crsOp d (Nothing, _, ()) = fmap (\x -> (Just x, x)) $ doSample d
crsOp _ (Just x, _, ()) = return (Just x, x)
crsOp d (Nothing, _, ()) = (\x -> (Just x, x)) <$> doSample d
commonRandomString :: Typeable b =>
Distribution b -> Functionality (CRSState b) (Ref (CRSState b) () b)
commonRandomString d = Functionality Nothing (strengthenSelf (crsOp d))

+ 1
- 1
tests/ExecTests.hs View File

@@ -8,7 +8,7 @@ import Test.Hspec.QuickCheck
import Yggdrasil.ExecutionModel

spec :: Spec
spec = do
spec =
describe "action" $ do
prop "obeys return" $ \i (x::String) ->
fst (run (mkStdGen i) (return x)) == Just x

Loading…
Cancel
Save