multistate 0.7.1.2 → 0.8.0.4
raw patch · 25 files changed
Files
- changelog.md +31/−1
- multistate.cabal +16/−19
- src/Control/Monad/MultiReader.hs +0/−34
- src/Control/Monad/MultiState.hs +0/−48
- src/Control/Monad/MultiWriter.hs +0/−44
- src/Control/Monad/Trans/MultiGST.hs +45/−0
- src/Control/Monad/Trans/MultiGST/Common.hs +186/−0
- src/Control/Monad/Trans/MultiGST/Lazy.hs +260/−0
- src/Control/Monad/Trans/MultiGST/Strict.hs +241/−0
- src/Control/Monad/Trans/MultiGet/Class.hs +29/−0
- src/Control/Monad/Trans/MultiRWS.hs +1/−0
- src/Control/Monad/Trans/MultiRWS/Lazy.hs +34/−26
- src/Control/Monad/Trans/MultiRWS/Strict.hs +34/−26
- src/Control/Monad/Trans/MultiReader/Class.hs +0/−1
- src/Control/Monad/Trans/MultiReader/Lazy.hs +22/−13
- src/Control/Monad/Trans/MultiReader/Strict.hs +22/−13
- src/Control/Monad/Trans/MultiState.hs +1/−0
- src/Control/Monad/Trans/MultiState/Class.hs +8/−9
- src/Control/Monad/Trans/MultiState/Lazy.hs +25/−17
- src/Control/Monad/Trans/MultiState/Strict.hs +27/−19
- src/Control/Monad/Trans/MultiWriter/Lazy.hs +8/−8
- src/Control/Monad/Trans/MultiWriter/Strict.hs +8/−8
- src/Data/HList/ContainsType.hs +4/−0
- src/Data/HList/HList.hs +18/−11
- test/Test.hs +3/−1
changelog.md view
@@ -1,6 +1,36 @@ # Changelog for [`multistate` package](https://hackage.haskell.org/package/multistate) -** 0.7.1.2 *August 2017*+## 0.8.0.4 *January 2022*++ * Adapt for ghc-9.0 and ghc-9.2+ * Clean up code a bit, fix compiler warnings (thanks sergv)++## 0.8.0.3 *May 2020*++ * Adapt for ghc-8.10+ * Add nix-expressions for testing against different ghc versions+ * Drop support for ghc < 8.4++## 0.8.0.2 *June 2019*++ * Adapt for ghc-8.8 (optimistically; QuickCheck does not build so+ tests are untested)++## 0.8.0.1 *October 2018*++ * Adapt for ghc-8.6 (really, this time)+ * Make package -Wcompat-ible++## 0.8.0.0 *April 2018*++ * Adapt for ghc-8.4+ * Drop support for ghc<8.0+ * Add class `MonadMultiGet` that roughly translates to "any read access"+ (instances for Reader and State)+ * Add data-type `MultiGST` that has a single taggified HList instead of the+ three r, w, s lists with `MultiRWS`++## 0.7.1.2 *August 2017* * Adapt for ghc-8.2
multistate.cabal view
@@ -1,17 +1,16 @@ Name: multistate-Version: 0.7.1.2+Version: 0.8.0.4 Cabal-Version: >= 1.10 Build-Type: Simple license: BSD3 license-file: LICENSE-Copyright: Copyright (C) 2013-2017 Jan Bracker, 2013-2016 Lennart Spitzner+Copyright: Copyright (C) 2013 Jan Bracker, 2013-2020 Lennart Spitzner Maintainer: Lennart Spitzner <hexagoxel@hexagoxel.de> Author: Jan Bracker, Lennart Spitzner Homepage: https://github.com/lspitzner/multistate Bug-reports: https://github.com/lspitzner/multistate/issues Stability: Experimental category: Control-tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 Synopsis: like mtl's ReaderT / WriterT / StateT, but more than one contained value/type.@@ -39,6 +38,7 @@ flag build-example description: Build the MultiState-example example program default: False+ manual: True library { default-language:@@ -46,9 +46,7 @@ exposed-modules: Data.HList.HList Data.HList.ContainsType- Control.Monad.MultiState- Control.Monad.MultiReader- Control.Monad.MultiWriter+ Control.Monad.Trans.MultiGet.Class Control.Monad.Trans.MultiReader Control.Monad.Trans.MultiReader.Class Control.Monad.Trans.MultiReader.Lazy@@ -64,9 +62,13 @@ Control.Monad.Trans.MultiRWS Control.Monad.Trans.MultiRWS.Lazy Control.Monad.Trans.MultiRWS.Strict+ Control.Monad.Trans.MultiGST+ Control.Monad.Trans.MultiGST.Lazy+ Control.Monad.Trans.MultiGST.Strict other-modules:+ Control.Monad.Trans.MultiGST.Common build-depends:- base >= 4.6 && <4.11,+ base >= 4.11 && <4.17, mtl >= 2.1 && <2.3, transformers >= 0.3 && <0.6, tagged >= 0.7 && <0.9,@@ -77,22 +79,17 @@ TypeFamilies MultiParamTypeClasses FunctionalDependencies+ FlexibleContexts FlexibleInstances UndecidableInstances TypeOperators DataKinds- if impl(ghc < 7.10) {- default-extensions:- OverlappingInstances- }+ LambdaCase ghc-options: { -Wall+ -Wcompat -fno-warn-unused-imports- }- if impl(ghc > 8.0) {- ghc-options: {- -fno-warn-redundant-constraints- }+ -fno-warn-redundant-constraints } hs-source-dirs: src }@@ -105,9 +102,9 @@ -- no version constraints necessary, because they are already -- given by library multistate,- base <4.11,+ base <999, transformers <0.6,- hspec >=2 && <2.5+ hspec >=2 && <2.9 ghc-options: -Wall main-is: Test.hs hs-source-dirs: test@@ -122,7 +119,7 @@ -- no version constraints necessary, because they are already -- given by library multistate,- base <4.11,+ base <999, mtl <2.3, transformers <0.6 } else {
− src/Control/Monad/MultiReader.hs
@@ -1,34 +0,0 @@--- | The multi-valued version of mtl's Reader / ReaderT--- / MonadReader-module Control.Monad.MultiReader {-# DEPRECATED "Use Control.Monad.Trans.MultiReader instead" #-}- (- -- * MultiReaderT- MultiReaderT(..)- , MultiReaderTNull- , MultiReader- -- * MonadMultiReader class- , MonadMultiReader(..)- -- * run-functions- , runMultiReaderT- , runMultiReaderT_- , runMultiReaderTNil- , runMultiReaderTNil_- -- * with-functions (single Reader)- , withMultiReader- , withMultiReader_- -- * with-functions (multiple Readers)- , withMultiReaders- , withMultiReaders_- -- * inflate-function (run ReaderT in MultiReaderT)- , inflateReader- -- * other functions- , mapMultiReaderT- , mGetRaw- , mPutRaw-) where------ just re-export-import Control.Monad.Trans.MultiReader.Class-import Control.Monad.Trans.MultiReader.Lazy
− src/Control/Monad/MultiState.hs
@@ -1,48 +0,0 @@--- | The multi-valued version of mtl's State / StateT--- / MonadState-module Control.Monad.MultiState {-# DEPRECATED "Use Control.Monad.Trans.MultiState instead" #-}- (- -- * MultiStateT- MultiStateT(..)- , MultiStateTNull- , MultiState- -- * MonadMultiState class- , MonadMultiState(..)- -- * run-functions- , runMultiStateT- , runMultiStateTAS- , runMultiStateTSA- , runMultiStateTA- , runMultiStateTS- , runMultiStateT_- , runMultiStateTNil- , runMultiStateTNil_- -- * with-functions (single state)- , withMultiState- , withMultiStateAS- , withMultiStateSA- , withMultiStateA- , withMultiStateS- , withMultiState_- -- * with-functions (multiple states)- , withMultiStates- , withMultiStatesAS- , withMultiStatesSA- , withMultiStatesA- , withMultiStatesS- , withMultiStates_- -- * inflate-functions (run single state in multiple states)- , inflateState- , inflateReader- , inflateWriter- -- * other functions- , mapMultiStateT- , mGetRaw- , mPutRaw-) where------ just re-export-import Control.Monad.Trans.MultiState.Class-import Control.Monad.Trans.MultiState.Lazy
− src/Control/Monad/MultiWriter.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}---- | The multi-valued version of mtl's Writer / WriterT--- / MonadWriter-module Control.Monad.MultiWriter {-# DEPRECATED "Use Control.Monad.Trans.MultiWriter instead" #-}- ( -- * MultiWriterT- MultiWriterT(..)- , MultiWriterTNull- , MultiWriter- -- * MonadMultiWriter class- , MonadMultiWriter(..)- -- * run-functions- , runMultiWriterT- , runMultiWriterTAW- , runMultiWriterTWA- -- , runMultiWriterTA- , runMultiWriterTW- -- , runMultiWriterT_- , runMultiWriterTNil- , runMultiWriterTNil_- -- * with-functions (single Writer)- , withMultiWriter- , withMultiWriterAW- , withMultiWriterWA- , withMultiWriterW- -- * with-functions (multiple Writers)- , withMultiWriters- , withMultiWritersAW- , withMultiWritersWA- , withMultiWritersW- -- * inflate-function (run WriterT in MultiWriterT)- , inflateWriter- -- * other functions- , mapMultiWriterT- , mGetRaw- , mPutRaw- )-where------ just re-exports-import Control.Monad.Trans.MultiWriter.Class-import Control.Monad.Trans.MultiWriter.Lazy
+ src/Control/Monad/Trans/MultiGST.hs view
@@ -0,0 +1,45 @@+-- | The multi-valued version of mtl's RWS / RWST+module Control.Monad.Trans.MultiGST+ (+ -- * MultiRWST+ MultiGSTT(..)+ , MultiGSTTNull+ , MultiGST+ -- * MonadMulti classes+ , ContainsReader+ , ContainsState+ , ContainsWriter+ , MonadMultiReader(..)+ , MonadMultiWriter(..)+ , MonadMultiGet(..)+ , CanReadWrite(..)+ -- * run-functions (extracting from RWST)+ , runMultiGSTTNil+ , runMultiGSTTNil_+ -- * with-functions (extending an RWST)+ , withReader+ , withReader_+ , withReaders+ , withWriter+ , withWriterAW+ , withWriterWA+ , withWriterW+ , withState+ , withStateAS+ , withStateSA+ , withStateA+ , withStateS+ , withState_+ -- * without-functions (reducing an RWST; inverse of with)+ , without+ -- * other functions+ , mapMultiGSTT+ , mGetRawR+ , mSetRaw+ , mGetRaw+) where++++-- just re-export+import Control.Monad.Trans.MultiGST.Lazy
+ src/Control/Monad/Trans/MultiGST/Common.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Common definitions for MultiGST.Strict and MultiGST.Lazy+module Control.Monad.Trans.MultiGST.Common+ ( HListM(..)+ , CanReadWrite(..)+ , CanReadWriteFlag(..)+ , HListMContainsImplication+ , HListMContains(..)+ , ContainsReader+ , ContainsState+ , ContainsWriter+ , CanWriteConstraint+ , AppendM+ , HListMReaders+ , AppendMReaders+ , HListMGettableClass(..)+ )+where++++import Data.Kind (Type)+import Data.Semigroup+import qualified Data.HList.HList as HList++import Control.Monad.Trans.MultiReader.Class+import Control.Monad.Trans.MultiWriter.Class+import Control.Monad.Trans.MultiState.Class++import GHC.Exts (Constraint)++++data CanReadWrite a+ = Gettable a+ | Settable a+ | Tellable a++data CanReadWriteFlag+ = GettableFlag+ | SettableFlag+ | TellableFlag++type family HListMContainsImplication (can :: CanReadWriteFlag) t cts :: Constraint where+ HListMContainsImplication 'GettableFlag t cts = ()+ HListMContainsImplication 'TellableFlag t cts = ()+ HListMContainsImplication 'SettableFlag t cts = HListMContains 'GettableFlag t cts++class HListMContainsImplication can t cts => HListMContains (can :: CanReadWriteFlag) t cts where+ readHListMElem :: HListM cts -> t+ writeHListMElem :: CanWriteConstraint can => t -> HListM cts -> HListM cts++type ContainsReader = HListMContains 'GettableFlag+type ContainsState = HListMContains 'SettableFlag+type ContainsWriter = HListMContains 'TellableFlag++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HListMContains 'GettableFlag x ('Gettable x ': tr) where+ readHListMElem (x :+-: _) = x+ writeHListMElem = error "writeHListMElem CanRead"+ -- ghc is too stupid to acknowledge that the constraint cannot be fulfilled..++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HListMContains 'GettableFlag x ('Settable x ': tr) where+ readHListMElem (x :++: _) = x+ writeHListMElem = error "writeHListMElem CanRead"+ -- ghc is too stupid to acknowledge that the constraint cannot be fulfilled..++instance HListMContains 'GettableFlag x ts => HListMContains 'GettableFlag x (t ': ts) where+ readHListMElem (_ :+-: xr) = readHListMElem @'GettableFlag xr+ readHListMElem (_ :-+: xr) = readHListMElem @'GettableFlag xr+ readHListMElem (_ :++: xr) = readHListMElem @'GettableFlag xr+ writeHListMElem = error "writeHListMElem CanRead"++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HListMContains 'TellableFlag x ('Tellable x ': tr) where+ readHListMElem (x :-+: _) = x+ writeHListMElem x ts = case ts of (_ :-+: tr) -> x :-+: tr++instance HListMContains 'TellableFlag x ts => HListMContains 'TellableFlag x (t ': ts) where+ readHListMElem (_ :+-: xr) = readHListMElem @'TellableFlag xr+ readHListMElem (_ :-+: xr) = readHListMElem @'TellableFlag xr+ readHListMElem (_ :++: xr) = readHListMElem @'TellableFlag xr+ writeHListMElem x (t :+-: tr) = t :+-: writeHListMElem @'TellableFlag x tr+ writeHListMElem x (t :-+: tr) = t :-+: writeHListMElem @'TellableFlag x tr+ writeHListMElem x (t :++: tr) = t :++: writeHListMElem @'TellableFlag x tr++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ HListMContains 'GettableFlag x ('Settable x ': tr)+ => HListMContains 'SettableFlag x ('Settable x ': tr) where+ readHListMElem (x :++: _) = x+ writeHListMElem x ts = case ts of (_ :++: tr) -> x :++: tr++instance HListMContains 'SettableFlag x ts => HListMContains 'SettableFlag x (t ': ts) where+ readHListMElem (_ :+-: xr) = readHListMElem @'SettableFlag xr+ readHListMElem (_ :-+: xr) = readHListMElem @'SettableFlag xr+ readHListMElem (_ :++: xr) = readHListMElem @'SettableFlag xr+ writeHListMElem x (t :+-: tr) = t :+-: writeHListMElem @'SettableFlag x tr+ writeHListMElem x (t :-+: tr) = t :-+: writeHListMElem @'SettableFlag x tr+ writeHListMElem x (t :++: tr) = t :++: writeHListMElem @'SettableFlag x tr+++type family CanWriteConstraint (f :: CanReadWriteFlag) :: Constraint where+ CanWriteConstraint 'TellableFlag = ()+ CanWriteConstraint 'SettableFlag = ()++data HListM :: [CanReadWrite Type] -> Type where+ HNilM :: HListM '[]+ (:+-:) :: x -> HListM xr -> HListM ('Gettable x ': xr)+ (:++:) :: x -> HListM xr -> HListM ('Settable x ': xr)+ (:-+:) :: x -> HListM xr -> HListM ('Tellable x ': xr)++instance Semigroup (HListM '[]) where+ _ <> _ = HNilM++instance Monoid (HListM '[]) where+ mempty = HNilM+ mappend = (<>)++instance Eq (HListM '[]) where+ HNilM == HNilM = True+ HNilM /= HNilM = False++instance (Eq x, Eq (HListM xs))+ => Eq (HListM ('Gettable x ': xs))+ where+ x1 :+-: xr1 == x2 :+-: xr2 = x1==x2 && xr1==xr2+ x1 :+-: xr1 /= x2 :+-: xr2 = x1/=x2 || xr1/=xr2+instance (Eq x, Eq (HListM xs))+ => Eq (HListM ('Tellable x ': xs))+ where+ x1 :-+: xr1 == x2 :-+: xr2 = x1==x2 && xr1==xr2+ x1 :-+: xr1 /= x2 :-+: xr2 = x1/=x2 || xr1/=xr2+instance (Eq x, Eq (HListM xs))+ => Eq (HListM ('Settable x ': xs))+ where+ x1 :++: xr1 == x2 :++: xr2 = x1==x2 && xr1==xr2+ x1 :++: xr1 /= x2 :++: xr2 = x1/=x2 || xr1/=xr2++type family AppendM (l1 :: [CanReadWrite Type]) (l2 :: [CanReadWrite Type]) :: [CanReadWrite Type] where+ AppendM '[] l2 = l2+ AppendM (car1 ': cdr2) l2 = car1 ': AppendM cdr2 l2++type family HListMReaders (l :: [Type]) :: [CanReadWrite Type] where+ HListMReaders '[] = '[]+ HListMReaders (t ': tr) = 'Gettable t ': HListMReaders tr++type family AppendMReaders (l1 :: [Type]) (l2 :: [CanReadWrite Type]) :: [CanReadWrite Type] where+ AppendMReaders '[] l2 = l2+ AppendMReaders (t ': tr) l2 = 'Gettable t ': AppendMReaders tr l2++class HListMGettableClass ts where+ type HListMGettableOnly ts :: [Type]+ hListMGettableOnly :: HListM ts -> HList.HList (HListMGettableOnly ts)++instance HListMGettableClass '[] where+ type HListMGettableOnly '[] = '[]+ hListMGettableOnly HNilM = HList.HNil++instance HListMGettableClass tr => HListMGettableClass ('Gettable t ': tr) where+ type HListMGettableOnly ('Gettable t ': tr) = (t ': HListMGettableOnly tr)+ hListMGettableOnly (t :+-: tr) = t HList.:+: hListMGettableOnly tr+instance HListMGettableClass tr => HListMGettableClass ('Settable t ': tr) where+ type HListMGettableOnly ('Settable t ': tr) = HListMGettableOnly tr+ hListMGettableOnly (_ :++: tr) = hListMGettableOnly tr+instance HListMGettableClass tr => HListMGettableClass ('Tellable t ': tr) where+ type HListMGettableOnly ('Tellable t ': tr) = HListMGettableOnly tr+ hListMGettableOnly (_ :-+: tr) = hListMGettableOnly tr
+ src/Control/Monad/Trans/MultiGST/Lazy.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Alternative multi-valued version of mtl's RWS / RWST. In contrast to+-- @'MultiRWS'(T)@ this version only takes a single list of types as+-- parameter, but with additional encoding of the allowed access for each+-- element. This supports the @'MonadMultiGet'@ notion more succinctly, i.e.+-- to pass a "state" element to a function that only requires/expects read/get+-- access. This is not possible with 'MultiRWS'.+module Control.Monad.Trans.MultiGST.Lazy+ ( MultiGSTT(..)+ , MultiGSTTNull+ , MultiGST+ -- * MonadMulti classes+ , ContainsReader+ , ContainsState+ , ContainsWriter+ , MonadMultiReader(..)+ , MonadMultiWriter(..)+ , MonadMultiGet(..)+ , MonadMultiState(..)+ , CanReadWrite(..)+ -- * run-functions+ , runMultiGSTTNil+ , runMultiGSTTNil_+ -- * with-functions+ , withReader+ , withReader_+ , withReaders+ , withWriter+ , withWriterAW+ , withWriterWA+ , withWriterW+ , withState+ , withStateAS+ , withStateSA+ , withStateA+ , withStateS+ , withState_+ -- * without-functions+ , without+ -- * other functions+ , mGetRaw+ , mSetRaw+ , mGetRawR+ , mapMultiGSTT+ )+where++++import Control.Monad.State.Lazy ( StateT(..)+ , MonadState(..)+ , execStateT+ , evalStateT+ , mapStateT )++import Data.Functor.Identity ( Identity )++import Control.Monad.Trans.Class ( MonadTrans+ , lift+ )+import Control.Monad ( MonadPlus(..)+ , liftM+ , ap+ , void+ )+import Control.Applicative ( Applicative(..)+ , Alternative(..)+ )+import Control.Monad.Fix ( MonadFix(..) )+import Control.Monad.IO.Class ( MonadIO(..) )++import Data.Monoid ( Monoid+ , (<>)+ )+++import GHC.Exts (Constraint)++import Control.Monad.Trans.MultiReader.Class+import Control.Monad.Trans.MultiWriter.Class+import Control.Monad.Trans.MultiState.Class++import qualified Data.HList.HList as HList++import Control.Monad.Trans.MultiGST.Common++++newtype MultiGSTT ts m a = MultiGSTT {+ runMultiGSTTRaw :: StateT (HListM ts) m a+}+ deriving(Functor, Applicative, Monad, MonadTrans, MonadIO, Alternative, MonadPlus)++type MultiGSTTNull = MultiGSTT '[]++type MultiGST r = MultiGSTT r Identity+++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ (Monad m, HListMContains 'GettableFlag a cts)+ => MonadMultiGet a (MultiGSTT cts m) where+ mGet = MultiGSTT $ liftM (\ts -> readHListMElem @'GettableFlag ts) get++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ (Monad m, HListMContains 'SettableFlag a cts)+ => MonadMultiState a (MultiGSTT cts m) where+ mSet x = MultiGSTT $ do+ ts <- get+ put $ writeHListMElem @'SettableFlag x ts++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( Monad m+ , Monoid a+ , HListMContains 'TellableFlag a cts+ ) => MonadMultiWriter a (MultiGSTT cts m) where+ mTell x = MultiGSTT $ do+ ts <- get+ let x' = readHListMElem @'TellableFlag ts+ put $ writeHListMElem @'TellableFlag (x' <> x) ts++runMultiGSTTNil :: Monad m => MultiGSTT '[] m a -> m a+runMultiGSTTNil_ :: Monad m => MultiGSTT '[] m a -> m ()++runMultiGSTTNil k = evalStateT (runMultiGSTTRaw k) (HNilM)+runMultiGSTTNil_ k = liftM (const ()) (evalStateT (runMultiGSTTRaw k) (HNilM))++withReader :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m a+withReader x k = MultiGSTT $ do+ tr <- get+ ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr)+ put $ case ts' of _ :+-: tr' -> tr'+ return a++withReader_ :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m ()+withReader_ x k = MultiGSTT $ do+ tr <- get+ ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr)+ put $ case ts' of _ :+-: tr' -> tr'++withReaders :: Monad m => HList.HList rs -> MultiGSTT (AppendM (HListMReaders rs) ts) m a -> MultiGSTT ts m a+withReaders HList.HNil = id+withReaders (t HList.:+: ts) = withReaders ts . withReader t++withWriter :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t)+withWriterAW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t)+withWriterWA :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (t, a)+withWriterW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m t+withWriter = withWriterAW+withWriterAW k = MultiGSTT $ do+ tr <- get+ ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr)+ case ts' of+ t :-+: tr' -> do+ put tr'+ return (a, t)+withWriterWA k = MultiGSTT $ do+ tr <- get+ ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr)+ case ts' of+ t :-+: tr' -> do+ put tr'+ return (t, a)+withWriterW k = MultiGSTT $ do+ tr <- get+ ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr)+ case ts' of+ t :-+: tr' -> do+ put tr'+ return t++withState :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t)+withStateAS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t)+withStateSA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (t, a)+withStateA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m a+withStateS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m t+withState_ :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m ()+withState = withStateAS+withStateAS t k = MultiGSTT $ do+ tr <- get+ ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr)+ case ts' of+ t' :++: tr' -> do+ put tr'+ return (a, t')+withStateSA t k = MultiGSTT $ do+ tr <- get+ ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr)+ case ts' of+ t' :++: tr' -> do+ put tr'+ return (t', a)+withStateA t k = MultiGSTT $ do+ tr <- get+ ~(a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr)+ case ts' of+ _ :++: tr' -> do+ put tr'+ return a+withStateS t k = MultiGSTT $ do+ tr <- get+ ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr)+ case ts' of+ t' :++: tr' -> do+ put tr'+ return t'+withState_ t k = MultiGSTT $ do+ tr <- get+ ~(_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr)+ case ts' of+ _ :++: tr' -> do+ put tr'++without :: Monad m => MultiGSTT tr m a -> MultiGSTT (ct ': tr) m a+without k = MultiGSTT $ do+ ts <- get+ case ts of+ (t :+-: tr) -> do+ ~(a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr+ put (t :+-: tr')+ return a+ (t :-+: tr) -> do+ ~(a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr+ put (t :-+: tr')+ return a+ (t :++: tr) -> do+ ~(a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr+ put (t :++: tr')+ return a++mGetRaw :: Monad m => MultiGSTT ts m (HListM ts)+mGetRaw = MultiGSTT get++mGetRawR :: (Monad m, HListMGettableClass ts) => MultiGSTT ts m (HList.HList (HListMGettableOnly ts))+mGetRawR = MultiGSTT $ liftM hListMGettableOnly get++mSetRaw :: Monad m => HListM ts -> MultiGSTT ts m ()+mSetRaw = MultiGSTT . put++mapMultiGSTT+ :: (ts ~ HListM cts)+ => (m (a, ts) -> m' (a', ts))+ -> MultiGSTT cts m a+ -> MultiGSTT cts m' a'+mapMultiGSTT f = MultiGSTT . mapStateT f . runMultiGSTTRaw+
+ src/Control/Monad/Trans/MultiGST/Strict.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Alternative multi-valued version of mtl's RWS / RWST. In contrast to+-- @'MultiRWS'(T)@ this version only takes a single list of types as+-- parameter, but with additional encoding of the allowed access for each+-- element. This supports the @'MonadMultiGet'@ notion more succinctly, i.e.+-- to pass a "state" element to a function that only requires/expects read/get+-- access. This is not possible with 'MultiRWS'.+module Control.Monad.Trans.MultiGST.Strict+ ( MultiGSTT(..)+ , MultiGSTTNull+ , MultiGST+ -- * MonadMulti classes+ , ContainsReader+ , ContainsState+ , ContainsWriter+ , MonadMultiReader(..)+ , MonadMultiWriter(..)+ , MonadMultiGet(..)+ , CanReadWrite(..)+ -- * run-functions+ , runMultiGSTTNil+ , runMultiGSTTNil_+ -- * with-functions+ , withReader+ , withReader_+ , withWriter+ , withWriterAW+ , withWriterWA+ , withWriterW+ , withState+ , withStateAS+ , withStateSA+ , withStateA+ , withStateS+ , withState_+ -- * without-functions+ , without+ -- * other functions+ , mGetRaw+ , mSetRaw+ , mapMultiGSTT+ )+where++++import Control.Monad.State.Strict ( StateT(..)+ , MonadState(..)+ , execStateT+ , evalStateT+ , mapStateT )++import Data.Functor.Identity ( Identity )++import Control.Monad.Trans.Class ( MonadTrans+ , lift+ )+import Control.Monad ( MonadPlus(..)+ , liftM+ , ap+ , void )++import Data.Monoid ( Monoid+ , (<>)+ )++import GHC.Exts (Constraint)++import Control.Monad.Trans.MultiReader.Class+import Control.Monad.Trans.MultiWriter.Class+import Control.Monad.Trans.MultiState.Class++import Control.Monad.Trans.MultiGST.Common++++newtype MultiGSTT ts m a = MultiGSTT {+ runMultiGSTTRaw :: StateT (HListM ts) m a+}+ deriving(Functor, Applicative, Monad, MonadTrans)++type MultiGSTTNull = MultiGSTT '[]++type MultiGST r = MultiGSTT r Identity+++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ (Monad m, HListMContains 'GettableFlag a cts)+ => MonadMultiGet a (MultiGSTT cts m) where+ mGet = MultiGSTT $ liftM (\ts -> readHListMElem @'GettableFlag ts) get++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ (Monad m, HListMContains 'SettableFlag a cts)+ => MonadMultiState a (MultiGSTT cts m) where+ mSet x = MultiGSTT $ do+ ts <- get+ put $ writeHListMElem @'SettableFlag x ts++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ ( Monad m+ , Monoid a+ , HListMContains 'TellableFlag a cts+ ) => MonadMultiWriter a (MultiGSTT cts m) where+ mTell x = MultiGSTT $ do+ ts <- get+ let x' = readHListMElem @'TellableFlag ts+ put $ writeHListMElem @'TellableFlag (x' <> x) ts++runMultiGSTTNil :: Monad m => MultiGSTT '[] m a -> m a+runMultiGSTTNil_ :: Monad m => MultiGSTT '[] m a -> m ()++runMultiGSTTNil k = evalStateT (runMultiGSTTRaw k) (HNilM)+runMultiGSTTNil_ k = liftM (const ()) (evalStateT (runMultiGSTTRaw k) (HNilM))++withReader :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m a+withReader x k = MultiGSTT $ do+ tr <- get+ (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr)+ put $ case ts' of _ :+-: tr' -> tr'+ return a++withReader_ :: Monad m => t -> MultiGSTT ('Gettable t ': tr) m a -> MultiGSTT tr m ()+withReader_ x k = MultiGSTT $ do+ tr <- get+ (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (x :+-: tr)+ put $ case ts' of _ :+-: tr' -> tr'++withWriter :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t)+withWriterAW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (a, t)+withWriterWA :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m (t, a)+withWriterW :: (Monoid t, Monad m) => MultiGSTT ('Tellable t ': tr) m a -> MultiGSTT tr m t+withWriter = withWriterAW+withWriterAW k = MultiGSTT $ do+ tr <- get+ (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr)+ case ts' of+ t :-+: tr' -> do+ put tr'+ return (a, t)+withWriterWA k = MultiGSTT $ do+ tr <- get+ (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr)+ case ts' of+ t :-+: tr' -> do+ put tr'+ return (t, a)+withWriterW k = MultiGSTT $ do+ tr <- get+ (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (mempty :-+: tr)+ case ts' of+ t :-+: tr' -> do+ put tr'+ return t++withState :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t)+withStateAS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (a, t)+withStateSA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m (t, a)+withStateA :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m a+withStateS :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m t+withState_ :: Monad m => t -> MultiGSTT ('Settable t ': tr) m a -> MultiGSTT tr m ()+withState = withStateAS+withStateAS t k = MultiGSTT $ do+ tr <- get+ (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr)+ case ts' of+ t' :++: tr' -> do+ put tr'+ return (a, t')+withStateSA t k = MultiGSTT $ do+ tr <- get+ (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr)+ case ts' of+ t' :++: tr' -> do+ put tr'+ return (t', a)+withStateA t k = MultiGSTT $ do+ tr <- get+ (a, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr)+ case ts' of+ _ :++: tr' -> do+ put tr'+ return a+withStateS t k = MultiGSTT $ do+ tr <- get+ (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr)+ case ts' of+ t' :++: tr' -> do+ put tr'+ return t'+withState_ t k = MultiGSTT $ do+ tr <- get+ (_, ts') <- lift $ runStateT (runMultiGSTTRaw k) (t :++: tr)+ case ts' of+ _ :++: tr' -> do+ put tr'++without :: Monad m => MultiGSTT tr m a -> MultiGSTT (ct ': tr) m a+without k = MultiGSTT $ do+ ts <- get+ case ts of+ (t :+-: tr) -> do+ (a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr+ put (t :+-: tr')+ return a+ (t :-+: tr) -> do+ (a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr+ put (t :-+: tr')+ return a+ (t :++: tr) -> do+ (a, tr') <- lift $ runStateT (runMultiGSTTRaw k) tr+ put (t :++: tr')+ return a++mGetRaw :: Monad m => MultiGSTT ts m (HListM ts)+mGetRaw = MultiGSTT get++mSetRaw :: Monad m => HListM ts -> MultiGSTT ts m ()+mSetRaw = MultiGSTT . put++mapMultiGSTT+ :: (ts ~ HListM cts)+ => (m (a, ts) -> m' (a', ts))+ -> MultiGSTT cts m a+ -> MultiGSTT cts m' a'+mapMultiGSTT f = MultiGSTT . mapStateT f . runMultiGSTTRaw+
+ src/Control/Monad/Trans/MultiGet/Class.hs view
@@ -0,0 +1,29 @@+-- | The MonadMultiReader type-class+module Control.Monad.Trans.MultiGet.Class+ (+ -- * MonadMultiReader class+ MonadMultiGet(..)+ )+where++++import Control.Monad.Trans.Class ( MonadTrans+ , lift )++++-- | In contrast to MonadMultiReader, MonadMultiGet is defined for State too,+-- so it corresponds to read-access of any kind.+--+-- Note however that for MultiRWS, only the values from the @state@ part can+-- be accessed via @MonadMultiGet@, due to limitations of the design of+-- @MultiRWS@ and of the type system. This is issue is resolved in the+-- @MultiGST@ type.+class (Monad m) => MonadMultiGet a m where+ mGet :: m a -- ^ Access to a specific type in the environment.++instance (MonadTrans t, Monad (t m), MonadMultiGet a m)+ => MonadMultiGet a (t m) where+ mGet = lift $ mGet+
src/Control/Monad/Trans/MultiRWS.hs view
@@ -8,6 +8,7 @@ -- * MonadMulti classes , MonadMultiReader(..) , MonadMultiWriter(..)+ , MonadMultiGet(..) , MonadMultiState(..) -- * run-functions (extracting from RWST) , runMultiRWST
src/Control/Monad/Trans/MultiRWS/Lazy.hs view
@@ -13,6 +13,7 @@ -- * MonadMulti classes , MonadMultiReader(..) , MonadMultiWriter(..)+ , MonadMultiGet(..) , MonadMultiState(..) -- * run-functions (extracting from RWST) , runMultiRWST@@ -75,7 +76,7 @@ import Control.Monad.Trans.MultiReader.Class ( MonadMultiReader(..) ) import Control.Monad.Trans.MultiWriter.Class ( MonadMultiWriter(..) )-import Control.Monad.Trans.MultiState.Class ( MonadMultiState(..) )+import Control.Monad.Trans.MultiState.Class import Control.Monad.Trans.MultiReader.Lazy ( MultiReaderT(..) , runMultiReaderT ) import Control.Monad.Trans.MultiWriter.Lazy ( MultiWriterT(..)@@ -134,42 +135,49 @@ (<*>) = ap instance (Monad m) => Monad (MultiRWST r w s m) where- return = MultiRWST . return+ return = pure k >>= f = MultiRWST $ runMultiRWSTRaw k >>= runMultiRWSTRaw . f instance MonadTrans (MultiRWST r w s) where lift = MultiRWST . lift +instance #if MIN_VERSION_base(4,8,0)-instance {-# OVERLAPPING #-} (Monad m, ContainsType a r)-#else-instance (Monad m, ContainsType a r)+ {-# OVERLAPPING #-} #endif+ (Monad m, ContainsType a r) => MonadMultiReader a (MultiRWST r w s m) where mAsk = MultiRWST $ liftM (\(r,_,_) -> getHListElem r) get +instance #if MIN_VERSION_base(4,8,0)-instance {-# OVERLAPPING #-} (Monad m, ContainsType a w, Monoid a)-#else-instance (Monad m, ContainsType a w, Monoid a)+ {-# OVERLAPPING #-} #endif+ (Monad m, ContainsType a w, Monoid a) => MonadMultiWriter a (MultiRWST r w s m) where mTell v = MultiRWST $ do ~(r,w,s) <- get put $ (r, setHListElem (getHListElem w `mappend` v) w, s) +instance #if MIN_VERSION_base(4,8,0)-instance {-# OVERLAPPING #-} (Monad m, ContainsType a s)-#else-instance (Monad m, ContainsType a s)+ {-# OVERLAPPING #-} #endif+ (Monad m, ContainsType a s)+ => MonadMultiGet a (MultiRWST r w s m) where+ mGet = MultiRWST $ do+ ~(_,_,s) <- get+ return $ getHListElem s++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ (Monad m, ContainsType a s) => MonadMultiState a (MultiRWST r w s m) where mSet v = MultiRWST $ do ~(r,w,s) <- get put (r, w, setHListElem v s)- mGet = MultiRWST $ do- ~(_,_,s) <- get- return $ getHListElem s instance MonadFix m => MonadFix (MultiRWST r w s m) where mfix f = MultiRWST $ mfix (runMultiRWSTRaw . f)@@ -378,18 +386,18 @@ withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x withoutMultiReader :: Monad m => MultiRWST rs w s m a -> MultiRWST (r ': rs) w s m a-withoutMultiReader k = MultiRWST $ do- (rs@(_ :+: rr), w, s) <- get- ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (rr, w, s)- put (rs, w', s')- return a+withoutMultiReader k = MultiRWST $ get >>= \case+ (rs@(_ :+: rr), w, s) -> do+ ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (rr, w, s)+ put (rs, w', s')+ return a withoutMultiState :: Monad m => MultiRWST r w ss m a -> MultiRWST r w (s ': ss) m a-withoutMultiState k = MultiRWST $ do- (r, w, s :+: sr) <- get- ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, sr)- put (r, w', s :+: s')- return a+withoutMultiState k = MultiRWST $ get >>= \case+ (r, w, s :+: sr) -> do+ ~(a, ~(_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, sr)+ put (r, w', s :+: s')+ return a inflateReader :: (Monad m, ContainsType r rs) => ReaderT r m a@@ -413,9 +421,9 @@ ~(x, w) <- lift $ runMultiWriterT k mPutRawW w return x-inflateState :: (Monad m, ContainsType s ss)+inflateState :: (Monad m, MonadMultiState s (t m), MonadTrans t) => StateT s m a- -> MultiRWST r w ss m a+ -> t m a inflateState k = do s <- mGet ~(x, s') <- lift $ runStateT k s
src/Control/Monad/Trans/MultiRWS/Strict.hs view
@@ -14,6 +14,7 @@ -- * MonadMulti classes , MonadMultiReader(..) , MonadMultiWriter(..)+ , MonadMultiGet(..) , MonadMultiState(..) -- * run-functions (extracting from RWST) , runMultiRWST@@ -76,7 +77,7 @@ import Control.Monad.Trans.MultiReader.Class ( MonadMultiReader(..) ) import Control.Monad.Trans.MultiWriter.Class ( MonadMultiWriter(..) )-import Control.Monad.Trans.MultiState.Class ( MonadMultiState(..) )+import Control.Monad.Trans.MultiState.Class import Control.Monad.Trans.MultiReader.Strict ( MultiReaderT(..) , runMultiReaderT ) import Control.Monad.Trans.MultiWriter.Strict ( MultiWriterT(..)@@ -135,43 +136,50 @@ (<*>) = ap instance (Monad m) => Monad (MultiRWST r w s m) where- return = MultiRWST . return+ return = pure k >>= f = MultiRWST $ runMultiRWSTRaw k >>= runMultiRWSTRaw . f instance MonadTrans (MultiRWST r w s) where lift = MultiRWST . lift +instance #if MIN_VERSION_base(4,8,0)-instance {-# OVERLAPPING #-} (Monad m, ContainsType a r)-#else-instance (Monad m, ContainsType a r)+ {-# OVERLAPPING #-} #endif+ (Monad m, ContainsType a r) => MonadMultiReader a (MultiRWST r w s m) where mAsk = MultiRWST $ liftM (\(r,_,_) -> getHListElem r) get +instance #if MIN_VERSION_base(4,8,0)-instance {-# OVERLAPPING #-} (Monad m, ContainsType a w, Monoid a)-#else-instance (Monad m, ContainsType a w, Monoid a)+ {-# OVERLAPPING #-} #endif+ (Monad m, ContainsType a w, Monoid a) => MonadMultiWriter a (MultiRWST r w s m) where mTell v = MultiRWST $ do (r,w,s) <- get let !x' = getHListElem w `mappend` v put $ (r, setHListElem x' w, s) +instance #if MIN_VERSION_base(4,8,0)-instance {-# OVERLAPPING #-} (Monad m, ContainsType a s)-#else-instance (Monad m, ContainsType a s)+ {-# OVERLAPPING #-} #endif+ (Monad m, ContainsType a s)+ => MonadMultiGet a (MultiRWST r w s m) where+ mGet = MultiRWST $ do+ (_,_,s) <- get+ return $ getHListElem s++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ (Monad m, ContainsType a s) => MonadMultiState a (MultiRWST r w s m) where mSet !v = MultiRWST $ do (r,w,s) <- get put (r, w, setHListElem v s)- mGet = MultiRWST $ do- (_,_,s) <- get- return $ getHListElem s instance MonadFix m => MonadFix (MultiRWST r w s m) where mfix f = MultiRWST $ mfix (runMultiRWSTRaw . f)@@ -380,18 +388,18 @@ withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x withoutMultiReader :: Monad m => MultiRWST rs w s m a -> MultiRWST (r ': rs) w s m a-withoutMultiReader k = MultiRWST $ do- (rs@(_ :+: rr), w, s) <- get- (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (rr, w, s)- put (rs, w', s')- return a+withoutMultiReader k = MultiRWST $ get >>= \case+ (rs@(_ :+: rr), w, s) -> do+ (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (rr, w, s)+ put (rs, w', s')+ return a withoutMultiState :: Monad m => MultiRWST r w ss m a -> MultiRWST r w (s ': ss) m a-withoutMultiState k = MultiRWST $ do- (r, w, s :+: sr) <- get- (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, sr)- put (r, w', s :+: s')- return a+withoutMultiState k = MultiRWST $ get >>= \case+ (r, w, s :+: sr) -> do+ (a, (_, w', s')) <- lift $ runStateT (runMultiRWSTRaw k) (r, w, sr)+ put (r, w', s :+: s')+ return a inflateReader :: (Monad m, ContainsType r rs) => ReaderT r m a@@ -415,9 +423,9 @@ (x, w) <- lift $ runMultiWriterT k mPutRawW w return x-inflateState :: (Monad m, ContainsType s ss)+inflateState :: (Monad m, MonadTrans t, MonadMultiState s (t m)) => StateT s m a- -> MultiRWST r w ss m a+ -> t m a inflateState k = do s <- mGet (x, s') <- lift $ runStateT k s
src/Control/Monad/Trans/MultiReader/Class.hs view
@@ -12,7 +12,6 @@ , lift ) - -- | All methods must be defined. -- -- The idea is: Any monad stack is instance of @MonadMultiReader a@, iff
src/Control/Monad/Trans/MultiReader/Lazy.hs view
@@ -9,6 +9,7 @@ , MultiReader -- * MonadMultiReader class , MonadMultiReader(..)+ , MonadMultiGet(..) -- * run-functions , runMultiReaderT , runMultiReaderT_@@ -35,7 +36,8 @@ import Data.HList.HList import Data.HList.ContainsType -import Control.Monad.Trans.MultiReader.Class ( MonadMultiReader(..) )+import Control.Monad.Trans.MultiReader.Class+import Control.Monad.Trans.MultiState.Class import Control.Monad.State.Lazy ( StateT(..) , MonadState(..)@@ -74,23 +76,23 @@ -- | A Reader transformer monad patameterized by:--- +-- -- * x - The list of types constituting the environment / input (to be read), -- * m - The inner monad.--- +-- -- 'MultiReaderT' corresponds to mtl's 'ReaderT', but can contain -- a heterogenous list of types.--- +-- -- This heterogenous list is represented using Types.Data.List, i.e:--- +-- -- * @'[]@ - The empty list, -- * @a ': b@ - A list where @/a/@ is an arbitrary type -- and @/b/@ is the rest list.--- +-- -- For example,--- +-- -- > MultiReaderT '[Int, Bool] :: (* -> *) -> (* -> *)--- +-- -- is a Reader transformer containing the types [Int, Bool]. newtype MultiReaderT x m a = MultiReaderT { runMultiReaderTRaw :: StateT (HList x) m a@@ -113,7 +115,7 @@ (<*>) = ap instance Monad m => Monad (MultiReaderT x m) where- return = MultiReaderT . return+ return = pure k >>= f = MultiReaderT $ runMultiReaderTRaw k >>= runMultiReaderTRaw . f instance MonadTrans (MultiReaderT x) where@@ -127,6 +129,14 @@ => MonadMultiReader a (MultiReaderT c m) where mAsk = MultiReaderT $ liftM getHListElem get +#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPING #-} (Monad m, ContainsType a c)+#else+instance (Monad m, ContainsType a c)+#endif+ => MonadMultiGet a (MultiReaderT c m) where+ mGet = MultiReaderT $ liftM getHListElem get+ instance MonadFix m => MonadFix (MultiReaderT r m) where mfix f = MultiReaderT $ mfix (runMultiReaderTRaw . f) @@ -176,9 +186,8 @@ withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader_ x withoutMultiReader :: Monad m => MultiReaderT rs m a -> MultiReaderT (r ': rs) m a-withoutMultiReader k = MultiReaderT $ do- _ :+: rr <- get- lift $ runMultiReaderT rr k+withoutMultiReader k = MultiReaderT $ get >>= \case+ (_ :+: rr) -> lift $ runMultiReaderT rr k inflateReader :: (Monad m, ContainsType r rs) => ReaderT r m a@@ -200,7 +209,7 @@ runMultiReaderTRaw pass = MultiReaderT . mapStateT (pass . liftM (\(~(~(a, f), w)) -> ((a, w), f))) .- runMultiReaderTRaw + runMultiReaderTRaw instance MonadIO m => MonadIO (MultiReaderT c m) where liftIO = lift . liftIO
src/Control/Monad/Trans/MultiReader/Strict.hs view
@@ -9,6 +9,7 @@ , MultiReader -- * MonadMultiReader class , MonadMultiReader(..)+ , MonadMultiGet(..) -- * run-functions , runMultiReaderT , runMultiReaderT_@@ -35,7 +36,8 @@ import Data.HList.HList import Data.HList.ContainsType -import Control.Monad.Trans.MultiReader.Class ( MonadMultiReader(..) )+import Control.Monad.Trans.MultiReader.Class+import Control.Monad.Trans.MultiState.Class import Control.Monad.State.Strict ( StateT(..) , MonadState(..)@@ -74,23 +76,23 @@ -- | A Reader transformer monad patameterized by:--- +-- -- * x - The list of types constituting the environment / input (to be read), -- * m - The inner monad.--- +-- -- 'MultiReaderT' corresponds to mtl's 'ReaderT', but can contain -- a heterogenous list of types.--- +-- -- This heterogenous list is represented using Types.Data.List, i.e:--- +-- -- * @'[]@ - The empty list, -- * @a ': b@ - A list where @/a/@ is an arbitrary type -- and @/b/@ is the rest list.--- +-- -- For example,--- +-- -- > MultiReaderT '[Int, Bool] :: (* -> *) -> (* -> *)--- +-- -- is a Reader transformer containing the types [Int, Bool]. newtype MultiReaderT x m a = MultiReaderT { runMultiReaderTRaw :: StateT (HList x) m a@@ -113,7 +115,7 @@ (<*>) = ap instance Monad m => Monad (MultiReaderT x m) where- return = MultiReaderT . return+ return = pure k >>= f = MultiReaderT $ runMultiReaderTRaw k >>= (runMultiReaderTRaw . f) instance MonadTrans (MultiReaderT x) where@@ -127,6 +129,14 @@ => MonadMultiReader a (MultiReaderT c m) where mAsk = MultiReaderT $ liftM getHListElem get +#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPING #-} (Monad m, ContainsType a c)+#else+instance (Monad m, ContainsType a c)+#endif+ => MonadMultiGet a (MultiReaderT c m) where+ mGet = MultiReaderT $ liftM getHListElem get+ instance MonadFix m => MonadFix (MultiReaderT r m) where mfix f = MultiReaderT $ mfix (runMultiReaderTRaw . f) @@ -176,9 +186,8 @@ withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader_ x withoutMultiReader :: Monad m => MultiReaderT rs m a -> MultiReaderT (r ': rs) m a-withoutMultiReader k = MultiReaderT $ do- _ :+: rr <- get- lift $ runMultiReaderT rr k+withoutMultiReader k = MultiReaderT $ get >>= \case+ (_ :+: rr) -> lift $ runMultiReaderT rr k inflateReader :: (Monad m, ContainsType r rs) => ReaderT r m a@@ -200,7 +209,7 @@ runMultiReaderTRaw pass = MultiReaderT . mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) .- runMultiReaderTRaw + runMultiReaderTRaw instance MonadIO m => MonadIO (MultiReaderT c m) where liftIO = lift . liftIO
src/Control/Monad/Trans/MultiState.hs view
@@ -7,6 +7,7 @@ , MultiStateTNull , MultiState -- * MonadMultiState class+ , MonadMultiGet(..) , MonadMultiState(..) -- * run-functions , runMultiStateT
src/Control/Monad/Trans/MultiState/Class.hs view
@@ -2,28 +2,27 @@ module Control.Monad.Trans.MultiState.Class ( -- * MonadMultiState class- MonadMultiState(..)+ MonadMultiGet(..)+ , MonadMultiState(..) ) where +import Control.Monad.Trans.MultiGet.Class+ import Control.Monad.Trans.Class ( MonadTrans , lift ) --- | All methods must be defined.--- -- The idea is: Any monad stack is instance of @MonadMultiState a@, iff--- the stack contains a @MultiStateT x@ with /a/ element of /x/.-class (Monad m) => MonadMultiState a m where- -- | state set function for values of type @a@.+-- the stack contains a @MultiStateT s m@ with /a/ element of /s/,+-- or a @MultiRWST r w s m@ with /a/ element of /s/.+class (MonadMultiGet a m) => MonadMultiState a m where mSet :: a -> m ()- -- | state get function for values of type @a@.- mGet :: m a instance (MonadTrans t, Monad (t m), MonadMultiState a m) => MonadMultiState a (t m) where mSet = lift . mSet- mGet = lift $ mGet+
src/Control/Monad/Trans/MultiState/Lazy.hs view
@@ -8,6 +8,7 @@ , MultiStateTNull , MultiState -- * MonadMultiState class+ , MonadMultiGet(..) , MonadMultiState(..) -- * run-functions , runMultiStateT@@ -91,23 +92,23 @@ -- | A State transformer monad patameterized by:--- +-- -- * x - The list of types constituting the state, -- * m - The inner monad.--- +-- -- 'MultiStateT' corresponds to mtl's 'StateT', but can contain -- a heterogenous list of types.--- +-- -- This heterogenous list is represented using Types.Data.List, i.e:--- +-- -- * @'[]@ - The empty list, -- * @a ': b@ - A list where @/a/@ is an arbitrary type -- and @/b/@ is the rest list.--- +-- -- For example,--- +-- -- > MultiStateT '[Int, Bool] :: (* -> *) -> (* -> *)--- +-- -- is a State wrapper containing the types [Int, Bool]. newtype MultiStateT x m a = MultiStateT { runMultiStateTRaw :: StateT (HList x) m a@@ -131,7 +132,7 @@ (<*>) = ap instance Monad m => Monad (MultiStateT x m) where- return = MultiStateT . return+ return = pure k >>= f = MultiStateT $ runMultiStateTRaw k >>= (runMultiStateTRaw.f) instance MonadTrans (MultiStateT x) where@@ -142,9 +143,16 @@ #else instance (Monad m, ContainsType a c) #endif+ => MonadMultiGet a (MultiStateT c m) where+ mGet = MultiStateT $ liftM getHListElem get++#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPING #-} (Monad m, ContainsType a c)+#else+instance (Monad m, ContainsType a c)+#endif => MonadMultiState a (MultiStateT c m) where mSet v = MultiStateT $ get >>= put . setHListElem v- mGet = MultiStateT $ liftM getHListElem get instance MonadFix m => MonadFix (MultiStateT s m) where mfix f = MultiStateT $ mfix (runMultiStateTRaw . f)@@ -215,11 +223,11 @@ withMultiStates = withMultiStatesAS withMultiStatesAS HNil = liftM (\r -> (r, HNil)) withMultiStatesAS (x :+: xs) = liftM (\(~(~(a, x'), xs')) -> (a, x' :+: xs'))- . withMultiStatesAS xs + . withMultiStatesAS xs . withMultiStateAS x withMultiStatesSA HNil = liftM (\r -> (HNil, r)) withMultiStatesSA (x :+: xs) = liftM (\(~(~(a, x'), xs')) -> (x' :+: xs', a))- . withMultiStatesAS xs + . withMultiStatesAS xs . withMultiStateAS x withMultiStatesA HNil = id withMultiStatesA (x :+: xs) = withMultiStatesA xs . withMultiStateA x@@ -231,11 +239,11 @@ withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x withoutMultiState :: (Functor m, Monad m) => MultiStateT ss m a -> MultiStateT (s ': ss) m a-withoutMultiState k = MultiStateT $ do- s :+: sr <- get- ~(a, sr') <- lift $ runMultiStateT sr k- put (s :+: sr')- return a+withoutMultiState k = MultiStateT $ get >>= \case+ s :+: sr -> do+ ~(a, sr') <- lift $ runMultiStateT sr k+ put (s :+: sr')+ return a inflateState :: (Monad m, ContainsType s ss) => StateT s m a@@ -274,7 +282,7 @@ runMultiStateTRaw pass = MultiStateT . mapStateT (pass . liftM (\(~(~(a, f), w)) -> ((a, w), f))) .- runMultiStateTRaw + runMultiStateTRaw instance MonadIO m => MonadIO (MultiStateT c m) where liftIO = lift . liftIO
src/Control/Monad/Trans/MultiState/Strict.hs view
@@ -8,6 +8,7 @@ , MultiStateTNull , MultiState -- * MonadMultiState class+ , MonadMultiGet(..) , MonadMultiState(..) -- * run-functions , runMultiStateT@@ -49,8 +50,6 @@ import Data.HList.HList import Data.HList.ContainsType -import Control.Monad.Trans.MultiState.Class- import Control.Monad.State.Strict ( StateT(..) , MonadState(..) , evalStateT@@ -65,7 +64,9 @@ , tell , writer , pass )+import Control.Monad.Trans.MultiState.Class + import Data.Functor.Identity ( Identity ) import Control.Applicative ( Applicative(..)@@ -91,23 +92,23 @@ -- | A State transformer monad patameterized by:--- +-- -- * x - The list of types constituting the state, -- * m - The inner monad.--- +-- -- 'MultiStateT' corresponds to mtl's 'StateT', but can contain -- a heterogenous list of types.--- +-- -- This heterogenous list is represented using Types.Data.List, i.e:--- +-- -- * @'[]@ - The empty list, -- * @a ': b@ - A list where @/a/@ is an arbitrary type -- and @/b/@ is the rest list.--- +-- -- For example,--- +-- -- > MultiStateT '[Int, Bool] :: (* -> *) -> (* -> *)--- +-- -- is a State wrapper containing the types [Int, Bool]. newtype MultiStateT x m a = MultiStateT { runMultiStateTRaw :: StateT (HList x) m a@@ -129,7 +130,7 @@ (<*>) = ap instance Monad m => Monad (MultiStateT x m) where- return = MultiStateT . return+ return = pure k >>= f = MultiStateT $ runMultiStateTRaw k >>= (runMultiStateTRaw.f) instance MonadTrans (MultiStateT x) where@@ -140,9 +141,16 @@ #else instance (Monad m, ContainsType a c) #endif+ => MonadMultiGet a (MultiStateT c m) where+ mGet = MultiStateT $ liftM getHListElem get++#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPING #-} (Monad m, ContainsType a c)+#else+instance (Monad m, ContainsType a c)+#endif => MonadMultiState a (MultiStateT c m) where mSet v = MultiStateT $ get >>= put . setHListElem v- mGet = MultiStateT $ liftM getHListElem get instance MonadFix m => MonadFix (MultiStateT s m) where mfix f = MultiStateT $ mfix (runMultiStateTRaw . f)@@ -213,11 +221,11 @@ withMultiStates = withMultiStatesAS withMultiStatesAS HNil = liftM (\r -> (r, HNil)) withMultiStatesAS (x :+: xs) = liftM (\((a, x'), xs') -> (a, x' :+: xs'))- . withMultiStatesAS xs + . withMultiStatesAS xs . withMultiStateAS x withMultiStatesSA HNil = liftM (\r -> (HNil, r)) withMultiStatesSA (x :+: xs) = liftM (\((a, x'), xs') -> (x' :+: xs', a))- . withMultiStatesAS xs + . withMultiStatesAS xs . withMultiStateAS x withMultiStatesA HNil = id withMultiStatesA (x :+: xs) = withMultiStatesA xs . withMultiStateA x@@ -229,11 +237,11 @@ withMultiStates_ (x :+: xs) = withMultiStates_ xs . withMultiState_ x withoutMultiState :: (Functor m, Monad m) => MultiStateT ss m a -> MultiStateT (s ': ss) m a-withoutMultiState k = MultiStateT $ do- s :+: sr <- get- (a, sr') <- lift $ runMultiStateT sr k- put (s :+: sr')- return a+withoutMultiState k = MultiStateT $ get >>= \case+ s :+: sr -> do+ (a, sr') <- lift $ runMultiStateT sr k+ put (s :+: sr')+ return a inflateState :: (Monad m, ContainsType s ss) => StateT s m a@@ -272,7 +280,7 @@ runMultiStateTRaw pass = MultiStateT . mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) .- runMultiStateTRaw + runMultiStateTRaw instance MonadIO m => MonadIO (MultiStateT c m) where liftIO = lift . liftIO
src/Control/Monad/Trans/MultiWriter/Lazy.hs view
@@ -85,23 +85,23 @@ -- | A Writer transformer monad patameterized by:--- +-- -- * x - The list of types that can be written (Monoid instances). -- * m - The inner monad.--- +-- -- 'MultiWriterT' corresponds to mtl's 'WriterT', but can contain -- a heterogenous list of types.--- +-- -- This heterogenous list is represented using Types.Data.List, i.e:--- +-- -- * @'[]@ - The empty list, -- * @a ': b@ - A list where @/a/@ is an arbitrary type -- and @/b/@ is the rest list.--- +-- -- For example,--- +-- -- > MultiWriterT '[Int, Bool] :: (* -> *) -> (* -> *)--- +-- -- is a Writer transformer containing the types [Int, Bool]. newtype MultiWriterT x m a = MultiWriterT { runMultiWriterTRaw :: StateT (HList x) m a@@ -120,7 +120,7 @@ (<*>) = ap instance Monad m => Monad (MultiWriterT x m) where- return = MultiWriterT . return+ return = pure k >>= f = MultiWriterT $ runMultiWriterTRaw k >>= (runMultiWriterTRaw . f) instance MonadTrans (MultiWriterT x) where
src/Control/Monad/Trans/MultiWriter/Strict.hs view
@@ -85,23 +85,23 @@ -- | A Writer transformer monad patameterized by:--- +-- -- * x - The list of types that can be written (Monoid instances). -- * m - The inner monad.--- +-- -- 'MultiWriterT' corresponds to mtl's 'WriterT', but can contain -- a heterogenous list of types.--- +-- -- This heterogenous list is represented using Types.Data.List, i.e:--- +-- -- * @'[]@ - The empty list, -- * @a ': b@ - A list where @/a/@ is an arbitrary type -- and @/b/@ is the rest list.--- +-- -- For example,--- +-- -- > MultiWriterT '[Int, Bool] :: (* -> *) -> (* -> *)--- +-- -- is a Writer transformer containing the types [Int, Bool]. newtype MultiWriterT x m a = MultiWriterT { runMultiWriterTRaw :: StateT (HList x) m a@@ -120,7 +120,7 @@ (<*>) = ap instance Monad m => Monad (MultiWriterT x m) where- return = MultiWriterT . return+ return = pure k >>= f = MultiWriterT $ runMultiWriterTRaw k >>= (runMultiWriterTRaw.f) instance MonadTrans (MultiWriterT x) where
src/Data/HList/ContainsType.hs view
@@ -12,6 +12,9 @@ +----------------------------------------+-- class ContainsType+-- | for get/put of a value in a HList, with type-directed lookup. class ContainsType a c where setHListElem :: a -> HList c -> HList c getHListElem :: HList c -> a@@ -27,3 +30,4 @@ instance (ContainsType a xs) => ContainsType a (x ': xs) where setHListElem a (x :+: xr) = x :+: setHListElem a xr getHListElem (_ :+: xr) = getHListElem xr+
src/Data/HList/HList.hs view
@@ -9,8 +9,8 @@ -- | A GADT HList implementation ----- Probably exists somewhere else already, but why add a dependency--- for something so simple.+-- There exist other implementations of HList on hackage, but none seem to+-- be reliably maintained. module Data.HList.HList ( HList(..) , Append@@ -22,13 +22,15 @@ import Prelude hiding (reverse) -import Data.Monoid+import Data.Kind (Type)+import Data.Monoid (Monoid, mappend, mempty)+import Data.Semigroup import Data.Proxy -data HList :: [*] -> * where+data HList :: [Type] -> Type where HNil :: HList '[] (:+:) :: x -> HList xs -> HList (x ': xs) -- TCons :: x -> HList xs -> HList (Cons x xs)@@ -42,16 +44,21 @@ instance (Show a, Show (HList b)) => Show (HList (a ': b)) where show (x :+: y) = "(" ++ show x ++ ":+:" ++ show y ++ ")" +instance Semigroup (HList '[]) where+ _ <> _ = HNil+instance (Semigroup x, Semigroup (HList xs))+ => Semigroup (HList (x ': xs))+ where+ (x1 :+: xs1) <> (x2 :+: xs2) = (x1 <> x2) :+: (xs1 <> xs2)+ instance Monoid (HList '[]) where mempty = HNil- mappend _ _ = HNil--instance (Monoid x, Monoid (HList xs))+ mappend = (<>)+instance (Semigroup x, Monoid x, Semigroup (HList xs), Monoid (HList xs)) => Monoid (HList (x ': xs)) where mempty = mempty :+: mempty- mappend (x1 :+: xs1) (x2 :+: xs2) = (x1 `mappend` x2)- :+: (xs1 `mappend` xs2)+ mappend = (<>) instance Eq (HList '[]) where HNil == HNil = True@@ -66,7 +73,7 @@ -- cannot use the closed variant because of ghc-7.8.4. -- (was not investigated more closely; there simply -- is some syntax error for code which works fine with ghc-7.10.)-type family Append (l1::[*]) (l2::[*]) :: [*]+type family Append (l1::[Type]) (l2::[Type]) :: [Type] type instance Append '[] l2 = l2 type instance Append (car1 ': cdr2) l2 = car1 ': Append cdr2 l2 @@ -74,7 +81,7 @@ hAppend HNil l = l hAppend (x:+:xs) l = x :+: hAppend xs l -class HInit (l1 :: [*]) where+class HInit (l1 :: [Type]) where hInit :: forall l2 . Proxy l2 -> HList (Append l1 l2) -> HList l1 hSplit :: forall l2 . HList (Append l1 l2) -> (HList l1, HList l2)
test/Test.hs view
@@ -12,6 +12,8 @@ import Data.Functor.Identity import Data.HList.HList import Data.Monoid+import Data.Semigroup+ import qualified Control.Monad.Trans.MultiState as MS import qualified Control.Monad.Trans.MultiReader as MR import qualified Control.Monad.Trans.MultiWriter as MW@@ -35,7 +37,7 @@ runnerMS x m = runEvalMS $ MS.withMultiStateA x m runnerMR :: a -> MR.MultiReaderT '[a] Identity a -> a runnerMR x m = runEvalMR $ MR.withMultiReader x m-runnerMW :: Monoid a => MW.MultiWriterT '[a] Identity b -> a+runnerMW :: (Semigroup a, Monoid a) => MW.MultiWriterT '[a] Identity b -> a runnerMW m = case runExecMW m of (x :+: _) -> x -- TODO: ghc bug?: warning on: -- runnerMW m = case runExecMW m of (x :+: HNil) -> x