ether 0.5.0.0 → 0.5.1.0

raw patch · 14 files changed

+230/−317 lines, 14 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• ether.cabal +27/−3
• src/Ether/Except.hs +1/−15
• src/Ether/Internal.hs +6/−117
• src/Ether/Internal/HasLens.hs +24/−0
• src/Ether/Internal/TH_TupleInstances.hs +79/−0
• src/Ether/Internal/TH_Utils.hs +14/−0
• src/Ether/Internal/Tags.hs +18/−0
• src/Ether/Internal/TupleInstances.hs +24/−0
• src/Ether/Reader.hs +0/−28
• src/Ether/State.hs +0/−56
• src/Ether/TagDispatch.hs +0/−50
• src/Ether/TaggedTrans.hs +32/−8
• src/Ether/Writer.hs +0/−40

@@ -1,3 +1,8 @@+0.5.1.0+-------++* Disable `HasLens` for tuples via cabal flag.+ 0.5.0.0 ------- 

@@ -1,5 +1,5 @@ name:                ether-version:             0.5.0.0+version:             0.5.1.0 synopsis:            Monad transformers and classes description:     Ether is a Haskell library that extends @mtl@ and @transformers@ with@@ -24,6 +24,20 @@   location: git@github.com:int-index/ether.git  +flag disable-tup-instances++  description:+      Disable auto-generated 'HasLens' instances for tuples. The reason one+      might want to do this is to reduce the size of .hi-files, as well as the+      time and memory GHC needs to build Ether. To recover flattening with+      tuples, use 'Ether.Internal.makeTupleInstancesHasLens' at specific tuple+      sizes you need in your application.++      This is a build-time performance hack, enable this flag at your own risk.++  default: False+  manual: True+ library    exposed-modules:@@ -36,10 +50,17 @@     Ether.TagDispatch     Ether.Internal +  other-modules:+    Ether.Internal.Tags+    Ether.Internal.HasLens+    Ether.Internal.TH_Utils+    Ether.Internal.TH_TupleInstances+    Ether.Internal.TupleInstances+   build-depends:     base >=4.9 && <4.11,-    transformers >=0.5.4.0,-    transformers-lift >=0.2.0.0,+    transformers >=0.5.2.0,+    transformers-lift >=0.2.0.1,     mtl >=2.2.1,     mmorph >=1.0.4,     monad-control >=1.0.0.4,@@ -83,6 +104,9 @@    ghc-options:     -Wall -O2++  if flag(disable-tup-instances)+    cpp-options: -DDISABLE_TUP_INSTANCES  test-suite regression 

