diff --git a/app/MeteorCounter/Church.hs b/app/MeteorCounter/Church.hs index d068117..b46b5bf 100644 --- a/app/MeteorCounter/Church.hs +++ b/app/MeteorCounter/Church.hs @@ -87,4 +87,4 @@ meteorsMonitoring = do L.process $ forever $ withRandomDelay $ meteorShower st SouthWest scenario :: R.CoreRuntime -> IO () -scenario coreRt = void $ R.startApp coreRt meteorsMonitoring +scenario coreRt = void $ R.startApp coreRt $ L.foreverApp meteorsMonitoring diff --git a/app/MeteorCounter/Free.hs b/app/MeteorCounter/Free.hs index a45559d..302d49c 100644 --- a/app/MeteorCounter/Free.hs +++ b/app/MeteorCounter/Free.hs @@ -87,4 +87,4 @@ meteorsMonitoring = do L.process $ forever $ withRandomDelay $ meteorShower st SouthWest scenario :: R.CoreRuntime -> IO () -scenario coreRt = void $ R.startApp coreRt meteorsMonitoring +scenario coreRt = void $ R.startApp coreRt $ L.foreverApp meteorsMonitoring diff --git a/meteor_counter.cfg b/meteor_counter.cfg index 457f2c4..e5f08f4 100644 --- a/meteor_counter.cfg +++ b/meteor_counter.cfg @@ -1,4 +1,4 @@ Config - { useLog = False - , method = FT + { useLog = True + , method = FreeM } diff --git a/src/Hydra/Core/Class.hs b/src/Hydra/Core/Class.hs new file mode 100644 index 0000000..b9ff630 --- /dev/null +++ b/src/Hydra/Core/Class.hs @@ -0,0 +1,10 @@ +module Hydra.Core.Class + ( module X + ) where + +import Hydra.Core.ControlFlow.Class as X +import Hydra.Core.Lang.Class as X +import Hydra.Core.Logger.Class as X +import Hydra.Core.Process.Class as X +import Hydra.Core.Random.Class as X +import Hydra.Core.State.Class as X diff --git a/src/Hydra/Core/Lang/ChurchL.hs b/src/Hydra/Core/Lang/ChurchL.hs index f4a0b18..f81281b 100644 --- a/src/Hydra/Core/Lang/ChurchL.hs +++ b/src/Hydra/Core/Lang/ChurchL.hs @@ -18,12 +18,13 @@ import qualified Hydra.Core.Random.Language as L import qualified Hydra.Core.State.ChurchL as CL import qualified Hydra.Core.State.Class as L import qualified Hydra.Core.State.Language as L +import qualified Hydra.Core.Lang.Class as C import Language.Haskell.TH.MakeFunctor (makeFunctorInstance) -- | Core effects container language. data LangF next where - -- -- | Eval stateful action atomically. + -- | Eval stateful action atomically. EvalStateAtomically :: CL.StateL a -> (a -> next) -> LangF next -- | Logger effect EvalLogger :: CL.LoggerL () -> (() -> next) -> LangF next @@ -31,7 +32,7 @@ data LangF next where EvalRandom :: CL.RandomL a -> (a -> next) -> LangF next -- | ControlFlow effect EvalControlFlow :: CL.ControlFlowL a -> (a -> next) -> LangF next - -- -- | Impure effect. Avoid using it in production code (it's not testable). + -- | Impure effect. Avoid using it in production code (it's not testable). EvalIO :: IO a -> (a -> next) -> LangF next makeFunctorInstance ''LangF @@ -44,33 +45,38 @@ type LangL = F LangF -- instance IOL LangL where -- evalIO io = liftF $ EvalIO io id --- | Eval stateful action atomically. -evalStateAtomically :: CL.StateL a -> LangL a -evalStateAtomically action = liftFC $ EvalStateAtomically action id +evalStateAtomically' :: L.StateL a -> LangL a +evalStateAtomically' action = liftFC $ EvalStateAtomically action id + +evalLogger' :: L.LoggerL () -> LangL () +evalLogger' logger = liftFC $ EvalLogger logger id + +evalRandom' :: L.RandomL a -> LangL a +evalRandom' g = liftFC $ EvalRandom g id + +evalControlFlow' :: L.ControlFlowL a -> LangL a +evalControlFlow' a = liftFC $ EvalControlFlow a id + +instance C.Lang L.LoggerL L.RandomL L.ControlFlowL L.StateL LangL where + evalStateAtomically = evalStateAtomically' + evalLogger = evalLogger' + evalRandom = evalRandom' + evalControlFlow = evalControlFlow' instance L.StateIO LangL where - newVarIO = evalStateAtomically . L.newVar - readVarIO = evalStateAtomically . L.readVar - writeVarIO var = evalStateAtomically . L.writeVar var - retryIO = evalStateAtomically L.retry + newVarIO = evalStateAtomically' . L.newVar + readVarIO = evalStateAtomically' . L.readVar + writeVarIO var = evalStateAtomically' . L.writeVar var + retryIO = evalStateAtomically' L.retry -instance L.Atomically CL.StateL LangL where - atomically = evalStateAtomically - -evalLogger :: CL.LoggerL () -> LangL () -evalLogger logger = liftFC $ EvalLogger logger id +instance L.Atomically L.StateL LangL where + atomically = evalStateAtomically' instance L.Logger LangL where - logMessage level msg = evalLogger $ L.logMessage level msg - -evalRandom :: CL.RandomL a -> LangL a -evalRandom g = liftFC $ EvalRandom g id + logMessage level msg = evalLogger' $ L.logMessage level msg instance L.Random LangL where - getRandomInt = evalRandom . L.getRandomInt - -evalControlFlow :: CL.ControlFlowL a -> LangL a -evalControlFlow a = liftFC $ EvalControlFlow a id + getRandomInt = evalRandom' . L.getRandomInt instance L.ControlFlow LangL where - delay i = evalControlFlow $ L.delay i + delay i = evalControlFlow' $ L.delay i diff --git a/src/Hydra/Core/Lang/Class.hs b/src/Hydra/Core/Lang/Class.hs new file mode 100644 index 0000000..1cd6bde --- /dev/null +++ b/src/Hydra/Core/Lang/Class.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Hydra.Core.Lang.Class where + +import Hydra.Prelude + +import qualified Hydra.Core.ControlFlow.Class as C +import qualified Hydra.Core.Random.Class as C +import qualified Hydra.Core.Logger.Class as C +import qualified Hydra.Core.State.Class as C +import qualified Hydra.Core.Domain as D + +import Language.Haskell.TH.MakeFunctor (makeFunctorInstance) + +class (C.Logger l, C.Random r, C.ControlFlow cf, C.State' s, Monad m) => Lang l r cf s m + | m -> l, m -> r, m -> cf, m -> s where + evalLogger :: l () -> m () + evalRandom :: r a -> m a + evalStateAtomically :: s a -> m a + evalControlFlow :: cf a -> m a + -- todo: io diff --git a/src/Hydra/Core/Lang/Language.hs b/src/Hydra/Core/Lang/Language.hs index d1591b2..7b32355 100644 --- a/src/Hydra/Core/Lang/Language.hs +++ b/src/Hydra/Core/Lang/Language.hs @@ -14,6 +14,7 @@ import qualified Hydra.Core.Random.Class as L import qualified Hydra.Core.Random.Language as L import qualified Hydra.Core.State.Class as L import qualified Hydra.Core.State.Language as L +import qualified Hydra.Core.Lang.Class as C import Language.Haskell.TH.MakeFunctor (makeFunctorInstance) @@ -40,33 +41,38 @@ class IOL m where instance IOL LangL where evalIO io = liftF $ EvalIO io id --- | Eval stateful action atomically. -evalStateAtomically :: L.StateL a -> LangL a -evalStateAtomically action = liftF $ EvalStateAtomically action id +evalStateAtomically' :: L.StateL a -> LangL a +evalStateAtomically' action = liftF $ EvalStateAtomically action id + +evalLogger' :: L.LoggerL () -> LangL () +evalLogger' logger = liftF $ EvalLogger logger id + +evalRandom' :: L.RandomL a -> LangL a +evalRandom' g = liftF $ EvalRandom g id + +evalControlFlow' :: L.ControlFlowL a -> LangL a +evalControlFlow' a = liftF $ EvalControlFlow a id + +instance C.Lang L.LoggerL L.RandomL L.ControlFlowL L.StateL LangL where + evalStateAtomically = evalStateAtomically' + evalLogger = evalLogger' + evalRandom = evalRandom' + evalControlFlow = evalControlFlow' instance L.StateIO LangL where - newVarIO = evalStateAtomically . L.newVar - readVarIO = evalStateAtomically . L.readVar - writeVarIO var = evalStateAtomically . L.writeVar var - retryIO = evalStateAtomically L.retry + newVarIO = evalStateAtomically' . L.newVar + readVarIO = evalStateAtomically' . L.readVar + writeVarIO var = evalStateAtomically' . L.writeVar var + retryIO = evalStateAtomically' L.retry instance L.Atomically L.StateL LangL where - atomically = evalStateAtomically - -evalLogger :: L.LoggerL () -> LangL () -evalLogger logger = liftF $ EvalLogger logger id + atomically = evalStateAtomically' instance L.Logger LangL where - logMessage level msg = evalLogger $ L.logMessage level msg - -evalRandom :: L.RandomL a -> LangL a -evalRandom g = liftF $ EvalRandom g id + logMessage level msg = evalLogger' $ L.logMessage level msg instance L.Random LangL where - getRandomInt = evalRandom . L.getRandomInt - -evalControlFlow :: L.ControlFlowL a -> LangL a -evalControlFlow a = liftF $ EvalControlFlow a id + getRandomInt = evalRandom' . L.getRandomInt instance L.ControlFlow LangL where - delay i = evalControlFlow $ L.delay i + delay i = evalControlFlow' $ L.delay i diff --git a/src/Hydra/Core/Process/ChurchL.hs b/src/Hydra/Core/Process/ChurchL.hs index d03d58e..c26c4b4 100644 --- a/src/Hydra/Core/Process/ChurchL.hs +++ b/src/Hydra/Core/Process/ChurchL.hs @@ -7,21 +7,22 @@ import Hydra.Prelude import qualified Hydra.Core.Domain as D import qualified Hydra.Core.Process.Language as L +import Hydra.Core.Process.Class -type ProcessL m' = F (L.ProcessF m') +type ProcessL m = F (L.ProcessF m) -- | Fork a process. -forkProcess :: m' a -> ProcessL m' (D.ProcessPtr a) -forkProcess action = liftFC $ L.ForkProcess action id +forkProcess' :: m a -> ProcessL m (D.ProcessPtr a) +forkProcess' action = liftFC $ L.ForkProcess action id -- | Hardly kill a process. -killProcess :: D.ProcessPtr a -> ProcessL m' () -killProcess processPtr = liftFC $ L.KillProcess processPtr id +killProcess' :: D.ProcessPtr a -> ProcessL m () +killProcess' processPtr = liftFC $ L.KillProcess processPtr id -- | Try get result from a process (non-blocking). -tryGetResult :: D.ProcessPtr a -> ProcessL m' (Maybe a) -tryGetResult handle = liftFC $ L.TryGetResult handle id +tryGetResult' :: D.ProcessPtr a -> ProcessL m (Maybe a) +tryGetResult' handle = liftFC $ L.TryGetResult handle id -- | Await for result from a process (blocking). -awaitResult :: D.ProcessPtr a -> ProcessL m' a -awaitResult handle = liftFC $ L.AwaitResult handle id +awaitResult' :: D.ProcessPtr a -> ProcessL m a +awaitResult' handle = liftFC $ L.AwaitResult handle id diff --git a/src/Hydra/Core/Process/Class.hs b/src/Hydra/Core/Process/Class.hs new file mode 100644 index 0000000..a13ea6a --- /dev/null +++ b/src/Hydra/Core/Process/Class.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Hydra.Core.Process.Class where + +import Hydra.Prelude + +import qualified Hydra.Core.Domain as D + +class (Monad m) => Process lang m | m -> lang where + forkProcess :: lang a -> m (D.ProcessPtr a) + killProcess :: D.ProcessPtr a -> m () + tryGetResult :: D.ProcessPtr a -> m (Maybe a) + awaitResult :: D.ProcessPtr a -> m a diff --git a/src/Hydra/Core/Process/Language.hs b/src/Hydra/Core/Process/Language.hs index 2ae7869..0435908 100644 --- a/src/Hydra/Core/Process/Language.hs +++ b/src/Hydra/Core/Process/Language.hs @@ -28,10 +28,6 @@ instance Functor (ProcessF m') where type ProcessL m' = Free (ProcessF m') --- class Process m' m where --- process :: m' () -> m () --- fork :: m' a -> m (D.ProcessPtr a) - -- | Fork a process. forkProcess :: m' a -> ProcessL m' (D.ProcessPtr a) forkProcess action = liftF $ ForkProcess action id diff --git a/src/Hydra/Core/Random/Class.hs b/src/Hydra/Core/Random/Class.hs index b593bba..8425da6 100644 --- a/src/Hydra/Core/Random/Class.hs +++ b/src/Hydra/Core/Random/Class.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} module Hydra.Core.Random.Class where @@ -7,4 +6,4 @@ module Hydra.Core.Random.Class where import Hydra.Prelude class Monad m => Random m where - getRandomInt :: (Int, Int) -> m Int + getRandomInt :: (Int, Int) -> m Int diff --git a/src/Hydra/Framework/App/ChurchL.hs b/src/Hydra/Framework/App/ChurchL.hs index 0cf8617..148560b 100644 --- a/src/Hydra/Framework/App/ChurchL.hs +++ b/src/Hydra/Framework/App/ChurchL.hs @@ -7,6 +7,7 @@ module Hydra.Framework.App.ChurchL where import Hydra.Prelude import qualified Hydra.Core.ChurchL as L +import qualified Hydra.Core.Class as C import qualified Hydra.Core.Domain as D import Language.Haskell.TH.MakeFunctor (makeFunctorInstance) @@ -30,26 +31,28 @@ evalLang action = liftFC $ EvalLang action id scenario :: L.LangL a -> AppL a scenario = evalLang --- | Eval process. -evalProcess :: L.ProcessL L.LangL a -> AppL a +evalProcess :: L.ProcessL L.Lang a -> AppL a evalProcess action = liftF $ EvalProcess action id +instance C.Process L.LangL AppL where + forkProcess = evalProcess . L.forkProcess' + killProcess = evalProcess . L.killProcess' + tryGetResult = evalProcess . L.tryGetResult' + awaitResult = evalProcess . L.awaitResult' + -- | Fork a process and keep the Process Ptr. fork :: L.LangL a -> AppL (D.ProcessPtr a) -fork action = evalProcess (L.forkProcess action) +fork action = evalProcess (L.forkProcess' action) -- | Fork a process and forget. process :: L.LangL a -> AppL () process action = void $ fork action --- instance L.IOL AppL where --- evalIO = evalLang . L.evalIO - instance L.StateIO AppL where - newVarIO = evalLang . L.newVarIO - readVarIO = evalLang . L.readVarIO - writeVarIO var = evalLang . L.writeVarIO var - retryIO = evalLang L.retryIO + newVarIO = evalLang . L.newVarIO + readVarIO = evalLang . L.readVarIO + writeVarIO var = evalLang . L.writeVarIO var + retryIO = evalLang L.retryIO instance L.Atomically L.StateL AppL where atomically = evalLang . L.atomically diff --git a/src/Hydra/Framework/App/Class.hs b/src/Hydra/Framework/App/Class.hs new file mode 100644 index 0000000..d3b5316 --- /dev/null +++ b/src/Hydra/Framework/App/Class.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Hydra.Framework.App.Class where + +import Hydra.Prelude + +import qualified Hydra.Core.Class as C +import qualified Hydra.Core.Domain as D + +import Language.Haskell.TH.MakeFunctor (makeFunctorInstance) + +class (C.Process lang proc, Monad m) => App m where + evalLang :: lang a -> m a + evalProcess :: proc a -> m a diff --git a/src/Hydra/Framework/App/Language.hs b/src/Hydra/Framework/App/Language.hs index 33e33d2..76f0506 100644 --- a/src/Hydra/Framework/App/Language.hs +++ b/src/Hydra/Framework/App/Language.hs @@ -8,6 +8,7 @@ import Hydra.Prelude import qualified Hydra.Core.Domain as D import qualified Hydra.Core.Language as L +import qualified Hydra.Core.Class as C import Language.Haskell.TH.MakeFunctor (makeFunctorInstance) @@ -34,6 +35,15 @@ scenario = evalLang evalProcess :: L.ProcessL L.LangL a -> AppL a evalProcess action = liftF $ EvalProcess action id +instance C.Process L.LangL AppL where + forkProcess = evalProcess . L.forkProcess' + killProcess = evalProcess . L.killProcess' + tryGetResult = evalProcess . L.tryGetResult' + awaitResult = evalProcess . L.awaitResult' + +process :: L.LangL a -> AppL () +process action = void $ forkProcess action + -- | Fork a process and keep the Process Ptr. fork :: L.LangL a -> AppL (D.ProcessPtr a) fork action = evalProcess (L.forkProcess action) diff --git a/src/Hydra/Language/Extra.hs b/src/Hydra/Language/Extra.hs index c0d919a..ab45fe9 100644 --- a/src/Hydra/Language/Extra.hs +++ b/src/Hydra/Language/Extra.hs @@ -6,19 +6,35 @@ module Hydra.Language.Extra where import Hydra.Prelude import qualified Hydra.Core.Language as L +import qualified Hydra.Core.ChurchL as CL import qualified Hydra.Domain as D import qualified Hydra.Framework.Language as L +import qualified Hydra.Framework.ChurchL as L +class App m => ForeverApp m where + foreverApp :: m a -> m () +instance ForeverApp L.LangL where + foreverApp app = do + app -foreverApp :: L.AppL a -> L.AppL () -foreverApp app = do - app + awaitVar <- L.newVarIO (1 :: Int) + L.process $ do + L.delay 10000000000 + L.writeVarIO awaitVar 1 + L.atomically $ do + x <- L.readVar awaitVar + when (x == 1) L.retry - awaitVar <- L.newVarIO (1 :: Int) - L.process $ do - L.delay 10000000000 - L.writeVarIO awaitVar 1 - L.atomically $ do - x <- L.readVar awaitVar - when (x == 1) L.retry +instance ForeverApp CL.LangL where + foreverApp :: CL.AppL a -> CL.AppL () + foreverApp app = do + app + + awaitVar <- CL.newVarIO (1 :: Int) + CL.process $ do + CL.delay 10000000000 + CL.writeVarIO awaitVar 1 + CL.atomically $ do + x <- CL.readVar awaitVar + when (x == 1) CL.retry