├── Makefile ├── LICENSE.md ├── examples ├── without_signals │ ├── FPStateTests.hs │ ├── IntStateTests.hs │ ├── MLFPStateFwdTests.hs │ ├── FileIOAndMLStateTests.hs │ ├── MLFPStateTests.hs │ ├── MLStateTests.hs │ ├── AmbientsTests.hs │ ├── TwoLevelStateTest.hs │ ├── CostTests.hs │ ├── OldFileIOTests.hs │ └── FileIOTests.hs └── with_signals │ ├── SignalMLStateTests.hs │ ├── ExcMLStateTests.hs │ └── MonotonicMLStateTests.hs ├── src └── Control │ ├── Runner │ ├── FileIOAndMLState.hs │ ├── Cost.hs │ ├── MLFPState.hs │ ├── MLFPStateFwd.hs │ ├── FPState.hs │ ├── IntState.hs │ ├── IntMLState.hs │ ├── MLState.hs │ ├── FileIO.hs │ ├── Ambients.hs │ └── OldFileIO.hs │ ├── SignalRunner │ ├── MonotonicMLState.hs │ ├── ExcMLState.hs │ └── SignalMLState.hs │ ├── Runner.hs │ └── SignalRunner.hs ├── haskell-coop.cabal └── README.md /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: examples 2 | 3 | default: all 4 | 5 | all: build examples 6 | 7 | build: 8 | cabal new-build --write-ghc-environment-files always --enable-documentation 9 | 10 | examples: 11 | ghc -fno-code examples/without_signals/*.hs 12 | ghc -fno-code examples/with_signals/*.hs 13 | 14 | clean: 15 | cabal new-clean 16 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Danel Ahman 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining 6 | a copy of this software and associated documentation files (the 7 | "Software"), to deal in the Software without restriction, including 8 | without limitation the rights to use, copy, modify, merge, publish, 9 | distribute, sublicense, and/or sell copies of the Software, and to 10 | permit persons to whom the Software is furnished to do so, subject to 11 | the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be 14 | included in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /examples/without_signals/FPStateTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | {-| 5 | Module : FPStateTests 6 | Description : Example use cases of the footprint-based runner for state from `Control.Runner.FPState` 7 | Copyright : (c) Danel Ahman, 2019 8 | License : MIT 9 | Maintainer : danel.ahman@eesti.ee 10 | Stability : experimental 11 | 12 | This module provides example use cases of the footprint-based 13 | runners for state from `Control.Runner.FPState`. 14 | -} 15 | module FPStateTests where 16 | 17 | import Control.Runner 18 | import Control.Runner.FPState 19 | 20 | test1 :: User '[State (ShC Int (ShC String ShE))] Int 21 | test1 = 22 | do x <- get AZ; 23 | return x 24 | 25 | test2 = fpTopLevel (MC 42 (MC "foo" ME)) test1 -- expected result 42 26 | 27 | test3 :: User '[State (ShC Int (ShC String ShE))] (Int,String) 28 | test3 = 29 | do s <- get (AS AZ); 30 | x <- get AZ; 31 | put AZ (x + 7); 32 | put (AS AZ) (s ++ "bar"); 33 | x' <- get AZ; 34 | s' <- get (AS AZ); 35 | return (x',s') 36 | 37 | test4 = fpTopLevel (MC 42 (MC "foo" ME)) test3 -- expected result (49,"foobar") 38 | -------------------------------------------------------------------------------- /examples/without_signals/IntStateTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | {-| 4 | Module : IntStateTests 5 | Description : Example use cases of the runner for integer-valued state from `Control.Runner.IntState` 6 | Copyright : (c) Danel Ahman, 2019 7 | License : MIT 8 | Maintainer : danel.ahman@eesti.ee 9 | Stability : experimental 10 | 11 | This module provides example use cases of the runner for 12 | integer-valued state from `Control.Runner.IntState`. 13 | -} 14 | module IntStateTests where 15 | 16 | import Control.Runner 17 | import Control.Runner.IntState 18 | 19 | one = AZ 20 | two = AS AZ 21 | 22 | test1 :: User '[State Z] Int 23 | test1 = 24 | withNewRef 42 ( 25 | do i <- get one; 26 | return i 27 | ) 28 | 29 | test2 = runSt test1 -- expected result 42 30 | 31 | test3 :: User '[State Z] Int 32 | test3 = 33 | withNewRef 4 ( 34 | do withNewRef 2 ( 35 | do i <- get two; -- reading the outer reference 36 | j <- get one; -- reading the inner reference 37 | put two (i + j) -- writing to the outer reference 38 | return ()); 39 | k <- get one; 40 | return (k + k + 1) 41 | ) 42 | 43 | test4 = runSt test3 -- expected result 13 -------------------------------------------------------------------------------- /examples/without_signals/MLFPStateFwdTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | {-| 5 | Module : MLFPStateFwdTests 6 | Description : Example use cases of the runner for footprint-based use of ML-style state from `Control.Runner.MLFPStateFwd` 7 | Copyright : (c) Danel Ahman, 2019 8 | License : MIT 9 | Maintainer : danel.ahman@eesti.ee 10 | Stability : experimental 11 | 12 | This module provides example use cases of the runner for footprint-based 13 | use of ML-style state from `Control.Runner.MLFPStateFwd`. 14 | -} 15 | module MLFPStateFwdTests where 16 | 17 | import Control.Runner 18 | import Control.Runner.MLState 19 | import Control.Runner.MLFPStateFwd 20 | 21 | test1 :: User '[MLState] (String,String,String,Bool) 22 | test1 = 23 | do r <- alloc "foobar"; 24 | r' <- alloc "foo"; 25 | r'' <- alloc "bar"; 26 | r''' <- alloc True; 27 | withFootprint (FC r' (FC r'' FE)) ( 28 | do s <- get AZ; 29 | s' <- get (AS AZ); 30 | put AZ s'; 31 | put (AS AZ) s 32 | ); 33 | s <- (!) r; 34 | s' <- (!) r'; 35 | s'' <- (!) r''; 36 | x <- (!) r'''; 37 | return (s,s',s'',x) 38 | 39 | test2 = mlTopLevel test1 -- expected result ("foobar","bar","foo",True) -------------------------------------------------------------------------------- /examples/without_signals/FileIOAndMLStateTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | {-| 4 | Module : FileIOAndMLStateTests 5 | Description : Example use cases of the combination of file IO and ML-style state from `Control.Runner.FileIOAndMLState` 6 | Copyright : (c) Danel Ahman, 2019 7 | License : MIT 8 | Maintainer : danel.ahman@eesti.ee 9 | Stability : experimental 10 | 11 | This module provides some example use cases of the combination of 12 | file IO and ML-style state from `Control.Runner.FileIOAndMLState`. 13 | -} 14 | module FileIOAndMLStateTests where 15 | 16 | import Control.Runner 17 | import Control.Runner.FileIO hiding (withFile) 18 | import Control.Runner.FileIOAndMLState 19 | import Control.Runner.MLState hiding (mlTopLevel) 20 | 21 | test1 :: FilePath -> User '[IO,MLState] String 22 | test1 fn = 23 | do r <- alloc ""; 24 | withFile 25 | fn 26 | ( 27 | do s <- fRead; 28 | r =:= s; 29 | fWrite s -- to retain the file's original contents 30 | ); 31 | s <- (!) r; 32 | withFile 33 | fn 34 | ( 35 | fWrite (s ++ "foobar") -- updating the file's contents 36 | ); 37 | s' <- (!) r; 38 | return s' 39 | 40 | test2 = ioMltopLevel (test1 "./out.txt") -------------------------------------------------------------------------------- /examples/without_signals/MLFPStateTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | {-| 5 | Module : MLFPStateTests 6 | Description : Example use cases of the runner for footprint-based use of ML-style state from `Control.Runner.MLFPState` 7 | Copyright : (c) Danel Ahman, 2019 8 | License : MIT 9 | Maintainer : danel.ahman@eesti.ee 10 | Stability : experimental 11 | 12 | This module provides example use cases of the runner for footprint-based 13 | use of ML-style state from `Control.Runner.MLFPState`. 14 | -} 15 | module MLFPStateTests where 16 | 17 | import Control.Runner 18 | import Control.Runner.FPState 19 | import Control.Runner.MLState 20 | import Control.Runner.MLFPState 21 | 22 | test1 :: User '[MLState] (String,String,String,Bool) 23 | test1 = 24 | do r <- alloc "foobar"; 25 | r' <- alloc "foo"; 26 | r'' <- alloc "bar"; 27 | r''' <- alloc True; 28 | withFootprint (FC r' (FC r'' FE)) ( 29 | do s <- get AZ; 30 | s' <- get (AS AZ); 31 | put AZ s'; 32 | put (AS AZ) s 33 | ); 34 | s <- (!) r; 35 | s' <- (!) r'; 36 | s'' <- (!) r''; 37 | x <- (!) r'''; 38 | return (s,s',s'',x) 39 | 40 | test2 = mlTopLevel test1 -- expected result ("foobar","bar","foo",True) -------------------------------------------------------------------------------- /src/Control/Runner/FileIOAndMLState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | 5 | {-| 6 | Module : Control.Runner.FileIOAndMLState 7 | Description : Combination of file IO and ML-style state, using the pairing of runners 8 | Copyright : (c) Danel Ahman, 2019 9 | License : MIT 10 | Maintainer : danel.ahman@eesti.ee 11 | Stability : experimental 12 | 13 | This module uses the pairing of runners (`pairRunners`) to combine the file 14 | IO runners from `FileIO` and the ML-style state runner from `MLState`. 15 | -} 16 | module Control.Runner.FileIOAndMLState 17 | ( 18 | withFile, ioMltopLevel 19 | ) where 20 | 21 | import Control.Runner 22 | import Control.Runner.FileIO hiding (withFile) 23 | import Control.Runner.MLState hiding (mlTopLevel) 24 | 25 | import System.IO hiding (withFile) 26 | 27 | -- | A variant of the with-file construct that runs user code that can 28 | -- perform effects both from the `File` and `MLState` effects. For 29 | -- simplicity, currently limited to the use of one file at a time. 30 | withFile :: FilePath -> User '[File,MLState] a -> User '[IO,MLState] a 31 | withFile fn c = 32 | run 33 | (pairRunners fioRunner fwdRunner) 34 | (return ((),())) 35 | ( 36 | run 37 | (pairRunners fhRunner (fwdRunner :: Runner '[MLState] '[FileIO,MLState] ())) 38 | (do s <- fioFhInitialiser fn; 39 | return (s,())) 40 | c 41 | (\ x (s,()) -> fioFhFinaliser x s) 42 | ) 43 | (\ x _ -> return x) 44 | 45 | -- | Top level for running user code that can perform 46 | -- both `IO` and `MLState` effects. 47 | ioMltopLevel :: User '[IO,MLState] a -> IO a 48 | ioMltopLevel m = 49 | ioTopLevel 50 | ( 51 | run 52 | (pairRunners fwdRunner mlRunner) 53 | (do h <- mlInitialiser; 54 | return ((),h)) 55 | m 56 | (\ x _ -> return x) 57 | ) 58 | -------------------------------------------------------------------------------- /examples/without_signals/MLStateTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | {-| 6 | Module : MLStateTests 7 | Description : Example use cases of the runner for ML-style state from `Control.Runner.MLState` 8 | Copyright : (c) Danel Ahman, 2019 9 | License : MIT 10 | Maintainer : danel.ahman@eesti.ee 11 | Stability : experimental 12 | 13 | This module provides example use cases of the runner 14 | for ML-style state from `Control.Runner.MLState`. 15 | -} 16 | module MLStateTests where 17 | 18 | import Control.Runner 19 | import Control.Runner.MLState 20 | 21 | test1 :: Int -> Int -> User '[MLState] (Int,Int) 22 | test1 x y = 23 | do r <- alloc x; 24 | r' <- alloc y; 25 | x' <- (!) r; 26 | y' <- (!) r'; 27 | return (x',y') 28 | 29 | test2 = mlTopLevel (test1 4 2) -- expected result (4,2) 30 | 31 | test3 :: Int -> User '[MLState] Int 32 | test3 x = 33 | do r <- alloc x; 34 | r =:= (x + 2); 35 | y <- (!) r; 36 | return y 37 | 38 | test4 = mlTopLevel (test3 4) -- expected result 6 39 | 40 | test5 :: forall (a :: *) . (Typeable a) => Ref a -> Ref a -> User '[MLState] () 41 | test5 r r' = 42 | do x <- (!) r; 43 | y <- (!) r'; 44 | r =:= y; 45 | r' =:= x 46 | 47 | test6 :: User '[MLState] (String,String) 48 | test6 = 49 | do r <- alloc "foo"; 50 | r' <- alloc "bar"; 51 | test5 r r'; 52 | s <- (!) r; 53 | s' <- (!) r'; 54 | return (s,s') -- expected result ("bar","foo") 55 | 56 | test7 = mlTopLevel test6 57 | 58 | test8 :: String -> Int 59 | test8 s = length s 60 | 61 | test9 :: String -> (String -> Int) -> User '[MLState] Int 62 | test9 s f = 63 | do r <- alloc f; -- storing a higher-order (pure) function argument in the state 64 | x <- test3 42; 65 | g <- (!) r; 66 | return (g s + x) -- length s + 44 67 | 68 | test10 = mlTopLevel (test9 "foobar" length) -- expected result 50 -------------------------------------------------------------------------------- /examples/without_signals/AmbientsTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | {-| 7 | Module : AmbientsTests 8 | Description : Example use cases of the runner for ambient values and ambient functions from `Control.Runner.Ambients` 9 | Copyright : (c) Danel Ahman, 2019 10 | License : MIT 11 | Maintainer : danel.ahman@eesti.ee 12 | Stability : experimental 13 | 14 | This module provides some example use cases of the runner for 15 | ambient values and ambient functions from `Control.Runner.Ambients`. 16 | -} 17 | module AmbientsTests where 18 | 19 | import Control.Runner 20 | import Control.Runner.Ambients 21 | 22 | ambFun :: AmbVal Int -> Int -> AmbEff Int 23 | ambFun x y = 24 | do x <- getVal x; 25 | return (x + y) 26 | 27 | test1 :: AmbEff Int 28 | test1 = 29 | withAmbVal 30 | (4 :: Int) 31 | (\ x -> -- bind an ambient value `x` with (initial) value 4 32 | withAmbFun 33 | (ambFun x) 34 | (\ f -> -- bind an ambient function `f` using the ambient value `x` 35 | do rebindVal x 2; -- rebind/update the ambient value `x` with value 2 36 | applyFun f 1)) 37 | 38 | test2 = ambTopLevel test1 -- expected result 5 39 | 40 | test3 :: AmbEff Int 41 | test3 = 42 | withAmbVal 43 | (4 :: Int) 44 | (\ x -> 45 | withAmbFun 46 | (ambFun x) 47 | (\ f -> 48 | do rebindVal x 2; 49 | rebindFun f (ambFun x); 50 | (applyFun f 1))) 51 | 52 | test4 = ambTopLevel test3 -- expected result 3 53 | 54 | test5 :: AmbEff Int 55 | test5 = 56 | withAmbVal 57 | (4 :: Int) 58 | (\ x -> 59 | withAmbFun 60 | (ambFun x) 61 | (\ f -> 62 | do rebindVal x 2; 63 | withAmbFun 64 | (ambFun x) 65 | (\ g -> applyFun f 1))) 66 | 67 | test6 = ambTopLevel test5 -- expected result 5 -------------------------------------------------------------------------------- /haskell-coop.cabal: -------------------------------------------------------------------------------- 1 | name: haskell-coop 2 | version: 0.1.0.0 3 | cabal-version: >=1.10 4 | synopsis: A library for programming with effectful runners in Haskell 5 | license: MIT 6 | license-file: LICENSE.md 7 | author: Danel Ahman 8 | maintainer: danel.ahman@eesti.ee 9 | copyright: (c) 2019 Danel Ahman 10 | category: Control 11 | build-type: Simple 12 | extra-source-files: README.md 13 | homepage: https://github.com/danelahman/haskell-coop 14 | bug-reports: https://github.com/danelahman/haskell-coop/issues 15 | 16 | description: 17 | An experimental library for programming with effectful runners in Haskell, 18 | based on ongoing research of [Danel Ahman](https://danel.ahman.ee) 19 | and [Andrej Bauer](http://www.andrej.com). See [Control.Runner](Control-Runner.html) 20 | and [Control.SignalRunner](Control-SignalRunner.html) for details. 21 | 22 | library 23 | exposed-modules: 24 | Control.Runner, 25 | Control.SignalRunner, 26 | Control.Runner.Ambients, 27 | Control.Runner.Cost, 28 | Control.Runner.FileIO, 29 | Control.Runner.FileIOAndMLState, 30 | Control.Runner.FPState, 31 | Control.Runner.IntMLState, 32 | Control.Runner.IntState, 33 | Control.Runner.MLFPState, 34 | Control.Runner.MLFPStateFwd, 35 | Control.Runner.MLState, 36 | Control.Runner.OldFileIO, 37 | Control.SignalRunner.ExcMLState, 38 | Control.SignalRunner.MonotonicMLState, 39 | Control.SignalRunner.SignalMLState 40 | default-extensions: 41 | DataKinds, 42 | DeriveFunctor, 43 | EmptyCase, 44 | FlexibleContexts, 45 | GADTs, 46 | GeneralizedNewtypeDeriving, 47 | KindSignatures, 48 | MonoLocalBinds, 49 | PolyKinds, 50 | RankNTypes, 51 | ScopedTypeVariables, 52 | TypeApplications, 53 | TypeFamilies, 54 | TypeOperators 55 | build-depends: 56 | base >=4.12 && <4.13, 57 | freer-simple >=1.2 && <1.3, 58 | mtl >=2.2 && <2.3, 59 | bytestring >=0.10 && <0.11 60 | hs-source-dirs: 61 | src 62 | default-language: 63 | Haskell2010 -------------------------------------------------------------------------------- /examples/with_signals/SignalMLStateTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | {-| 4 | Module : SignalMLStateTests 5 | Description : Example use cases of the runner for ML-style state from `Control.SignalRunner.SignalMLState` 6 | Copyright : (c) Danel Ahman, 2019 7 | License : MIT 8 | Maintainer : danel.ahman@eesti.ee 9 | Stability : experimental 10 | 11 | This module provides example use cases of the runner 12 | for ML-style state from `Control.SignalRunner.SignalMLState`. 13 | 14 | In this example, the runner might raise a kill signal 15 | if one tries to dereference a non-existent memory location. 16 | 17 | For instance, below we deliberately leak references out of 18 | an `mlTopLevel` block and feed them to the next such block, 19 | where the references of course do not exist any more in the 20 | heap (that's initialised empty), and cause a signal to be sent. 21 | -} 22 | module SignalMLStateTests where 23 | 24 | import Control.SignalRunner 25 | import Control.SignalRunner.SignalMLState 26 | 27 | test1 :: Int -> Int -> User '[MLState] Zero (Int,Int) 28 | test1 x y = 29 | do r <- alloc x; 30 | r' <- alloc y; 31 | x' <- (!) r; 32 | y' <- (!) r'; 33 | return (x',y') 34 | 35 | test2 = mlTopLevel (test1 4 2) -- expected result (4,2) 36 | 37 | test3 :: Int -> Int -> User '[MLState] Zero (Ref Int,Ref Int) 38 | test3 x y = 39 | do r <- alloc x; 40 | r' <- alloc y; 41 | return (r,r') 42 | 43 | test4 :: Ref Int -> Ref Int -> User '[MLState] Zero (Int,Int) 44 | test4 r r' = 45 | do x' <- (!) r; 46 | y' <- (!) r'; 47 | return (x',y') 48 | 49 | test5 = 50 | let (r,r') = mlTopLevel (test3 4 2) in 51 | mlTopLevel (test4 r r') 52 | -- expected result "Exception: signal reached top level (RefNotInHeapInDerefSignal -- ref. with address Z)" 53 | 54 | test6 :: Int -> Int -> User '[MLState] Zero (Ref Int,Ref Int) 55 | test6 x y = 56 | do r <- alloc x; 57 | r' <- alloc y; 58 | return (r',r) 59 | 60 | test7 = 61 | let (r,r') = mlTopLevel (test6 4 2) in 62 | mlTopLevel (test4 r r') 63 | -- expected result "Exception: signal reached top level (RefNotInHeapInDerefSignal -- ref. with address S Z)" 64 | 65 | test8 :: Ref Int -> Ref Int -> Int -> Int -> User '[MLState] Zero (Int,Int) 66 | test8 r r' x y = 67 | do r =:= x ; 68 | r' =:= y; 69 | return (x,y) 70 | 71 | test9 = 72 | let (r,r') = mlTopLevel (test3 4 2) in 73 | mlTopLevel (test8 r r' 2 4) 74 | -- expected result "Exception: signal reached top level (RefNotInHeapInAssignSignal -- ref. with address Z)" 75 | 76 | test10 = 77 | let (r,r') = mlTopLevel (test6 4 2) in 78 | mlTopLevel (test8 r r' 2 4) 79 | -- expected result "Exception: signal reached top level (RefNotInHeapInAssignSignal -- ref. with address S Z)" 80 | -------------------------------------------------------------------------------- /src/Control/Runner/Cost.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | {-| 8 | Module : Control.Runner.Cost 9 | Description : Runner for instrumenting a user computation with a simple cost model 10 | Copyright : (c) Danel Ahman, 2019 11 | License : MIT 12 | Maintainer : danel.ahman@eesti.ee 13 | Stability : experimental 14 | 15 | This module implements a runner that provides a means 16 | to instrument user code with a very simple cost model 17 | that simply counts the total number of operation calls 18 | that the user code makes, with the corresponding 19 | finaliser `costFinaliser` then reporting the final cost. 20 | 21 | For simplicity, the finaliser `costFinaliser` 22 | simply returns a pair of the user code's return value 23 | and the final cost of the computation. One can of course 24 | envisage both more elaborate cost models, but also 25 | finalisers that act on the final cost with other effects, 26 | e.g., by writing the final cost of the computation to IO. 27 | -} 28 | module Control.Runner.Cost ( 29 | costRunner, costInitialiser, costFinaliser, costInstrumentation 30 | ) where 31 | 32 | import Control.Runner 33 | 34 | -- | The co-operations of the runner `costRunner`. 35 | costCoOps :: Member eff sig => eff a -> Kernel sig Int a 36 | costCoOps e = 37 | do c <- getEnv; 38 | setEnv (c + 1); 39 | performK e 40 | 41 | -- | Runner that instruments a user computation with a simple 42 | -- cost model that simply counts the number of operation calls 43 | -- the user code makes (storing the count in its runtime state). 44 | costRunner :: Member eff sig => Runner '[eff] sig Int 45 | costRunner = mkRunner costCoOps 46 | 47 | -- | Initialiser for the runner `costRunner`. 48 | -- 49 | -- It sets the number of operation calls to zero. 50 | costInitialiser :: User sig Int 51 | costInitialiser = return 0 52 | 53 | -- | Finaliser for the runner `costRunner`. 54 | -- 55 | -- It returns the pair of the return value and the 56 | -- final cost of the user computation that was run. 57 | costFinaliser :: a -> Int -> User sig (a,Int) 58 | costFinaliser x c = return (x,c) 59 | 60 | -- | Sugar for inserting the runner `costRunner` inbetween 61 | -- the user code @m@ and some enveloping runner. 62 | -- 63 | -- As it stands, `costInstrumentation` is defined for a single 64 | -- effect @eff@. For instrumenting code that uses more than one 65 | -- effect, one can union the runner `costRunner` with itself 66 | -- using `unionRunners` suitably many times. 67 | costInstrumentation :: Member eff sig => User '[eff] a -> User sig (a,Int) 68 | costInstrumentation m = 69 | run 70 | costRunner 71 | costInitialiser 72 | m 73 | costFinaliser -------------------------------------------------------------------------------- /src/Control/Runner/MLFPState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | {-| 7 | Module : Control.Runner.MLFPState 8 | Description : Using a runner to locally run a footprint of general, external ML-style state 9 | Copyright : (c) Danel Ahman, 2019 10 | License : MIT 11 | Maintainer : danel.ahman@eesti.ee 12 | Stability : experimental 13 | 14 | This module uses the `fpRunner` to locally run a footprint of 15 | general, external ML-style state (see `MLState` for details). 16 | -} 17 | module Control.Runner.MLFPState ( 18 | Footprint(..), withFootprint 19 | ) where 20 | 21 | import Control.Runner 22 | import Control.Runner.FPState 23 | import Control.Runner.MLState 24 | 25 | import System.IO 26 | 27 | -- | Footprint is a memory shape indexed vector of ML-style 28 | -- references, with the typing ensuring that types of 29 | -- the references match locations in the memory shape. 30 | data Footprint :: forall memsize . MemShape memsize -> * where 31 | FE :: Footprint ShE 32 | FC :: (Typeable a) => Ref a -> Footprint sh -> Footprint (ShC a sh) 33 | 34 | -- | Initialiser for running the given footprint of ML-style 35 | -- references locally using the runner `fpRunner. 36 | -- 37 | -- The initialiser recurses through the given footprint, and 38 | -- looks up the values stored in each of the references, 39 | -- and assembles them into a memory which it then returns. 40 | fpInitialiser :: Footprint memshape -> User '[MLState] (Memory memshape) 41 | fpInitialiser FE = return ME 42 | fpInitialiser (FC r fp) = 43 | do mem <- fpInitialiser fp; 44 | x <- (!) r; 45 | return (MC x mem) 46 | 47 | -- | Finaliser for running the given footprint of ML-style 48 | -- references locally using the runner `fpRunner. 49 | -- 50 | -- The finaliser recurses through the given footprint, 51 | -- and performs assignments to all the references in it, 52 | -- and then passes on the return value unchanged. 53 | fpFinaliser :: Footprint memshape -> a -> Memory memshape -> User '[MLState] a 54 | fpFinaliser FE x _ = return x 55 | fpFinaliser (FC r fp) x (MC y mem) = 56 | do z <- fpFinaliser fp x mem; 57 | r =:= y; 58 | return z 59 | 60 | -- | Scoped running of user code on a given footprint of 61 | -- general, external ML-style memory, using `fpRunner`. 62 | -- 63 | -- The idea is that any reads and writes that the given 64 | -- performs on the given footprint happen locally. It is 65 | -- only in a finaliser for `fpRunner` that the final values 66 | -- of the footprint get committed back to the ML-style state. 67 | withFootprint :: Footprint memshape -> User '[State memshape] a -> User '[MLState] a 68 | withFootprint fp m = 69 | run 70 | fpRunner 71 | (fpInitialiser fp) 72 | m 73 | (fpFinaliser fp) -------------------------------------------------------------------------------- /examples/without_signals/TwoLevelStateTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | 5 | {-| 6 | Module : TwoLevelStateTest 7 | Description : Example use of runners on a simple two-location integer-valued state 8 | Copyright : (c) Danel Ahman, 2019 9 | License : MIT 10 | Maintainer : danel.ahman@eesti.ee 11 | Stability : experimental 12 | 13 | This module provides an example use of runners on a simple two-location 14 | integer-valued state, showing how runners can be used to "focus" on a 15 | fraction of some bigger external resource, in this case on one of the 16 | two memory locations of the `BigState` effect. 17 | -} 18 | module TwoLevelStateTest where 19 | 20 | import Control.Runner 21 | 22 | data BigState a where 23 | Get1 :: BigState Int 24 | Put1 :: Int -> BigState () 25 | Get2 :: BigState String 26 | Put2 :: String -> BigState () 27 | 28 | data SmallState a where 29 | Get :: SmallState Int 30 | Put :: Int -> SmallState () 31 | 32 | smallStateCoOps :: SmallState r -> Kernel '[BigState] Int r 33 | smallStateCoOps Get = 34 | do i <- getEnv; 35 | return i 36 | smallStateCoOps (Put i) = 37 | setEnv i 38 | 39 | smallStateRunner :: Runner '[SmallState] '[BigState] Int 40 | smallStateRunner = mkRunner smallStateCoOps 41 | 42 | smallStateInitially :: User '[BigState] Int 43 | smallStateInitially = 44 | do i <- performU Get1 45 | return (i + 7) 46 | 47 | smallStateFinally :: () -> Int -> User '[BigState] () 48 | smallStateFinally _ i = performU (Put1 i) 49 | 50 | smallStateComp :: User '[BigState] () 51 | smallStateComp = 52 | run 53 | smallStateRunner 54 | smallStateInitially 55 | ( 56 | do i <- performU Get; 57 | performU (Put (i + 42)) 58 | ) 59 | smallStateFinally 60 | 61 | bigStateCoOps :: BigState r -> Kernel '[] (Int,String) r 62 | bigStateCoOps Get1 = 63 | do (i,s) <- getEnv; 64 | return i 65 | bigStateCoOps (Put1 i) = 66 | do (_,s) <- getEnv; 67 | setEnv (i,s) 68 | bigStateCoOps Get2 = 69 | do (i,s) <- getEnv; 70 | return s 71 | bigStateCoOps (Put2 s) = 72 | do (i,_) <- getEnv; 73 | setEnv (i,s) 74 | 75 | bigStateRunner :: Runner '[BigState] '[] (Int,String) 76 | bigStateRunner = mkRunner bigStateCoOps 77 | 78 | 79 | bigStateInitially :: User '[] (Int,String) 80 | bigStateInitially = return (0,"default value") 81 | 82 | bigStateFinally :: () -> (Int,String) -> User '[] (Int,String) 83 | bigStateFinally _ (i,s) = return (i,s) 84 | 85 | bigStateComp :: User '[] (Int,String) 86 | bigStateComp = 87 | run 88 | bigStateRunner 89 | bigStateInitially 90 | ( 91 | do smallStateComp; 92 | performU (Put2 "new value") 93 | ) 94 | bigStateFinally 95 | 96 | test = pureTopLevel bigStateComp -- expected result (49,"new value") -------------------------------------------------------------------------------- /examples/with_signals/ExcMLStateTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | {-| 4 | Module : ExcMLStateTests 5 | Description : Example use cases of the runner for ML-style state from `Control.SignalRunner.ExcMLState` 6 | Copyright : (c) Danel Ahman, 2019 7 | License : MIT 8 | Maintainer : danel.ahman@eesti.ee 9 | Stability : experimental 10 | 11 | This module provides example use cases of the runner 12 | for ML-style state from `Control.SignalRunner.ExcMLState`. 13 | 14 | In this example, the runner might raise an exception 15 | if one tries to dereference a non-existent memory location. 16 | 17 | For instance, below we deliberately leak references out of 18 | an `mlTopLevel` block and feed them to the next such block, 19 | where the references of course do not exist any more in the heap 20 | (that's initialised empty), and cause an exception to be raised. 21 | -} 22 | module ExcMLStateTests where 23 | 24 | import Control.SignalRunner 25 | import Control.SignalRunner.ExcMLState 26 | 27 | test1 :: Int -> Int -> User '[MLState] E (Int,Int) 28 | test1 x y = 29 | do r <- alloc x; 30 | r' <- alloc y; 31 | x' <- (!) r; 32 | y' <- (!) r'; 33 | return (x',y') 34 | 35 | test2 = mlTopLevel (test1 4 2) -- expected result (4,2) 36 | 37 | test3 :: Int -> Int -> User '[MLState] E (Ref Int,Ref Int) 38 | test3 x y = 39 | do r <- alloc x; 40 | r' <- alloc y; 41 | return (r,r') 42 | 43 | test4 :: Ref Int -> Ref Int -> User '[MLState] E (Int,Int) 44 | test4 r r' = 45 | do x' <- (!) r; 46 | y' <- (!) r'; 47 | return (x',y') 48 | 49 | test5 = 50 | let (r,r') = mlTopLevel (test3 4 2) in 51 | mlTopLevel (test4 r r') 52 | -- expected result "Exception: exception reached top level (RefNotInHeapInDerefException -- ref. with address Z)" 53 | 54 | test6 :: Int -> Int -> User '[MLState] E (Ref Int,Ref Int) 55 | test6 x y = 56 | do r <- alloc x; 57 | r' <- alloc y; 58 | return (r',r) 59 | 60 | test7 = 61 | let (r,r') = mlTopLevel (test6 4 2) in 62 | mlTopLevel (test4 r r') 63 | -- expected result "Exception: exception reached top level (RefNotInHeapInDerefException -- ref. with address S Z)" 64 | 65 | test8 :: Ref Int -> Ref Int -> User '[MLState] E (Int,Int) 66 | test8 r r' = 67 | do x' <- tryWithU ((!) r) 68 | return 69 | (\ e -> error ("intercepted an exception (" ++ show e ++ ")")); 70 | y' <- (!) r'; 71 | return (x',y') 72 | 73 | test9 = 74 | let (r,r') = mlTopLevel (test3 4 2) in 75 | mlTopLevel (test8 r r') 76 | -- expected result "Exception: intercepted an exception (RefNotInHeapInDerefException -- ref. with address Z)" 77 | 78 | test10 :: Ref Int -> Ref Int -> Int -> Int -> User '[MLState] E (Int,Int) 79 | test10 r r' x y = 80 | do r =:= x ; 81 | r' =:= y; 82 | return (x,y) 83 | 84 | test11 = 85 | let (r,r') = mlTopLevel (test3 4 2) in 86 | mlTopLevel (test10 r r' 2 4) 87 | -- expected result "Exception: exception reached top level (RefNotInHeapInAssignException -- ref. with address Z)" 88 | 89 | test12 = 90 | let (r,r') = mlTopLevel (test6 4 2) in 91 | mlTopLevel (test10 r r' 2 4) 92 | -- expected result "Exception: exception reached top level (RefNotInHeapInAssignException -- ref. with address S Z)" 93 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell-Coop 2 | 3 | Haskell-Coop is an experimental Haskell library for programming with effectful runners. 4 | 5 | This library is based on ongoing research of [Danel Ahman](https://danel.ahman.ee) 6 | and [Andrej Bauer](http://www.andrej.com). Interested readers should check out a 7 | recent draft [Runners in action](https://arxiv.org/abs/1910.11629) that develops 8 | the theoretical underpinnings, presents a core calculus for programming with runners 9 | that the Haskell-Coop library implements, and discusses various example uses of runners. 10 | 11 | For general background reading on algebraic effects and handlers, we recommend the lecture 12 | notes [What is algebraic about algebraic effects and handlers?](https://arxiv.org/abs/1807.05923). 13 | Section 4 of these lecture notes discusses ordinary runners of algebraic effects (also known in the 14 | literature as comodels of algebraic effects). 15 | 16 | ## Prerequisites 17 | 18 | To build Haskell-Coop, you need a working installation 19 | of [Haskell](https://www.haskell.org/platform/), 20 | and the [Cabal](https://www.haskell.org/cabal/) package manager and build system. 21 | 22 | ## Building haskell-coop 23 | 24 | You can type: 25 | 26 | - `make` to locally build the Haskell-Coop library, generate documentation, and typecheck examples. 27 | - `make build` to locally build the Haskell-Coop library and generate documentation. 28 | - `make examples` to typecheck examples. 29 | - `make clean` to clean up. 30 | 31 | Building Haskell-Coop uses `cabal new-build` to locally build the library and all its dependencies, 32 | and to generate Haddock documentation. The generated documentation can be found in 33 | `dist-newstyle/build/platform/ghc-version/haskell-coop-version/doc/html/haskell-coop/index.html`. 34 | The examples are typechecked with `ghci`. 35 | 36 | ## Entry points 37 | 38 | There are two main entry points to the Haskell-Coop library: 39 | 40 | - [src/Control/Runner.hs](src/Control/Runner.hs) that implements a restricted form of effectful runners (without exceptions and signals). 41 | - [src/Control/SignalRunner.hs](src/Control/SignalRunner.hs) that implements the general form of effectful runners (with exceptions and signals). 42 | 43 | The directories [src/Control/Runner/](src/Control/Runner/) 44 | and [src/Control/SignalRunner/](src/Control/SignalRunner/) contain various example 45 | runners that implement file IO, ML-style state, their combinations, ambient functions as present 46 | in the [Koka](https://github.com/koka-lang/koka) language, etc. 47 | 48 | Example uses of these runners can be found in [examples/without_signals/](examples/without_signals/) 49 | and [examples/with_signals/](examples/with_signals/). 50 | 51 | ## Further documentation 52 | 53 | Further documentation of the Haskell-Coop library can be found in its individual modules. 54 | 55 | ## Acknowledgements 56 | 57 | 58 | 59 | 60 |
This project has received funding from the European Union’s Horizon 2020 research and innovation programme under the Marie Skłodowska-Curie grant agreement No 834146.
This material is based upon work supported by the Air Force Office of Scientific Research under award number FA9550-17-1-0326.
61 | -------------------------------------------------------------------------------- /examples/without_signals/CostTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MonoLocalBinds #-} 4 | 5 | {-| 6 | Module : CostTests 7 | Description : Example use cases of the runner for cost model instrumentation from `Control.Runner.Cost` 8 | Copyright : (c) Danel Ahman, 2019 9 | License : MIT 10 | Maintainer : danel.ahman@eesti.ee 11 | Stability : experimental 12 | 13 | This module provides example use cases of the runner for 14 | cost model instrumentation from `Control.Runner.Cost`. 15 | -} 16 | module CostTests where 17 | 18 | import Control.Runner 19 | import Control.Runner.Cost 20 | 21 | import Control.Runner.MLState 22 | 23 | import Control.Runner.FileIO 24 | import System.IO hiding (withFile) 25 | 26 | 27 | -- Instrumenting ML-style state with a simple cost model 28 | 29 | test1 :: Int -> Int -> User '[MLState] (Int,Int) 30 | test1 x y = 31 | do r <- alloc x; 32 | r' <- alloc y; 33 | x' <- (!) r; 34 | y' <- (!) r'; 35 | return (x',y') 36 | 37 | test2 = 38 | mlTopLevel (costInstrumentation (test1 4 2)) -- expected result ((4,2),4) 39 | 40 | test3 :: Int -> User '[MLState] Int 41 | test3 x = 42 | do r <- alloc x; 43 | r =:= (x + 2); 44 | y <- (!) r; 45 | return y 46 | 47 | test4 = mlTopLevel (costInstrumentation (test3 4)) -- expected result (6,3) 48 | 49 | test5 :: String -> (String -> Int) -> User '[MLState] Int 50 | test5 s f = 51 | do r <- alloc f; -- storing a higher-order (pure) function argument in the state 52 | x <- test3 42; 53 | g <- (!) r; 54 | return (g s + x) -- length s + 44 55 | 56 | test6 = mlTopLevel (costInstrumentation (test5 "foobar" length)) -- expected result (50,5) 57 | -- 2 operation calls from test5, 58 | -- and 3 operation calls from test3 59 | 60 | 61 | -- Instrumenting file IO state with a simple cost model 62 | 63 | writeLines :: Member File sig => [String] -> User sig () 64 | writeLines [] = return () 65 | writeLines (l:ls) = do fWrite l; 66 | fWrite "\n"; 67 | writeLines ls 68 | 69 | exampleLines = ["Lorem ipsum dolor sit amet, consectetur adipiscing elit.", 70 | "Cras sit amet felis arcu.", 71 | "Maecenas ac mollis mauris, vel fermentum nibh."] 72 | 73 | test7 :: User '[IO] () 74 | test7 = -- in IO signature, using IO container 75 | run 76 | fioRunner 77 | ioFioInitialiser 78 | ( -- in FileIO signature, using FIO runner 79 | run 80 | fhRunner 81 | (fioFhInitialiser "./out.txt") 82 | ( -- in File signature, using FH runner 83 | writeLines exampleLines 84 | ) 85 | fioFhFinaliser 86 | ) 87 | ioFioFinaliser 88 | 89 | test8 = ioTopLevel (costInstrumentation test7) -- expected result ((),11) 90 | -- 6 operation calls from writeLines 91 | -- 4 operation calls from fioFhInitialiser 92 | -- 1 operation call from fioFhFinaliser 93 | -- 0 operation calls from ioFioInitialiser and ioFioFinaliser 94 | -------------------------------------------------------------------------------- /examples/with_signals/MonotonicMLStateTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | {-| 4 | Module : MonotonicMLStateTests 5 | Description : Example use cases of the runner for ML-style state from `Control.SignalRunner.MonotonicMLState` 6 | Copyright : (c) Danel Ahman, 2019 7 | License : MIT 8 | Maintainer : danel.ahman@eesti.ee 9 | Stability : experimental 10 | 11 | This module provides example use cases of the runner 12 | for ML-style state from `Control.SignalRunner.MonotonicMLState`. 13 | 14 | In these examples, the runner might raise a kill signal 15 | (i) if one tries to dereference a non-existent memory location; 16 | this is inherited from the runner in `SignalMLState`, or 17 | (ii) if one tries assign to a reference that has no preorder 18 | associated with it. 19 | 20 | Further, if one tries to assign a new value to a reference that 21 | is not related to the reference's existing value by the associated 22 | preorder, then we raise an exception, that the user code can catch 23 | (if it so wishes) to, e.g., try again with a different value. 24 | -} 25 | module MonotonicMLStateTests where 26 | 27 | import Control.SignalRunner 28 | import Control.SignalRunner.MonotonicMLState 29 | 30 | test1 :: Int -> User '[MonMLState] MonE Int 31 | test1 x = 32 | do r <- alloc x (>); 33 | x' <- (!) r; 34 | return x' 35 | 36 | test2 = monTopLevel (test1 42) -- expected result 42 37 | 38 | test3 :: Int -> User '[MonMLState] MonE Int 39 | test3 x = 40 | do r <- alloc x (<=); 41 | x' <- (!) r; 42 | r =:= (x' + 1); 43 | r =:= (x' + 2); 44 | x'' <- (!) r; 45 | return x'' 46 | 47 | test4 = monTopLevel (test3 42) -- expected result 44 48 | 49 | test5 :: Int -> User '[MonMLState] MonE Int 50 | test5 x = 51 | do r <- alloc x (<=); 52 | x' <- (!) r; 53 | r =:= (x' - 1); 54 | x'' <- (!) r; 55 | return x'' 56 | 57 | test6 = monTopLevel (test5 42) 58 | -- expected result "Exception: exception reached (monotonic) top level (MononicityViolationException -- ref. with address Z)" 59 | 60 | test7 :: Int -> Int -> User '[MonMLState] MonE (Ref Int,Ref Int) 61 | test7 x y = 62 | do r <- alloc x (<=); 63 | r' <- alloc y (<=); 64 | return (r,r') 65 | 66 | test8 :: Ref Int -> Ref Int -> User '[MonMLState] MonE (Int,Int) 67 | test8 r r' = 68 | do x' <- (!) r; 69 | y' <- (!) r'; 70 | return (x',y') 71 | 72 | test9 = 73 | let (r,r') = monTopLevel (test7 4 2) in 74 | monTopLevel (test8 r r') 75 | -- expected result "Exception: signal reached top level (RefNotInHeapInDerefSignal -- ref. with address Z)" 76 | -- this signal happens in the ML-style state layer and thus kills off the monotonic state layer 77 | 78 | test10 :: Int -> User '[MonMLState] MonE Int 79 | test10 x = 80 | do r <- alloc x (<=); 81 | x' <- (!) r; 82 | tryWithU 83 | (r =:= (x' - 1)) 84 | (\ x -> return x) 85 | (\ e -> r =:= (x' + 1)); 86 | x'' <- (!) r; 87 | return x'' 88 | 89 | test11 = monTopLevel (test10 42) -- expected result 43 90 | 91 | test12 :: Int -> User '[MonMLState] MonE Int 92 | test12 x = 93 | do r <- alloc x (<=); 94 | x' <- (!) r; 95 | tryWithU 96 | (r =:= (x' + 2)) 97 | (\ x -> return x) 98 | (\ e -> r =:= (x' - 1)); 99 | x'' <- (!) r; 100 | return x'' 101 | 102 | test13 = monTopLevel (test12 42) -- expected result 44 103 | -------------------------------------------------------------------------------- /examples/without_signals/OldFileIOTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | 5 | {-| 6 | Module : OldFileIOTests 7 | Description : Example use cases of the runners for file IO from `Control.Runner.OldFileIO` 8 | Copyright : (c) Danel Ahman, 2019 9 | License : MIT 10 | Maintainer : danel.ahman@eesti.ee 11 | Stability : experimental 12 | 13 | This module provides some example use cases of the 14 | runners for file IO from `Control.Runner.OldFileIO`. 15 | -} 16 | module OldFileIOTests where 17 | 18 | import Control.Runner 19 | import Control.Runner.OldFileIO 20 | 21 | import System.IO 22 | 23 | test1 :: User '[File] () 24 | test1 = 25 | do s <- performU Read; 26 | if s == "foo" 27 | then (performU (Write "contents was foo")) 28 | else (performU (Write "contents was not foo")) 29 | 30 | writeLines :: Member File iface => [String] -> User iface () 31 | writeLines [] = return () 32 | writeLines (l:ls) = do performU (Write l); 33 | performU (Write "\n"); 34 | writeLines ls 35 | 36 | exampleLines = ["Lorem ipsum dolor sit amet, consectetur adipiscing elit.", 37 | "Cras sit amet felis arcu.", 38 | "Maecenas ac mollis mauris, vel fermentum nibh."] 39 | 40 | test2 :: User '[IO] () 41 | test2 = -- in IO signature 42 | run 43 | fioRunner 44 | ioFioInitialiser 45 | ( -- in FileIO signature 46 | run 47 | fhRunner 48 | (fioFhInitialiser "./out.txt") 49 | ( -- in File signature, with FH runner 50 | writeLines exampleLines -- this runner appends to the existing file 51 | ) 52 | fioFhFinaliser 53 | ) 54 | ioFioFinaliser 55 | 56 | test3 = ioTopLevel test2 57 | 58 | test4 :: User '[IO] () 59 | test4 = -- in IO signature 60 | run 61 | fioRunner 62 | ioFioInitialiser 63 | ( -- in FileIO signature 64 | run 65 | fcRunner 66 | (fioFcInitialiser "./out2.txt") 67 | ( -- in File signature, with FC runner 68 | writeLines exampleLines -- this runner appends to the existing file 69 | ) 70 | (fioFcFinaliser "./out2.txt") 71 | ) 72 | ioFioFinaliser 73 | 74 | test5 = ioTopLevel test4 75 | 76 | test6 :: User '[IO] () 77 | test6 = -- in IO signature 78 | run 79 | fioRunner 80 | ioFioInitialiser 81 | ( -- in FileIO signature 82 | run 83 | fcOwRunner 84 | (fioFcOwInitialiser "./out3.txt") 85 | ( -- in File signature, with FC+OW runner 86 | writeLines exampleLines -- this runner overwrites the existing file 87 | ) 88 | (fioFcOwFinaliser "./out3.txt") 89 | ) 90 | ioFioFinaliser 91 | 92 | test7 = ioTopLevel test6 93 | 94 | test8 :: User '[IO] () 95 | test8 = -- in IO signature 96 | run 97 | fioRunner 98 | ioFioInitialiser 99 | ( -- in FileIO signature 100 | run 101 | fcOwRunner 102 | (fioFcOwInitialiser "./out4.txt") 103 | ( -- in File signature, with FC+OW runner 104 | do s <- performU Read; 105 | performU (Write s); 106 | performU (Write "\n"); 107 | performU (Write s); 108 | if not (s == "foo") 109 | then (do performU Clean; -- selectively empties file contents 110 | performU (Write "foo")) 111 | else (return ()) 112 | ) 113 | (fioFcOwFinaliser "./out4.txt") 114 | ) 115 | ioFioFinaliser 116 | 117 | test9 = ioTopLevel test8 118 | -------------------------------------------------------------------------------- /src/Control/Runner/MLFPStateFwd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | {-| 7 | Module : Control.Runner.MLFPState 8 | Description : Using a runner to run a footprint of general, external ML-style state 9 | Copyright : (c) Danel Ahman, 2019 10 | License : MIT 11 | Maintainer : danel.ahman@eesti.ee 12 | Stability : experimental 13 | 14 | This module uses the `fpRunner` to run a footprint of general, 15 | external ML-style state (see `MLState` for details). 16 | -} 17 | module Control.Runner.MLFPStateFwd ( 18 | Nat(..), MemShape(..), Footprint(..), Addr(..), 19 | State(..), get, put, fpRunner, withFootprint 20 | ) where 21 | 22 | import Control.Runner 23 | import Control.Runner.MLState 24 | 25 | import Data.Typeable 26 | import System.IO 27 | 28 | -- | Type of natural numbers that we use for the footprint size. 29 | data Nat where 30 | Z :: Nat 31 | S :: Nat -> Nat 32 | 33 | -- | Shape of the memory. 34 | -- 35 | -- This is a length-indexed vector of the types that 36 | -- the memory locations store in the memory. 37 | data MemShape :: Nat -> * where 38 | ShE :: MemShape Z 39 | ShC :: * -> MemShape n -> MemShape (S n) 40 | 41 | -- | Footprint is a memory shape indexed vector of ML-style 42 | -- references, with the typing ensuring that types of 43 | -- the references match locations in the memory shape. 44 | data Footprint :: forall memsize . MemShape memsize -> * where 45 | FE :: Footprint ShE 46 | FC :: (Typeable a) => Ref a -> Footprint sh -> Footprint (ShC a sh) 47 | 48 | -- | Addresses of memory locations. 49 | -- 50 | -- This is a type of finite sets (of locations) 51 | -- indexed by a specific memory shape. The typing 52 | -- ensures that the type of the address matches the 53 | -- type of values stored in a given location. 54 | data Addr a :: forall memsize . MemShape memsize -> * where 55 | AZ :: (Typeable a) => Addr a (ShC a sh) 56 | AS :: (Typeable a,Typeable b) => Addr a sh -> Addr a (ShC b sh) 57 | 58 | -- | Looking up the reference in a given footprint by its address. 59 | lkpRef :: (Typeable a) => Footprint memshape -> Addr a memshape -> Ref a 60 | lkpRef (FC r _) AZ = r 61 | lkpRef (FC _ mem) (AS addr) = lkpRef mem addr 62 | 63 | -- | A memory shape indexed effect for reading the value stored 64 | -- at a given address, and writing a value to a given address. 65 | data State (memshape :: MemShape memsize) :: * -> * where 66 | -- | Algebraic operation for reading the value stored at a given address. 67 | Get :: (Typeable a) => Addr a memshape -> State memshape a 68 | -- | Algebraic operation for writing the value to a given address. 69 | Put :: (Typeable a) => Addr a memshape -> a -> State memshape () 70 | 71 | -- | Generic effect for reading the value stored at a given address. 72 | get :: (Typeable a) => Addr a memshape -> User '[State memshape] a 73 | get addr = performU (Get addr) 74 | 75 | -- | Generic effect for writing the value to a given address. 76 | put :: (Typeable a) => Addr a memshape -> a -> User '[State memshape] () 77 | put addr x = performU (Put addr x) 78 | 79 | -- | The co-operations of the runner `fpRunner`. 80 | fpCoOps :: State memshape r -> Kernel '[MLState] (Footprint memshape) r 81 | fpCoOps (Get addr) = 82 | do mem <- getEnv; 83 | r <- return (lkpRef mem addr); 84 | user ((!) r) return 85 | fpCoOps (Put addr x) = 86 | do mem <- getEnv; 87 | r <- return (lkpRef mem addr); 88 | user (r =:= x) return 89 | 90 | -- | Runner that implements the global state effect `State` 91 | -- in an external context that provides the `MLState` effect. 92 | -- 93 | -- As its runtime state, this runner stores a footprint of 94 | -- ML-style references. The co-operations for `Get` and 95 | -- `Put` delegate the operations to some enveloping runner 96 | -- that implements the `MLState` effect of ML-style state. 97 | fpRunner :: Runner '[State memshape] '[MLState] (Footprint memshape) 98 | fpRunner = mkRunner fpCoOps 99 | 100 | -- | Scoped running of user code on a given footprint of 101 | -- general, external ML-style memory, using `fpRunner`. 102 | withFootprint :: Footprint memshape -> User '[State memshape] a -> User '[MLState] a 103 | withFootprint fp m = 104 | run 105 | fpRunner 106 | (return fp) 107 | m 108 | (\ x _ -> return x) -------------------------------------------------------------------------------- /src/Control/Runner/FPState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | {-| 7 | Module : Control.Runner.FPState 8 | Description : Runner for footprint-indexed global state, using effect typing to ensure that only the footprint is accessed 9 | Copyright : (c) Danel Ahman, 2019 10 | License : MIT 11 | Maintainer : danel.ahman@eesti.ee 12 | Stability : experimental 13 | 14 | This module implements a runner that provides access to 15 | footprint-indexed global state (with n-many locations 16 | storing values of possibly different types). 17 | 18 | We use effect typing to ensure that only locations in a 19 | given footprint are allowed to be accessed. Specifically, 20 | the `State` effect that this module provides is indexed by 21 | a footprint, which comprises the shape of the memory, 22 | specifying how many locations/addresses are present, and 23 | what are the types of values that they store. 24 | -} 25 | module Control.Runner.FPState ( 26 | Nat(..), MemShape(..), Memory(..), Addr(..), 27 | State(..), get, put, fpRunner, fpTopLevel 28 | ) where 29 | 30 | import Control.Runner 31 | import System.IO 32 | 33 | -- | Type of natural numbers that we use for the size of the memory. 34 | data Nat where 35 | Z :: Nat 36 | S :: Nat -> Nat 37 | 38 | -- | Shape of the memory. 39 | -- 40 | -- This is a length-indexed vector of the types that 41 | -- the memory locations store in the memory. 42 | data MemShape :: Nat -> * where 43 | ShE :: MemShape Z 44 | ShC :: * -> MemShape n -> MemShape (S n) 45 | 46 | -- | Contents of the memory. 47 | -- 48 | -- This is a memory shape indexed vector of values 49 | -- stored in the memory locations determined by the 50 | -- memory shape. The typing ensures that a location 51 | -- meant to store values of type @a@ indeed stores 52 | -- values of type @a@. 53 | data Memory :: forall memsize . MemShape memsize -> * where 54 | ME :: Memory ShE 55 | MC :: a -> Memory sh -> Memory (ShC a sh) 56 | 57 | -- | Addresses of memory locations. 58 | -- 59 | -- This is a type of finite sets (of locations) 60 | -- indexed by a specific memory shape. The typing 61 | -- ensures that the type of the address matches the 62 | -- type of values stored in a given location. 63 | data Addr a :: forall memsize . MemShape memsize -> * where 64 | AZ :: Addr a (ShC a sh) 65 | AS :: Addr a sh -> Addr a (ShC b sh) 66 | 67 | -- | Looking up the value of an address in the memory. 68 | lkp :: Memory memshape -> Addr a memshape -> a 69 | lkp (MC x _) AZ = x 70 | lkp (MC _ mem) (AS addr) = lkp mem addr 71 | 72 | -- | Updating the value of an address in the memory. 73 | upd :: Memory memshape -> Addr a memshape -> a -> Memory memshape 74 | upd (MC _ mem) AZ x = MC x mem 75 | upd (MC y mem) (AS addr) x = MC y (upd mem addr x) 76 | 77 | -- 78 | -- Signature of the state effect for 0..m-1 references. 79 | -- 80 | 81 | -- | A memory shape indexed effect for reading the value stored 82 | -- at a given address, and writing a value to a given address. 83 | data State (memshape :: MemShape memsize) :: * -> * where 84 | -- | Algebraic operation for reading the value stored at a given address. 85 | Get :: Addr a memshape -> State memshape a 86 | -- | Algebraic operation for writing the value to a given address. 87 | Put :: Addr a memshape -> a -> State memshape () 88 | 89 | -- | Generic effect for reading the value stored at a given address. 90 | get :: Addr a memshape -> User '[State memshape] a 91 | get addr = performU (Get addr) 92 | 93 | -- | Generic effect for writing the value to a given address. 94 | put :: Addr a memshape -> a -> User '[State memshape] () 95 | put addr x = performU (Put addr x) 96 | 97 | -- | The co-operations of the runner `fpRunner`. 98 | fpCoOps :: State memshape a -> Kernel sig (Memory memshape) a 99 | fpCoOps (Get addr) = 100 | do mem <- getEnv; 101 | return (lkp mem addr) 102 | fpCoOps (Put addr x) = 103 | do mem <- getEnv; 104 | setEnv (upd mem addr x) 105 | 106 | -- | Runner that implements the `State` effect, by reading 107 | -- values from its runtime state for the `Get` operations, 108 | -- and updating the values in its runtime state for the `Put` 109 | -- operations. 110 | fpRunner :: Runner '[State memshape] sig (Memory memshape) 111 | fpRunner = mkRunner fpCoOps 112 | 113 | -- | Top-level for running user code in the `State` effect (as a pure value). 114 | fpTopLevel :: Memory memshape -> User '[State memshape] a -> a 115 | fpTopLevel init m = 116 | pureTopLevel ( 117 | run 118 | fpRunner 119 | (return init) 120 | m 121 | (\ x _ -> return x) 122 | ) -------------------------------------------------------------------------------- /src/Control/Runner/IntState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | {-| 8 | Module : Control.Runner.IntState 9 | Description : Runner for integer-valued global state, using effect typing to ensure that only a given footprint is accessed 10 | Copyright : (c) Danel Ahman, 2019 11 | License : MIT 12 | Maintainer : danel.ahman@eesti.ee 13 | Stability : experimental 14 | 15 | This module implements a runner that provides access to 16 | integer-valued global state indexed by memory size (with 17 | n-many locations, all storing integers). 18 | 19 | We use effect typing to ensure that only locations in a 20 | given footprint are allowed to be accessed. Specifically, 21 | the `State` effect that this module provides is indexed by 22 | a footprint, the size of the memory, specifying how many 23 | locations/addresses are present, and thus can be accessed. 24 | -} 25 | module Control.Runner.IntState ( 26 | Nat(..), Addr(..), 27 | State(..), get, put, 28 | Memory, stRunner, withNewRef, topRunner, runSt 29 | ) where 30 | 31 | import Control.Runner 32 | import System.IO 33 | 34 | -- | Type of natural numbers that we use for the size of the memory. 35 | data Nat where 36 | Z :: Nat 37 | S :: Nat -> Nat 38 | 39 | -- | Type of memory addresses of a given size. 40 | data Addr :: Nat -> * where 41 | AZ :: Addr (S n) 42 | AS :: Addr n -> Addr (S n) 43 | 44 | -- | An memory size indexed effect for reading the value stored at 45 | -- a given memory address, and writing a value to a given memory address. 46 | data State (memsize :: Nat) :: * -> * where 47 | -- | Algebraic operation for reading the value stored at a given memory address. 48 | Get :: Addr memsize -> State memsize Int 49 | -- | Algebraic operation for writing the value to a given memory address. 50 | Put :: Addr memsize -> Int -> State memsize () 51 | 52 | -- | Generic effect for reading the value stored at a given memory address. 53 | get :: Addr memsize -> User '[State memsize] Int 54 | get addr = performU (Get addr) 55 | 56 | -- | Generic effect for writing the value to a given memory address. 57 | put :: Addr memsize -> Int -> User '[State memsize] () 58 | put addr x = performU (Put addr x) 59 | 60 | -- | The type of the runtime state of the runner `stRunner`. 61 | type Memory = Int 62 | 63 | -- | The co-operations of the runner `stRunner`. 64 | stCoOps :: State (S memsize) a -> Kernel '[State memsize] Memory a 65 | stCoOps (Get AZ) = getEnv 66 | stCoOps (Get (AS addr)) = performK (Get addr) 67 | stCoOps (Put AZ x) = setEnv x 68 | stCoOps (Put (AS addr) x) = performK (Put addr x) 69 | 70 | -- | Runner that implements the effect @State (S memsize)@ 71 | -- in an external context that provides the @State memsize@ effect. 72 | -- 73 | -- The intuition is that every time we call `run` with `stRunner`, 74 | -- we allocate a new "fresh" memory address. Internally then 75 | -- this runner keeps only the value of the most recently 76 | -- allocated memory address in its runtime state, and 77 | -- delegates `Get` and `Put` operations to all other 78 | -- addresses to some enveloping runner (implementing @State memsize@). 79 | stRunner :: Runner '[State (S memsize)] '[State memsize] Memory 80 | stRunner = mkRunner stCoOps 81 | 82 | -- | A scoped allocation of a fresh memory address. 83 | -- 84 | -- The first `Int`-valued argument is the initial value stored 85 | -- in the fresh memory address. 86 | withNewRef :: Int 87 | -> User '[State (S memsize)] a 88 | -> User '[State memsize] a 89 | withNewRef init m = 90 | run stRunner (return init) m (\ x _ -> return x) 91 | 92 | -- | The co-operations of the runner `topRunner`. 93 | topCoOps :: State Z r -> Kernel '[] () r 94 | topCoOps (Get _) = 95 | error "Should not be possible to run `get` in empty state" 96 | topCoOps (Put _ x) = 97 | error "Should not be possible to run `put` in empty state" 98 | 99 | -- | Top level runner for running user code with the 100 | -- `State` effect in the empty external signature. 101 | topRunner :: Runner '[State Z] '[] () 102 | topRunner = mkRunner topCoOps 103 | 104 | -- | Top-level running of user code with the `State` 105 | -- effect. It simply wraps `pureTopLevel` around running 106 | -- user code with `topRunner`. The given user code starts 107 | -- with no memory addresses allocated, and can then 108 | -- allocate new addresses using `withNewRef`. 109 | runSt :: User '[State Z] a -> a 110 | runSt m = 111 | pureTopLevel ( 112 | run 113 | topRunner 114 | (return ()) 115 | m 116 | (\ x _ -> return x) 117 | ) 118 | -------------------------------------------------------------------------------- /src/Control/Runner/IntMLState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | {-| 7 | Module : Control.Runner.IntMLState 8 | Description : Runner for integer-valued ML-style state (supporting allocation, dereferencing, and assignment) 9 | Copyright : (c) Danel Ahman, 2019 10 | License : MIT 11 | Maintainer : danel.ahman@eesti.ee 12 | Stability : experimental 13 | 14 | This module implements a runner that provides integer-valued 15 | ML-style state, i.e., state that supports allocation of references, 16 | dereferencing a value of a reference, and assignment to a reference. 17 | -} 18 | module Control.Runner.IntMLState 19 | ( 20 | Ref, Heap, IntMLState(..), 21 | alloc, (!), (=:=), 22 | intMLRunner, intMLInitialiser, intMLFinaliser, intMLTopLevel, 23 | ) where 24 | 25 | import Control.Runner 26 | 27 | -- | Type of natural numbers that we use for the address of references. 28 | data Nat where 29 | Z :: Nat 30 | S :: Nat -> Nat 31 | 32 | instance Eq Nat where 33 | Z == Z = True 34 | (S n) == (S m) = n == m 35 | _ == _ = False 36 | 37 | -- | Addresses of references. 38 | type Addr = Nat 39 | 40 | -- | Type of references. 41 | data Ref where 42 | R :: Addr -> Ref 43 | 44 | -- | Exposing the address of a reference (private to this module). 45 | addrOf :: Ref -> Addr 46 | addrOf (R r) = r 47 | 48 | -- | Memory if a partial map from references to integers. 49 | type Memory = Ref -> Maybe Int 50 | 51 | -- | Type of heaps. These comprise a partial map from 52 | -- references to integers, and the address of 53 | -- the next fresh reference to be allocated. 54 | data Heap = H { memory :: Memory, nextAddr :: Addr } 55 | 56 | -- | Reading the value of a reference in the heap. 57 | heapSel :: Heap -> Ref -> Int 58 | heapSel h r = 59 | case memory h r of 60 | Nothing -> error "reference not in the heap" -- raising a runtime error 61 | Just x -> x 62 | 63 | -- | Updating the value of a reference in the memory. 64 | memUpd :: Memory -> Ref -> Int -> Memory 65 | memUpd m r x r' = 66 | if (addrOf r == addrOf r') 67 | then Just x 68 | else m r' 69 | 70 | -- | Updatring the value of a reference 71 | -- in the heap, with the given initial value. 72 | heapUpd :: Heap -> Ref -> Int -> Heap 73 | heapUpd h r x = h { memory = memUpd (memory h) r x } 74 | 75 | -- | Allocating a fresh reference in the heap. 76 | heapAlloc :: Heap -> Int -> (Ref,Heap) 77 | heapAlloc h init = 78 | let r = R (nextAddr h) in 79 | (r , H { memory = memUpd (memory h) r init , 80 | nextAddr = S (nextAddr h) }) 81 | 82 | -- | An effect for integer-valued ML-style state. 83 | data IntMLState a where 84 | -- | Algebraic operation for allocating a fresh reference. 85 | Alloc :: Int -> IntMLState Ref 86 | -- | Algebraic operation for dereferencing a reference. 87 | Deref :: Ref -> IntMLState Int 88 | -- | Algebraic operation for assiging a value to a reference. 89 | Assign :: Ref -> Int -> IntMLState () 90 | 91 | -- | Generic effect for allocating a fresh reference. 92 | alloc :: Member IntMLState sig => Int -> User sig Ref 93 | alloc init = performU (Alloc init) 94 | 95 | -- | Generic effect for dereferencing a reference. 96 | (!) :: Member IntMLState sig => Ref -> User sig Int 97 | (!) r = performU (Deref r) 98 | 99 | -- | Generic effect for assigning a value to a reference. 100 | (=:=) :: Member IntMLState sig => Ref -> Int -> User sig () 101 | (=:=) r x = performU (Assign r x) 102 | 103 | -- | The co-operations of the runner `intMLRunner`. 104 | intMLCoOps :: IntMLState a -> Kernel sig Heap a 105 | intMLCoOps (Alloc init) = 106 | do h <- getEnv; 107 | (r,h') <- return (heapAlloc h init); 108 | setEnv h'; 109 | return r 110 | intMLCoOps (Deref r) = 111 | do h <- getEnv; 112 | return (heapSel h r) 113 | intMLCoOps (Assign r x) = 114 | do h <- getEnv; 115 | setEnv (heapUpd h r x) 116 | 117 | -- | Runner that implements the `IntMLState` effect. 118 | -- 119 | -- Its runtime state is a heap (see `Heap`), and its 120 | -- co-operations call the corresponding allocation, 121 | -- dereferencing, and assignment operations on the heap. 122 | intMLRunner :: Runner '[IntMLState] sig Heap 123 | intMLRunner = mkRunner intMLCoOps 124 | 125 | -- | Initialiser for the runner `intMLRunner` that 126 | -- initialises the heap with the empty partial map, 127 | -- and sets the next address to be allocated to zero. 128 | intMLInitialiser :: User sig Heap 129 | intMLInitialiser = return (H { memory = \ _ -> Nothing , nextAddr = Z }) 130 | 131 | -- | Finaliser for the runner `intMLRunner` that 132 | -- discards the final value of the heap, and simply 133 | -- passes on the return value. 134 | intMLFinaliser :: a -> Heap -> User sig a 135 | intMLFinaliser x _ = return x 136 | 137 | -- | Top level for running user code that can use 138 | -- integer-valued ML-style state. 139 | intMLTopLevel :: User '[IntMLState] a -> a 140 | intMLTopLevel m = 141 | pureTopLevel ( 142 | run 143 | intMLRunner 144 | intMLInitialiser 145 | m 146 | intMLFinaliser 147 | ) -------------------------------------------------------------------------------- /examples/without_signals/FileIOTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | 5 | {-| 6 | Module : FileIOTests 7 | Description : Example use cases of the runners for file IO from `Control.Runner.FileIO` 8 | Copyright : (c) Danel Ahman, 2019 9 | License : MIT 10 | Maintainer : danel.ahman@eesti.ee 11 | Stability : experimental 12 | 13 | This module provides some example use cases of the 14 | runners for file IO from `Control.Runner.FileIO`. 15 | -} 16 | module FileIOTests where 17 | 18 | import Control.Runner 19 | import Control.Runner.FileIO 20 | 21 | import System.IO hiding (withFile) 22 | 23 | writeLines :: Member File sig => [String] -> User sig () 24 | writeLines [] = return () 25 | writeLines (l:ls) = do fWrite l; 26 | fWrite "\n"; 27 | writeLines ls 28 | 29 | exampleLines = ["Lorem ipsum dolor sit amet, consectetur adipiscing elit.", 30 | "Cras sit amet felis arcu.", 31 | "Maecenas ac mollis mauris, vel fermentum nibh."] 32 | 33 | test1 :: User '[IO] () 34 | test1 = -- in IO signature, using IO container 35 | run 36 | fioRunner 37 | ioFioInitialiser 38 | ( -- in FileIO signature, using FIO runner 39 | run 40 | fhRunner 41 | (fioFhInitialiser "./out.txt") 42 | ( -- in File signature, using FH runner 43 | writeLines exampleLines 44 | ) 45 | fioFhFinaliser 46 | ) 47 | ioFioFinaliser 48 | 49 | test2 = ioTopLevel test1 50 | 51 | test3 :: User '[IO] () 52 | test3 = -- in IO signature, using IO container 53 | run 54 | fioRunner 55 | ioFioInitialiser 56 | ( -- in FileIO signature, using FIO runner 57 | run 58 | fhRunner 59 | (fioFhInitialiser "./out2.txt") 60 | ( -- in File signature, using FH runner 61 | do s <- fRead; -- contents of the file at the point of entering the FH runner 62 | fWrite s; -- write the contents back to the file 63 | writeLines exampleLines -- write additional lines to the file 64 | ) 65 | fioFhFinaliser 66 | ) 67 | ioFioFinaliser 68 | 69 | test4 = ioTopLevel test3 70 | 71 | test5 :: User '[IO] () 72 | test5 = -- in IO signature, using IO container 73 | run 74 | fioRunner 75 | ioFioInitialiser 76 | ( -- in FileIO signature, using FIO runner 77 | run 78 | fhRunner 79 | (fioFhInitialiser "./out3.txt") 80 | ( -- in File signature, using FH runner 81 | do run 82 | fcRunner 83 | fhFcInitialiser 84 | ( -- in File signature, using FC runner 85 | writeLines exampleLines -- writing example lines using FC runner 86 | ) 87 | fhFcFinaliser; 88 | fWrite "Proin eu porttitor enim." -- writing another line using FH runner 89 | ) 90 | fioFhFinaliser 91 | ) 92 | ioFioFinaliser 93 | 94 | test6 = ioTopLevel test5 95 | 96 | test7 :: User '[IO] () 97 | test7 = -- in IO signature, using IO container 98 | run 99 | fioRunner 100 | ioFioInitialiser 101 | ( -- in FileIO signature, using FIO runner 102 | run 103 | fhRunner 104 | (fioFhInitialiser "./out3.txt") 105 | ( -- in File signature, using FH runner 106 | do run 107 | fcRunner 108 | fhFcInitialiser 109 | ( -- in File signature, using FC runner 110 | writeLines exampleLines -- writing example lines using FC runner 111 | ) 112 | (\ x s -> do fWrite "Finalising FC runner\n"; 113 | fhFcFinaliser x s); 114 | fWrite "Proin eu porttitor enim.\n" -- writing another line using FH runner 115 | ) 116 | (\ x (s,fh) -> do fWriteOS fh "Finalising FH runner\n"; 117 | fioFhFinaliser x (s,fh)) 118 | ) 119 | ioFioFinaliser 120 | 121 | test8 = ioTopLevel test7 122 | 123 | test9 :: User '[IO] () 124 | test9 = -- in IO signature, using IO container 125 | withFile 126 | "./out4.txt" 127 | ( -- in File signature, using FIO,FH,FC runners 128 | do writeLines exampleLines; 129 | fWrite "\nProin eu porttitor enim.\n\n"; 130 | s <- fRead; -- the initial contents of the file 131 | fWrite "\nInitial contents of the file [START]\n"; 132 | fWrite s; 133 | fWrite "\nInitial contents of the file [END]\n" 134 | ) 135 | 136 | test10 = ioTopLevel test9 -------------------------------------------------------------------------------- /src/Control/Runner/MLState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | {-| 12 | Module : Control.Runner.MLState 13 | Description : Runner for general ML-style state (supporting allocation, dereferencing, and assignment) 14 | Copyright : (c) Danel Ahman, 2019 15 | License : MIT 16 | Maintainer : danel.ahman@eesti.ee 17 | Stability : experimental 18 | 19 | This module implements a runner that provides general ML-style state 20 | that supports allocation of references, dereferencing references, 21 | and assignment to references. 22 | 23 | We allow a large class of Haskell values to be stored in our references, 24 | as long as they are instances of the `Typeable` type class. We use this 25 | restriction to be able to compare the types of references for equality, 26 | so as to be able to define decidable equality for references (`refEq`), 27 | which we in turn use when updating the values stored in the heap. 28 | -} 29 | module Control.Runner.MLState 30 | ( 31 | Ref, refEq, MLState(..), Heap, 32 | alloc, (!), (=:=), 33 | mlRunner, mlInitialiser, mlFinaliser, mlTopLevel, 34 | Typeable 35 | ) where 36 | 37 | import Control.Runner 38 | 39 | import Data.Typeable 40 | 41 | -- | Type of natural numbers that we use for the address of references. 42 | data Nat where 43 | Z :: Nat 44 | S :: Nat -> Nat 45 | 46 | instance Eq Nat where 47 | Z == Z = True 48 | (S n) == (S m) = n == m 49 | _ == _ = False 50 | 51 | -- | Addresses of references. 52 | type Addr = Nat 53 | 54 | -- | Type of references, restricted to only store 55 | -- values of types satisfying the `Typeable` type class. 56 | data Ref a where 57 | R :: (Typeable a) => Addr -> Ref a 58 | 59 | -- | Exposing the address of a reference (private to this module). 60 | addrOf :: Ref a -> Addr 61 | addrOf (R r) = r 62 | 63 | -- | Decidable equality on references (of possibly different types). 64 | -- 65 | -- If the references are deemed to be equal, the equality test also 66 | -- returns a proof that their types are (propositionally) equal. 67 | refEq :: (Typeable a,Typeable b) => Ref a -> Ref b -> Maybe (a :~: b) 68 | refEq (r :: Ref a) (r' :: Ref b) = 69 | if (addrOf r == addrOf r') 70 | then eqT @a @b 71 | else Nothing 72 | 73 | -- | Memory is a partial map from references to `Typeable` values. 74 | type Memory = forall a . (Typeable a) => Ref a -> Maybe a 75 | 76 | -- | Type of heaps. These comprise a partial map 77 | -- from references to values, and the address of 78 | -- the next fresh reference to be allocated. 79 | data Heap = H { memory :: Memory, nextAddr :: Addr } 80 | 81 | -- | Reading the value of a reference in the heap. 82 | heapSel :: (Typeable a) => Heap -> Ref a -> a 83 | heapSel h r = 84 | case memory h r of 85 | Nothing -> error "reference not in the heap" -- raising a runtime error 86 | Just x -> x 87 | 88 | -- | Updating the value of a reference in the memory. 89 | memUpd :: (Typeable a) => Memory -> Ref a -> a -> Memory 90 | memUpd mem (r :: Ref a) x (r' :: Ref b) = 91 | case refEq r r' of 92 | Nothing -> mem r' 93 | Just Refl -> Just x 94 | 95 | -- | Updatring the value of a reference in the heap. 96 | heapUpd :: (Typeable a) => Heap -> Ref a -> a -> Heap 97 | heapUpd h r x = h { memory = memUpd (memory h) r x } 98 | 99 | -- | Allocating a fresh reference in the heap, 100 | -- with the given initial value. 101 | heapAlloc :: (Typeable a) => Heap -> a -> (Ref a,Heap) 102 | heapAlloc h init = 103 | let r = R (nextAddr h) in 104 | (r , H { memory = memUpd (memory h) r init , 105 | nextAddr = S (nextAddr h) }) 106 | 107 | -- | An effect for general ML-style state. 108 | data MLState a where 109 | -- | Algebraic operation for allocating a fresh reference. 110 | Alloc :: (Typeable a) => a -> MLState (Ref a) 111 | -- | Algebraic operation for dereferencing a reference. 112 | Deref :: (Typeable a) => Ref a -> MLState a 113 | -- | Algebraic operation for assiging a value to a reference. 114 | Assign :: (Typeable a) => Ref a -> a -> MLState () 115 | 116 | -- | Generic effect for allocating a fresh reference. 117 | alloc :: (Typeable a,Member MLState sig) => a -> User sig (Ref a) 118 | alloc init = performU (Alloc init) 119 | 120 | -- | Generic effect for dereferencing a reference. 121 | (!) :: (Typeable a,Member MLState sig) => Ref a -> User sig a 122 | (!) r = performU (Deref r) 123 | 124 | -- | Generic effect for assigning a value to a reference. 125 | (=:=) :: (Typeable a,Member MLState sig) => Ref a -> a -> User sig () 126 | (=:=) r x = performU (Assign r x) 127 | 128 | -- | The co-operations of the runner `mlRunner`. 129 | mlCoOps :: MLState a -> Kernel sig Heap a 130 | mlCoOps (Alloc init) = 131 | do h <- getEnv; 132 | (r,h') <- return (heapAlloc h init); 133 | setEnv h'; 134 | return r 135 | mlCoOps (Deref r) = 136 | do h <- getEnv; 137 | return (heapSel h r) 138 | mlCoOps (Assign r x) = 139 | do h <- getEnv; 140 | setEnv (heapUpd h r x) 141 | 142 | -- | Runner that implements the `MLState` effect. 143 | -- 144 | -- Its runtime state is a heap (see `Heap`), and its 145 | -- co-operations call the corresponding allocation, 146 | -- dereferencing, and assignment operations on the heap. 147 | mlRunner :: Runner '[MLState] sig Heap 148 | mlRunner = mkRunner mlCoOps 149 | 150 | -- | Initialiser for the runner `mlRunner` that 151 | -- initialises the heap with the empty partial map, 152 | -- and sets the next address to be allocated to zero. 153 | mlInitialiser :: User sig Heap 154 | mlInitialiser = return (H { memory = \ _ -> Nothing , nextAddr = Z }) 155 | 156 | -- | Finaliser for the runner `mlRunner` that 157 | -- discards the final value of the heap, and simply 158 | -- passes on the return value. 159 | mlFinaliser :: a -> Heap -> User sig a 160 | mlFinaliser x _ = return x 161 | 162 | -- | Top level for running user code that can use ML-style state. 163 | mlTopLevel :: User '[MLState] a -> a 164 | mlTopLevel m = 165 | pureTopLevel ( 166 | run 167 | mlRunner 168 | mlInitialiser 169 | m 170 | mlFinaliser 171 | ) -------------------------------------------------------------------------------- /src/Control/SignalRunner/MonotonicMLState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | {-| 10 | Module : Control.SignalRunner.MonotonicMLState 11 | Description : Runner for monotonic ML-style state (supporting allocation, dereferencing, and assignment) 12 | Copyright : (c) Danel Ahman, 2019 13 | License : MIT 14 | Maintainer : danel.ahman@eesti.ee 15 | Stability : experimental 16 | 17 | This module implements a runner that provides monotonic ML-style state 18 | that supports allocation of references, dereferencing references, and 19 | assignment to references. 20 | 21 | We implement monotonicity similarly to the [F*](https://www.fstar-lang.org) 22 | language, by assiging a preorder with each reference, and ensuring that 23 | any assignments to references follow their respective preorders. While F* 24 | uses dependent types to enforce such monotonicity statically, we use 25 | runners to make dynamic checks. 26 | 27 | The idea is that the runner provided by this module would be interposed 28 | between the runner `mlRunner` and the user code. It internally only 29 | stores a memory of preorders, and delegates any reference allocation, 30 | dereferencing, and assignment operations to the runner `mlRunner` 31 | (or any other runner implementing the `MLState` effect). 32 | 33 | If one attempts to perform an assignment to a reference with a value 34 | that is not related to the old value of the reference by the respective 35 | preorder, then we raise a corresponding exception (alternatively, one could 36 | raise a (kill) signal, so as to not allow the user to re-try assingment 37 | with a different value, e.g., if we were to care about not leaking 38 | information about the exisiting value of the reference to user code). 39 | 40 | Further, if we observe that the user tries assignment with a reference that has 41 | no preorder assigned, we raise a (kill) signal and kill the user code being run. 42 | -} 43 | module Control.SignalRunner.MonotonicMLState 44 | ( 45 | MonE(..), MonS(..), Preorder, 46 | Ref, MonMemory, 47 | MonMLState(..), alloc, (!), (=:=), 48 | monRunner, monInitialiser, monFinaliserVal, monFinaliserExc, monFinaliserSig, monTopLevel, 49 | Typeable 50 | ) where 51 | 52 | import Control.SignalRunner 53 | import Control.SignalRunner.SignalMLState hiding (alloc, (!), (=:=)) 54 | import qualified Control.SignalRunner.SignalMLState as ML (alloc, deref, assign) 55 | 56 | import Data.Typeable 57 | 58 | -- | Type of exceptions. 59 | data MonE where 60 | -- | Exception raised when we observe that an assignment 61 | -- to a reference is not following the associated preorder. 62 | MonotonicityViolationException :: Ref a -> MonE 63 | 64 | instance Show MonE where 65 | show (MonotonicityViolationException r) = "MononicityViolationException -- " ++ show r 66 | 67 | -- | Type of (kill) signals. 68 | data MonS where 69 | -- | Signal sent when we observe that a given 70 | -- reference has no preorder associated with it. 71 | MissingPreorderSignal :: Ref a -> MonS 72 | 73 | instance Show MonS where 74 | show (MissingPreorderSignal r) = "MissingPreorderSignal -- " ++ show r 75 | 76 | -- | Type of preorders (implicitly assumed to satisfy reflexivity and transitivity). 77 | type Preorder a = a -> a -> Bool 78 | 79 | -- | Type of memory which associates `Ref`-typed references with 80 | -- preorder. It is a partial map from references to preorders. 81 | newtype MonMemory = M { memory :: forall a . (Typeable a) => Ref a -> Maybe (Preorder a)} 82 | 83 | -- | Looking up the preorder associated with a given reference. 84 | memSel :: (Typeable a) => MonMemory -> Ref a -> Maybe (Preorder a) 85 | memSel m r = memory m r 86 | 87 | -- | Updating the preorder associated with a given reference. 88 | memUpd :: (Typeable a) => MonMemory -> Ref a -> Preorder a -> MonMemory 89 | memUpd m r p = 90 | M { memory = 91 | \ r' -> case refEq r r' of 92 | Nothing -> memory m r' 93 | Just Refl -> Just p } 94 | 95 | -- | An effect for monotonic ML-style state. 96 | data MonMLState :: * -> * where 97 | -- | Algebraic operation for allocating a fresh reference 98 | -- and associating a preorder with it. 99 | MonAlloc :: (Typeable a) => a -> Preorder a -> MonMLState (Ref a) 100 | -- | Algebraic operation for dereferencing a reference. 101 | MonDeref :: (Typeable a) => Ref a -> MonMLState a 102 | -- | Algebraic operation for assiging a value to a reference. 103 | MonAssign :: (Typeable a) => Ref a -> a -> MonMLState (Either () MonE) 104 | 105 | -- | Generic effect for allocating a fresh reference. 106 | alloc :: (Typeable a,Member MonMLState sig) => a -> Preorder a -> User sig e (Ref a) 107 | alloc init rel = performU (MonAlloc init rel) 108 | 109 | -- | Generic effect for dereferencing a reference. 110 | (!) :: (Typeable a,Member MonMLState sig) => Ref a -> User sig e a 111 | (!) r = performU (MonDeref r) 112 | 113 | -- | Generic effect for assigning a value to a reference. 114 | (=:=) :: (Typeable a,Member MonMLState sig) => Ref a -> a -> User sig MonE () 115 | (=:=) r x = do xe <- performU (MonAssign r x); 116 | either return (\ e -> raiseU e) xe 117 | 118 | -- | The co-operations of the runner `monRunner`. 119 | monCoOps :: Member MLState sig => MonMLState a -> Kernel sig Zero MonS MonMemory a 120 | monCoOps (MonAlloc init rel) = 121 | do r <- user (ML.alloc init) return impossible; 122 | m <- getEnv; 123 | m' <- return (memUpd m r rel); 124 | setEnv m'; 125 | return r 126 | monCoOps (MonDeref r) = 127 | user (ML.deref r) return impossible 128 | monCoOps (MonAssign r y) = 129 | do x <- user (ML.deref r) return impossible; 130 | m <- getEnv; 131 | maybe 132 | (kill (MissingPreorderSignal r)) 133 | (\ rel -> if (rel x y) 134 | then (user (ML.assign r y) (\ x -> return (Left x)) impossible) 135 | else (return (Right (MonotonicityViolationException r)))) 136 | (memSel m r) 137 | 138 | -- | Runner that implements the `MonMLState` effect. 139 | -- 140 | -- Its runtime state is a memory of preorders (see `MonMemory`), 141 | -- and its co-operations call both the corresponding allocation, 142 | -- dereferencing, and assignment operations on the memory, 143 | -- and on some enveloping runner that implements the `MLState` 144 | -- effect, e.g., such as `mlRunner`. 145 | -- 146 | -- In the co-operation `MonAssign`, if there is no preorder 147 | -- associated with the given reference, then the (kill) signal 148 | -- `MissingPreorderSignal` gets sent, and user code being run is killed. 149 | -- 150 | -- Further in the co-operation `MonAssign`, if the new value being 151 | -- assigned to a reference is not related to its existing value, 152 | -- then an exception `MonotonicityViolationException` gets raised. 153 | monRunner :: Member MLState sig => Runner '[MonMLState] sig MonS MonMemory 154 | monRunner = mkRunner monCoOps 155 | 156 | -- | Initialiser for the runner `monRunner` that 157 | -- initialises the memory with the empty partial map. 158 | monInitialiser :: User sig Zero MonMemory 159 | monInitialiser = return (M { memory = \ _ -> Nothing }) 160 | 161 | -- | Finaliser for return values for the runner `mlRunner`, 162 | -- which discards the final value of the memory, and simply 163 | -- passes on the return value. 164 | monFinaliserVal :: a -> MonMemory -> User sig Zero a 165 | monFinaliserVal x _ = return x 166 | 167 | -- | Finaliser for exceptions for the runner `mlRunner`, 168 | -- which raises a Haskell runtime error to signify 169 | -- that an uncaught exception reached the top level. 170 | monFinaliserExc :: MonE -> MonMemory -> User sig Zero a 171 | monFinaliserExc e _ = error ("exception reached (monotonic) top level (" ++ show e ++ ")") 172 | 173 | -- | Finaliser for signals for the runner `mlRunner`, 174 | -- which raises a Haskell runtime error to signify 175 | -- that an uncaught signal reached the top level. 176 | monFinaliserSig :: MonS -> User sig Zero a 177 | monFinaliserSig s = error ("signal reached (monotonic) top level (" ++ show s ++ ")") 178 | 179 | -- | Top level for running user code that can use monotonic ML-style state. 180 | monTopLevel :: User '[MonMLState] MonE a -> a 181 | monTopLevel m = 182 | pureTopLevel ( 183 | run 184 | mlRunner 185 | mlInitialiser 186 | (run 187 | monRunner 188 | monInitialiser 189 | m 190 | monFinaliserVal 191 | monFinaliserExc 192 | monFinaliserSig) 193 | mlFinaliserVal 194 | mlFinaliserExc 195 | mlFinaliserSig 196 | ) 197 | -------------------------------------------------------------------------------- /src/Control/SignalRunner/ExcMLState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | {-| 12 | Module : Control.SignalRunner.ExcMLState 13 | Description : Runner for general ML-style state (supporting allocation, dereferencing, and assignment) 14 | Copyright : (c) Danel Ahman, 2019 15 | License : MIT 16 | Maintainer : danel.ahman@eesti.ee 17 | Stability : experimental 18 | 19 | This module implements a runner that provides general ML-style state 20 | that supports allocation of references, dereferencing references, 21 | and assignment to references. 22 | 23 | We allow a large class of Haskell values to be stored in our references, 24 | as long as they are instances of the `Typeable` type class. We use this 25 | restriction to be able to compare the types of references for equality, 26 | so as to be able to define decidable equality for references (`refEq`), 27 | which we in turn use when updating the values stored in the heap. 28 | 29 | If one attempts to access a non-existent reference (for dereferencing 30 | or assignment), then the corresponding co-operation is going to raise an 31 | exception, which one can catch with `tryWithU` or the finaliser of `run`. 32 | -} 33 | module Control.SignalRunner.ExcMLState 34 | ( 35 | Ref, refEq, MLState(..), E(..), Heap, 36 | alloc, (!), (=:=), 37 | mlRunner, mlInitialiser, mlFinaliserVal, 38 | mlFinaliserExc, mlFinaliserSig, mlTopLevel, 39 | Typeable 40 | ) where 41 | 42 | import Control.SignalRunner 43 | 44 | import Data.Typeable 45 | 46 | -- | Type of exceptions. 47 | data E where 48 | -- | Exception raised when we observe that the given 49 | -- reference is not in the heap during dereferencing. 50 | RefNotInHeapInDerefException :: Ref a -> E 51 | -- | Exception raised when we observe that the given 52 | -- reference is not in the heap during assignment. 53 | RefNotInHeapInAssignException :: Ref a -> E 54 | 55 | instance Show E where 56 | show (RefNotInHeapInDerefException r) = "RefNotInHeapInDerefException -- " ++ show r 57 | show (RefNotInHeapInAssignException r) = "RefNotInHeapInAssignException -- " ++ show r 58 | 59 | -- | Type of natural numbers that we use for the address of references. 60 | data Nat where 61 | Z :: Nat 62 | S :: Nat -> Nat 63 | 64 | instance Eq Nat where 65 | Z == Z = True 66 | (S n) == (S m) = n == m 67 | _ == _ = False 68 | 69 | instance Show Nat where 70 | show Z = "Z" 71 | show (S n) = "S " ++ show n 72 | 73 | -- | Addresses of references. 74 | type Addr = Nat 75 | 76 | -- | Type of references, restricted to only store 77 | -- values of types satisfying the `Typeable` type class. 78 | data Ref a where 79 | R :: (Typeable a) => Addr -> Ref a 80 | 81 | instance Show (Ref a) where 82 | show r = "ref. with address " ++ show (addrOf r) 83 | 84 | -- | Exposing the address of a reference (private to this module). 85 | addrOf :: Ref a -> Addr 86 | addrOf (R r) = r 87 | 88 | -- | Decidable equality on references (of possibly different types). 89 | -- 90 | -- If the references are deemed to be equal, the equality test also 91 | -- returns a proof that their types are (propositionally) equal. 92 | refEq :: (Typeable a,Typeable b) => Ref a -> Ref b -> Maybe (a :~: b) 93 | refEq (r :: Ref a) (r' :: Ref b) = 94 | if (addrOf r == addrOf r') 95 | then eqT @a @b 96 | else Nothing 97 | 98 | -- | Memory is a partial map from references to `Typeable` values. 99 | type Memory = forall a . (Typeable a) => Ref a -> Maybe a 100 | 101 | -- | Type of heaps. These comprise a partial map from 102 | -- references to values, and the address of 103 | -- the next fresh reference to be allocated. 104 | data Heap = H { memory :: Memory, nextAddr :: Addr } 105 | 106 | -- | Reading the value of a reference in the heap. 107 | -- 108 | -- It returns an optional value, depending on whether 109 | -- the reference was present in the heap or not. 110 | heapSel :: (Typeable a) => Heap -> Ref a -> Maybe a 111 | heapSel h r = memory h r 112 | 113 | -- | Updating the value of a reference in the memory. 114 | memUpd :: (Typeable a) => Memory -> Ref a -> a -> Memory 115 | memUpd mem r x r' = 116 | case refEq r r' of 117 | Nothing -> mem r' 118 | Just Refl -> Just x 119 | 120 | -- | Updatring the value of a reference in the heap. 121 | heapUpd :: (Typeable a) => Heap -> Ref a -> a -> Heap 122 | heapUpd h r x = h { memory = memUpd (memory h) r x } 123 | 124 | -- | Allocating a fresh reference in the heap, 125 | -- with the given initial value. 126 | heapAlloc :: (Typeable a) => Heap -> a -> (Ref a,Heap) 127 | heapAlloc h init = 128 | let r = R (nextAddr h) in 129 | (r , H { memory = memUpd (memory h) r init , 130 | nextAddr = S (nextAddr h) }) 131 | 132 | -- | An effect for general ML-style state. 133 | data MLState a where 134 | -- | Algebraic operation for allocating a fresh reference. 135 | Alloc :: (Typeable a) => a -> MLState (Ref a) 136 | -- | Algebraic operation for dereferencing a reference, raises 137 | -- an exception in `E` when the reference is not present in the heap. 138 | Deref :: (Typeable a) => Ref a -> MLState (Either a E) 139 | -- | Algebraic operation for assiging a value to a reference, raises 140 | -- an exception in `E` when the reference is not present in the heap. 141 | Assign :: (Typeable a) => Ref a -> a -> MLState (Either () E) 142 | 143 | -- | Generic effect for allocating a fresh reference. 144 | alloc :: (Typeable a,Member MLState sig) => a -> User sig e (Ref a) 145 | alloc init = performU (Alloc init) 146 | 147 | -- | Generic effect for dereferencing a reference. 148 | (!) :: (Typeable a,Member MLState sig) => Ref a -> User sig E a 149 | (!) r = do xe <- performU (Deref r); 150 | either return (\ e -> raiseU e) xe 151 | 152 | -- | Generic effect for assigning a value to a reference. 153 | (=:=) :: (Typeable a,Member MLState sig) => Ref a -> a -> User sig E () 154 | (=:=) r x = do xe <- performU (Assign r x); 155 | either return (\ e -> raiseU e) xe 156 | 157 | -- | The co-operations of the runner `mlRunner`. 158 | mlCoOps :: MLState a -> Kernel sig Zero Zero Heap a 159 | mlCoOps (Alloc init) = 160 | do h <- getEnv; 161 | (r,h') <- return (heapAlloc h init); 162 | setEnv h'; 163 | return r 164 | mlCoOps (Deref r) = 165 | do h <- getEnv; 166 | maybe 167 | (return (Right (RefNotInHeapInDerefException r))) 168 | (\ x -> return (Left x)) 169 | (heapSel h r) 170 | mlCoOps (Assign r x) = 171 | do h <- getEnv; 172 | maybe 173 | (return (Right (RefNotInHeapInAssignException r))) 174 | (\ _ -> do setEnv (heapUpd h r x); return (Left ())) 175 | (heapSel h r) 176 | 177 | -- | Runner that implements the `MLState` effect. 178 | -- 179 | -- Its runtime state is a heap (see `Heap`), and its 180 | -- co-operations call the corresponding allocation, 181 | -- dereferencing, and assignment operations on the heap. 182 | -- 183 | -- In the co-operation `Deref`, if the reference is 184 | -- not present in the heap, the exception 185 | -- `RefNotInHeapInDerefException` gets raised. 186 | -- 187 | -- In the co-operation `Assign`, if the reference is 188 | -- not present in the heap, the exception 189 | -- `RefNotInHeapInAssignException` gets raised. 190 | mlRunner :: Runner '[MLState] sig Zero Heap 191 | mlRunner = mkRunner mlCoOps 192 | 193 | -- | Initialiser for the runner `mlRunner` that 194 | -- initialises the heap with the empty partial map, 195 | -- and sets the next address to be allocated to zero. 196 | mlInitialiser :: User sig Zero Heap 197 | mlInitialiser = return (H { memory = \ _ -> Nothing , nextAddr = Z }) 198 | 199 | -- | Finaliser for return values for the runner `mlRunner`, 200 | -- which discards the final value of the heap, and simply 201 | -- passes on the return value. 202 | mlFinaliserVal :: a -> Heap -> User sig Zero a 203 | mlFinaliserVal x _ = return x 204 | 205 | -- | Finaliser for exceptions for the runner `mlRunner`, 206 | -- which discards the final value of the heap, and 207 | -- simply raises a Haskell runtime error to signify 208 | -- that an uncaught exception reached the top level. 209 | mlFinaliserExc :: E -> Heap -> User sig Zero a 210 | mlFinaliserExc e _ = error ("exception reached top level (" ++ show e ++ ")") 211 | 212 | -- | Finaliser for signals for the runner `mlRunner`, 213 | -- which is vacuously defined because there are 214 | -- no signals (the signals index is `Zero`). 215 | mlFinaliserSig :: Zero -> User sig Zero a 216 | mlFinaliserSig = impossible 217 | 218 | -- | Top level for running user code that can use ML-style state. 219 | mlTopLevel :: User '[MLState] E a -> a 220 | mlTopLevel m = 221 | pureTopLevel ( 222 | run 223 | mlRunner 224 | mlInitialiser 225 | m 226 | mlFinaliserVal 227 | mlFinaliserExc 228 | mlFinaliserSig 229 | ) -------------------------------------------------------------------------------- /src/Control/SignalRunner/SignalMLState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | {-| 12 | Module : Control.SignalRunner.SignalMLState 13 | Description : Runner for general ML-style state (supporting allocation, dereferencing, and assignment) 14 | Copyright : (c) Danel Ahman, 2019 15 | License : MIT 16 | Maintainer : danel.ahman@eesti.ee 17 | Stability : experimental 18 | 19 | This module implements a runner that provides general ML-style state 20 | that supports allocation of references, dereferencing references, 21 | and assignment to references. 22 | 23 | We allow a large class of Haskell values to be stored in our references, 24 | as long as they are instances of the `Typeable` type class. We use this 25 | restriction to be able to compare the types of references for equality, 26 | so as to be able to define decidable equality for references (`refEq`), 27 | which we in turn use when updating the values stored in the heap. 28 | 29 | If one attempts to access a non-existent reference (for dereferencing 30 | or assignment), then the corresponding co-operation is going to send a 31 | (kill) signal, which one can catch with the signal finaliser of `run`. 32 | -} 33 | module Control.SignalRunner.SignalMLState 34 | ( 35 | Ref, refEq, MLState(..), S(..), Heap, 36 | alloc, (!), deref, (=:=), assign, 37 | mlRunner, mlInitialiser, mlFinaliserVal, mlFinaliserExc, mlFinaliserSig, mlTopLevel, 38 | Typeable 39 | ) where 40 | 41 | import Control.SignalRunner 42 | 43 | import Data.Typeable 44 | 45 | -- | Type of (kill) signals. 46 | data S where 47 | -- | Signal sent when we observe that the given 48 | -- reference is not in the heap during dereferencing. 49 | RefNotInHeapInDerefSignal :: Ref a -> S 50 | -- | Signal sent when we observe that the given 51 | -- reference is not in the heap during assignment. 52 | RefNotInHeapInAssignSignal :: Ref a -> S 53 | 54 | instance Show S where 55 | show (RefNotInHeapInDerefSignal r) = "RefNotInHeapInDerefSignal -- " ++ show r 56 | show (RefNotInHeapInAssignSignal r) = "RefNotInHeapInAssignSignal -- " ++ show r 57 | 58 | -- | Type of natural numbers that we use for the address of references. 59 | data Nat where 60 | Z :: Nat 61 | S :: Nat -> Nat 62 | 63 | instance Eq Nat where 64 | Z == Z = True 65 | (S n) == (S m) = n == m 66 | _ == _ = False 67 | 68 | instance Show Nat where 69 | show Z = "Z" 70 | show (S n) = "S " ++ show n 71 | 72 | -- | Addresses of references (exposed because we need it to implement @MonotonicMLState@). 73 | type Addr = Nat 74 | 75 | -- | Type of references, restricted to only store values 76 | -- of types satisfying the `Typeable` type class. 77 | data Ref a where 78 | R :: (Typeable a) => Addr -> Ref a 79 | 80 | instance Eq (Ref a) where 81 | R addr == R addr' = addr == addr' 82 | 83 | instance Show (Ref a) where 84 | show r = "ref. with address " ++ show (addrOf r) 85 | 86 | -- | Exposing the address of a reference (private to this module). 87 | addrOf :: Ref a -> Addr 88 | addrOf (R r) = r 89 | 90 | -- | Decidable equality on references (of possibly different types). 91 | -- 92 | -- If the references are deemed to be equal, the equality test also 93 | -- returns a proof that their types are (propositionally) equal. 94 | refEq :: (Typeable a,Typeable b) => Ref a -> Ref b -> Maybe (a :~: b) 95 | refEq (r :: Ref a) (r' :: Ref b) = 96 | if (addrOf r == addrOf r') 97 | then eqT @a @b 98 | else Nothing 99 | 100 | -- | Memory is a partial map from references to `Typeable` values. 101 | type Memory = forall a . (Typeable a) => Ref a -> Maybe a 102 | 103 | -- | Type of heaps. These comprise a partial map 104 | -- from references to values, and the address of 105 | -- the next fresh reference to be allocated. 106 | data Heap = H { memory :: Memory, nextAddr :: Addr } 107 | 108 | -- | Reading the value of a reference in the heap. 109 | -- 110 | -- It returns an optional value, depending on whether 111 | -- the reference was present in the heap or not. 112 | heapSel :: (Typeable a) => Heap -> Ref a -> Maybe a 113 | heapSel h r = memory h r 114 | 115 | -- | Updating the value of a reference in the memory. 116 | memUpd :: (Typeable a) => Memory -> Ref a -> a -> Memory 117 | memUpd mem r x r' = 118 | case refEq r r' of 119 | Nothing -> mem r' 120 | Just Refl -> Just x 121 | 122 | -- | Updatring the value of a reference in the heap. 123 | heapUpd :: (Typeable a) => Heap -> Ref a -> a -> Heap 124 | heapUpd h r x = h { memory = memUpd (memory h) r x } 125 | 126 | -- | Allocating a fresh reference in the heap, 127 | -- with the given initial value. 128 | heapAlloc :: (Typeable a) => Heap -> a -> (Ref a,Heap) 129 | heapAlloc h init = 130 | let r = R (nextAddr h) in 131 | (r , H { memory = memUpd (memory h) r init , 132 | nextAddr = S (nextAddr h) }) 133 | 134 | -- | An effect for general ML-style state. 135 | data MLState :: * -> * where 136 | -- | Algebraic operation for allocating a fresh reference. 137 | Alloc :: (Typeable a) => a -> MLState (Ref a) 138 | -- | Algebraic operation for dereferencing a reference. 139 | Deref :: (Typeable a) => Ref a -> MLState a 140 | -- | Algebraic operation for assiging a value to a reference. 141 | Assign :: (Typeable a) => Ref a -> a -> MLState () 142 | 143 | -- | Generic effect for allocating a fresh reference. 144 | alloc :: (Typeable a,Member MLState sig) => a -> User sig e (Ref a) 145 | alloc init = performU (Alloc init) 146 | 147 | -- | Generic effect for dereferencing a reference. 148 | (!) :: (Typeable a,Member MLState sig) => Ref a -> User sig e a 149 | (!) r = performU (Deref r) 150 | 151 | -- | Generic effect for dereferencing a reference (synonym of @(!)@). 152 | deref r = (!) r -- used with qualified module names 153 | 154 | -- | Generic effect for assigning a value to a reference. 155 | (=:=) :: (Typeable a,Member MLState sig) => Ref a -> a -> User sig e () 156 | (=:=) r x = performU (Assign r x) 157 | 158 | -- | Generic effect for assigning a value to a reference (synonym of @(=:=)@). 159 | assign r x = r =:= x -- used with qualified module names 160 | 161 | -- | The co-operations of the runner `mlRunner`. 162 | mlCoOps :: MLState a -> Kernel sig Zero S Heap a 163 | mlCoOps (Alloc init) = 164 | do h <- getEnv; 165 | (r,h') <- return (heapAlloc h init); 166 | setEnv h'; 167 | return r 168 | mlCoOps (Deref r) = 169 | do h <- getEnv; 170 | maybe 171 | (kill (RefNotInHeapInDerefSignal r)) 172 | (\ x -> return x) 173 | (heapSel h r) 174 | mlCoOps (Assign r x) = 175 | do h <- getEnv; 176 | maybe 177 | (kill (RefNotInHeapInAssignSignal r)) 178 | (\ _ -> setEnv (heapUpd h r x)) 179 | (heapSel h r) 180 | 181 | -- | Runner that implements the `MLState` effect. 182 | -- 183 | -- Its runtime state is a heap (see `Heap`), and its 184 | -- co-operations call the corresponding allocation, 185 | -- dereferencing, and assignment operations on the heap. 186 | -- 187 | -- In the co-operation `Deref`, if the reference is 188 | -- not present in the heap, the (kill) signal 189 | -- `RefNotInHeapInDerefSignal` gets sent. 190 | -- 191 | -- In the co-operation `Assign`, if the reference is 192 | -- not present in the heap, the (kill) signal 193 | -- `RefNotInHeapInAssignSignal` gets sent. 194 | mlRunner :: Runner '[MLState] sig S Heap 195 | mlRunner = mkRunner mlCoOps 196 | 197 | -- | Initialiser for the runner `mlRunner` that 198 | -- initialises the heap with the empty partial map, 199 | -- and sets the next address to be allocated to zero. 200 | mlInitialiser :: User sig Zero Heap 201 | mlInitialiser = return (H { memory = \ _ -> Nothing , nextAddr = Z }) 202 | 203 | -- | Finaliser for return values for the runner `mlRunner`, 204 | -- which discards the final value of the heap, and simply 205 | -- passes on the return value. 206 | mlFinaliserVal :: a -> Heap -> User sig Zero a 207 | mlFinaliserVal x _ = return x 208 | 209 | -- | Finaliser for exceptions for the runner `mlRunner`, 210 | -- which is vacuously defined because there are 211 | -- no exceptions (the exceptions index is `Zero`). 212 | mlFinaliserExc :: Zero -> Heap -> User sig Zero a 213 | mlFinaliserExc e _ = impossible e 214 | 215 | -- | Finaliser for signals for the runner `mlRunner`, 216 | -- which raises a Haskell runtime error to signify 217 | -- that an uncaught signal reached the top level. 218 | mlFinaliserSig :: S -> User sig Zero a 219 | mlFinaliserSig s = error ("signal reached top level (" ++ show s ++ ")") 220 | 221 | -- | Top level for running user code that can use ML-style state. 222 | mlTopLevel :: User '[MLState] Zero a -> a 223 | mlTopLevel m = 224 | pureTopLevel ( 225 | run 226 | mlRunner 227 | mlInitialiser 228 | m 229 | mlFinaliserVal 230 | mlFinaliserExc 231 | mlFinaliserSig 232 | ) -------------------------------------------------------------------------------- /src/Control/Runner/FileIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | 6 | {-| 7 | Module : Control.Runner.FileIO 8 | Description : Runners implementing file IO 9 | Copyright : (c) Danel Ahman, 2019 10 | License : MIT 11 | Maintainer : danel.ahman@eesti.ee 12 | Stability : experimental 13 | 14 | This module provides a variety of runners implementing file IO. 15 | These runners mostly differ in what they store in their runtime 16 | state, e.g., storing a file handle vs storing the accumulated 17 | writes to a file. 18 | -} 19 | module Control.Runner.FileIO ( 20 | FileIO(..), fOpenOS, fCloseOS, fReadOS, fWriteOS, 21 | File(..), fRead, fWrite, FIOState, FHState, FCState, 22 | fioRunner, fhRunner, fcRunner, 23 | ioFioInitialiser, fioFhInitialiser, fhFcInitialiser, 24 | ioFioFinaliser, fioFhFinaliser, fhFcFinaliser, 25 | withFile 26 | ) where 27 | 28 | import Control.Runner 29 | import System.IO hiding (withFile) 30 | 31 | import qualified Data.ByteString.Char8 as B 32 | 33 | -- | An effect for performing file IO. 34 | data FileIO a where 35 | -- | Algebraic operation for opening a file in a given mode. 36 | OpenFile :: FilePath -> IOMode -> FileIO Handle 37 | -- | Algebraic operation of closing a given file. 38 | CloseFile :: Handle -> FileIO () 39 | -- | Algebraic operation for reading from a given file. 40 | ReadFile :: Handle -> FileIO String 41 | -- | Algebraic operation for writing to a given file. 42 | WriteFile :: Handle -> String -> FileIO () 43 | 44 | -- | Generic effect for opening a file in a given mode. 45 | fOpenOS :: (Member FileIO sig) => FilePath -> IOMode -> User sig Handle 46 | fOpenOS fn mode = performU (OpenFile fn mode) 47 | 48 | -- | Generic effect for closing a given file. 49 | fCloseOS :: (Member FileIO sig) => Handle -> User sig () 50 | fCloseOS fh = performU (CloseFile fh) 51 | 52 | -- | Generic effect for reading from a given file. 53 | fReadOS :: (Member FileIO sig) => Handle -> User sig String 54 | fReadOS fh = performU (ReadFile fh) 55 | 56 | -- | Generic effect for writing to a given file. 57 | fWriteOS :: (Member FileIO sig) => Handle -> String -> User sig () 58 | fWriteOS fh s = performU (WriteFile fh s) 59 | 60 | -- | An effect for performing reads and writes (on a file whose file 61 | -- handle is hidden by the user code through the use of runners). 62 | -- 63 | -- In this module, we additionally suppose that Read denotes 64 | -- reading the initial value of a file when using a runner. 65 | data File a where 66 | -- | Algebraic operation for reading (from a file that is hidden from user code). 67 | Read :: File String 68 | -- | Algebraic operation for writing (to a file that is hidden from user code). 69 | Write :: String -> File () 70 | 71 | -- | Generic effect for reading (from a file that is hidden from user code). 72 | fRead :: (Member File sig) => User sig String 73 | fRead = performU Read 74 | 75 | -- | Generic effect for writing (to a file that is hidden from user code). 76 | fWrite :: (Member File sig) => String -> User sig () 77 | fWrite s = performU (Write s) 78 | 79 | -- 80 | -- FIO: File-fragment of the top-level IO-container. 81 | -- 82 | -- The state of FIO is trivial because we cannot 83 | -- internally access nor represent the real world. 84 | -- 85 | 86 | -- | Type of the runtime state of the runner `fioRunner`. 87 | -- 88 | -- The state is trivial because this runner directly delegates 89 | -- the file IO operations to Haskell's `IO` monad operations. 90 | type FIOState = () 91 | 92 | -- | The co-operations of the runner `fioRunner`. 93 | fioCoOps :: Member IO sig => FileIO a -> Kernel sig FIOState a 94 | fioCoOps (OpenFile fn mode) = 95 | performK (openFile fn mode) 96 | fioCoOps (CloseFile fh) = 97 | performK (hClose fh) 98 | fioCoOps (ReadFile fh) = 99 | -- using ByteString IO to ensure strictness of IO 100 | do s <- performK (B.hGetContents fh); 101 | return (B.unpack s) 102 | fioCoOps (WriteFile fh s) = 103 | performK (B.hPutStr fh (B.pack s)) 104 | 105 | -- | Runner that implements the `FileIO` effect, by delegating 106 | -- the file IO operations to Haskell's `IO` monad operations. 107 | -- 108 | -- Intuitively, this runner focusses on a fraction of the larger, 109 | -- external signature (namely, that of the `IO` monad). 110 | fioRunner :: Member IO sig => Runner '[FileIO] sig FIOState 111 | fioRunner = mkRunner fioCoOps 112 | 113 | -- | Type of the runtime state of the runner `fhRunner`. 114 | -- 115 | -- The state comprises the initial contents of the file 116 | -- and then a file handle supporting (over)writing to the file. 117 | type FHState = (String , Handle) 118 | 119 | -- | Type co-operations of the runner `fhRunner`. 120 | fhCoOps :: Member FileIO sig => File a -> Kernel sig FHState a 121 | fhCoOps Read = 122 | do (s,fh) <- getEnv; 123 | return s 124 | fhCoOps (Write s') = 125 | do (s,fh) <- getEnv; 126 | performK (WriteFile fh s') 127 | 128 | -- | Runner that implements the `File` effect, by 129 | -- returning the internally stored (initial) contents 130 | -- on `Read` operations, and delegates `Write` operations 131 | -- to some enveloping runner for the `FileIO` effect, 132 | -- using the file handle stored in its runtime state. 133 | fhRunner :: Member FileIO sig => Runner '[File] sig FHState 134 | fhRunner = mkRunner fhCoOps 135 | 136 | -- 137 | -- FC: File-runner that operates on the contents of a single file. 138 | -- 139 | -- The state of FC is the initial contents of the file and 140 | -- then the contents to be written to the file in finally. 141 | -- 142 | 143 | -- | Type of the runtime state of the runner `fcRunner`. 144 | -- 145 | -- The state comprises the initial contents of the file, 146 | -- and then an accumulator for strings to be written to 147 | -- the file in the finalisation (when running with `fcRunner`). 148 | type FCState = (String , String) 149 | 150 | -- | The co-operations of the runner `fcRunner`. 151 | fcCoOps :: File a -> Kernel sig FCState a 152 | fcCoOps Read = 153 | do (s,s') <- getEnv; 154 | return s 155 | fcCoOps (Write s'') = 156 | do (s,s') <- getEnv; 157 | setEnv (s,s' ++ s'') 158 | 159 | -- | Runner that implements the `File` effect, 160 | -- by returning the internally stored (initial) 161 | -- contents on `Read` operations, and accumulates 162 | -- any `Write` operations in its runtime state. 163 | fcRunner :: Runner '[File] sig FCState 164 | fcRunner = mkRunner fcCoOps 165 | 166 | -- 167 | -- IO <-> FIO. 168 | -- 169 | 170 | -- | Initialiser for the runner `fioRunner` 171 | -- in the `IO` monad external context. 172 | ioFioInitialiser :: Member IO sig => User sig FIOState 173 | ioFioInitialiser = return () 174 | 175 | -- | Finaliser for the runner `fioRunner` 176 | -- in the `IO` monad external context. 177 | -- 178 | -- As the runtime state of the `fioRunner` is trivial, 179 | -- the finaliser simply passes on the return value. 180 | ioFioFinaliser :: Member IO sig => a -> FIOState -> User sig a 181 | ioFioFinaliser x _ = return x 182 | 183 | -- | Initialiser for the runner `fhRunner`, 184 | -- in the `FileIO` effect external context. 185 | -- 186 | -- It first reads the initial contents of the given 187 | -- file and then it opens the file for writing, 188 | -- returning the initial contents and the file handle. 189 | fioFhInitialiser :: Member FileIO sig => FilePath -> User sig FHState 190 | fioFhInitialiser fn = 191 | do fh <- fOpenOS fn ReadWriteMode; 192 | s <- fReadOS fh; 193 | fCloseOS fh; 194 | fh <- fOpenOS fn WriteMode; 195 | return (s,fh) 196 | 197 | -- | Finaliser for the runner `fhRunner`, 198 | -- in the `FileIO` effect external context. 199 | -- 200 | -- It closes the file given file handle, and passes 201 | -- on the return value. 202 | fioFhFinaliser :: Member FileIO sig => a -> FHState -> User sig a 203 | fioFhFinaliser x (_,fh) = 204 | do fCloseOS fh; 205 | return x 206 | 207 | -- | Initialiser for the runner `fcRunner`, 208 | -- in the `File` effect external context. 209 | -- 210 | -- It first reads the initial contents of the given 211 | -- file, and then returns the contents and the empty 212 | -- accumulator for `Write` operations. 213 | fhFcInitialiser :: Member File sig => User sig FCState 214 | fhFcInitialiser = 215 | do s <- fRead; 216 | return (s,"") 217 | 218 | -- | Finaliser for the runner `fcRunner`, 219 | -- in the `File` effect external context. 220 | -- 221 | -- It writes the accumulated writes with `Write` 222 | -- and passes on the return value. 223 | fhFcFinaliser :: Member File sig => a -> FCState -> User sig a 224 | fhFcFinaliser x (_,s) = 225 | do fWrite s; 226 | return x 227 | 228 | -- 229 | -- Derived with-file construct using the 230 | -- composite IO <-> FIO <-> FH <-> FC. 231 | -- 232 | 233 | -- | Derived with-file construct that runs user code with 234 | -- the `File` effect in the external context of the `IO` 235 | -- monad. 236 | -- 237 | -- This construct nests all the different runners implemented 238 | -- in this module, as follows 239 | -- 240 | -- > IO monad <-> fioRunner <-> fhRunner <-> fcRunner <-> user code 241 | -- 242 | -- with the arrows informally denoting the various initialisers 243 | -- and finalisers for the different runners. 244 | withFile :: FilePath -> User '[File] a -> User '[IO] a 245 | withFile fn m = 246 | run 247 | fioRunner 248 | ioFioInitialiser 249 | ( 250 | run 251 | fhRunner 252 | (fioFhInitialiser fn) 253 | ( 254 | run 255 | fcRunner 256 | fhFcInitialiser 257 | m 258 | fhFcFinaliser 259 | ) 260 | fioFhFinaliser 261 | ) 262 | ioFioFinaliser -------------------------------------------------------------------------------- /src/Control/Runner/Ambients.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | {-| 10 | Module : Control.Runner.Ambients 11 | Description : Runner for Koka-style ambient values and ambient functions 12 | Copyright : (c) Danel Ahman, 2019 13 | License : MIT 14 | Maintainer : danel.ahman@eesti.ee 15 | Stability : experimental 16 | 17 | This module provides a runner that implements ambient values and ambient 18 | functions as present in the [Koka](https://github.com/koka-lang/koka) 19 | language. Ambient values are essentially just mutable variables. Ambient 20 | functions are functions that are dynamically bound but evaluated in the 21 | lexical scope of their binding. 22 | 23 | As a simple example, in the following code snippet (in Koka-style syntax) 24 | 25 | > ambient fun f : int -> int 26 | > ambient val x : int 27 | > 28 | > with val x = 4 29 | > with fun f = fun y -> x + y 30 | > with val x = 2 31 | > f 1 32 | 33 | the final application results in @5@ instead of @3@ that one might 34 | naively expect. This is so because @f@ is an ambient function, 35 | and thus the application happens in the context in which it was 36 | last bound, where the ambient value @x@ still had the value @4@. 37 | 38 | We implement ambient values and ambient functions using a runner by 39 | treating the binding and application operations as co-operations. 40 | Internally, the runner carries a heap of ambient values and ambient 41 | functions, where each address tracks the values of these at different 42 | points in time (i.e., at the points when new values and functions get 43 | bound, or old ones rebound). The application co-operation then temporarily 44 | rewinds the heap to the state where the function was last bound, 45 | evaluates the application in that state, and then restores the state 46 | of the heap as it was before the ambient function application. 47 | 48 | For more details about ambient values and ambient functions, how they 49 | can be used in practice and operationally implemented, we suggest 50 | this [technical report](https://www.microsoft.com/en-us/research/uploads/prod/2019/03/implicits-tr-v2.pdf). 51 | -} 52 | module Control.Runner.Ambients 53 | ( 54 | AmbFun, AmbVal, Amb(..), AmbEff, 55 | getVal, applyFun, 56 | rebindVal, rebindFun, 57 | ambRunner, AmbHeap, 58 | withAmbVal, withAmbFun, 59 | ambTopLevel 60 | ) where 61 | 62 | import Control.Runner 63 | 64 | import Data.Typeable 65 | 66 | -- | Type of natural numbers (used for memory addresses). 67 | data Nat where 68 | Z :: Nat 69 | S :: Nat -> Nat 70 | 71 | instance Eq Nat where 72 | Z == Z = True 73 | (S n) == (S m) = n == m 74 | _ == _ = False 75 | 76 | -- | Addresses of ambient values and functions. 77 | type Addr = Nat 78 | 79 | -- | Type of ambient functions, from type @a@ to type @b@. 80 | data AmbFun a b where 81 | F :: (Typeable a,Typeable b) => Addr -> AmbFun a b 82 | 83 | -- | The memory address of an ambient function. 84 | addrOf :: AmbFun a b -> Addr 85 | addrOf (F r) = r 86 | 87 | -- | Type of ambient values of type @a@. 88 | data AmbVal a where 89 | AV :: (Typeable a) => AmbFun () a -> AmbVal a 90 | 91 | -- | Depth of the state of the heap, in terms of the number of 92 | -- bindings and rebindings of ambient values and ambient functions 93 | -- that have happened in the past. 94 | type Depth = Nat 95 | 96 | -- | Memory is a partial depth-dependent mapping from ambient values 97 | -- and ambient functions to correspondingly typed `AmbEff` functions. 98 | type AmbMemory = 99 | forall a b sig . 100 | (Typeable a,Typeable b) => 101 | AmbFun a b -> Depth -> Maybe (a -> AmbEff b) 102 | 103 | -- | Heap in which we store the definitions of ambient values and ambient functions. 104 | data AmbHeap = 105 | H { memory :: AmbMemory, -- memory that stores definitions of ambient values and ambient functions 106 | nextAddr :: Addr, -- address of the next ambient value or ambient function to be allocated 107 | depth :: Depth } -- the current binding depth of the heap 108 | 109 | -- | Selecting an ambient function definition from the heap. Also returns 110 | -- the depth at which the ambient function was bound to its definition. 111 | ambHeapSel :: (Typeable a,Typeable b) 112 | => AmbHeap 113 | -> AmbFun a b 114 | -> Depth 115 | -> (a -> AmbEff b,Depth) 116 | ambHeapSel h f Z = 117 | case memory h f Z of 118 | Nothing -> error "Ambient function not bound" 119 | Just f -> (f,Z) 120 | ambHeapSel h f (S d) = 121 | case memory h f (S d) of 122 | Nothing -> ambHeapSel h f d 123 | Just f -> (f,S d) 124 | 125 | -- | Updating the memory with a new ambient value or ambient function definition. 126 | ambMemUpd :: (Typeable a,Typeable b) 127 | => AmbMemory 128 | -> AmbFun a b 129 | -> (a -> AmbEff b) 130 | -> Depth 131 | -> AmbMemory 132 | ambMemUpd mem f g d f' d' = 133 | case cast g of 134 | Nothing -> mem f' d' 135 | Just g -> ( 136 | if (addrOf f == addrOf f' && d == d') 137 | then Just g 138 | else mem f' d') 139 | 140 | -- | Updating the heap with a new ambient value or ambient function definition. 141 | ambHeapUpd :: (Typeable a,Typeable b) 142 | => AmbHeap 143 | -> AmbFun a b 144 | -> (a -> AmbEff b) 145 | -> AmbHeap 146 | ambHeapUpd h f g = 147 | h { memory = ambMemUpd (memory h) f g (depth h) , 148 | depth = S (depth h) } 149 | 150 | -- | Allocating a new ambient value or ambient function in the heap. 151 | ambHeapAlloc :: (Typeable a,Typeable b) 152 | => AmbHeap 153 | -> (a -> AmbEff b) 154 | -> (AmbFun a b,AmbHeap) 155 | ambHeapAlloc h f = 156 | let addr = nextAddr h in 157 | let g = F addr in 158 | let d = depth h in 159 | (g , H { memory = ambMemUpd (memory h) g f d , 160 | nextAddr = S addr , 161 | depth = S d }) 162 | 163 | -- | The effect for programming with ambient values and ambient functions. 164 | data Amb :: * -> * where 165 | -- | Algebraic operation for (the initial) binding of a value to an ambient value. 166 | BindVal :: (Typeable a) => a -> Amb (AmbVal a) 167 | -- | Algebraic operation for (the initial) binding of a function to an ambient function. 168 | BindFun :: (Typeable a,Typeable b) => (a -> AmbEff b) -> Amb (AmbFun a b) 169 | -- | Algebraic operation for getting the value of an ambient value. 170 | GetVal :: (Typeable a) => AmbVal a -> Amb a 171 | -- | Algebraic operation for applying an ambient function to a value. 172 | ApplyFun :: (Typeable a,Typeable b) => AmbFun a b -> a -> Amb b 173 | -- | Algebraic operation for rebinding an ambient value to a new value. 174 | RebindVal :: (Typeable a) => AmbVal a -> a -> Amb () 175 | -- | Algebraic operation for rebinding an ambient function to a new function. 176 | RebindFun :: (Typeable a,Typeable b) => AmbFun a b -> (a -> AmbEff b) -> Amb () 177 | 178 | -- | Syntactic sugar for the type of user computations that can perform the `Amb` effect. 179 | type AmbEff a = User '[Amb] a 180 | 181 | -- | Generic effect for getting the value of an ambient value. 182 | getVal :: (Typeable a) => AmbVal a -> AmbEff a 183 | getVal (AV x) = performU (ApplyFun x ()) 184 | 185 | -- | Generic effect for applying an ambient function to a value. 186 | applyFun :: (Typeable a,Typeable b) => AmbFun a b -> a -> AmbEff b 187 | applyFun f x = performU (ApplyFun f x) 188 | 189 | -- | Generic effect for rebinding an ambient value to a new value. 190 | rebindVal :: (Typeable a) => AmbVal a -> a -> AmbEff () 191 | rebindVal x y = performU (RebindVal x y) 192 | 193 | -- | Generic effect for rebinding an ambient function to a new function. 194 | rebindFun :: (Typeable a,Typeable b) 195 | => AmbFun a b 196 | -> (a -> AmbEff b) 197 | -> AmbEff () 198 | rebindFun f g = performU (RebindFun f g) 199 | 200 | -- | Generic effect for (the initial) binding of an ambient value. 201 | bindVal :: Typeable a 202 | => a 203 | -> AmbEff (AmbVal a) 204 | bindVal x = performU (BindVal x) 205 | 206 | -- | Generic effect for (the initial) binding of an ambient function. 207 | bindFun :: (Typeable a,Typeable b) 208 | => (a -> AmbEff b) 209 | -> AmbEff (AmbFun a b) 210 | bindFun f = performU (BindFun f) 211 | 212 | -- | Co-operations of the runner implementing ambient values and ambient functions. 213 | ambCoOps :: Amb a -> Kernel sig AmbHeap a 214 | ambCoOps (BindVal x) = 215 | do h <- getEnv; 216 | (x,h') <- return (ambHeapAlloc h (\ _ -> return x)); 217 | setEnv h'; 218 | return (AV x) 219 | ambCoOps (BindFun f) = 220 | do h <- getEnv; 221 | (f,h') <- return (ambHeapAlloc h f); 222 | setEnv h'; 223 | return f 224 | ambCoOps (GetVal (AV x)) = 225 | do h <- getEnv; 226 | (x,d) <- return (ambHeapSel h x (depth h)); 227 | user 228 | (run 229 | ambRunner 230 | (return h) 231 | (x ()) 232 | ambFinaliser) 233 | return 234 | ambCoOps (ApplyFun f x) = 235 | do h <- getEnv; 236 | (f,d) <- return (ambHeapSel h f (depth h)); 237 | user 238 | (run 239 | ambRunner 240 | (return (h {depth = d})) -- observe that we rewind the heap to the poin where @f@ was last bound 241 | (f x) 242 | ambFinaliser) 243 | return 244 | ambCoOps (RebindVal (AV x) y) = 245 | do h <- getEnv; 246 | setEnv (ambHeapUpd h x (\ _ -> return y)) 247 | ambCoOps (RebindFun f g) = 248 | do h <- getEnv; 249 | setEnv (ambHeapUpd h f g) 250 | 251 | -- | Runner implementing ambient values and ambient functions. 252 | ambRunner :: Runner '[Amb] sig AmbHeap 253 | ambRunner = mkRunner ambCoOps 254 | 255 | -- | Scoped initial binding of an ambient value. 256 | withAmbVal :: (Typeable a) 257 | => a 258 | -> (AmbVal a -> AmbEff b) -> AmbEff b 259 | withAmbVal x k = 260 | do x <- bindVal x; 261 | k x 262 | 263 | -- | Scoped initial binding of an ambient function. 264 | withAmbFun :: (Typeable a,Typeable b) 265 | => (a -> AmbEff b) 266 | -> (AmbFun a b -> AmbEff c) -> AmbEff c 267 | withAmbFun f k = 268 | do f <- bindFun f; 269 | k f 270 | 271 | -- | Initialiser for running user code with `ambRunner`. 272 | ambInitialiser :: User sig AmbHeap 273 | ambInitialiser = 274 | return (H { memory = \ _ _ -> Nothing , 275 | nextAddr = Z , 276 | depth = Z }) 277 | 278 | -- | Finaliser for running user code with `ambRunner`. 279 | ambFinaliser :: a -> AmbHeap -> User sig a 280 | ambFinaliser x _ = return x 281 | 282 | -- | Top level for running user code with the `AmbEff` effect. 283 | -- 284 | -- Internally this top level functionality runs the user code 285 | -- using the runner `ambRunner`. 286 | ambTopLevel :: AmbEff a -> a 287 | ambTopLevel m = 288 | pureTopLevel ( 289 | run 290 | ambRunner 291 | ambInitialiser 292 | m 293 | ambFinaliser 294 | ) -------------------------------------------------------------------------------- /src/Control/Runner/OldFileIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | 5 | {-| 6 | Module : Control.Runner.OldFileIO 7 | Description : Runners implementing file IO 8 | Copyright : (c) Danel Ahman, 2019 9 | License : MIT 10 | Maintainer : danel.ahman@eesti.ee 11 | Stability : experimental 12 | 13 | This module provides a variety of runners implementing file IO. 14 | These runners mostly differ in what they store in their runtime 15 | state, e.g., storing a file handle vs storing the accumulated 16 | writes to a file. 17 | 18 | It differs from what can be found in the (newer) Control.Runner.FileIO 19 | module in that the file handle `fhRunner` does not store the file handle 20 | in its runtime state but instead the file name. This is to accommodate 21 | the non-persistence of Haskell file handles across calls to `hGetContents`. 22 | -} 23 | module Control.Runner.OldFileIO 24 | ( 25 | FileIO(..), File(..), Cleaner(..), 26 | fioRunner, fhRunner, fcRunner, fcOwRunner, 27 | ioFioInitialiser, ioFioFinaliser, 28 | fioFhInitialiser, fioFhFinaliser, 29 | fhFcInitialiser, fhFcFinaliser, 30 | fhFcOwInitialiser, fhFcOwFinaliser, 31 | fioFcInitialiser, fioFcFinaliser, 32 | fioFcOwInitialiser, fioFcOwFinaliser 33 | ) where 34 | 35 | import Control.Runner 36 | import System.IO 37 | 38 | import qualified Data.ByteString.Char8 as B 39 | 40 | -- | An effect for performing file IO. 41 | data FileIO a where 42 | -- | Algebraic operation for opening a file in a given mode. 43 | OpenFile :: FilePath -> IOMode -> FileIO Handle 44 | -- | Algebraic operation of closing a given file. 45 | CloseFile :: Handle -> FileIO () 46 | -- | Algebraic operation for reading from a given file. 47 | ReadFile :: Handle -> FileIO String 48 | -- | Algebraic operation for writing to a given file. 49 | WriteFile :: Handle -> String -> FileIO () 50 | 51 | -- | An effect for performing reads and writes (on a file whose file 52 | -- handle is hidden by the user code through the use of runners). 53 | data File a where 54 | -- | Algebraic operation for reading (from a file that is hidden from user code). 55 | Read :: File String 56 | -- | Algebraic operation for writing (to a file that is hidden from user code). 57 | Write :: String -> File () 58 | 59 | -- | An effect to empty a given file. 60 | data Cleaner a where 61 | -- | Algebraic operation that empties the contents of a given file. 62 | Clean :: Cleaner () 63 | 64 | -- | The co-operations of the `fioRunner`. 65 | fioCoOps :: FileIO a -> Kernel '[IO] () a 66 | fioCoOps (OpenFile fn mode) = 67 | performK (openFile fn mode) 68 | fioCoOps (CloseFile fh) = 69 | performK (hClose fh) 70 | fioCoOps (ReadFile fh) = 71 | do s <- performK (B.hGetContents fh); 72 | return (B.unpack s) 73 | fioCoOps (WriteFile fh s) = 74 | performK (B.hPutStr fh (B.pack s)) 75 | 76 | -- | Runner that implements the `FileIO` effect, by delegating 77 | -- the file IO operations to Haskell's `IO` monad operations. 78 | -- 79 | -- Intuitively, this runner focusses on a fraction of the larger, 80 | -- external signature (namely, that of the `IO` monad). 81 | -- 82 | -- Its runtime state is trivial because this runner directly delegates 83 | -- the file IO operations to Haskell's `IO` monad operations. 84 | fioRunner :: Runner '[FileIO] '[IO] () 85 | fioRunner = mkRunner fioCoOps 86 | 87 | -- | The co-operations of the `fhRunner`. 88 | fhCoOps :: File a -> Kernel '[FileIO] FilePath a 89 | fhCoOps Read = 90 | do fn <- getEnv; 91 | fh <- performK (OpenFile fn ReadWriteMode); 92 | s <- performK (ReadFile fh); 93 | performK (CloseFile fh); 94 | return s 95 | fhCoOps (Write s) = 96 | do fn <- getEnv; 97 | fh <- performK (OpenFile fn AppendMode); 98 | performK (WriteFile fh s); 99 | performK (CloseFile fh) 100 | 101 | -- | Runner that implements the `File` effect, by 102 | -- internally storing a given file name (of type `FilePath`), 103 | -- and implementing the co-operations for the `File` 104 | -- effect using the operations of the `FileIO` effect. 105 | -- 106 | -- Both co-operations follow a similar pattern: open the 107 | -- file, do the `File` effect, and then close the file, 108 | -- while keeping the stored file name unchanged. 109 | fhRunner :: Runner '[File] '[FileIO] FilePath 110 | fhRunner = mkRunner fhCoOps 111 | 112 | -- | The co-operations of the `fcRunner`. 113 | fcCoOps :: File a -> Kernel sig String a 114 | fcCoOps Read = 115 | getEnv 116 | fcCoOps (Write s') = 117 | do s <- getEnv; 118 | setEnv (s ++ s') 119 | 120 | -- | Runner that implements the `File` effect, 121 | -- by returning the internally stored contents 122 | -- on `Read` operations, and accumulates any 123 | -- `Write` operations in its runtime state. 124 | fcRunner :: Runner '[File] sig String 125 | fcRunner = mkRunner fcCoOps 126 | 127 | -- 128 | -- FC+OW: File-runner that operates on the contents of a single file, but 129 | -- which overwrites the existing contents of a file (in contrast with FC), 130 | -- and it additionally supports on-demand emptying of the given file. 131 | -- 132 | 133 | -- | The co-operations of the `fcOwRunner` runner. 134 | fcOwCoOpsAux :: File a -> Either String String -> Kernel sig (Either String String) a 135 | fcOwCoOpsAux Read (Left s) = 136 | return s 137 | fcOwCoOpsAux Read (Right s) = 138 | return s 139 | fcOwCoOpsAux (Write s') (Left _) = 140 | setEnv (Right s') 141 | fcOwCoOpsAux (Write s') (Right s) = 142 | setEnv (Right (s ++ s')) 143 | 144 | -- | The co-operations of the `fcOwRunner` runner. 145 | fcOwCoOps :: File a -> Kernel sig (Either String String) a 146 | fcOwCoOps f = 147 | do s <- getEnv; 148 | fcOwCoOpsAux f s 149 | 150 | -- | The co-operations of the `fcOwRunner` runner. 151 | fcClCoOps :: Cleaner a -> Kernel sig (Either String String) a 152 | fcClCoOps Clean = setEnv (Right "") 153 | 154 | -- | Runner that implements the union of the `File` and `Cleaner` 155 | -- effects, by operating on the contents of a single file, 156 | -- overwriting the existing contents of a file (in contrast to 157 | -- `fcRunner`), and additionally allowing for on-demand emptying 158 | -- of the file (using the `Clean` co-operation). 159 | -- 160 | -- The runtime state of this runner is either the initial contents 161 | -- of the file (modelled as @Left s@), or the contents overwriting 162 | -- the initial one (modelled as @Right s@). 163 | -- 164 | -- The `Write` co-operation overwrites the initial contents, and 165 | -- then starts accumulating the subsequent writes. The `Read` 166 | -- co-operation returns whatever string is currently stored in 167 | -- the runtime state (be it initial or new). The `Clean` co-operation 168 | -- simply sets the runtime state to @Right ""@, i.e., empties the file. 169 | fcOwRunner :: Runner '[File,Cleaner] sig (Either String String) 170 | fcOwRunner = unionRunners (mkRunner fcOwCoOps) (mkRunner fcClCoOps) 171 | 172 | -- | Initialiser for the runner `fioRunner` 173 | -- in the `IO` monad external context. 174 | ioFioInitialiser :: User '[IO] () 175 | ioFioInitialiser = return () 176 | 177 | -- | Finaliser for the runner `fioRunner` 178 | -- in the `IO` monad external context. 179 | -- 180 | -- As the runtime state of the `fioRunner` is trivial, 181 | -- the finaliser simply passes on the return value. 182 | ioFioFinaliser :: a -> () -> User '[IO] a 183 | ioFioFinaliser x _ = return x 184 | 185 | -- | Initialiser for the runner `fhRunner`, 186 | -- in the `FileIO` effect external context. 187 | -- 188 | -- It simply returns the given file path. 189 | fioFhInitialiser :: FilePath -> User '[FileIO] FilePath 190 | fioFhInitialiser fn = return fn 191 | 192 | -- | Finaliser for the runner `fhRunner`, 193 | -- in the `FileIO` effect external context. 194 | fioFhFinaliser :: a -> FilePath -> User '[FileIO] a 195 | fioFhFinaliser x _ = return x 196 | 197 | -- | Initialiser for the runner `fcRunner`, 198 | -- in the `File` effect external context. 199 | -- 200 | -- It reads (with `Read`) and returns the initial 201 | -- contents of the given file. 202 | fhFcInitialiser :: User '[File] String 203 | fhFcInitialiser = 204 | performU Read 205 | 206 | -- | Finaliser for the runner `fcRunner`, 207 | -- in the `File` effect external context. 208 | -- 209 | -- It writes the accumulated writes with `Write` 210 | -- and passes on the return value. 211 | fhFcFinaliser :: a -> String -> User '[File] a 212 | fhFcFinaliser x s = 213 | do performU (Write s); 214 | return x 215 | 216 | -- | Initialiser for the runner `fcOwRunner`, 217 | -- in the `File` effect external context. 218 | -- 219 | -- It reads and returns the initial contents of the given file. 220 | fhFcOwInitialiser :: User '[File] (Either String String) 221 | fhFcOwInitialiser = 222 | do s <- performU Read; 223 | return (Left s) 224 | 225 | -- | Finaliser for the runner `fcOwRunner`, 226 | -- in the `File` effect external context. 227 | -- 228 | -- If the final value of the runtime state is still 229 | -- the initial contents of the file (it is @Left s@), 230 | -- then it simply passes on the return value. If the 231 | -- original contents of the file has been overwritten, 232 | -- then the finaliser writes it with `Write`, and then 233 | -- passes on the return value. 234 | fhFcOwFinaliser :: a -> (Either String String) -> User '[File] a 235 | fhFcOwFinaliser x (Left s) = 236 | return x 237 | fhFcOwFinaliser x (Right s) = 238 | do performU (Write s); 239 | return x 240 | 241 | -- | Initialiser for the runner `fcRunner`, 242 | -- in the `FileIO` effect external context. 243 | -- 244 | -- It opens the given file in reading mode, reads 245 | -- the contents, closes the file, and returns the contents. 246 | fioFcInitialiser :: FilePath -> User '[FileIO] String 247 | fioFcInitialiser fn = 248 | do fh <- performU (OpenFile fn ReadWriteMode); 249 | s <- performU (ReadFile fh); 250 | performU (CloseFile fh); 251 | return s 252 | 253 | -- | Finaliser for the runner `fcRunner`, 254 | -- in the `FileIO` effect external context. 255 | -- 256 | -- It opens the given file in (over-)writing mode, writes 257 | -- the final value of the runtime state to the file, 258 | -- closes the file, and passes on the return value. 259 | fioFcFinaliser :: FilePath -> a -> String -> User '[FileIO] a 260 | fioFcFinaliser fn x s = 261 | do fh <- performU (OpenFile fn WriteMode); 262 | performU (WriteFile fh s); 263 | performU (CloseFile fh); 264 | return x 265 | 266 | -- | Initialiser for the runner `fcOwRunner`, 267 | -- in the `FileIO` effect external context. 268 | -- 269 | -- It opens the given file in reading mode, reads 270 | -- the contents, closes the file, and returns the 271 | -- contents (as a left inject in @Either String String@). 272 | fioFcOwInitialiser :: FilePath -> User '[FileIO] (Either String String) 273 | fioFcOwInitialiser fn = 274 | do fh <- performU (OpenFile fn ReadWriteMode); 275 | s <- performU (ReadFile fh); 276 | performU (CloseFile fh); 277 | return (Left s) 278 | 279 | -- | Finaliser for the runner `fcOwRunner`, 280 | -- in the `FileIO` effect external context. 281 | -- 282 | -- If the final value of the runtime state is still 283 | -- equal to the initial contents of the file, it 284 | -- simply passes on the return value. If the contents 285 | -- of the file has changed, it opens the file in 286 | -- (over-)writing mode, writes the final value of the 287 | -- runtime state to the file, closes the file, and 288 | -- passes on the return value. 289 | fioFcOwFinaliser :: FilePath -> a -> (Either String String) -> User '[FileIO] a 290 | fioFcOwFinaliser fn x (Left s) = return x 291 | fioFcOwFinaliser fn x (Right s) = 292 | do fh <- performU (OpenFile fn WriteMode); 293 | performU (WriteFile fh s); 294 | performU (CloseFile fh); 295 | return x -------------------------------------------------------------------------------- /src/Control/Runner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | {-| 10 | Module : Control.Runner 11 | Description : Effectful runners (in a restricted form, without support for exceptions and signals) 12 | Copyright : (c) Danel Ahman, 2019 13 | License : MIT 14 | Maintainer : danel.ahman@eesti.ee 15 | Stability : experimental 16 | 17 | This module provides an implementation of effectful runners of algebraic effects (in a restricted form, 18 | without support for exceptions and signals) to run user code (modelled using the `User` monad) 19 | with co-operations implemented as kernel code (modelled using the `Kernel` monad). 20 | 21 | This module is based on ongoing research of [Danel Ahman](https://danel.ahman.ee) and [Andrej Bauer](http://www.andrej.com). 22 | Interested readers should check out a recent draft [Runners in action](https://arxiv.org/abs/1910.11629) 23 | that develops the theoretical underpinnings, presents a core calculus for programming with runners 24 | that the current module implements, and discusses various example uses of runners. 25 | For general background reading on algebraic effects and handlers, we recommend the lecture 26 | notes [What is algebraic about algebraic effects and handlers?](https://arxiv.org/abs/1807.05923). Section 4 27 | of these notes discusses ordinary runners of algebraic effects (also known in the literature as comodels of algebraic effects). 28 | 29 | The `User` and `Kernel` monad use internally the [freer-simple](http://hackage.haskell.org/package/freer-simple) 30 | implementation of a free monad on a signature of effects, namely, the `Eff` monad. 31 | -} 32 | module Control.Runner ( 33 | User, Kernel, embedU, embedK, focus, performU, performK, 34 | getEnv, setEnv, kernel, user, Runner, mkRunner, emptyRunner, 35 | SigUnion, unionRunners, embedRunner, extendRunner, pairRunners, 36 | fwdRunner, run, pureTopLevel, topLevel, ioTopLevel, Member 37 | ) where 38 | 39 | import Control.Monad.Freer.Internal hiding (run) 40 | 41 | -- | The monad that we use to model user computations that can perform algebraic 42 | -- operations given by effects in the signature @sig@ (using `performU`) and return 43 | -- values of type @a@. The algebraic operation calls will be implemented by some 44 | -- enveloping runner of type `Runner`. 45 | -- 46 | -- The signature @sig@ has type @[* -> *]@, in other words, it is a list of effects. 47 | -- Exactly as in the [freer-simple](http://hackage.haskell.org/package/freer-simple) 48 | -- package, each such effect is meant to be given by a GADT whose constructors 49 | -- denote the "algebraic operations" associated with the given effect. 50 | -- 51 | -- For instance, the effect of performing file IO could be described using 52 | -- the @FileIO@ effect, given by 53 | -- 54 | -- > data FileIO :: * -> * where 55 | -- > OpenFile :: FilePath -> IOMode -> FileIO Handle 56 | -- > CloseFile :: Handle -> FileIO () 57 | -- > ReadFile :: Handle -> FileIO String 58 | -- > WriteFile :: Handle -> String -> FileIO () 59 | -- 60 | -- A user computation performing no other effects than file IO and returning 61 | -- values of type @a@ would then have type @User '[FileIO] a@. 62 | newtype User sig a = 63 | UC (Eff sig a) deriving (Functor,Applicative,Monad) 64 | 65 | -- | The monad that we use to model kernel computations. Analogously to user 66 | -- computations, kernel computations can perform algebraic operations given 67 | -- effects in the signature @sig@ (using `performK`) and return values of 68 | -- type @a@. But differently from user computations, kernel computations 69 | -- additionally have access to runtime state of type @c@, which they can 70 | -- read using `getEnv` and write with `setEnv`. 71 | -- 72 | -- The primary use of kernel computations is to implement co-operations of 73 | -- runners, which in turn are then used to run user code using `run`. 74 | newtype Kernel sig c a = 75 | KC (c -> Eff sig (a,c)) deriving (Functor) 76 | 77 | instance Applicative (Kernel sig c) where 78 | pure v = KC (\ c -> return (v,c)) 79 | (KC f) <*> (KC k) = 80 | KC (\ c -> do (g,c') <- f c; 81 | (x,c'') <- k c'; 82 | return (g x,c'')) 83 | 84 | instance Monad (Kernel sig c) where 85 | return x = KC (\ c -> return (x,c)) 86 | (KC k) >>= f = 87 | KC (\ c -> do (x,c') <- k c; 88 | let (KC l) = f x in l c') 89 | 90 | -- | Embedding a user computation in a larger signature. 91 | embedU :: User sig a -> User (eff ': sig) a 92 | embedU (UC m) = UC (raise m) 93 | 94 | -- | Embedding a kernel computation in a larger signature. 95 | embedK :: Kernel sig c a -> Kernel (eff ': sig) c a 96 | embedK (KC k) = KC (\ c -> raise (k c)) 97 | 98 | -- | Focussing on a particular effect in a larger signature. 99 | -- 100 | -- This is sometimes useful when the effect @eff@ involves 101 | -- advanced uses of type indices, e.g., to track which 102 | -- references are alive in a given point in one's program, 103 | -- in which case the typing of `performU` can get confused. 104 | focus :: Member eff sig => User '[eff] a -> User sig a 105 | focus m = 106 | run fwdRunner (return ()) m (\ x () -> return x) 107 | 108 | -- | Performing an algebraic operation of the effect @eff@ in user code. 109 | -- 110 | -- For example, to perform a file read in user code one writes 111 | -- 112 | -- > performU (ReadFile fileHandle) :: User '[FileIO] String 113 | performU :: Member eff sig => eff a -> User sig a 114 | performU op = UC (send op) 115 | 116 | -- | Performing an algebraic operation of the effect @eff@ in kernel code. 117 | performK :: Member eff sig => eff a -> Kernel sig c a 118 | performK op = KC (\ c -> do x <- send op; return (x,c)) 119 | 120 | -- | Reading runtime state of type @c@ in kernel code. 121 | getEnv :: Kernel sig c c 122 | getEnv = KC (\ c -> return (c,c)) 123 | 124 | -- | Writing runtime state of type @c@ in kernel code. 125 | setEnv :: c -> Kernel sig c () 126 | setEnv c' = KC (\ c -> return ((),c')) 127 | 128 | -- | Context switch to execute a kernel computation in user mode. 129 | -- 130 | -- The 1st argument of type @Kernel sig c a@ is the kernel computation to be executed. 131 | -- 132 | -- The 2nd argument of type @c@ is the initial value for runtime state. 133 | -- 134 | -- The 3rd argument of type @a -> c -> User sig b@ is a finaliser for return values, 135 | -- which also performs the context switch back to user mode. 136 | kernel :: Kernel sig c a -> c -> (a -> c -> User sig b) -> User sig b 137 | kernel (KC k) c f = 138 | UC (do (x,c') <- k c; let (UC m) = f x c' in m) 139 | 140 | -- | Context switch to execute a user computation in kernel mode. 141 | -- 142 | -- The 1st argument of type @User sig a@ is the user computation to be executed. 143 | -- 144 | -- The 2nd argument of type @a -> Kernel sig c b@ is a finaliser for return values, 145 | -- which also performs the context switch back to kernel mode. 146 | user :: User sig a -> (a -> Kernel sig c b) -> Kernel sig c b 147 | user (UC m) f = 148 | KC (\ c -> do x <- m; let (KC k) = f x in k c) 149 | 150 | -- | Type of effectful runners that implement co-operations for the effects in signature @sig@, 151 | -- where each of the co-operations is a kernel computation that can perform algebraic operations 152 | -- given by (external) effects in the signature @sig'@ and access runtime state of type @c@. 153 | -- 154 | -- Given an effect @eff :: * -> *@ in @sig@, the corresponding co-operations are given by a 155 | -- function of type 156 | -- 157 | -- > forall b . eff b -> Kernel sig' c b 158 | -- 159 | -- in other words, by a mapping of every algebraic operation of the effect @eff@ 160 | -- (i.e., each of its constructors) to a corresponding kernel computation. 161 | data Runner sig sig' c where 162 | Empty :: Runner '[] sig' c 163 | CoOps :: (forall b . eff b -> Kernel sig' c b) 164 | -> Runner sig sig' c-> Runner (eff ': sig) sig' c 165 | 166 | -- | Make a runner for a single effect @eff@ by providing co-operations implementing 167 | -- each of its algebraic operations. 168 | -- 169 | -- For instance, a runner whose runtime state carries a file handle and that 170 | -- implements a co-operation for write-only file access could be given by 171 | -- 172 | -- > mkRunner (\ (Write s) -> do fh <- getEnv; performK (WriteFile fh s)) :: Runner '[WriteIO] '[FileIO] Handle 173 | -- 174 | -- where we assume that the effect @eff@ is given by 175 | -- 176 | -- > data WriteIO :: * -> * where 177 | -- > Write :: String -> FileIO () 178 | mkRunner :: (forall b . eff b -> Kernel sig c b) -> Runner '[eff] sig c 179 | mkRunner coops = CoOps coops Empty 180 | 181 | -- | Runner for the empty signature. 182 | emptyRunner :: Runner '[] sig' c 183 | emptyRunner = Empty 184 | 185 | -- | The (disjoint) union of two signatures. 186 | type family SigUnion (sig :: [* -> *]) (sig' :: [* -> *]) :: [* -> *] where 187 | SigUnion '[] sig' = sig' 188 | SigUnion (eff ': sig) sig' = eff ': (SigUnion sig sig') 189 | 190 | -- | Taking the union of (the co-operations of) two runners with the same 191 | -- external signature @sig''@ and runtime state @c@. The resulting runner 192 | -- implements co-operations for the union of the given signatures. 193 | -- 194 | -- The intended use of `unionRunners` is to build a runner for a composite 195 | -- signature from runners for individual effects given by `mkRunner`. 196 | unionRunners :: Runner sig sig'' c -> Runner sig' sig'' c 197 | -> Runner (SigUnion sig sig') sig'' c 198 | unionRunners Empty r' = r' 199 | unionRunners (CoOps coops r) r' = 200 | CoOps coops (unionRunners r r') 201 | 202 | -- | Embedding a runner in a larger external signature. 203 | embedRunner :: Runner sig sig' c -> Runner sig (eff ': sig') c 204 | embedRunner Empty = Empty 205 | embedRunner (CoOps coops r) = 206 | CoOps (\ op -> embedK (coops op)) (embedRunner r) 207 | 208 | -- | Extending the runtime state with an additional component, 209 | -- which the co-operations of the resulting runner keep unchanged. 210 | extendRunner :: Runner sig sig' c' -> Runner sig sig' (c,c') 211 | extendRunner Empty = Empty 212 | extendRunner (CoOps coops r) = 213 | CoOps (\ op -> KC (\ (c,c') -> 214 | do (x,c'') <- let (KC k) = coops op in k c'; 215 | return (x,(c,c'')))) 216 | (extendRunner r) 217 | 218 | -- | Pairing two runners with the same external signature @sig''@ 219 | -- but with possibly different runtime state types @c@ and @c'@. The 220 | -- resulting runner implements co-operations for the disjoint union 221 | -- of the given signatures, by executing first runner's co-operations 222 | -- on the first part of the composite runtime state, and the second 223 | -- runner's co-operations on the second part of the composite state. 224 | -- 225 | -- In other words, the resulting runner runs the given runners 226 | -- side-by-side, in a kind of a horizontal composition of runners. 227 | -- 228 | -- The intended use of `pairRunners` is to construct n-ary combinations 229 | -- of individual runners, e.g., by combining some number of file IO 230 | -- runners with some number of runners implementing ML-style state. 231 | pairRunners :: Runner sig sig'' c -> Runner sig' sig'' c' 232 | -> Runner (SigUnion sig sig') sig'' (c,c') 233 | pairRunners Empty r' = extendRunner r' 234 | pairRunners (CoOps coops r) r' = 235 | CoOps (\ op -> KC (\ (c,c') -> 236 | do (x,c'') <- let (KC k) = coops op in k c 237 | return (x,(c'',c')))) 238 | (pairRunners r r') 239 | 240 | -- | Runner that forwards all of its co-operations to some enveloping runner. 241 | fwdRunner :: Member eff sig => Runner '[eff] sig c 242 | fwdRunner = CoOps performK Empty 243 | 244 | -- | Running a single algebraic operation as a kernel computation using the given runner. 245 | runOp :: Runner sig sig' c -> Union sig b -> Kernel sig' c b 246 | runOp Empty _ = 247 | error "this should not have happened" 248 | runOp (CoOps coop coops) u = 249 | case decomp u of 250 | Right o -> coop o 251 | Left u -> runOp coops u 252 | 253 | -- | Auxiliary operation for running user computations using a given runner in which 254 | -- the initial runtime state is initialised by a value rather than an effectful user 255 | -- computation as in `run`. 256 | runAux :: Runner sig sig' c 257 | -> c 258 | -> User sig a 259 | -> (a -> c -> User sig' b) 260 | -> User sig' b 261 | runAux r c (UC (Val x)) mf = mf x c 262 | runAux r c (UC (E u q)) mf = 263 | kernel (runOp r u) c 264 | (\ x c' -> runAux r c' (UC (qApp q x)) mf) 265 | 266 | -- | A programming construct to run user code using a runner with guaranteed finalisation. 267 | -- 268 | -- The 1st argument (of type @Runner sig sig' c@) is the given runner. 269 | -- 270 | -- The 2nd argument (of type @User sig' c@) is a user computation that produces an initial 271 | -- value for the runtime state that the runner operates on. 272 | -- 273 | -- The 3rd argument (of type @User sig a@) is the user computation that we are running 274 | -- using the given runner. Observe that this user computation can only perform the 275 | -- algebraic operations for the effects in the signature @sig@ implemented by the runner. 276 | -- It cannot directly perform algebraic operations from the (external) signature @sig'@. 277 | -- It can only do so if the runner explicitly forwards the needed algebraic operations. 278 | -- 279 | -- The 4th argument (of type @a -> c -> User sig' b@) is a user computation that 280 | -- finalises for return values. Notice that in addition to having access to return values, 281 | -- it can also access the final value of the runtime state, so as to perform cleanup. 282 | -- 283 | -- For instance, we can run a simple user computation using the write-only file access 284 | -- runner defined in the description of `mkRunner` as follows 285 | -- 286 | -- > run 287 | -- > (mkRunner (\ (Write s) -> do fh <- getEnv; performK (WriteFile fh s))) 288 | -- > (performU (OpenFile "hello.txt" WriteMode)) 289 | -- > (do performU (Write "Hello, world."); performU (Write "Hello, again.")) 290 | -- > (\ x fh -> do performU (CloseFile fh); return x) 291 | -- > :: User '[FileIO] () 292 | -- 293 | -- Here we initialise the runtime state for the write-only file access runner 294 | -- with a file handle pointing to @"hello.txt"@, by performing a file open 295 | -- operation that would be implemented by some enveloping runner. The user 296 | -- computation that we run with said runner simply performs two calls to 297 | -- the @Write@ operation. Finally, the finaliser closes the file handle and 298 | -- passes on the return value unchanged. Observe how this write-only file 299 | -- access runner hides the file handle from the user code being run (the 300 | -- latter can only perform the @Write@ operation that takes only a string 301 | -- as an argument and not the file handle itself). Furthermore, the semantics 302 | -- of the `run` operation ensures that the finaliser is always called exactly 303 | -- once, ensuring a correct cleanup of the file handle resource, as desired. 304 | -- 305 | -- In the context of the 306 | -- talk [Interacting with external resources using runners (aka comodels)](https://danel.ahman.ee/talks/chocola19.pdf), 307 | -- the `run` operation corresponds to the following programming construct 308 | -- 309 | -- > using R @ M_init 310 | -- > run M 311 | -- > finally { 312 | -- > return x @ c -> M_return } 313 | run :: Runner sig sig' c 314 | -> User sig' c 315 | -> User sig a 316 | -> (a -> c -> User sig' b) 317 | -> User sig' b 318 | run r mi m mf = 319 | do c <- mi; runAux r c m mf 320 | 321 | -- | A top-level for running user computations for the empty signature as pure, effect-free values. 322 | pureTopLevel :: User '[] a -> a 323 | pureTopLevel (UC (Val x)) = x 324 | pureTopLevel _ = error "this should not have happened" 325 | 326 | -- | A top-level for running user computations as Haskell's monadic computations. 327 | topLevel :: Monad m => User '[m] a -> m a 328 | topLevel (UC c) = runM c 329 | 330 | -- | Syntactic sugar for top-level running of user computations in the IO monad, defined using `topLevel`. 331 | ioTopLevel :: User '[IO] a -> IO a 332 | ioTopLevel = topLevel 333 | -------------------------------------------------------------------------------- /src/Control/SignalRunner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | {-| 12 | Module : Control.SignalRunner 13 | Description : Effectful runners (in their general form, with support for both exceptions and signals) 14 | Copyright : (c) Danel Ahman, 2019 15 | License : MIT 16 | Maintainer : danel.ahman@eesti.ee 17 | Stability : experimental 18 | 19 | This module provides an implementation of effectful runners of algebraic effects (in their general form, 20 | with support for both exceptions and signals) to run user code (modelled using the `User` monad) 21 | with co-operations implemented as kernel code (modelled using the `Kernel` monad). 22 | 23 | This module is based on ongoing research of [Danel Ahman](https://danel.ahman.ee) and [Andrej Bauer](http://www.andrej.com). 24 | Interested readers should check out a recent draft [Runners in action](https://arxiv.org/abs/1910.11629) 25 | that develops the theoretical underpinnings, presents a core calculus for programming with runners 26 | that the current module implements, and discusses various example uses of runners. 27 | For general background reading on algebraic effects and handlers, we recommend the lecture 28 | notes [What is algebraic about algebraic effects and handlers?](https://arxiv.org/abs/1807.05923). Section 4 29 | of these notes discusses ordinary runners of algebraic effects (also known in the literature as comodels of algebraic effects). 30 | 31 | The `User` and `Kernel` monad use internally the [freer-simple](http://hackage.haskell.org/package/freer-simple) 32 | implementation of a free monad on a signature of effects, namely, the `Eff` monad. 33 | -} 34 | module Control.SignalRunner ( 35 | User, Kernel, embedU, embedK, focus, performU, performK, 36 | raiseU, raiseK, kill, getEnv, setEnv, tryWithU, tryWithK, 37 | kernel, user, Runner, mkRunner, emptyRunner, SigUnion, 38 | unionRunners, embedRunner, extendRunner, pairRunners, 39 | fwdRunner, run, pureTopLevel, topLevel, ioTopLevel, 40 | Zero, impossible, Member 41 | ) where 42 | 43 | import Control.Monad.Freer.Internal hiding (run) 44 | import Control.Monad.Except 45 | import Control.Monad.State 46 | 47 | -- | The monad that we use to model user computations that can perform algebraic 48 | -- operations given by effects in the signature @sig@ (using `performU`), raise 49 | -- exceptions of type @e@ (using `raiseU`), and return values of type @a@. 50 | -- The algebraic operation calls will be implemented by some enveloping runner of type `Runner`. 51 | -- 52 | -- The signature @sig@ has type @[* -> *]@, in other words, it is a list of effects. 53 | -- Exactly as in the [freer-simple](http://hackage.haskell.org/package/freer-simple) 54 | -- package, each such effect is meant to be given by a GADT whose constructors 55 | -- denote the "algebraic operations" associated with the given effect. 56 | -- 57 | -- Compared to the talk [Interacting with external resources using runners (aka comodels)](https://danel.ahman.ee/talks/chocola19.pdf), 58 | -- the our library currently does not support uniformly attaching an exception type to 59 | -- each of effects in the signature @sig@. Instead, the programmer is currently expected 60 | -- to model effects that can raise exceptions by typing relevant algebraic operations 61 | -- appropriately, and pass the exception as an `Either`-typed return value. 62 | -- 63 | -- For instance, the effect of performing file IO could be described using 64 | -- the @FileIO@ effect, given by 65 | -- 66 | -- > data FileIO :: * -> * where 67 | -- > OpenFile :: FilePath -> IOMode -> FileIO (Either Handle E) 68 | -- > CloseFile :: Handle -> FileIO (Either () E) 69 | -- > ReadFile :: Handle -> FileIO (Either String E) 70 | -- > WriteFile :: Handle -> String -> FileIO (Either () E) 71 | -- 72 | -- where @E@ is a type of IO exceptions. For example, one plausible definition of @E@ could be 73 | -- 74 | -- > data E where 75 | -- > FileNotFound :: FilePath -> E 76 | -- > InvalidFilehandle :: Handle -> E 77 | -- > QuotaExceeded :: E 78 | -- > IncorrectIOMode :: IOMode -> E 79 | -- > FileHandleAlreadyClosed :: Handle -> E 80 | -- > IOException :: E 81 | -- 82 | -- As such, performing any of the file IO operation in one's code could either result 83 | -- in returning a successful return value in the left branch of `Either`, or raising 84 | -- an exception in @E@ by returning a value in the right branch of `Either`. 85 | -- 86 | -- It is worthwhile to point out that some of the exceptions also carry data, which can be 87 | -- useful for debugging reasons, or for finalising resources in the `run` operation below. 88 | -- We also note that one could be flexible about which operations of an effect can raise 89 | -- exceptions and which cannot. After all, exceptions are just part of the typing of 90 | -- individual operations. 91 | -- 92 | -- A user computation performing no other effects than file IO, potentially raising exceptions 93 | -- @e@, and returning values of type @a@ would then have type @User '[FileIO] e a@. 94 | newtype User sig e a = 95 | U (Eff sig (Either a e)) 96 | 97 | fmapE :: (a -> b) -> Either a e -> Either b e 98 | fmapE f (Left x) = Left (f x) 99 | fmapE f (Right e) = Right e 100 | 101 | instance Functor (User sig e) where 102 | fmap f (U m) = U (fmap (fmapE f) m) 103 | 104 | bindU :: User sig e a -> (a -> User sig e b) -> User sig e b 105 | bindU m f = tryWithU m f (\ e -> raiseU e) 106 | 107 | instance Applicative (User sig e) where 108 | pure x = U (pure (Left x)) 109 | f <*> m = bindU f (\ g -> bindU m (\ x -> pure (g x))) 110 | 111 | instance Monad (User sig e) where 112 | return x = pure x 113 | m >>= f = bindU m f 114 | 115 | -- | The monad that we use to model kernel computations. Analogously to user 116 | -- computations, kernel computations can perform algebraic operations given 117 | -- effects in the signature @sig@ (using `performK`), raise exceptions of type @e@ 118 | -- (using `raiseK`), and return values of type @a@. But differently from user 119 | -- computations, kernel computations additionally have access to runtime state of type @c@, 120 | -- which they can read using `getEnv` and write with `setEnv`, and they can 121 | -- also send (kill) signals of type @s@ (using `kill`). 122 | -- 123 | -- The primary use of kernel computations is to implement co-operations of 124 | -- runners, which in turn are then used to run user code using `run`. 125 | newtype Kernel sig e s c a = 126 | K (c -> (Eff sig (Either (Either a e,c) s))) 127 | 128 | instance Functor (Kernel sig e s c) where 129 | fmap f (K k) = 130 | K (\ c -> fmap (fmapE (\ (xe,c) -> (fmapE f xe,c))) (k c)) 131 | 132 | bindK :: Kernel sig e s c a 133 | -> (a -> Kernel sig e s c b) 134 | -> Kernel sig e s c b 135 | bindK k f = tryWithK k f (\ e -> raiseK e) 136 | 137 | instance Applicative (Kernel sig e s c) where 138 | pure x = K (\ c -> pure (Left (Left x,c))) 139 | f <*> k = bindK f (\ g -> bindK k (\ x -> pure (g x))) 140 | 141 | instance Monad (Kernel sig e s c) where 142 | return x = pure x 143 | k >>= f = bindK k f 144 | 145 | -- | Embedding a user computation in a larger signature. 146 | embedU :: User sig e a -> User (eff ': sig) e a 147 | embedU (U m) = U (raise m) 148 | 149 | -- | Embedding a kernel computation in a larger signature. 150 | embedK :: Kernel sig e s c a -> Kernel (eff ': sig) e s c a 151 | embedK (K k) = K (\ c -> raise (k c)) 152 | 153 | -- | Focussing on a particular effect in a larger signature. 154 | focus :: Member eff sig => User '[eff] e a -> User sig e a 155 | focus m = 156 | run 157 | fwdRunner 158 | (return ()) 159 | m 160 | (\ x () -> return x) 161 | (\ e () -> raiseU e) 162 | impossible -- forces the set of kill signals of `fwdRunner` to be `Zero` 163 | 164 | -- | Performing an algebraic operation of the effect @eff@ in user code. 165 | -- 166 | -- For example, to perform a file read in user code one writes 167 | -- 168 | -- > performU (ReadFile fileHandle) :: User '[FileIO] e (Either String E) 169 | -- 170 | -- As discussed in the description of `User`, the library currently 171 | -- does not support attaching exceptions to effects in a signature. 172 | -- Instead the programmer is expected to model any exceptions returned 173 | -- by an operation as an exceptional return values, as above. In example 174 | -- programs we have found that this style is not too troublesome, 175 | -- because in the end one usually exposes more human-readably wrapped 176 | -- generic effects to the programmer. Part of that wrapping is then 177 | -- pattern matching on the exception returned as a `Either`-typed value, 178 | -- and raising it as an exception proper in the `User` monad (using 179 | -- `raiseU`), e.g., see the discussion in the description of `run`. 180 | -- 181 | -- Also observe that the exception index @e@ is left polymorphic above---it 182 | -- gets instantiated by the contex in which one places this operation call. 183 | -- 184 | performU :: Member eff sig => eff a -> User sig e a 185 | performU op = U (do x <- send op; return (Left x)) 186 | 187 | -- | Performing an algebraic operation of the effect @eff@ in kernel code. 188 | performK :: Member eff sig => eff a -> Kernel sig e s c a 189 | performK op = K (\ c -> (do x <- send op; return (Left (Left x,c)))) 190 | 191 | -- | Raising an exception of type @e@ in user code. 192 | -- 193 | -- Raised user exceptions can be caught with `tryWithU`, and with 194 | -- the finalisers of `run` and `user`. 195 | -- 196 | -- For instance, when working with file IO, @e@ could be the type 197 | -- 198 | -- > data E where 199 | -- > FileNotFound :: FilePath -> E 200 | -- > InvalidFilehandle :: Handle -> E 201 | -- > QuotaExceeded :: E 202 | -- > IncorrectIOMode :: IOMode -> E 203 | -- > FileHandleAlreadyClosed :: Handle -> E 204 | -- > IOException :: E 205 | -- 206 | -- that we discussed in the description of the `User` monad. 207 | raiseU :: e -> User sig e a 208 | raiseU e = U (return (Right e)) 209 | 210 | -- | Raising an exception of type @e@ in user code. 211 | -- 212 | -- Raised kernel exceptions can be caught with `tryWithK`, 213 | -- and with the finalisers of `kernel`. 214 | raiseK :: e -> Kernel sig e s c a 215 | raiseK e = K (\ c -> return (Left (Right e,c))) 216 | 217 | -- | Sending a (kill) signal of type @s@ in kernel code. 218 | -- 219 | -- Signals can be caught with the finalisers of `run` and `kernel`. 220 | -- 221 | -- For instance, when working with file IO, @s@ could be the type 222 | -- 223 | -- > data S where 224 | -- > DiscDisconnected :: S 225 | -- > IOError :: S 226 | -- 227 | -- The role of signals is to indicate unavoidable, unrecoverable circumstances. 228 | -- If a signal is sent in a co-operation when running user code with `run`, 229 | -- the rest of the user code is killed off and control jumps to the finaliser 230 | -- for signals. This is in contrast with exceptions raised by co-operations, 231 | -- from which user code being run with `run` can recover from. 232 | kill :: s -> Kernel sig e s c a 233 | kill s = K (\ c -> return (Right s)) 234 | 235 | -- | Reading runtime state of type @c@ in kernel code. 236 | getEnv :: Kernel sig e s c c 237 | getEnv = K (\ c -> return (Left (Left c,c))) 238 | 239 | -- | Writing runtime state of type @c@ in kernel code. 240 | setEnv :: c -> Kernel sig e s c () 241 | setEnv c' = K (\ c -> return (Left (Left (),c'))) 242 | 243 | -- | Exception handler for user code, based on Benton and Kennedy's 244 | -- [exceptional syntax](https://www.cambridge.org/core/journals/journal-of-functional-programming/article/exceptional-syntax/58206FB399EDC9F197A0D53BC46E4667). 245 | tryWithU :: User sig e a 246 | -> (a -> User sig e' b) 247 | -> (e -> User sig e' b) 248 | -> User sig e' b 249 | tryWithU (U m) f g = 250 | U (do ex <- m; 251 | either 252 | (\ x -> let (U m') = f x in m') 253 | (\ e -> let (U m') = g e in m') 254 | ex) 255 | 256 | -- | Exception handler for kernel code, based on Benton and Kennedy's 257 | -- [exceptional syntax](https://www.cambridge.org/core/journals/journal-of-functional-programming/article/exceptional-syntax/58206FB399EDC9F197A0D53BC46E4667). 258 | tryWithK :: Kernel sig e s c a 259 | -> (a -> Kernel sig e' s c b) 260 | -> (e -> Kernel sig e' s c b) 261 | -> Kernel sig e' s c b 262 | tryWithK (K k) f g = 263 | K (\ c -> 264 | do xs <- k c; 265 | either 266 | (\ (xe,c') -> 267 | either 268 | (\ x -> let (K f') = f x in f' c') 269 | (\ e -> let (K g') = g e in g' c') 270 | xe) 271 | (\ s -> return (Right s)) 272 | xs) 273 | 274 | -- | Context switch to execute a kernel computation in user mode. 275 | -- 276 | -- The 1st argument of type @Kernel sig e s c a@ is the kernel computation to be executed. 277 | -- 278 | -- The 2nd argument of type @c@ is the initial value for runtime state. 279 | -- 280 | -- The 3rd argument of type @a -> c -> User sig e' b@ is a finaliser for return values. 281 | -- 282 | -- The 4th argument of type @e -> c -> User sig e' b@ is a finaliser for exceptions. 283 | -- 284 | -- The 5th argument of type @s -> User sig e' b@ is a finaliser for signals. 285 | -- 286 | -- The 3rd, 4th, and 5th argument perform the context switch back to user mode. 287 | kernel :: Kernel sig e s c a 288 | -> c 289 | -> (a -> c -> User sig e' b) 290 | -> (e -> c -> User sig e' b) 291 | -> (s -> User sig e' b) 292 | -> User sig e' b 293 | kernel (K k) c f g h = 294 | U (do xs <- k c; 295 | either 296 | (\ (xe,c') -> 297 | either 298 | (\ x -> let (U m) = f x c' in m) 299 | (\ e -> let (U m) = g e c' in m) 300 | xe) 301 | (\ s -> let (U m) = h s in m) 302 | xs) 303 | 304 | -- | Context switch to execute a user computation in kernel mode. 305 | -- 306 | -- The 1st argument of type @User sig e a@ is the user computation to be executed. 307 | -- 308 | -- The 2nd argument of type @a -> Kernel sig e' s c b@ is a finaliser for return values. 309 | -- 310 | -- The 3rd argument of type @e -> Kernel sig e' s c b@ is a finaliser for exceptions. 311 | -- 312 | -- The 2nd and 3rd argument perform the context switch back to kernel mode. 313 | user :: User sig e a 314 | -> (a -> Kernel sig e' s c b) 315 | -> (e -> Kernel sig e' s c b) 316 | -> Kernel sig e' s c b 317 | user (U m) f g = 318 | K (\ c -> do xe <- m; 319 | either 320 | (\ x -> let (K k) = f x in k c) 321 | (\ e -> let (K k) = g e in k c) 322 | xe) 323 | 324 | -- | Type of effectful runners that implement co-operations for the effects in 325 | -- signature @sig@, where each of the co-operations is a kernel computation that 326 | -- can perform algebraic operations given by (external) effects in the signature 327 | -- @sig'@, send (kill) signals @s@, and access runtime state of type @c@. The 328 | -- exception index in the type of each co-operation is `Zero`, i.e., the empty 329 | -- type, because currently we do not attach exceptions to effects in signatures. 330 | -- As a result, any exceptions have to be returned as `Either`-typed values. 331 | -- For example, see the discussion in the descriptions of `User` and `performU`. 332 | -- 333 | -- Given an effect @eff :: * -> *@ in @sig@, the corresponding co-operations are 334 | -- given by a function of type 335 | -- 336 | -- > forall b . eff b -> Kernel sig' c b 337 | -- 338 | -- in other words, by a mapping of every algebraic operation of the effect @eff@ 339 | -- (i.e., each of its constructors) to a corresponding kernel computation. 340 | data Runner sig sig' s c where 341 | Empty :: Runner '[] sig' s c 342 | CoOps :: (forall b . eff b -> Kernel sig' Zero s c b) 343 | -> Runner sig sig' s c-> Runner (eff ': sig) sig' s c 344 | 345 | -- | Make a runner for a single effect @eff@ by providing co-operations implementing 346 | -- each of its algebraic operations. 347 | -- 348 | -- For instance, a runner whose runtime state carries a file handle and that 349 | -- implements a co-operation for write-only file access could be given by 350 | -- 351 | -- > mkRunner (\ (Write s) -> do fh <- getEnv; performK (WriteFile fh s)) :: Runner '[WriteIO] '[FileIO] S (Either Handle E) 352 | -- 353 | -- where we assume that the effect @eff@ is given by 354 | -- 355 | -- > data WriteIO :: * -> * where 356 | -- > Write :: String -> FileIO (Either () E) 357 | -- 358 | -- where @E@ is some type of IO exceptions (e.g., see the description of `raiseU`), and 359 | -- where @S@ is some type of IO signals (e.g., containing a @DiskDisconnected@ signal 360 | -- to model the possibility of a remote disk getting disconnected unexpectedly). 361 | mkRunner :: (forall b . eff b -> Kernel sig Zero s c b) 362 | -> Runner '[eff] sig s c 363 | mkRunner coops = CoOps coops Empty 364 | 365 | -- | Runner for the empty signature. 366 | emptyRunner :: Runner '[] sig' s c 367 | emptyRunner = Empty 368 | 369 | -- | The (disjoint) union of two signatures. 370 | type family SigUnion (sig :: [* -> *]) (sig' :: [* -> *]) :: [* -> *] where 371 | SigUnion '[] sig' = sig' 372 | SigUnion (eff ': sig) sig' = eff ': (SigUnion sig sig') 373 | 374 | -- | Taking the union of (the co-operations of) two runners with the same 375 | -- external signature @sig''@, (kill) signals @s@, and runtime state @c@. 376 | -- The resulting runner implements co-operations for the union of the given signatures. 377 | -- 378 | -- The intended use of `unionRunners` is to build a runner for a composite 379 | -- signature from runners for individual effects given by `mkRunner`. 380 | unionRunners :: Runner sig sig'' s c -> Runner sig' sig'' s c 381 | -> Runner (SigUnion sig sig') sig'' s c 382 | unionRunners Empty r' = r' 383 | unionRunners (CoOps coops r) r' = 384 | CoOps coops (unionRunners r r') 385 | 386 | -- | Embedding a runner in a larger external signature. 387 | embedRunner :: Runner sig sig' s c -> Runner sig (eff ': sig') s c 388 | embedRunner Empty = Empty 389 | embedRunner (CoOps coops r) = 390 | CoOps (\ op -> embedK (coops op)) (embedRunner r) 391 | 392 | -- | Extending the runtime state with an additional component, 393 | -- which the co-operations of the resulting runner keep unchanged. 394 | extendRunner :: Runner sig sig' s c' -> Runner sig sig' s (c,c') 395 | extendRunner Empty = Empty 396 | extendRunner (CoOps coops r) = 397 | CoOps (\ op -> K (\ (c,c') -> 398 | do xs <- let (K k) = coops op in k c'; 399 | either 400 | (\ (xe,c'') -> return (Left (xe,(c,c'')))) 401 | (\ s -> return (Right s)) 402 | xs)) 403 | (extendRunner r) 404 | 405 | -- | Pairing two runners with the same external signature @sig''@ 406 | -- but with possibly different runtime state types @c@ and @c'@. The 407 | -- resulting runner implements co-operations for the disjoint union 408 | -- of the given signatures, by executing first runner's co-operations 409 | -- on the first part of the composite runtime state, and the second 410 | -- runner's co-operations on the second part of the composite state. 411 | -- 412 | -- In other words, the resulting runner runs the given runners 413 | -- side-by-side, in a kind of a horizontal composition of runners. 414 | -- 415 | -- The intended use of `pairRunners` is to construct n-ary combinations 416 | -- of individual runners, e.g., by combining some number of file IO 417 | -- runners with some number of runners implementing ML-style state. 418 | pairRunners :: Runner sig sig'' s c -> Runner sig' sig'' s c' 419 | -> Runner (SigUnion sig sig') sig'' s (c,c') 420 | pairRunners Empty r' = extendRunner r' 421 | pairRunners (CoOps coops r) r' = 422 | CoOps (\ op -> K (\ (c,c') -> 423 | do xs <- let (K k) = coops op in k c 424 | either 425 | (\ (xe,c'') -> return (Left (xe,(c'',c')))) 426 | (\ s -> return (Right s)) 427 | xs)) 428 | (pairRunners r r') 429 | 430 | -- | Runner that forwards all of its co-operations to some enveloping runner. 431 | fwdRunner :: Member eff sig => Runner '[eff] sig s c 432 | fwdRunner = CoOps performK Empty 433 | 434 | -- | Running a single algebraic operation as a kernel computation using the given runner. 435 | runOp :: Runner sig sig' s c -> Union sig b -> Kernel sig' Zero s c b 436 | runOp Empty _ = 437 | error "this should not have happened" 438 | runOp (CoOps coop coops) u = 439 | case decomp u of 440 | Right o -> coop o 441 | Left u -> runOp coops u 442 | 443 | -- | Auxiliary operation for running user computations using a given runner in which 444 | -- the initial runtime state is initialised by a value rather than an effectful user 445 | -- computation as in `run`. 446 | runAux :: Runner sig sig' s c 447 | -> c 448 | -> User sig e a 449 | -> (a -> c -> User sig' e' b) 450 | -> (e -> c -> User sig' e' b) 451 | -> (s -> User sig' e' b) 452 | -> User sig' e' b 453 | runAux r c (U (Val (Left x))) f g h = f x c 454 | runAux r c (U (Val (Right e))) f g h = g e c 455 | runAux r c (U (E op q)) f g h = 456 | kernel 457 | (runOp r op) 458 | c 459 | (\ x c' -> runAux r c' (U (qApp q x)) f g h) 460 | (\ e c' -> impossible e) 461 | (\ s -> h s) 462 | 463 | -- | A programming construct to run user code using a runner with guaranteed finalisation. 464 | -- 465 | -- The 1st argument (of type @Runner sig sig' c@) is the given runner. 466 | -- 467 | -- The 2nd argument (of type @User sig' e' c@) is a user computation that produces an initial 468 | -- value for the runtime state that the runner operates on. 469 | -- 470 | -- The 3rd argument (of type @User sig e a@) is the user computation that we are running 471 | -- using the given runner. Observe that this user computation can only perform the 472 | -- algebraic operations for the effects in the signature @sig@ implemented by the runner. 473 | -- It cannot directly perform algebraic operations from the (external) signature @sig'@. 474 | -- It can only do so if the runner explicitly forwards the needed algebraic operations. 475 | -- 476 | -- The 4th argument (of type @a -> c -> User sig' e' b@) is a user computation that 477 | -- finalises for return values. Notice that in addition to having access to return values, 478 | -- it can also access the final value of the runtime state, so as to perform cleanup. 479 | -- 480 | -- The 5th argument (of type @e -> c -> User sig' e' b@) is a user computation that 481 | -- finalises for exceptions. As with the finaliser for return values, this computation 482 | -- also has access to the final value of the rutime state, so as to perform cleanup. 483 | -- 484 | -- The 6th argument (of type @s -> User sig' e' b@) is a user computation that 485 | -- finalises for (kill) signals. In contrast witht the finalisers for return values and 486 | -- exceptions, this computation does not have access to the final runtime state. 487 | -- 488 | -- For instance, we can run a simple user computation using the write-only file access 489 | -- runner defined in the description of `mkRunner` as follows 490 | -- 491 | -- > run 492 | -- > (mkRunner (\ (Write s) -> do fh <- getEnv; performK (WriteFile fh s))) 493 | -- > (open "hello.txt" WriteMode) 494 | -- > (write "Hello, world."; write "Hello, again.") 495 | -- > (\ x fh -> close fh; return x) 496 | -- > (\ e fh -> close fh; raiseU e) 497 | -- > (\ s -> return ()) 498 | -- > :: User '[FileIO] E () 499 | -- 500 | -- where @open@, @write@, and @close@ are the human-readably wrapped generic effect 501 | -- for performing @OpenFile@, @Write@, and @CloseFile@ operations, defined as follows 502 | -- 503 | -- > open fn m = 504 | -- > do xe <- performU (OpenFile fn m); 505 | -- > either (\ x -> return x) (\ e -> raiseU e) xe 506 | -- > :: User '[FileIO] E Handle 507 | -- 508 | -- > write fn m = 509 | -- > do xe <- performU (Write s); 510 | -- > either (\ x -> return x) (\ e -> raiseU e) xe 511 | -- > :: User '[WriteIO] E () 512 | -- 513 | -- > close fh = 514 | -- > do xe <- performU (CloseFile fh); 515 | -- > either (\ x -> return x) (\ e -> raiseU e) xe 516 | -- > :: User '[FileIO] E () 517 | -- 518 | -- Observe that these generic effects pattern-matches on the `Either`-typed value returned 519 | -- by `performU`, and raise any exception values as exceptions proper with `raiseU`. 520 | -- 521 | -- Above we initialise the runtime state for the write-only file access runner 522 | -- with a file handle pointing to @"hello.txt"@, by performing a file open 523 | -- operation that would be implemented by some enveloping runner. The user 524 | -- computation that we run with said runner simply performs two calls to 525 | -- the @Write@ operation. Finally, the finaliser for return values closes the 526 | -- file handle and passes on the return value unchanged; the finaliser for 527 | -- exceptions also closes the file handle, but re-raises the exception; and 528 | -- the finaliser for signals simply returns the unit value, the intuition 529 | -- being that once a signal is sent, there are no resources to finalise. 530 | -- 531 | -- Observe how this write-only file access runner hides the file handle from 532 | -- the user code being run (the latter can only perform the @Write@ operation 533 | -- that takes only a string as an argument and not the file handle itself). 534 | -- Furthermore, the semantics of the `run` operation ensures that one of the 535 | -- finalisers is always called exactly once, ensuring a correct cleanup of the 536 | -- file handle resource, as desired. Though this last part has to be taken with 537 | -- a pinch of salt. If a signal is raised in a co-operation of some outer, enveloping 538 | -- runner that is used to run the above code-snippet, then control jumps to the 539 | -- finalisation block of this outer `run` operation, and the inner code gets killed. 540 | -- 541 | -- In the context of the 542 | -- talk [Interacting with external resources using runners (aka comodels)](https://danel.ahman.ee/talks/chocola19.pdf), 543 | -- the `run` operation corresponds to the following programming construct 544 | -- 545 | -- > using R @ M_init 546 | -- > run M 547 | -- > finally { 548 | -- > return x @ c -> M_return, 549 | -- > (raise e @ c -> M_e)_{e \in E}, 550 | -- > (kill s -> M_s)_{s \in S}} 551 | run :: Runner sig sig' s c 552 | -> User sig' e' c 553 | -> User sig e a 554 | -> (a -> c -> User sig' e' b) 555 | -> (e -> c -> User sig' e' b) 556 | -> (s -> User sig' e' b) 557 | -> User sig' e' b 558 | run r i m f g h = 559 | do c <- i; runAux r c m f g h 560 | 561 | -- | A top-level for running user computations for the empty signature as pure, effect-free values. 562 | pureTopLevel :: User '[] Zero a -> a 563 | pureTopLevel (U (Val (Left x))) = x 564 | pureTopLevel _ = error "this should not have happened" 565 | 566 | -- | A top-level for running user computations as Haskell's monadic computations. 567 | topLevel :: Monad m => User '[m] Zero a -> m a 568 | topLevel (U m) = runM (fmap (either id impossible) m) 569 | 570 | -- | Syntactic sugar for top-level running of user computations in the IO monad, defined using `topLevel`. 571 | ioTopLevel :: User '[IO] Zero a -> IO a 572 | ioTopLevel = topLevel 573 | 574 | -- | The empty type that does not have any constructors. 575 | data Zero 576 | 577 | -- | The elimination form for the empty type. 578 | impossible :: Zero -> a 579 | impossible x = case x of {} 580 | --------------------------------------------------------------------------------