├── .gitignore ├── Setup.hs ├── Control └── Monad │ ├── RSS.hs │ ├── Trans │ ├── RSS.hs │ └── RSS │ │ ├── Lazy.hs │ │ └── Strict.hs │ └── RSS │ ├── Lazy.hs │ └── Strict.hs ├── README.md ├── tests ├── spaceleak.hs └── rwscompare.hs ├── LICENSE ├── bench └── bench.hs ├── stateWriter.cabal ├── .travis.yml └── proof.v /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | stack.yaml 3 | dist 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Control/Monad/RSS.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- Declaration of the MonadRSS class. 3 | -- 4 | -- This is a variant of the classic "Control.Monad.RWS" transformer, 5 | -- where the Writer part rides with the State part. 6 | -- 7 | ----------------------------------------------------------------------------- 8 | 9 | module Control.Monad.RSS ( 10 | module Control.Monad.RSS.Strict 11 | ) where 12 | 13 | import Control.Monad.RSS.Strict 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # stateWriter 2 | 3 | [![Build Status](https://travis-ci.org/bartavelle/stateWriter.svg?branch=master)](https://travis-ci.org/bartavelle/stateWriter) 4 | [![stateWriter on Stackage LTS 3](http://stackage.org/package/stateWriter/badge/lts-3)](http://stackage.org/lts-3/package/stateWriter) 5 | [![stateWriter on Stackage Nightly](http://stackage.org/package/stateWriter/badge/nightly)](http://stackage.org/nightly/package/stateWriter) 6 | 7 | 8 | A rewrite of the `RWS` monad, where the `Writer` part is actually handled like strict state so that it doesn't leak memory. 9 | -------------------------------------------------------------------------------- /Control/Monad/Trans/RSS.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. 3 | -- This version is strict; for a lazy version, see 4 | -- "Control.Monad.Trans.RSS.Lazy", which has the same interface. 5 | -- 6 | -- This is a variant of the classic "Control.Monad.Trans.RWS" transformer, 7 | -- where the Writer part rides with the State part. 8 | ----------------------------------------------------------------------------- 9 | 10 | module Control.Monad.Trans.RSS ( 11 | module Control.Monad.Trans.RSS.Strict 12 | ) where 13 | 14 | import Control.Monad.Trans.RSS.Strict 15 | -------------------------------------------------------------------------------- /tests/spaceleak.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import qualified Control.Monad.Trans.RSS.Lazy as RSSL 5 | import qualified Control.Monad.Trans.RSS.Strict as RSSS 6 | import Control.Monad.Writer 7 | import Data.Monoid (Sum (..)) 8 | import System.Environment 9 | 10 | n :: Int 11 | n = 10000000 12 | 13 | main :: IO () 14 | main = do 15 | print $ RSSS.runRSS (replicateM_ n $ tell $ Sum (1 :: Int)) () () 16 | tryExplode <- fmap (not . null) getArgs 17 | if tryExplode 18 | then do 19 | putStrLn "Strict version ok, the next test should explode the stack." 20 | print $ RSSL.runRSS (replicateM_ n $ tell $ Sum (1 :: Int)) () () 21 | putStrLn "Lazy version should have exploded !" 22 | else putStrLn "Do not try exploding the stack. Run the test program with any command line argument to test it" 23 | -------------------------------------------------------------------------------- /Control/Monad/RSS/Lazy.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Lazy RSS monad. 4 | -- 5 | -- This is a variant of the classic "Control.Monad..RWS.Lazy" transformer, 6 | -- where the Writer part rides with the State part. 7 | -- 8 | ----------------------------------------------------------------------------- 9 | 10 | module Control.Monad.RSS.Lazy ( 11 | -- * The RSS monad 12 | RSS, 13 | rss, 14 | runRSS, 15 | evalRSS, 16 | execRSS, 17 | withRSS, 18 | -- * The RSST monad transformer 19 | RSST, 20 | runRSST, 21 | evalRSST, 22 | execRSST, 23 | withRSST, 24 | -- * Lazy Reader-writer-state monads 25 | module Control.Monad.RWS.Class, 26 | module Control.Monad, 27 | module Control.Monad.Fix, 28 | module Control.Monad.Trans, 29 | module Data.Monoid, 30 | ) where 31 | 32 | import Control.Monad.RWS.Class 33 | 34 | import Control.Monad.Trans 35 | import Control.Monad.Trans.RSS.Lazy ( 36 | RSS, rss, runRSS, evalRSS, execRSS, withRSS, 37 | RSST, evalRSST, execRSST, withRSST, runRSST) 38 | 39 | import Control.Monad 40 | import Control.Monad.Fix 41 | import Data.Monoid 42 | 43 | -------------------------------------------------------------------------------- /Control/Monad/RSS/Strict.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Strict RSS monad. 4 | -- 5 | -- This is a variant of the classic "Control.Monad..RWS.Strict" transformer, 6 | -- where the Writer part rides with the State part. 7 | -- 8 | ----------------------------------------------------------------------------- 9 | 10 | module Control.Monad.RSS.Strict ( 11 | -- * The RSS monad 12 | RSS, 13 | rss, 14 | runRSS, 15 | evalRSS, 16 | execRSS, 17 | withRSS, 18 | -- * The RSST monad transformer 19 | RSST, 20 | runRSST, 21 | evalRSST, 22 | execRSST, 23 | withRSST, 24 | -- * Strict Reader-writer-state monads 25 | module Control.Monad.RWS.Class, 26 | module Control.Monad, 27 | module Control.Monad.Fix, 28 | module Control.Monad.Trans, 29 | module Data.Monoid, 30 | ) where 31 | 32 | import Control.Monad.RWS.Class 33 | 34 | import Control.Monad.Trans 35 | import Control.Monad.Trans.RSS.Strict ( 36 | RSS, rss, runRSS, evalRSS, execRSS, withRSS, 37 | RSST, evalRSST, execRSST, withRSST, runRSST) 38 | 39 | import Control.Monad 40 | import Control.Monad.Fix 41 | import Data.Monoid 42 | 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Simon Marechal 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 Simon Marechal 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 | -------------------------------------------------------------------------------- /bench/bench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Main where 3 | 4 | import qualified Control.Monad.Trans.RSS.Lazy as RSSL 5 | import qualified Control.Monad.Trans.RSS.Strict as RSSS 6 | import qualified Control.Monad.Trans.RWS.Lazy as RWSL 7 | import qualified Control.Monad.Trans.RWS.Strict as RWSS 8 | 9 | import Criterion 10 | import Criterion.Main 11 | 12 | import qualified Data.Sequence as Seq 13 | import qualified Data.Vector.Primitive as VP 14 | import qualified Data.IntSet as IS 15 | import qualified Data.Set as S 16 | import qualified Data.DList as D 17 | 18 | import Control.Monad.RWS 19 | 20 | testActions :: (Monoid w, Monad m, MonadRWS () w Int m) => (Int -> m ()) -> m () 21 | testActions tellaction = do 22 | v <- get 23 | unless (v == 0) $ do 24 | put $! v - 1 25 | when (v `mod` 11 == 0) $ tellaction v 26 | testActions tellaction 27 | 28 | benchlen :: Int 29 | benchlen = 10000 30 | 31 | actions :: (Monoid w) => (Int -> w) -> [(String, Int -> ((), Int, w))] 32 | actions cnv = [ ("RSS.Lazy" , RSSL.runRSS (testActions (tell . cnv)) ()) 33 | , ("RSS.Strict", RSSS.runRSS (testActions (tell . cnv)) ()) 34 | , ("RWS.Lazy" , RWSL.runRWS (testActions (tell . cnv)) ()) 35 | , ("RWS.Strict", RWSS.runRWS (testActions (tell . cnv)) ()) 36 | ] 37 | 38 | main :: IO () 39 | main = defaultMain $ mkBench "Seq" Seq.singleton 40 | ++ mkBench "List" (:[]) 41 | ++ mkBench "Vector Primitive" VP.singleton 42 | ++ mkBench "IntSet" IS.singleton 43 | ++ mkBench "Set" S.singleton 44 | ++ mkBench "DList" D.singleton 45 | where 46 | mkBench n = map toBench . actions 47 | where 48 | toBench (n', a) = bench (n' ++ " [" ++ n ++ "]") $ nf a benchlen 49 | 50 | -------------------------------------------------------------------------------- /stateWriter.cabal: -------------------------------------------------------------------------------- 1 | -- Initial stateWriter.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: stateWriter 5 | version: 0.4.0 6 | synopsis: A faster variant of the RWS monad transformers. 7 | description: This is a version of the RWS monad transformers that should be much faster than what's found in transformers. The writer in the strict version does not leak memory. 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Simon Marechal 11 | maintainer: bartavelle@gmail.com 12 | -- copyright: 13 | category: Control 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | Tested-With: GHC == 8.8.4, GHC == 8.10.2, GHC == 9.4.5 18 | 19 | source-repository head 20 | type: git 21 | location: git://github.com/bartavelle/stateWriter.git 22 | 23 | library 24 | exposed-modules: Control.Monad.Trans.RSS.Lazy, Control.Monad.Trans.RSS.Strict, Control.Monad.RSS.Lazy, Control.Monad.RSS.Strict, Control.Monad.RSS, Control.Monad.Trans.RSS 25 | ghc-options: -Wall 26 | other-extensions: FlexibleInstances, MultiParamTypeClasses 27 | build-depends: base >= 4.13 && < 5, transformers >=0.3 && <0.7, mtl >=2.1 && <2.4 28 | default-language: Haskell2010 29 | 30 | test-suite spaceleak 31 | hs-source-dirs: tests 32 | type: exitcode-stdio-1.0 33 | ghc-options: -Wall -rtsopts 34 | build-depends: stateWriter,base,mtl 35 | main-is: spaceleak.hs 36 | default-language: Haskell2010 37 | 38 | test-suite rwscompare 39 | hs-source-dirs: tests 40 | type: exitcode-stdio-1.0 41 | ghc-options: -Wall -rtsopts 42 | build-depends: stateWriter,base,hspec,QuickCheck,mtl,free 43 | main-is: rwscompare.hs 44 | default-language: Haskell2010 45 | 46 | benchmark bench 47 | hs-source-dirs: bench 48 | type: exitcode-stdio-1.0 49 | ghc-options: -Wall -rtsopts -O2 50 | build-depends: stateWriter,base,criterion,containers,mtl,transformers,lens,vector,dlist >= 0.7,deepseq 51 | main-is: bench.hs 52 | default-language: Haskell2010 53 | 54 | 55 | -------------------------------------------------------------------------------- /tests/rwscompare.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, FlexibleContexts, FlexibleInstances #-} 2 | module Main where 3 | 4 | import Control.Monad.Trans.RSS.Strict 5 | import Control.Monad.RWS 6 | import Test.Hspec 7 | import Test.QuickCheck 8 | import Data.Functor.Classes 9 | import Control.Applicative 10 | import Control.Monad.Free 11 | import Prelude 12 | 13 | data ActionF next = Tell [Int] next 14 | | SetState Int next 15 | | AskAndStore IModification next 16 | | Modify SModification next 17 | | GetAndStore IModification next 18 | 19 | type Action = Free ActionF 20 | 21 | data SModification = SId 22 | | Double 23 | deriving (Enum, Show, Bounded) 24 | 25 | data IModification = IReturn 26 | | ReplicateThrice 27 | deriving (Enum, Show, Bounded) 28 | 29 | instance Arbitrary SModification where 30 | arbitrary = arbitraryBoundedEnum 31 | instance Arbitrary IModification where 32 | arbitrary = arbitraryBoundedEnum 33 | 34 | instance Arbitrary next => Arbitrary (ActionF next) where 35 | arbitrary = frequency [ (5, Tell <$> arbitrary <*> arbitrary) 36 | , (5, SetState <$> arbitrary <*> arbitrary) 37 | , (20, AskAndStore <$> arbitrary <*> arbitrary) 38 | , (20, GetAndStore <$> arbitrary <*> arbitrary) 39 | , (20, Modify <$> arbitrary <*> arbitrary) 40 | ] 41 | 42 | instance Arbitrary (Action Int) where 43 | arbitrary = frequency [ (1, Pure <$> arbitrary) 44 | , (9, Free <$> arbitrary) 45 | ] 46 | 47 | evaluateIM :: IModification -> (Int -> [Int]) 48 | evaluateIM IReturn x = [x] 49 | evaluateIM ReplicateThrice x = [x,x,x] 50 | 51 | evaluateSM :: SModification -> (Int -> Int) 52 | evaluateSM SId = id 53 | evaluateSM Double = (*) 2 54 | 55 | instance Show next => Show (ActionF next) where 56 | show (Tell x n) = "Tell " ++ show x ++ " / " ++ show n 57 | show (SetState s n) = "Set " ++ show s ++ " / " ++ show n 58 | show (AskAndStore i n) = "AskAndStore " ++ show i ++ " / " ++ show n 59 | show (GetAndStore i n) = "GetAndStore " ++ show i ++ " / " ++ show n 60 | show (Modify s n) = "Modify " ++ show s ++ " / " ++ show n 61 | 62 | instance Show1 ActionF where 63 | liftShowsPrec showp _ _ a = case a of 64 | Tell x n -> showString "Tell " . shows x . showString " / " . showp 0 n 65 | SetState s n -> showString "Set " . shows s . showString " / " . showp 0 n 66 | AskAndStore i n -> showString "AskAndStore " . shows i . showString " / " . showp 0 n 67 | GetAndStore i n -> showString "GetAndStore " . shows i . showString " / " . showp 0 n 68 | Modify s n -> showString "Modify " . shows s . showString " / " . showp 0 n 69 | 70 | evaluateActions :: (MonadRWS Int [Int] Int m) => Action x -> m x 71 | evaluateActions (Free (Tell x next)) = tell x >> evaluateActions next 72 | evaluateActions (Free (SetState s next)) = put s >> evaluateActions next 73 | evaluateActions (Free (AskAndStore f next)) = ask >>= tell . evaluateIM f >> evaluateActions next 74 | evaluateActions (Free (GetAndStore f next)) = get >>= tell . evaluateIM f >> evaluateActions next 75 | evaluateActions (Free (Modify f next)) = modify (evaluateSM f) >> evaluateActions next 76 | evaluateActions (Pure x) = return x 77 | 78 | main :: IO () 79 | main = hspec $ do 80 | describe "Writer part" $ do 81 | it "logs stuff in the right order, with tell" $ 82 | property $ \listOfLists -> runRSS (mapM_ tell (listOfLists :: [[Int]])) () () == runRWS (mapM_ tell listOfLists) () () 83 | it "listen" $ 84 | runRSS (tell "lol" >> listen (return ())) () () `shouldBe` (((),""),(),"lol") 85 | it "listen" $ 86 | runRSS (tell "lol" >> listen (tell "lal")) () () `shouldBe` (((),"lal"),(),"lollal") 87 | 88 | describe "RWS comparison" $ 89 | it "interprets actions the same" $ 90 | property $ \actions -> runRSS (evaluateActions (actions :: Action Int)) 42 12 == runRWS (evaluateActions actions) 42 12 91 | 92 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'stateWriter.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.10.3 12 | # 13 | version: ~> 1.0 14 | language: c 15 | os: linux 16 | dist: xenial 17 | git: 18 | # whether to recursively clone submodules 19 | submodules: false 20 | cache: 21 | directories: 22 | - $HOME/.cabal/packages 23 | - $HOME/.cabal/store 24 | - $HOME/.hlint 25 | before_cache: 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 27 | # remove files that are regenerated by 'cabal update' 28 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 29 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 30 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 31 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 32 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 33 | - rm -rfv $CABALHOME/packages/head.hackage 34 | jobs: 35 | include: 36 | - compiler: ghc-8.10.2 37 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.2","cabal-install-3.2"]}} 38 | os: linux 39 | - compiler: ghc-8.8.4 40 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.4","cabal-install-3.2"]}} 41 | os: linux 42 | before_install: 43 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 44 | - WITHCOMPILER="-w $HC" 45 | - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') 46 | - HCPKG="$HC-pkg" 47 | - unset CC 48 | - CABAL=/opt/ghc/bin/cabal 49 | - CABALHOME=$HOME/.cabal 50 | - export PATH="$CABALHOME/bin:$PATH" 51 | - TOP=$(pwd) 52 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 53 | - echo $HCNUMVER 54 | - CABAL="$CABAL -vnormal+nowrap" 55 | - set -o pipefail 56 | - TEST=--enable-tests 57 | - BENCH=--enable-benchmarks 58 | - HEADHACKAGE=false 59 | - rm -f $CABALHOME/config 60 | - | 61 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 62 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 63 | echo "write-ghc-environment-files: always" >> $CABALHOME/config 64 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 65 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 66 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 67 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 68 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 69 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 70 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 71 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 72 | echo "install-dirs user" >> $CABALHOME/config 73 | echo " prefix: $CABALHOME" >> $CABALHOME/config 74 | echo "repository hackage.haskell.org" >> $CABALHOME/config 75 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 76 | install: 77 | - ${CABAL} --version 78 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 79 | - | 80 | echo "program-default-options" >> $CABALHOME/config 81 | echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config 82 | - cat $CABALHOME/config 83 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 84 | - travis_retry ${CABAL} v2-update -v 85 | # Generate cabal.project 86 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 87 | - touch cabal.project 88 | - | 89 | echo "packages: ." >> cabal.project 90 | - echo 'package stateWriter' >> cabal.project 91 | - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" 92 | - | 93 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(stateWriter)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 94 | - cat cabal.project || true 95 | - cat cabal.project.local || true 96 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 97 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} 98 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 99 | - rm cabal.project.freeze 100 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all 101 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all 102 | script: 103 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 104 | # Packaging... 105 | - ${CABAL} v2-sdist all 106 | # Unpacking... 107 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 108 | - cd ${DISTDIR} || false 109 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 110 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 111 | - PKGDIR_stateWriter="$(find . -maxdepth 1 -type d -regex '.*/stateWriter-[0-9.]*')" 112 | # Generate cabal.project 113 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 114 | - touch cabal.project 115 | - | 116 | echo "packages: ${PKGDIR_stateWriter}" >> cabal.project 117 | - echo 'package stateWriter' >> cabal.project 118 | - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" 119 | - | 120 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(stateWriter)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 121 | - cat cabal.project || true 122 | - cat cabal.project.local || true 123 | # Building... 124 | # this builds all libraries and executables (without tests/benchmarks) 125 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 126 | # Building with tests and benchmarks... 127 | # build & run tests, build benchmarks 128 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all 129 | # Testing... 130 | - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all 131 | # cabal check... 132 | - (cd ${PKGDIR_stateWriter} && ${CABAL} -vnormal check) 133 | # haddock... 134 | - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all 135 | # Building without installed constraints for packages in global-db... 136 | - rm -f cabal.project.local 137 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 138 | 139 | # REGENDATA ("0.10.3",["stateWriter.cabal"]) 140 | # EOF 141 | -------------------------------------------------------------------------------- /Control/Monad/Trans/RSS/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | module Control.Monad.Trans.RSS.Lazy ( 6 | -- * The RWS monad 7 | RSS, 8 | rss, 9 | runRSS, 10 | evalRSS, 11 | execRSS, 12 | withRSS, 13 | -- * The RSST monad transformer 14 | RSST, 15 | runRSST, 16 | evalRSST, 17 | execRSST, 18 | withRSST, 19 | -- * Helpers 20 | liftCatch 21 | ) where 22 | 23 | import Control.Applicative 24 | import Control.Monad 25 | import Control.Monad.Fix 26 | import Control.Monad.IO.Class 27 | import Control.Monad.Trans.Class 28 | import Control.Monad.Except 29 | import Control.Monad.Signatures 30 | import Data.Functor.Identity 31 | 32 | import Control.Monad.State 33 | import Control.Monad.Reader 34 | import Control.Monad.Writer 35 | import Control.Monad.RWS 36 | 37 | -- | A monad containing an environment of type @r@, output of type @w@ 38 | -- and an updatable state of type @s@. 39 | type RSS r w s = RSST r w s Identity 40 | 41 | -- | Construct an RSS computation from a function. 42 | -- (The inverse of 'runRSS'.) 43 | rss :: Monoid w => (r -> s -> (a, s, w)) -> RSS r w s a 44 | rss f = RSST $ \r (s,w) -> let (a,s',w') = f r s 45 | in Identity (a, (s', w <> w')) 46 | 47 | -- | Unwrap an RSS computation as a function. 48 | -- (The inverse of 'rws'.) 49 | runRSS :: Monoid w => RSS r w s a -> r -> s -> (a,s,w) 50 | runRSS m r s = runIdentity (runRSST m r s) 51 | 52 | -- | Evaluate a computation with the given initial state and environment, 53 | -- returning the final value and output, discarding the final state. 54 | evalRSS :: Monoid w 55 | => RSS r w s a -- ^RWS computation to execute 56 | -> r -- ^initial environment 57 | -> s -- ^initial value 58 | -> (a, w) -- ^final value and output 59 | evalRSS m r s = let 60 | (a, _, w) = runRSS m r s 61 | in (a, w) 62 | 63 | -- | Evaluate a computation with the given initial state and environment, 64 | -- returning the final state and output, discarding the final value. 65 | execRSS :: Monoid w 66 | => RSS r w s a -- ^RWS computation to execute 67 | -> r -- ^initial environment 68 | -> s -- ^initial value 69 | -> (s, w) -- ^final state and output 70 | execRSS m r s = let 71 | (_, s', w) = runRSS m r s 72 | in (s', w) 73 | 74 | -- and state modified by applying @f@. 75 | -- 76 | -- * @'runRSS' ('withRSS' f m) r s = 'uncurry' ('runRSS' m) (f r s)@ 77 | withRSS :: (r' -> s -> (r, s)) -> RSS r w s a -> RSS r' w s a 78 | withRSS = withRSST 79 | 80 | --------------------------------------------------------------------------- 81 | -- | A monad transformer adding reading an environment of type @r@, 82 | -- collecting an output of type @w@ and updating a state of type @s@ 83 | -- to an inner monad @m@. 84 | newtype RSST r w s m a = RSST { runRSST' :: r -> (s,w) -> m (a, (s, w)) } 85 | 86 | runRSST :: (Monoid w, Monad m) => RSST r w s m a -> r -> s -> m (a, s, w) 87 | runRSST m r s = do 88 | ~(a,(s',w)) <- runRSST' m r (s,mempty) 89 | return (a,s',w) 90 | 91 | -- | Evaluate a computation with the given initial state and environment, 92 | -- returning the final value and output, discarding the final state. 93 | evalRSST :: (Monad m, Monoid w) 94 | => RSST r w s m a -- ^computation to execute 95 | -> r -- ^initial environment 96 | -> s -- ^initial value 97 | -> m (a,w) -- ^computation yielding final value and output 98 | evalRSST m r s = do 99 | ~(a, (_, w)) <- runRSST' m r (s,mempty) 100 | return (a, w) 101 | 102 | -- | Evaluate a computation with the given initial state and environment, 103 | -- returning the final state and output, discarding the final value. 104 | execRSST :: (Monad m, Monoid w) 105 | => RSST r w s m a -- ^computation to execute 106 | -> r -- ^initial environment 107 | -> s -- ^initial value 108 | -> m (s, w) -- ^computation yielding final state and output 109 | execRSST m r s = do 110 | ~(_, (s', w)) <- runRSST' m r (s,mempty) 111 | return (s', w) 112 | 113 | -- | @'withRSST' f m@ executes action @m@ with an initial environment 114 | -- and state modified by applying @f@. 115 | -- 116 | -- * @'runRSST' ('withRSST' f m) r s = 'uncurry' ('runRSST' m) (f r s)@ 117 | withRSST :: (r' -> s -> (r, s)) -> RSST r w s m a -> RSST r' w s m a 118 | withRSST f m = RSST $ \r (s,w) -> 119 | let (r',s') = f r s 120 | in runRSST' m r' (s',w) 121 | 122 | instance (Functor m) => Functor (RSST r w s m) where 123 | fmap f m = RSST $ \r s -> 124 | fmap (\ ~(a, (s', w)) -> (f a, (s', w))) $ runRSST' m r s 125 | 126 | instance (Monad m) => Monad (RSST r w s m) where 127 | return = pure 128 | m >>= k = RSST $ \r s -> do 129 | ~(a, (s', w)) <- runRSST' m r s 130 | runRSST' (k a) r (s',w) 131 | 132 | instance (MonadFail m) => MonadFail (RSST r w s m) where 133 | fail msg = RSST $ \_ _ -> fail msg 134 | 135 | instance (MonadPlus m) => MonadPlus (RSST r w s m) where 136 | mzero = empty 137 | mplus = (<|>) 138 | 139 | instance (Functor m, Monad m) => Applicative (RSST r w s m) where 140 | pure a = RSST $ \_ s -> pure (a, s) 141 | (<*>) = ap 142 | 143 | instance (Functor m, MonadPlus m) => Alternative (RSST r w s m) where 144 | empty = RSST $ \_ _ -> empty 145 | m <|> n = RSST $ \r s -> runRSST' m r s <|> runRSST' n r s 146 | 147 | instance (MonadFix m) => MonadFix (RSST r w s m) where 148 | mfix f = RSST $ \r s -> mfix $ \ ~(a, _) -> runRSST' (f a) r s 149 | 150 | instance MonadTrans (RSST r w s) where 151 | lift m = RSST $ \_ s -> do 152 | a <- m 153 | return (a, s) 154 | 155 | instance (MonadIO m) => MonadIO (RSST r w s m) where 156 | liftIO = lift . liftIO 157 | 158 | instance Monad m => MonadState s (RSST r w s m) where 159 | get = RSST $ \_ (s,w) -> return (s,(s,w)) 160 | put ns = RSST $ \_ (_,w) -> return ((),(ns,w)) 161 | state f = RSST $ \_ (s,w) -> case f s of 162 | (a,s') -> return (a, (s', w)) 163 | 164 | 165 | 166 | instance Monad m => MonadReader r (RSST r w s m) where 167 | ask = RSST $ \r s -> return (r, s) 168 | local f rw = RSST $ \r s -> runRSST' rw (f r) s 169 | reader f = RSST $ \r s -> return (f r, s) 170 | 171 | instance (Monoid w, Monad m) => MonadWriter w (RSST r w s m) where 172 | writer (a,w) = tell w >> return a 173 | tell w = RSST $ \_ (s, ow) -> 174 | let nw = ow <> w 175 | in return ((), (s, nw)) 176 | listen rw = RSST $ \r (s, w) -> do 177 | (a, (ns, nw)) <- runRSST' rw r (s, mempty) 178 | return ((a, nw), (ns, w <> nw)) 179 | pass rw = RSST $ \r (s, w) -> do 180 | ( (a, fw), (s', w') ) <- runRSST' rw r (s, mempty) 181 | return (a, (s', w `mappend` fw w')) 182 | 183 | instance (Monoid w, Monad m) => MonadRWS r w s (RSST r w s m) 184 | 185 | instance (Monoid w, MonadError e m) => MonadError e (RSST r w s m) where 186 | throwError = lift . throwError 187 | catchError = liftCatch catchError 188 | 189 | -- | Lift a @catchE@ operation to the new monad. 190 | liftCatch :: Catch e m (a,(s,w)) -> Catch e (RSST r w s m) a 191 | liftCatch catchE m h = 192 | RSST $ \ r s -> runRSST' m r s `catchE` \ e -> runRSST' (h e) r s 193 | {-# INLINE liftCatch #-} 194 | 195 | -------------------------------------------------------------------------------- /Control/Monad/Trans/RSS/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | module Control.Monad.Trans.RSS.Strict ( 6 | -- * The RWS monad 7 | RSS, 8 | rss, 9 | runRSS, 10 | evalRSS, 11 | execRSS, 12 | withRSS, 13 | -- * The RSST monad transformer 14 | RSST, 15 | runRSST, 16 | evalRSST, 17 | execRSST, 18 | withRSST, 19 | -- * Helpers 20 | liftCatch 21 | ) where 22 | 23 | import Control.Applicative 24 | import Control.Monad 25 | import Control.Monad.Fix 26 | import Control.Monad.IO.Class 27 | import Control.Monad.Trans.Class 28 | import Control.Monad.Except 29 | import Control.Monad.Signatures 30 | import Data.Functor.Identity 31 | 32 | import Control.Monad.State 33 | import Control.Monad.Reader 34 | import Control.Monad.Writer 35 | import Control.Monad.RWS 36 | 37 | -- | A monad containing an environment of type @r@, output of type @w@ 38 | -- and an updatable state of type @s@. 39 | type RSS r w s = RSST r w s Identity 40 | 41 | -- | Construct an RSS computation from a function. 42 | -- (The inverse of 'runRSS'.) 43 | rss :: Monoid w => (r -> s -> (a, s, w)) -> RSS r w s a 44 | rss f = RSST $ \r (s,w) -> let (a,s',w') = f r s 45 | in Identity (a, (s', w <> w')) 46 | 47 | -- | Unwrap an RSS computation as a function. 48 | -- (The inverse of 'rss'.) 49 | runRSS :: Monoid w => RSS r w s a -> r -> s -> (a,s,w) 50 | runRSS m r s = runIdentity (runRSST m r s) 51 | 52 | -- | Evaluate a computation with the given initial state and environment, 53 | -- returning the final value and output, discarding the final state. 54 | evalRSS :: Monoid w 55 | => RSS r w s a -- ^RWS computation to execute 56 | -> r -- ^initial environment 57 | -> s -- ^initial value 58 | -> (a, w) -- ^final value and output 59 | evalRSS m r s = let 60 | (a, _, w) = runRSS m r s 61 | in (a, w) 62 | 63 | -- | Evaluate a computation with the given initial state and environment, 64 | -- returning the final state and output, discarding the final value. 65 | execRSS :: Monoid w 66 | => RSS r w s a -- ^RWS computation to execute 67 | -> r -- ^initial environment 68 | -> s -- ^initial value 69 | -> (s, w) -- ^final state and output 70 | execRSS m r s = let 71 | (_, s', w) = runRSS m r s 72 | in (s', w) 73 | 74 | -- and state modified by applying @f@. 75 | -- 76 | -- * @'runRSS' ('withRSS' f m) r s = 'uncurry' ('runRSS' m) (f r s)@ 77 | withRSS :: (r' -> s -> (r, s)) -> RSS r w s a -> RSS r' w s a 78 | withRSS = withRSST 79 | 80 | --------------------------------------------------------------------------- 81 | -- | A monad transformer adding reading an environment of type @r@, 82 | -- collecting an output of type @w@ and updating a state of type @s@ 83 | -- to an inner monad @m@. 84 | newtype RSST r w s m a = RSST { runRSST' :: r -> (s,w) -> m (a, (s, w)) } 85 | 86 | runRSST :: (Monoid w, Monad m) => RSST r w s m a -> r -> s -> m (a, s, w) 87 | runRSST m r s = do 88 | (a,(s',w)) <- runRSST' m r (s,mempty) 89 | return (a,s',w) 90 | 91 | -- | Evaluate a computation with the given initial state and environment, 92 | -- returning the final value and output, discarding the final state. 93 | evalRSST :: (Monoid w, Monad m) 94 | => RSST r w s m a -- ^computation to execute 95 | -> r -- ^initial environment 96 | -> s -- ^initial value 97 | -> m (a,w) -- ^computation yielding final value and output 98 | evalRSST m r s = do 99 | (a, _, w) <- runRSST m r s 100 | return (a, w) 101 | 102 | -- | Evaluate a computation with the given initial state and environment, 103 | -- returning the final state and output, discarding the final value. 104 | execRSST :: (Monoid w, Monad m) 105 | => RSST r w s m a -- ^computation to execute 106 | -> r -- ^initial environment 107 | -> s -- ^initial value 108 | -> m (s, w) -- ^computation yielding final state and output 109 | execRSST m r s = do 110 | (_, s', w) <- runRSST m r s 111 | return (s', w) 112 | 113 | -- | @'withRSST' f m@ executes action @m@ with an initial environment 114 | -- and state modified by applying @f@. 115 | -- 116 | -- * @'runRSST' ('withRSST' f m) r s = 'uncurry' ('runRSST' m) (f r s)@ 117 | withRSST :: (r' -> s -> (r, s)) -> RSST r w s m a -> RSST r' w s m a 118 | withRSST f m = RSST $ \r (s,w) -> 119 | let (r',s') = f r s 120 | in runRSST' m r' (s',w) 121 | 122 | instance (Functor m) => Functor (RSST r w s m) where 123 | fmap f m = RSST $ \r s -> 124 | fmap (\ (a, (s', w)) -> (f a, (s', w))) $ runRSST' m r s 125 | {-# INLINE fmap #-} 126 | 127 | instance (Monad m) => Monad (RSST r w s m) where 128 | return = pure 129 | {-# INLINE return #-} 130 | m >>= k = RSST $ \r s -> do 131 | (a, (s', w)) <- runRSST' m r s 132 | runRSST' (k a) r (s',w) 133 | {-# INLINE (>>=) #-} 134 | 135 | instance (MonadFail m) => MonadFail (RSST r w s m) where 136 | fail msg = RSST $ \_ _ -> fail msg 137 | 138 | instance (MonadPlus m) => MonadPlus (RSST r w s m) where 139 | mzero = empty 140 | {-# INLINE mzero #-} 141 | mplus = (<|>) 142 | {-# INLINE mplus #-} 143 | 144 | instance (Functor m, Monad m) => Applicative (RSST r w s m) where 145 | pure a = RSST $ \_ s -> pure (a, s) 146 | {-# INLINE pure #-} 147 | (<*>) = ap 148 | {-# INLINE (<*>) #-} 149 | 150 | instance (Functor m, MonadPlus m) => Alternative (RSST r w s m) where 151 | empty = RSST $ \_ _ -> empty 152 | {-# INLINE empty #-} 153 | m <|> n = RSST $ \r s -> runRSST' m r s <|> runRSST' n r s 154 | {-# INLINE (<|>) #-} 155 | 156 | instance (MonadFix m) => MonadFix (RSST r w s m) where 157 | mfix f = RSST $ \r s -> mfix $ \ ~(a, _) -> runRSST' (f a) r s 158 | {-# INLINE mfix #-} 159 | 160 | instance MonadTrans (RSST r w s) where 161 | lift m = RSST $ \_ s -> do 162 | a <- m 163 | return (a, s) 164 | {-# INLINE lift #-} 165 | 166 | instance (MonadIO m) => MonadIO (RSST r w s m) where 167 | liftIO = lift . liftIO 168 | {-# INLINE liftIO #-} 169 | 170 | instance Monad m => MonadState s (RSST r w s m) where 171 | get = RSST $ \_ (s,w) -> return (s,(s,w)) 172 | {-# INLINE get #-} 173 | put ns = RSST $ \_ (_,w) -> return ((),(ns,w)) 174 | {-# INLINE put #-} 175 | state f = RSST $ \_ (s,w) -> case f s of 176 | (a,s') -> return (a, (s', w)) 177 | {-# INLINE state #-} 178 | 179 | instance Monad m => MonadReader r (RSST r w s m) where 180 | ask = RSST $ \r s -> return (r, s) 181 | {-# INLINE ask #-} 182 | local f rw = RSST $ \r s -> runRSST' rw (f r) s 183 | {-# INLINE local #-} 184 | reader f = RSST $ \r s -> return (f r, s) 185 | {-# INLINE reader #-} 186 | 187 | instance (Monoid w, Monad m) => MonadWriter w (RSST r w s m) where 188 | writer (a,w) = tell w >> return a 189 | {-# INLINE writer #-} 190 | tell w = RSST $ \_ (s, ow) -> 191 | let nw = ow `mappend` w 192 | in nw `seq` return ((), (s, nw)) 193 | {-# INLINE tell #-} 194 | listen rw = RSST $ \r (s, w) -> do 195 | (a, (ns, nw)) <- runRSST' rw r (s,mempty) 196 | let ow = w `mappend` nw 197 | ow `seq` return ((a, nw), (ns, ow)) 198 | {-# INLINE listen #-} 199 | pass rw = RSST $ \r (s, w) -> do 200 | ( (a, fw), (s', w') ) <- runRSST' rw r (s, mempty) 201 | return (a, (s', w `mappend` fw w')) 202 | {-# INLINE pass #-} 203 | 204 | instance (Monoid w, Monad m) => MonadRWS r w s (RSST r w s m) 205 | 206 | instance (Monoid w, MonadError e m) => MonadError e (RSST r w s m) where 207 | throwError = lift . throwError 208 | catchError = liftCatch catchError 209 | 210 | -- | Lift a @catchE@ operation to the new monad. 211 | liftCatch :: Catch e m (a,(s,w)) -> Catch e (RSST r w s m) a 212 | liftCatch catchE m h = 213 | RSST $ \ r s -> runRSST' m r s `catchE` \ e -> runRSST' (h e) r s 214 | {-# INLINE liftCatch #-} 215 | 216 | -------------------------------------------------------------------------------- /proof.v: -------------------------------------------------------------------------------- 1 | (* stateWriter laws *) 2 | 3 | Require Import Notations. 4 | Require Import FunctionalExtensionality. 5 | 6 | Set Implicit Arguments. 7 | 8 | (** * The Monad Type Class *) 9 | 10 | Definition idf {A : Type} (x : A) : A := x. 11 | 12 | Definition composition {A} {B} {C} (f : B -> C) (g : A -> B) (a : A) := f (g a). 13 | 14 | Class Functor f := { 15 | fmap: forall A B, (A -> B) -> f A -> f B; 16 | fmap_id: (forall A (a: f A), fmap idf a = a); 17 | fmap_dist: (forall A B C (fn : A -> B) (g : B -> C) (a : f A), 18 | fmap g (fmap fn a) = fmap (fun x => g (fn x)) a) 19 | }. 20 | 21 | Class Applicative (m : Type -> Type) (F: Functor m) := { 22 | pure: forall A, A -> m A; 23 | app: forall A B, m (A -> B) -> m A -> m B; 24 | app_identity: forall A (a : m A), app (pure idf) a = a; 25 | app_homo: forall A B (f : A -> B) (a : A), app (pure f) (pure a) = pure (f a); 26 | app_interchange: forall A B (u : m (A -> B)) (y : A), app u (pure y) = app (pure (fun f => f y)) u; 27 | app_composition: forall A B C (u : m (B -> C)) (v : m (A -> B)) (w : m A), 28 | app u (app v w) = 29 | app (app (app (pure composition) u) v) w; 30 | fmap_app: forall A B (f : A -> B) (x : m A), app (pure f) x = fmap f x 31 | }. 32 | 33 | Theorem fmap_pure (m : Type -> Type) (AF: Functor m) (AP: Applicative AF) : 34 | forall A B (a : A) (f : A -> B), 35 | fmap f (pure a) = pure (f a). 36 | Proof. 37 | intros. 38 | rewrite <- app_homo. 39 | rewrite fmap_app. 40 | reflexivity. 41 | Qed. 42 | 43 | Class Monad (m : Type -> Type) (AF: Functor m) (AP: Applicative AF) := { 44 | bind : forall A B, m A -> (A -> m B) -> m B; 45 | right_unit: forall A (a: m A), a = bind a (fun x => pure x); 46 | left_unit: forall A (a: A) B (f: A -> m B), 47 | f a = bind (pure a) f; 48 | associativity: forall A (ma : m A) B f C (g: B -> m C), 49 | bind ma (fun x => bind (f x) g) = bind (bind ma f) g; 50 | app_bind: forall A B (fs : m (A -> B)) (xs : m A), 51 | app A B fs xs = bind fs (fun f => bind xs (fun x => pure (f x))); 52 | }. 53 | 54 | Theorem fmap_return (m : Type -> Type) (AF: Functor m) (AP: Applicative AF) (AM: Monad AP): 55 | forall A B (ma : m A) (f : A -> B), 56 | bind B ma (fun a => pure (f a)) = fmap f ma. 57 | Proof. 58 | intros. 59 | rewrite <- fmap_app. 60 | rewrite app_bind. 61 | rewrite <- left_unit. 62 | reflexivity. 63 | Qed. 64 | 65 | Theorem bind_fmap (m : Type -> Type) (AF: Functor m) (AP: Applicative AF) (AM: Monad AP): 66 | forall A B C (ma : m A) (f : A -> B) (mf : B -> m C), 67 | @bind m AF AP AM B C (fmap f ma) mf = @bind m AF AP AM A C ma (composition mf f). 68 | Proof. 69 | intros. 70 | rewrite <- (fmap_return AM). 71 | rewrite <- associativity. 72 | apply f_equal. 73 | extensionality x. 74 | rewrite <- left_unit. 75 | unfold composition. 76 | reflexivity. 77 | Qed. 78 | 79 | Definition RSST (R : Type) (W : Type) (S : Type) (M : Type -> Type) (A : Type) := 80 | R -> (S * W) -> M (A * (S * W)). 81 | 82 | Definition first {A : Type} {B : Type} {C : Type} (f : A -> B) (x : (A*C)) := 83 | (f (fst x), snd x). 84 | 85 | Theorem pair_idf : forall A B, (fun (x : A * B) => (fst x, snd x)) = idf. 86 | Proof. 87 | intros. apply functional_extensionality. 88 | destruct x. simpl. unfold idf. reflexivity. 89 | Qed. 90 | 91 | Theorem funProductBreak: forall (A B C: Type) (f : (A*B) -> C), (fun x : A * B => let (a,b) := x in f (a,b)) = f. 92 | Proof. 93 | intros. apply functional_extensionality. intros. destruct x. reflexivity. 94 | Qed. 95 | 96 | Theorem fstSnd: forall (A B C: Type) (f : A -> B -> C), 97 | (fun x : A * B => let (a,b) := x in f a b) = (fun x => f (fst x) (snd x)). 98 | Proof. 99 | intros. 100 | extensionality x. destruct x. simpl. reflexivity. 101 | Qed. 102 | 103 | Instance RSSTFunctor R W S (M : Type -> Type) (F: Functor M) : Functor (RSST R W S M) := 104 | { fmap M A f FA := fun r sw => fmap (first f) (FA r sw) 105 | }. 106 | Proof. 107 | - (* fmap_identity *) 108 | intros T m. 109 | extensionality r. 110 | extensionality sw. 111 | destruct sw. 112 | unfold first. unfold idf. 113 | rewrite pair_idf. 114 | rewrite fmap_id. 115 | reflexivity. 116 | - (* fmap dist *) 117 | intros. 118 | extensionality r. 119 | extensionality sw. 120 | apply fmap_dist. 121 | Defined. 122 | 123 | Instance RSSTApplicative : forall R W S (M : Type -> Type) (FM : Functor M) (AM : Applicative FM) (MM : Monad AM) 124 | , Applicative (RSSTFunctor R W S FM) := 125 | { 126 | pure := fun A x r sw => @pure M FM AM (A*(S*W)) (x, sw); 127 | app A B mf mb := fun r sw => 128 | @bind M FM AM MM ((A -> B)*(S*W)) (B*(S*W)) (mf r sw) (fun blob1 => 129 | let (f,sw') := blob1 130 | in @bind M FM AM MM (A*(S*W)) (B * (S*W)) (mb r sw') (fun blob2 => 131 | let (x,sw'') := blob2 in pure (f x, sw''))) 132 | }. 133 | Proof. 134 | - (* app identity *) 135 | intros. 136 | extensionality r. extensionality sw. 137 | rewrite <- left_unit. 138 | unfold idf. 139 | rewrite funProductBreak. 140 | rewrite <- right_unit. 141 | reflexivity. 142 | - (* app_homo *) 143 | intros. 144 | extensionality r. extensionality sw. 145 | rewrite <- left_unit. rewrite <- left_unit. reflexivity. 146 | - (* app_interchange *) 147 | intros. 148 | extensionality r. extensionality sw. 149 | rewrite <- left_unit. apply f_equal. 150 | extensionality sw'. 151 | destruct sw. 152 | destruct sw'. 153 | rewrite <- left_unit. reflexivity. 154 | - (* app_composition *) 155 | intros. 156 | extensionality r. extensionality sw. 157 | rewrite <- left_unit. rewrite <- associativity. rewrite <- associativity. 158 | apply f_equal. 159 | extensionality sw'. 160 | destruct sw. destruct sw'. rewrite <- left_unit. 161 | rewrite <- associativity. rewrite <- associativity. apply f_equal. 162 | extensionality sw''. 163 | destruct sw''. 164 | rewrite <- left_unit. 165 | rewrite <- associativity. apply f_equal. 166 | apply functional_extensionality. intros. 167 | destruct p0. destruct x. rewrite <- left_unit. unfold composition. reflexivity. 168 | - (* fmap pure *) 169 | intros. 170 | extensionality r. extensionality sw. 171 | unfold fmap. simpl. 172 | rewrite <- left_unit. 173 | rewrite fstSnd. 174 | rewrite fmap_return. reflexivity. 175 | Defined. 176 | 177 | Instance RSSTMonad : forall R W S (M : Type -> Type) (FM : Functor M) (AM : Applicative FM) (MM : Monad AM) 178 | , Monad (RSSTApplicative R W S MM) := 179 | { 180 | bind A B ma f := 181 | fun r sw => 182 | @bind M FM AM MM (A*(S*W)) (B*(S*W)) (ma r sw) (fun blob => 183 | let (a,sw') := blob 184 | in (f a) r sw') 185 | }. 186 | Proof. 187 | - (* right unit *) 188 | intros. 189 | extensionality r. extensionality sw. 190 | unfold pure. simpl. 191 | rewrite funProductBreak. rewrite <- right_unit. reflexivity. 192 | - (* left unit *) 193 | intros. 194 | extensionality r. extensionality sw. 195 | unfold pure. simpl. 196 | rewrite <- left_unit. reflexivity. 197 | - (* associativity *) 198 | intros. 199 | extensionality r. extensionality sw. 200 | rewrite <- associativity. apply f_equal. 201 | extensionality sw'. 202 | destruct sw'. reflexivity. 203 | - (* app_bind *) 204 | intros. 205 | extensionality r. extensionality sw. 206 | destruct sw. 207 | unfold pure. simpl. reflexivity. 208 | Defined. 209 | 210 | Class StateMonad (S : Type) (m : Type -> Type) (AF: Functor m) (AP: Applicative AF) (AM: Monad AP) := { 211 | get : m S; 212 | put : S -> m unit; 213 | stateLaw1: @bind m AF AP AM S unit get put = pure tt; 214 | stateLaw2: forall (s s' : S), bind unit (put s) (fun _ => put s') = put s'; 215 | stateLaw3: forall (s : S), @bind m AF AP AM unit S (put s) (fun _ => get) = @bind m AF AP AM unit S (put s) (fun _ => pure s); 216 | stateLaw4: forall B (k : S -> S -> m B), 217 | @bind m AF AP AM S B get (fun s => @bind m AF AP AM S B get (fun s' => k s s')) 218 | = @bind m AF AP AM S B get (fun s => k s s) 219 | }. 220 | 221 | Instance RSSTState : forall R W S (M : Type -> Type) (FM : Functor M) (AM : Applicative FM) (MM : Monad AM) 222 | , StateMonad S (RSSTMonad R W S MM) := 223 | { 224 | get := fun r sw => pure (fst sw, sw); 225 | put := fun ns r sw => pure (tt, (ns, snd sw)) 226 | }. 227 | Proof. 228 | - extensionality r; extensionality sw. 229 | destruct sw. unfold pure at 3; simpl. 230 | repeat(rewrite <- left_unit). simpl. 231 | reflexivity. 232 | - intros. 233 | extensionality r; extensionality sw. 234 | destruct sw. 235 | unfold bind at 1. simpl. 236 | repeat(rewrite <- left_unit). simpl. 237 | reflexivity. 238 | - intros. 239 | extensionality r; extensionality sw. 240 | destruct sw. 241 | unfold bind at 1;simpl. 242 | repeat(rewrite <- left_unit). simpl. 243 | reflexivity. 244 | - intros. 245 | unfold bind at 1;simpl. 246 | extensionality r; extensionality sw. 247 | repeat(rewrite <- left_unit); simpl. 248 | reflexivity. 249 | Defined. 250 | 251 | Class Monoid W := { 252 | mempty : W; 253 | mappend : W -> W -> W; 254 | midleft: forall x, mappend mempty x = x; 255 | midright: forall x, mappend x mempty = x; 256 | massoc: forall a b c, mappend (mappend a b) c = mappend a (mappend b c) 257 | }. 258 | 259 | Class WriterMonad (W : Type) (m : Type -> Type) (AF: Functor m) (AP: Applicative AF) (AM: Monad AP) (MW: Monoid W):= { 260 | tell: W -> m unit; 261 | listen: forall A, m A -> m (A*W); 262 | pass: forall A, m (A*(W->W)) -> m A 263 | }. 264 | 265 | Instance RSSTWriter: forall R W S (M : Type -> Type) (FM : Functor M) (AM : Applicative FM) (MM : Monad AM) (MW: Monoid W) 266 | , WriterMonad (RSSTMonad R W S MM) MW := 267 | { 268 | tell := fun w _ sw => 269 | let (s,ow) := sw in 270 | pure (tt, (s,mappend ow w)); 271 | listen := fun A rw r sw => 272 | let (s,w) := sw 273 | in @bind M FM AM MM (A*(S*W)) (A*W*(S*W)) 274 | (rw r (s,mempty)) 275 | (fun blob => let (a,sw') := blob in let (ns,nw) := sw' in pure ((a,nw),(ns,mappend w nw))); 276 | pass := fun A rw r sw => 277 | let (s,w) := sw 278 | in @bind M FM AM MM (A*(W->W)*(S*W)) (A*(S*W)) (rw r (s,mempty)) 279 | (fun blob => 280 | let (afw,sw') := blob in 281 | let (a,fw) := afw in 282 | let (s',w') := sw' in 283 | pure (a,(s',mappend w (fw w')))) 284 | }. 285 | 286 | Definition lift {M : Type -> Type} {FM: Functor M} {AM: Applicative FM} {MM: Monad AM} {R} {W} {S} {A} : 287 | M A -> RSST R W S M A := 288 | fun act _ sw => @bind M FM AM MM A (A*(S*W)) act (fun a => pure (a,sw)). 289 | 290 | 291 | Theorem listenA R W S (M : Type -> Type) (FM: Functor M) (AM: Applicative FM) (MM: Monad AM) (MW: Monoid W): 292 | forall A (act: M A), 293 | @listen W (RSST R W S M) (RSSTFunctor R W S FM) 294 | (RSSTApplicative R W S MM) (RSSTMonad R W S MM) MW 295 | (RSSTWriter R S MM MW) A 296 | 297 | (lift act) = fmap (fun v => (v,mempty)) (lift act). 298 | Proof. 299 | intros. 300 | unfold listen, fmap. simpl. unfold first. 301 | extensionality r. extensionality sw. 302 | destruct sw. unfold lift. 303 | rewrite <- associativity. 304 | rewrite fmap_return. 305 | rewrite fmap_dist. simpl. 306 | rewrite <- (fmap_return MM). 307 | apply f_equal. 308 | extensionality a. 309 | rewrite <- left_unit. 310 | rewrite midright. 311 | reflexivity. 312 | Qed. 313 | 314 | --------------------------------------------------------------------------------