Classes for Lang and App experiment.

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

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

meteor_counter.cfg

@@ -1,4 +1,4 @@
 Config
-  { useLog = False
+  { useLog = True
-  , method = FT
+  , method = FreeM
   }

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

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' :: L.StateL a -> LangL a
-evalStateAtomically :: CL.StateL a -> LangL a
+evalStateAtomically' action = liftFC $ EvalStateAtomically action id
-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
+  newVarIO       = evalStateAtomically' . L.newVar
-  readVarIO      = evalStateAtomically . L.readVar
+  readVarIO      = evalStateAtomically' . L.readVar
-  writeVarIO var = evalStateAtomically . L.writeVar var
+  writeVarIO var = evalStateAtomically' . L.writeVar var
-  retryIO        = evalStateAtomically L.retry
+  retryIO        = evalStateAtomically' L.retry
 
-instance L.Atomically CL.StateL LangL where
+instance L.Atomically L.StateL LangL where
-  atomically = evalStateAtomically
+  atomically = evalStateAtomically'
-
-evalLogger :: CL.LoggerL () -> LangL ()
-evalLogger logger = liftFC $ EvalLogger logger id
 
 instance L.Logger LangL where
-  logMessage level msg = evalLogger $ L.logMessage level msg
+  logMessage level msg = evalLogger' $ L.logMessage level msg
-
-evalRandom :: CL.RandomL a -> LangL a
-evalRandom g = liftFC $ EvalRandom g id
 
 instance L.Random LangL where
-  getRandomInt = evalRandom . L.getRandomInt
+  getRandomInt = evalRandom' . L.getRandomInt
-
-evalControlFlow :: CL.ControlFlowL a -> LangL a
-evalControlFlow a = liftFC $ EvalControlFlow a id
 
 instance L.ControlFlow LangL where
-  delay i = evalControlFlow $ L.delay i
+  delay i = evalControlFlow' $ L.delay i

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

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 :: L.StateL a -> LangL a
+evalStateAtomically' action = liftF $ EvalStateAtomically action id
-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
+  newVarIO       = evalStateAtomically' . L.newVar
-  readVarIO      = evalStateAtomically . L.readVar
+  readVarIO      = evalStateAtomically' . L.readVar
-  writeVarIO var = evalStateAtomically . L.writeVar var
+  writeVarIO var = evalStateAtomically' . L.writeVar var
-  retryIO        = evalStateAtomically L.retry
+  retryIO        = evalStateAtomically' L.retry
 
 instance L.Atomically L.StateL LangL where
-  atomically = evalStateAtomically
+  atomically = evalStateAtomically'
-
-evalLogger :: L.LoggerL () -> LangL ()
-evalLogger logger = liftF $ EvalLogger logger id
 
 instance L.Logger LangL where
-  logMessage level msg = evalLogger $ L.logMessage level msg
+  logMessage level msg = evalLogger' $ L.logMessage level msg
-
-evalRandom :: L.RandomL a -> LangL a
-evalRandom g = liftF $ EvalRandom g id
 
 instance L.Random LangL where
-  getRandomInt = evalRandom . L.getRandomInt
+  getRandomInt = evalRandom' . L.getRandomInt
-
-evalControlFlow :: L.ControlFlowL a -> LangL a
-evalControlFlow a = liftF $ EvalControlFlow a id
 
 instance L.ControlFlow LangL where
-  delay i = evalControlFlow $ L.delay i
+  delay i = evalControlFlow' $ L.delay i

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' :: m a -> ProcessL m (D.ProcessPtr a)
-forkProcess action = liftFC $ L.ForkProcess action id
+forkProcess' action = liftFC $ L.ForkProcess action id
 
 -- | Hardly kill a process.
-killProcess :: D.ProcessPtr a -> ProcessL m' ()
+killProcess' :: D.ProcessPtr a -> ProcessL m ()
-killProcess processPtr = liftFC $ L.KillProcess processPtr id
+killProcess' processPtr = liftFC $ L.KillProcess processPtr id
 
 -- | Try get result from a process (non-blocking).
-tryGetResult :: D.ProcessPtr a -> ProcessL m' (Maybe a)
+tryGetResult' :: D.ProcessPtr a -> ProcessL m (Maybe a)
-tryGetResult handle = liftFC $ L.TryGetResult handle id
+tryGetResult' handle = liftFC $ L.TryGetResult handle id
 
 -- | Await for result from a process (blocking).
-awaitResult :: D.ProcessPtr a -> ProcessL m' a
+awaitResult' :: D.ProcessPtr a -> ProcessL m a
-awaitResult handle = liftFC $ L.AwaitResult handle id
+awaitResult' handle = liftFC $ L.AwaitResult handle id

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

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

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

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.Lang a -> AppL a
-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'
+
 -- | 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
+  newVarIO       = evalLang . L.newVarIO
-    readVarIO      = evalLang . L.readVarIO
+  readVarIO      = evalLang . L.readVarIO
-    writeVarIO var = evalLang . L.writeVarIO var
+  writeVarIO var = evalLang . L.writeVarIO var
-    retryIO        = evalLang L.retryIO
+  retryIO        = evalLang L.retryIO
 
 instance L.Atomically L.StateL AppL where
   atomically = evalLang . L.atomically

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

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)

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 ()
+    awaitVar <- L.newVarIO (1 :: Int)
-foreverApp app = do
+    L.process $ do
-  app
+      L.delay 10000000000
+      L.writeVarIO awaitVar 1
+    L.atomically $ do
+      x <- L.readVar awaitVar
+      when (x == 1) L.retry
 
-  awaitVar <- L.newVarIO (1 :: Int)
+instance ForeverApp CL.LangL where
-  L.process $ do
+  foreverApp :: CL.AppL a -> CL.AppL ()
-    L.delay 10000000000
+  foreverApp app = do
-    L.writeVarIO awaitVar 1
+    app
-  L.atomically $ do
+
-    x <- L.readVar awaitVar
+    awaitVar <- CL.newVarIO (1 :: Int)
-    when (x == 1) L.retry
+    CL.process $ do
+      CL.delay 10000000000
+      CL.writeVarIO awaitVar 1
+    CL.atomically $ do
+      x <- CL.readVar awaitVar
+      when (x == 1) CL.retry