Additional perf testing app added

app/PerfTestApp/FTL.hs

@@ -16,6 +16,8 @@ import           Types
 
 import           Hydra.FTLI    ()
 
+-- TODO: join this with the FT approach in the MeteorCounter app
+
 getRandomMeteor :: FTL.RandomL m => m Meteor
 getRandomMeteor = Meteor <$> FTL.getRandomInt (1, 100)
 

app/PerfTestApp2/Church.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Church where
+
+import           Control.Monad
+import qualified Data.Map      as Map
+import qualified Data.Set      as Set
+import           Hydra.Prelude
+
+import qualified Hydra.ChurchL  as L
+import qualified Hydra.Domain  as D
+import qualified Hydra.Runtime as R
+
+
+flow :: IORef Int -> L.AppL ()
+flow ref = L.scenario $ do
+  val' <- L.evalIO $ readIORef ref
+  val  <- L.getRandomInt (1, 100)
+  L.evalIO $ writeIORef ref $ val' + val
+
+
+scenario :: Int -> R.AppRuntime -> IO ()
+scenario ops appRt = do
+  ref <- newIORef 0
+  void $ R.startApp appRt (replicateM_ ops $ flow ref)
+  val <- readIORef ref
+  print val

app/PerfTestApp2/FTL.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module FTL where
+
+import           Control.Monad
+import qualified Data.Map      as Map
+import qualified Data.Set      as Set
+import           Hydra.Prelude
+
+import qualified Hydra.Domain  as D
+import qualified Hydra.FTL     as FTL
+import qualified Hydra.Runtime as R
+
+import           Hydra.FTLI    ()
+
+
+flow :: (MonadIO m, FTL.LangL m) => IORef Int -> m ()
+flow ref = do
+  val' <- liftIO $ readIORef ref
+  val <- FTL.getRandomInt (1, 100)
+  liftIO $ writeIORef ref $ val' + val
+
+scenario :: Int -> R.CoreRuntime -> IO ()
+scenario ops coreRt = do
+  ref <- newIORef 0
+  void $ runReaderT (replicateM_ ops $ flow ref) coreRt
+  val <- readIORef ref
+  print val

app/PerfTestApp2/Free.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Free where
+
+import           Control.Monad
+import qualified Data.Map       as Map
+import qualified Data.Set       as Set
+import           Hydra.Prelude
+
+import qualified Hydra.Domain   as D
+import qualified Hydra.Language as L
+import qualified Hydra.Runtime  as R
+
+
+flow :: IORef Int -> L.AppL ()
+flow ref = L.scenario $ do
+  val' <- L.evalIO $ readIORef ref
+  val  <- L.getRandomInt (1, 100)
+  L.evalIO $ writeIORef ref $ val' + val
+
+
+scenario :: Int -> R.AppRuntime -> IO ()
+scenario ops appRt = do
+  ref <- newIORef 0
+  void $ R.startApp appRt (replicateM_ ops $ flow ref)
+  val <- readIORef ref
+  print val

app/PerfTestApp2/IO.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module IO where
+
+import           Control.Monad
+import qualified Data.Map      as Map
+import qualified Data.Set      as Set
+import           Hydra.Prelude
+
+import           System.Entropy
+import           System.Random       hiding (next)
+
+flow :: IORef Int -> IO ()
+flow ref = do
+  val' <- readIORef ref
+  val <- randomRIO (1, 100)
+  writeIORef ref $ val' + val
+
+scenario :: Int -> IO ()
+scenario ops = do
+  ref <- newIORef 0
+  void $ replicateM_ ops $ flow ref
+  val <- readIORef ref
+  print val

