diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +0.2 [2019.08.28] +------------------- +* Release use `Control.Monad.Factory`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,9 +5,17 @@ [![stackage LTS package](http://stackage.org/package/boots/badge/lts)](http://stackage.org/lts/package/boots) [![stackage Nightly package](http://stackage.org/package/boots/badge/nightly)](http://stackage.org/nightly/package/boots) [![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/leptonyu/boots/blob/master/LICENSE) +![Hackage-Deps](https://img.shields.io/hackage-deps/v/boots) IoC Monad in Haskell. +### Packages based on boots + +- [![Hackage](https://img.shields.io/badge/boots-app-orange)](https://hackage.haskell.org/package/boots-app) Factory for quickly building an application. +- [![Hackage](https://img.shields.io/badge/boots-web-orange)](https://hackage.haskell.org/package/boots-web) Factory for quickly building a web application. +- [![Hackage](https://img.shields.io/badge/boots-cloud-orange)](https://hackage.haskell.org/package/boots-cloud) Factory for quickly building a microservice. + + ### Motivation Simplify to create an application in Haskell. @@ -17,18 +25,3 @@ ## A Project Use boots to Build Refer to [鬼谷子](https://github.com/leptonyu/guiguzi) - -### Have a Try - -```Haskell -factory = do - log <- logFactory - conf <- confFactory - within (log, conf) $ do - a <- withFactory fst aFactory - b <- withFactory snd bFactory - polish AB{..} - [ xFactory - , yFactory - ] >>> bootFactory -``` diff --git a/boots.cabal b/boots.cabal --- a/boots.cabal +++ b/boots.cabal @@ -4,13 +4,13 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 07ea4190e76748290f6abd6bd660c00f0d6ba2c91a51c3021fb010274bb510ac +-- hash: f2aa610e1c0d974992d89103041429343b5aa10e47a821783039d97408d2ee7f name: boots -version: 0.1.1 +version: 0.2 synopsis: IoC Monad in Haskell -description: Inverse of control monad used in building large application. -category: Library, Application +description: Monad used to encapsulate components, similiar to an IoC container. +category: Library, Application, Monad, Factory, IoC homepage: https://github.com/leptonyu/boots#readme author: Daniel YU maintainer: leptonyu@gmail.com @@ -20,15 +20,17 @@ build-type: Simple extra-source-files: README.md + CHANGELOG.md library exposed-modules: - Boots.Factory + Control.Monad.Factory + Control.Monad.Factory.Class other-modules: Paths_boots hs-source-dirs: src - default-extensions: FlexibleInstances MultiParamTypeClasses GeneralizedNewtypeDeriving OverloadedStrings RecordWildCards FlexibleContexts RankNTypes ScopedTypeVariables FunctionalDependencies ConstraintKinds + default-extensions: RecordWildCards ScopedTypeVariables ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: base >=4.10 && <5 @@ -40,15 +42,14 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Boots.Factory Paths_boots hs-source-dirs: test - src - default-extensions: FlexibleInstances MultiParamTypeClasses GeneralizedNewtypeDeriving OverloadedStrings RecordWildCards FlexibleContexts RankNTypes ScopedTypeVariables FunctionalDependencies ConstraintKinds + default-extensions: RecordWildCards ScopedTypeVariables ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: base >=4.10 && <5 + , boots , exceptions >=0.10.2 && <0.11 , hspec , mtl >=2.2.2 && <2.3 diff --git a/src/Boots/Factory.hs b/src/Boots/Factory.hs deleted file mode 100644 --- a/src/Boots/Factory.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module: Boots.Factory --- Copyright: 2019 Daniel YU --- License: MIT --- Maintainer: leptonyu@gmail.com --- Stability: experimental --- Portability: portable --- --- IoC Monad in Haskell. --- --- * Motivation --- --- Simplify to create an application in Haskell. --- --- When we decide to create an application using Haskell. --- We may need using configurations, loggers as basic functions. --- If this application needs storages, caches, etc., --- then we have to weaving the management of connection of these facilities into the application. --- Connections need to be created before and be destroyed after using them. --- There is a common strategy to manage connections, that is using `Control.Monad.Cont`. --- Then we can encapsulate the management of connections separately. --- For example, we can write a database plugin `Factory` @m@ @cxt@ @DBConnection@, --- which can manage the database connections in monad @m@ with context @cxt@. --- Context @cxt@ may be requested for getting configurations or logging functions. --- When all the components of application are encapsulated by plugins, then running an application will be simplified. --- --- * Factory --- --- 'Factory' has an environment @env@, which provides anything needs by the factory. @component@ is the production of --- the factory, it will be used by other 'Factory'. Finally to build a complete 'Factory' m () (m ()), which can be 'boot'. --- --- For example: --- --- > factory = do --- > log <- logFactory --- > conf <- confFactory --- > within (log, conf) $ do --- > a <- withFactory fst aFactory --- > b <- withFactory snd bFactory --- > polish AB{..} --- > [ xFactory --- > , yFactory --- > ] >>> bootFactory -module Boots.Factory( - -- * Definition - Factory - -- ** Run functions - , running - , boot - -- * Factory Construction - -- ** With - , withFactory - , within - -- ** Polish - , polish - -- ** Nature Transformation - , natTrans - -- ** Resource - , wrap - , bracket - , offer - , delay - -- * Reexport Function - -- ** Category Arrow - , (C.>>>) - , (C.<<<) - -- ** Monoid Join - , (<>) - -- ** Other - , MonadThrow(..) - , MonadCatch - , MonadReader(..) - , asks - , MonadIO(..) - , lift - ) where - -import qualified Control.Category as C -import Control.Monad.Catch hiding (bracket) -import Control.Monad.Cont -import Control.Monad.Reader -import Unsafe.Coerce (unsafeCoerce) -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup -#endif - --- | Factory defines how to generate a @component@ under the environment @env@ in monad @m@. --- It is similar to IoC container in oop, @env@ will provide anything to be wanted to generate @component@. --- -newtype Factory m env component - = Factory { unFactory :: ReaderT env (ContT () m) component } - deriving (Functor, Applicative, Monad, MonadReader env, MonadIO) - -instance MonadThrow m => MonadThrow (Factory m env) where - {-# INLINE throwM #-} - throwM = offer . throwM - -instance Monad m => MonadCont (Factory m env) where - {-# INLINE callCC #-} - callCC a = do - env <- ask - wrap . running env $ callCC a - -instance Semigroup (Factory m env env) where - {-# INLINE (<>) #-} - a <> b = a >>= (`within` b) - -instance Monoid (Factory m env env) where - {-# INLINE mempty #-} - mempty = ask - {-# INLINE mappend #-} - mappend = (<>) - -instance C.Category (Factory m) where - {-# INLINE id #-} - id = ask - {-# INLINE (.) #-} - a . b = b >>= (`within` a) - --- | Running the factory. -running :: env -> Factory m env c -> (c -> m ()) -> m () -running env pma = runContT (runReaderT (unFactory pma) env) -{-# INLINE running #-} - --- | Run the application using a specified factory. -boot :: Monad m => Factory m () (m ()) -> m () -boot factory = running () factory id - --- | Switch factory environment. -withFactory :: (env' -> env) -> Factory m env component -> Factory m env' component -withFactory = unsafeCoerce withReaderT -{-# INLINE withFactory #-} - --- | Construct factory under @env@, and adapt it to fit another @env'@. -within :: env -> Factory m env component -> Factory m env' component -within = withFactory . const -{-# INLINE within #-} - --- | Polish @component@ by a sequence of 'Factory', and construct a unified one. -polish :: component -> [Factory m component component] -> Factory m env' component -polish env = within env . mconcat -{-# INLINE polish #-} - --- | Nature transform of one 'Factory' with monad @n@ into another with monad @m@. -natTrans :: (n () -> m ()) -> (m () -> n ()) -> Factory n env component -> Factory m env component -natTrans fnm fmn fac = do - env <- ask - wrap $ \fm -> fnm $ running env fac (fmn . fm) -{-# INLINE natTrans #-} - --- | Wrap raw procedure into a 'Factory'. -wrap :: ((c -> m ()) -> m ()) -> Factory m env c -wrap = Factory . lift . ContT -{-# INLINE wrap #-} - --- | Construct open-close resource into a 'Factory'. -bracket :: MonadCatch m => m res -> (res -> m ()) -> Factory m env res -bracket open close = wrap $ \f -> do - res <- open - a <- try $ f res - b <- try $ close res - go a b - where - go (Left e) _ = throwM (e :: SomeException) - go _ (Left e) = throwM (e :: SomeException) - go _ _ = return () - {-# INLINE go #-} -{-# INLINE bracket #-} - --- | Lift a monad @m@ into a 'Factory'. -offer :: Monad m => m a -> Factory m env a -offer ma = wrap (ma >>=) -{-# INLINE offer #-} - --- | Put a delay action into 'Factory', it will run at close phase. -delay :: MonadCatch m => m () -> Factory m env () -delay ma = bracket (return ()) (const ma) -{-# INLINE delay #-} diff --git a/src/Control/Monad/Factory.hs b/src/Control/Monad/Factory.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Factory.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | +-- Module: Control.Monad.Factory +-- Copyright: 2019 Daniel YU +-- License: MIT +-- Maintainer: leptonyu@gmail.com +-- Stability: experimental +-- Portability: portable +-- +-- IoC Monad in Haskell. +-- +-- * Motivation +-- +-- Simplify to create an application in Haskell. +-- +-- When we decide to create an application using Haskell. +-- We may need using configurations, loggers as basic functions. +-- If this application needs storages, caches, etc., +-- then we have to weaving the management of connection of these facilities into the application. +-- Connections need to be created before and be destroyed after using them. +-- There is a common strategy to manage connections, that is using `Control.Monad.Cont`. +-- Then we can encapsulate the management of connections separately. +-- For example, we can write a database plugin `Factory` @m@ @cxt@ @DBConnection@, +-- which can manage the database connections in monad @m@ with context @cxt@. +-- Context @cxt@ may be requested for getting configurations or logging functions. +-- When all the components of application are encapsulated by plugins, then running an application will be simplified. +-- +-- * Factory +-- +-- 'Factory' has an environment @env@, which provides anything needs by the factory. @component@ is the production of +-- the factory, it will be used by other 'Factory'. Finally to build a complete 'Factory' m () (m ()), which can be 'boot'. +-- +-- +module Control.Monad.Factory( + -- * Monad + MonadFactory(..) + , defer + , asksEnv + , modifyEnv + , withEnv + , runEnv + -- * Monad Instance + , Factory(..) + -- ** Run functions + , running + , boot + -- ** With + , within + , withFactory + , wrap + , liftFT + , natTrans + , tryBuild + -- * Reexport Function + -- ** Category Arrow + , (C.>>>) + , (C.<<<) + -- ** Monoid Join + , (<>) + -- ** Other + , MonadThrow(..) + , MonadCatch + , MonadMask + , MonadIO(..) + , lift + ) where + +import qualified Control.Category as C +import Control.Monad.Catch +import Control.Monad.Cont +import Control.Monad.Factory.Class +import Control.Monad.State +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup +#endif + + +-- | Factory defines how to generate a @component@ under the environment @env@ in monad @m@. +-- It is similar to IoC container in oop, @env@ will provide anything to be wanted to generate @component@. +-- +newtype Factory m env component + = Factory { unFactory :: StateT env (ContT () m) component } + deriving (Functor, Applicative, Monad, MonadState env, MonadIO) + +instance MonadThrow m => MonadThrow (Factory m env) where + {-# INLINE throwM #-} + throwM = liftFT . throwM + +instance Monad m => MonadCont (Factory m env) where + {-# INLINE callCC #-} + callCC a = do + env <- get + wrap . running env $ callCC a + +instance C.Category (Factory m) where + {-# INLINE id #-} + id = get + {-# INLINE (.) #-} + a . b = b >>= (`within` a) + +instance MonadMask m => MonadFactory env m (Factory m env) where + getEnv = get + putEnv = put + produce o = wrap . bracket o + +-- | Running the factory. +running :: env -> Factory m env c -> (c -> m ()) -> m () +running env pma = runContT (evalStateT (unFactory pma) env) +{-# INLINE running #-} + +-- | Run the application using a specified factory. +boot :: Monad m => Factory m () (m ()) -> m () +boot factory = running () factory id + +-- | Construct factory under @env@, and adapt it to fit another @env'@. +within :: env -> Factory m env component -> Factory m env' component +within env = Factory . lift . (`evalStateT` env) . unFactory +{-# INLINE within #-} + +-- | Construct factory under @env@, and adapt it to fit another @env'@. +withFactory :: (env' -> env) -> Factory m env component -> Factory m env' component +withFactory f (Factory ma) = do + env <- get + Factory (lift $ evalStateT ma (f env)) +{-# INLINE withFactory #-} + +-- | Wrap raw procedure into a 'Factory'. +wrap :: ((c -> m ()) -> m ()) -> Factory m env c +wrap = Factory . lift . ContT +{-# INLINE wrap #-} + +-- | Lift a monad @m@ into a 'Factory'. +liftFT :: Monad m => m a -> Factory m env a +liftFT ma = wrap (ma >>=) +{-# INLINE liftFT #-} + +-- | Nature transform of one 'Factory' with monad @n@ into another with monad @m@. +natTrans :: (n () -> m ()) -> (m () -> n ()) -> Factory n env component -> Factory m env component +natTrans fnm fmn fac = do + env <- get + wrap $ \fm -> fnm $ running env fac (fmn . fm) +{-# INLINE natTrans #-} + +{-# INLINE tryBuild #-} +tryBuild :: Bool -> Factory n env () -> Factory n env () +tryBuild b p = if b then p else return () diff --git a/src/Control/Monad/Factory/Class.hs b/src/Control/Monad/Factory/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Factory/Class.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +-- | +-- Module: Control.Monad.Factory.Class +-- Copyright: 2019 Daniel YU +-- License: MIT +-- Maintainer: leptonyu@gmail.com +-- Stability: experimental +-- Portability: portable +-- +module Control.Monad.Factory.Class( + MonadFactory(..) + , defer + , asksEnv + , withEnv + , modifyEnv + , runEnv + ) where + +-- | Monads which allow to produce @component@ under @env@, and @env@ can be changed by this procedure. +class (Monad m, Monad n) => MonadFactory env n m | m -> env n where + -- | Return the environment of the monad. + getEnv :: m env + -- | Replace the environment inside the monad. + putEnv :: env -> m () + -- | Produce a resource component, with open and close. + produce + :: n component -- ^ Open resource + -> (component -> n ()) -- ^ Close resource + -> m component + +-- | Asks sub value of env. +asksEnv :: MonadFactory env n m => (env -> a) -> m a +asksEnv f = f <$> getEnv + +-- | Defer to run side effect when closeing resource. +defer :: MonadFactory env n m => n () -> m () +defer = produce (return ()) . const + +-- | Change environment @env@. +withEnv :: MonadFactory env n m => (env -> m env) -> m () +withEnv f = getEnv >>= f >>= putEnv + +-- | Modify environment @env@. +modifyEnv :: MonadFactory env n m => (env -> env) -> m () +modifyEnv f = getEnv >>= putEnv . f + +-- | Run factory, return component @c@ and updated environment @env@. +runEnv :: MonadFactory env n m => m c -> m (env, c) +runEnv ma = do + a <- ma + e <- getEnv + return (e, a) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,14 +1,14 @@ module Main where -import Boots.Factory import Control.Concurrent.MVar import Control.Exception (Exception) +import Control.Monad.Factory import Control.Monad.Identity import Test.Hspec main = hspec $ do - describe "Boots.Factory" specProperty + describe "Control.Monad.Factory" specProperty data TestExp = Failure deriving Show @@ -27,20 +27,15 @@ boot (return $ return ()) `shouldBe` Just () it "boot - Error " $ do boot (return $ throwM Failure) `shouldBe` Nothing - context "With" $ do - it "withFactory" $ do - running ('A', True) (withFactory fst $ ask >>= \a -> offer (a `shouldBe` 'A')) return - running ('A', True) (withFactory snd $ ask >>= \a -> offer (a `shouldBe` True)) return it "within" $ do - running () (within 'A' $ ask >>= \a -> offer (a `shouldBe` 'A')) return - context "Polish" $ do - it "polish" $ do - running () (polish (0 :: Int) (replicate 10 $ withFactory (+1) ask)) (shouldBe 10) + running () (within 'A' $ getEnv >>= \a -> liftFT (a `shouldBe` 'A')) return + it "modify" $ do + running () (within 'A' $ putEnv 'B' >> getEnv >>= \a -> liftFT (a `shouldBe` 'B')) return context "natTrans" $ do it "natTrans" $ do running () (natTrans runIdentityT IdentityT $ return ()) return `shouldBe` Just () context "Resource" $ do - it "bracket" $ do + it "produce" $ do ref <- newMVar (0 :: Int) let open = do @@ -54,8 +49,8 @@ b `shouldBe` 2 return () boot $ do - a <- bracket open close - offer $ do + a <- produce open close + liftFT $ do a `shouldBe` 0 b <- swapMVar ref 2 b `shouldBe` 1 @@ -63,8 +58,8 @@ it "bracket - error" $ do ref <- newMVar (0 :: Int) (`shouldThrow` anyException) $ boot $ do - a <- bracket (readMVar ref) (\_ -> throwM Failure) - _ <- offer $ do + a <- produce (readMVar ref) (\_ -> throwM Failure) + _ <- liftFT $ do a `shouldBe` 0 swapMVar ref 1 return (return ())