FT WIP

app/Hydra/Main.hs

@@ -1,13 +1,14 @@
 module Main where
 
-import qualified Data.Map       as Map
-import qualified Data.Set       as Set
+import qualified Data.Map      as Map
+import qualified Data.Set      as Set
 
-import qualified Hydra.Domain   as D
-import qualified Hydra.FTL as FTL
+import qualified Hydra.Domain  as D
+import qualified Hydra.FTL     as L
+import qualified Hydra.FTLI    ()
 -- import qualified Hydra.Language as L
 import           Hydra.Prelude
-import qualified Hydra.Runtime  as R
+import qualified Hydra.Runtime as R
 
 type MTime = Int
 
@@ -31,47 +32,46 @@ data AppState = AppState
   { catalogue :: D.StateVar Catalogue
   }
 
-
-initState :: (L.AppL m, L.StateL m) => ReaderT AppState m
+initState :: L.StateL m => m AppState
 initState = do
-  ne <- L.newVarIO Map.empty
-  nw <- L.newVarIO Map.empty
-  se <- L.newVarIO Map.empty
-  sw <- L.newVarIO Map.empty
+  ne <- L.newVar Map.empty
+  nw <- L.newVar Map.empty
+  se <- L.newVar Map.empty
+  sw <- L.newVar Map.empty
   let catalogueMap = Map.fromList
         [ (NorthEast, ne)
         , (NorthWest, nw)
         , (SouthEast, se)
         , (SouthWest, sw)
         ]
-  catalogue <- L.newVarIO catalogueMap
+  catalogue <- L.newVar catalogueMap
   pure $ AppState catalogue
 
-meteorCounter :: AppState -> L.LangL ()
-meteorCounter st = pure ()
-
-getRandomMeteor :: L.LangL Meteor
-getRandomMeteor = Meteor <$> L.getRandomInt (1, 100)
-
-getRandomMilliseconds :: L.LangL MTime
-getRandomMilliseconds = (* 1000) <$> L.getRandomInt (0, 3000)
-
-meteorShower :: AppState -> Region -> L.LangL ()
-meteorShower st region = do
-  getRandomMilliseconds >>= L.delay
-  meteor <- getRandomMeteor
-  L.logInfo $ "[MS] " <> " a new meteor appeared at " <> show region <> ": " <> show meteor
-  meteorShower st region
-
-meteorsMonitoring :: L.AppL ()
-meteorsMonitoring = do
-  L.logInfo "Starting app..."
-  st <- initState
-  L.process $ meteorCounter st
-  L.process $ meteorShower st NorthEast
-  L.process $ meteorShower st NorthWest
-  L.process $ meteorShower st SouthEast
-  L.process $ meteorShower st SouthWest
+-- meteorCounter :: L.LangL m => AppState -> m ()
+-- meteorCounter st = pure ()
+--
+-- getRandomMeteor :: L.LangL m => m Meteor
+-- getRandomMeteor = Meteor <$> L.getRandomInt (1, 100)
+--
+-- getRandomMilliseconds :: L.LangL m => m MTime
+-- getRandomMilliseconds = (* 1000) <$> L.getRandomInt (0, 3000)
+--
+-- meteorShower :: L.LangL m => AppState -> Region -> m ()
+-- meteorShower st region = do
+--   getRandomMilliseconds >>= L.delay
+--   meteor <- getRandomMeteor
+--   L.logInfo $ "[MS] " <> " a new meteor appeared at " <> show region <> ": " <> show meteor
+--   meteorShower st region
+--
+-- meteorsMonitoring :: L.AppL m => m ()
+-- meteorsMonitoring = do
+--   L.logInfo "Starting app..."
+--   st <- initState
+--   L.process $ meteorCounter st
+--   L.process $ meteorShower st NorthEast
+--   L.process $ meteorShower st NorthWest
+--   L.process $ meteorShower st SouthEast
+--   L.process $ meteorShower st SouthWest
 
 loggerCfg :: D.LoggerConfig
 loggerCfg = D.LoggerConfig
@@ -82,8 +82,38 @@ loggerCfg = D.LoggerConfig
   , D._logToFile    = False
   }
 