app/PerfTestApp2/Main.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main where
+
+import           Control.Monad
+import qualified Data.Map      as Map
+import qualified Data.Set      as Set
+import           Hydra.Prelude
+
+import qualified Free          as Free
+import qualified FTL           as FTL
+import qualified Church        as Church
+import qualified IO            as IO
+import qualified Hydra.Domain  as D
+import qualified Hydra.Runtime as R
+import qualified Hydra.Framework.RLens as RLens
+
+data Method = FT | FreeM | ChurchM | IO
+  deriving (Show, Read, Eq, Ord)
+
+data Config = Config
+  { method     :: Method
+  , iterations :: Int
+  }
+  deriving (Show, Read, Eq, Ord)
+
+loggerCfg :: D.LoggerConfig
+loggerCfg = D.LoggerConfig
+  { D._format       = "$prio $loggername: $msg"
+  , D._level        = D.Debug
+  , D._logFilePath  = ""
+  , D._logToConsole = True
+  , D._logToFile    = False
+  }
+
+main :: IO ()
+main = do
+  cfgStr <- readFile "perf_test_app2.cfg"
+  let cfg :: Config = read $ toString cfgStr
+
+  putStrLn @String $ "Method: " <> show (method cfg) <> ", iterations: " <> show (iterations cfg)
+
+  let ops = iterations cfg
+
+  R.withAppRuntime Nothing $ \appRt -> do
+    when (method cfg == FT)
+      $ FTL.scenario ops $ appRt ^. RLens.coreRuntime
+
+    when (method cfg == FreeM)
+      $ Free.scenario ops appRt
+
+    when (method cfg == ChurchM)
+      $ Church.scenario ops appRt
+
+    when (method cfg == IO)
+      $ IO.scenario ops

package.yaml

@@ -135,6 +135,18 @@ executables:
     dependencies:
     - Hydra
 
+  perf-test-app2:
+    main:                Main.hs
+    source-dirs:         app/PerfTestApp2
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -Wall
+    - -O2
+    dependencies:
+    - Hydra
+
   meteor-counter-app:
     main:                Main.hs
     source-dirs:         app/MeteorCounter

perf_test_app2.cfg

@@ -0,0 +1,4 @@
+Config
+  { method     = FreeM
+  , iterations = 10000
+  }

src/Hydra/Core/Lang/ChurchL.hs

@@ -41,11 +41,8 @@ makeFunctorInstance ''LangF
 
 type LangL = F LangF
 
--- class IOL m where
---   evalIO :: IO a -> m a
---
--- instance IOL LangL where
---   evalIO io = liftF $ EvalIO io id
+instance C.IOL LangL where
+  evalIO io = liftFC $ EvalIO io id
 
 evalStateAtomically' :: CL.StateL a -> LangL a
 evalStateAtomically' action = liftFC $ EvalStateAtomically action id

src/Hydra/Core/Lang/Class.hs

@@ -23,3 +23,8 @@ class (C.Logger l, C.Random r, C.ControlFlow cf, C.State' s, Monad m)
   evalStateAtomically :: s a  -> m a
   evalControlFlow     :: cf a -> m a
   -- todo: io
+
+
+-- TODO: this should not be here.
+class IOL m where
+  evalIO :: IO a -> m a

src/Hydra/Core/Lang/Language.hs

@@ -68,10 +68,7 @@ instance Functor LangF where
 
 type LangL = Free LangF
 
-class IOL m where
-  evalIO :: IO a -> m a
-
-instance IOL LangL where
+instance C.IOL LangL where
   evalIO io = liftF $ EvalIO io id
 
 evalStateAtomically' :: L.StateL a -> LangL a

src/Hydra/Framework/App/ChurchL.hs

@@ -48,6 +48,9 @@ fork = evalProcess' . L.forkProcess'
 process :: L.LangL a -> AppL ()
 process action = void $ fork action
 
+instance C.IOL AppL where
+  evalIO = evalLang' . C.evalIO
+
 instance L.StateIO AppL where
   newVarIO       = evalLang' . L.newVarIO
   readVarIO      = evalLang' . L.readVarIO

src/Hydra/Framework/App/Language.hs

@@ -104,8 +104,8 @@ fork = evalProcess' . L.forkProcess'
 process :: L.LangL a -> AppL ()
 process action = void $ fork action
 
-instance L.IOL AppL where
-  evalIO = evalLang' . L.evalIO
+instance C.IOL AppL where
+  evalIO = evalLang' . C.evalIO
 
 instance L.StateIO AppL where
   newVarIO       = evalLang' . L.newVarIO