Hydra Framework: initial commit.

.ghci

@@ -0,0 +1 @@
+:set prompt "λ> "

.gitignore

@@ -0,0 +1,9 @@
+.stack-work/*
+data/*
+*.swp
+cabal-helper*build/
+log.txt
+*.csv
+.hspec-failures
+*.cabal
+.vscode

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Hydra/Main.hs

@@ -0,0 +1,88 @@
+module Main where
+
+import qualified Data.Map       as Map
+import qualified Data.Set       as Set
+
+import qualified Hydra.Domain   as D
+import qualified Hydra.Language as L
+import           Hydra.Prelude
+import qualified Hydra.Runtime  as R
+
+type MTime = Int
+
+data Meteor = Meteor
+  { size :: Int
+  }
+  deriving (Show, Eq, Ord)
+
+data Region
+  = NorthEast
+  | NorthWest
+  | SouthEast
+  | SouthWest
+  deriving (Show, Eq, Ord)
+
+type Meteors = D.StateVar (Map.Map MTime Meteor)
+
+type Catalogue = Map.Map Region Meteors
+
+data AppState = AppState
+  { catalogue :: D.StateVar Catalogue
+  }
+
+
+initState :: L.AppL AppState
+initState = do
+  ne <- L.newVarIO Map.empty
+  nw <- L.newVarIO Map.empty
+  se <- L.newVarIO Map.empty
+  sw <- L.newVarIO Map.empty
+  let catalogueMap = Map.fromList
+        [ (NorthEast, ne)
+        , (NorthWest, nw)
+        , (SouthEast, se)
+        , (SouthWest, sw)
+        ]
+  catalogue <- L.newVarIO 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
+
+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
+  loggerRt <- R.createLoggerRuntime loggerCfg
+  appRt <- R.createAppRuntime loggerRt
+  R.startApp appRt $ L.foreverApp meteorsMonitoring

package.yaml

@@ -0,0 +1,128 @@
+name:                Hydra
+version:             1.0.0.0
+github:              "graninas/Hydra"
+license:             BSD3
+author:              "Alexander Granin"
+maintainer:          "graninas@gmail.com"
+copyright:           "Granin A.S. 2019"
+
+description:
+  Hydra is the project that allows to build multithreaded concurrent applications.
+  Hydra is initially based on the Enecuum.Framework.
+
+default-extensions:
+- NoImplicitPrelude
+- GADTs
+- RankNTypes
+- DeriveFunctor
+- DeriveGeneric
+- OverloadedStrings
+- LambdaCase
+- MultiParamTypeClasses
+- ExplicitNamespaces
+- TypeApplications
+- ScopedTypeVariables
+- TypeOperators
+- TypeFamilies
+- DataKinds
+- FlexibleContexts
+- FlexibleInstances
+- PatternSynonyms
+- PolyKinds
+- DefaultSignatures
+- ConstraintKinds
+- NamedFieldPuns
+- TupleSections
+- ViewPatterns
+- MultiWayIf
+
+dependencies:
+- base >= 4.7 && < 5
+- bytestring
+- time-units
+- network
+- aeson
+- aeson-pretty
+- cereal
+- mtl
+- cryptonite
+- base16-bytestring
+- base58-bytestring
+- base64-bytestring
+- arithmoi
+- directory
+- filepath
+- process
+- extra
+- time
+- clock
+- vector
+- scientific
+- containers
+- random
+- free
+- iproute
+- memory
+- transformers
+- template-haskell
+- async
+- text
+- haskeline
+- cryptohash-sha256
+- bytestring-conversion
+- newtype-generics
+- lens
+- universum
+- fmt
+- stm
+- hslogger
+- lens-aeson
+- th-abstraction
+- MonadRandom
+- entropy
+- validation
+- silently
+- uuid
+- resourcet
+- triplesec
+- yaml
+- hspec
+- HUnit
+- QuickCheck
+- hspec-contrib
+- newtype-generics
+- regex-posix
+- safe-exceptions
+
+library:
+  source-dirs:
+    - src
+  ghc-options:
+  - -Wall
+
+executables:
+  test-app-hydra:
+    main:                Main.hs
+    source-dirs:         app/Hydra
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -Wall
+    - -O2
+    dependencies:
+    - Hydra
+
+
+tests:
+  functional-tests:
+    main: Spec.hs
+
+    dependencies:
+    - Hydra
+    source-dirs:
+    - test/spec
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N

src/Hydra/Core/ControlFlow/Interpreter.hs

@@ -0,0 +1,14 @@
+module Hydra.Core.ControlFlow.Interpreter where
+
+import qualified Hydra.Core.ControlFlow.Language as L
+import           Hydra.Prelude
+
+import qualified Hydra.Core.Runtime              as R
+
+interpretControlFlowF :: R.CoreRuntime -> L.ControlFlowF a -> IO a
+interpretControlFlowF _ (L.Delay i next) = do
+    threadDelay i
+    pure $ next ()
+
+runControlFlowL :: R.CoreRuntime -> Free L.ControlFlowF a -> IO a
+runControlFlowL coreRt = foldFree (interpretControlFlowF coreRt)

src/Hydra/Core/ControlFlow/Language.hs

@@ -0,0 +1,18 @@
+module Hydra.Core.ControlFlow.Language where
+
+import           Hydra.Prelude
+
+data ControlFlowF next where
+  -- | Freeze the current thread on time (in microseconds).
+  Delay :: Int -> (() -> next) -> ControlFlowF next
+
+instance Functor ControlFlowF where
+    fmap g (Delay i next) = Delay i (g . next)
+
+type ControlFlowL next = Free ControlFlowF next
+
+class ControlFlow m where
+    delay :: Int -> m ()
+
+instance ControlFlow (Free ControlFlowF) where
+    delay i = liftF $ Delay i id

src/Hydra/Core/Domain.hs

@@ -0,0 +1,7 @@
+module Hydra.Core.Domain
+  ( module X
+  ) where
+
+import           Hydra.Core.Domain.Logger  as X
+import           Hydra.Core.Domain.Process as X
+import           Hydra.Core.Domain.State   as X

src/Hydra/Core/Domain/Logger.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Hydra.Core.Domain.Logger where
+
+import           Hydra.Prelude
+
+-- | Logging level.
+data LogLevel = Debug | Info | Warning | Error
+    deriving (Generic, Eq, Ord, Show, Read, Enum, ToJSON, FromJSON)
+
+-- | Logging format.
+type Format = String
+
+data LoggerConfig = LoggerConfig
+  { _format       :: Format
+  , _level        :: LogLevel
+  , _logFilePath  :: FilePath
+  , _logToConsole :: Bool
+  , _logToFile    :: Bool
+  } deriving (Generic, Show, Read)
+
+type Message = Text
+
+data LogEntry = LogEntry LogLevel Message
+type Log = [LogEntry]
+
+standardFormat :: String
+standardFormat = "$prio $loggername: $msg"
+
+nullFormat :: String
+nullFormat = "$msg"
+
+defaultLoggerConfig :: LoggerConfig
+defaultLoggerConfig = LoggerConfig
+    { _format = standardFormat
+    , _level = Debug
+    , _logFilePath = ""
+    , _logToConsole = True
+    , _logToFile = False
+    }
+
+nullLoger :: LoggerConfig
+nullLoger = defaultLoggerConfig
+    {   _logFilePath = "null"
+    ,   _logToConsole = False
+    }

src/Hydra/Core/Domain/Process.hs

@@ -0,0 +1,25 @@
+module Hydra.Core.Domain.Process
+    ( ProcessId
+    , ProcessPtr
+    , ProcessVar
+    , createProcessPtr
+    , getProcessId
+    , getProcessVar
+    ) where
+
+import Hydra.Prelude
+
+type ProcessVar a = TMVar a
+type ProcessId = Int
+data ProcessPtr a = ProcessPtr ProcessId (ProcessVar a)
+
+createProcessPtr :: ProcessId -> IO (ProcessPtr a, ProcessVar a)
+createProcessPtr pId = do
+    pVar <- newEmptyTMVarIO
+    pure (ProcessPtr pId pVar, pVar)
+
+getProcessId :: ProcessPtr a -> ProcessId
+getProcessId (ProcessPtr pId _) = pId
+
+getProcessVar :: ProcessPtr a -> ProcessVar a
+getProcessVar (ProcessPtr _ pVar) = pVar

src/Hydra/Core/Domain/State.hs

@@ -0,0 +1,13 @@
+module Hydra.Core.Domain.State where
+
+import           Hydra.Prelude
+
+type VarId = Int
+
+-- | Concurrent variable (STM TVar).
+newtype StateVar a = StateVar
+  { _varId :: VarId
+  }
+
+-- | Denotes a signaling concurrent variable.
+type SignalVar = StateVar Bool

src/Hydra/Core/Interpreters.hs

@@ -0,0 +1,10 @@
+module Hydra.Core.Interpreters
+  ( module X
+  ) where
+
+import           Hydra.Core.ControlFlow.Interpreter as X
+import           Hydra.Core.Lang.Interpreter        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

src/Hydra/Core/Lang/Interpreter.hs

@@ -0,0 +1,32 @@
+module Hydra.Core.Lang.Interpreter where
+
+import           Hydra.Prelude
+
+import           Hydra.Core.ControlFlow.Interpreter (runControlFlowL)
+import           Hydra.Core.Random.Interpreter      (runRandomL)
+import           Hydra.Core.State.Interpreter       (runStateL)
+
+import qualified Hydra.Core.Language                as L
+import           Hydra.Core.Logger.Impl.HsLogger    (runLoggerL)
+import           Hydra.Core.Random.Interpreter
+import qualified Hydra.Core.RLens                   as RLens
+import qualified Hydra.Core.Runtime                 as R
+
+-- | Interprets core lang.
+interpretLangF :: R.CoreRuntime -> L.LangF a -> IO a
+interpretLangF coreRt (L.EvalStateAtomically action next) = do
+    let stateRt  = coreRt ^. RLens.stateRuntime
+    let loggerRt = coreRt ^. RLens.loggerRuntime
+    res <- atomically $ runStateL stateRt action
+    R.flushStmLogger stateRt loggerRt
+    pure $ next res
+
+interpretLangF coreRt (L.EvalLogger msg next) =
+    next <$> runLoggerL (coreRt ^. RLens.loggerRuntime . RLens.hsLoggerHandle) msg
+interpretLangF _      (L.EvalRandom  s next)        = next <$> runRandomL s
+interpretLangF coreRt (L.EvalControlFlow f    next) = next <$> runControlFlowL coreRt f
+interpretLangF _      (L.EvalIO f next)             = next <$> f
+
+-- | Runs core lang.
+runLangL :: R.CoreRuntime -> L.LangL a -> IO a
+runLangL coreRt = foldFree (interpretLangF coreRt)

src/Hydra/Core/Lang/Language.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hydra.Core.Lang.Language 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           Language.Haskell.TH.MakeFunctor (makeFunctorInstance)
+
+-- | Core effects container language.
+data LangF next where
+  -- | Eval stateful action atomically.
+  EvalStateAtomically :: L.StateL a -> (a -> next) -> LangF next
+  -- | Logger effect
+  EvalLogger      :: L.LoggerL ()     -> (() -> next) -> LangF next
+  -- | Random effect
+  EvalRandom      :: L.RandomL a     -> (a  -> next) -> LangF next
+  -- | ControlFlow effect
+  EvalControlFlow :: L.ControlFlowL a -> (a  -> next) -> LangF next
+  -- | Impure effect. Avoid using it in production code (it's not testable).
+  EvalIO          :: IO a           -> (a  -> next) -> LangF next
+
+makeFunctorInstance ''LangF
+
+type LangL = Free LangF
+
+class IOL m where
+  evalIO :: IO a -> m a
+
+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
+
+instance L.StateIO LangL where
+    atomically     = evalStateAtomically
+    newVarIO       = evalStateAtomically . L.newVar
+    readVarIO      = evalStateAtomically . L.readVar
+    writeVarIO var = evalStateAtomically . L.writeVar var
+
+evalLogger :: L.LoggerL () -> LangL ()
+evalLogger logger = liftF $ EvalLogger logger id
+
+instance Logger LangL where
+  logMessage level msg = evalLogger $ logMessage level msg
+
+evalRandom :: L.RandomL a -> LangL a
+evalRandom g = liftF $ EvalRandom g id
+
+instance L.Random LangL where
+  getRandomInt = evalRandom . getRandomInt
+
+evalControlFlow :: L.ControlFlowL a -> LangL a
+evalControlFlow a = liftF $ EvalControlFlow a id
+
+instance L.ControlFlow LangL where
+  delay i = evalControlFlow $ L.delay i

src/Hydra/Core/Language.hs

@@ -0,0 +1,10 @@
+module Hydra.Core.Language
+  ( module X
+  ) where
+
+import           Hydra.Core.ControlFlow.Language as X
+import           Hydra.Core.Lang.Language        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

src/Hydra/Core/Logger/Impl/HsLogger.hs

@@ -0,0 +1,67 @@
+module Hydra.Core.Logger.Impl.HsLogger where
+
+import           Hydra.Prelude
+
+import qualified Data.Text                 as TXT (unpack)
+import           System.IO                 (Handle, stdout)
+import           System.Log.Formatter
+import           System.Log.Handler        (close, setFormatter)
+import           System.Log.Handler.Simple (GenericHandler, fileHandler, streamHandler)
+import           System.Log.Logger
+
+import qualified Hydra.Core.Domain         as D (LogLevel (..), LoggerConfig (..))
+import qualified Hydra.Core.Language       as L
+
+-- | Opaque type covering all information needed to teardown the logger.
+data HsLoggerHandle = HsLoggerHandle
+  { handlers :: [GenericHandler Handle]
+  }
+
+component :: String
+component = ""
+
+-- | Bracket an IO action which denotes the whole scope where the loggers of
+-- the application are needed to installed. Sets them up before running the action
+-- and tears them down afterwards. Even in case of an exception.
+withLogger :: D.LoggerConfig -> (HsLoggerHandle -> IO c) -> IO c
+withLogger config = bracket (setupLogger config) teardownLogger
+
+-- | Dispatch log level from the LoggerL language
+-- to the relevant log level of hslogger package
+dispatchLogLevel :: D.LogLevel -> Priority
+dispatchLogLevel D.Debug   = DEBUG
+dispatchLogLevel D.Info    = INFO
+dispatchLogLevel D.Warning = WARNING
+dispatchLogLevel D.Error   = ERROR
+
+-- | Interpret LoggerL language.
+interpretLoggerL :: HsLoggerHandle -> L.LoggerF a -> IO a
+interpretLoggerL _ (L.LogMessage level msg next) = do
+    logM component (dispatchLogLevel level) $ TXT.unpack msg
+    pure $ next ()
+
+runLoggerL :: Maybe HsLoggerHandle -> L.LoggerL () -> IO ()
+runLoggerL (Just h) l = foldFree (interpretLoggerL h) l
+runLoggerL Nothing  _ = pure ()
+
+-- | Setup logger required by the application.
+setupLogger :: D.LoggerConfig -> IO HsLoggerHandle
+setupLogger (D.LoggerConfig format level logFileName isConsoleLog isFileLog) = do
+    let logLevel     = dispatchLogLevel level
+    let setFormat lh = pure $ setFormatter lh (simpleLogFormatter format)
+
+    let fileH        = [fileHandler logFileName logLevel >>= setFormat | isFileLog   ]
+    let consoleH     = [streamHandler stdout logLevel    >>= setFormat | isConsoleLog]
+
+    handlers <- sequence $ fileH ++ consoleH
+
+    when (length handlers > 0) $ updateGlobalLogger rootLoggerName (setLevel DEBUG . setHandlers handlers)
+    pure $ HsLoggerHandle handlers
+
+-- TODO: FIXME: these clearings don't work for console logger.
+-- | Tear down the application logger; i.e. close all associated log handlers.
+teardownLogger :: HsLoggerHandle -> IO ()
+teardownLogger (HsLoggerHandle handlers) = do
+    let x = setHandlers @(GenericHandler Handle) []
+    updateGlobalLogger rootLoggerName (setLevel EMERGENCY . x)
+    mapM_ close handlers

src/Hydra/Core/Logger/Impl/StmLogger.hs

@@ -0,0 +1,16 @@
+module Hydra.Core.Logger.Impl.StmLogger where
+
+import           Hydra.Prelude
+
+import qualified Hydra.Core.Domain   as D
+import qualified Hydra.Core.Language as L
+
+
+-- | Interpret LoggerF language for a stm log.
+interpretStmLoggerF :: TVar D.Log -> L.LoggerF a -> STM a
+interpretStmLoggerF stmLog (L.LogMessage level msg next) =
+    next <$> modifyTVar stmLog (D.LogEntry level msg :)
+
+-- | Run LoggerL language for a stm log.
+runStmLoggerL :: TVar D.Log -> L.LoggerL () -> STM ()
+runStmLoggerL stmLog = foldFree (interpretStmLoggerF stmLog)

src/Hydra/Core/Logger/Language.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hydra.Core.Logger.Language where
+
+import           Hydra.Prelude
+
+import qualified Hydra.Core.Domain               as D (LogLevel (..), Message)
+
+import           Language.Haskell.TH.MakeFunctor
+
+-- | Language for logging.
+data LoggerF next where
+  -- | Log message with a predefined level.
+  LogMessage :: D.LogLevel -> D.Message -> (() -> next) -> LoggerF next
+
+makeFunctorInstance ''LoggerF
+
+type LoggerL = Free LoggerF
+
+class Logger m where
+  logMessage :: D.LogLevel -> D.Message -> m ()
+
+instance Logger LoggerL where
+  logMessage level msg = liftF $ LogMessage level msg id
+
+-- | Log message with Info level.
+logInfo :: Logger m => D.Message -> m ()
+logInfo = logMessage D.Info
+
+-- | Log message with Error level.
+logError :: Logger m => D.Message -> m ()
+logError = logMessage D.Error
+
+-- | Log message with Debug level.
+logDebug :: Logger m => D.Message -> m ()
+logDebug = logMessage D.Debug
+
+-- | Log message with Warning level.
+logWarning :: Logger m => D.Message -> m ()
+logWarning = logMessage D.Warning

src/Hydra/Core/Process/Interpreter.hs

@@ -0,0 +1,61 @@
+module Hydra.Core.Process.Interpreter where
+
+import           Hydra.Prelude
+
+import qualified Data.Map                  as M
+
+import qualified Hydra.Core.Domain.Process as D
+import qualified Hydra.Core.Language       as L
+import qualified Hydra.Core.RLens          as RLens
+import qualified Hydra.Core.Runtime        as R
+
+newtype LangRunner m' = LangRunner (forall a. m' a -> IO a)
+
+runLang :: LangRunner m' -> m' a -> IO a
+runLang (LangRunner runner) action = runner action
+
+getNextProcessId :: R.ProcessRuntime -> IO Int
+getNextProcessId processRt = atomicModifyIORef' (processRt ^. RLens.idCounter) (\a -> (a + 1, a + 1))
+
+addProcess :: R.ProcessRuntime -> D.ProcessPtr a -> ThreadId -> IO ()
+addProcess procRt pPtr threadId = do
+    let pId = D.getProcessId pPtr
+    ps <- readTVarIO $ procRt ^. RLens.processes
+    let newPs = M.insert pId threadId ps
+    atomically $ writeTVar (procRt ^. RLens.processes) newPs
+
+popProcess :: R.ProcessRuntime -> D.ProcessPtr a -> IO (Maybe ThreadId)
+popProcess procRt pPtr = do
+    let pId = D.getProcessId pPtr
+    ps <- readTVarIO $ procRt ^. RLens.processes
+    let mbThreadId = M.lookup pId ps
+    let newPs = M.delete pId ps
+    atomically $ writeTVar (procRt ^. RLens.processes) newPs
+    pure mbThreadId
+
+interpretProcessF :: LangRunner m' -> R.ProcessRuntime -> L.ProcessF m' a -> IO a
+interpretProcessF runner processRt (L.ForkProcess action next) = do
+    (pPtr, pVar) <- getNextProcessId processRt >>= D.createProcessPtr
+    threadId <- forkIO $ do
+        res <- runLang runner action
+        atomically $ putTMVar pVar res
+    addProcess processRt pPtr threadId
+    pure $ next pPtr
+
+interpretProcessF _ processRt (L.KillProcess pId next) = do
+    mbThreadId <- popProcess processRt pId
+    whenJust mbThreadId killThread
+    pure $ next ()
+
+interpretProcessF _ _ (L.TryGetResult pPtr next) = do
+    let pVar = D.getProcessVar pPtr
+    mbResult <- atomically $ tryReadTMVar pVar
+    pure $ next mbResult
+
+interpretProcessF _ _ (L.AwaitResult pPtr next) = do
+    let pVar = D.getProcessVar pPtr
+    result <- atomically $ takeTMVar pVar
+    pure $ next result
+
+runProcessL :: LangRunner m' -> R.ProcessRuntime -> L.ProcessL m' a -> IO a
+runProcessL runner processRt = foldFree (interpretProcessF runner processRt)

src/Hydra/Core/Process/Language.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hydra.Core.Process.Language where
+
+import           Hydra.Prelude
+
+import qualified Hydra.Core.Domain               as D
+
+import           Language.Haskell.TH.MakeFunctor (makeFunctorInstance)
+
+-- | Language for Process.
+data ProcessF m' next where
+    -- | Fork a process for node.
+    ForkProcess :: m' a -> (D.ProcessPtr a -> next) -> ProcessF m' next
+    -- | Hardly kill the process.
+    KillProcess :: D.ProcessPtr a -> (() -> next) -> ProcessF m' next
+    -- | Try get result (non-blocking).
+    TryGetResult :: D.ProcessPtr a -> (Maybe a -> next) -> ProcessF m' next
+    -- | Await for result (blocking).
+    AwaitResult :: D.ProcessPtr a -> (a -> next) -> ProcessF m' next
+
+instance Functor (ProcessF m') where
+    fmap f (ForkProcess action next) = ForkProcess action (f . next)
+    fmap f (KillProcess pPtr next)   = KillProcess pPtr (f . next)
+    fmap f (TryGetResult pPtr next)  = TryGetResult pPtr (f . next)
+    fmap f (AwaitResult pPtr next)   = AwaitResult pPtr (f . next)
+
+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
+
+-- | Hardly kill a process.
+killProcess :: D.ProcessPtr a -> ProcessL m' ()
+killProcess processPtr = liftF $ KillProcess processPtr id
+
+-- | Try get result from a process (non-blocking).
+tryGetResult :: D.ProcessPtr a -> ProcessL m' (Maybe a)
+tryGetResult handle = liftF $ TryGetResult handle id
+
+-- | Await for result from a process (blocking).
+awaitResult :: D.ProcessPtr a -> ProcessL m' a
+awaitResult handle = liftF $ AwaitResult handle id
+
+-- instance Process m' (ProcessL m') where
+--   process action = void (forkProcess action)
+--   fork = forkProcess

src/Hydra/Core/RLens.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE DuplicateRecordFields  #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TemplateHaskell        #-}
+
+module Hydra.Core.RLens where
+
+import           Control.Lens       (makeFieldsNoPrefix)
+import           Hydra.Core.Runtime (CoreRuntime, LoggerRuntime, ProcessRuntime, StateRuntime)
+
+makeFieldsNoPrefix ''CoreRuntime
+makeFieldsNoPrefix ''LoggerRuntime
+makeFieldsNoPrefix ''StateRuntime
+makeFieldsNoPrefix ''ProcessRuntime

src/Hydra/Core/Random/Interpreter.hs

@@ -0,0 +1,18 @@
+module Hydra.Core.Random.Interpreter where
+
+import           Hydra.Prelude
+
+import           System.Entropy
+import           System.Random       hiding (next)
+
+import qualified Hydra.Core.Language as L
+
+-- | Interpret RandomF language.
+interpretRandomF :: L.RandomF a -> IO a
+interpretRandomF (L.GetRandomInt range next) = do
+    r <- randomRIO range
+    pure $ next r
+
+-- | Interpret RandomL language.
+runRandomL :: L.RandomL a -> IO a
+runRandomL = foldFree interpretRandomF

src/Hydra/Core/Random/Language.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE PackageImports  #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hydra.Core.Random.Language where
+
+import           Hydra.Prelude
+
+import           Language.Haskell.TH.MakeFunctor
+
+-- | Language for Random.
+data RandomF next where
+    -- | Get Int from range
+    GetRandomInt :: (Int, Int) -> (Int -> next) -> RandomF next
+
+makeFunctorInstance ''RandomF
+
+type RandomL next = Free RandomF next
+
+class Random m where
+    getRandomInt :: (Int,Int) -> m Int
+
+instance Random (Free RandomF) where
+    getRandomInt range = liftF $ GetRandomInt range id

src/Hydra/Core/Runtime.hs

@@ -0,0 +1,96 @@
+module Hydra.Core.Runtime where
+
+import           Hydra.Prelude
+
+import qualified Data.Map                        as Map
+
+import qualified Hydra.Core.Domain               as D
+import qualified Hydra.Core.Language             as L
+import qualified Hydra.Core.Logger.Impl.HsLogger as Impl
+
+-- | Runtime data for the concrete logger impl.
+newtype LoggerRuntime = LoggerRuntime
+    { _hsLoggerHandle :: Maybe Impl.HsLoggerHandle
+    }
+
+data ProcessRuntime = ProcessRuntime
+    { _idCounter :: IORef Int
+    , _processes :: TVar (Map D.ProcessId ThreadId)
+    }
+
+-- | Runtime data for core subsystems.
+data CoreRuntime = CoreRuntime
+    { _loggerRuntime  :: LoggerRuntime
+    , _stateRuntime   :: StateRuntime
+    }
+
+-- | Logger that can be used in runtime via the logging subsystem.
+newtype RuntimeLogger = RuntimeLogger
+    { logMessage' :: D.LogLevel -> D.Message -> IO ()
+    }
+
+newtype VarHandle = VarHandle (TVar Any)
+
+data StateRuntime = StateRuntime
+    { _varId  :: TVar D.VarId                       -- ^ Var id counter
+    , _state  :: TMVar (Map.Map D.VarId VarHandle)  -- ^ Node state.
+    , _stmLog :: TVar D.Log                         -- ^ Stm log entries
+    }
+
+createVoidLoggerRuntime :: IO LoggerRuntime
+createVoidLoggerRuntime = pure $ LoggerRuntime Nothing
+
+createLoggerRuntime :: D.LoggerConfig -> IO LoggerRuntime
+createLoggerRuntime config = LoggerRuntime . Just <$> Impl.setupLogger config
+
+clearLoggerRuntime :: LoggerRuntime -> IO ()
+clearLoggerRuntime (LoggerRuntime (Just hsLogger)) = Impl.teardownLogger hsLogger
+clearLoggerRuntime _                               = pure ()
+
+createStateRuntime :: IO StateRuntime
+createStateRuntime = StateRuntime
+    <$> newTVarIO 0
+    <*> newTMVarIO Map.empty
+    <*> newTVarIO []
+
+createProcessRuntime :: IO ProcessRuntime
+createProcessRuntime = ProcessRuntime
+    <$> newIORef 0
+    <*> newTVarIO Map.empty
+
+createCoreRuntime :: LoggerRuntime -> IO CoreRuntime
+createCoreRuntime loggerRt = CoreRuntime
+    <$> pure loggerRt
+    <*> createStateRuntime
+
+-- clearCoreRuntime :: CoreRuntime -> IO ()
+-- clearCoreRuntime _ = pure ()
+
+-- mkRuntimeLogger :: LoggerRuntime -> RuntimeLogger
+-- mkRuntimeLogger (LoggerRuntime hsLog) = RuntimeLogger
+--     { logMessage' = \lvl msg -> Impl.runLoggerL hsLog $ L.logMessage lvl msg
+--     }
+
+-- Runtime log functions
+-- logInfo' :: RuntimeLogger -> D.Message -> IO ()
+-- logInfo' (RuntimeLogger l) = l D.Info
+--
+-- logError' :: RuntimeLogger -> D.Message -> IO ()
+-- logError' (RuntimeLogger l) = l D.Error
+--
+-- logDebug' :: RuntimeLogger -> D.Message -> IO ()
+-- logDebug' (RuntimeLogger l) = l D.Debug
+--
+-- logWarning' :: RuntimeLogger -> D.Message -> IO ()
+-- logWarning' (RuntimeLogger l) = l D.Warning
+
+
+-- | Writes all stm entries into real logger.
+flushStmLogger :: StateRuntime -> LoggerRuntime -> IO ()
+flushStmLogger stateRt loggerRt = do
+    l <- atomically $ do
+            l <- readTVar $ _stmLog stateRt
+            writeTVar (_stmLog stateRt) []
+            pure l
+    let loggerHandle = _hsLoggerHandle loggerRt
+    mapM_ (\(D.LogEntry level msg) -> Impl.runLoggerL loggerHandle $ L.logMessage level msg) l

src/Hydra/Core/State/Interpreter.hs

@@ -0,0 +1,54 @@
+module Hydra.Core.State.Interpreter where
+
+import           Hydra.Prelude
+
+import qualified Data.Map                         as Map
+import           Unsafe.Coerce                    (unsafeCoerce)
+
+import qualified Hydra.Core.Language              as L
+import qualified Hydra.Core.RLens                 as RLens
+import qualified Hydra.Core.Runtime               as R
+import qualified Hydra.Core.Domain                as D
+
+import           Hydra.Core.Logger.Impl.StmLogger (runStmLoggerL)
+
+getVarId :: R.StateRuntime -> STM D.VarId
+getVarId stateRt = do
+  v <- readTVar $ stateRt ^. RLens.varId
+  writeTVar (stateRt ^. RLens.varId) $ v + 1
+  pure v
+
+newVar' :: R.StateRuntime -> a -> STM D.VarId
+newVar' stateRt a = do
+    nodeState <- takeTMVar $ stateRt ^. RLens.state
+    varId     <- getVarId stateRt
+    tvar      <- newTVar $ unsafeCoerce a
+    putTMVar (stateRt ^. RLens.state) $ Map.insert varId (R.VarHandle tvar) nodeState
+    pure varId
+
+readVar' :: R.StateRuntime -> D.StateVar a -> STM a
+readVar' stateRt (D.StateVar varId) = do
+    nodeState <- readTMVar $ stateRt ^. RLens.state
+    case Map.lookup varId nodeState of
+        Nothing                 -> error $ "Var not found: " +|| varId ||+ "."
+        Just (R.VarHandle tvar) -> unsafeCoerce <$> readTVar tvar
+
+writeVar' :: R.StateRuntime -> D.StateVar a -> a -> STM ()
+writeVar' stateRt (D.StateVar varId) val = do
+    nodeState <- readTMVar $ stateRt ^. RLens.state
+    case Map.lookup varId nodeState of
+        Nothing                 -> error $ "Var not found: " +|| varId ||+ "."
+        Just (R.VarHandle tvar) -> writeTVar tvar $ unsafeCoerce val
+
+
+-- | Interpret StateF as STM.
+interpretStateF :: R.StateRuntime -> L.StateF a -> STM a
+interpretStateF stateRt (L.NewVar  val next     )  = next . D.StateVar <$> newVar' stateRt val
+interpretStateF stateRt (L.ReadVar var next     )  = next <$> readVar' stateRt var
+interpretStateF stateRt (L.WriteVar var val next)  = next <$> writeVar' stateRt var val
+interpretStateF _       (L.Retry _              )  = retry
+interpretStateF stateRt (L.EvalStmLogger act next) = next <$> runStmLoggerL (stateRt ^. RLens.stmLog) act
+
+-- | Runs state model as STM.
+runStateL :: R.StateRuntime -> L.StateL a -> STM a
+runStateL stateRt = foldFree (interpretStateF stateRt)

src/Hydra/Core/State/Language.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hydra.Core.State.Language where
+
+import           Hydra.Prelude
+
+import qualified Hydra.Core.Domain               as D
+import qualified Hydra.Core.Logger.Language      as L
+
+import           Language.Haskell.TH.MakeFunctor
+
+-- | 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
+
+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
+
+-- | Modify variable with function.
+modifyVar :: D.StateVar a -> (a -> a) -> StateL ()
+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
+
+instance L.Logger StateL where
+    logMessage level = evalStmLogger . L.logMessage level

src/Hydra/Domain.hs

@@ -0,0 +1,6 @@
+module Hydra.Domain
+  ( module X
+  ) where
+
+import           Hydra.Core.Domain as X
+import           Hydra.Framework.Domain as X

src/Hydra/Framework/App/Interpreter.hs

@@ -0,0 +1,27 @@
+module Hydra.Framework.App.Interpreter where
+
+import           Hydra.Prelude
+
+import qualified Hydra.Core.Interpreters as Impl
+import qualified Hydra.Core.Language as L
+import qualified Hydra.Core.Domain   as D
+import qualified Hydra.Core.Runtime   as R
+import qualified Hydra.Framework.Language as L
+import qualified Hydra.Framework.RLens     as RLens
+import qualified Hydra.Framework.Runtime   as R
+
+langRunner :: R.CoreRuntime -> Impl.LangRunner L.LangL
+langRunner coreRt = Impl.LangRunner (Impl.runLangL coreRt)
+
+interpretAppF :: R.AppRuntime -> L.AppF a -> IO a
+interpretAppF appRt (L.EvalLang action next) = do
+    res <- Impl.runLangL (appRt ^. RLens.coreRuntime) action
+    pure $ next res
+
+interpretAppF appRt (L.EvalProcess action next) = do
+    let coreRt = appRt ^. RLens.coreRuntime
+    res <- Impl.runProcessL (langRunner coreRt) (appRt ^. RLens.processRuntime) action
+    pure $ next res
+
+runAppL :: R.AppRuntime -> L.AppL a -> IO a
+runAppL appRt = foldFree (interpretAppF appRt)

src/Hydra/Framework/App/Language.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hydra.Framework.App.Language where
+
+import           Hydra.Prelude
+
+import           Hydra.Core.Domain         as D
+import           Hydra.Core.Language       as L
+
+import           Language.Haskell.TH.MakeFunctor (makeFunctorInstance)
+
+-- | Core effects container language.
+data AppF next where
+  -- | Eval process.
+  EvalProcess :: L.ProcessL L.LangL a -> (a -> next) -> AppF next
+  -- | Eval lang.
+  EvalLang    :: L.LangL a  -> (a -> next) -> AppF next
+
+makeFunctorInstance ''AppF
+
+type AppL = Free AppF
+
+-- | Eval lang.
+evalLang :: L.LangL a -> AppL a
+evalLang action = liftF $ EvalLang action id
+
+-- | Eval lang.
+scenario :: L.LangL a -> AppL a
+scenario = evalLang
+
+-- | Eval process.
+evalProcess :: L.ProcessL L.LangL a -> AppL a
+evalProcess action = liftF $ EvalProcess action id
+
+-- | Fork a process and keep the Process Ptr.
+fork :: L.LangL a -> AppL (D.ProcessPtr a)
+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
+    atomically     = evalLang . L.atomically
+    newVarIO       = evalLang . L.newVarIO
+    readVarIO      = evalLang . L.readVarIO
+    writeVarIO var = evalLang . L.writeVarIO var
+
+instance L.Logger AppL where
+  logMessage level msg = evalLang $ L.logMessage level msg
+
+instance L.Random AppL where
+  getRandomInt = evalLang . L.getRandomInt
+
+instance L.ControlFlow AppL where
+  delay = evalLang . L.delay

src/Hydra/Framework/Domain.hs

@@ -0,0 +1,3 @@
+module Hydra.Framework.Domain
+  (
+  ) where

src/Hydra/Framework/Interpreters.hs

@@ -0,0 +1,5 @@
+module Hydra.Framework.Interpreters
+  ( module X
+  ) where
+
+import           Hydra.Framework.App.Interpreter as X

src/Hydra/Framework/Language.hs

@@ -0,0 +1,5 @@
+module Hydra.Framework.Language
+  ( module X
+  ) where
+
+import           Hydra.Framework.App.Language as X

src/Hydra/Framework/RLens.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE DuplicateRecordFields  #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TemplateHaskell        #-}
+
+module Hydra.Framework.RLens where
+
+import           Control.Lens       (makeFieldsNoPrefix)
+import           Hydra.Framework.Runtime (AppRuntime)
+
+makeFieldsNoPrefix ''AppRuntime

src/Hydra/Framework/Runtime.hs

@@ -0,0 +1,19 @@
+module Hydra.Framework.Runtime where
+
+import           Hydra.Prelude
+
+import qualified Data.Map                        as Map
+
+import qualified Hydra.Core.Domain               as D
+import qualified Hydra.Core.Runtime              as R
+
+-- | App runtime data.
+data AppRuntime = AppRuntime
+    { _coreRuntime :: R.CoreRuntime
+    , _processRuntime :: R.ProcessRuntime
+    }
+
+createAppRuntime :: R.LoggerRuntime -> IO AppRuntime
+createAppRuntime loggerRt = AppRuntime
+    <$> R.createCoreRuntime loggerRt
+    <*> R.createProcessRuntime

src/Hydra/Interpreters.hs

@@ -0,0 +1,6 @@
+module Hydra.Interpreters
+  ( module X
+  ) where
+
+import           Hydra.Core.Interpreters as X
+import           Hydra.Framework.Interpreters as X

src/Hydra/Language.hs

@@ -0,0 +1,7 @@
+module Hydra.Language
+  ( module X
+  ) where
+
+import           Hydra.Core.Language        as X
+import           Hydra.Framework.Language   as X
+import           Hydra.Language.Extra       as X

src/Hydra/Language/Extra.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+
+module Hydra.Language.Extra where
+
+import           Hydra.Prelude
+
+import qualified Hydra.Core.Language      as L
+import qualified Hydra.Domain             as D
+import qualified Hydra.Framework.Language as L
+
+
+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

src/Hydra/Prelude.hs

@@ -0,0 +1,30 @@
+{-# OPTIONS -fno-warn-orphans #-}
+
+module Hydra.Prelude
+  ( module X
+  ) where
+
+import           Control.Concurrent           as X (ThreadId, forkIO, killThread, threadDelay)
+import           Control.Concurrent.STM       as X (retry)
+import           Control.Concurrent.STM.TMVar as X (TMVar, newEmptyTMVar, newEmptyTMVarIO, newTMVar, newTMVarIO,
+                                                    putTMVar, readTMVar, takeTMVar, tryReadTMVar)
+import           Control.Concurrent.STM.TVar  as X (modifyTVar)
+import           Control.Exception            as X (SomeException (..))
+import           Control.Lens                 as X (at, (.=))
+import           Control.Lens.TH              as X (makeFieldsNoPrefix, makeLenses)
+import           Control.Monad                as X (liftM, unless, void, when)
+import           Control.Monad.Free           as X (Free (..), foldFree, liftF)
+import           Control.Newtype.Generics     as X (Newtype, O, pack, unpack)
+import           Data.Aeson                   as X (FromJSON, ToJSON, genericParseJSON, genericToJSON, parseJSON,
+                                                    toJSON)
+import           Data.Maybe                   as X (fromJust, fromMaybe)
+import           Data.Serialize               as X (Serialize)
+import           Fmt                          as X ((+|), (+||), (|+), (||+))
+import           GHC.Base                     as X (until)
+import           GHC.Generics                 as X (Generic)
+import           Text.Read                    as X (read, readsPrec)
+
+-- includes Data.IORef
+import           Universum                    as X hiding (All, Option, Set, Type, head, init, last, set, tail, trace)
+import           Universum.Functor.Fmap       as X ((<<$>>))
+import           Universum.Unsafe             as X (head, init, last, tail, (!!))

src/Hydra/Runtime.hs

@@ -0,0 +1,15 @@
+module Hydra.Runtime
+    ( module X
+    , startApp
+    ) where
+
+import Hydra.Prelude
+
+import           Hydra.Core.Runtime as X
+import           Hydra.Framework.Runtime as X
+
+import           Hydra.Framework.App.Interpreter as Impl
+import           Hydra.Framework.Language as L
+
+startApp :: X.AppRuntime -> L.AppL a -> IO a
+startApp appRt app = Impl.runAppL appRt app

src/Language/Haskell/TH/MakeFunctor.hs

@@ -0,0 +1,35 @@
+module Language.Haskell.TH.MakeFunctor where
+
+import           Hydra.Prelude
+import qualified Data.List as L
+import           Language.Haskell.TH
+import           Language.Haskell.TH.Datatype
+
+makeFunctorInstance :: Name -> Q [Dec]
+makeFunctorInstance name =
+    forM [1 :: Int] $ \_ -> instanceD (cxt []) (appT (conT $ mkName "Functor") (conT name)) [makeFmap name]
+
+makeFmap :: Name -> Q Dec
+makeFmap name = do
+    constructors <- datatypeCons <$> reifyDatatype name
+    funD (mkName "fmap") (makeFmapBody <$> constructors)
+
+makeFmapBody :: ConstructorInfo -> Q Clause
+makeFmapBody info = clause
+    [varP $ mkName "g", conP consName (varP <$> varNames)]
+    (normalB
+        (  foldApp
+        $  ConE consName
+        :  (VarE <$> L.init varNames)
+        ++ [UInfixE (VarE $ mkName "g") (VarE $ mkName ".") (VarE lastArg)]
+        )
+    )
+    []
+  where
+    lastArg  = last varNames
+    varNames = (\a -> mkName $ "a" <> show a) <$> [1 .. argNum]
+    consName = constructorName info
+    argNum   = length $ constructorFields info
+
+foldApp :: [Exp] -> Q Exp
+foldApp = pure . foldl1 AppE

stack.yaml

@@ -0,0 +1,15 @@
+resolver: lts-11.22
+
+packages:
+- .
+
+extra-deps:
+  - base58-bytestring-0.1.0
+  - time-units-1.0.0
+
+
+
+build:
+  haddock-arguments:
+    haddock-args:
+    - "--odir=./../node-docs"

test/spec/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}