@@ -50,12 +50,8 @@          , Monad (t m)          , MonadExcept tag e m          ) => MonadExcept tag e (t m) where-     throw = Lift.lift . throw @tag-    {-# INLINE throw #-}-     catch = Lift.liftCatch (catch @tag)-    {-# INLINE catch #-}  -- | Encode type-level information for 'ExceptT'. data EXCEPT@@ -77,17 +73,14 @@ -- | Runs an 'Except' and returns either an exception or a normal value. runExcept :: forall tag e a . Except tag e a -> Either e a runExcept = coerce (T.runExcept @e @a)-{-# INLINE runExcept #-}  -- | Runs an 'ExceptT' and returns either an exception or a normal value. runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a) runExceptT = coerce (T.runExceptT @e @m @a)-{-# INLINE runExceptT #-}  -- | Constructor for computations in the exception monad transformer. exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a exceptT = coerce (T.ExceptT @e @m @a)-{-# INLINE exceptT #-}  type instance HandleSuper      EXCEPT e trans   = () type instance HandleConstraint EXCEPT e trans m =@@ -95,47 +88,40 @@  instance Handle EXCEPT e (T.ExceptT e) where   handling r = r-  {-# INLINE handling #-}  instance     ( Handle EXCEPT e trans     , Monad m, Monad (trans m)     ) => MonadExcept tag e (TaggedTrans (TAGGED EXCEPT tag) trans m)   where+     throw =       handling @EXCEPT @e @trans @m $       coerce (T.throwError @e @(trans m) @a) ::         forall eff a . e -> TaggedTrans eff trans m a-    {-# INLINE throw #-}      catch =       handling @EXCEPT @e @trans @m $       coerce (T.catchError @e @(trans m) @a) ::         forall eff a . Catch e (TaggedTrans eff trans m) a-    {-# INLINE catch #-}  type MonadExcept' e = MonadExcept e e  throw' :: forall e m a . MonadExcept' e m => e -> m a throw' = throw @e-{-# INLINE throw' #-}  catch' :: forall e m a . MonadExcept' e m => m a -> (e -> m a) -> m a catch' = catch @e-{-# INLINE catch' #-}  type Except' e = Except e e  runExcept' :: Except' e a -> Either e a runExcept' = runExcept-{-# INLINE runExcept' #-}  type ExceptT' e = ExceptT e e  exceptT' :: m (Either e a) -> ExceptT' e m a exceptT' = exceptT-{-# INLINE exceptT' #-}  runExceptT' :: ExceptT' e m a -> m (Either e a) runExceptT' = runExceptT-{-# INLINE runExceptT' #-}

@@ -16,19 +16,21 @@   , HandleSuper   , HandleConstraint   , Handle(..)+  , makeTupleInstancesHasLens   ) where  import Control.Applicative-import Control.Monad import Data.Coerce import Data.Functor.Identity import Data.Kind-import Data.List as List import Data.Tagged-import Data.Traversable import GHC.Exts (Constraint)-import qualified Language.Haskell.TH as TH +import Ether.Internal.HasLens+import Ether.Internal.Tags+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)+import Ether.Internal.TupleInstances ()+ data TAGGED e t  type K_Monad = Type -> Type@@ -55,125 +57,12 @@   where     handling :: Monad m => (HandleConstraint eff p trans m => r) -> r -type LensLike f s t a b = (a -> f b) -> s -> f t--type Lens s t a b = forall f. Functor f => LensLike f s t a b--type Lens' s a = Lens s s a a- newtype ReifiedLens s t a b = Lens (Lens s t a b)  type ReifiedLens' s a = ReifiedLens s s a a -class HasLens tag outer inner | tag outer -> inner where-  lensOf :: Lens' outer inner--instance HasLens a a a where-  lensOf = id-  {-# INLINE lensOf #-}- view :: LensLike (Const a) s t a b -> s -> a view l = coerce (l Const)-{-# INLINE view #-}  over :: LensLike Identity s t a b -> (a -> b) -> s -> t over = coerce-{-# INLINE over #-}--data HList xs where-  HNil :: HList '[]-  HCons :: x -> HList xs -> HList (x ': xs)--type KindOf (a :: k) = k--type family TagsK (p :: Type) :: [Type]-type family Tags  (p :: Type) :: HList (TagsK p)--return []--type instance TagsK () = '[]-type instance TagsK (Tagged t a) = '[KindOf t]-type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1]--return []--type instance Tags () = 'HNil-type instance Tags (Tagged t a) = 'HCons t 'HNil-type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)--do-  let-    tupCount = 62-    names    = [1..] >>= flip replicateM ['a'..'z']-  varNames <- traverse TH.newName (take tupCount names)-  fmap List.concat $-    for (List.drop 2 (List.inits varNames)) $-      \varNames' -> do-        let n = List.length varNames'-        tagsInstances <- for [() | n > 2] $ \() -> do-          tag <- TH.newName "tag"-          let-            (cur:rest) = varNames'-            tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))-              ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur :-                map TH.VarT rest )-            tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1)))-              (map TH.VarT rest)-          return $-            TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy]-              ( TH.PromotedConsT `TH.AppT` (TH.ConT ''KindOf `TH.AppT` TH.VarT tag) `TH.AppT`-                (TH.ConT ''TagsK `TH.AppT` tupTy') ))-        return tagsInstances-do-  let-    tupCount = 62-    names    = [1..] >>= flip replicateM ['a'..'z']-  varNames <- traverse TH.newName (take tupCount names)-  fmap List.concat $-    for (List.drop 2 (List.inits varNames)) $-      \varNames' -> do-        let n = List.length varNames'-        tagsInstances <- for [() | n > 2] $ \() -> do-          tag <- TH.newName "tag"-          let-            (cur:rest) = varNames'-            tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))-              ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur :-                map TH.VarT rest )-            tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1)))-              (map TH.VarT rest)-            tagsInst =-              TH.TySynInstD ''Tags (TH.TySynEqn [tupTy]-                ( TH.PromotedT 'HCons `TH.AppT` TH.VarT tag `TH.AppT`-                  (TH.ConT ''Tags `TH.AppT` tupTy') ))-          return tagsInst-        hasLensInstances <- for [0..n-1] $ \k -> do-          tag <- TH.newName "tag"-          let-            (prev, cur:next) = List.splitAt k varNames'-            tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))-              ( map TH.VarT prev ++-                [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++-                map TH.VarT next )-          cur' <- TH.newName "x"-          f <- TH.newName "f"-          return $-            TH.InstanceD Nothing []-              (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)-              [ TH.FunD 'lensOf-                  [ TH.Clause-                      [TH.VarP f, TH.TupP-                        ( map TH.VarP prev ++-                          [TH.ConP 'Tagged [TH.VarP cur]] ++-                          map TH.VarP next )]-                      (TH.NormalB $-                         TH.VarE 'fmap `TH.AppE`-                           (TH.LamE [TH.VarP cur']-                             (TH.TupE-                              ( map TH.VarE prev ++-                                [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++-                                map TH.VarE next ))) `TH.AppE`-                           (TH.VarE f `TH.AppE` TH.VarE cur) )-                      [] ],-                TH.PragmaD (TH.InlineP 'lensOf TH.Inline TH.FunLike TH.AllPhases) ]-        return $ tagsInstances ++ hasLensInstances

@@ -0,0 +1,24 @@+module Ether.Internal.HasLens+  ( LensLike+  , Lens+  , Lens'+  , HasLens(..)+  ) where++import Data.Tagged+import Data.Coerce++type LensLike f s t a b = (a -> f b) -> s -> f t++type Lens s t a b = forall f. Functor f => LensLike f s t a b++type Lens' s a = Lens s s a a++class HasLens tag outer inner | tag outer -> inner where+  lensOf :: Lens' outer inner++instance HasLens a a a where+  lensOf = id++instance HasLens t (Tagged t a) a where+  lensOf = \f -> fmap coerce . f . coerce

@@ -0,0 +1,79 @@+module Ether.Internal.TH_TupleInstances+  ( makeTupleInstancesTagsK+  , makeTupleInstancesTags+  , makeTupleInstancesHasLens+  ) where++import Data.Tagged+import Data.Traversable+import Data.List as List+import qualified Language.Haskell.TH as TH++import Ether.Internal.HasLens+import Ether.Internal.Tags+import Ether.Internal.TH_Utils++makeTupleInstancesTagsK :: TH.DecsQ+makeTupleInstancesTagsK = do+  for [2..tupCount] $ \n -> do+    let+      tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $+        (\k -> TH.ConT ''Tagged `TH.AppT`+          TH.VarT (tagName k) `TH.AppT`+          TH.VarT (varName k)) <$> [0..n-1]+      tagsList = List.foldr+        (\a b -> TH.PromotedConsT `TH.AppT` a `TH.AppT` b)+        TH.PromotedNilT+        (TH.AppT (TH.ConT ''KindOf) . TH.VarT . tagName <$> [0..n-1])+    return $+      TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] tagsList)++makeTupleInstancesTags :: TH.DecsQ+makeTupleInstancesTags = do+  for [2..tupCount] $ \n -> do+    let+      tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $+        (\k -> TH.ConT ''Tagged `TH.AppT`+          TH.VarT (tagName k) `TH.AppT`+          TH.VarT (varName k)) <$> [0..n-1]+      tagsList = List.foldr+        (\a b -> TH.PromotedT 'HCons `TH.AppT` a `TH.AppT` b)+        (TH.PromotedT 'HNil)+        (TH.VarT . tagName <$> [0..n-1])+    return $+      TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] tagsList)++makeTupleInstancesHasLens :: [Int] -> TH.DecsQ+makeTupleInstancesHasLens range = List.concat <$> do+  for range $ \n ->+    for [0..n-1] $ \k -> do+      let+        tag = TH.mkName "tag"+        prev = varName <$> [0..k-1]+        cur  = varName k+        next = varName <$> [k+1..n-1]+        tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))+          ( map TH.VarT prev +++            [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] +++            map TH.VarT next )+      let+        cur' = TH.mkName "x"+        f = TH.mkName "f"+      return $+        TH.InstanceD Nothing []+          (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)+          [ TH.FunD 'lensOf+              [ TH.Clause+                  [TH.VarP f, TH.TupP+                    ( map TH.VarP prev +++                      [TH.ConP 'Tagged [TH.VarP cur]] +++                      map TH.VarP next )]+                  (TH.NormalB $+                     TH.VarE 'fmap `TH.AppE`+                       (TH.LamE [TH.VarP cur']+                         (TH.TupE+                          ( map TH.VarE prev +++                            [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] +++                            map TH.VarE next ))) `TH.AppE`+                       (TH.VarE f `TH.AppE` TH.VarE cur) )+                  [] ] ]

@@ -0,0 +1,14 @@+module Ether.Internal.TH_Utils+  ( tupCount+  , varName+  , tagName+  ) where++import qualified Language.Haskell.TH as TH++tupCount :: Int+tupCount = 62++varName, tagName :: Int -> TH.Name+varName k = TH.mkName ('a' : show k)+tagName k = TH.mkName ('t' : show k)

@@ -0,0 +1,18 @@+module Ether.Internal.Tags+  ( Tags+  , TagsK+  , HList(..)+  , KindOf+  ) where++import Data.Kind++data HList xs where+  HNil :: HList '[]+  HCons :: x -> HList xs -> HList (x ': xs)++type KindOf (a :: k) = k++type family TagsK (p :: Type) :: [Type]+type family Tags  (p :: Type) :: HList (TagsK p)+

@@ -0,0 +1,24 @@+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}++module Ether.Internal.TupleInstances () where++import Data.Tagged+import Ether.Internal.Tags+import Ether.Internal.TH_TupleInstances++type instance TagsK () = '[]+type instance TagsK (Tagged t a) = '[KindOf t]+type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1]++makeTupleInstancesTagsK++type instance Tags () = 'HNil+type instance Tags (Tagged t a) = 'HCons t 'HNil+type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)++makeTupleInstancesTags++#ifndef DISABLE_TUP_INSTANCES+makeTupleInstancesHasLens [2..62]+#endif

@@ -77,15 +77,9 @@     , MonadReader tag r m     ) => MonadReader tag r (t m)   where-     ask = Lift.lift (ask @tag)-    {-# INLINE ask #-}-     local = Lift.liftLocal (ask @tag) (local @tag)-    {-# INLINE local #-}-     reader = Lift.lift . reader @tag-    {-# INLINE reader #-}  instance {-# OVERLAPPABLE #-}     ( Monad (trans m)@@ -98,21 +92,18 @@         TaggedTrans         effs  trans m r ->         TaggedTrans (eff ': effs) trans m r)       (ask @tag)-    {-# INLINE ask #-}      local =       (coerce :: forall a .         Lift.Local r (TaggedTrans         effs  trans m) a ->         Lift.Local r (TaggedTrans (eff ': effs) trans m) a)       (local @tag)-    {-# INLINE local #-}      reader =       (coerce :: forall a .         ((r -> a) -> TaggedTrans         effs  trans m a) ->         ((r -> a) -> TaggedTrans (eff ': effs) trans m a))       (reader @tag)-    {-# INLINE reader #-}  -- | Retrieves a function of the current environment. asks@@ -122,7 +113,6 @@   -- ^ The selector function to apply to the environment.   -> m a asks = reader @tag-{-# INLINE asks #-}  -- | Encode type-level information for 'ReaderT'. data READER@@ -145,19 +135,16 @@ -- | Constructor for computations in the reader monad transformer. readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a readerT = coerce (T.ReaderT @r @m @a)-{-# INLINE readerT #-}  -- | Runs a 'ReaderT' with the given environment -- and returns the final value. runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a runReaderT = coerce (T.runReaderT @r @_ @m @a)-{-# INLINE runReaderT #-}  -- | Runs a 'ReaderT' with the given environment -- and returns the final value. runReader :: forall tag r a . Reader tag r a -> r -> a runReader = coerce (T.runReader @r @a)-{-# INLINE runReader #-}  type instance HandleSuper      READER r trans   = () type instance HandleConstraint READER r trans m =@@ -165,7 +152,6 @@  instance Handle READER r (T.ReaderT r) where   handling r = r-  {-# INLINE handling #-}  instance     ( Handle READER r trans@@ -176,19 +162,16 @@     ask =       handling @READER @r @trans @m $       coerce (T.ask @r @(trans m))-    {-# INLINE ask #-}      local =       handling @READER @r @trans @m $       coerce (T.local @r @(trans m) @a) ::         forall eff a . Local r (TaggedTrans eff trans m) a-    {-# INLINE local #-}      reader =       handling @READER @r @trans @m $       coerce (T.reader @r @(trans m) @a) ::         forall eff a . (r -> a) -> TaggedTrans eff trans m a-    {-# INLINE reader #-}  instance     ( HasLens tag payload r@@ -203,7 +186,6 @@                     trans m a ->         TaggedTrans eff trans m a)       (T.asks (view (lensOf @tag @payload @r)))-    {-# INLINE ask #-}      local f =       handling @READER @payload @trans @m $@@ -211,7 +193,6 @@                     (trans m a ->            trans m a) ->         (TaggedTrans eff trans m a -> TaggedTrans eff trans m a))       (T.local (over (lensOf @tag @payload @r) f))-    {-# INLINE local #-}  type family READERS (ts :: HList xs) :: [Type] where   READERS 'HNil = '[]@@ -223,42 +204,33 @@  runReadersT :: forall p m a . ReadersT p m a -> p -> m a runReadersT = coerce (T.runReaderT @p @_ @m @a)-{-# INLINE runReadersT #-}  runReaders :: forall p a . Readers p a -> p -> a runReaders = coerce (T.runReader @p @a)-{-# INLINE runReaders #-}  type ReaderT' r = ReaderT r r  readerT' :: (r -> m a) -> ReaderT' r m a readerT' = readerT-{-# INLINE readerT' #-}  runReaderT' :: ReaderT' r m a -> r -> m a runReaderT' = runReaderT-{-# INLINE runReaderT' #-}  type Reader' r = Reader r r  runReader' :: Reader' r a -> r -> a runReader' = runReader-{-# INLINE runReader' #-}  type MonadReader' r = MonadReader r r  local' :: forall r m a . MonadReader' r m => (r -> r) -> m a -> m a local' = local @r-{-# INLINE local' #-}  ask' :: forall r m . MonadReader' r m => m r ask' = ask @r-{-# INLINE ask' #-}  reader' :: forall r m a . MonadReader' r m => (r -> a) -> m a reader' = reader @r-{-# INLINE reader' #-}  asks' :: forall r m a . MonadReader' r m => (r -> a) -> m a asks' = asks @r-{-# INLINE asks' #-}

@@ -114,15 +114,9 @@     , MonadState tag s m     ) => MonadState tag s (t m)   where-     get = Lift.lift (get @tag)-    {-# INLINE get #-}-     put = Lift.lift . put @tag-    {-# INLINE put #-}-     state = Lift.lift . state @tag-    {-# INLINE state #-}  instance {-# OVERLAPPABLE #-}     ( Monad (trans m)@@ -135,31 +129,26 @@         TaggedTrans         effs  trans m s ->         TaggedTrans (eff ': effs) trans m s)       (get @tag)-    {-# INLINE get #-}      put =       (coerce ::         (s -> TaggedTrans         effs  trans m ()) ->         (s -> TaggedTrans (eff ': effs) trans m ()))       (put @tag)-    {-# INLINE put #-}      state =       (coerce :: forall a .         ((s -> (a, s)) -> TaggedTrans         effs  trans m a) ->         ((s -> (a, s)) -> TaggedTrans (eff ': effs) trans m a))       (state @tag)-    {-# INLINE state #-}  -- | Modifies the state inside a state monad. modify :: forall tag s m . MonadState tag s m => (s -> s) -> m () modify f = state @tag (\s -> ((), f s))-{-# INLINABLE modify #-}  -- | Gets specific component of the state, using a projection function supplied. gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a gets f = fmap f (get @tag)-{-# INLINABLE gets #-}  -- | Encode type-level information for 'StateT'. data STATE@@ -170,11 +159,9 @@  instance Handle STATE s (T.Strict.StateT s) where   handling r = r-  {-# INLINE handling #-}  instance Handle STATE s (T.Lazy.StateT s) where   handling r = r-  {-# INLINE handling #-}  instance     ( Handle STATE s trans@@ -185,18 +172,15 @@     get =       handling @STATE @s @trans @m $       coerce (T.get @s @(trans m))-    {-# INLINE get #-}      put =       handling @STATE @s @trans @m $       coerce (T.put @s @(trans m))-    {-# INLINE put #-}      state =       handling @STATE @s @trans @m $       coerce (T.state @s @(trans m) @a) ::         forall eff a . (s -> (a, s)) -> TaggedTrans eff trans m a-    {-# INLINE state #-}  instance     ( HasLens tag payload s@@ -211,7 +195,6 @@                     trans m a ->         TaggedTrans eff trans m a)       (T.gets (view (lensOf @tag @payload @s)))-    {-# INLINE get #-}      put s =       handling @STATE @payload @trans @m $@@ -219,7 +202,6 @@                     trans m a ->         TaggedTrans eff trans m a)       (T.modify (over (lensOf @tag @payload @s) (const s)))-    {-# INLINE put #-}      state f =       handling @STATE @payload @trans @m $@@ -227,7 +209,6 @@                     trans m a ->         TaggedTrans eff trans m a)       (T.state (lensOf @tag @payload @s f))-    {-# INLINE state #-}  -- | The parametrizable state monad. --@@ -246,43 +227,36 @@ -- | Constructor for computations in the state monad transformer. stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a stateT = coerce (T.Strict.StateT @s @m @a)-{-# INLINE stateT #-}  -- | Runs a 'StateT' with the given initial state -- and returns both the final value and the final state. runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s) runStateT = coerce (T.Strict.runStateT @s @m @a)-{-# INLINE runStateT #-}  -- | Runs a 'StateT' with the given initial state -- and returns the final value, discarding the final state. evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a evalStateT = coerce (T.Strict.evalStateT @m @s @a)-{-# INLINE evalStateT #-}  -- | Runs a 'StateT' with the given initial state -- and returns the final state, discarding the final value. execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s execStateT = coerce (T.Strict.execStateT @m @s @a)-{-# INLINE execStateT #-}  -- | Runs a 'State' with the given initial state -- and returns both the final value and the final state. runState :: forall tag s a . State tag s a -> s -> (a, s) runState = coerce (T.Strict.runState @s @a)-{-# INLINE runState #-}  -- | Runs a 'State' with the given initial state -- and returns the final value, discarding the final state. evalState :: forall tag s a . State tag s a -> s -> a evalState = coerce (T.Strict.evalState @s @a)-{-# INLINE evalState #-}  -- | Runs a 'State' with the given initial state -- and returns the final state, discarding the final value. execState :: forall tag s a . State tag s a -> s -> s execState = coerce (T.Strict.execState @s @a)-{-# INLINE execState #-}  -- | The parametrizable state monad. --@@ -301,43 +275,36 @@ -- | Constructor for computations in the state monad transformer. lazyStateT :: forall tag s m a . (s -> m (a, s)) -> LazyStateT tag s m a lazyStateT = coerce (T.Lazy.StateT @s @m @a)-{-# INLINE lazyStateT #-}  -- | Runs a 'StateT' with the given initial state -- and returns both the final value and the final state. runLazyStateT :: forall tag s m a . LazyStateT tag s m a -> s -> m (a, s) runLazyStateT = coerce (T.Lazy.runStateT @s @m @a)-{-# INLINE runLazyStateT #-}  -- | Runs a 'StateT' with the given initial state -- and returns the final value, discarding the final state. evalLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m a evalLazyStateT = coerce (T.Lazy.evalStateT @m @s @a)-{-# INLINE evalLazyStateT #-}  -- | Runs a 'StateT' with the given initial state -- and returns the final state, discarding the final value. execLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m s execLazyStateT = coerce (T.Lazy.execStateT @m @s @a)-{-# INLINE execLazyStateT #-}  -- | Runs a 'State' with the given initial state -- and returns both the final value and the final state. runLazyState :: forall tag s a . LazyState tag s a -> s -> (a, s) runLazyState = coerce (T.Lazy.runState @s @a)-{-# INLINE runLazyState #-}  -- | Runs a 'State' with the given initial state -- and returns the final value, discarding the final state. evalLazyState :: forall tag s a . LazyState tag s a -> s -> a evalLazyState = coerce (T.Lazy.evalState @s @a)-{-# INLINE evalLazyState #-}  -- | Runs a 'State' with the given initial state -- and returns the final state, discarding the final value. execLazyState :: forall tag s a . LazyState tag s a -> s -> s execLazyState = coerce (T.Lazy.execState @s @a)-{-# INLINE execLazyState #-}  type family STATES (ts :: HList xs) :: [Type] where   STATES 'HNil = '[]@@ -349,97 +316,76 @@  runStatesT :: forall p m a . StatesT p m a -> p -> m (a, p) runStatesT = coerce (T.Strict.runStateT @p @m @a)-{-# INLINE runStatesT #-}  runStates :: forall p a . States p a -> p -> (a, p) runStates = coerce (T.Strict.runState @p @a)-{-# INLINE runStates #-}  type StateT' s = StateT s s  stateT' :: (s -> m (a, s)) -> StateT' s m a stateT' = stateT-{-# INLINE stateT' #-}  runStateT' :: StateT' s m a -> s -> m (a, s) runStateT' = runStateT-{-# INLINE runStateT' #-}  runState' :: State' s a -> s -> (a, s) runState' = runState-{-# INLINE runState' #-}  evalStateT' :: Monad m => StateT' s m a -> s -> m a evalStateT' = evalStateT-{-# INLINE evalStateT' #-}  type State' s = State s s  evalState' :: State' s a -> s -> a evalState' = evalState-{-# INLINE evalState' #-}  execStateT' :: Monad m => StateT' s m a -> s -> m s execStateT' = execStateT-{-# INLINE execStateT' #-}  execState' :: State' s a -> s -> s execState' = execState-{-# INLINE execState' #-}  type LazyStateT' s = LazyStateT s s  lazyStateT' :: (s -> m (a, s)) -> LazyStateT' s m a lazyStateT' = lazyStateT-{-# INLINE lazyStateT' #-}  runLazyStateT' :: LazyStateT' s m a -> s -> m (a, s) runLazyStateT' = runLazyStateT-{-# INLINE runLazyStateT' #-}  runLazyState' :: LazyState' s a -> s -> (a, s) runLazyState' = runLazyState-{-# INLINE runLazyState' #-}  evalLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m a evalLazyStateT' = evalLazyStateT-{-# INLINE evalLazyStateT' #-}  type LazyState' s = LazyState s s  evalLazyState' :: LazyState' s a -> s -> a evalLazyState' = evalLazyState-{-# INLINE evalLazyState' #-}  execLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m s execLazyStateT' = execLazyStateT-{-# INLINE execLazyStateT' #-}  execLazyState' :: LazyState' s a -> s -> s execLazyState' = execLazyState-{-# INLINE execLazyState' #-}  type MonadState' s = MonadState s s  get' :: forall s m . MonadState' s m => m s get' = get @s-{-# INLINE get' #-}  gets' :: forall s m a . MonadState' s m => (s -> a) -> m a gets' = gets @s-{-# INLINE gets' #-}  put' :: forall s m . MonadState' s m => s -> m () put' = put @s-{-# INLINE put' #-}  state' :: forall s m a . MonadState' s m => (s -> (a, s)) -> m a state' = state @s-{-# INLINE state' #-}  modify' :: forall s m . MonadState' s m => (s -> s) -> m () modify' = modify @s-{-# INLINE modify' #-}  -- | Encode type-level information for 'zoom'. data ZOOM t z@@ -453,7 +399,6 @@   -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => ZoomT tag z m a)   -> m a zoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z))-{-# INLINE zoom #-}  instance     ( MonadState tag sOuter m@@ -468,4 +413,3 @@       (state @tag . l)       where         Lens l = reflect (Proxy :: Proxy z)-    {-# INLINE state #-}

@@ -63,63 +63,38 @@ -- | Attach a tag to untagged transformers. tagAttach :: forall tag m a . TagAttachT tag m a -> m a tagAttach = coerce (runIdentityT @_ @m @a)-{-# INLINE tagAttach #-}  instance {-# OVERLAPPING #-}     ( MonadReader tag r m, trans ~ IdentityT     ) => Mtl.MonadReader r (TaggedTrans (TAG_ATTACH tag) trans m)   where-     ask = ask @tag-    {-# INLINE ask #-}-     local = local @tag-    {-# INLINE local #-}-     reader = reader @tag-    {-# INLINE reader #-}  instance {-# OVERLAPPING #-}     ( MonadState tag s m, trans ~ IdentityT     ) => Mtl.MonadState s (TaggedTrans (TAG_ATTACH tag) trans m)   where-     get = get @tag-    {-# INLINE get #-}-     put = put @tag-    {-# INLINE put #-}-     state = state @tag-    {-# INLINE state #-}  instance {-# OVERLAPPING #-}     ( MonadExcept tag e m, trans ~ IdentityT     ) => Mtl.MonadError e (TaggedTrans (TAG_ATTACH tag) trans m)   where-     throwError = throw @tag-    {-# INLINE throwError #-}-     catchError = catch @tag-    {-# INLINE catchError #-}  instance {-# OVERLAPPING #-}     ( MonadWriter tag w m, trans ~ IdentityT     ) => Mtl.MonadWriter w (TaggedTrans (TAG_ATTACH tag) trans m)   where-     writer = writer @tag-    {-# INLINE writer #-}-     tell = tell @tag-    {-# INLINE tell #-}-     listen = listen @tag-    {-# INLINE listen #-}-     pass = pass @tag-    {-# INLINE pass #-}  -- | Encode type-level information for 'tagReplace'. data TAG_REPLACE tOld tNew@@ -129,60 +104,35 @@ -- | Replace a tag with another tag. tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a tagReplace = coerce (runIdentityT @_ @m @a)-{-# INLINE tagReplace #-}  instance     ( MonadReader tNew r m, trans ~ IdentityT     ) => MonadReader tOld r (TaggedTrans (TAG_REPLACE tOld tNew) trans m)   where-     ask = ask @tNew-    {-# INLINE ask #-}-     local = local @tNew-    {-# INLINE local #-}-     reader = reader @tNew-    {-# INLINE reader #-}  instance     ( MonadState tNew s m, trans ~ IdentityT     ) => MonadState tOld s (TaggedTrans (TAG_REPLACE tOld tNew) trans m)   where-     get = get @tNew-    {-# INLINE get #-}-     put = put @tNew-    {-# INLINE put #-}-     state = state @tNew-    {-# INLINE state #-}  instance     ( MonadExcept tNew e m, trans ~ IdentityT     ) => MonadExcept tOld e (TaggedTrans (TAG_REPLACE tOld tNew) trans m)   where-     throw = throw @tNew-    {-# INLINE throw #-}-     catch = catch @tNew-    {-# INLINE catch #-}  instance     ( MonadWriter tNew w m, trans ~ IdentityT     ) => MonadWriter tOld w (TaggedTrans (TAG_REPLACE tOld tNew) trans m)   where-     writer = writer @tNew-    {-# INLINE writer #-}-     tell = tell @tNew-    {-# INLINE tell #-}-     listen = listen @tNew-    {-# INLINE listen #-}-     pass = pass @tNew-    {-# INLINE pass #-}

@@ -1,3 +1,7 @@+-- The use of ImpredicativeTypes here is safe, see discussion under GitHub issue+-- #35. It's only needed to allow the visible type application of a polytype.+{-# LANGUAGE ImpredicativeTypes #-}+ module Ether.TaggedTrans   ( TaggedTrans(..)   ) where@@ -7,7 +11,7 @@ import Control.Monad.Fix (MonadFix) import Control.Monad.Trans.Class (MonadTrans, lift) import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Morph (MFunctor, MMonad)+import Control.Monad.Morph (MFunctor(..), MMonad(..)) import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)  import qualified Control.Monad.Base as MB@@ -33,7 +37,7 @@   deriving     ( Generic     , Functor, Applicative, Alternative, Monad, MonadPlus-    , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad+    , MonadFix, MonadTrans, MonadIO     , MonadThrow, MonadCatch, MonadMask )  type Pack tag trans m a = trans m a -> TaggedTrans tag trans m a@@ -49,7 +53,6 @@         (b a -> trans m a) ->         (b a -> TaggedTrans tag trans m a))       MB.liftBase-    {-# INLINE liftBase #-}  instance     ( MC.MonadTransControl trans@@ -60,11 +63,9 @@     liftWith = MC.defaultLiftWith       (coerce :: Pack tag trans m a)       (coerce :: Unpack tag trans m a)-    {-# INLINE liftWith #-}      restoreT = MC.defaultRestoreT       (coerce :: Pack tag trans m a)-    {-# INLINE restoreT #-}  type LiftBaseWith b m a = (MC.RunInBase m b -> b a) -> m a @@ -75,7 +76,6 @@   LiftBaseWith b (TaggedTrans tag trans m) a coerceLiftBaseWith lbw =   unLBW (coerce (LBW lbw))-{-# INLINE coerceLiftBaseWith #-}  instance     ( MC.MonadBaseControl b (trans m)@@ -84,14 +84,12 @@     type StM (TaggedTrans tag trans m) a = MC.StM (trans m) a      liftBaseWith = coerceLiftBaseWith MC.liftBaseWith-    {-# INLINE liftBaseWith #-}      restoreM =       (coerce :: forall a .         (MC.StM (trans m) a ->                 trans m a) ->         (MC.StM (trans m) a -> TaggedTrans tag trans m a))       MC.restoreM-    {-# INLINE restoreM #-}  type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a @@ -180,3 +178,29 @@   where     throwError = lift . Mtl.throwError     catchError = Lift.liftCatch Mtl.catchError++type Hoist trans =+  forall m n b . Monad m =>+    (forall a . m a -> n a) -> trans m b -> trans n b++-- NB: Don't use GeneralizedNewtypeDeriving to create this instance, as it will+-- trigger GHC Trac #11837 on GHC 8.0.1 and older.+instance MFunctor trans => MFunctor (TaggedTrans tag trans) where+  hoist =+    coerce+      @(Hoist trans)+      @(Hoist (TaggedTrans tag trans))+      hoist++type Embed trans =+  forall n m b . Monad n =>+    (forall a . m a -> trans n a) -> trans m b -> trans n b++-- NB: Don't use GeneralizedNewtypeDeriving to create this instance, as it will+-- trigger GHC Trac #11837 on GHC 8.0.1 and older.+instance MMonad trans => MMonad (TaggedTrans tag trans) where+  embed =+    coerce+      @(Embed                  trans)+      @(Embed (TaggedTrans tag trans))+      embed

@@ -96,18 +96,10 @@          , MonadWriter tag w m          , Monoid w          ) => MonadWriter tag w (t m) where-     writer = Lift.lift . writer @tag-    {-# INLINE writer #-}-     tell   = Lift.lift . tell @tag-    {-# INLINE tell #-}-     listen = Lift.liftListen (listen @tag)-    {-# INLINE listen #-}-     pass   = Lift.liftPass (pass @tag)-    {-# INLINE pass #-}  -- | Execute an action and add the result of applying the given function to -- its accumulator to the value of the computation.@@ -131,11 +123,9 @@  instance Monoid w => Handle WRITER w (T.CPS.WriterT w) where   handling r = r-  {-# INLINE handling #-}  instance Monoid w => Handle WRITER w (T.Lazy.WriterT w) where   handling r = r-  {-# INLINE handling #-}  instance     ( Handle WRITER w trans@@ -147,24 +137,20 @@       handling @WRITER @w @trans @m $       coerce (T.writer @w @(trans m) @a) ::         forall eff a . (a, w) -> TaggedTrans eff trans m a-    {-# INLINE writer #-}      tell =       handling @WRITER @w @trans @m $       coerce (T.tell @w @(trans m))-    {-# INLINE tell #-}      listen =       handling @WRITER @w @trans @m $       coerce (T.listen @w @(trans m) @a) ::         forall eff a . Listen w (TaggedTrans eff trans m) a-    {-# INLINE listen #-}      pass =       handling @WRITER @w @trans @m $       coerce (T.pass @w @(trans m) @a) ::         forall eff a . Pass w (TaggedTrans eff trans m) a-    {-# INLINE pass #-}  -- | The parametrizable writer monad. --@@ -183,31 +169,26 @@ -- | Constructor for computations in the writer monad transformer. writerT :: forall tag w m a . (Functor m, Monoid w) => m (a, w) -> WriterT tag w m a writerT = coerce (T.CPS.writerT @m @w @a)-{-# INLINE writerT #-}  -- | Runs a 'WriterT' and returns both the normal value -- and the final accumulator. runWriterT :: forall tag w m a . Monoid w => WriterT tag w m a -> m (a, w) runWriterT = coerce (T.CPS.runWriterT @w @m @a)-{-# INLINE runWriterT #-}  -- | Runs a 'Writer' and returns both the normal value -- and the final accumulator. runWriter :: forall tag w a . Monoid w => Writer tag w a -> (a, w) runWriter = coerce (T.CPS.runWriter @w @a)-{-# INLINE runWriter #-}  -- | Runs a 'WriterT' and returns the final accumulator, -- discarding the normal value. execWriterT :: forall tag w m a . (Monad m, Monoid w) => WriterT tag w m a -> m w execWriterT = coerce (T.CPS.execWriterT @m @w @a)-{-# INLINE execWriterT #-}  -- | Runs a 'Writer' and returns the final accumulator, -- discarding the normal value. execWriter :: forall tag w a . Monoid w => Writer tag w a -> w execWriter = coerce (T.CPS.execWriter @w @a)-{-# INLINE execWriter #-}  -- | The parametrizable writer monad. --@@ -226,102 +207,81 @@ -- | Constructor for computations in the writer monad transformer. lazyWriterT :: forall tag w m a . m (a, w) -> LazyWriterT tag w m a lazyWriterT = coerce (T.Lazy.WriterT @w @m @a)-{-# INLINE lazyWriterT #-}  -- | Runs a 'WriterT' and returns both the normal value -- and the final accumulator. runLazyWriterT :: forall tag w m a . LazyWriterT tag w m a -> m (a, w) runLazyWriterT = coerce (T.Lazy.runWriterT @w @m @a)-{-# INLINE runLazyWriterT #-}  -- | Runs a 'Writer' and returns both the normal value -- and the final accumulator. runLazyWriter :: forall tag w a . LazyWriter tag w a -> (a, w) runLazyWriter = coerce (T.Lazy.runWriter @w @a)-{-# INLINE runLazyWriter #-}  -- | Runs a 'WriterT' and returns the final accumulator, -- discarding the normal value. execLazyWriterT :: forall tag w m a . Monad m => LazyWriterT tag w m a -> m w execLazyWriterT = coerce (T.Lazy.execWriterT @m @w @a)-{-# INLINE execLazyWriterT #-}  -- | Runs a 'Writer' and returns the final accumulator, -- discarding the normal value. execLazyWriter :: forall tag w a . LazyWriter tag w a -> w execLazyWriter = coerce (T.Lazy.execWriter @w @a)-{-# INLINE execLazyWriter #-}  type Writer' w = Writer w w  runWriter' :: Monoid w => Writer' w a -> (a, w) runWriter' = runWriter-{-# INLINE runWriter' #-}  execWriter' :: Monoid w => Writer' w a -> w execWriter' = execWriter-{-# INLINE execWriter' #-}  type WriterT' w = WriterT w w  writerT' :: (Functor m, Monoid w) => m (a, w) -> WriterT' w m a writerT' = writerT-{-# INLINE writerT' #-}  runWriterT' :: Monoid w => WriterT' w m a -> m (a, w) runWriterT' = runWriterT-{-# INLINE runWriterT' #-}  execWriterT' :: (Monad m, Monoid w) => WriterT' w m a -> m w execWriterT' = execWriterT-{-# INLINE execWriterT' #-}  type LazyWriter' w = LazyWriter w w  runLazyWriter' :: LazyWriter' w a -> (a, w) runLazyWriter' = runLazyWriter-{-# INLINE runLazyWriter' #-}  execLazyWriter' :: LazyWriter' w a -> w execLazyWriter' = execLazyWriter-{-# INLINE execLazyWriter' #-}  type LazyWriterT' w = LazyWriterT w w  lazyWriterT' :: m (a, w) -> LazyWriterT' w m a lazyWriterT' = lazyWriterT-{-# INLINE lazyWriterT' #-}  runLazyWriterT' :: LazyWriterT' w m a -> m (a, w) runLazyWriterT' = runLazyWriterT-{-# INLINE runLazyWriterT' #-}  execLazyWriterT' :: Monad m => LazyWriterT' w m a -> m w execLazyWriterT' = execLazyWriterT-{-# INLINE execLazyWriterT' #-}  type MonadWriter' w = MonadWriter w w  writer' :: forall w m a . MonadWriter' w m => (a, w) -> m a writer' = writer @w-{-# INLINE writer' #-}  tell' :: forall w m . MonadWriter' w m => w -> m () tell' = tell @w-{-# INLINE tell' #-}  listen' :: forall w m a . MonadWriter' w m => m a -> m (a, w) listen' = listen @w-{-# INLINE listen' #-}  pass' :: forall w m a . MonadWriter' w m => m (a, w -> w) -> m a pass' = pass @w-{-# INLINE pass' #-}  listens' :: forall w m a b . MonadWriter' w m => (w -> b) -> m a -> m (a, b) listens' = listens @w-{-# INLINE listens' #-}  censor' :: forall w m a . MonadWriter' w m => (w -> w) -> m a -> m a censor' = censor @w-{-# INLINE censor' #-}