├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── bench ├── Bench.hs └── TupleInstances.hs ├── ether.cabal ├── shell.nix ├── src ├── Ether.hs └── Ether │ ├── Except.hs │ ├── Internal.hs │ ├── Internal │ ├── HasLens.hs │ ├── TH_TupleInstances.hs │ ├── TH_Utils.hs │ ├── Tags.hs │ └── TupleInstances.hs │ ├── Reader.hs │ ├── State.hs │ ├── TagDispatch.hs │ ├── TaggedTrans.hs │ └── Writer.hs └── test ├── Regression.hs ├── Regression ├── T1.hs ├── T10.hs ├── T11.hs ├── T12.hs ├── T2.hs ├── T3.hs ├── T4.hs ├── T5.hs ├── T6.hs ├── T7.hs ├── T8.hs └── T9.hs └── TupleInstances.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # Cabal 2 | dist 3 | dist-newstyle 4 | .cabal-sandbox/ 5 | cabal.sandbox.config 6 | cabal.project.local 7 | .ghc.environment* 8 | 9 | # Profiling 10 | *.prof 11 | 12 | # Stack 13 | .stack-work 14 | 15 | # Emacs 16 | TAGS 17 | .dir-locals.el 18 | 19 | # Vim 20 | tags 21 | *.swp 22 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: nix 2 | 3 | os: 4 | - linux 5 | - osx 6 | 7 | env: 8 | - HC=ghc822 9 | - HC=ghc844 10 | - HC=ghc861 11 | 12 | before_install: 13 | - curl https://raw.githubusercontent.com/monadfix/nix-cabal/master/nix-cabal -o nix-cabal && chmod u+x nix-cabal 14 | - travis_retry ./nix-cabal new-update 15 | 16 | script: 17 | - ./nix-cabal new-test ether:regression 18 | - ./nix-cabal new-bench ether:bench 19 | 20 | cache: 21 | directories: 22 | - ~/.cabal 23 | - ~/.ghc 24 | 25 | matrix: 26 | # broken at the moment 27 | exclude: 28 | - os: osx 29 | env: HC=ghc822 30 | - os: osx 31 | env: HC=ghc861 32 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 0.5.1.0 2 | ------- 3 | 4 | * Disable `HasLens` for tuples via cabal flag. 5 | 6 | 0.5.0.0 7 | ------- 8 | 9 | * Support only GHC 8.0 and higher. 10 | * Use the `TypeApplications` extension to get rid of `Proxy`. 11 | * Remove `Control.Ether.TH`. 12 | * Remove `Control.Ether.Abbr`. 13 | * Unify `Dispatch` and `TaggedTrans`. 14 | * Better `MonadBase` and `MonadBaseControl` instances. 15 | * Add flattening for `ReaderT` and `StateT`. 16 | * Add zooming for `MonadState`. 17 | * Simpler module structure. 18 | 19 | 0.4.1.0 20 | ------- 21 | 22 | * Export DispatchT newtype constructor. 23 | 24 | 0.4.0.0 25 | ------- 26 | 27 | * Poly-kinded tags. 28 | * Remove `Control.Ether.Tagged`. 29 | * Replace `Control.Ether.Wrapped` with `Control.Monad.Trans.Ether.Dispatch`. 30 | * Unified tagged transformer type in `Control.Monad.Trans.Ether.Tagged`. 31 | * `MonadThrow`, `MonadCatch`, `MonadMask` instances. 32 | * Drop `newtype-generics`. 33 | * Instance search is now more strict. 34 | 35 | 36 | 0.3.1.1 37 | ------- 38 | 39 | * Fix GHC 7.8 test issue. 40 | * Remove unused imports. 41 | 42 | 43 | 0.3.1.0 44 | ------- 45 | 46 | * Fix an issue with overlapping instances. 47 | 48 | 49 | 0.3.0.0 50 | ------- 51 | 52 | * `MonadBase`, `MonadTransControl`, `MonadBaseControl` instances. 53 | * `MFunctor`, `MMonad` instances. 54 | * Use `transformers-lift`. 55 | 56 | 57 | 0.2.1.0 58 | ------- 59 | 60 | * Constraint abbreviations: `Control.Ether.Abbr` and `Control.Ether.Implicit.Abbr`. 61 | 62 | 63 | 0.2.0.0 64 | ------- 65 | 66 | * Convenience modules `Control.Monad.Ether` and `Control.Monad.Ether.Implicit`. 67 | * Remove `fmapN` and `deepN`. 68 | * Remove `Control.Monad.Ether.Implicit.Except.TH`. 69 | * Add `handle` and `handleT`. 70 | 71 | 72 | 0.1.0.1 73 | ------- 74 | 75 | * Fix `transformers` lower bound. 76 | * Remove unused language extensions. 77 | * GHC 7.8 compatibility. 78 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Vladislav Zavialov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Vladislav Zavialov nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Ether 2 | 3 | [![Build Status](https://img.shields.io/travis/int-index/ether.svg)](https://travis-ci.org/int-index/ether) 4 | [![Hackage](https://img.shields.io/hackage/v/ether.svg)](https://hackage.haskell.org/package/ether) 5 | 6 | 7 | Ether is a Haskell library that extends [mtl](https://hackage.haskell.org/package/mtl) 8 | and [transformers](https://hackage.haskell.org/package/transformers) with tagged 9 | monad transformers and classes in a compatible way. 10 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/Bench.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fno-warn-partial-type-signatures #-} 2 | 3 | module Main (main) where 4 | 5 | import Control.DeepSeq 6 | import qualified Control.Lens as L 7 | import qualified Control.Monad.Reader as M 8 | import qualified Control.Monad.State as M 9 | import Criterion.Main 10 | import Ether 11 | import TupleInstances () 12 | 13 | id' :: a -> a 14 | id' = id 15 | {-# NOINLINE id' #-} 16 | 17 | readerCombinerMTL_flat_9 18 | :: M.MonadReader (Int, Int, Int, Int, Int, Int, Int, Int, Int) m 19 | => m () 20 | readerCombinerMTL_flat_9 = do 21 | rnf <$> sequenceA 22 | [ L.view L._1 23 | , L.view L._2 24 | , L.view L._3 25 | , L.view L._4 26 | , L.view L._5 27 | , L.view L._6 28 | , L.view L._7 29 | , L.view L._8 30 | , L.view L._9 ] 31 | {-# NOINLINE readerCombinerMTL_flat_9 #-} 32 | 33 | stateCombinerMTL_flat_9 34 | :: M.MonadState (Int, Int, Int, Int, Int, Int, Int, Int, Int) m 35 | => m () 36 | stateCombinerMTL_flat_9 = do 37 | M.modify (L.over L._1 id') 38 | M.modify (L.over L._2 id') 39 | M.modify (L.over L._3 id') 40 | M.modify (L.over L._4 id') 41 | M.modify (L.over L._5 id') 42 | M.modify (L.over L._6 id') 43 | M.modify (L.over L._7 id') 44 | M.modify (L.over L._8 id') 45 | M.modify (L.over L._9 id') 46 | rnf <$> sequenceA 47 | [ L.use L._1 48 | , L.use L._2 49 | , L.use L._3 50 | , L.use L._4 51 | , L.use L._5 52 | , L.use L._6 53 | , L.use L._7 54 | , L.use L._8 55 | , L.use L._9 ] 56 | {-# NOINLINE stateCombinerMTL_flat_9 #-} 57 | 58 | run_readerCombinerMTL_flat_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> () 59 | run_readerCombinerMTL_flat_9 60 | (a1, a2, a3, a4, a5, a6, a7, a8, a9) = 61 | M.runReader readerCombinerMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1) 62 | 63 | run_stateCombinerMTL_flat_9 :: 64 | (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> 65 | ((), (Int, Int, Int, Int, Int, Int, Int, Int, Int)) 66 | run_stateCombinerMTL_flat_9 67 | (a1, a2, a3, a4, a5, a6, a7, a8, a9) = 68 | M.runState stateCombinerMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1) 69 | 70 | readerCombinerEther_sep_9 71 | :: ( MonadReader 1 Int m 72 | , MonadReader 2 Int m 73 | , MonadReader 3 Int m 74 | , MonadReader 4 Int m 75 | , MonadReader 5 Int m 76 | , MonadReader 6 Int m 77 | , MonadReader 7 Int m 78 | , MonadReader 8 Int m 79 | , MonadReader 9 Int m ) 80 | => m () 81 | readerCombinerEther_sep_9 = rnf <$> sequenceA 82 | [ ask @1 83 | , ask @2 84 | , ask @3 85 | , ask @4 86 | , ask @5 87 | , ask @6 88 | , ask @7 89 | , ask @8 90 | , ask @9 ] 91 | {-# NOINLINE readerCombinerEther_sep_9 #-} 92 | 93 | stateCombinerEther_sep_9 94 | :: ( MonadState 1 Int m 95 | , MonadState 2 Int m 96 | , MonadState 3 Int m 97 | , MonadState 4 Int m 98 | , MonadState 5 Int m 99 | , MonadState 6 Int m 100 | , MonadState 7 Int m 101 | , MonadState 8 Int m 102 | , MonadState 9 Int m ) 103 | => m () 104 | stateCombinerEther_sep_9 = do 105 | modify @1 id' 106 | modify @2 id' 107 | modify @3 id' 108 | modify @4 id' 109 | modify @5 id' 110 | modify @6 id' 111 | modify @7 id' 112 | modify @8 id' 113 | modify @9 id' 114 | rnf <$> sequenceA 115 | [ get @1 116 | , get @2 117 | , get @3 118 | , get @4 119 | , get @5 120 | , get @6 121 | , get @7 122 | , get @8 123 | , get @9 ] 124 | {-# NOINLINE stateCombinerEther_sep_9 #-} 125 | 126 | run_readerCombinerEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> () 127 | run_readerCombinerEther_nested_9 128 | (a1, a2, a3, a4, a5, a6, a7, a8, a9) 129 | = flip (runReader @9) a1 130 | . flip (runReaderT @8) a2 131 | . flip (runReaderT @7) a3 132 | . flip (runReaderT @6) a4 133 | . flip (runReaderT @5) a5 134 | . flip (runReaderT @4) a6 135 | . flip (runReaderT @3) a7 136 | . flip (runReaderT @2) a8 137 | . flip (runReaderT @1) a9 138 | $ readerCombinerEther_sep_9 139 | 140 | run_readerCombinerEther_flatten_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> () 141 | run_readerCombinerEther_flatten_9 142 | (a1, a2, a3, a4, a5, a6, a7, a8, a9) 143 | = 144 | runReaders 145 | readerCombinerEther_sep_9 146 | ( Tagged @1 a9, 147 | Tagged @2 a8, 148 | Tagged @3 a7, 149 | Tagged @4 a6, 150 | Tagged @5 a5, 151 | Tagged @6 a4, 152 | Tagged @7 a3, 153 | Tagged @8 a2, 154 | Tagged @9 a1 ) 155 | 156 | run_readerCombinerEther_flattenhalf_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> () 157 | run_readerCombinerEther_flattenhalf_9 158 | (a1, a2, a3, a4, a5, a6, a7, a8, a9) = 159 | flip runReaders 160 | ( Tagged @1 a9, 161 | Tagged @2 a8, 162 | Tagged @3 a7, 163 | Tagged @4 a6 ) . 164 | flip runReadersT 165 | ( Tagged @5 a5, 166 | Tagged @6 a4, 167 | Tagged @7 a3, 168 | Tagged @8 a2, 169 | Tagged @9 a1 ) $ 170 | readerCombinerEther_sep_9 171 | 172 | run_stateCombinerEther_flatten_9 :: 173 | (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> 174 | ((), _) 175 | run_stateCombinerEther_flatten_9 176 | (a1, a2, a3, a4, a5, a6, a7, a8, a9) 177 | = 178 | runStates 179 | stateCombinerEther_sep_9 180 | ( Tagged @1 a9, 181 | Tagged @2 a8, 182 | Tagged @3 a7, 183 | Tagged @4 a6, 184 | Tagged @5 a5, 185 | Tagged @6 a4, 186 | Tagged @7 a3, 187 | Tagged @8 a2, 188 | Tagged @9 a1 ) 189 | 190 | tuple_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) 191 | tuple_9 = (1, -2, 3, -4, 5, -6, 7, -8, 9) 192 | 193 | main :: IO () 194 | main = do 195 | defaultMain 196 | [ bench "readerCombinerMTL_flat_9" $ nf run_readerCombinerMTL_flat_9 tuple_9 197 | , bench "readerCombinerEther_nested_9" $ nf run_readerCombinerEther_nested_9 tuple_9 198 | , bench "readerCombinerEther_flatten_9" $ nf run_readerCombinerEther_flatten_9 tuple_9 199 | , bench "readerCombinerEther_flattenhalf_9" $ 200 | nf run_readerCombinerEther_flattenhalf_9 tuple_9 201 | , bench "stateCombinerMTL_flat_9" $ nf run_stateCombinerMTL_flat_9 tuple_9 202 | , bench "stateCombinerEther_flatten_9" $ nf run_stateCombinerEther_flatten_9 tuple_9 203 | ] 204 | -------------------------------------------------------------------------------- /bench/TupleInstances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fno-warn-orphans #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | module TupleInstances () where 5 | 6 | #ifdef DISABLE_TUP_INSTANCES 7 | import Ether.Internal (makeTupleInstancesHasLens) 8 | makeTupleInstancesHasLens [4,5,9] 9 | #endif 10 | -------------------------------------------------------------------------------- /ether.cabal: -------------------------------------------------------------------------------- 1 | name: ether 2 | version: 0.5.1.0 3 | synopsis: Monad transformers and classes 4 | description: 5 | Ether is a Haskell library that extends @mtl@ and @transformers@ with 6 | tagged monad transformers and classes in a compatible way. 7 | 8 | Introduction 9 | 10 | category: Control 11 | license: BSD3 12 | license-file: LICENSE 13 | author: Vladislav Zavialov 14 | maintainer: Vladislav Zavialov 15 | homepage: https://int-index.github.io/ether/ 16 | bug-reports: https://github.com/int-index/ether/issues 17 | build-type: Simple 18 | cabal-version: >=1.18 19 | extra-source-files: CHANGELOG.md 20 | 21 | source-repository head 22 | 23 | type: git 24 | location: git@github.com:int-index/ether.git 25 | 26 | 27 | flag disable-tup-instances 28 | 29 | description: 30 | Disable auto-generated 'HasLens' instances for tuples. The reason one 31 | might want to do this is to reduce the size of .hi-files, as well as the 32 | time and memory GHC needs to build Ether. To recover flattening with 33 | tuples, use 'Ether.Internal.makeTupleInstancesHasLens' at specific tuple 34 | sizes you need in your application. 35 | 36 | This is a build-time performance hack, enable this flag at your own risk. 37 | 38 | default: False 39 | manual: True 40 | 41 | library 42 | 43 | exposed-modules: 44 | Ether 45 | Ether.Reader 46 | Ether.State 47 | Ether.Writer 48 | Ether.Except 49 | Ether.TaggedTrans 50 | Ether.TagDispatch 51 | Ether.Internal 52 | 53 | other-modules: 54 | Ether.Internal.Tags 55 | Ether.Internal.HasLens 56 | Ether.Internal.TH_Utils 57 | Ether.Internal.TH_TupleInstances 58 | Ether.Internal.TupleInstances 59 | 60 | build-depends: 61 | base >=4.9 && <4.13, 62 | transformers >=0.5.2.0, 63 | transformers-lift >=0.2.0.1, 64 | mtl >=2.2.1, 65 | mmorph >=1.0.4, 66 | monad-control >=1.0.0.4, 67 | transformers-base >=0.4.4, 68 | writer-cps-mtl >= 0.1.1.4, 69 | exceptions >=0.8, 70 | template-haskell >=2.11, 71 | tagged >=0.8.5, 72 | reflection >=2.1 73 | 74 | default-language: 75 | Haskell2010 76 | 77 | default-extensions: 78 | AllowAmbiguousTypes 79 | ConstraintKinds 80 | DataKinds 81 | DeriveGeneric 82 | EmptyDataDecls 83 | FlexibleContexts 84 | FlexibleInstances 85 | FunctionalDependencies 86 | GADTs 87 | GeneralizedNewtypeDeriving 88 | PartialTypeSignatures 89 | PolyKinds 90 | ScopedTypeVariables 91 | RankNTypes 92 | TemplateHaskell 93 | TupleSections 94 | TypeApplications 95 | TypeFamilies 96 | TypeInType 97 | TypeOperators 98 | TypeSynonymInstances 99 | UndecidableInstances 100 | UndecidableSuperClasses 101 | 102 | hs-source-dirs: 103 | src 104 | 105 | ghc-options: 106 | -Wall -O2 107 | 108 | if flag(disable-tup-instances) 109 | cpp-options: -DDISABLE_TUP_INSTANCES 110 | 111 | test-suite regression 112 | 113 | build-depends: 114 | base >=4.9 && <4.13, 115 | transformers >=0.4.2, 116 | mtl >=2.2.1, 117 | tasty >=0.10, 118 | tasty-quickcheck >=0.8, 119 | QuickCheck >=2.8, 120 | ghc-prim >=0.3, 121 | lens >=4.14, 122 | ether 123 | 124 | main-is: 125 | Regression.hs 126 | 127 | other-modules: 128 | TupleInstances 129 | Regression.T1 130 | Regression.T2 131 | Regression.T3 132 | Regression.T4 133 | Regression.T5 134 | Regression.T6 135 | Regression.T7 136 | Regression.T8 137 | Regression.T9 138 | Regression.T10 139 | Regression.T11 140 | Regression.T12 141 | 142 | type: 143 | exitcode-stdio-1.0 144 | 145 | hs-source-dirs: 146 | test 147 | 148 | default-language: 149 | Haskell2010 150 | 151 | default-extensions: 152 | AllowAmbiguousTypes 153 | ConstraintKinds 154 | DataKinds 155 | DeriveGeneric 156 | EmptyDataDecls 157 | FlexibleContexts 158 | FlexibleInstances 159 | FunctionalDependencies 160 | GADTs 161 | GeneralizedNewtypeDeriving 162 | PartialTypeSignatures 163 | PolyKinds 164 | ScopedTypeVariables 165 | RankNTypes 166 | TemplateHaskell 167 | TupleSections 168 | TypeApplications 169 | TypeFamilies 170 | TypeInType 171 | TypeOperators 172 | TypeSynonymInstances 173 | UndecidableInstances 174 | UndecidableSuperClasses 175 | 176 | ghc-options: 177 | -Wall -fno-warn-missing-signatures 178 | 179 | if flag(disable-tup-instances) 180 | cpp-options: -DDISABLE_TUP_INSTANCES 181 | 182 | 183 | benchmark bench 184 | 185 | build-depends: 186 | base >=4.9 && <4.13, 187 | mtl >=2.2.1, 188 | transformers >=0.4.2, 189 | criterion >=1.1, 190 | deepseq >=1.4, 191 | lens >=4.14, 192 | ether 193 | 194 | main-is: 195 | Bench.hs 196 | 197 | other-modules: 198 | TupleInstances 199 | 200 | type: 201 | exitcode-stdio-1.0 202 | 203 | hs-source-dirs: 204 | bench 205 | 206 | default-language: 207 | Haskell2010 208 | 209 | default-extensions: 210 | AllowAmbiguousTypes 211 | ConstraintKinds 212 | DataKinds 213 | DeriveGeneric 214 | EmptyDataDecls 215 | FlexibleContexts 216 | FlexibleInstances 217 | FunctionalDependencies 218 | GADTs 219 | GeneralizedNewtypeDeriving 220 | PartialTypeSignatures 221 | PolyKinds 222 | ScopedTypeVariables 223 | RankNTypes 224 | TemplateHaskell 225 | TupleSections 226 | TypeApplications 227 | TypeFamilies 228 | TypeInType 229 | TypeOperators 230 | TypeSynonymInstances 231 | UndecidableInstances 232 | UndecidableSuperClasses 233 | 234 | ghc-options: 235 | -Wall -O2 236 | 237 | ghc-prof-options: 238 | -fprof-auto 239 | 240 | if flag(disable-tup-instances) 241 | cpp-options: -DDISABLE_TUP_INSTANCES 242 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {}, 2 | hc ? "ghc844" 3 | }: 4 | 5 | pkgs.stdenv.mkDerivation rec { 6 | name = "ether"; 7 | buildInputs = [ 8 | pkgs.haskell.compiler.${hc} 9 | pkgs.git 10 | pkgs.zlib 11 | pkgs.cabal-install 12 | pkgs.pkgconfig 13 | ]; 14 | shellHook = '' 15 | export LD_LIBRARY_PATH=${pkgs.lib.makeLibraryPath buildInputs}:$LD_LIBRARY_PATH 16 | export LANG=en_US.UTF-8 17 | ''; 18 | LOCALE_ARCHIVE = 19 | if pkgs.stdenv.isLinux 20 | then "${pkgs.glibcLocales}/lib/locale/locale-archive" 21 | else ""; 22 | } 23 | -------------------------------------------------------------------------------- /src/Ether.hs: -------------------------------------------------------------------------------- 1 | module Ether 2 | ( module Control.Monad 3 | , module Control.Monad.Fix 4 | , module Control.Monad.Trans.Identity 5 | , module Data.Functor.Identity 6 | , module Data.Tagged 7 | , module Ether.Reader 8 | , module Ether.Writer 9 | , module Ether.State 10 | , module Ether.Except 11 | , module Ether.TagDispatch 12 | , module Ether.TaggedTrans 13 | ) where 14 | 15 | import Control.Monad 16 | import Control.Monad.Fix 17 | import Control.Monad.Trans.Identity 18 | import Data.Functor.Identity 19 | import Data.Tagged 20 | import Ether.Reader 21 | import Ether.Writer 22 | import Ether.State 23 | import Ether.Except 24 | import Ether.TagDispatch 25 | import Ether.TaggedTrans 26 | -------------------------------------------------------------------------------- /src/Ether/Except.hs: -------------------------------------------------------------------------------- 1 | module Ether.Except 2 | ( 3 | -- * MonadExcept class 4 | MonadExcept 5 | , throw 6 | , catch 7 | -- * The Except monad 8 | , Except 9 | , runExcept 10 | -- * The ExceptT monad transformer 11 | , ExceptT 12 | , exceptT 13 | , runExceptT 14 | -- * MonadExcept class (implicit) 15 | , MonadExcept' 16 | , throw' 17 | , catch' 18 | -- * The Except monad (implicit) 19 | , Except' 20 | , runExcept' 21 | -- * The ExceptT monad transformer (implicit) 22 | , ExceptT' 23 | , exceptT' 24 | , runExceptT' 25 | -- * Internal labels 26 | , TAGGED 27 | , EXCEPT 28 | ) where 29 | 30 | import qualified Control.Monad.Except as T 31 | import Control.Monad.Signatures (Catch) 32 | import qualified Control.Monad.Trans.Lift.Catch as Lift 33 | import Data.Coerce 34 | import Data.Functor.Identity 35 | 36 | import Ether.TaggedTrans 37 | import Ether.Internal 38 | 39 | class Monad m => MonadExcept tag e m | m tag -> e where 40 | 41 | -- | Is used within a monadic computation to begin exception processing. 42 | throw :: e -> m a 43 | 44 | -- | A TaggedTrans function to handle previous exceptions and return to 45 | -- normal execution. 46 | catch :: m a -> (e -> m a) -> m a 47 | 48 | instance {-# OVERLAPPABLE #-} 49 | ( Lift.LiftCatch t 50 | , Monad (t m) 51 | , MonadExcept tag e m 52 | ) => MonadExcept tag e (t m) where 53 | throw = Lift.lift . throw @tag 54 | catch = Lift.liftCatch (catch @tag) 55 | 56 | -- | Encode type-level information for 'ExceptT'. 57 | data EXCEPT 58 | 59 | -- | The parameterizable exception monad. 60 | -- 61 | -- Computations are either exceptions or normal values. 62 | -- 63 | -- The 'return' function returns a normal value, while '>>=' exits on 64 | -- the first exception. 65 | type Except tag e = ExceptT tag e Identity 66 | 67 | -- | The exception monad transformer. 68 | -- 69 | -- The 'return' function returns a normal value, while '>>=' exits on 70 | -- the first exception. 71 | type ExceptT tag e = TaggedTrans (TAGGED EXCEPT tag) (T.ExceptT e) 72 | 73 | -- | Runs an 'Except' and returns either an exception or a normal value. 74 | runExcept :: forall tag e a . Except tag e a -> Either e a 75 | runExcept = coerce (T.runExcept @e @a) 76 | 77 | -- | Runs an 'ExceptT' and returns either an exception or a normal value. 78 | runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a) 79 | runExceptT = coerce (T.runExceptT @e @m @a) 80 | 81 | -- | Constructor for computations in the exception monad transformer. 82 | exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a 83 | exceptT = coerce (T.ExceptT @e @m @a) 84 | 85 | type instance HandleSuper EXCEPT e trans = () 86 | type instance HandleConstraint EXCEPT e trans m = 87 | T.MonadError e (trans m) 88 | 89 | instance Handle EXCEPT e (T.ExceptT e) where 90 | handling r = r 91 | 92 | instance 93 | ( Handle EXCEPT e trans 94 | , Monad m, Monad (trans m) 95 | ) => MonadExcept tag e (TaggedTrans (TAGGED EXCEPT tag) trans m) 96 | where 97 | 98 | throw = 99 | handling @EXCEPT @e @trans @m $ 100 | coerce (T.throwError @e @(trans m) @a) :: 101 | forall eff a . e -> TaggedTrans eff trans m a 102 | 103 | catch = 104 | handling @EXCEPT @e @trans @m $ 105 | coerce (T.catchError @e @(trans m) @a) :: 106 | forall eff a . Catch e (TaggedTrans eff trans m) a 107 | 108 | type MonadExcept' e = MonadExcept e e 109 | 110 | throw' :: forall e m a . MonadExcept' e m => e -> m a 111 | throw' = throw @e 112 | 113 | catch' :: forall e m a . MonadExcept' e m => m a -> (e -> m a) -> m a 114 | catch' = catch @e 115 | 116 | type Except' e = Except e e 117 | 118 | runExcept' :: Except' e a -> Either e a 119 | runExcept' = runExcept 120 | 121 | type ExceptT' e = ExceptT e e 122 | 123 | exceptT' :: m (Either e a) -> ExceptT' e m a 124 | exceptT' = exceptT 125 | 126 | runExceptT' :: ExceptT' e m a -> m (Either e a) 127 | runExceptT' = runExceptT 128 | -------------------------------------------------------------------------------- /src/Ether/Internal.hs: -------------------------------------------------------------------------------- 1 | module Ether.Internal 2 | ( Tagged(..) 3 | , TagsK 4 | , Tags 5 | , HasLens(..) 6 | , LensLike 7 | , Lens 8 | , Lens' 9 | , ReifiedLens(..) 10 | , ReifiedLens' 11 | , view 12 | , over 13 | , HList(..) 14 | , KindOf 15 | , TAGGED 16 | , HandleSuper 17 | , HandleConstraint 18 | , Handle(..) 19 | , makeTupleInstancesHasLens 20 | ) where 21 | 22 | import Control.Applicative 23 | import Data.Coerce 24 | import Data.Functor.Identity 25 | import Data.Kind 26 | import Data.Tagged 27 | import GHC.Exts (Constraint) 28 | 29 | import Ether.Internal.HasLens 30 | import Ether.Internal.Tags 31 | import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens) 32 | import Ether.Internal.TupleInstances () 33 | 34 | data TAGGED e t 35 | 36 | type K_Monad = Type -> Type 37 | 38 | type K_Trans = K_Monad -> K_Monad 39 | 40 | type family 41 | HandleSuper 42 | (eff :: keff) 43 | (p :: kp) 44 | (trans :: K_Trans) 45 | :: Constraint 46 | 47 | type family 48 | HandleConstraint 49 | (eff :: keff) 50 | (p :: kp) 51 | (trans :: K_Trans) (m :: K_Monad) 52 | :: Constraint 53 | 54 | class 55 | HandleSuper eff p trans => 56 | Handle eff p (trans :: K_Trans) | eff trans -> p 57 | where 58 | handling :: Monad m => (HandleConstraint eff p trans m => r) -> r 59 | 60 | newtype ReifiedLens s t a b = Lens (Lens s t a b) 61 | 62 | type ReifiedLens' s a = ReifiedLens s s a a 63 | 64 | view :: LensLike (Const a) s t a b -> s -> a 65 | view l = coerce (l Const) 66 | 67 | over :: LensLike Identity s t a b -> (a -> b) -> s -> t 68 | over = coerce 69 | -------------------------------------------------------------------------------- /src/Ether/Internal/HasLens.hs: -------------------------------------------------------------------------------- 1 | module Ether.Internal.HasLens 2 | ( LensLike 3 | , Lens 4 | , Lens' 5 | , HasLens(..) 6 | ) where 7 | 8 | import Data.Tagged 9 | import Data.Coerce 10 | 11 | type LensLike f s t a b = (a -> f b) -> s -> f t 12 | 13 | type Lens s t a b = forall f. Functor f => LensLike f s t a b 14 | 15 | type Lens' s a = Lens s s a a 16 | 17 | class HasLens tag outer inner | tag outer -> inner where 18 | lensOf :: Lens' outer inner 19 | 20 | instance HasLens a a a where 21 | lensOf = id 22 | 23 | instance HasLens t (Tagged t a) a where 24 | lensOf = \f -> fmap coerce . f . coerce 25 | -------------------------------------------------------------------------------- /src/Ether/Internal/TH_TupleInstances.hs: -------------------------------------------------------------------------------- 1 | module Ether.Internal.TH_TupleInstances 2 | ( makeTupleInstancesTagsK 3 | , makeTupleInstancesTags 4 | , makeTupleInstancesHasLens 5 | ) where 6 | 7 | import Data.Tagged 8 | import Data.Traversable 9 | import Data.List as List 10 | import qualified Language.Haskell.TH as TH 11 | 12 | import Ether.Internal.HasLens 13 | import Ether.Internal.Tags 14 | import Ether.Internal.TH_Utils 15 | 16 | makeTupleInstancesTagsK :: TH.DecsQ 17 | makeTupleInstancesTagsK = do 18 | for [2..tupCount] $ \n -> do 19 | let 20 | tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $ 21 | (\k -> TH.ConT ''Tagged `TH.AppT` 22 | TH.VarT (tagName k) `TH.AppT` 23 | TH.VarT (varName k)) <$> [0..n-1] 24 | tagsList = List.foldr 25 | (\a b -> TH.PromotedConsT `TH.AppT` a `TH.AppT` b) 26 | TH.PromotedNilT 27 | (TH.AppT (TH.ConT ''KindOf) . TH.VarT . tagName <$> [0..n-1]) 28 | return $ 29 | TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] tagsList) 30 | 31 | makeTupleInstancesTags :: TH.DecsQ 32 | makeTupleInstancesTags = do 33 | for [2..tupCount] $ \n -> do 34 | let 35 | tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $ 36 | (\k -> TH.ConT ''Tagged `TH.AppT` 37 | TH.VarT (tagName k) `TH.AppT` 38 | TH.VarT (varName k)) <$> [0..n-1] 39 | tagsList = List.foldr 40 | (\a b -> TH.PromotedT 'HCons `TH.AppT` a `TH.AppT` b) 41 | (TH.PromotedT 'HNil) 42 | (TH.VarT . tagName <$> [0..n-1]) 43 | return $ 44 | TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] tagsList) 45 | 46 | makeTupleInstancesHasLens :: [Int] -> TH.DecsQ 47 | makeTupleInstancesHasLens range = List.concat <$> do 48 | for range $ \n -> 49 | for [0..n-1] $ \k -> do 50 | let 51 | tag = TH.mkName "tag" 52 | prev = varName <$> [0..k-1] 53 | cur = varName k 54 | next = varName <$> [k+1..n-1] 55 | tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n)) 56 | ( map TH.VarT prev ++ 57 | [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++ 58 | map TH.VarT next ) 59 | let 60 | cur' = TH.mkName "x" 61 | f = TH.mkName "f" 62 | return $ 63 | TH.InstanceD Nothing [] 64 | (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur) 65 | [ TH.FunD 'lensOf 66 | [ TH.Clause 67 | [TH.VarP f, TH.TupP 68 | ( map TH.VarP prev ++ 69 | [TH.ConP 'Tagged [TH.VarP cur]] ++ 70 | map TH.VarP next )] 71 | (TH.NormalB $ 72 | TH.VarE 'fmap `TH.AppE` 73 | (TH.LamE [TH.VarP cur'] 74 | (TH.TupE 75 | ( map TH.VarE prev ++ 76 | [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++ 77 | map TH.VarE next ))) `TH.AppE` 78 | (TH.VarE f `TH.AppE` TH.VarE cur) ) 79 | [] ] ] 80 | -------------------------------------------------------------------------------- /src/Ether/Internal/TH_Utils.hs: -------------------------------------------------------------------------------- 1 | module Ether.Internal.TH_Utils 2 | ( tupCount 3 | , varName 4 | , tagName 5 | ) where 6 | 7 | import qualified Language.Haskell.TH as TH 8 | 9 | tupCount :: Int 10 | tupCount = 62 11 | 12 | varName, tagName :: Int -> TH.Name 13 | varName k = TH.mkName ('a' : show k) 14 | tagName k = TH.mkName ('t' : show k) 15 | -------------------------------------------------------------------------------- /src/Ether/Internal/Tags.hs: -------------------------------------------------------------------------------- 1 | module Ether.Internal.Tags 2 | ( Tags 3 | , TagsK 4 | , HList(..) 5 | , KindOf 6 | ) where 7 | 8 | import Data.Kind 9 | 10 | data HList xs where 11 | HNil :: HList '[] 12 | HCons :: x -> HList xs -> HList (x ': xs) 13 | 14 | type KindOf (a :: k) = k 15 | 16 | type family TagsK (p :: Type) :: [Type] 17 | type family Tags (p :: Type) :: HList (TagsK p) 18 | 19 | -------------------------------------------------------------------------------- /src/Ether/Internal/TupleInstances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fno-warn-orphans #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | module Ether.Internal.TupleInstances () where 5 | 6 | import Data.Tagged 7 | import Ether.Internal.Tags 8 | import Ether.Internal.TH_TupleInstances 9 | 10 | type instance TagsK () = '[] 11 | type instance TagsK (Tagged t a) = '[KindOf t] 12 | type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1] 13 | 14 | makeTupleInstancesTagsK 15 | 16 | type instance Tags () = 'HNil 17 | type instance Tags (Tagged t a) = 'HCons t 'HNil 18 | type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil) 19 | 20 | makeTupleInstancesTags 21 | 22 | #ifndef DISABLE_TUP_INSTANCES 23 | makeTupleInstancesHasLens [2..62] 24 | #endif 25 | -------------------------------------------------------------------------------- /src/Ether/Reader.hs: -------------------------------------------------------------------------------- 1 | module Ether.Reader 2 | ( 3 | -- * MonadReader class 4 | MonadReader 5 | , ask 6 | , local 7 | , reader 8 | , asks 9 | -- * The Reader monad 10 | , Reader 11 | , runReader 12 | -- * The ReaderT monad transformer 13 | , ReaderT 14 | , readerT 15 | , runReaderT 16 | -- * The Reader monad (flattened) 17 | , Readers 18 | , runReaders 19 | -- * The ReaderT monad transformer (flattened) 20 | , ReadersT 21 | , runReadersT 22 | -- * MonadReader class (implicit) 23 | , MonadReader' 24 | , local' 25 | , ask' 26 | , reader' 27 | , asks' 28 | -- * The Reader monad (implicit) 29 | , Reader' 30 | , runReader' 31 | -- * The ReaderT monad transformer (implicit) 32 | , ReaderT' 33 | , readerT' 34 | , runReaderT' 35 | -- * Internal labels 36 | , TAGGED 37 | , READER 38 | , READERS 39 | ) where 40 | 41 | import qualified Control.Monad.Reader as T 42 | import qualified Control.Monad.Trans.Lift.Local as Lift 43 | import Control.Monad.Trans.Lift.Local (Local) 44 | import Data.Coerce 45 | import Data.Functor.Identity 46 | import Data.Kind 47 | 48 | import Ether.TaggedTrans 49 | import Ether.Internal 50 | 51 | class Monad m => MonadReader tag r m | m tag -> r where 52 | 53 | {-# MINIMAL (ask | reader), local #-} 54 | 55 | -- | Retrieves the monad environment. 56 | ask :: m r 57 | ask = reader @tag id 58 | 59 | -- | Executes a computation in a modified environment. 60 | local 61 | :: (r -> r) 62 | -- ^ The function to modify the environment. 63 | -> m a 64 | -- ^ @Reader@ to run in the modified environment. 65 | -> m a 66 | 67 | -- | Retrieves a function of the current environment. 68 | reader 69 | :: (r -> a) 70 | -- ^ The selector function to apply to the environment. 71 | -> m a 72 | reader f = fmap f (ask @tag) 73 | 74 | instance {-# OVERLAPPABLE #-} 75 | ( Lift.LiftLocal t 76 | , Monad (t m) 77 | , MonadReader tag r m 78 | ) => MonadReader tag r (t m) 79 | where 80 | ask = Lift.lift (ask @tag) 81 | local = Lift.liftLocal (ask @tag) (local @tag) 82 | reader = Lift.lift . reader @tag 83 | 84 | instance {-# OVERLAPPABLE #-} 85 | ( Monad (trans m) 86 | , MonadReader tag r (TaggedTrans effs trans m) 87 | ) => MonadReader tag r (TaggedTrans (eff ': effs) trans (m :: Type -> Type)) 88 | where 89 | 90 | ask = 91 | (coerce :: 92 | TaggedTrans effs trans m r -> 93 | TaggedTrans (eff ': effs) trans m r) 94 | (ask @tag) 95 | 96 | local = 97 | (coerce :: forall a . 98 | Lift.Local r (TaggedTrans effs trans m) a -> 99 | Lift.Local r (TaggedTrans (eff ': effs) trans m) a) 100 | (local @tag) 101 | 102 | reader = 103 | (coerce :: forall a . 104 | ((r -> a) -> TaggedTrans effs trans m a) -> 105 | ((r -> a) -> TaggedTrans (eff ': effs) trans m a)) 106 | (reader @tag) 107 | 108 | -- | Retrieves a function of the current environment. 109 | asks 110 | :: forall tag r m a 111 | . MonadReader tag r m 112 | => (r -> a) 113 | -- ^ The selector function to apply to the environment. 114 | -> m a 115 | asks = reader @tag 116 | 117 | -- | Encode type-level information for 'ReaderT'. 118 | data READER 119 | 120 | -- | The parameterizable reader monad. 121 | -- 122 | -- Computations are functions of a shared environment. 123 | -- 124 | -- The 'return' function ignores the environment, while '>>=' passes 125 | -- the inherited environment to both subcomputations. 126 | type Reader tag r = ReaderT tag r Identity 127 | 128 | -- | The reader monad transformer, 129 | -- which adds a read-only environment to the given monad. 130 | -- 131 | -- The 'return' function ignores the environment, while '>>=' passes 132 | -- the inherited environment to both subcomputations. 133 | type ReaderT tag r = TaggedTrans (TAGGED READER tag) (T.ReaderT r) 134 | 135 | -- | Constructor for computations in the reader monad transformer. 136 | readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a 137 | readerT = coerce (T.ReaderT @r @m @a) 138 | 139 | -- | Runs a 'ReaderT' with the given environment 140 | -- and returns the final value. 141 | runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a 142 | runReaderT = coerce (T.runReaderT @r @_ @m @a) 143 | 144 | -- | Runs a 'ReaderT' with the given environment 145 | -- and returns the final value. 146 | runReader :: forall tag r a . Reader tag r a -> r -> a 147 | runReader = coerce (T.runReader @r @a) 148 | 149 | type instance HandleSuper READER r trans = () 150 | type instance HandleConstraint READER r trans m = 151 | T.MonadReader r (trans m) 152 | 153 | instance Handle READER r (T.ReaderT r) where 154 | handling r = r 155 | 156 | instance 157 | ( Handle READER r trans 158 | , Monad m, Monad (trans m) 159 | ) => MonadReader tag r (TaggedTrans (TAGGED READER tag) trans m) 160 | where 161 | 162 | ask = 163 | handling @READER @r @trans @m $ 164 | coerce (T.ask @r @(trans m)) 165 | 166 | local = 167 | handling @READER @r @trans @m $ 168 | coerce (T.local @r @(trans m) @a) :: 169 | forall eff a . Local r (TaggedTrans eff trans m) a 170 | 171 | reader = 172 | handling @READER @r @trans @m $ 173 | coerce (T.reader @r @(trans m) @a) :: 174 | forall eff a . (r -> a) -> TaggedTrans eff trans m a 175 | 176 | instance 177 | ( HasLens tag payload r 178 | , Handle READER payload trans 179 | , Monad m, Monad (trans m) 180 | ) => MonadReader tag r (TaggedTrans (TAGGED READER tag ': effs) trans m) 181 | where 182 | 183 | ask = 184 | handling @READER @payload @trans @m $ 185 | (coerce :: forall eff a . 186 | trans m a -> 187 | TaggedTrans eff trans m a) 188 | (T.asks (view (lensOf @tag @payload @r))) 189 | 190 | local f = 191 | handling @READER @payload @trans @m $ 192 | (coerce :: forall eff a . 193 | (trans m a -> trans m a) -> 194 | (TaggedTrans eff trans m a -> TaggedTrans eff trans m a)) 195 | (T.local (over (lensOf @tag @payload @r) f)) 196 | 197 | type family READERS (ts :: HList xs) :: [Type] where 198 | READERS 'HNil = '[] 199 | READERS ('HCons t ts) = TAGGED READER t ': READERS ts 200 | 201 | type ReadersT r = TaggedTrans (READERS (Tags r)) (T.ReaderT r) 202 | 203 | type Readers r = ReadersT r Identity 204 | 205 | runReadersT :: forall p m a . ReadersT p m a -> p -> m a 206 | runReadersT = coerce (T.runReaderT @p @_ @m @a) 207 | 208 | runReaders :: forall p a . Readers p a -> p -> a 209 | runReaders = coerce (T.runReader @p @a) 210 | 211 | type ReaderT' r = ReaderT r r 212 | 213 | readerT' :: (r -> m a) -> ReaderT' r m a 214 | readerT' = readerT 215 | 216 | runReaderT' :: ReaderT' r m a -> r -> m a 217 | runReaderT' = runReaderT 218 | 219 | type Reader' r = Reader r r 220 | 221 | runReader' :: Reader' r a -> r -> a 222 | runReader' = runReader 223 | 224 | type MonadReader' r = MonadReader r r 225 | 226 | local' :: forall r m a . MonadReader' r m => (r -> r) -> m a -> m a 227 | local' = local @r 228 | 229 | ask' :: forall r m . MonadReader' r m => m r 230 | ask' = ask @r 231 | 232 | reader' :: forall r m a . MonadReader' r m => (r -> a) -> m a 233 | reader' = reader @r 234 | 235 | asks' :: forall r m a . MonadReader' r m => (r -> a) -> m a 236 | asks' = asks @r 237 | -------------------------------------------------------------------------------- /src/Ether/State.hs: -------------------------------------------------------------------------------- 1 | module Ether.State 2 | ( 3 | -- * MonadState class 4 | MonadState 5 | , get 6 | , put 7 | , state 8 | , modify 9 | , gets 10 | -- * The State monad 11 | , State 12 | , runState 13 | , evalState 14 | , execState 15 | -- * The StateT monad transformer 16 | , StateT 17 | , stateT 18 | , runStateT 19 | , evalStateT 20 | , execStateT 21 | -- * The State monad (lazy) 22 | , LazyState 23 | , runLazyState 24 | , evalLazyState 25 | , execLazyState 26 | -- * The StateT monad transformer (lazy) 27 | , LazyStateT 28 | , lazyStateT 29 | , runLazyStateT 30 | , evalLazyStateT 31 | , execLazyStateT 32 | -- * The State monad (flattened) 33 | , States 34 | , runStates 35 | -- * The StateT monad transformer (flattened) 36 | , StatesT 37 | , runStatesT 38 | -- * MonadState class (implicit) 39 | , MonadState' 40 | , get' 41 | , put' 42 | , state' 43 | , modify' 44 | , gets' 45 | -- * The State monad (implicit) 46 | , State' 47 | , runState' 48 | , evalState' 49 | , execState' 50 | -- * The StateT monad transformer (implicit) 51 | , StateT' 52 | , stateT' 53 | , runStateT' 54 | , evalStateT' 55 | , execStateT' 56 | -- * The State monad (lazy, implicit) 57 | , LazyState' 58 | , runLazyState' 59 | , evalLazyState' 60 | , execLazyState' 61 | -- * The StateT monad transformer (lazy, implicit) 62 | , LazyStateT' 63 | , lazyStateT' 64 | , runLazyStateT' 65 | , evalLazyStateT' 66 | , execLazyStateT' 67 | -- * Zoom 68 | , ZoomT 69 | , zoom 70 | -- * Internal labels 71 | , TAGGED 72 | , STATE 73 | , STATES 74 | , ZOOM 75 | ) where 76 | 77 | import qualified Control.Monad.State.Class as T 78 | import qualified Control.Monad.Trans as Lift 79 | import Control.Monad.Trans.Identity 80 | import qualified Control.Monad.Trans.State.Lazy as T.Lazy 81 | import qualified Control.Monad.Trans.State.Strict as T.Strict 82 | import Data.Coerce 83 | import Data.Functor.Identity 84 | import Data.Kind 85 | import Data.Proxy 86 | import Data.Reflection 87 | 88 | import Ether.Internal 89 | import Ether.TaggedTrans 90 | 91 | class Monad m => MonadState tag s m | m tag -> s where 92 | 93 | {-# MINIMAL state | get, put #-} 94 | 95 | -- | Return the state from the internals of the monad. 96 | get :: m s 97 | get = state @tag (\s -> (s, s)) 98 | 99 | -- | Replace the state inside the monad. 100 | put :: s -> m () 101 | put s = state @tag (\_ -> ((), s)) 102 | 103 | -- | Embed a simple state action into the monad. 104 | state :: (s -> (a, s)) -> m a 105 | state f = do 106 | s <- get @tag 107 | let ~(a, s') = f s 108 | put @tag s' 109 | return a 110 | 111 | instance {-# OVERLAPPABLE #-} 112 | ( Lift.MonadTrans t 113 | , Monad (t m) 114 | , MonadState tag s m 115 | ) => MonadState tag s (t m) 116 | where 117 | get = Lift.lift (get @tag) 118 | put = Lift.lift . put @tag 119 | state = Lift.lift . state @tag 120 | 121 | instance {-# OVERLAPPABLE #-} 122 | ( Monad (trans m) 123 | , MonadState tag s (TaggedTrans effs trans m) 124 | ) => MonadState tag s (TaggedTrans (eff ': effs) trans (m :: Type -> Type)) 125 | where 126 | 127 | get = 128 | (coerce :: 129 | TaggedTrans effs trans m s -> 130 | TaggedTrans (eff ': effs) trans m s) 131 | (get @tag) 132 | 133 | put = 134 | (coerce :: 135 | (s -> TaggedTrans effs trans m ()) -> 136 | (s -> TaggedTrans (eff ': effs) trans m ())) 137 | (put @tag) 138 | 139 | state = 140 | (coerce :: forall a . 141 | ((s -> (a, s)) -> TaggedTrans effs trans m a) -> 142 | ((s -> (a, s)) -> TaggedTrans (eff ': effs) trans m a)) 143 | (state @tag) 144 | 145 | -- | Modifies the state inside a state monad. 146 | modify :: forall tag s m . MonadState tag s m => (s -> s) -> m () 147 | modify f = state @tag (\s -> ((), f s)) 148 | 149 | -- | Gets specific component of the state, using a projection function supplied. 150 | gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a 151 | gets f = fmap f (get @tag) 152 | 153 | -- | Encode type-level information for 'StateT'. 154 | data STATE 155 | 156 | type instance HandleSuper STATE s trans = () 157 | type instance HandleConstraint STATE s trans m = 158 | T.MonadState s (trans m) 159 | 160 | instance Handle STATE s (T.Strict.StateT s) where 161 | handling r = r 162 | 163 | instance Handle STATE s (T.Lazy.StateT s) where 164 | handling r = r 165 | 166 | instance 167 | ( Handle STATE s trans 168 | , Monad m, Monad (trans m) 169 | ) => MonadState tag s (TaggedTrans (TAGGED STATE tag) trans m) 170 | where 171 | 172 | get = 173 | handling @STATE @s @trans @m $ 174 | coerce (T.get @s @(trans m)) 175 | 176 | put = 177 | handling @STATE @s @trans @m $ 178 | coerce (T.put @s @(trans m)) 179 | 180 | state = 181 | handling @STATE @s @trans @m $ 182 | coerce (T.state @s @(trans m) @a) :: 183 | forall eff a . (s -> (a, s)) -> TaggedTrans eff trans m a 184 | 185 | instance 186 | ( HasLens tag payload s 187 | , Handle STATE payload trans 188 | , Monad m, Monad (trans m) 189 | ) => MonadState tag s (TaggedTrans (TAGGED STATE tag ': effs) trans m) 190 | where 191 | 192 | get = 193 | handling @STATE @payload @trans @m $ 194 | (coerce :: forall eff a . 195 | trans m a -> 196 | TaggedTrans eff trans m a) 197 | (T.gets (view (lensOf @tag @payload @s))) 198 | 199 | put s = 200 | handling @STATE @payload @trans @m $ 201 | (coerce :: forall eff a . 202 | trans m a -> 203 | TaggedTrans eff trans m a) 204 | (T.modify (over (lensOf @tag @payload @s) (const s))) 205 | 206 | state f = 207 | handling @STATE @payload @trans @m $ 208 | (coerce :: forall eff a . 209 | trans m a -> 210 | TaggedTrans eff trans m a) 211 | (T.state (lensOf @tag @payload @s f)) 212 | 213 | -- | The parametrizable state monad. 214 | -- 215 | -- Computations have access to a mutable state. 216 | -- 217 | -- The 'return' function leaves the state unchanged, while '>>=' uses 218 | -- the final state of the first computation as the initial state of the second. 219 | type State tag r = StateT tag r Identity 220 | 221 | -- | The state monad transformer. 222 | -- 223 | -- The 'return' function leaves the state unchanged, while '>>=' uses 224 | -- the final state of the first computation as the initial state of the second. 225 | type StateT tag s = TaggedTrans (TAGGED STATE tag) (T.Strict.StateT s) 226 | 227 | -- | Constructor for computations in the state monad transformer. 228 | stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a 229 | stateT = coerce (T.Strict.StateT @s @m @a) 230 | 231 | -- | Runs a 'StateT' with the given initial state 232 | -- and returns both the final value and the final state. 233 | runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s) 234 | runStateT = coerce (T.Strict.runStateT @s @m @a) 235 | 236 | -- | Runs a 'StateT' with the given initial state 237 | -- and returns the final value, discarding the final state. 238 | evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a 239 | evalStateT = coerce (T.Strict.evalStateT @m @s @a) 240 | 241 | -- | Runs a 'StateT' with the given initial state 242 | -- and returns the final state, discarding the final value. 243 | execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s 244 | execStateT = coerce (T.Strict.execStateT @m @s @a) 245 | 246 | -- | Runs a 'State' with the given initial state 247 | -- and returns both the final value and the final state. 248 | runState :: forall tag s a . State tag s a -> s -> (a, s) 249 | runState = coerce (T.Strict.runState @s @a) 250 | 251 | -- | Runs a 'State' with the given initial state 252 | -- and returns the final value, discarding the final state. 253 | evalState :: forall tag s a . State tag s a -> s -> a 254 | evalState = coerce (T.Strict.evalState @s @a) 255 | 256 | -- | Runs a 'State' with the given initial state 257 | -- and returns the final state, discarding the final value. 258 | execState :: forall tag s a . State tag s a -> s -> s 259 | execState = coerce (T.Strict.execState @s @a) 260 | 261 | -- | The parametrizable state monad. 262 | -- 263 | -- Computations have access to a mutable state. 264 | -- 265 | -- The 'return' function leaves the state unchanged, while '>>=' uses 266 | -- the final state of the first computation as the initial state of the second. 267 | type LazyState tag r = LazyStateT tag r Identity 268 | 269 | -- | The state monad transformer. 270 | -- 271 | -- The 'return' function leaves the state unchanged, while '>>=' uses 272 | -- the final state of the first computation as the initial state of the second. 273 | type LazyStateT tag s = TaggedTrans (TAGGED STATE tag) (T.Lazy.StateT s) 274 | 275 | -- | Constructor for computations in the state monad transformer. 276 | lazyStateT :: forall tag s m a . (s -> m (a, s)) -> LazyStateT tag s m a 277 | lazyStateT = coerce (T.Lazy.StateT @s @m @a) 278 | 279 | -- | Runs a 'StateT' with the given initial state 280 | -- and returns both the final value and the final state. 281 | runLazyStateT :: forall tag s m a . LazyStateT tag s m a -> s -> m (a, s) 282 | runLazyStateT = coerce (T.Lazy.runStateT @s @m @a) 283 | 284 | -- | Runs a 'StateT' with the given initial state 285 | -- and returns the final value, discarding the final state. 286 | evalLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m a 287 | evalLazyStateT = coerce (T.Lazy.evalStateT @m @s @a) 288 | 289 | -- | Runs a 'StateT' with the given initial state 290 | -- and returns the final state, discarding the final value. 291 | execLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m s 292 | execLazyStateT = coerce (T.Lazy.execStateT @m @s @a) 293 | 294 | -- | Runs a 'State' with the given initial state 295 | -- and returns both the final value and the final state. 296 | runLazyState :: forall tag s a . LazyState tag s a -> s -> (a, s) 297 | runLazyState = coerce (T.Lazy.runState @s @a) 298 | 299 | -- | Runs a 'State' with the given initial state 300 | -- and returns the final value, discarding the final state. 301 | evalLazyState :: forall tag s a . LazyState tag s a -> s -> a 302 | evalLazyState = coerce (T.Lazy.evalState @s @a) 303 | 304 | -- | Runs a 'State' with the given initial state 305 | -- and returns the final state, discarding the final value. 306 | execLazyState :: forall tag s a . LazyState tag s a -> s -> s 307 | execLazyState = coerce (T.Lazy.execState @s @a) 308 | 309 | type family STATES (ts :: HList xs) :: [Type] where 310 | STATES 'HNil = '[] 311 | STATES ('HCons t ts) = TAGGED STATE t ': STATES ts 312 | 313 | type StatesT s = TaggedTrans (STATES (Tags s)) (T.Strict.StateT s) 314 | 315 | type States s = StatesT s Identity 316 | 317 | runStatesT :: forall p m a . StatesT p m a -> p -> m (a, p) 318 | runStatesT = coerce (T.Strict.runStateT @p @m @a) 319 | 320 | runStates :: forall p a . States p a -> p -> (a, p) 321 | runStates = coerce (T.Strict.runState @p @a) 322 | 323 | type StateT' s = StateT s s 324 | 325 | stateT' :: (s -> m (a, s)) -> StateT' s m a 326 | stateT' = stateT 327 | 328 | runStateT' :: StateT' s m a -> s -> m (a, s) 329 | runStateT' = runStateT 330 | 331 | runState' :: State' s a -> s -> (a, s) 332 | runState' = runState 333 | 334 | evalStateT' :: Monad m => StateT' s m a -> s -> m a 335 | evalStateT' = evalStateT 336 | 337 | type State' s = State s s 338 | 339 | evalState' :: State' s a -> s -> a 340 | evalState' = evalState 341 | 342 | execStateT' :: Monad m => StateT' s m a -> s -> m s 343 | execStateT' = execStateT 344 | 345 | execState' :: State' s a -> s -> s 346 | execState' = execState 347 | 348 | type LazyStateT' s = LazyStateT s s 349 | 350 | lazyStateT' :: (s -> m (a, s)) -> LazyStateT' s m a 351 | lazyStateT' = lazyStateT 352 | 353 | runLazyStateT' :: LazyStateT' s m a -> s -> m (a, s) 354 | runLazyStateT' = runLazyStateT 355 | 356 | runLazyState' :: LazyState' s a -> s -> (a, s) 357 | runLazyState' = runLazyState 358 | 359 | evalLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m a 360 | evalLazyStateT' = evalLazyStateT 361 | 362 | type LazyState' s = LazyState s s 363 | 364 | evalLazyState' :: LazyState' s a -> s -> a 365 | evalLazyState' = evalLazyState 366 | 367 | execLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m s 368 | execLazyStateT' = execLazyStateT 369 | 370 | execLazyState' :: LazyState' s a -> s -> s 371 | execLazyState' = execLazyState 372 | 373 | type MonadState' s = MonadState s s 374 | 375 | get' :: forall s m . MonadState' s m => m s 376 | get' = get @s 377 | 378 | gets' :: forall s m a . MonadState' s m => (s -> a) -> m a 379 | gets' = gets @s 380 | 381 | put' :: forall s m . MonadState' s m => s -> m () 382 | put' = put @s 383 | 384 | state' :: forall s m a . MonadState' s m => (s -> (a, s)) -> m a 385 | state' = state @s 386 | 387 | modify' :: forall s m . MonadState' s m => (s -> s) -> m () 388 | modify' = modify @s 389 | 390 | -- | Encode type-level information for 'zoom'. 391 | data ZOOM t z 392 | 393 | type ZoomT t (z :: Type) = TaggedTrans (ZOOM t z) IdentityT 394 | 395 | -- | Zoom into a part of a state using a lens. 396 | zoom 397 | :: forall tag sOuter sInner m a 398 | . Lens' sOuter sInner 399 | -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => ZoomT tag z m a) 400 | -> m a 401 | zoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z)) 402 | 403 | instance 404 | ( MonadState tag sOuter m 405 | , Reifies z (ReifiedLens' sOuter sInner) 406 | , trans ~ IdentityT 407 | ) => MonadState tag sInner (TaggedTrans (ZOOM tag z) trans m) 408 | where 409 | state = 410 | (coerce :: forall eff r a . 411 | (r -> m a) -> 412 | (r -> TaggedTrans eff trans m a)) 413 | (state @tag . l) 414 | where 415 | Lens l = reflect (Proxy :: Proxy z) 416 | -------------------------------------------------------------------------------- /src/Ether/TagDispatch.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | 3 | Type-level machinery to manipulate constraints on the monad 4 | transformer stack. 5 | 6 | Out of the box it provides the following dispatch strategies: 7 | 8 | * 'tagAttach' to use functions defined using untagged monad classes 9 | as if they were defined using tagged ones. 10 | 11 | * 'tagReplace' to use functions defined using one tag 12 | as if they were defined using another one. 13 | 14 | > import Ether 15 | > import Control.Monad.State as Mtl 16 | > 17 | > data Foo 18 | > data Bar 19 | > 20 | > f :: Mtl.MonadState Int m => m String 21 | > f = fmap show Mtl.get 22 | > 23 | > g :: Ether.MonadState Foo Int m => m String 24 | > g = tagAttach @Foo f 25 | > 26 | > h :: Ether.MonadState Bar Int m => m String 27 | > h = tagReplace @Foo @Bar g 28 | 29 | -} 30 | 31 | module Ether.TagDispatch 32 | ( 33 | -- * The Tag Attach monad transformer 34 | TagAttachT 35 | , tagAttach 36 | -- * The Tag Replace monad transformer 37 | , TagReplaceT 38 | , tagReplace 39 | -- * Internal labels 40 | , TAG_ATTACH 41 | , TAG_REPLACE 42 | ) where 43 | 44 | import qualified Control.Monad.Error.Class as Mtl 45 | import qualified Control.Monad.Reader.Class as Mtl 46 | import qualified Control.Monad.State.Class as Mtl 47 | import qualified Control.Monad.Writer.Class as Mtl 48 | 49 | import Ether.Except 50 | import Ether.Reader 51 | import Ether.State 52 | import Ether.Writer 53 | import Ether.TaggedTrans 54 | 55 | import Control.Monad.Trans.Identity 56 | import Data.Coerce 57 | 58 | -- | Encode type-level information for 'tagAttach'. 59 | data TAG_ATTACH t 60 | 61 | type TagAttachT t = TaggedTrans (TAG_ATTACH t) IdentityT 62 | 63 | -- | Attach a tag to untagged transformers. 64 | tagAttach :: forall tag m a . TagAttachT tag m a -> m a 65 | tagAttach = coerce (runIdentityT @_ @m @a) 66 | 67 | instance {-# OVERLAPPING #-} 68 | ( MonadReader tag r m, trans ~ IdentityT 69 | ) => Mtl.MonadReader r (TaggedTrans (TAG_ATTACH tag) trans m) 70 | where 71 | ask = ask @tag 72 | local = local @tag 73 | reader = reader @tag 74 | 75 | instance {-# OVERLAPPING #-} 76 | ( MonadState tag s m, trans ~ IdentityT 77 | ) => Mtl.MonadState s (TaggedTrans (TAG_ATTACH tag) trans m) 78 | where 79 | get = get @tag 80 | put = put @tag 81 | state = state @tag 82 | 83 | instance {-# OVERLAPPING #-} 84 | ( MonadExcept tag e m, trans ~ IdentityT 85 | ) => Mtl.MonadError e (TaggedTrans (TAG_ATTACH tag) trans m) 86 | where 87 | throwError = throw @tag 88 | catchError = catch @tag 89 | 90 | instance {-# OVERLAPPING #-} 91 | ( MonadWriter tag w m, trans ~ IdentityT 92 | ) => Mtl.MonadWriter w (TaggedTrans (TAG_ATTACH tag) trans m) 93 | where 94 | writer = writer @tag 95 | tell = tell @tag 96 | listen = listen @tag 97 | pass = pass @tag 98 | 99 | -- | Encode type-level information for 'tagReplace'. 100 | data TAG_REPLACE tOld tNew 101 | 102 | type TagReplaceT tOld tNew = TaggedTrans (TAG_REPLACE tOld tNew) IdentityT 103 | 104 | -- | Replace a tag with another tag. 105 | tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a 106 | tagReplace = coerce (runIdentityT @_ @m @a) 107 | 108 | instance 109 | ( MonadReader tNew r m, trans ~ IdentityT 110 | ) => MonadReader tOld r (TaggedTrans (TAG_REPLACE tOld tNew) trans m) 111 | where 112 | ask = ask @tNew 113 | local = local @tNew 114 | reader = reader @tNew 115 | 116 | instance 117 | ( MonadState tNew s m, trans ~ IdentityT 118 | ) => MonadState tOld s (TaggedTrans (TAG_REPLACE tOld tNew) trans m) 119 | where 120 | get = get @tNew 121 | put = put @tNew 122 | state = state @tNew 123 | 124 | instance 125 | ( MonadExcept tNew e m, trans ~ IdentityT 126 | ) => MonadExcept tOld e (TaggedTrans (TAG_REPLACE tOld tNew) trans m) 127 | where 128 | throw = throw @tNew 129 | catch = catch @tNew 130 | 131 | instance 132 | ( MonadWriter tNew w m, trans ~ IdentityT 133 | ) => MonadWriter tOld w (TaggedTrans (TAG_REPLACE tOld tNew) trans m) 134 | where 135 | writer = writer @tNew 136 | tell = tell @tNew 137 | listen = listen @tNew 138 | pass = pass @tNew 139 | -------------------------------------------------------------------------------- /src/Ether/TaggedTrans.hs: -------------------------------------------------------------------------------- 1 | -- The use of ImpredicativeTypes here is safe, see discussion under GitHub issue 2 | -- #35. It's only needed to allow the visible type application of a polytype. 3 | {-# LANGUAGE ImpredicativeTypes #-} 4 | 5 | module Ether.TaggedTrans 6 | ( TaggedTrans(..) 7 | ) where 8 | 9 | import Control.Applicative 10 | import Control.Monad (MonadPlus) 11 | import Control.Monad.Fix (MonadFix) 12 | import Control.Monad.Trans.Class (MonadTrans, lift) 13 | import Control.Monad.IO.Class (MonadIO) 14 | import Control.Monad.Morph (MFunctor(..), MMonad(..)) 15 | import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) 16 | 17 | import qualified Control.Monad.Base as MB 18 | import qualified Control.Monad.Trans.Control as MC 19 | 20 | import qualified Control.Monad.Trans.Lift.StT as Lift 21 | import qualified Control.Monad.Trans.Lift.Local as Lift 22 | import qualified Control.Monad.Trans.Lift.Catch as Lift 23 | import qualified Control.Monad.Trans.Lift.Listen as Lift 24 | import qualified Control.Monad.Trans.Lift.Pass as Lift 25 | import qualified Control.Monad.Trans.Lift.CallCC as Lift 26 | 27 | import qualified Control.Monad.Cont.Class as Mtl 28 | import qualified Control.Monad.Reader.Class as Mtl 29 | import qualified Control.Monad.State.Class as Mtl 30 | import qualified Control.Monad.Writer.Class as Mtl 31 | import qualified Control.Monad.Error.Class as Mtl 32 | 33 | import GHC.Generics (Generic) 34 | import Data.Coerce (coerce) 35 | 36 | newtype TaggedTrans tag trans m a = TaggedTrans (trans m a) 37 | deriving 38 | ( Generic 39 | , Functor, Applicative, Alternative, Monad, MonadPlus 40 | , MonadFix, MonadTrans, MonadIO 41 | , MonadThrow, MonadCatch, MonadMask ) 42 | 43 | type Pack tag trans m a = trans m a -> TaggedTrans tag trans m a 44 | 45 | type Unpack tag trans m a = TaggedTrans tag trans m a -> trans m a 46 | 47 | instance 48 | ( MB.MonadBase b (trans m) 49 | ) => MB.MonadBase b (TaggedTrans tag trans m) 50 | where 51 | liftBase = 52 | (coerce :: forall a . 53 | (b a -> trans m a) -> 54 | (b a -> TaggedTrans tag trans m a)) 55 | MB.liftBase 56 | 57 | instance 58 | ( MC.MonadTransControl trans 59 | ) => MC.MonadTransControl (TaggedTrans tag trans) 60 | where 61 | type StT (TaggedTrans tag trans) a = MC.StT trans a 62 | 63 | liftWith = MC.defaultLiftWith 64 | (coerce :: Pack tag trans m a) 65 | (coerce :: Unpack tag trans m a) 66 | 67 | restoreT = MC.defaultRestoreT 68 | (coerce :: Pack tag trans m a) 69 | 70 | type LiftBaseWith b m a = (MC.RunInBase m b -> b a) -> m a 71 | 72 | newtype LiftBaseWith' b m a = LBW { unLBW :: LiftBaseWith b m a } 73 | 74 | coerceLiftBaseWith :: 75 | LiftBaseWith b (trans m) a -> 76 | LiftBaseWith b (TaggedTrans tag trans m) a 77 | coerceLiftBaseWith lbw = 78 | unLBW (coerce (LBW lbw)) 79 | 80 | instance 81 | ( MC.MonadBaseControl b (trans m) 82 | ) => MC.MonadBaseControl b (TaggedTrans tag trans m) 83 | where 84 | type StM (TaggedTrans tag trans m) a = MC.StM (trans m) a 85 | 86 | liftBaseWith = coerceLiftBaseWith MC.liftBaseWith 87 | 88 | restoreM = 89 | (coerce :: forall a . 90 | (MC.StM (trans m) a -> trans m a) -> 91 | (MC.StM (trans m) a -> TaggedTrans tag trans m a)) 92 | MC.restoreM 93 | 94 | type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a 95 | 96 | instance Lift.LiftLocal trans => Lift.LiftLocal (TaggedTrans tag trans) where 97 | liftLocal = 98 | Lift.defaultLiftLocal 99 | (coerce :: Pack tag trans m a) 100 | (coerce :: Unpack tag trans m a) 101 | 102 | instance Lift.LiftCatch trans => Lift.LiftCatch (TaggedTrans tag trans) where 103 | liftCatch = 104 | Lift.defaultLiftCatch 105 | (coerce :: Pack tag trans m a) 106 | (coerce :: Unpack tag trans m a) 107 | 108 | instance Lift.LiftListen trans => Lift.LiftListen (TaggedTrans tag trans) where 109 | liftListen = 110 | Lift.defaultLiftListen 111 | (coerce :: Pack tag trans m a) 112 | (coerce :: Unpack tag trans m a) 113 | 114 | instance Lift.LiftPass trans => Lift.LiftPass (TaggedTrans tag trans) where 115 | liftPass = 116 | Lift.defaultLiftPass 117 | (coerce :: Pack tag trans m a) 118 | (coerce :: Unpack tag trans m a) 119 | 120 | instance Lift.LiftCallCC trans => Lift.LiftCallCC (TaggedTrans tag trans) where 121 | liftCallCC = 122 | Lift.defaultLiftCallCC 123 | (coerce :: Pack tag trans m a) 124 | (coerce :: Unpack tag trans m a) 125 | liftCallCC' = 126 | Lift.defaultLiftCallCC' 127 | (coerce :: Pack tag trans m a) 128 | (coerce :: Unpack tag trans m a) 129 | 130 | 131 | -- Instances for mtl classes 132 | 133 | instance 134 | ( Mtl.MonadCont m 135 | , Lift.LiftCallCC trans 136 | , Monad (trans m) 137 | ) => Mtl.MonadCont (TaggedTrans tag trans m) 138 | where 139 | callCC = Lift.liftCallCC' Mtl.callCC 140 | 141 | instance 142 | ( Mtl.MonadReader r m 143 | , Lift.LiftLocal trans 144 | , Monad (trans m) 145 | ) => Mtl.MonadReader r (TaggedTrans tag trans m) 146 | where 147 | ask = lift Mtl.ask 148 | local = Lift.liftLocal Mtl.ask Mtl.local 149 | reader = lift . Mtl.reader 150 | 151 | instance 152 | ( Mtl.MonadState s m 153 | , MonadTrans trans 154 | , Monad (trans m) 155 | ) => Mtl.MonadState s (TaggedTrans tag trans m) 156 | where 157 | get = lift Mtl.get 158 | put = lift . Mtl.put 159 | state = lift . Mtl.state 160 | 161 | instance 162 | ( Mtl.MonadWriter w m 163 | , Lift.LiftListen trans 164 | , Lift.LiftPass trans 165 | , Monad (trans m) 166 | ) => Mtl.MonadWriter w (TaggedTrans tag trans m) 167 | where 168 | writer = lift . Mtl.writer 169 | tell = lift . Mtl.tell 170 | listen = Lift.liftListen Mtl.listen 171 | pass = Lift.liftPass Mtl.pass 172 | 173 | instance 174 | ( Mtl.MonadError e m 175 | , Lift.LiftCatch trans 176 | , Monad (trans m) 177 | ) => Mtl.MonadError e (TaggedTrans tag trans m) 178 | where 179 | throwError = lift . Mtl.throwError 180 | catchError = Lift.liftCatch Mtl.catchError 181 | 182 | type Hoist trans = 183 | forall m n b . Monad m => 184 | (forall a . m a -> n a) -> trans m b -> trans n b 185 | 186 | -- NB: Don't use GeneralizedNewtypeDeriving to create this instance, as it will 187 | -- trigger GHC Trac #11837 on GHC 8.0.1 and older. 188 | instance MFunctor trans => MFunctor (TaggedTrans tag trans) where 189 | hoist = 190 | coerce 191 | @(Hoist trans) 192 | @(Hoist (TaggedTrans tag trans)) 193 | hoist 194 | 195 | type Embed trans = 196 | forall n m b . Monad n => 197 | (forall a . m a -> trans n a) -> trans m b -> trans n b 198 | 199 | -- NB: Don't use GeneralizedNewtypeDeriving to create this instance, as it will 200 | -- trigger GHC Trac #11837 on GHC 8.0.1 and older. 201 | instance MMonad trans => MMonad (TaggedTrans tag trans) where 202 | embed = 203 | coerce 204 | @(Embed trans) 205 | @(Embed (TaggedTrans tag trans)) 206 | embed 207 | -------------------------------------------------------------------------------- /src/Ether/Writer.hs: -------------------------------------------------------------------------------- 1 | module Ether.Writer 2 | ( 3 | -- * MonadWriter class 4 | MonadWriter 5 | , writer 6 | , tell 7 | , listen 8 | , pass 9 | , listens 10 | , censor 11 | -- * The Writer monad 12 | , Writer 13 | , runWriter 14 | , execWriter 15 | -- * The WriterT monad transformer 16 | , WriterT 17 | , writerT 18 | , runWriterT 19 | , execWriterT 20 | -- * The Writer monad (lazy) 21 | , LazyWriter 22 | , runLazyWriter 23 | , execLazyWriter 24 | -- * The WriterT monad transformer (lazy) 25 | , LazyWriterT 26 | , lazyWriterT 27 | , runLazyWriterT 28 | , execLazyWriterT 29 | -- * MonadWriter class (implicit) 30 | , MonadWriter' 31 | , writer' 32 | , tell' 33 | , listen' 34 | , pass' 35 | , listens' 36 | , censor' 37 | -- * The Writer monad (implicit) 38 | , Writer' 39 | , runWriter' 40 | , execWriter' 41 | -- * The WriterT monad transformer (implicit) 42 | , WriterT' 43 | , writerT' 44 | , runWriterT' 45 | , execWriterT' 46 | -- * The Writer monad (lazy, implicit) 47 | , LazyWriter' 48 | , runLazyWriter' 49 | , execLazyWriter' 50 | -- * The WriterT monad transformer (lazy, implicit) 51 | , LazyWriterT' 52 | , lazyWriterT' 53 | , runLazyWriterT' 54 | , execLazyWriterT' 55 | -- * Internal labels 56 | , TAGGED 57 | , WRITER 58 | ) where 59 | 60 | import Control.Monad.Signatures (Listen, Pass) 61 | import qualified Control.Monad.Trans.Lift.Listen as Lift 62 | import qualified Control.Monad.Trans.Lift.Pass as Lift 63 | import qualified Control.Monad.Writer.Class as T 64 | import qualified Control.Monad.Writer.CPS as T.CPS 65 | import qualified Control.Monad.Writer.Lazy as T.Lazy 66 | import Data.Coerce 67 | import Data.Functor.Identity 68 | 69 | import Ether.Internal 70 | import Ether.TaggedTrans 71 | 72 | class (Monoid w, Monad m) => MonadWriter tag w m | m tag -> w where 73 | 74 | {-# MINIMAL (writer | tell), listen, pass #-} 75 | 76 | -- | Embed a simple writer action. 77 | writer :: (a, w) -> m a 78 | writer ~(a, w) = a <$ tell @tag w 79 | 80 | -- | Append a value to the accumulator within the monad. 81 | tell :: w -> m () 82 | tell w = writer @tag ((),w) 83 | 84 | -- | Execute an action and add its accumulator 85 | -- to the value of the computation. 86 | listen :: m a -> m (a, w) 87 | 88 | -- | Execute an action which returns a value and a function, 89 | -- and return the value, applying the function to the accumulator. 90 | pass :: m (a, w -> w) -> m a 91 | 92 | instance {-# OVERLAPPABLE #-} 93 | ( Lift.LiftListen t 94 | , Lift.LiftPass t 95 | , Monad (t m) 96 | , MonadWriter tag w m 97 | , Monoid w 98 | ) => MonadWriter tag w (t m) where 99 | writer = Lift.lift . writer @tag 100 | tell = Lift.lift . tell @tag 101 | listen = Lift.liftListen (listen @tag) 102 | pass = Lift.liftPass (pass @tag) 103 | 104 | -- | Execute an action and add the result of applying the given function to 105 | -- its accumulator to the value of the computation. 106 | listens :: forall tag w m a b . MonadWriter tag w m => (w -> b) -> m a -> m (a, b) 107 | listens f m = do 108 | ~(a, w) <- listen @tag m 109 | return (a, f w) 110 | 111 | -- | Execute an action and apply a function to its accumulator. 112 | censor :: forall tag w m a . MonadWriter tag w m => (w -> w) -> m a -> m a 113 | censor f m = pass @tag $ do 114 | a <- m 115 | return (a, f) 116 | 117 | -- | Encode type-level information for 'WriterT'. 118 | data WRITER 119 | 120 | type instance HandleSuper WRITER w trans = Monoid w 121 | type instance HandleConstraint WRITER w trans m = 122 | T.MonadWriter w (trans m) 123 | 124 | instance Monoid w => Handle WRITER w (T.CPS.WriterT w) where 125 | handling r = r 126 | 127 | instance Monoid w => Handle WRITER w (T.Lazy.WriterT w) where 128 | handling r = r 129 | 130 | instance 131 | ( Handle WRITER w trans 132 | , Monad m, Monad (trans m) 133 | ) => MonadWriter tag w (TaggedTrans (TAGGED WRITER tag) trans m) 134 | where 135 | 136 | writer = 137 | handling @WRITER @w @trans @m $ 138 | coerce (T.writer @w @(trans m) @a) :: 139 | forall eff a . (a, w) -> TaggedTrans eff trans m a 140 | 141 | tell = 142 | handling @WRITER @w @trans @m $ 143 | coerce (T.tell @w @(trans m)) 144 | 145 | listen = 146 | handling @WRITER @w @trans @m $ 147 | coerce (T.listen @w @(trans m) @a) :: 148 | forall eff a . Listen w (TaggedTrans eff trans m) a 149 | 150 | pass = 151 | handling @WRITER @w @trans @m $ 152 | coerce (T.pass @w @(trans m) @a) :: 153 | forall eff a . Pass w (TaggedTrans eff trans m) a 154 | 155 | -- | The parametrizable writer monad. 156 | -- 157 | -- Computations can accumulate a monoid value. 158 | -- 159 | -- The 'return' function produces the output 'mempty', while '>>=' combines 160 | -- the outputs of the subcomputations using 'mappend'. 161 | type Writer tag w = WriterT tag w Identity 162 | 163 | -- | The writer monad transformer. 164 | -- 165 | -- The 'return' function produces the output 'mempty', while '>>=' combines 166 | -- the outputs of the subcomputations using 'mappend'. 167 | type WriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.CPS.WriterT w) 168 | 169 | -- | Constructor for computations in the writer monad transformer. 170 | writerT :: forall tag w m a . (Functor m, Monoid w) => m (a, w) -> WriterT tag w m a 171 | writerT = coerce (T.CPS.writerT @m @w @a) 172 | 173 | -- | Runs a 'WriterT' and returns both the normal value 174 | -- and the final accumulator. 175 | runWriterT :: forall tag w m a . Monoid w => WriterT tag w m a -> m (a, w) 176 | runWriterT = coerce (T.CPS.runWriterT @w @m @a) 177 | 178 | -- | Runs a 'Writer' and returns both the normal value 179 | -- and the final accumulator. 180 | runWriter :: forall tag w a . Monoid w => Writer tag w a -> (a, w) 181 | runWriter = coerce (T.CPS.runWriter @w @a) 182 | 183 | -- | Runs a 'WriterT' and returns the final accumulator, 184 | -- discarding the normal value. 185 | execWriterT :: forall tag w m a . (Monad m, Monoid w) => WriterT tag w m a -> m w 186 | execWriterT = coerce (T.CPS.execWriterT @m @w @a) 187 | 188 | -- | Runs a 'Writer' and returns the final accumulator, 189 | -- discarding the normal value. 190 | execWriter :: forall tag w a . Monoid w => Writer tag w a -> w 191 | execWriter = coerce (T.CPS.execWriter @w @a) 192 | 193 | -- | The parametrizable writer monad. 194 | -- 195 | -- Computations can accumulate a monoid value. 196 | -- 197 | -- The 'return' function produces the output 'mempty', while '>>=' combines 198 | -- the outputs of the subcomputations using 'mappend'. 199 | type LazyWriter tag w = LazyWriterT tag w Identity 200 | 201 | -- | The writer monad transformer. 202 | -- 203 | -- The 'return' function produces the output 'mempty', while '>>=' combines 204 | -- the outputs of the subcomputations using 'mappend'. 205 | type LazyWriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.Lazy.WriterT w) 206 | 207 | -- | Constructor for computations in the writer monad transformer. 208 | lazyWriterT :: forall tag w m a . m (a, w) -> LazyWriterT tag w m a 209 | lazyWriterT = coerce (T.Lazy.WriterT @w @m @a) 210 | 211 | -- | Runs a 'WriterT' and returns both the normal value 212 | -- and the final accumulator. 213 | runLazyWriterT :: forall tag w m a . LazyWriterT tag w m a -> m (a, w) 214 | runLazyWriterT = coerce (T.Lazy.runWriterT @w @m @a) 215 | 216 | -- | Runs a 'Writer' and returns both the normal value 217 | -- and the final accumulator. 218 | runLazyWriter :: forall tag w a . LazyWriter tag w a -> (a, w) 219 | runLazyWriter = coerce (T.Lazy.runWriter @w @a) 220 | 221 | -- | Runs a 'WriterT' and returns the final accumulator, 222 | -- discarding the normal value. 223 | execLazyWriterT :: forall tag w m a . Monad m => LazyWriterT tag w m a -> m w 224 | execLazyWriterT = coerce (T.Lazy.execWriterT @m @w @a) 225 | 226 | -- | Runs a 'Writer' and returns the final accumulator, 227 | -- discarding the normal value. 228 | execLazyWriter :: forall tag w a . LazyWriter tag w a -> w 229 | execLazyWriter = coerce (T.Lazy.execWriter @w @a) 230 | 231 | type Writer' w = Writer w w 232 | 233 | runWriter' :: Monoid w => Writer' w a -> (a, w) 234 | runWriter' = runWriter 235 | 236 | execWriter' :: Monoid w => Writer' w a -> w 237 | execWriter' = execWriter 238 | 239 | type WriterT' w = WriterT w w 240 | 241 | writerT' :: (Functor m, Monoid w) => m (a, w) -> WriterT' w m a 242 | writerT' = writerT 243 | 244 | runWriterT' :: Monoid w => WriterT' w m a -> m (a, w) 245 | runWriterT' = runWriterT 246 | 247 | execWriterT' :: (Monad m, Monoid w) => WriterT' w m a -> m w 248 | execWriterT' = execWriterT 249 | 250 | type LazyWriter' w = LazyWriter w w 251 | 252 | runLazyWriter' :: LazyWriter' w a -> (a, w) 253 | runLazyWriter' = runLazyWriter 254 | 255 | execLazyWriter' :: LazyWriter' w a -> w 256 | execLazyWriter' = execLazyWriter 257 | 258 | type LazyWriterT' w = LazyWriterT w w 259 | 260 | lazyWriterT' :: m (a, w) -> LazyWriterT' w m a 261 | lazyWriterT' = lazyWriterT 262 | 263 | runLazyWriterT' :: LazyWriterT' w m a -> m (a, w) 264 | runLazyWriterT' = runLazyWriterT 265 | 266 | execLazyWriterT' :: Monad m => LazyWriterT' w m a -> m w 267 | execLazyWriterT' = execLazyWriterT 268 | 269 | type MonadWriter' w = MonadWriter w w 270 | 271 | writer' :: forall w m a . MonadWriter' w m => (a, w) -> m a 272 | writer' = writer @w 273 | 274 | tell' :: forall w m . MonadWriter' w m => w -> m () 275 | tell' = tell @w 276 | 277 | listen' :: forall w m a . MonadWriter' w m => m a -> m (a, w) 278 | listen' = listen @w 279 | 280 | pass' :: forall w m a . MonadWriter' w m => m (a, w -> w) -> m a 281 | pass' = pass @w 282 | 283 | listens' :: forall w m a b . MonadWriter' w m => (w -> b) -> m a -> m (a, b) 284 | listens' = listens @w 285 | 286 | censor' :: forall w m a . MonadWriter' w m => (w -> w) -> m a -> m a 287 | censor' = censor @w 288 | -------------------------------------------------------------------------------- /test/Regression.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Tasty 4 | 5 | import Regression.T1 6 | import Regression.T2 7 | import Regression.T3 8 | import Regression.T4 9 | import Regression.T5 10 | import Regression.T6 11 | import Regression.T7 12 | import Regression.T8 13 | import Regression.T9 14 | import Regression.T10 15 | import Regression.T11 16 | import Regression.T12 17 | 18 | main :: IO () 19 | main = defaultMain suite 20 | 21 | suite :: TestTree 22 | suite = testGroup "Ether" 23 | [ test1 24 | , test2 25 | , test3 26 | , test4 27 | , test5 28 | , test6 29 | , test7 30 | , test8 31 | , test9 32 | , test10 33 | , test11 34 | , test12 35 | ] 36 | -------------------------------------------------------------------------------- /test/Regression/T1.hs: -------------------------------------------------------------------------------- 1 | module Regression.T1 (test1) where 2 | 3 | import Ether 4 | import TupleInstances () 5 | import Data.List (group) 6 | 7 | import Test.Tasty 8 | import Test.Tasty.QuickCheck 9 | 10 | data Tag1 11 | data Tag2 12 | 13 | testEther 14 | :: (MonadReader Tag1 String m, MonadReader Tag2 String m) 15 | => m ((String, String), (String, String)) 16 | testEther = do 17 | s1 <- ask @Tag1 18 | s2 <- ask @Tag2 19 | let s1s2 = (s1, s2) 20 | s1s2' <- local @Tag2 (map succ) $ do 21 | s1' <- ask @Tag1 22 | s2' <- ask @Tag2 23 | return (s1', s2') 24 | return (s1s2, s1s2') 25 | 26 | runner1 s1 s2 = flip (runReader @Tag1) s1 . flip (runReaderT @Tag2) s2 27 | runner2 s1 s2 = flip (runReader @Tag2) s2 . flip (runReaderT @Tag1) s1 28 | runner3 s1 s2 = flip runReaders (Tagged @Tag1 s1, Tagged @Tag2 s2) 29 | 30 | same :: Eq a => [a] -> Bool 31 | same = (<=1) . length . group 32 | 33 | test1 :: TestTree 34 | test1 = testGroup "T1: Reader local environment" 35 | [ testProperty "runner₁ works" 36 | $ \s1 s2 -> property 37 | $ runner1 s1 s2 testEther == ((s1, s2), (s1, map succ s2)) 38 | , testProperty "runner₂ works" 39 | $ \s1 s2 -> property 40 | $ runner2 s1 s2 testEther == ((s1, s2), (s1, map succ s2)) 41 | , testProperty "runner₃ works" 42 | $ \s1 s2 -> property 43 | $ runner3 s1 s2 testEther == ((s1, s2), (s1, map succ s2)) 44 | , testProperty "runner₁ == runner₂ == runner₃" 45 | $ \s1 s2 -> property 46 | $ same 47 | [ runner1 s1 s2 testEther 48 | , runner2 s1 s2 testEther 49 | , runner3 s1 s2 testEther ] 50 | ] 51 | -------------------------------------------------------------------------------- /test/Regression/T10.hs: -------------------------------------------------------------------------------- 1 | module Regression.T10 (test10) where 2 | 3 | import Control.Applicative 4 | import Data.Functor.Identity 5 | 6 | import Ether 7 | 8 | import Test.Tasty 9 | import Test.Tasty.QuickCheck 10 | 11 | testEther :: Integer -> StateT' Integer Maybe [Integer] 12 | testEther m = range 13 | where 14 | range = liftA2 (:) yield (range <|> pure []) 15 | yield = stateT' $ \n -> do 16 | guard (n <= m) 17 | Just (n, n + 1) 18 | 19 | testEther' :: Integer -> State' Integer [Integer] 20 | testEther' m = 21 | stateT' $ Identity . maybe ([], m + 1) id . runStateT' (testEther m) 22 | 23 | next1 :: Integer -> Integer -> Maybe Integer 24 | next1 m n 25 | | n <= m = Just (m + 1) 26 | | otherwise = Nothing 27 | 28 | range1 :: Integer -> Integer -> Maybe [Integer] 29 | range1 m n 30 | | n <= m = Just [n..m] 31 | | otherwise = Nothing 32 | 33 | test10 :: TestTree 34 | test10 = testGroup "T10: Alternative instance" 35 | [ testProperty "execStateT works" 36 | $ \m n -> execStateT' (testEther m) n == next1 m n 37 | , testProperty "evalStateT works" 38 | $ \m n -> evalStateT' (testEther m) n == range1 m n 39 | , testProperty "execState works" 40 | $ \m n -> execState' (testEther' m) n == m + 1 41 | , testProperty "evalState works" 42 | $ \m n -> evalState' (testEther' m) n == [n..m] 43 | ] 44 | -------------------------------------------------------------------------------- /test/Regression/T11.hs: -------------------------------------------------------------------------------- 1 | module Regression.T11 (test11) where 2 | 3 | import Ether 4 | 5 | import Data.Bool 6 | import qualified Control.Monad.State as T 7 | import qualified Control.Monad.Reader as T 8 | 9 | import Test.Tasty 10 | import Test.Tasty.QuickCheck 11 | 12 | data STag 13 | 14 | testEther 15 | :: ( MonadState STag [Integer] m 16 | , T.MonadState Bool m 17 | , T.MonadReader Integer m ) 18 | => m () 19 | testEther = do 20 | T.modify not 21 | f <- bool negate id <$> T.get 22 | n <- T.ask 23 | T.local succ testEther 24 | modify @STag (f n:) 25 | 26 | model :: Integer -> [Integer] 27 | model n = zipWith ($) (cycle [id, negate]) [n..] 28 | 29 | runner1 n 30 | = flip (T.runReader) n 31 | . flip (execLazyStateT @STag) [] 32 | . flip T.evalStateT False 33 | 34 | runner2 n 35 | = flip T.evalState False 36 | . flip (execLazyStateT @STag) [] 37 | . flip T.runReaderT n 38 | 39 | test11 :: TestTree 40 | test11 = testGroup "T11: Lazy sequence" 41 | [ testProperty "runner₁ works" 42 | $ \l n -> property 43 | $ take l (runner1 n testEther) == take l (model n) 44 | , testProperty "runner₂ works" 45 | $ \l n -> property 46 | $ take l (runner2 n testEther) == take l (model n) 47 | , testProperty "runner₁ == runner₂" 48 | $ \l n -> property 49 | $ take l (runner1 n testEther) == take l (runner2 n testEther) 50 | ] 51 | -------------------------------------------------------------------------------- /test/Regression/T12.hs: -------------------------------------------------------------------------------- 1 | module Regression.T12 (test12) where 2 | 3 | import Ether 4 | import Control.Lens 5 | 6 | import Test.Tasty 7 | import Test.Tasty.QuickCheck 8 | 9 | data Foo 10 | 11 | succState :: Enum a => MonadState Foo a m => m () 12 | succState = modify @Foo succ 13 | 14 | testEther :: (Enum a, MonadState Foo (a, a) m) => m (a, a) 15 | testEther = do 16 | Ether.zoom @Foo _1 succState 17 | Ether.zoom @Foo _2 $ modify @Foo pred 18 | get @Foo 19 | 20 | model :: Enum a => (a, a) -> (a, a) 21 | model (a1, a2) = (succ a1, pred a2) 22 | 23 | runner = evalState @Foo 24 | 25 | test12 :: TestTree 26 | test12 = testGroup "T12: State zooming" 27 | [ testProperty "runner works" 28 | $ \(a1 :: Integer, a2 :: Integer) -> property 29 | $ runner testEther (a1, a2) == model (a1, a2) 30 | ] 31 | -------------------------------------------------------------------------------- /test/Regression/T2.hs: -------------------------------------------------------------------------------- 1 | module Regression.T2 (test2) where 2 | 3 | import Ether 4 | 5 | import Test.Tasty 6 | import Test.Tasty.QuickCheck 7 | 8 | testEther :: (MonadReader' Integer m, MonadReader' Bool m) => m String 9 | testEther = local' (succ :: Integer -> Integer) $ do 10 | n :: Integer <- asks' (*2) 11 | b <- local' not ask' 12 | return (if b then "" else show n) 13 | 14 | runner1 (n :: Integer) = flip runReader' n . flip runReaderT' True 15 | runner2 (n :: Integer) = flip runReader' True . flip runReaderT' n 16 | 17 | test2 :: TestTree 18 | test2 = testGroup "T2: Implicit tags" 19 | [ testProperty "runner₁ works" 20 | $ \n -> property 21 | $ runner1 n testEther == show (succ n * 2) 22 | , testProperty "runner₂ works" 23 | $ \n -> property 24 | $ runner2 n testEther == show (succ n * 2) 25 | , testProperty "runner₁ == runner₂" 26 | $ \n -> property 27 | $ runner1 n testEther == runner2 n testEther 28 | ] 29 | -------------------------------------------------------------------------------- /test/Regression/T3.hs: -------------------------------------------------------------------------------- 1 | module Regression.T3 (test3) where 2 | 3 | import Ether 4 | 5 | import qualified Control.Monad.Reader as T 6 | import qualified Control.Monad.State as T 7 | 8 | import Test.Tasty 9 | import Test.Tasty.QuickCheck 10 | 11 | data RTag 12 | data STag 13 | 14 | testMTL :: (T.MonadReader Int m, T.MonadState Int m) => m Int 15 | testMTL = do 16 | b <- T.get 17 | a <- T.ask 18 | T.put (a + b) 19 | return (a * b) 20 | 21 | testEther 22 | :: (MonadReader STag Int m, MonadState STag Int m, MonadReader RTag Int m) 23 | => m (Int, Int, Int) 24 | testEther = local @RTag (*2) $ do 25 | a_mul_b <- tagAttach @STag testMTL 26 | a_add_b <- get @STag 27 | modify @STag negate 28 | c <- ask @RTag 29 | return (a_mul_b, a_add_b, c) 30 | 31 | runner1 s r 32 | = flip (runReader @RTag) (negate r) 33 | . flip (runReaderT @STag) r 34 | . flip (runStateT @STag) s 35 | runner2 s r 36 | = flip (runReader @RTag) (negate r) 37 | . flip (runStateT @STag) s 38 | . flip (runReaderT @STag) r 39 | 40 | test3 :: TestTree 41 | test3 = testGroup "T3: Tag attachement" 42 | [ testProperty "runner₁ works" 43 | $ \s r -> property 44 | $ (==) 45 | (runner1 s r testEther) 46 | ((s * r, s + r, negate r * 2), negate (s + r)) 47 | , testProperty "runner₂ works" 48 | $ \s r -> property 49 | $ (==) 50 | (runner2 s r testEther) 51 | ((s * r, s + r, negate r * 2), negate (s + r)) 52 | , testProperty "runner₁ == runner₂" 53 | $ \s r -> property 54 | $ runner1 s r testEther == runner2 s r testEther 55 | ] 56 | -------------------------------------------------------------------------------- /test/Regression/T4.hs: -------------------------------------------------------------------------------- 1 | module Regression.T4 (test4) where 2 | 3 | import Ether 4 | 5 | import Test.Tasty 6 | import Test.Tasty.QuickCheck 7 | 8 | data RTag 9 | 10 | testEther :: MonadReader RTag Int m => m Int 11 | testEther = ask @RTag 12 | 13 | runner r 14 | = flip (runReader @RTag) (r' :: Int) 15 | . flip (runReaderT @RTag) (r :: Int) 16 | where 17 | r' = negate r 18 | 19 | test4 :: TestTree 20 | test4 = testGroup "T4: Nested same-tag readers" 21 | [ testProperty "runner works" 22 | $ \r -> property 23 | $ runner r testEther == r 24 | ] 25 | -------------------------------------------------------------------------------- /test/Regression/T5.hs: -------------------------------------------------------------------------------- 1 | module Regression.T5 (test5) where 2 | 3 | import Ether 4 | 5 | import Test.Tasty 6 | import Test.Tasty.QuickCheck 7 | 8 | newtype Counter = Counter Int 9 | deriving (Eq, Ord, Num, Enum) 10 | 11 | incCounter :: Counter -> Counter 12 | incCounter = succ 13 | 14 | testEther 15 | :: (Num a, Ord a) 16 | => (MonadReader' a m, MonadState' Counter m) 17 | => m a 18 | testEther = do 19 | a <- ask' 20 | if a <= 0 21 | then do 22 | put' (0 :: Counter) 23 | return 1 24 | else do 25 | modify' incCounter -- overriden in the base case 26 | b <- runReaderT' testEther (a - 1) 27 | modify' incCounter 28 | return (a * b) 29 | 30 | runner :: (Num a, Ord a) => a -> (a, Counter) 31 | runner a = runState' (runReaderT' testEther a) (0 :: Counter) 32 | 33 | factorial :: (Num a, Enum a) => a -> a 34 | factorial a = product [1..a] 35 | 36 | test5 :: TestTree 37 | test5 = testGroup "T5: Factorial via Ether" 38 | [ testProperty "runner works" 39 | $ \n -> property 40 | $ let n' = fromIntegral n :: Integer 41 | in runner n' == (factorial n', max 0 (Counter n)) 42 | ] 43 | -------------------------------------------------------------------------------- /test/Regression/T6.hs: -------------------------------------------------------------------------------- 1 | module Regression.T6 (test6) where 2 | 3 | import Data.Function 4 | import Ether 5 | 6 | import Test.Tasty 7 | import Test.Tasty.QuickCheck 8 | 9 | data DivideByZero = DivideByZero 10 | deriving (Show) 11 | 12 | data NegativeLog a = NegativeLog a 13 | deriving (Show) 14 | 15 | testEther 16 | :: (Floating a, Ord a) 17 | => (MonadExcept' DivideByZero m, MonadExcept' (NegativeLog a) m) 18 | => a -> a -> m a 19 | testEther a b = do 20 | when (b == 0) (throw' DivideByZero) 21 | let d = a / b 22 | when (d < 0) (throw' (NegativeLog d)) 23 | return (log d) 24 | 25 | handleNegativeLog (NegativeLog (x :: Double)) = "nl: " ++ show x 26 | handleDivideByZero DivideByZero = "dz" 27 | 28 | handleT' :: Functor m => (e -> a) -> ExceptT' e m a -> m a 29 | handleT' h m = fmap (either h id) (runExceptT' m) 30 | 31 | runner1 :: Double -> Double -> String 32 | runner1 a b = do 33 | (show `fmap` testEther a b) 34 | & handleT' handleNegativeLog 35 | & handleT' handleDivideByZero 36 | & runIdentity 37 | 38 | runner2 :: Double -> Double -> String 39 | runner2 a b = do 40 | (show `fmap` testEther a b) 41 | & handleT' handleDivideByZero 42 | & handleT' handleNegativeLog 43 | & runIdentity 44 | 45 | logDiv :: Double -> Double -> String 46 | logDiv a b 47 | | b == 0 = "dz" 48 | | d < 0 = "nl: " ++ show d 49 | | otherwise = show (log d) 50 | where 51 | d = a / b 52 | 53 | test6 :: TestTree 54 | test6 = testGroup "T6: Checked exceptions" 55 | [ testProperty "runner₁ works" 56 | $ \a b -> property 57 | $ runner1 a b == logDiv a b 58 | , testProperty "runner₂ works" 59 | $ \a b -> property 60 | $ runner2 a b == logDiv a b 61 | , testProperty "runner₁ == runner₂" 62 | $ \a b -> property 63 | $ runner1 a b == runner2 a b 64 | ] 65 | -------------------------------------------------------------------------------- /test/Regression/T7.hs: -------------------------------------------------------------------------------- 1 | module Regression.T7 (test7) where 2 | 3 | import Data.Monoid 4 | import Control.Monad 5 | 6 | import Ether 7 | import qualified Control.Monad.Writer as T 8 | 9 | import Test.Tasty 10 | import Test.Tasty.QuickCheck 11 | 12 | data WTag 13 | 14 | testEther 15 | :: Num a 16 | => T.MonadWriter (Sum a) m 17 | => MonadWriter WTag (Sum a) m 18 | => [a] -> m () 19 | testEther xs = do 20 | forM_ xs $ \x -> do 21 | u1 <- T.tell (Sum x) 22 | u2 <- tell @WTag (Sum 1) 23 | when (u1 /= u2) $ error "Impossible" 24 | 25 | runner1 :: Num a => [a] -> (a, a) 26 | runner1 xs = 27 | let (s, c) = T.runWriter . execWriterT @WTag $ testEther xs 28 | in (getSum s, getSum c) 29 | 30 | runner2 :: Num a => [a] -> (a, a) 31 | runner2 xs = 32 | let (c, s) = runWriter @WTag . T.execWriterT $ testEther xs 33 | in (getSum s, getSum c) 34 | 35 | triangular :: Integral a => a -> a 36 | triangular n = div (n * (n + 1)) 2 37 | 38 | test7 :: TestTree 39 | test7 = testGroup "T7: Triangular via Ether" 40 | [ testProperty "runner₁ works" 41 | $ \n -> property 42 | $ let n' = abs n :: Integer 43 | in runner1 [1..n'] == (n', triangular n') 44 | , testProperty "runner₂ works" 45 | $ \n -> property 46 | $ let n' = abs n :: Integer 47 | in runner2 [1..n'] == (n', triangular n') 48 | , testProperty "runner₁ == runner₂" 49 | $ \(ns :: [Integer]) -> property 50 | $ runner1 ns == runner2 ns 51 | ] 52 | -------------------------------------------------------------------------------- /test/Regression/T8.hs: -------------------------------------------------------------------------------- 1 | module Regression.T8 (test8) where 2 | 3 | import Ether 4 | 5 | import qualified Control.Monad.State as T 6 | 7 | import Test.Tasty 8 | import Test.Tasty.QuickCheck 9 | 10 | data Foo 11 | data Bar 12 | 13 | testMTL1 :: T.MonadState Int m => m () 14 | testMTL1 = T.modify negate 15 | 16 | testMTL2 :: T.MonadState Bool m => m () 17 | testMTL2 = T.modify not 18 | 19 | testEther 20 | :: (MonadState Foo Int m, MonadState Bar Bool m) 21 | => m String 22 | testEther = do 23 | tagAttach @Foo testMTL1 24 | tagAttach @Bar testMTL2 25 | a <- gets @Foo show 26 | b <- gets @Bar show 27 | return (a ++ b) 28 | 29 | model :: Int -> Bool -> String 30 | model a b = show (negate a) ++ show (not b) 31 | 32 | runner1 a b 33 | = flip (evalState @Foo) a 34 | . flip (evalStateT @Bar) b 35 | 36 | runner2 a b 37 | = flip (evalState @Bar) b 38 | . flip (evalStateT @Foo) a 39 | 40 | test8 :: TestTree 41 | test8 = testGroup "T8: Multiple tag attachements" 42 | [ testProperty "runner₁ works" 43 | $ \a b -> property 44 | $ runner1 a b testEther == model a b 45 | , testProperty "runner₂ works" 46 | $ \a b -> property 47 | $ runner2 a b testEther == model a b 48 | , testProperty "runner₁ == runner₂" 49 | $ \a b -> property 50 | $ runner1 a b testEther == runner2 a b testEther 51 | ] 52 | -------------------------------------------------------------------------------- /test/Regression/T9.hs: -------------------------------------------------------------------------------- 1 | module Regression.T9 (test9) where 2 | 3 | import Ether 4 | 5 | import Test.Tasty 6 | import Test.Tasty.QuickCheck 7 | 8 | data Foo 9 | data Bar 10 | 11 | testEther1 :: MonadState Foo Int m => m String 12 | testEther1 = do 13 | modify @Foo negate 14 | gets @Foo show 15 | 16 | testEther2 :: MonadState Bar Int m => m String 17 | testEther2 = tagReplace @Foo @Bar testEther1 18 | 19 | testEther 20 | :: (MonadState Foo Int m, MonadState Bar Int m) 21 | => m String 22 | testEther = do 23 | a <- testEther1 24 | b <- testEther2 25 | return (a ++ b) 26 | 27 | model :: Int -> Int -> String 28 | model a b = show (negate a) ++ show (negate b) 29 | 30 | runner1 a b 31 | = flip (evalState @Foo) a 32 | . flip (evalStateT @Bar) b 33 | 34 | runner2 a b 35 | = flip (evalState @Bar) b 36 | . flip (evalStateT @Foo) a 37 | 38 | test9 :: TestTree 39 | test9 = testGroup "T9: Tag replacement" 40 | [ testProperty "runner₁ works" 41 | $ \a b -> property 42 | $ runner1 a b testEther == model a b 43 | , testProperty "runner₂ works" 44 | $ \a b -> property 45 | $ runner2 a b testEther == model a b 46 | , testProperty "runner₁ == runner₂" 47 | $ \a b -> property 48 | $ runner1 a b testEther == runner2 a b testEther 49 | ] 50 | -------------------------------------------------------------------------------- /test/TupleInstances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fno-warn-orphans #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | module TupleInstances () where 5 | 6 | #ifdef DISABLE_TUP_INSTANCES 7 | import Ether.Internal (makeTupleInstancesHasLens) 8 | makeTupleInstancesHasLens [2] 9 | #endif 10 | --------------------------------------------------------------------------------