data-has (empty) → 0.1.0.0
raw patch · 6 files changed
+477/−0 lines, 6 filesdep +basedep +criteriondep +data-hassetup-changed
Dependencies added: base, criterion, data-has, transformers
Files
- Data/Has.hs +276/−0
- LICENSE +30/−0
- README.md +33/−0
- Setup.hs +2/−0
- benchmark/Main.hs +98/−0
- data-has.cabal +38/−0
+ Data/Has.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++{-|+Module : Data.Has+Description : Simple extensible product+Copyright : (c) Winterland, 2016+License : BSD+Maintainer : drkoster@qq.com+Stability : experimental+Portability : PORTABLE++This module provide 'Has' class which provide simple extensible product.+The use case for this class is illustrated as following:++@+ \{\-\# LANGUAGE FlexibleContexts \#\-\}++ -- in some library code+ ...+ logInAnyReaderHasLogger :: (Has Logger r, MonadReader r m) => LogString -> m ()+ logInAnyReaderHasLogger s = asks get >>= logWithLogger s++ queryInAnyReaderHasSQL :: (Has SqlBackEnd r, MonadReader r m) => Query -> m a+ queryInAnyReaderHasSQL q = asks get >>= queryWithSQL q+ ...++ -- now you want to use these effects together+ ...+ logger <- initLogger ...+ sql <- initSqlBackEnd ...++ (`runReader` (logger, sql)) $ do+ ...+ logInAnyReaderHasLogger ...+ ...+ x <- queryInAnyReaderHasSQL ...+ ...+@++If you need multiple elements with same type, you can use <http://hackage.haskell.org/package/tagged tagged>+like:++@+(Has (Tagged \"StdLogger\" Logger) r, Has (Tagged \"FileLogger\" Logger) r, ...) => ...++runYourMonad ... ( stdLogger :: Tagged \"StdLogger\" Logger+ , fileLogger :: Tagged \"FileLogger\" Logger, ...)+@++Or you can define newtypes(which is less verbose and require no dependency):++@+newtype StdLogger = StdLogger Logger+newtype FileLogger = FileLogger Logger++runYourMonad ... (StdLogger stdLogger, FileLogger fileLogger)+@++Polymorphic values, such as numeric and string literals(with OverloadedString Enabled)+may lead to type inference failure, you simply need type annotations in these cases:++@ ... (3 :: Int, "hello" :: String, ...) @++-}++module Data.Has where++-- | A type class for extensible product.+--+-- We provide instances for tuples up to 8 elements by default.+-- You can define your own instance of 'Has', but most of the time tuples will do fine.+--+class Has a t where+ get :: t -> a+ modify :: (a -> a) -> t -> t++instance Has a a where+ get = id+ {-# INLINABLE get #-}+ modify = id+ {-# INLINABLE modify #-}++instance Has a (a, b) where+ get (a, _) = a+ {-# INLINABLE get #-}+ modify f (a, b) = (f a, b)+ {-# INLINABLE modify #-}+instance Has b (a, b) where+ get (_, b) = b+ {-# INLINABLE get #-}+ modify f (a, b) = (a, f b)+ {-# INLINABLE modify #-}++--------------------------------------------------------------------------------++instance Has a (a, b, c) where+ get (a, _, _) = a+ {-# INLINABLE get #-}+ modify f (a, b, c) = (f a, b, c)+ {-# INLINABLE modify #-}+instance Has b (a, b, c) where+ get (_, b, _) = b+ {-# INLINABLE get #-}+ modify f (a, b, c) = (a, f b, c)+ {-# INLINABLE modify #-}+instance Has c (a, b, c) where+ get (_, _, c) = c+ {-# INLINABLE get #-}+ modify f (a, b, c) = (a, b, f c)+ {-# INLINABLE modify #-}++--------------------------------------------------------------------------------++instance Has a (a, b, c, d) where+ get (a, _, _, _) = a+ {-# INLINABLE get #-}+ modify f (a, b, c, d) = (f a, b, c, d)+ {-# INLINABLE modify #-}+instance Has b (a, b, c, d) where+ get (_, b, _, _) = b+ {-# INLINABLE get #-}+ modify f (a, b, c, d) = (a, f b, c, d)+ {-# INLINABLE modify #-}+instance Has c (a, b, c, d) where+ get (_, _, c, _) = c+ {-# INLINABLE get #-}+ modify f (a, b, c, d) = (a, b, f c, d)+ {-# INLINABLE modify #-}+instance Has d (a, b, c, d) where+ get (_, _, _, d) = d+ {-# INLINABLE get #-}+ modify f (a, b, c, d) = (a, b, c, f d)+ {-# INLINABLE modify #-}++--------------------------------------------------------------------------------++instance Has a (a, b, c, d, e) where+ get (a, _, _, _, _) = a+ {-# INLINABLE get #-}+ modify f (a, b, c, d, e) = (f a, b, c, d, e)+ {-# INLINABLE modify #-}+instance Has b (a, b, c, d, e) where+ get (_, b, _, _, _) = b+ {-# INLINABLE get #-}+ modify f (a, b, c, d, e) = (a, f b, c, d, e)+ {-# INLINABLE modify #-}+instance Has c (a, b, c, d, e) where+ get (_, _, c, _, _) = c+ {-# INLINABLE get #-}+ modify f (a, b, c, d, e) = (a, b, f c, d, e)+ {-# INLINABLE modify #-}+instance Has d (a, b, c, d, e) where+ get (_, _, _, d, _) = d+ {-# INLINABLE get #-}+ modify f (a, b, c, d, e) = (a, b, c, f d, e)+ {-# INLINABLE modify #-}+instance Has e (a, b, c, d, e) where+ get (_, _, _, _, e) = e+ {-# INLINABLE get #-}+ modify f (a, b, c, d, e) = (a, b, c, d, f e)+ {-# INLINABLE modify #-}++--------------------------------------------------------------------------------++instance Has a (a, b, c, d, e, f) where+ get (a, _, _, _, _, _) = a+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f) = (ff a, b, c, d, e, f)+ {-# INLINABLE modify #-}+instance Has b (a, b, c, d, e, f) where+ get (_, b, _, _, _, _) = b+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f) = (a, ff b, c, d, e, f)+ {-# INLINABLE modify #-}+instance Has c (a, b, c, d, e, f) where+ get (_, _, c, _, _, _) = c+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f) = (a, b, ff c, d, e, f)+ {-# INLINABLE modify #-}+instance Has d (a, b, c, d, e, f) where+ get (_, _, _, d, _, _) = d+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f) = (a, b, c, ff d, e, f)+ {-# INLINABLE modify #-}+instance Has e (a, b, c, d, e, f) where+ get (_, _, _, _, e, _) = e+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f) = (a, b, c, d, ff e, f)+ {-# INLINABLE modify #-}+instance Has f (a, b, c, d, e, f) where+ get (_, _, _, _, _, f) = f+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f) = (a, b, c, d, e, ff f)+ {-# INLINABLE modify #-}++--------------------------------------------------------------------------------++instance Has a (a, b, c, d, e, f, g) where+ get (a, _, _, _, _, _, _) = a+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g) = (ff a, b, c, d, e, f, g)+ {-# INLINABLE modify #-}+instance Has b (a, b, c, d, e, f, g) where+ get (_, b, _, _, _, _, _) = b+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g) = (a, ff b, c, d, e, f, g)+ {-# INLINABLE modify #-}+instance Has c (a, b, c, d, e, f, g) where+ get (_, _, c, _, _, _, _) = c+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g) = (a, b, ff c, d, e, f, g)+ {-# INLINABLE modify #-}+instance Has d (a, b, c, d, e, f, g) where+ get (_, _, _, d, _, _, _) = d+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g) = (a, b, c, ff d, e, f, g)+ {-# INLINABLE modify #-}+instance Has e (a, b, c, d, e, f, g) where+ get (_, _, _, _, e, _, _) = e+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g) = (a, b, c, d, ff e, f, g)+ {-# INLINABLE modify #-}+instance Has f (a, b, c, d, e, f, g) where+ get (_, _, _, _, _, f, _) = f+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g) = (a, b, c, d, e, ff f, g)+ {-# INLINABLE modify #-}+instance Has g (a, b, c, d, e, f, g) where+ get (_, _, _, _, _, _, g) = g+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g) = (a, b, c, d, e, f, ff g)+ {-# INLINABLE modify #-}++--------------------------------------------------------------------------------++instance Has a (a, b, c, d, e, f, g, h) where+ get (a, _, _, _, _, _, _, _) = a+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g, h) = (ff a, b, c, d, e, f, g, h)+ {-# INLINABLE modify #-}+instance Has b (a, b, c, d, e, f, g, h) where+ get (_, b, _, _, _, _, _, _) = b+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g, h) = (a, ff b, c, d, e, f, g, h)+ {-# INLINABLE modify #-}+instance Has c (a, b, c, d, e, f, g, h) where+ get (_, _, c, _, _, _, _, _) = c+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g, h) = (a, b, ff c, d, e, f, g, h)+ {-# INLINABLE modify #-}+instance Has d (a, b, c, d, e, f, g, h) where+ get (_, _, _, d, _, _, _, _) = d+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g, h) = (a, b, c, ff d, e, f, g, h)+ {-# INLINABLE modify #-}+instance Has e (a, b, c, d, e, f, g, h) where+ get (_, _, _, _, e, _, _, _) = e+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g, h) = (a, b, c, d, ff e, f, g, h)+ {-# INLINABLE modify #-}+instance Has f (a, b, c, d, e, f, g, h) where+ get (_, _, _, _, _, f, _, _) = f+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g, h) = (a, b, c, d, e, ff f, g, h)+ {-# INLINABLE modify #-}+instance Has g (a, b, c, d, e, f, g, h) where+ get (_, _, _, _, _, _, g, _) = g+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g, h) = (a, b, c, d, e, f, ff g, h)+ {-# INLINABLE modify #-}+instance Has h (a, b, c, d, e, f, g, h) where+ get (_, _, _, _, _, _, _, h) = h+ {-# INLINABLE get #-}+ modify ff (a, b, c, d, e, f, g, h) = (a, b, c, d, e, f, g, ff h)+ {-# INLINABLE modify #-}
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, winterland1989++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 winterland1989 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,33 @@+data-has+========++[](http://hackage.haskell.org/package/data-has)+[](https://travis-ci.org/winterland1989/data-has)++A simple extensible product system, a typical usage is to free you from considering how to layer your monad stack, because your can now extend your monad in one layer:++```haskell+ {-# LANGUAGE FlexibleContexts #-}++ -- in some library code+ ...+ logInAnyReaderHasLogger :: (Has Logger r, MonadReader r m) => LogString -> m ()+ logInAnyReaderHasLogger s = asks get >>= logWithLogger s++ queryInAnyReaderHasSQL :: (Has SqlBackEnd r, MonadReader r m) => Query -> m a+ queryInAnyReaderHasSQL q = asks get >>= queryWithSQL q+ ...++ -- now you want to use these effects together+ ...+ logger <- initLogger ...+ sql <- initSqlBackEnd ...++ (`runReader` (logger, sql)) $ do+ ...+ logInAnyReaderHasLogger ...+ ...+ x <- queryInAnyReaderHasSQL ...+ ...+...+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/Main.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}++module Main where++-------------------------------------------------------------------------------++import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class+import Criterion.Main+import Data.Has+import GHC.TypeLits++main :: IO ()+main = defaultMain+ [ bgroup "has vs 2 layer reader"+ [ bench "has" $ whnf (runReader hasReader) (1 :: Int, "hello" :: String)+ , bench "2 layer" $ whnf (\ (i, s) -> runReader (runReaderT multiReader i) s)+ (1 :: Int, "hello" :: String)+ ]+ , bgroup "has vs 8 layer reader"+ [ bench "has" $ whnf (runReader hasReader8)+ ( T 1 :: T 1 Int+ , T 2 :: T 2 Int+ , T 3 :: T 3 Int+ , T 4 :: T 4 Int+ , T 5 :: T 5 Int+ , T 6 :: T 6 Int+ , T 7 :: T 7 Int+ , T 8 :: T 8 Int)+ , bench "8 layer" $ whnf (\ (i1, i2, i3, i4, i5, i6, i7, i8) ->+ runReader+ (runReaderT+ (runReaderT+ (runReaderT+ (runReaderT+ (runReaderT+ (runReaderT+ (runReaderT multiReader8 i1+ ) i2) i3) i4) i5) i6) i7) i8+ ) (1, 2, 3, 4, 5, 6, 7, 8)+ ]+ ]++hasReader :: (Has Int r, Has String r) => Reader r String+hasReader = do+ i :: Int <- asks get+ s :: String <- asks get+ return (s ++ show i)++multiReader :: ReaderT Int (Reader String) String+multiReader = do+ i <- ask+ s <- lift ask+ return (s ++ show i)++newtype T (a :: Nat) b = T { uT :: b }++hasReader8 :: ( Has (T 1 Int) r+ , Has (T 2 Int) r+ , Has (T 3 Int) r+ , Has (T 4 Int) r+ , Has (T 5 Int) r+ , Has (T 6 Int) r+ , Has (T 7 Int) r+ , Has (T 8 Int) r+ ) => Reader r Int+hasReader8 = do+ i1 :: T 1 Int <- asks get+ i2 :: T 2 Int <- asks get+ i3 :: T 3 Int <- asks get+ i4 :: T 4 Int <- asks get+ i5 :: T 5 Int <- asks get+ i6 :: T 6 Int <- asks get+ i7 :: T 7 Int <- asks get+ i8 :: T 8 Int <- asks get+ return (uT i1 + uT i2 + uT i3 + uT i4 + uT i5 + uT i6 + uT i7 + uT i8)++multiReader8 :: ReaderT Int+ (ReaderT Int+ (ReaderT Int+ (ReaderT Int+ (ReaderT Int+ (ReaderT Int+ (ReaderT Int+ (Reader Int))))))) Int+multiReader8 = do+ i1 <- ask+ i2 <- lift ask+ i3 <- lift (lift ask)+ i4 <- lift (lift (lift ask))+ i5 <- lift (lift (lift (lift ask)))+ i6 <- lift (lift (lift (lift (lift ask))))+ i7 <- lift (lift (lift (lift (lift (lift ask)))))+ i8 <- lift (lift (lift (lift (lift (lift (lift ask))))))+ return (i1 + i2 + i3 + i4 + i5 + i6 + i7 + i8)
+ data-has.cabal view
@@ -0,0 +1,38 @@+name: data-has+version: 0.1.0.0+synopsis: Simple extensible product+description: Simple extensible product+license: BSD3+license-file: LICENSE+author: winterland1989+maintainer: winterland1989@gmail.com+-- copyright: +category: Data+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10+homepage: https://github.com/winterland1989/data-has++source-repository head+ type: git+ location: git://github.com/winterland1989/data-has.git++library+ exposed-modules: Data.Has+ -- other-modules: + -- other-extensions: + build-depends: base < 5++ -- hs-source-dirs: + default-language: Haskell2010++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: benchmark+ default-language: Haskell2010+ build-depends: base+ , data-has+ , criterion >= 1.0.2.0+ , transformers+