state-bag (empty) → 0.1.0.0

raw patch · 9 files changed

+520/−0 lines, 9 filesdep +basedep +ghc-primdep +hspecsetup-changed

Dependencies added: base, ghc-prim, hspec, primitive, state-bag, transformers, vector

Files

CHANGELOG +5/−0
LICENSE +30/−0
Setup.hs +2/−0
src/Control/Monad/Trans/StateBag/Class.hs +47/−0
src/Control/Monad/Trans/StateBag/Internal.hs +33/−0
src/Control/Monad/Trans/StateBag/Primitive.hs +131/−0
src/Control/Monad/Trans/StateBag/Pure.hs +130/−0
state-bag.cabal +58/−0
test/Main.hs +84/−0

+ CHANGELOG view

@@ -0,0 +1,5 @@+state-bag - Release History++release-0.1.0.0 - 2016.07.22++  * Initial release.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2016, Robin KAY++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 Robin KAY 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.

+ Setup.hs view

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

+ src/Control/Monad/Trans/StateBag/Class.hs view

@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds, KindSignatures, ScopedTypeVariables,+    MultiParamTypeClasses, FlexibleContexts, FlexibleInstances,+    TypeFamilies, TypeOperators, RankNTypes #-}++-- | Abstraction over the primitive and pure versions of StateBagT.+module Control.Monad.Trans.StateBag.Class (+    StateBagMonad(+        Bag,+        BagBase,+        getItem,+        putItem,+        modifyItemM),+    ElementCount(),+    ElementIndex()+) where++import Control.Monad.Primitive+import Control.Monad.Trans.StateBag.Internal+import qualified Control.Monad.Trans.StateBag.Pure as Pure+import qualified Control.Monad.Trans.StateBag.Primitive as Prim++-- | Type-class which abstract over the primitive and pure versions of+-- StateBagT.+class (Monad m) => StateBagMonad (m :: * -> *) where+    type Bag m :: [*]+    type BagBase m :: * -> *+    -- | Gets the current value of @item@ from the bag.+    getItem :: (ElementIndex item (Bag m)) => m item+    -- | Stores a new value of @item@ in the bag.+    putItem :: (ElementIndex item (Bag m)) => item -> m ()+    -- | Applies a monadic function to an item in the bag and stores the result.+    modifyItemM :: (ElementIndex item (Bag m)) => (item -> m item) -> m ()+    modifyItemM f = getItem >>= f >>= putItem++instance (Monad m) => StateBagMonad (Pure.StateBagT bag m) where+    type Bag (Pure.StateBagT bag m) = bag+    type BagBase (Pure.StateBagT bag m) = m+    getItem = Pure.getItem+    putItem = Pure.putItem+    modifyItemM = Pure.modifyItemM++instance (PrimMonad m) => StateBagMonad (Prim.StateBagT bag m) where+    type Bag (Prim.StateBagT bag m) = bag+    type BagBase (Prim.StateBagT bag m) = m+    getItem = Prim.getItem+    putItem = Prim.putItem+    modifyItemM = Prim.modifyItemM

+ src/Control/Monad/Trans/StateBag/Internal.hs view