+-- main :: IO ()
+-- main = do
+--   loggerRt <- R.createLoggerRuntime loggerCfg
+--   appRt <- R.createAppRuntime loggerRt
+--   -- R.startApp appRt $ L.foreverApp meteorsMonitoring
+--   runReaderT (L.foreverApp meteorsMonitoring) appRt
+
+delayAction :: L.ControlFlowL m => Int -> m ()
+delayAction = L.delay
+
+meteorsMonitoring :: (L.ControlFlowL m, L.LoggerL m) => m ()
+meteorsMonitoring = do
+  L.logInfo "Delaying..."
+  L.delay 10000
+  L.logInfo "Done."
+
+-- Could not decuce...
+-- initStateApp :: L.LangL m => m AppState
+-- initStateApp = L.atomically initState
+
+-- This is wrong: the upper m should not be a state-working m
+-- (because the state is STM, and should not appear as is, only with atomically).
+-- Also,
+-- 'No instance for (L.StateL (ReaderT R.CoreRuntime IO))':
+-- this interpreter should not exist (we don't want to evaluate the actions separately in IO)
+initStateApp :: (L.StateL m, L.LangL m) => m AppState
+initStateApp = initState
+
 main :: IO ()
 main = do
   loggerRt <- R.createLoggerRuntime loggerCfg
+  coreRt <- R.createCoreRuntime loggerRt
   appRt <- R.createAppRuntime loggerRt
-  R.startApp appRt $ L.foreverApp meteorsMonitoring
+  runReaderT meteorsMonitoring coreRt
+  void $ runReaderT initStateApp coreRt

src/Hydra/Core/ControlFlow/FTL.hs

@@ -1,6 +1,6 @@
-module Hydra.Core.ControlFlow.FTLI where
+module Hydra.Core.ControlFlow.FTL where
 
 import           Hydra.Prelude
 
 class Monad m => ControlFlowL m where
-    delay :: Int -> m ()
+  delay :: Int -> m ()

src/Hydra/Core/ControlFlow/FTLI.hs

@@ -1,7 +1,10 @@
-module Hydra.Core.ControlFlow.Interpreter where
+module Hydra.Core.ControlFlow.FTLI where
 
-import qualified Hydra.Core.ControlFlow.Language as L
 import           Hydra.Prelude
 
+import qualified Hydra.Core.FTL     as L
+import qualified Hydra.Core.RLens   as RLens
+import qualified Hydra.Core.Runtime as R
+
 instance L.ControlFlowL (ReaderT R.CoreRuntime IO) where
-    delay = liftIO threadDelay
+    delay = liftIO . threadDelay

src/Hydra/Core/FTL.hs

@@ -4,7 +4,7 @@ module Hydra.Core.FTL
 
 import           Hydra.Core.ControlFlow.FTL as X
 import           Hydra.Core.Lang.FTL        as X
--- import           Hydra.Core.Logger.Language      as X
--- import           Hydra.Core.Process.Language     as X
--- import           Hydra.Core.Random.Language      as X
--- import           Hydra.Core.State.Language       as X
+import           Hydra.Core.Logger.FTL      as X
+import           Hydra.Core.Process.FTL     as X
+import           Hydra.Core.Random.FTL      as X
+import           Hydra.Core.State.FTL       as X

src/Hydra/Core/FTLI.hs

@@ -4,7 +4,7 @@ module Hydra.Core.FTLI
 
 import           Hydra.Core.ControlFlow.FTLI as X
 import           Hydra.Core.Lang.FTLI        as X
--- import           Hydra.Core.Logger.Interpreter      as X
--- import           Hydra.Core.Process.Interpreter     as X
--- import           Hydra.Core.Random.Interpreter      as X
--- import           Hydra.Core.State.Interpreter       as X
+import           Hydra.Core.Logger.FTLI      as X
+-- import           Hydra.Core.Process.FTLI     as X
+-- import           Hydra.Core.Random.FTLI      as X
+import           Hydra.Core.State.FTLI       as X

src/Hydra/Core/Lang/FTL.hs

@@ -1,24 +1,33 @@
 {-# LANGUAGE GADTs           #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Hydra.Core.Lang.Language where
+module Hydra.Core.Lang.FTL where
 
 import           Hydra.Prelude
 
-import           Hydra.Core.ControlFlow.Language as L
-import           Hydra.Core.Logger.Language      as L
-import           Hydra.Core.Random.Language      as L
-import           Hydra.Core.State.Language       as L
+import           Hydra.Core.ControlFlow.FTL as L
+import           Hydra.Core.Logger.FTL      as L
+import           Hydra.Core.Random.FTL      as L
+import           Hydra.Core.State.FTL       as L
 
+class Monad m => LangL m
 
+-- Doesn't work
+-- class Monad m => LangL m where
+--   atomically :: StateL m' => m' a -> m a
+--
+-- Compiles but wrong.
+-- class Monad m => LangL m where
+--   atomically :: StateL m => m a -> m a
 
+-- Doesn't work
+-- class (StateL sm, Monad m) => LangL m where
+--   atomically :: sm a -> m a
 
+-- Wrong, doesn't work
+-- class StateLLangL m where
+--   atomically :: (StateL sm, LangL m) => sm a -> m a
 
-class Monad m => IOL m where
-  evalIO :: IO a -> m a
-
-class (Monad m, IOL m) => LangL m where
-  evalStateAtomically :: L.StateL a -> m a
-  evalLogger :: L.LoggerL () -> m ()
-  evalRandom :: L.RandomL a -> m a
-  evalControlFlow :: L.ControlFlow a -> m a
+-- Wrong (we can't express this function without knowing the runtime.
+-- atomically :: (L.StateL m1, LangL m2) => m1 a -> m2 a
+-- atomically = ???

src/Hydra/Core/Lang/FTLI.hs

@@ -2,20 +2,37 @@ module Hydra.Core.Lang.FTLI where
 
 import           Hydra.Prelude
 
-import qualified Hydra.Core.FTL                     as L
-import qualified Hydra.Core.RLens                   as RLens
-import qualified Hydra.Core.Runtime                 as R
+import qualified Hydra.Core.FTL     as L
+import qualified Hydra.Core.RLens   as RLens
+import qualified Hydra.Core.Runtime as R
 
-instance L.IOL (ReaderT R.CoreRuntime IO) where
-  evalIO io = liftIO io
+-- Compiles but wrong.
+-- class Monad m => LangL m where
+--   atomically :: StateL m => m a -> m a
+-- Doesn't work
+-- instance L.LangL (ReaderT R.CoreRuntime IO) where
+--   atomically stmlAction = do
+--     coreRt <- ask
+--     let stmAction = runReaderT stmlAction coreRt
+--     res <- liftIO $ atomically stmAction
+--     pure res
 
-instance L.LangL (ReaderT R.CoreRuntime IO) where
-  evalStateAtomically action = do
-      coreRt <- ask
-      let loggerRt = coreRt ^. RLens.loggerRuntime
-      res <- liftIO $ atomically action
-      liftiO $ R.flushStmLogger stateRt loggerRt
-      pure res
-  evalLogger = error "Logger not implemented"
-  evalRandom = error "Logger not implemented"
-  evalControlFlow = error "Logger not implemented"
+
+-- class Monad m => LangL m
+-- class StateLLangL m where
+--   atomically :: (StateL sm, LangL m) => sm a -> m a
+-- Doesn't work
+-- instance L.StateLLangL (ReaderT R.CoreRuntime IO) where
+--   atomically stmlAction = do
+--     coreRt <- ask
+--     let stmAction = runReaderT stmlAction coreRt
+--     res <- liftIO $ atomically stmAction
+--     pure res
+
+
+instance L.StateL (ReaderT R.CoreRuntime IO) where
+  atomically stmlAction = do
+    coreRt <- ask
+    let stmAction = runReaderT stmlAction coreRt
+    res <- liftIO $ atomically stmAction
+    pure res

src/Hydra/Core/Logger/FTL.hs

@@ -5,14 +5,14 @@ module Hydra.Core.Logger.FTL where
 
 import           Hydra.Prelude
 
-import qualified Hydra.Core.Domain               as D (LogLevel (..), Message)
+import qualified Hydra.Core.Domain as D
 
 
 class Monad m => LoggerL m where
   logMessage :: D.LogLevel -> D.Message -> m ()
 
--- class Logger m => StmLoggerL m where
---   logMessage :: D.LogLevel -> D.Message -> STM ()
+-- -- class Logger m => StmLoggerL m where
+-- --   logMessage :: D.LogLevel -> D.Message -> STM ()
 
 
 -- | Log message with Info level.

src/Hydra/Core/Logger/FTLI.hs

@@ -0,0 +1,19 @@
+module Hydra.Core.Logger.FTLI where
+
+import           Hydra.Prelude
+
+import qualified Hydra.Core.FTL                  as L
+import qualified Hydra.Core.RLens                as RLens
+import qualified Hydra.Core.Runtime              as R
+
+import qualified Data.Text                       as TXT (unpack)
+import qualified Hydra.Core.Logger.Impl.HsLogger as Hs
+import qualified System.Log.Logger               as Hs
+
+-- TODO: hslogger specific is here!
+instance L.LoggerL (ReaderT R.CoreRuntime IO) where
+  logMessage lvl msg = do
+    coreRt <- ask
+    let mbHsRt = coreRt ^. RLens.loggerRuntime ^. RLens.hsLoggerHandle
+    when (isJust mbHsRt) $
+      liftIO $ Hs.logM Hs.component (Hs.dispatchLogLevel lvl) $ TXT.unpack msg

src/Hydra/Core/Process/FTL.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hydra.Core.Process.FTL where
+
+import           Hydra.Prelude
+
+import qualified Hydra.Core.Domain as D
+
+
+-- class (Monad m') => ProcessL m' where
+--   forkProcess  :: m' a -> ProcessL m' (D.ProcessPtr a)
+--   killProcess  :: D.ProcessPtr a -> ProcessL m' ()
+--   tryGetResult :: D.ProcessPtr a -> ProcessL m' (Maybe a)
+--   awaitResult  :: D.ProcessPtr a -> ProcessL m' a

src/Hydra/Core/Random/FTL.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hydra.Core.Random.FTL where
+
+import           Hydra.Prelude
+
+import qualified Hydra.Core.Domain as D
+
+
+-- class Monad m => RandomL m where
+--   getRandomInt :: (Int, Int) -> m Int

src/Hydra/Core/Random/Language.hs

@@ -18,7 +18,7 @@ makeFunctorInstance ''RandomF
 type RandomL next = Free RandomF next
 
 class Random m where
-    getRandomInt :: (Int,Int) -> m Int
+    getRandomInt :: (Int, Int) -> m Int
 
 instance Random (Free RandomF) where
     getRandomInt range = liftF $ GetRandomInt range id

src/Hydra/Core/State/FTL.hs

@@ -1,62 +1,30 @@
-module Hydra.Core.State.FTLI where
+module Hydra.Core.State.FTL where
 
 import           Hydra.Prelude
 
---
--- -- | State language. It reflects STM and its behavior.
--- data StateF next where
---   -- | Create variable.
---   NewVar :: a -> (D.StateVar a -> next) -> StateF next
---   -- | Read variable.
---   ReadVar :: D.StateVar a -> (a -> next) -> StateF next
---   -- | Write variable.
---   WriteVar :: D.StateVar a -> a -> (() -> next) -> StateF next
---   -- | Retry until some variable is changed in this atomic block.
---   Retry :: (a -> next) -> StateF next
---   -- | Eval "delayed" logger: it will be written after successfull state operation.
---   EvalStmLogger :: L.LoggerL () -> (() -> next) -> StateF next
---
--- makeFunctorInstance ''StateF
---
--- type StateL = Free StateF
+import qualified Hydra.Core.Domain as D
 
-class (StmLogger m, Monad m) => StateL m where
-  newVar :: a -> m (D.StateVar a)
-  readVar :: D.StateVar a -> m a
+class Monad m => StateL m where
+  newVar   :: a -> m (D.StateVar a)
+  readVar  :: D.StateVar a -> m a
   writeVar :: D.StateVar a -> a -> m ()
-  retry :: m a
-
-
-
-class StateIO m where
-  atomically :: StateL a -> m a
-  newVarIO :: a -> m (D.StateVar a)
-  readVarIO :: D.StateVar a -> m a
-  writeVarIO :: D.StateVar a -> a -> m ()
-
--- | Create variable.
-newVar :: a -> StateL (D.StateVar a)
-newVar val = liftF $ NewVar val id
-
--- | Read variable.
-readVar :: D.StateVar a -> StateL a
-readVar var = liftF $ ReadVar var id
-
--- | Write variable.
-writeVar :: D.StateVar a -> a -> StateL ()
-writeVar var val = liftF $ WriteVar var val id
+  retry    :: m a
 
 -- | Modify variable with function.
-modifyVar :: D.StateVar a -> (a -> a) -> StateL ()
+modifyVar :: StateL m => D.StateVar a -> (a -> a) -> m ()
 modifyVar var f = readVar var >>= writeVar var . f
 
--- | Retry until some variable is changed in this atomic block.
-retry :: StateL a
-retry = liftF $ Retry id
 
--- | Eval "delayed" logger: it will be written after successfull state operation.
-evalStmLogger :: L.LoggerL () -> StateL ()
-evalStmLogger action = liftF $ EvalStmLogger action id
+-- class StateIO m where
+--   atomically :: StateL a -> m a
+--   newVarIO :: a -> m (D.StateVar a)
+--   readVarIO :: D.StateVar a -> m a
+--   writeVarIO :: D.StateVar a -> a -> m ()
+--
 
-instance L.Logger StateL where
-    logMessage level = evalStmLogger . L.logMessage level
+-- -- -- | Eval "delayed" logger: it will be written after successfull state operation.
+-- -- evalStmLogger :: L.LoggerL () -> StateL ()
+-- -- evalStmLogger action = liftF $ EvalStmLogger action id
+--
+-- -- instance L.Logger StateL where
+-- --     logMessage level = evalStmLogger . L.logMessage level

src/Hydra/Core/State/FTLI.hs

@@ -1,7 +1,23 @@
 module Hydra.Core.State.FTLI where
 
-import qualified Hydra.Core.ControlFlow.Language as L
 import           Hydra.Prelude
 
-instance L.ControlFlowL (ReaderT R.CoreRuntime IO) where
-    delay = liftIO threadDelay
+import qualified Hydra.Core.Domain            as D
+import qualified Hydra.Core.FTL               as L
+import qualified Hydra.Core.RLens             as RLens
+import qualified Hydra.Core.Runtime           as R
+
+import qualified Hydra.Core.State.Interpreter as Impl
+
+instance L.StateL (ReaderT R.CoreRuntime STM) where
+  newVar val = do
+    coreRt <- ask
+    r <- lift $ Impl.newVar' (coreRt ^. RLens.stateRuntime) val
+    pure $ D.StateVar r
+  readVar var = do
+    coreRt <- ask
+    lift $ Impl.readVar' (coreRt ^. RLens.stateRuntime) var
+  writeVar var val = do
+    coreRt <- ask
+    lift $ Impl.writeVar' (coreRt ^. RLens.stateRuntime) var val
+  retry    = lift retry

src/Hydra/Framework/App/FTL.hs

@@ -1,15 +1,14 @@
 {-# LANGUAGE GADTs           #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Hydra.Frameork.App.FTL where
+module Hydra.Framework.App.FTL where
 
 import           Hydra.Prelude
 
 import           Hydra.Core.FTL as L
 
 
-type AppL m =
-  ( L.LangL m
-
-
-  )
+-- type AppL m =
+--   ( L.LangL m
+--   , L.ProcessL m
+--   )

src/Hydra/Framework/App/FTLI.hs

@@ -1,21 +1,7 @@
-module Hydra.Core.Lang.FTLI where
+module Hydra.Framework.App.FTLI where
 
 import           Hydra.Prelude
 
-import qualified Hydra.Core.FTL                     as L
-import qualified Hydra.Core.RLens                   as RLens
-import qualified Hydra.Core.Runtime                 as R
-
-instance L.IOL (ReaderT R.CoreRuntime IO) where
-  evalIO io = liftIO io
-
-instance L.LangL (ReaderT R.CoreRuntime IO) where
-  evalStateAtomically action = do
-      coreRt <- ask
-      let loggerRt = coreRt ^. RLens.loggerRuntime
-      res <- liftIO $ atomically action
-      liftiO $ R.flushStmLogger stateRt loggerRt
-      pure res
-  evalLogger = error "Logger not implemented"
-  evalRandom = error "Logger not implemented"
-  evalControlFlow = error "Logger not implemented"
+import qualified Hydra.Framework.App.FTL as L
+import qualified Hydra.Framework.RLens   as RLens
+import qualified Hydra.Framework.Runtime as R