packages feed

multistate 0.7.1.2 → 0.8.0.0

raw patch · 22 files changed

+890/−187 lines, 22 filesdep ~basedep ~hspec

Dependency ranges changed: base, hspec

Files

changelog.md view
@@ -1,5 +1,14 @@ # Changelog for [`multistate` package](https://hackage.haskell.org/package/multistate) +** 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,5 +1,5 @@ Name:          multistate-Version:       0.7.1.2+Version:       0.8.0.0 Cabal-Version: >= 1.10 Build-Type:    Simple license:       BSD3@@ -39,6 +39,7 @@ flag build-example   description: Build the MultiState-example example program   default: False+  manual: True  library {   default-language:@@ -46,9 +47,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 +63,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.9   && <4.12,     mtl          >= 2.1   && <2.3,     transformers >= 0.3   && <0.6,     tagged       >= 0.7   && <0.9,@@ -81,10 +84,6 @@     UndecidableInstances     TypeOperators     DataKinds-  if impl(ghc < 7.10) {-    default-extensions:-      OverlappingInstances-  }   ghc-options: {     -Wall     -fno-warn-unused-imports@@ -105,7 +104,7 @@     -- no version constraints necessary, because they are already     -- given by library     multistate,-    base <4.11,+    base <999,     transformers <0.6,     hspec >=2 && <2.5   ghc-options:      -Wall@@ -122,7 +121,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,185 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ConstraintKinds #-}++-- | 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.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 *] -> * 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 _ _ = HNilM++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 *]) (l2 :: [CanReadWrite *]) :: [CanReadWrite *] where+  AppendM '[] l2 = l2+  AppendM (car1 ': cdr2) l2 = car1 ': AppendM cdr2 l2++type family HListMReaders (l :: [*]) :: [CanReadWrite *] where+  HListMReaders '[] = '[]+  HListMReaders (t ': tr) = 'Gettable t ': HListMReaders tr++type family AppendMReaders (l1 :: [*]) (l2 :: [CanReadWrite *]) :: [CanReadWrite *] where+  AppendMReaders '[] l2 = l2+  AppendMReaders (t ': tr) l2 = 'Gettable t ': AppendMReaders tr l2++class HListMGettableClass ts where+  type HListMGettableOnly ts :: [*]+  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,259 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- | 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,240 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- | 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(..)@@ -140,36 +141,43 @@ 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)@@ -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(..)@@ -141,37 +142,44 @@ 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)@@ -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(..)@@ -126,6 +128,14 @@ #endif       => 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)
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(..)@@ -126,6 +128,14 @@ #endif       => 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)
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@@ -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)
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(..)@@ -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)
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,7 +22,8 @@  import Prelude hiding (reverse) -import Data.Monoid+import Data.Monoid (Monoid, mappend, mempty)+import Data.Semigroup  import Data.Proxy @@ -42,10 +43,16 @@ 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))       => Monoid (HList (x ': xs))   where