@@ -0,0 +1,33 @@+{-# LANGUAGE DataKinds, KindSignatures, ScopedTypeVariables,+    MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, TypeFamilies,+    TypeOperators, RankNTypes, MagicHash, GeneralizedNewtypeDeriving #-}++module Control.Monad.Trans.StateBag.Internal where++import Control.Monad.Trans.Class+import Control.Monad.Trans.State+import Control.Monad.Primitive+import Control.Monad.IO.Class+import Data.Proxy+import GHC.Prim (Any)++-- | Type-class for counting the number of elements in a type-level list.+class ElementCount (a :: [*]) where+    elemCount :: Proxy a -> Int++instance ElementCount '[] where+    elemCount _ = 0++instance (ElementCount xs) => ElementCount (x ': xs) where+    elemCount _ = 1 + elemCount (Proxy :: Proxy xs)++-- | Type-class for finding the index of an element in a type-level list.+class ElementIndex x (xs :: [*]) where+    elemIndex :: Proxy x -> Proxy xs -> Int++instance ElementIndex x (x ': xs) where+    elemIndex _ _ = 0++instance {-# OVERLAPS #-} forall x y xs. (ElementIndex x xs) =>+    ElementIndex x (y ': xs) where+    elemIndex px _ = 1 + elemIndex px (Proxy :: Proxy xs)

+ src/Control/Monad/Trans/StateBag/Primitive.hs view

@@ -0,0 +1,131 @@+{-# LANGUAGE DataKinds, KindSignatures, ScopedTypeVariables,+    MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, TypeFamilies,+    TypeOperators, RankNTypes, MagicHash, GeneralizedNewtypeDeriving #-}++-- | State bag monad transformer which runs on a PrimMonad stack.+module Control.Monad.Trans.StateBag.Primitive (+    StateBaggerT,+    runBagger,+    addItem,+    topItem,+    stackItem,+    StateBagT,+    makeBag,+    getItem,+    putItem,+    modifyItemM,+    ElementCount(),+    ElementIndex(),+) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Control.Monad.Trans.StateBag.Internal+import Control.Monad.IO.Class+import Control.Monad.Primitive+import Data.Proxy+import GHC.Prim (Any, unsafeCoerce#)+import qualified Data.Vector.Mutable as V++newtype BagImpl s (bag :: [*]) = BagImpl (V.MVector s Any)++-- | Monad transformer for building state bags. +newtype StateBaggerT full (bag :: [*]) m a+    = StateBaggerT (ReaderT (BagImpl (PrimState m) full) m a)+    deriving (Functor, Applicative, Monad, MonadIO)++instance MonadTrans (StateBaggerT full bag) where+    lift = StateBaggerT . lift++instance (PrimMonad m) => PrimMonad (StateBaggerT full bag m) where+  type PrimState (StateBaggerT full bag m) = PrimState m+  primitive = lift . primitive++-- | Run an empty state bagger on top of a monad stack.+runBagger :: forall full m a. (PrimMonad m, ElementCount full) =>+    StateBaggerT full '[] m a -> m a+runBagger (StateBaggerT r) = do+    vec <- V.new $ elemCount (Proxy :: Proxy full)+    runReaderT r $ BagImpl vec++-- | Run a state bagger with one additional item.+addItem :: forall item full bag m a. (PrimMonad m, ElementIndex item full) =>+    item -> StateBaggerT full (item ': bag) m a -> StateBaggerT full bag m a+addItem item (StateBaggerT chain) = StateBaggerT $ do+    (BagImpl vec) <- ask+    V.write vec (elemIndex (Proxy :: Proxy item) (Proxy :: Proxy full)) $+        unsafeCoerce# item+    lift $ runReaderT chain $ BagImpl vec++-- | Get the value of the top item in a state bagger.+topItem :: forall item full bag m. (PrimMonad m, ElementIndex item full) =>+    StateBaggerT full (item ': bag) m item+topItem = StateBaggerT $ do+    (BagImpl vec) <- ask+    fmap unsafeCoerce# $ V.read vec $+        elemIndex (Proxy :: Proxy item) (Proxy :: Proxy full)++-- | Run a state bagger with one additional item and capture the final value of+-- that item on return.+stackItem :: forall item full bag m a. (PrimMonad m, ElementIndex item full) =>+    item -> StateBaggerT full (item ': bag) m a ->+    StateBaggerT full bag m (a, item)+stackItem item chain =+    addItem item $ liftM2 (,) chain topItem++-- | State bag monad transformer where the state items are represented by the+-- type-level list @bag@.+newtype StateBagT bag m a = StateBagT (ReaderT (BagImpl (PrimState m) bag) m a)+    deriving (Functor, Applicative, Monad, MonadIO)++instance MonadTrans (StateBagT bag) where+    lift = StateBagT . lift++instance (PrimMonad m) => PrimMonad (StateBagT bag m) where+  type PrimState (StateBagT bag m) = PrimState m+  primitive = lift . primitive++-- | Runs a state bag with the items prepared in a state bagger.+makeBag ::+    forall bag m a. (PrimMonad m, ElementCount bag) =>+    StateBagT bag m a -> StateBaggerT bag bag m a+makeBag (StateBagT r) = StateBaggerT r++itemImpl :: forall m item bag.+    (PrimMonad m, ElementIndex item bag) =>+    StateBagT bag m (StateBagT bag m item, item -> StateBagT bag m ())+{-# INLINE itemImpl #-}+itemImpl = do+    let i = elemIndex (Proxy :: Proxy item) (Proxy :: Proxy bag)+    (BagImpl vec) <- StateBagT ask+    let geti = fmap unsafeCoerce# $ V.read vec i+    let puti item = V.write vec i $ unsafeCoerce# item+    return (geti, puti)++-- | Gets the current value of @item@ from the bag.+getItem :: forall m item bag.+    (PrimMonad m, ElementIndex item bag) =>+    StateBagT bag m item+{-# INLINE getItem #-}+getItem = itemImpl >>= fst++-- | Stores a new value of @item@ in the bag.+putItem :: forall m item bag.+    (PrimMonad m, ElementIndex item bag) =>+    item -> StateBagT bag m ()+{-# INLINE putItem #-}+putItem item = itemImpl >>= flip snd item++-- | Applies a monadic function to an item in the bag and stores the result.+modifyItemM :: forall m item bag.+    (PrimMonad m, ElementIndex item bag) =>+    (item -> StateBagT bag m item) -> StateBagT bag m ()+{-# INLINE modifyItemM #-}+modifyItemM f = do+    (get, put) <- itemImpl+    item <- get+    item' <- f item+    put item'

+ src/Control/Monad/Trans/StateBag/Pure.hs view

@@ -0,0 +1,130 @@+{-# LANGUAGE DataKinds, KindSignatures, ScopedTypeVariables,+    MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, TypeFamilies,+    TypeOperators, RankNTypes, MagicHash, GeneralizedNewtypeDeriving #-}++-- | State bag monad transformer which runs on any monad stack.+module Control.Monad.Trans.StateBag.Pure (+    StateBaggerT,+    runBagger,+    addItem,+    topItem,+    stackItem,+    StateBagT,+    makeBag,+    getItem,+    putItem,+    modifyItemM,+    ElementCount(),+    ElementIndex(),+) where++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.State+import Control.Monad.Trans.StateBag.Internal+import Control.Monad.IO.Class+import Control.Monad.Primitive+import Data.Proxy+import GHC.Prim (Any, unsafeCoerce#)+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV++newtype BaggerImpl (bag :: [*]) = BaggerImpl [Any]++-- | Monad transformer for building state bags. +newtype StateBaggerT bag m a = StateBaggerT (StateT (BaggerImpl bag) m a)+    deriving (Functor, Applicative, Monad, MonadIO)++instance MonadTrans (StateBaggerT bag) where+    lift = StateBaggerT . lift++instance (PrimMonad m) => PrimMonad (StateBaggerT bag m) where+  type PrimState (StateBaggerT bag m) = PrimState m+  primitive = lift . primitive++-- | Run an empty state bagger on top of a monad stack.+runBagger :: (Monad m) => StateBaggerT '[] m a -> m a+runBagger (StateBaggerT s) =+    fmap fst $ runStateT s $ BaggerImpl []++-- | Run a state bagger with one additional item.+addItem :: forall item bag m a. (Monad m) =>+    item -> StateBaggerT (item ': bag) m a -> StateBaggerT bag m a+addItem item (StateBaggerT chain) = StateBaggerT $ do+    (BaggerImpl list) <- get+    (ret, BaggerImpl (_:list')) <- lift $ runStateT chain $+        BaggerImpl (unsafeCoerce# item : list)+    put $ BaggerImpl list'+    return ret++-- | Get the value of the top item in a state bagger.+topItem :: forall item bag m. (Monad m) =>+    StateBaggerT (item ': bag) m item+topItem = StateBaggerT $ do+    (BaggerImpl (item:_)) <- get+    return $ unsafeCoerce# item++-- | Run a state bagger with one additional item and capture the final value of+-- that item on return.+stackItem :: forall item bag m a. (Monad m) =>+    item -> StateBaggerT (item ': bag) m a -> StateBaggerT bag m (a, item)+stackItem item chain =+    addItem item $ liftM2 (,) chain topItem++newtype BagImpl (bag :: [*]) = BagImpl (V.Vector Any)++-- | State bag monad transformer where the state items are represented by the+-- type-level list @bag@.+newtype StateBagT bag m a = StateBagT (StateT (BagImpl bag) m a)+    deriving (Functor, Applicative, Monad, MonadIO)++instance MonadTrans (StateBagT bag) where+    lift = StateBagT . lift++instance (PrimMonad m) => PrimMonad (StateBagT bag m) where+  type PrimState (StateBagT bag m) = PrimState m+  primitive = lift . primitive++-- | Runs a state bag with the items prepared in a state bagger.+makeBag ::+    forall bag m a. (Monad m, ElementCount bag) =>+    StateBagT bag m a -> StateBaggerT bag m a+makeBag (StateBagT s) = StateBaggerT $ do+    (BaggerImpl list) <- get+    let vlen = elemCount (Proxy :: Proxy bag)+    (ret, BagImpl vec') <- lift $ runStateT s $ BagImpl $ V.fromListN vlen list+    put $ BaggerImpl $ V.toList vec'+    return ret++itemImpl :: forall m item bag.+    (Monad m, ElementIndex item bag) =>+    StateBagT bag m (item, item -> StateBagT bag m ())+{-# INLINE itemImpl #-}+itemImpl = do+    let i = elemIndex (Proxy :: Proxy item) (Proxy :: Proxy bag)+    (BagImpl vec) <- StateBagT get+    let item = unsafeCoerce# $ (V.!) vec i+    let puti item' = StateBagT $ put $ BagImpl $ V.modify (\mvec ->+                        MV.write mvec i $ unsafeCoerce# item') vec+    return (item, puti)++-- | Gets the current value of @item@ from the bag.+getItem :: forall m item bag.+    (Monad m, ElementIndex item bag) =>+    StateBagT (bag :: [*]) m item+getItem = fmap fst itemImpl++-- | Stores a new value of @item@ in the bag.+putItem :: forall m item bag.+    (Monad m, ElementIndex item bag) =>+    item -> StateBagT (bag :: [*]) m ()+putItem item = itemImpl >>= flip snd item++-- | Applies a monadic function to an item in the bag and stores the result.+modifyItemM :: forall m item bag.+    (Monad m, ElementIndex item bag) =>+    (item -> StateBagT bag m item) -> StateBagT bag m ()+modifyItemM f = do+    (item, puti) <- itemImpl+    item' <- f item+    puti item'

+ state-bag.cabal view

@@ -0,0 +1,58 @@+name:                state-bag+version:             0.1.0.0+cabal-version:       >=1.10+build-type:          Simple+license:             BSD3+license-file:        LICENSE+extra-source-files:  CHANGELOG+copyright:           (c) 2016 Robin KAY+author:              Robin KAY+maintainer:          komadori@gekkou.co.uk+homepage:            http://www.gekkou.co.uk/software/+category:            Control+synopsis:            Monad transformers for holding bags of state.+description:+    A state monad transformer which can hold multiple different state values+    represented in a type-level list.++library+  exposed-modules:+    Control.Monad.Trans.StateBag.Class,+    Control.Monad.Trans.StateBag.Pure,+    Control.Monad.Trans.StateBag.Primitive+  other-modules:+    Control.Monad.Trans.StateBag.Internal+  other-extensions:+    DataKinds,+    KindSignatures,+    ScopedTypeVariables,+    MultiParamTypeClasses,+    FlexibleContexts,+    FlexibleInstances,+    TypeFamilies,+    TypeOperators,+    RankNTypes,+    MagicHash,+    GeneralizedNewtypeDeriving+  build-depends:+    base         == 4.*,+    ghc-prim     >= 0.4 && < 0.6,+    primitive    >= 0.6 && < 0.7,+    transformers >= 0.4 && < 0.6,+    vector       >= 0.11 && < 0.12+  hs-source-dirs: src+  default-language: Haskell2010++test-suite Test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    base         == 4.*,+    state-bag    == 0.1.*,+    transformers >= 0.4 && < 0.6,+    hspec        >= 2.2 && < 2.3++source-repository head+    type:     darcs+    location: http://hub.darcs.net/komadori/state-bag/

+ test/Main.hs view

@@ -0,0 +1,84 @@+{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies, RankNTypes #-}++module Main where++import Test.Hspec+import Data.Functor.Identity+import Control.Monad.Trans.StateBag.Class+import Control.Monad.ST+import qualified Control.Monad.Trans.StateBag.Pure as Pure+import qualified Control.Monad.Trans.StateBag.Primitive as Prim++main :: IO ()+main = hspec $ do+  let abc0 = (1,2,3)+      abc1 = (4,5,6)+      abcF = ((+10), (+20), (+30))+      abc2 = (11,22,33)+      check r (a, b) = r == a && r == b+  describe "Pure.StateBag" $ do+      it "can get" $+          check abc0 $ runPureBag abc0 getABC+      it "can put" $+          check abc1 $ runPureBag abc0 $ putABC abc1 >> getABC+      it "can modify" $+          check abc2 $ runPureBag abc0 $ modifyABC abcF >> getABC+  describe "Prim.StateBag" $ do+      it "can get" $+          check abc0 $ runPrimBag abc0 getABC+      it "can put" $+          check abc1 $ runPrimBag abc0 $ putABC abc1 >> getABC+      it "can modify" $+          check abc2 $ runPrimBag abc0 $ modifyABC abcF >> getABC++newtype TypeA = TypeA Int+newtype TypeB = TypeB Int+newtype TypeC = TypeC Int++runPrimBag ::+    (Int, Int, Int) ->+    (forall s. Prim.StateBagT '[TypeA, TypeB, TypeC] (ST s) a) ->+    ((Int, Int, Int), a)+runPrimBag (a, b, c) m =+  runST $+  fmap (\(((ret, TypeA a), TypeB b), TypeC c) -> ((a, b, c), ret)) $+  Prim.runBagger $+  Prim.stackItem (TypeC c) $+  Prim.stackItem (TypeB b) $+  Prim.stackItem (TypeA a) $+  Prim.makeBag m++runPureBag ::+    (Int, Int, Int) ->+    Pure.StateBagT '[TypeA, TypeB, TypeC] Identity a ->+    ((Int, Int, Int), a)+runPureBag (a, b, c) m =+  runIdentity $+  fmap (\(((ret, TypeA a), TypeB b), TypeC c) -> ((a, b, c), ret)) $+  Pure.runBagger $+  Pure.stackItem (TypeC c) $+  Pure.stackItem (TypeB b) $+  Pure.stackItem (TypeA a) $+  Pure.makeBag m++getABC :: (StateBagMonad m, Bag m ~ '[TypeA, TypeB, TypeC]) =>+    m (Int, Int, Int)+getABC = do+    (TypeA a) <- getItem+    (TypeB b) <- getItem+    (TypeC c) <- getItem+    return (a, b, c)++putABC :: (StateBagMonad m, Bag m ~ '[TypeA, TypeB, TypeC]) =>+    (Int, Int, Int) -> m ()+putABC (a, b, c) = do+    putItem $ TypeA a+    putItem $ TypeB b+    putItem $ TypeC c++modifyABC :: (StateBagMonad m, Bag m ~ '[TypeA, TypeB, TypeC]) =>+    (Int -> Int, Int -> Int, Int -> Int) -> m ()+modifyABC (a, b, c) = do+    modifyItemM (\(TypeA x) -> return $ TypeA $ a x)+    modifyItemM (\(TypeB x) -> return $ TypeB $ b x)+    modifyItemM (\(TypeC x) -> return $ TypeC $ c x)