commit 20b356321fbd4155bde4a078545fad98c1ff5d9e Author: Alexander Granin Date: Thu May 2 00:12:50 2019 +0700 Hydra Framework: initial commit. diff --git a/.ghci b/.ghci new file mode 100755 index 0000000..89c33e0 --- /dev/null +++ b/.ghci @@ -0,0 +1 @@ +:set prompt "λ> " diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..59237f7 --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +.stack-work/* +data/* +*.swp +cabal-helper*build/ +log.txt +*.csv +.hspec-failures +*.cabal +.vscode \ No newline at end of file diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Hydra/Main.hs b/app/Hydra/Main.hs new file mode 100644 index 0000000..58d6572 --- /dev/null +++ b/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 diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..e6d4f16 --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/ControlFlow/Interpreter.hs b/src/Hydra/Core/ControlFlow/Interpreter.hs new file mode 100644 index 0000000..b9167fb --- /dev/null +++ b/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) diff --git a/src/Hydra/Core/ControlFlow/Language.hs b/src/Hydra/Core/ControlFlow/Language.hs new file mode 100644 index 0000000..7ac271a --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Domain.hs b/src/Hydra/Core/Domain.hs new file mode 100644 index 0000000..ba6f5dd --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Domain/Logger.hs b/src/Hydra/Core/Domain/Logger.hs new file mode 100644 index 0000000..cf3fcd0 --- /dev/null +++ b/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 + } diff --git a/src/Hydra/Core/Domain/Process.hs b/src/Hydra/Core/Domain/Process.hs new file mode 100644 index 0000000..1208b4b --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Domain/State.hs b/src/Hydra/Core/Domain/State.hs new file mode 100644 index 0000000..5d978be --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Interpreters.hs b/src/Hydra/Core/Interpreters.hs new file mode 100644 index 0000000..d9e2ce7 --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Lang/Interpreter.hs b/src/Hydra/Core/Lang/Interpreter.hs new file mode 100644 index 0000000..358974b --- /dev/null +++ b/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) diff --git a/src/Hydra/Core/Lang/Language.hs b/src/Hydra/Core/Lang/Language.hs new file mode 100644 index 0000000..0f9197e --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Language.hs b/src/Hydra/Core/Language.hs new file mode 100644 index 0000000..b3c3edf --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Logger/Impl/HsLogger.hs b/src/Hydra/Core/Logger/Impl/HsLogger.hs new file mode 100644 index 0000000..7916bb1 --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Logger/Impl/StmLogger.hs b/src/Hydra/Core/Logger/Impl/StmLogger.hs new file mode 100644 index 0000000..d44bdd2 --- /dev/null +++ b/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) diff --git a/src/Hydra/Core/Logger/Language.hs b/src/Hydra/Core/Logger/Language.hs new file mode 100644 index 0000000..8943b1a --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Process/Interpreter.hs b/src/Hydra/Core/Process/Interpreter.hs new file mode 100644 index 0000000..306cebb --- /dev/null +++ b/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) diff --git a/src/Hydra/Core/Process/Language.hs b/src/Hydra/Core/Process/Language.hs new file mode 100644 index 0000000..2ae7869 --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/RLens.hs b/src/Hydra/Core/RLens.hs new file mode 100644 index 0000000..dca75e3 --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Random/Interpreter.hs b/src/Hydra/Core/Random/Interpreter.hs new file mode 100644 index 0000000..9b1f168 --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Random/Language.hs b/src/Hydra/Core/Random/Language.hs new file mode 100644 index 0000000..e8ec279 --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/Runtime.hs b/src/Hydra/Core/Runtime.hs new file mode 100644 index 0000000..d7f933f --- /dev/null +++ b/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 diff --git a/src/Hydra/Core/State/Interpreter.hs b/src/Hydra/Core/State/Interpreter.hs new file mode 100644 index 0000000..1fb32e3 --- /dev/null +++ b/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) diff --git a/src/Hydra/Core/State/Language.hs b/src/Hydra/Core/State/Language.hs new file mode 100644 index 0000000..7142d06 --- /dev/null +++ b/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 diff --git a/src/Hydra/Domain.hs b/src/Hydra/Domain.hs new file mode 100644 index 0000000..cc54ca0 --- /dev/null +++ b/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 diff --git a/src/Hydra/Framework/App/Interpreter.hs b/src/Hydra/Framework/App/Interpreter.hs new file mode 100644 index 0000000..1c3f1a6 --- /dev/null +++ b/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) diff --git a/src/Hydra/Framework/App/Language.hs b/src/Hydra/Framework/App/Language.hs new file mode 100644 index 0000000..11e529a --- /dev/null +++ b/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 diff --git a/src/Hydra/Framework/Domain.hs b/src/Hydra/Framework/Domain.hs new file mode 100644 index 0000000..66edd6d --- /dev/null +++ b/src/Hydra/Framework/Domain.hs @@ -0,0 +1,3 @@ +module Hydra.Framework.Domain + ( + ) where diff --git a/src/Hydra/Framework/Interpreters.hs b/src/Hydra/Framework/Interpreters.hs new file mode 100644 index 0000000..815ef31 --- /dev/null +++ b/src/Hydra/Framework/Interpreters.hs @@ -0,0 +1,5 @@ +module Hydra.Framework.Interpreters + ( module X + ) where + +import Hydra.Framework.App.Interpreter as X diff --git a/src/Hydra/Framework/Language.hs b/src/Hydra/Framework/Language.hs new file mode 100644 index 0000000..26d6527 --- /dev/null +++ b/src/Hydra/Framework/Language.hs @@ -0,0 +1,5 @@ +module Hydra.Framework.Language + ( module X + ) where + +import Hydra.Framework.App.Language as X diff --git a/src/Hydra/Framework/RLens.hs b/src/Hydra/Framework/RLens.hs new file mode 100644 index 0000000..d56b315 --- /dev/null +++ b/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 diff --git a/src/Hydra/Framework/Runtime.hs b/src/Hydra/Framework/Runtime.hs new file mode 100644 index 0000000..5fba9aa --- /dev/null +++ b/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 diff --git a/src/Hydra/Interpreters.hs b/src/Hydra/Interpreters.hs new file mode 100644 index 0000000..36b32bb --- /dev/null +++ b/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 diff --git a/src/Hydra/Language.hs b/src/Hydra/Language.hs new file mode 100644 index 0000000..140d685 --- /dev/null +++ b/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 diff --git a/src/Hydra/Language/Extra.hs b/src/Hydra/Language/Extra.hs new file mode 100644 index 0000000..16344a1 --- /dev/null +++ b/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 diff --git a/src/Hydra/Prelude.hs b/src/Hydra/Prelude.hs new file mode 100644 index 0000000..12d7af9 --- /dev/null +++ b/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, (!!)) diff --git a/src/Hydra/Runtime.hs b/src/Hydra/Runtime.hs new file mode 100644 index 0000000..763650a --- /dev/null +++ b/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 diff --git a/src/Language/Haskell/TH/MakeFunctor.hs b/src/Language/Haskell/TH/MakeFunctor.hs new file mode 100644 index 0000000..9f5d97c --- /dev/null +++ b/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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..77485ab --- /dev/null +++ b/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" diff --git a/test/spec/Spec.hs b/test/spec/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/test/spec/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}