haskey-mtl (empty) → 0.1.0.0
raw patch · 6 files changed
+416/−0 lines, 6 filesdep +basedep +binarydep +exceptionssetup-changed
Dependencies added: base, binary, exceptions, haskey, haskey-btree, haskey-mtl, lens, mtl, text, transformers
Files
- LICENSE +32/−0
- README.md +11/−0
- Setup.hs +2/−0
- example/Main.hs +150/−0
- haskey-mtl.cabal +58/−0
- src/Control/Monad/Haskey.hs +163/−0
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright (c) 2017, Henri Verroken, Steven Keuchel++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Henri Verroken or Steven Keuchel nor the+ names of other contributors may be used to endorse or promote+ products derived from this software without specific prior+ written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,11 @@+haskey-mtl+==========++[](https://travis-ci.org/haskell-haskey/haskey-mtl)+[](https://hackage.haskell.org/package/haskey-mtl)+[](http://stackage.org/nightly/package/haskey-mtl)+[](http://stackage.org/lts/package/haskey-mtl)++A monad transformer supporting Haskey transactions.++See [example/Main.hs](example/Main.hs) for a complete example.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Main.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+module Main where++import Control.Applicative (Applicative, (<$>))+import Control.Lens (Lens', lens, (^.), (%%~))+import Control.Monad.Haskey+import Control.Monad.Reader+import Control.Monad.IO.Class (MonadIO, liftIO)++import Data.BTree.Alloc (AllocM, AllocReaderM)+import Data.BTree.Impure (Tree, insertTree, lookupTree, toList)+import Data.BTree.Primitives (Value)+import Data.Binary (Binary)+import Data.Foldable (foldlM)+import Data.Int (Int64)+import Data.Text (Text, unpack)+import Data.Typeable (Typeable)+import qualified Data.BTree.Impure as Tree++import Database.Haskey.Alloc.Concurrent (Root)++import GHC.Generics (Generic)++--------------------------------------------------------------------------------+-- Our application monad transformer stack, includes the HaskeyT monad+-- transformer.+--------------------------------------------------------------------------------++newtype App a = AppT (ReaderT String (HaskeyT Schema IO) a)+ deriving (Functor, Applicative, Monad, MonadIO,+ MonadHaskey Schema, MonadReader String)++runApp :: App a+ -> String+ -> ConcurrentDb Schema+ -> FileStoreConfig+ -> IO a+runApp (AppT m) r = runFileStoreHaskeyT (runReaderT m r)++--------------------------------------------------------------------------------+-- Definition of our custom schema. As well as query and modify functions.+--------------------------------------------------------------------------------++data Tweet = Tweet {+ tweetUser :: !Text+ , tweetContent :: !Text+ } deriving (Generic, Show, Typeable)++instance Binary Tweet+instance Value Tweet++data User = User {+ userName :: !Text+ , userEmail :: !Text+ } deriving (Generic, Show, Typeable)++instance Binary User+instance Value User++data Schema = Schema {+ _schemaTweets :: Tree Int64 Tweet+ , _schemaUsers :: Tree Text User+ } deriving (Generic, Show, Typeable)++instance Binary Schema+instance Value Schema+instance Root Schema++emptySchema :: Schema+emptySchema = Schema Tree.empty Tree.empty++schemaTweets :: Lens' Schema (Tree Int64 Tweet)+schemaTweets = lens _schemaTweets $ \s x -> s { _schemaTweets = x }++schemaUsers :: Lens' Schema (Tree Text User)+schemaUsers = lens _schemaUsers $ \s x -> s { _schemaUsers = x }++-- | Insert or update a tweet.+insertTweet :: AllocM n => Int64 -> Tweet -> Schema -> n Schema+insertTweet k v = schemaTweets %%~ insertTree k v++-- | Query all tweets.+queryAllTweets :: AllocReaderM n => Schema -> n [(Int64, Tweet)]+queryAllTweets root = toList (root ^. schemaTweets)++-- | Query a tweet.+queryTweet :: AllocReaderM n => Int64 -> Schema -> n (Maybe Tweet)+queryTweet k root = lookupTree k (root ^. schemaTweets)++-- | Insert a new user.+insertUser :: AllocM n => Text -> User -> Schema -> n Schema+insertUser k v = schemaUsers %%~ insertTree k v++-- | Quer a user.+queryUser :: AllocReaderM n => Text -> Schema -> n (Maybe User)+queryUser userId root = lookupTree userId (root ^. schemaUsers)++--------------------------------------------------------------------------------+-- Our main application.+--------------------------------------------------------------------------------+main :: IO ()+main = do+ let db = "/tmp/mtl-example.haskey"+ putStrLn $ "Using " ++ db+ main' db++main' :: FilePath -> IO ()+main' fp = do+ db <- flip runFileStoreT defFileStoreConfig $+ openConcurrentDb hnds >>= \case+ Nothing -> createConcurrentDb hnds emptySchema+ Just db -> return db++ runApp app "Hello World!" db defFileStoreConfig+ where+ hnds = concurrentHandles fp++app :: App ()+app = insertDefaultTweets >> printTweetsWithUser++insertDefaultTweets :: App ()+insertDefaultTweets = do+ transact_ $ \schema ->+ foldlM (flip $ uncurry insertUser) schema users+ >>= commit_++ transact_ $ \schema ->+ foldlM (flip $ uncurry insertTweet) schema tweets+ >>= commit_+ where+ users = [("foo", User "Foo" "foo@example.org"),+ ("bar", User "Bar" "bar@example.org")]+ tweets = [(1, Tweet "foo" "Hey, I'm Foo!"),+ (2, Tweet "bar" "Hey, I'm Bar!"),+ (3, Tweet "foo" "I like you, Bar!")]++printTweetsWithUser :: App ()+printTweetsWithUser = do+ tweets <- map snd <$> transactReadOnly queryAllTweets+ users <- mapM (\t -> transactReadOnly $ queryUser (tweetUser t)) tweets+ mapM_ print' $ zip users tweets+ where+ print' (Just user, tweet) = liftIO . putStrLn $ unpack (userName user) ++ ": " ++ unpack (tweetContent tweet)+ print' (Nothing , tweet) = liftIO . putStrLn $ "?: " ++ unpack (tweetContent tweet)
+ haskey-mtl.cabal view
@@ -0,0 +1,58 @@+name: haskey-mtl+version: 0.1.0.0+synopsis: A monad transformer supporting Haskey transactions.+description:+ This library provides a monad transformer supporting Haskey transactions,+ with default lifted instances for all mtl monad transformers.+ .+ For more information on how to use this package, visit+ <https://github.com/haskell-haskey/haskey-mtl>+homepage: https://github.com/haskell-haskey+license: BSD3+license-file: LICENSE+author: Henri Verroken, Steven Keuchel+maintainer: steven.keuchel@gmail.com+copyright: Copyright (c) 2017, Henri Verroken, Steven Keuchel+category: Database+build-type: Simple+cabal-version: >=1.10++extra-source-files: README.md++library+ exposed-modules:+ Control.Monad.Haskey++ build-depends:+ base >=4.7 && <5,+ exceptions >=0.8.3 && <0.9,+ mtl >=2.1 && <3,+ transformers >=0.3 && <1,+ haskey-btree >=0.2.0.0 && <1,+ haskey++ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: src++test-suite haskey-mtl-example+ type: exitcode-stdio-1.0+ hs-source-dirs: example+ main-is: Main.hs+ build-depends:+ base >= 4.7 && <5,+ haskey,+ haskey-btree >=0.2 && <1,+ haskey-mtl,+ binary >=0.6 && <0.9 || >0.9 && <1,+ exceptions >=0.8.3 && <0.9,+ lens >=4.12 && <5,+ mtl >=2.1 && <3,+ transformers >=0.3 && <1,+ text >=1.2 && <2++ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ default-language: Haskell2010+source-repository head+ type: git+ location: https://github.com/haskell-haskey/haskey-mtl
+ src/Control/Monad/Haskey.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}+-- | A monad transformer supporting Haskey transactions.+--+-- See <https://github.com/haskell-haskey/haskey-mtl/blob/master/example/Main.hs>+-- for a complete example.+module Control.Monad.Haskey (+ -- * Re-exports+ module Database.Haskey.Alloc.Transaction++ -- * Monad+, MonadHaskey(..)+, HaskeyT+, runFileStoreHaskeyT++ -- * Open and create (re-exports)+, FileStoreT+, FileStoreConfig+, runFileStoreT+, defFileStoreConfig+, ConcurrentDb+, concurrentHandles+, openConcurrentDb+, createConcurrentDb+) where++import Control.Applicative (Applicative)+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)+import Control.Monad.Trans.Class (MonadTrans(..))++import Control.Monad.RWS (MonadRWS)+import Control.Monad.State (MonadState(..))+import Control.Monad.Writer (MonadWriter(..))+import qualified Control.Monad.RWS.Lazy as RWSL+import qualified Control.Monad.RWS.Strict as RWSS+import qualified Control.Monad.State.Lazy as StateL+import qualified Control.Monad.State.Strict as StateS+import qualified Control.Monad.Writer.Lazy as WriterL+import qualified Control.Monad.Writer.Strict as WriterS++import Data.BTree.Alloc (AllocM, AllocReaderM)+import Data.Monoid (Monoid)++import Database.Haskey.Alloc.Concurrent (ConcurrentDb, Root, Transaction,+ concurrentHandles,+ openConcurrentDb, createConcurrentDb)+import Database.Haskey.Alloc.Transaction+import Database.Haskey.Store.File (FileStoreT, runFileStoreT,+ FileStoreConfig, defFileStoreConfig)+import qualified Database.Haskey.Alloc.Concurrent as D++-- | A monad supporting database transactions.+--+-- The type @root@ is the data type holding the roots of the database trees.+class Monad m => MonadHaskey root m | m -> root where+ transact :: Root root+ => (forall n. (AllocM n, MonadMask n) => root -> n (Transaction root a))+ -> m a++ transact_ :: Root root+ => (forall n. (AllocM n, MonadMask n) => root -> n (Transaction root ()))+ -> m ()++ transactReadOnly :: Root root+ => (forall n. (AllocReaderM n, MonadMask n) => root -> n a)+ -> m a++-- | A monad transformer that is an instance of 'MonadHaskey'.+--+-- The @root@ is the data type holding the roots of the database trees.+newtype HaskeyT root m a = HaskeyT { fromHaskeyT :: ReaderT (ConcurrentDb root, FileStoreConfig) m a }+ deriving (Functor, Applicative, Monad, MonadIO,+ MonadThrow, MonadCatch, MonadMask)++instance (Root root, Applicative m, MonadMask m, MonadIO m) => MonadHaskey root (HaskeyT root m) where+ transact tx = askDb >>= runFileStoreT' . D.transact tx+ transact_ tx = askDb >>= runFileStoreT' . D.transact_ tx+ transactReadOnly tx = askDb >>= runFileStoreT' . D.transactReadOnly tx++instance MonadTrans (HaskeyT root) where+ lift = HaskeyT . lift++-- | Run Haskey transactions, backed by a file store.+runFileStoreHaskeyT :: (Root root, MonadMask m, MonadIO m)+ => HaskeyT root m a+ -> ConcurrentDb root+ -> FileStoreConfig+ -> m a+runFileStoreHaskeyT m db config = runReaderT (fromHaskeyT m) (db, config)++runFileStoreT' :: (MonadIO m, MonadMask m)+ => FileStoreT FilePath (HaskeyT root m) a+ -> HaskeyT root m a+runFileStoreT' m = askCfg >>= runFileStoreT m++askDb :: Monad m => HaskeyT root m (ConcurrentDb root)+askDb = HaskeyT $ asks fst++askCfg :: Monad m => HaskeyT root m FileStoreConfig+askCfg = HaskeyT $ asks snd++--------------------------------------------------------------------------------+-- Some definitions of mtl monad transformers below.+--------------------------------------------------------------------------------++instance MonadReader r m => MonadReader r (HaskeyT root m) where+ ask = lift ask+ reader = lift . reader+ local f (HaskeyT (ReaderT m)) = HaskeyT . ReaderT $ \r -> local f (m r)++instance MonadHaskey root m => MonadHaskey root (ReaderT r m) where+ transact tx = lift $ transact tx+ transact_ tx = lift $ transact_ tx+ transactReadOnly tx = lift $ transactReadOnly tx++instance MonadState s m => MonadState s (HaskeyT root m) where+ get = lift get+ put = lift . put+ state = lift . state++instance MonadHaskey root m => MonadHaskey root (StateL.StateT s m) where+ transact tx = lift $ transact tx+ transact_ tx = lift $ transact_ tx+ transactReadOnly tx = lift $ transactReadOnly tx++instance MonadHaskey root m => MonadHaskey root (StateS.StateT s m) where+ transact tx = lift $ transact tx+ transact_ tx = lift $ transact_ tx+ transactReadOnly tx = lift $ transactReadOnly tx++instance MonadWriter w m => MonadWriter w (HaskeyT root m) where+ writer = lift . writer+ tell = lift . tell+ listen (HaskeyT (ReaderT m)) = HaskeyT . ReaderT $ \r -> listen (m r)+ pass (HaskeyT (ReaderT m)) = HaskeyT . ReaderT $ \r -> pass (m r)++instance (Monoid w, MonadHaskey root m) => MonadHaskey root (WriterL.WriterT w m) where+ transact tx = lift $ transact tx+ transact_ tx = lift $ transact_ tx+ transactReadOnly tx = lift $ transactReadOnly tx++instance (Monoid w, MonadHaskey root m) => MonadHaskey root (WriterS.WriterT w m) where+ transact tx = lift $ transact tx+ transact_ tx = lift $ transact_ tx+ transactReadOnly tx = lift $ transactReadOnly tx++instance MonadRWS r w s m => MonadRWS r w s (HaskeyT root m) where++instance (Monoid w, MonadHaskey root m) => MonadHaskey root (RWSL.RWST r w s m) where+ transact tx = lift $ transact tx+ transact_ tx = lift $ transact_ tx+ transactReadOnly tx = lift $ transactReadOnly tx++instance (Monoid w, MonadHaskey root m) => MonadHaskey root (RWSS.RWST r w s m) where+ transact tx = lift $ transact tx+ transact_ tx = lift $ transact_ tx+ transactReadOnly tx = lift $ transactReadOnly tx+--------------------------------------------------------------------------------