├── LICENSE ├── Paper ├── content │ ├── conclusions.tex │ ├── examples.tex │ ├── implement.tex │ ├── intro.tex │ ├── motivate.tex │ └── sttutorial.tex ├── diagrams │ ├── doorstate.graphml │ ├── doorstate.pdf │ ├── login.graphml │ ├── login.pdf │ ├── login2.graphml │ ├── login2.pdf │ ├── netstate.graphml │ ├── netstate.pdf │ ├── randarch.graphml │ ├── randarch.pdf │ ├── randclient.graphml │ ├── randclient.pdf │ ├── randserver.graphml │ └── randserver.pdf ├── dtp.bib ├── fpmacros.sty ├── idrislang.sty ├── idrisvars.pdf ├── idrisvars.tex └── library.ltx ├── README.md ├── examples ├── Async.idr ├── Composite.idr ├── Door.idr ├── Graphics │ ├── Draw.idr │ └── Turtle.idr ├── HTTP │ ├── HTTPMessage.idr │ ├── HTTPServer.idr │ ├── Network.idr │ └── Threads.idr ├── Login.idr ├── Net │ ├── EchoSimple.idr │ ├── Network.idr │ ├── RandServer.idr │ └── Threads.idr └── Sessions │ └── Conc.idr ├── src └── Control │ ├── ST.idr │ └── ST │ └── ImplicitCall.idr └── vars.ipkg /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Edwin Brady 2 | School of Computer Science, University of St Andrews 3 | All rights reserved. 4 | 5 | This code is derived from software written by Edwin Brady 6 | (eb@cs.st-andrews.ac.uk). 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 3. None of the names of the copyright holders may be used to endorse 17 | or promote products derived from this software without specific 18 | prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY 21 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 23 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE 24 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 25 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 26 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 27 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 29 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 30 | IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | *** End of disclaimer. *** 33 | -------------------------------------------------------------------------------- /Paper/content/conclusions.tex: -------------------------------------------------------------------------------- 1 | %\section{Discussion} 2 | 3 | \section{Related Work} 4 | 5 | This paper builds on previous work on algebraic effects in 6 | Idris~\citep{brady-eff2013,brady-tfp14}, and the implementation of 7 | \texttt{STrans} follows many of the ideas used in these earlier 8 | implementations. However, this earlier work had several limitations, most 9 | importantly that it was not possible to implement one effectful API in 10 | terms of others, and that it was difficult to describe the relationship 11 | between separate resources, such as the fact that \texttt{accept} creates 12 | a new resource in a specific initial state. The work in the present paper is 13 | influenced in particular by previous work on Separation Logic, Linear Types 14 | and Session Types, and has connections with other type systems and tools 15 | for formal verification. In this section we discuss these and other 16 | connections. 17 | 18 | \emph{\textsf{Separation Logic and Indexed Monads:}} 19 | % 20 | The representation of state transition systems using dependent types owes much 21 | to Atkey's study of indexed monads~\citep{atkey-param}, and McBride's 22 | implementation of dynamic interaction in Haskell~\citep{mcbride-kleisli}. The 23 | state transitions given by operations in \states{}, like in this previous 24 | work on indexed monads, are reminiscent of Hoare Triples~\citep{hoarelogic}. 25 | Separation Logic~\citep{reynolds2002}, an extension of Hoare Logic, 26 | permits local reasoning by allowing a heap to be split into two disjoint 27 | parts, like the \texttt{call} function in 28 | \states{}. This has previously been implemented as Ynot, an axiomatic extension 29 | to Coq~\citep{ynot08}. 30 | Separation Logic allows us to reason about the state of a program's heap. The 31 | key distinction between this previous work and \states{} is that we reason 32 | about individual resources, such as files and network sockets, rather than 33 | about the entire heap, and list these resources in a context. 34 | While Separation Logic can prove more complex properties, our 35 | approach has a clean embedding in the host language, which 36 | leads to readable types and, because resources are combined in predictable 37 | ways, minimises the proof obligations for the programmer. Indeed, the examples 38 | in Section~\ref{sect:examples} require \emph{no} additional effort 39 | from the programmer to prove that resources are used correctly. 40 | 41 | % \citep{Chlipala2015} 42 | 43 | \emph{\textsf{Linear Types:}} 44 | % 45 | Indexed monads, as used in \states{}, are a way of encoding 46 | linearity~\citep{wadler-linear,Abramsky1993} 47 | in a dependently typed host language. Recent work by~\citet{neelk2015} 48 | and by~\citet{McBride2016} has shown ways of integrating linear and 49 | dependent types, and the latter has been implemented as an experimental 50 | extension to Idris. 51 | Our experience has been that linear types can provide the same guarantees 52 | as the \states{} library, but that, subjectively, they have a more ``low-level'' 53 | feel than the indexed monad approach. A particular notational inconvenience is 54 | the need for a function which updates a linear resource to return a new 55 | reference to the resource, a detail which is abstracted away by the indexed 56 | monad. Nevertheless, we hope to explore the connection further in future work. 57 | In particular, linear dependent types may give us an efficienct 58 | method for implementing \states{}. 59 | 60 | \emph{\textsf{Types and State Machines:}} 61 | % 62 | Earlier work has recognised the importance of state transition systems 63 | in describing applications~\citep{statecharts}. 64 | % 65 | In this paper, we have used \states{} to describe systems in terms 66 | of state transitions on resources, 67 | both at the level of external resources like network sockets and at 68 | the application level. 69 | The problem of reasoning about protocols has previously been 70 | tackled using special purpose type systems~\citep{Walker2000}, by creating 71 | DSLs for resource management~\citep{Brady2010a}, or with 72 | Typestate~\citep{Aldrich2009,Strom1986}. In these approaches, however, 73 | it is difficult to compose systems from multiple resources or to implement a 74 | resource in terms of other resources. In \states{}, we can combine resources 75 | by using additional interfaces, and implement those interfaces in terms of 76 | other lower level resources. 77 | 78 | \emph{\textsf{Types for Communication:}} 79 | % 80 | A strong motivation for the work in the present paper is to be able to 81 | incorporate a form of Session Types~\citep{Honda93,Honda08} into dependently 82 | typed applications, while also supporting other stateful components. 83 | Session Types describe the state of a communication channel, 84 | and recent work has shown the correspondence between propositions and 85 | sessions~\citep{propositions-sessions} and how to implement this in a 86 | programming language~\citep{Lindley2015}. 87 | More recently,~\citet{Toninho2016} have shown how to increase the 88 | expressivity of multi-party session to capture invariants on data. 89 | We expect 90 | to be able to encode similar properties in \states{} and in doing so, be 91 | able to encode security properties of communicating systems with 92 | dependent types, following~\citep{Guenot2015}. 93 | Type systems in modern programming languages, such as Rust~\citep{session-rust} 94 | and Haskell~\citep{session-haskell}, are strong enough to support Session 95 | Types, and by describing communication protocols in types, we expect to be able 96 | to use the type system to verify correctness of implementations of security 97 | protocols~\citep{gordon2003authenticity,sewell-tls}. 98 | 99 | 100 | %Also Dijkstra Monads~\cite{Ahman2017} 101 | 102 | \emph{\textsf{Effects and Modules:}} 103 | % 104 | Algebraic effects~\citep{Plotkin2009,Bauer} are increasingly being proposed as 105 | an alternative to monad transformers for structuring Haskell 106 | applications~\citep{KiselyovEffects,handlers2013}. 107 | Earlier work in Idris~\cite{brady-eff2013,brady-tfp14} has used a system 108 | based on algebraic effects to track resource state, like \states{} in 109 | this paper. 110 | Koka~\cite{Leijen2017} uses row polymorphism to describe the allowed effects 111 | of a function, which is similar to the \texttt{Context} of an \states{} 112 | program in that a function's type lists only the parts of the overall state it 113 | needs. 114 | 115 | In \states{}, rather than using effects and handlers, we use 116 | \emph{interfaces} to constrain the operations on a resource, and provide 117 | \emph{implementations} of those interfaces. This does not have the full 118 | power of handlers of algebraic effects---in particular, we cannot reorder 119 | handlers to implement exception handling or other control flow---but it 120 | does allow us to express the state transitions precisely. Indeed, we do not 121 | want handlers to be \emph{too} flexible: for example, a handler which 122 | implements non-determinism by executing an operation several times would 123 | violate linear access to a resource. 124 | % 125 | Interfaces in Idris are similar to Haskell type classes, but with support 126 | for \emph{named} overlapping instances. This means that we can give multiple 127 | different interpretations to an interface in different implementations, and 128 | in this sense they are similar in power to ML modules~\citep{Dreyer2005}. 129 | Interfaces in Idris are first class, meaning that implementations can be 130 | calculated by a function, and thus provide the same power as first-class 131 | modules in 1ML~\citep{rossberg2015}. 132 | 133 | \section{Conclusions and Further Work} 134 | 135 | We have shown how to describe APIs in terms of type-dependent state transition 136 | systems, using a library \states{} and evaluated the library by presenting 137 | several diverse examples which show how \states{} can be used in practice. 138 | In particular, we have shown how to design larger scale systems by composing 139 | state machines both horizontally (that is, using multiple state machines in the 140 | same function definition) and vertically (that is, implementing the behaviour 141 | of a state machine using other lower level state machines). 142 | 143 | A significant strength of this approach to structuring 144 | programs is that state machines are ubiquitous, if implicit, in realistic APIs, 145 | especially when dealing with external resources like surfaces on which to draw 146 | graphics, endpoints in network communication, and databases. The \states{} 147 | library makes these state machines explicit in types, meaning 148 | that we can be sure by type checking that a program correctly follows the state 149 | machine. As the \texttt{Sockets} interface shows, we can give precise types to 150 | an existing API (in this case, the POSIX sockets API), and use the operations 151 | in more or less the same way, with additional confidence in their correctness. 152 | % 153 | Furthermore, as we briefly discussed in Section~\ref{sect:getdata}, and 154 | saw throughout the paper, we can use \emph{interactive}, type-driven, program 155 | development and see the internal state of a program at any point during 156 | development. 157 | 158 | Since \states{} is parameterised by an underlying computation context, which is 159 | most commonly a monad, it is a monad transformer. Also, an instance of 160 | \states{} which preserves states is itself a monad, so \states{} programs can 161 | be combined with monad transformers, and therefore are compatible with a common 162 | existing method of organising large scale functional programs. 163 | 164 | There are several avenues for further work. For example, we have not discussed 165 | the efficiency of our approach in this paper. There is a small overhead due to 166 | the interpreter for \states{} but we expect to be able to eliminate this using 167 | a combination of partial evaluation~\citep{scrap-engine} and a finally tagless 168 | approach to interpretation~\citep{Carette2009}. We may also be able to use 169 | linear types for the underlying implementation~\citep{McBride2016} using an 170 | experimental extension to Idris. 171 | 172 | Most importantly, however, we believe there are several applications to 173 | this approach in defining security protocols, and verified implementation 174 | of distributed systems. For the former, security protocols follow a clearly 175 | defined series of steps and any violation can be disastrous, causing 176 | sensitive data to leak. 177 | % 178 | For the latter, we are currently developing an implementation of Session 179 | Types~\citep{Honda93,Honda08} embedded in Idris, generalising the random 180 | number server presented in Section~\ref{sect:randserver}. 181 | 182 | The \states{} library provides a generic interface for implementing a useful 183 | pattern in dependently typed program in such a way that it is \emph{reusable} 184 | by application developers. State is everywhere, and introduces complexity 185 | throughout applications. Dependently typed purely functional programming gives 186 | us the tools we need to keep this complexity under control. 187 | -------------------------------------------------------------------------------- /Paper/content/examples.tex: -------------------------------------------------------------------------------- 1 | \section{Examples} 2 | 3 | \label{sect:examples} 4 | 5 | %\subsection{Socket Programming, with Exceptions} 6 | 7 | The \texttt{ST} library can be used in any situation which calls for tracking 8 | of the states of resource in types. In this section, we present several 9 | diverse examples which 10 | show how the library allows us to compose stateful systems both 11 | horizontally (that is, using multiple stateful systems at once) and 12 | vertically (that is, implementing one stateful system in terms of one or 13 | more others). 14 | 15 | \subsection{A Graphics Interface} 16 | 17 | Listing \ref{fig:drawiface} shows an interface for a small graphics library 18 | which supports creating a window and drawing into that window. 19 | The \texttt{flip} operation supports double buffering. 20 | We create a state of type \texttt{Surface} using the following function: 21 | 22 | \small 23 | \begin{code} 24 | initWindow : Int -> Int -> ST m (Maybe Var) [addIfJust Surface] 25 | \end{code} 26 | \normalsize 27 | 28 | This uses a type level function \texttt{addIfJust}, provided by the \texttt{ST} 29 | library, which allows us to write concisely in a type that the function will 30 | add a resource when it successfully returns a variable: 31 | 32 | \small 33 | \begin{code} 34 | addIfJust : Type -> Action (Maybe a) 35 | addIfJust ty = Add (maybe [] (\var => [var ::: ty])) 36 | \end{code} 37 | \normalsize 38 | 39 | \small 40 | \begin{code}[float=h, frame=single,caption={The \texttt{Draw} interface which 41 | supports drawing lines in a window},label=fig:drawiface] 42 | interface Draw (m : Type -> Type) where 43 | Surface : Type 44 | 45 | initWindow : Int -> Int -> ST m (Maybe Var) [addIfJust Surface] 46 | closeWindow : (win : Var) -> ST m () [Remove win Surface] 47 | flip : (win : Var) -> ST m () [win ::: Surface] 48 | filledRectangle : (win : Var) -> (Int, Int) -> (Int, Int) -> Col -> 49 | ST m () [win ::: Surface] 50 | drawLine : (win : Var) -> (Int, Int) -> (Int, Int) -> Col -> 51 | ST m () [win ::: Surface] 52 | \end{code} 53 | \normalsize 54 | 55 | We can provide an implementation for this interface using the SDL graphics 56 | library\footnote{\url{https://www.libsdl.org/}}, for example: 57 | 58 | \small 59 | \begin{code} 60 | implementation Draw IO where 61 | Surface = State SDLSurface 62 | ... 63 | \end{code} 64 | \normalsize 65 | 66 | Having defined a primitive interface for graphics operations, we can use it 67 | as a basis for more high level interfaces. For example, we can build a library 68 | for turtle graphics by building a \emph{composite} resource from a 69 | \texttt{Surface} and the state of a turtle (including location, direction and 70 | pen colour). 71 | 72 | \subsection{Turtle Graphics} 73 | 74 | \label{sect:turtle} 75 | 76 | Turtle graphics involves a ``turtle'' manoeuvring around a screen, drawing 77 | lines as it moves. 78 | It has attributes describing its location, direction, and 79 | pen colour. 80 | There are commands for moving the turtle forwards, turning through an angle, 81 | and changing colour. 82 | Listing~\ref{fig:turtleiface} gives one possible interface 83 | using \texttt{ST}. 84 | 85 | \small 86 | \begin{code}[float=h, frame=single,caption={An interface for turtle graphics, 87 | supporting creating a turtle, drawing lines, and rendering the result}, 88 | label=fig:turtleiface] 89 | interface TurtleGraphics (m : Type -> Type) where 90 | Turtle : Type 91 | 92 | start : Int -> Int -> ST m (Maybe Var) [addIfJust Turtle] 93 | end : (t : Var) -> ST m () [Remove t Turtle] 94 | fd : (t : Var) -> Int -> ST m () [t ::: Turtle] 95 | rt : (t : Var) -> Int -> ST m () [t ::: Turtle] 96 | col : (t : Var) -> Col -> ST m () [t ::: Turtle] 97 | render : (t : Var) -> ST m () [t ::: Turtle] 98 | \end{code} 99 | \normalsize 100 | 101 | The \texttt{start} function initialises the system with window dimensions. 102 | Then, the state of the 103 | turtle can be updated by issuing commands. Finally, the \texttt{render} 104 | function displays the picture drawn so far in a window. The following 105 | function, for example, initialises a turtle and, if successful, draws a 106 | coloured square: 107 | 108 | \small 109 | \begin{code} 110 | square : (ConsoleIO m, TurtleGraphics m) => ST m () [] 111 | square = do Just t <- start 640 480 | Nothing => putStr "Can't make turtle\n" 112 | col t yellow; fd t 100; rt t 90; col t green; fd t 100; rt t 90 113 | col t red; fd t 100; rt t 90; col t blue; fd t 100; rt t 90 114 | render t; end t 115 | \end{code} 116 | \normalsize 117 | 118 | We can implement the interface using \texttt{Draw}, and render using 119 | a \texttt{Surface} but we need additional state to represent the current 120 | state of the turtle, and to record what we need to draw when \texttt{render} 121 | is called. We can achieve this using a composite resource: 122 | 123 | \small 124 | \begin{code} 125 | implementation Draw m => TurtleGraphics m where 126 | Turtle = Composite [Surface {m}, State Col, State (Int, Int, Int), 127 | State (List Line)] 128 | ... 129 | \end{code} 130 | \normalsize 131 | 132 | The components are: the \texttt{Surface} to draw on; the current pen colour, 133 | the current turtle location and direction, and a list 134 | of lines to draw. When we initialise the system, we create each component 135 | of the composite resource then \texttt{combine} them: 136 | 137 | \small 138 | \begin{code} 139 | start x y = do Just srf <- initWindow x y | Nothing => pure Nothing 140 | col <- new white; pos <- new (320, 200, 0) 141 | lines <- new []; turtle <- new () 142 | combine turtle [srf, col, pos, lines] 143 | pure (Just turtle) 144 | \end{code} 145 | \normalsize 146 | 147 | In each operation, to access an individual element of the composite resource, 148 | we need to \texttt{split} the resource, then \texttt{combine} the components 149 | when done. For example, to turn right: 150 | 151 | \small 152 | \begin{code} 153 | rt t angle = do [srf, col, pos, lines] <- split t 154 | (x, y, d) <- read pos 155 | write pos (x, y, d + angle `mod` 360) 156 | combine t [srf, col, pos, lines] 157 | \end{code} 158 | \normalsize 159 | 160 | In this way, we can implement a larger system as a \emph{hieararchy} of 161 | smaller systems. The \texttt{Turtle}, as far as the programmer who writes 162 | \texttt{square} is concerned, is an individual system, but internally there 163 | are state machines all the way down to the concrete implementations of 164 | \texttt{Draw} and \texttt{State}. 165 | 166 | \subsection{Socket Programming, with Error Handling} 167 | 168 | \begin{tabular}{ll} 169 | \begin{minipage}{9cm} 170 | The POSIX sockets API supports communication between processes across 171 | a network. A \emph{socket} represents an endpoint of a network communication, 172 | and can be in one of several states: \texttt{Ready}, the initial state; 173 | \texttt{Bound}, meaning that it has been bound to an address ready for incoming 174 | connections; \texttt{Listening}, meaning that it is listening for incoming 175 | connections; \texttt{Open}, meaning that it is ready for sending and 176 | receiving data; and \texttt{Closed} meaning that it is no longer active. 177 | The diagram on the right shows how the operations provided by the API 178 | modify the state, where \texttt{Ready} is the initial state. 179 | \end{minipage} 180 | & 181 | \begin{minipage}{6.5cm} 182 | \includegraphics[width=6.5cm]{diagrams/netstate.pdf} 183 | \end{minipage} 184 | \end{tabular} 185 | 186 | \small 187 | \begin{code}[float=h, frame=single,caption={The POSIX sockets API, written 188 | as in interface for \texttt{ST} describing how each operation affects 189 | socket state}, 190 | label=fig:socketsiface] 191 | data SocketState = Ready | Bound | Listening | Open | Closed 192 | 193 | interface Sockets (m : Type -> Type) where 194 | Sock : SocketState -> Type 195 | 196 | socket : SocketType -> ST m (Either () Var) [addIfRight (Sock Ready)] 197 | bind : (sock : Var) -> (addr : Maybe SocketAddress) -> (port : Port) -> 198 | ST m (Either () ()) [sock ::: Sock Ready :-> (Sock Closed `or` Sock Bound)] 199 | listen : (sock : Var) -> 200 | ST m (Either () ()) [sock ::: Sock Bound :-> (Sock Closed `or` Sock Listening)] 201 | accept : (sock : Var) -> 202 | ST m (Either () Var) [addIfRight (Sock Open), sock ::: Sock Listening] 203 | connect : (sock : Var) -> SocketAddress -> Port -> 204 | ST m (Either () ()) [sock ::: Sock Ready :-> (Sock Closed `or` Sock Open)] 205 | close : (sock : Var) -> {auto prf : CloseOK st} -> 206 | ST m () [sock ::: Sock st :-> Sock Closed] 207 | remove : (sock : Var) -> ST m () [Remove sock (Sock Closed)] 208 | send : (sock : Var) -> String -> 209 | ST m (Either () ()) [sock ::: Sock Open :-> (Sock Closed `or` Sock Open)] 210 | recv : (sock : Var) -> 211 | ST m (Either () String) [sock ::: Sock Open :-> (Sock Closed `or` Sock Open)] 212 | \end{code} 213 | \normalsize 214 | 215 | Listing~\ref{fig:socketsiface} shows how these operations can be given precise 216 | types which describe how the operations affect socket state, using \texttt{ST}. 217 | By convention, each operation returns something with a type of the form 218 | \texttt{Either a b}, representing the possibility of failure. 219 | The \texttt{ST} library provides two helper functions 220 | which allow us to write concise types for these operations: 221 | 222 | \small 223 | \begin{code} 224 | addIfRight : Type -> Action (Either a b) 225 | addIfRight ty = Add (either (const []) (\var => [var ::: ty])) 226 | 227 | or : a -> a -> Either b c -> a 228 | or x y = either (const x) (const y) 229 | \end{code} 230 | \normalsize 231 | 232 | Note, in particular, that \texttt{accept} explicitly creates a new 233 | \texttt{Open} socket specifically for processing an incoming connection, 234 | keeping the existing socket in a \texttt{Listening} state. This could allow, 235 | for example, processing an incoming connection in a different thread: 236 | 237 | \small 238 | \begin{code} 239 | accept : (sock : Var) -> 240 | ST m (Either () Var) [addIfRight (Sock Open), sock ::: Sock Listening] 241 | \end{code} 242 | \normalsize 243 | 244 | We could use \texttt{Sockets} to write an ``echo'' server which repeatedly 245 | accepts an incoming connection from a client, and echoes a message back to the 246 | client. We can define a function \texttt{echoServer} which accepts connections 247 | on a \texttt{Listening} socket, and logs messages to the console: 248 | 249 | \small 250 | \begin{code} 251 | echoServer : (ConsoleIO m, Sockets m) => (sock : Var) -> 252 | ST m () [Remove sock (Sock {m} Listening)] 253 | \end{code} 254 | \normalsize 255 | 256 | Then, before we start up \texttt{echoServer}, we need to create a socket, bind 257 | it to a port, then begin listening for incoming connections. Each of these 258 | operations could fail, so we include pattern matching alternatives to clean 259 | up the resources if necessary: 260 | 261 | \small 262 | \begin{code} 263 | startServer : (ConsoleIO io, Sockets io) => ST io () [] 264 | startServer = do Right sock <- socket Stream | Left err => pure () 265 | Right ok <- bind sock Nothing 9442 | Left err => remove sock 266 | Right ok <- listen sock | Left err => remove sock 267 | echoServer sock 268 | \end{code} 269 | \normalsize 270 | 271 | We can begin writing \texttt{echoServer} as follows, accepting a connection 272 | or cleaning up the resources and returning if \texttt{accept} fails: 273 | 274 | \small 275 | \begin{code} 276 | echoServer sock = 277 | do Right new <- accept sock | Left err => do close sock; remove sock 278 | ?rest 279 | \end{code} 280 | \normalsize 281 | 282 | Checking the type of \texttt{?rest} here shows us that we have a 283 | \texttt{new} socket, which is \texttt{Open} and therefore ready to communicate 284 | with the client, as well as \texttt{sock} which remains listening for new 285 | connections: 286 | 287 | \small 288 | \begin{code} 289 | rest : STrans m () [new ::: Sock Open, sock ::: Sock Listening] 290 | (\result1 => []) 291 | \end{code} 292 | \normalsize 293 | 294 | \subsection{Asynchronous Programming with Threads} 295 | 296 | \label{sect:async} 297 | 298 | In \texttt{ST}, resources are linear, in that there is exactly one reference 299 | to each, and once a resource has been overwritten the old value is no longer 300 | available. So, if we spawn a thread, we need to consider how to preserve 301 | linearity, and maintain only one reference to each resource. 302 | Listing~\ref{fig:asynciface} shows one way to do this, where the 303 | \texttt{fork} function takes a thread described in \texttt{STrans}, and 304 | a proof that the forked thread uses a subcontext of the parent thread. 305 | Then, the parent thread keeps only the resources which are not used by 306 | the child thread. 307 | 308 | \small 309 | \begin{code}[float=h, frame=single,caption={An interface supporting 310 | asynchronous programming, dividing resources between a child 311 | and a parent thread}, 312 | label=fig:asynciface] 313 | interface Conc (m : Type -> Type) where 314 | fork : (thread : STrans m () thread_res (const [])) -> 315 | {auto tprf : SubCtxt thread_res all} -> 316 | STrans m () all (const (kept tprf)) 317 | \end{code} 318 | \normalsize 319 | 320 | An implementation of \texttt{Conc} then needs to divide the resources 321 | appropriately. We can achieve this with \texttt{dropSubCtxt} (to remove 322 | the subcontext from the current thread, returning the environment) and 323 | \texttt{runWith} (to pass that environment to the spawned thread): 324 | 325 | \small 326 | \begin{code} 327 | implementation Conc IO where 328 | fork thread = do threadEnv <- dropSubCtxt 329 | lift (spawn (do runWith threadEnv thread 330 | pure ())) 331 | pure () 332 | 333 | \end{code} 334 | \normalsize 335 | 336 | The Idris library defines \texttt{spawn} to create a new thread. It 337 | returns a process identifier, to allow communication between threads, but 338 | we leave communication between threads for future work. 339 | 340 | \subsection{Managing Sessions: A Random Number Server} 341 | 342 | \label{sect:randserver} 343 | 344 | In the turtle graphics example, we implemented a high level 345 | graphics API in terms of lower level drawing operations. Similarly, we can 346 | implement a high level network application protocol in terms of sockets. 347 | Listing~\ref{fig:randiface} shows an interface for a server which replies 348 | to requests from a client for a random number within a bound. 349 | 350 | \small 351 | \begin{code}[float=h, frame=single,caption={An interface for a server which 352 | returns random numbers within a given bound}, 353 | label=fig:randiface] 354 | data SessionState = Waiting | Processing | Done 355 | 356 | interface RandomSession (m : Type -> Type) where 357 | Connection : SessionState -> Type 358 | Server : Type 359 | 360 | recvReq : (conn : Var) -> 361 | ST m (Maybe Integer) [conn ::: Connection Waiting :-> 362 | \res => Connection (case res of 363 | Nothing => Done 364 | Just _ => Processing)] 365 | sendResp : (conn : Var) -> Integer -> 366 | ST m () [conn ::: Connection Processing :-> Connection Done] 367 | start : ST m (Maybe Var) [addIfJust Server] 368 | quit : (srv : Var) -> ST m () [Remove srv Server] 369 | done : (conn : Var) -> ST m () [Remove conn (Connection Done)] 370 | accept : (srv : Var) -> 371 | ST m (Maybe Var) [srv ::: Server, addIfJust (Connection Waiting)] 372 | \end{code} 373 | \normalsize 374 | 375 | The interface defines two types: 376 | 377 | \begin{itemize} 378 | \item \texttt{Connection}, which is the current state of a session with 379 | a client. A session is either \texttt{Waiting} for the client to send 380 | a request, \texttt{Processing} the request from the client, or \texttt{Done} 381 | and ready to close. 382 | \item \texttt{Server}, which is the type of a server which processes 383 | incoming client requests. 384 | \end{itemize} 385 | 386 | Overall, a server listens for an incoming request from a client, 387 | and when it receives a request, it initialises a session with the client 388 | and continues waiting for further incoming requests. In a session, we can 389 | call one of: 390 | 391 | \begin{itemize} 392 | \item \texttt{recvReq}, which, if we're in the \texttt{Waiting} state, 393 | receives a request from a client, and if it is valid moves into the 394 | \texttt{Processing} state. 395 | \item \texttt{sendResp}, which, if we're in the \texttt{Processing} state, 396 | sends a random number within the given bound. Note that \texttt{sendResp} 397 | itself is intended to do the work of generating the random number. 398 | \item \texttt{done}, which closes the session and removes the \texttt{Connection} 399 | state. 400 | \end{itemize} 401 | 402 | To implement a random number server, we'll use this interface, as well 403 | as \texttt{ConsoleIO} for console logging, and \texttt{Conc} to process 404 | requests asynchronously. To avoid repetition in every function signature, 405 | Idris provides a notation to allow us to state that every function in a 406 | block is constrained by the same interfaces: 407 | 408 | \small 409 | \begin{code} 410 | using (ConsoleIO m, RandomSession m, Conc m) 411 | \end{code} 412 | \normalsize 413 | 414 | We implement a session with \texttt{rndSession} which, given a 415 | \texttt{Connection} in the \texttt{Waiting} state will process a client 416 | request and eventually delete the connection, using \texttt{recvReq}, 417 | \texttt{sendResp} and \texttt{done}: 418 | 419 | \small 420 | \begin{code} 421 | rndSession : (conn : Var) -> ST m () [Remove conn (Connection {m} Waiting)] 422 | \end{code} 423 | \normalsize 424 | 425 | The main loop of the server calls \texttt{accept} to receive an incoming 426 | connection. If it fails, it reports an error. Otherwise, it uses 427 | \texttt{fork} to process the incoming connection in a separate thread. 428 | The resources are divided between \texttt{rndSession} (whose type states that 429 | it receives the \texttt{Connection} variable \texttt{conn}) and the parent thread, which 430 | retains the \texttt{Server} variable \texttt{srv}: 431 | 432 | \small 433 | \begin{code} 434 | rndLoop : (srv : Var) -> ST m () [srv ::: Server {m}] 435 | rndLoop srv = do Just conn <- accept srv | Nothing => putStr "accept failed\n" 436 | putStr "Connection received\n" 437 | fork (rndSession conn) 438 | rndLoop srv 439 | 440 | rndServer : ST m () [] 441 | rndServer = do Just srv <- start | Nothing => putStr "Can't start server\n" 442 | rndLoop srv; quit srv 443 | \end{code} 444 | \normalsize 445 | 446 | Finally, we can implement the interface using composite resources for both 447 | the \texttt{Connection} and the \texttt{Server}. Each one carries an 448 | \texttt{Integer} seed for the random number generator, and a socket for 449 | receiving incoming connections. In the case of \texttt{Connection}, the socket 450 | will be in a different state depending on the current state of the session. In 451 | particular, once the session is \texttt{Done}, the socket will need to be 452 | \texttt{Closed}. 453 | 454 | \small 455 | \begin{code} 456 | implementation (ConsoleIO m, Sockets m) => RandomSession m where 457 | Connection Waiting = Composite [State Integer, Sock {m} Open] 458 | Connection Processing = Composite [State Integer, Sock {m} Open] 459 | Connection Done = Composite [State Integer, Sock {m} Closed] 460 | Server = Composite [State Integer, Sock {m} Listening] 461 | ... 462 | \end{code} 463 | \normalsize 464 | 465 | % The complete code for this and the previous examples is available as 466 | % supplementary material, and will be made available online. 467 | -------------------------------------------------------------------------------- /Paper/content/implement.tex: -------------------------------------------------------------------------------- 1 | \section{Implementation} 2 | 3 | \label{sect:implementst} 4 | 5 | As we have seen, \texttt{STrans} allows us to write programs which 6 | describe sequences of state transitions, creating and destroying resources 7 | as necessary. In this section, we will describe some implementation details 8 | of \texttt{STrans}. In particular, we will describe how a \texttt{Context} 9 | corresponds to an environment containing concrete values at run time, and 10 | see the concrete definition of \texttt{STrans} itself. We will show 11 | the mechanism for calling subprograms with smaller sets of resources, and 12 | show how to build \emph{composite} resources, consisting of a list of 13 | independent resources. Finally, we will briefly describe how Idris' error 14 | reflection mechanism~\citep{christiansen-thesis} lets us rewrite type error 15 | messages to describe errors in terms of the problem domain, rather than in 16 | terms of the implementation language. 17 | 18 | \subsection{Environments and Execution} 19 | 20 | The indices of \texttt{STrans} describe how a sequence of operations affects 21 | the types of elements in a context. Correspondingly, when we \texttt{run} 22 | an \texttt{STrans} program, we need to keep track of the \emph{values} 23 | of those elements in an environment, defined as follows: 24 | 25 | \small 26 | \begin{code} 27 | data Env : Context -> Type where 28 | Nil : Env [] 29 | (::) : ty -> Env xs -> Env ((lbl ::: ty) :: xs) 30 | \end{code} 31 | \normalsize 32 | 33 | Then, when running a program, we provide an \emph{input} environment, 34 | and a continuation which explains how to process the result of the program 35 | and the output environment, whose type is calculated from the result: 36 | 37 | \small 38 | \begin{code} 39 | runST : Env invars -> STrans m a invars outfn -> 40 | ((x : a) -> Env (outfn x) -> m b) -> m b 41 | \end{code} 42 | \normalsize 43 | 44 | At the top level, we can \texttt{run} a program with no resources on 45 | input and output: 46 | 47 | \small 48 | \begin{code} 49 | run : Applicative m => ST m a [] -> m a 50 | run prog = runST [] prog (\res, _ => pure res) 51 | \end{code} 52 | \normalsize 53 | 54 | The \texttt{Applicative} constraint on \texttt{run} is required so that 55 | we can inject the result of the computation into the underlying computation 56 | context \texttt{m}. In the special case that \texttt{m} is the identity 57 | function, we can return the result directly instead: 58 | 59 | \small 60 | \begin{code} 61 | runPure : ST id a [] -> a 62 | runPure prog = runST [] prog (\res, _ => res) 63 | \end{code} 64 | \normalsize 65 | 66 | % Specifically IO because we only want to allow this in concrete settings. 67 | % Idea of Env is that only 'run' can access it but this escape is handy 68 | % for 'fork'. 69 | 70 | Finally, in some cases we might want to execute an \texttt{STrans} program 71 | with an initial environment and read the resulting environment, which we can 72 | achieve using \texttt{runWith} provided that we are executing the program in 73 | the \texttt{IO} monad. 74 | 75 | \small 76 | \begin{code} 77 | runWith : Env ctxt -> STrans IO a ctxt (\res => ctxtf res) -> 78 | IO (res ** Env (ctxtf res)) 79 | runWith env prog = runST env prog (\res, env' => pure (res ** env')) 80 | \end{code} 81 | \normalsize 82 | 83 | It is important to restrict this to a specific monad, rather than allowing 84 | \texttt{runWith} to be parameterised over any monad \texttt{m} like 85 | \texttt{run}. 86 | The reason is that the intention of \texttt{STrans} is to control all accesses 87 | to state via \texttt{read} and \texttt{write}, but \texttt{runWith} gives 88 | us a convenient ``escape hatch'' if we need more flexibility to modify the 89 | environment in a concrete 90 | \texttt{IO} setting. We will need this when implementing asynchronous 91 | programs in Section~\ref{sect:async}. By restricting \texttt{runWith} to work 92 | in a \emph{concrete} monad, we know that it is at least impossible to use it 93 | in programs which are written in a generic context. For example, we saw 94 | \texttt{writeToFile} earlier: 95 | 96 | \small 97 | \begin{code} 98 | writeToFile : (FileIO m, DataStore m) => (h : Var) -> (st : Var) -> 99 | ST m () [h ::: File {m} Write, st ::: Store {m} LoggedIn] 100 | \end{code} 101 | \normalsize 102 | 103 | We know that it is impossible for \texttt{writeToFile} to call 104 | \texttt{runWith}, and possibly introduce new items into the environment, 105 | because it is parameterised over some monad \texttt{m}. 106 | 107 | \subsection{Defining \texttt{STrans}} 108 | 109 | \texttt{STrans} itself is defined as an algebraic data type, describing 110 | operations for reading, writing, creating and destroying resources, 111 | and sequencing stateful operations. Additionally, there are operations for 112 | manipulating the context in some more advanced ways. The complete definition 113 | is shown in Listing~\ref{fig:stransdef}. 114 | 115 | \small 116 | \begin{code}[float=h, frame=single,caption={The complete definition of 117 | \texttt{STrans} as an Idris data type},label=fig:stransdef] 118 | data STrans : (m : Type -> Type) -> (ty : Type) -> 119 | Context -> (ty -> Context) -> Type where 120 | Pure : (result : ty) -> STrans m ty (out_fn result) out_fn 121 | Bind : STrans m a st1 st2_fn -> 122 | ((result : a) -> STrans m b (st2_fn result) st3_fn) -> 123 | STrans m b st1 st3_fn 124 | Lift : Monad m => m t -> STrans m t ctxt (const ctxt) 125 | New : (val : state) -> 126 | STrans m Var ctxt (\lbl => (lbl ::: State state) :: ctxt) 127 | Delete : (lbl : Var) -> (prf : InState lbl (State st) ctxt) -> 128 | STrans m () ctxt (const (drop ctxt prf)) 129 | DropSubCtxt : (prf : SubCtxt ys xs) -> STrans m (Env ys) xs (const (kept prf)) 130 | Split : (lbl : Var) -> (prf : InState lbl (Composite vars) ctxt) -> 131 | STrans m (VarList vars) ctxt 132 | (\vs => mkCtxt vs ++ updateCtxt ctxt prf (State ())) 133 | Combine : (comp : Var) -> (vs : List Var) -> 134 | (prf : VarsIn (comp :: vs) ctxt) -> 135 | STrans m () ctxt (const (combineVarsIn ctxt prf)) 136 | Call : STrans m t ys ys' -> (ctxt_prf : SubCtxt ys xs) -> 137 | STrans m t xs (\res => updateWith (ys' res) xs ctxt_prf) 138 | Read : (lbl : Var) -> (prf : InState lbl (State ty) ctxt) -> 139 | STrans m ty ctxt (const ctxt) 140 | Write : (lbl : Var) -> (prf : InState lbl ty ctxt) -> (val : ty') -> 141 | STrans m () ctxt (const (updateCtxt ctxt prf (State ty'))) 142 | \end{code} 143 | \normalsize 144 | 145 | The operations we have described so far, in Section~\ref{sect:statemachines}, 146 | are implemented by using the corresponding constructor of \texttt{STrans}. 147 | The main difference is that proof terms (such as the \texttt{prf} arguments 148 | of \texttt{Delete} and \texttt{Read}) are explicit, rather than marked 149 | as implicit with \texttt{auto}. 150 | % 151 | There are four constructors we have not yet encountered. These are 152 | \texttt{Lift}, \texttt{DropSubCtxt}, \texttt{Split} and \texttt{Combine}: 153 | 154 | \begin{itemize} 155 | \item \texttt{Lift} allows us to use operations in the underlying monad 156 | \texttt{m}. We will need this to implement interfaces in terms of existing 157 | monads. 158 | \item \texttt{DropSubCtxt} allows us to remove a subset of resources, and 159 | returns their values as an environment. The output context is calculated using 160 | a function \texttt{kept}, which returns the resources which are not part of the 161 | subset. We will use this to share resources between multiple threads in 162 | Section~\ref{sect:async}. 163 | \item \texttt{Split} and \texttt{Combine} allow us to work with 164 | \emph{composite} resources. We will discuss these shortly in 165 | Section~\ref{sect:splitcomb}, and we will need them to be able to implement one 166 | stateful interface in terms of a collection of others. For example, in 167 | Section~\ref{sect:turtle}, we will implement a small high level graphics API 168 | in terms of resources describing a low level graphics context, and some 169 | internal state. 170 | \end{itemize} 171 | 172 | The implementation of \texttt{runST} is by pattern matching on \texttt{STrans}, 173 | and largely uses well known implementation techniques for well-typed interpreters 174 | with dependent types~\citep{Pasalic2002,augustsson1999exercise}. Most of 175 | the implementation is about managing the environment, particularly 176 | when interpreting \texttt{Call}, \texttt{Split} and \texttt{Combine}, which 177 | involve restructuring the environment according to the proofs. 178 | % 179 | When we interpret \texttt{New}, we need to provide a new \texttt{Var}. 180 | The \texttt{Var} type is defined as follows, and perhaps surprisingly has only 181 | one value: 182 | 183 | \small 184 | \begin{code} 185 | data Var = MkVar 186 | \end{code} 187 | \normalsize 188 | 189 | We do not need any more than this because internally all references 190 | to variables are managed using proofs of context membership, such as 191 | \texttt{InState} and \texttt{SubCtxt}. The variable of type \texttt{Var} 192 | gives a human readable name, and a way of disambiguating resources by Idris 193 | variable names, but by the time we execute a program with \texttt{runST}, these 194 | variables have been resolved into proofs of context membership so we do 195 | not need to construct any unambiguous concrete values. 196 | 197 | \subsection{Calling subprograms} 198 | 199 | \label{sect:callimpl} 200 | 201 | We often need to call subprograms with a \emph{smaller} set of resources 202 | than the caller, as we saw in Section~\ref{sect:multiplests}. 203 | To do this, we provide a proof that the input resources required by the 204 | subprogram (\texttt{sub}) are a subset of the current input resources 205 | (\texttt{old}): 206 | 207 | \small 208 | \begin{code} 209 | Call : STrans m t sub new_f -> (ctxt_prf : SubCtxt sub old) -> 210 | STrans m t old (\res => updateWith (new_f res) old ctxt_prf) 211 | \end{code} 212 | \normalsize 213 | 214 | A value of type \texttt{SubCtxt sub old} is a proof that every element 215 | in \texttt{sub} appears exactly once in \texttt{old}. In other words, it is 216 | a proof that the resources in \texttt{sub} are a subset of those in \texttt{old}. 217 | To show this, we need to be able to show that a specific \texttt{Resource} is 218 | an element of a \texttt{Context}: 219 | 220 | \small 221 | \begin{code} 222 | data ElemCtxt : Resource -> Context -> Type where 223 | HereCtxt : ElemCtxt a (a :: as) 224 | ThereCtxt : ElemCtxt a as -> ElemCtxt a (b :: as) 225 | \end{code} 226 | \normalsize 227 | 228 | Then, a proof of \texttt{SubCtxt sub old} 229 | essentially states, for each entry in \texttt{old}, 230 | either where it appears in \texttt{sub} (using \texttt{InCtxt} and a 231 | proof of its location using \texttt{ElemCtxt}) or that it is not present in 232 | \texttt{sub} (using \texttt{Skip}): 233 | 234 | \small 235 | \begin{code} 236 | data SubCtxt : Context -> Context -> Type where 237 | SubNil : SubCtxt [] [] 238 | InCtxt : (el : ElemCtxt x ys) -> SubCtxt xs (dropEl ys el) -> 239 | SubCtxt (x :: xs) ys 240 | Skip : SubCtxt xs ys -> SubCtxt xs (y :: ys) 241 | \end{code} 242 | \normalsize 243 | 244 | A context is a subcontext of itself, so we can say that \texttt{[]} is 245 | a subcontext of \texttt{[]}. 246 | To ensure that there is no repetition in the sub-context, the recursive 247 | argument to \texttt{InCtxt} explicitly states that the resource cannot 248 | appear in the remaining sub-context, using \texttt{dropEl}: 249 | 250 | \small 251 | \begin{code} 252 | dropEl : (ys: _) -> ElemCtxt x ys -> Context 253 | dropEl (x :: as) HereCtxt = as 254 | dropEl (x :: as) (ThereCtxt p) = x :: dropEl as p 255 | \end{code} 256 | \normalsize 257 | 258 | The type of \texttt{Call} relies on the following function, which 259 | calculates a new context for the calling function, based on the updates 260 | made by the subprogram: 261 | 262 | \small 263 | \begin{code} 264 | updateWith : (new : Context) -> (old : Context) -> SubCtxt sub old -> Context 265 | \end{code} 266 | \normalsize 267 | 268 | The result of \texttt{updateWith} is the contents of \texttt{new}, adding 269 | those values in \texttt{old} which were previously \texttt{Skip}ped as 270 | described by the proof of \texttt{SubCtxt sub old}. 271 | Correspondingly, there is a function used by \texttt{runST} which rebuilds 272 | an environment after evaluating the \texttt{Call}ed subprogram: 273 | 274 | \small 275 | \begin{code} 276 | rebuildEnv : Env new -> Env old -> (prf : SubCtxt sub old) -> 277 | Env (updateWith new old prf) 278 | \end{code} 279 | \normalsize 280 | 281 | When we use \texttt{Call}, the contexts described by 282 | \texttt{SubCtxt} are known at compile time, from the type of the subprogram 283 | and the state of the \texttt{Context} at the call site. Idris' 284 | built in proof search, which searches constructors up to a 285 | depth limit until it finds an application which type checks, is strong enough 286 | to find these proofs without programmer intervention, so in the top level 287 | \texttt{call} function we mark the proof argument as \texttt{auto}: 288 | 289 | \small 290 | \begin{code} 291 | call : STrans m t sub new_f -> {auto ctxt_prf : SubCtxt sub old} -> 292 | STrans m t old (\res => updateWith (new_f res) old ctxt_prf) 293 | \end{code} 294 | \normalsize 295 | 296 | \subsection{Composite Resources} 297 | 298 | \label{sect:splitcomb} 299 | 300 | A \emph{composite} resource is built from a list of other resources, and 301 | is essentially defined as a heterogeneous list: 302 | 303 | \small 304 | \begin{code} 305 | data Composite : List Type -> Type 306 | \end{code} 307 | \normalsize 308 | 309 | If we have a composite resource, we can split it into its 310 | constituent resources, and create new variables for each of those resources, 311 | using the following top level function which is defined using \texttt{Split}, 312 | again using proof search to find the label in the context: 313 | 314 | \small 315 | \begin{code} 316 | split : (lbl : Var) -> {auto prf : InState lbl (Composite vars) ctxt} -> 317 | STrans m (VarList vars) ctxt 318 | (\vs => mkCtxt vs ++ updateCtxt ctxt prf (State ())) 319 | \end{code} 320 | \normalsize 321 | 322 | A \texttt{VarList} is a list of variable names, one for each resource 323 | in the composite resource. We use \texttt{mkCtxt} to convert it into 324 | a fragment of a context where the composite resource has been split into 325 | independent resources: 326 | 327 | \small 328 | \begin{code} 329 | VarList : List Type -> Type 330 | mkCtxt : VarList tys -> Context 331 | \end{code} 332 | \normalsize 333 | 334 | After splitting the composite resource, the original resource is replaced with 335 | unit \texttt{()}. We can see the effect of this in the following code fragment, 336 | in a function which is intended to swap two integers in a composite resource: 337 | 338 | \small 339 | \begin{code} 340 | swap : (comp : Var) -> ST m () [comp ::: Composite [State Int, State Int]] 341 | swap comp = do [val1, val2] <- split comp 342 | ?rest 343 | \end{code} 344 | \normalsize 345 | 346 | If we check the type of the hole \texttt{?rest}, we see that \texttt{val1} 347 | and \texttt{val2} are now individual resources: 348 | 349 | \small 350 | \begin{code} 351 | rest : STrans m () [val1 ::: State Int, val2 ::: State Int, comp ::: State ()] 352 | (const [comp ::: Composite [State Int, State Int]]) 353 | \end{code} 354 | \normalsize 355 | 356 | The type of \texttt{?rest} shows that, on exit, we need a composite resource 357 | again. We can build a composite resource from individual resources using 358 | \texttt{combine}, implemented in terms of the corresponding \texttt{STrans} 359 | constructor: 360 | 361 | \small 362 | \begin{code} 363 | combine : (comp : Var) -> (vs : List Var) -> 364 | {auto prf : InState comp} -> {auto var_prf : VarsIn (comp :: vs) ctxt} -> 365 | STrans m () ctxt (const (combineVarsIn ctxt var_prf)) 366 | \end{code} 367 | \normalsize 368 | 369 | Similar to \texttt{SubCtxt}, \texttt{VarsIn} is a proof that every variable 370 | in a list appears once in a context. Then, \texttt{combineVarsIn} replaces 371 | those variables with a single \texttt{Composite} resource. Correspondingly, 372 | in the implementation of \texttt{runST}, \texttt{rebuildVarsIn} updates the 373 | environment: 374 | 375 | \small 376 | \begin{code} 377 | rebuildVarsIn : Env ctxt -> (prf : VarsIn (comp :: vs) ctxt) -> 378 | Env (combineVarsIn ctxt prf) 379 | \end{code} 380 | \normalsize 381 | 382 | Using \texttt{combine}, we can reconstruct the context in \texttt{swap} with 383 | the resources swapped: 384 | 385 | \small 386 | \begin{code} 387 | swap : (comp : Var) -> ST m () [comp ::: Composite [State Int, State Int]] 388 | swap comp = do [val1, val2] <- split comp 389 | combine comp [val2, val1] 390 | \end{code} 391 | \normalsize 392 | 393 | \subsection{Improving Error Messages with Error Reflection} 394 | 395 | \label{sect:errorreflection} 396 | 397 | Helpful error messages make an important contribution to the usability of any 398 | system. We have used Idris' error message reflection~\citep{christiansen-thesis} 399 | to rewrite the errors produced by Idris to explain the relevant part of 400 | specific errors, namely, the preconditions and postconditions on operations. 401 | Consider the following incorrect code fragment, using the data store defined 402 | in Section~\ref{sect:strans} but attempting to read without first logging in: 403 | 404 | \small 405 | \begin{code} 406 | badGet : DataStore m => ST m () [] 407 | badGet = do st <- connect 408 | secret <- readSecret st 409 | ?more 410 | \end{code} 411 | \normalsize 412 | 413 | By default, Idris reports the following as part of the error message: 414 | 415 | \small 416 | \begin{code} 417 | When checking an application of function Control.ST.>>=: 418 | Type mismatch between 419 | STrans m String [st ::: Store LoggedIn] 420 | (\result => 421 | [st ::: Store LoggedIn]) (Type of readSecret st) 422 | and STrans m String [st ::: Store LoggedOut] 423 | (\result => [st ::: Store LoggedIn]) (Expected type) 424 | \end{code} 425 | \normalsize 426 | 427 | This includes the relevant information, that the store needs to be 428 | \texttt{LoggedIn} but in fact is \texttt{LoggedOut}, but the important parts 429 | are hidden inside a larger term. However, recognising that errors arising 430 | from running an operation when the preconditions do not match always have 431 | the same form, we can extract the pre- and postconditions from the message, 432 | and rewrite it to the following using an \emph{error handler}: 433 | 434 | \small 435 | \begin{code} 436 | Error in state transition: 437 | Operation has preconditions: [st ::: Store LoggedIn] 438 | States here are: [st ::: Store LoggedOut] 439 | Operation has postconditions: \result => [st ::: Store LoggedIn] 440 | Required result states here are: \result => [st ::: Store LoggedIn] 441 | \end{code} 442 | \normalsize 443 | 444 | The full details are beyond the scope of this paper, but they rely on 445 | the following function which inspects a reflected error message, and returns 446 | a new message if the original message has a particular form: 447 | 448 | \small 449 | \begin{code} 450 | st_precondition : Err -> Maybe (List ErrorReportPart) 451 | \end{code} 452 | \normalsize 453 | 454 | -------------------------------------------------------------------------------- /Paper/content/intro.tex: -------------------------------------------------------------------------------- 1 | \section{Introduction} 2 | 3 | Software relies on state, and many components rely on state machines. For 4 | example, they describe network transport protocols like TCP~\citep{rfc793}, and 5 | implement event-driven systems and regular expression matching. 6 | % 7 | Furthermore, many fundamental resources like network sockets and 8 | files are, implicitly, managed by state machines, in that certain 9 | operations are only valid on resources in certain states, and those operations 10 | can change the states of the underlying resource. For example, it only makes 11 | sense to send a message on a connected network socket, and closing a socket 12 | changes its state from ``open'' to ``closed''. State machines can also encode 13 | important security properties. For example, in the software which implements 14 | an ATM, it's important that the ATM dispenses cash only when the machine is 15 | in a state where a card has been inserted and the PIN verified. 16 | 17 | Despite this, state transitions are generally not checked by compilers. 18 | We routinely use type checkers to ensure that variables and 19 | arguments are used consistently, but statically checking that 20 | operations are performed only on resources in an appropriate state is not well 21 | supported by mainstream type systems. 22 | % 23 | In this paper, we show how to represent state machines precisely in the 24 | dependently typed programming language Idris~\citep{brady2013idris}, 25 | and present a library which allows composing larger programs from multiple 26 | state transition systems. The library supports composition in two ways: 27 | firstly, we can use several independently implemented state transition 28 | systems at once; secondly, we can implement one state transition system 29 | in terms of others. 30 | 31 | %inspired by the work of Hancock and Setzer on describing 32 | %interactive programming in dependent type theory with command and response 33 | %trees~\citep{hancock-interactive}, and by ongoing work on algebraic effects and 34 | %handlers~\citep{Plotkin2009,Bauer}. 35 | 36 | A motivation for this work is to be able to define communicating 37 | systems, where the type system verifies that each participant follows a 38 | defined protocol. This is inspired by Session Types~\citep{Honda93,Honda08}, 39 | in which the state of a session at any point represents the allowed 40 | interactions on a communication channel. 41 | %One of the goals, therefore, 42 | %is to represent a form of session types using dependent types. 43 | 44 | However, in order to use session types effectively in practice, we need to be 45 | able to use them in larger systems, interacting with other components. The 46 | \states{} type we present in this paper will allow us to implement a system as 47 | a hierarchy of state machines, and as an example we will implement a 48 | client-server system in which a client requests a random number within a 49 | specific bound from a server, and in which the server processes requests 50 | \emph{asynchronously}. All of the examples are available 51 | online (for review: submitted as supplementary material). 52 | 53 | \subsection{Contributions} 54 | 55 | We build on previous work on algebraic effects in 56 | Idris~\citep{brady-eff2013,brady-tfp14}. 57 | In this earlier work, an \emph{effect} is described by an algebraic data 58 | type which gives the operations supported by that effect, and which 59 | is parameterised by a \emph{resource} type. 60 | Operations can change the types of those resources, meaning 61 | that we can implement and verify state transition systems using effects. 62 | However, there are shortcomings: the concrete resource type is defined by the 63 | \emph{effect signature} rather than by its \emph{implementation}; 64 | it is not possible to create \emph{new} resources in a 65 | controlled way; and, it is not possible to implement \emph{handlers} for 66 | effects in terms of other effects. 67 | % 68 | In this paper, we address these shortcomings, making the following 69 | specific contributions: 70 | 71 | \begin{itemize} 72 | \item We present a type, \states{}, which allows a programmer to 73 | describe a the pre- and post-conditions of a stateful function, creating 74 | and destroying resources as necessary (Section~\ref{sect:statemachines}). 75 | \item We describe the implementation of \states{}, in particular using 76 | Idris' proof automation to construct proofs of correct state management 77 | without programmer intervention (Section~\ref{sect:implementst}). 78 | \item We show how to use \states{} to describe existing stateful APIs, 79 | notably working with network sockets, and to implement high level stateful 80 | systems, such as network application protocols, in terms of these lower level 81 | systems (Section~\ref{sect:examples}). 82 | \end{itemize} 83 | 84 | An important goal of \states{} is \emph{usability}, providing notation 85 | to help write \emph{correct} programs without a significant \emph{cost}. 86 | Concretely, this means 87 | that the types need to be readable and need to help direct a programmer to a 88 | working implementation, and error messages need to explain problems clearly. 89 | We therefore use holes (Section~\ref{sect:getdata}) 90 | to help build programs interactively, type level programming 91 | (Section~\ref{sect:sttype}) to provide a readable type level notation, and 92 | error reflection (Section~\ref{sect:errorreflection}) to rewrite error messages 93 | into the language of the problem domain. 94 | 95 | Using \states{}, we can encode the assumptions we make about state transitions 96 | in a type, and ensure that these assumptions hold at 97 | run time. Moreover, by allowing state machines to be composed both horizontally 98 | (using multiple state machines at once within a function) and vertically 99 | (implementing a state machine in terms of other, lower level, state machines), 100 | \states{} provides an \emph{architecture} for larger scale dependently typed 101 | programs. 102 | 103 | %\subsection{Motivation: Client-Server Communication} 104 | 105 | %\label{sect:motivating} 106 | 107 | % For each state machine, we use the type system to guarantee that operations 108 | % satisfy their necessary \emph{preconditions}, for example that we can only send 109 | % a reply to a message after receiving a request. To begin, therefore, 110 | % we will describe how to represent a state machine in a type, including error 111 | % handling, for a small example: a data store which will only allow data 112 | % to be read after a user has logged in. 113 | 114 | \section{Example: A data store, requiring a login} 115 | 116 | Our goal is to use the type system not only to describe the inputs 117 | and outputs of functions precisely, but also to explain the effect of 118 | functions on any external resources. 119 | One way to achieve this is to use an indexed monad~\citep{atkey-param}, 120 | where for each operation the monad supports, the type carries a 121 | \remph{precondition} which must hold before the operation is executed, 122 | and a \remph{postcondition} which holds after the operation is executed, 123 | possibly depending on the result of the operation. In a sense, these 124 | are Hoare triples~\citep{hoarelogic}, embedded in the type. 125 | % 126 | In this section, we introduce this idea with a small example: a data store which requires users 127 | to log in before giving access to secret data. 128 | 129 | \subsection{State Transitions in the Store} 130 | 131 | The store has two states: 132 | \texttt{LoggedIn}, which means that a user is logged in and able to access 133 | data; and \texttt{LoggedOut}, which means that the user is not logged in. 134 | Reading data is only allowed when the system is in the \texttt{LoggedIn} state. 135 | % 136 | Figure~\ref{fig:login} illustrates the data store, showing the 137 | \remph{states} the system can be in (\texttt{LoggedOut} and \texttt{LoggedIn}) 138 | and the operations a user can perform on the system. The operations are: 139 | 140 | \begin{itemize} 141 | \item \texttt{login}, which is valid when the system is in the 142 | \texttt{LoggedOut} state, and either results in the system being in the 143 | \texttt{LoggedIn} state, if login was successful, or the \texttt{LoggedOut} 144 | state otherwise (for example, due to an incorrectly entered password). 145 | \item \texttt{logout}, which is valid when the system is in the 146 | \texttt{LoggedIn} state, and moves the system to the \texttt{LoggedOut} state. 147 | \item \texttt{readSecret}, which returns the data held in the store, and 148 | is only valid when the system is in the \texttt{LoggedIn} state. 149 | \end{itemize} 150 | 151 | \begin{figure}[h] 152 | \includegraphics[width=10cm]{diagrams/login.pdf} 153 | \caption{A state machine describing the states and transitions in a system 154 | which allows a program to read some secret data only after successfully logging 155 | in to a data store.} 156 | \label{fig:login} 157 | \end{figure} 158 | 159 | By using the type system to capture the state of this system, we can be 160 | sure that a program will only succeed in reading data when it has successfully 161 | logged in to the system. 162 | 163 | \subsection{Representing State Transitions in a Type} 164 | 165 | Our goal is that attempting to read data without logging in should result in a 166 | static type error. Listing~\ref{fig:storemonad} shows how we can achieve this 167 | using an indexed monad. 168 | 169 | \small 170 | \begin{code}[float=h, frame=single,caption={Implementing the state store as 171 | an indexed monad},label=fig:storemonad] 172 | data Access = LoggedOut | LoggedIn 173 | data LoginResult = OK | BadPassword 174 | 175 | data Store : (ty : Type) -> Access -> (ty -> Access) -> Type where 176 | Login : Store LoginResult LoggedOut 177 | (\res => case res of 178 | OK => LoggedIn 179 | BadPassword => LoggedOut) 180 | Logout : Store () LoggedIn (const LoggedOut) 181 | ReadSecret : Store String LoggedIn (const LoggedIn) 182 | 183 | Pure : (x : ty) -> Store ty (st x) st 184 | Lift : IO ty -> Store ty st (const st) 185 | (>>=) : Store a st1 st2 -> ((x : a) -> Store b (st2 x) st3) -> Store b st1 st3 186 | \end{code} 187 | \normalsize 188 | 189 | The \texttt{Store} indexed by the type of the result of the operation, the 190 | required input state, and an output state calculated from the result of the 191 | operation. In the simplest cases, such as \texttt{Logout}, the result has no 192 | influence on the result, so we use \texttt{const} (which returns its first 193 | argument and discards its second) to compute the result state: 194 | 195 | \small 196 | \begin{code} 197 | Logout : Store () LoggedIn (const LoggedOut) 198 | \end{code} 199 | \normalsize 200 | 201 | When we \texttt{Login}, on the other hand, the result state depends on the 202 | result of the operation. If login is successful, it returns \texttt{OK}, 203 | and the resulting state of the system is \texttt{LoggedIn}; otherwise, it 204 | is \texttt{LoggedOut}: 205 | 206 | \small 207 | \begin{code} 208 | Login : Store LoginResult LoggedOut (\res => case res of 209 | OK => LoggedIn 210 | BadPassword => LoggedOut) 211 | \end{code} 212 | \normalsize 213 | 214 | \subsection{Implementing a program to access the \texttt{Store}} 215 | 216 | \label{sect:getdata} 217 | 218 | Listing~\ref{fig:storeprog} shows how to combine operations on the store into a 219 | complete function which attempts to login, then reads and prints the data if 220 | successful, or prints an error if not. 221 | 222 | \small 223 | \begin{code}[float=h, frame=single,caption={A function which logs in to the 224 | store and reads the secret data if login succeeds},label=fig:storeprog] 225 | getData : Store () LoggedOut (const LoggedOut) 226 | getData = do result <- Login 227 | case result of 228 | OK => do secret <- ReadSecret 229 | Lift (putStr ("Secret: " ++ show secret ++ "\n")) 230 | Logout 231 | BadPassword => Lift (putStr "Failure\n") 232 | \end{code} 233 | \normalsize 234 | 235 | Rather than writing \texttt{getData} in one go, we develop it interactively 236 | using \emph{holes}. The following listing contains a hole 237 | \texttt{getData\_rest}, which stands for the rest of the sequence after 238 | attempting to login: 239 | 240 | \small 241 | \begin{code} 242 | getData : Store () LoggedOut (const LoggedOut) 243 | getData = do result <- Login 244 | ?getData_rest 245 | \end{code} 246 | \normalsize 247 | 248 | Then, if we check the type of the hole, we can see both the current state of 249 | the system explicitly in the type, and the required state at the end of the 250 | function. Here, we see we need to inspect \texttt{result}: 251 | 252 | \small 253 | \begin{code} 254 | getData_rest : Store () (case result of 255 | OK => LoggedIn 256 | BadPassword => LoggedOut) (const LoggedOut) 257 | \end{code} 258 | \normalsize 259 | 260 | %The type here indicates that we can only make progress 261 | %by inspecting the value of \texttt{result}. 262 | %Functions with holes can be type checked, and even compiled, although 263 | %executing an incomplete program gives a run time error. 264 | 265 | We leave \remph{execution} of a \texttt{Store} program abstract here; 266 | this depends on factors such as how to connect to the store, the security 267 | policy, and so on. 268 | Nevertheless, by defining an indexed monad for the operations on a data store, 269 | we can be sure that programs which access the store correctly follow a protocol 270 | of logging in before reading data. However, there are limitations to this 271 | approach. For example: 272 | 273 | \begin{itemize} 274 | \item What if we want to write programs which use other external 275 | resources, as well as the data store? 276 | \item % What if we need access to several different stores? 277 | Can we connect to an arbitrary number of stores, rather than being limited to 278 | one? 279 | \item \texttt{Store} describes a session with a 280 | \remph{connected} store. How do we handle connecting and disconnecting? 281 | \end{itemize} 282 | 283 | In the rest of this paper, we will decribe a library, \states{}, written in 284 | Idris, which allows us to describe APIs such as those provided by 285 | \texttt{Store}. It will address the above limitations, allowing us to 286 | \remph{compose} multiple stateful systems, implement systems in terms of other, 287 | lower level systems, and create and destroy resources as required. 288 | 289 | \endinput 290 | 291 | \endinput 292 | 293 | \begin{figure} 294 | \begin{center} 295 | \includegraphics[width=7cm]{diagrams/randclient.pdf} 296 | \end{center} 297 | \caption{A state transition diagram which shows the states and 298 | operations of a client which connects to a server, sends a single message 299 | and receives a reply. The initial and final state is \texttt{Closed}.} 300 | \label{fig:randclient} 301 | \end{figure} 302 | 303 | Figure~\ref{fig:randclient} shows the general form of the states in a 304 | client, where the client connects to a server, sends a message, waits for 305 | a reply, then closes the connection. 306 | Connecting to the server may fail, for example due to a network error, so 307 | in practice we'll need to check whether the \tFN{Open} operation was 308 | successful. Furthermore, although we may have implemented the client 309 | correctly, we can't assume that the server is implemented correctly. If the 310 | server is following a different protocol, \tFN{Recv} may also fail. 311 | 312 | \begin{figure} 313 | \begin{center} 314 | \includegraphics[width=9cm]{diagrams/randserver.pdf} 315 | \end{center} 316 | \caption{A state transition diagram which shows the states and 317 | operations of a server which waits for connections from a client. 318 | On accepting a connection, it also starts a new machine in the \texttt{Waiting} 319 | state. The initial state is \texttt{Idle} and the final states are 320 | \texttt{Idle} and \texttt{Done}.} 321 | \label{fig:randserver} 322 | \end{figure} 323 | 324 | A client only has to deal with one connection, to a single server. A server, on 325 | the other hand, may receive requests from several clients. 326 | Figure~\ref{fig:randserver} shows the general form of the states in a server 327 | which waits for connections from clients, and on receiving a connection 328 | initiates a session in which it waits for an incoming message, then sends 329 | a reply. When it initiates a session, the session itself might run in 330 | another thread or process. There are two state machines here: 331 | 332 | \begin{enumerate} 333 | \item \textbf{Session initiation:} either the server is not running, or it's ready 334 | for an incoming connection. When it receives an incoming connection, it 335 | sets up a new \emph{session interaction} state machine for that connection 336 | and continues waiting for connections 337 | \item \textbf{Session interaction:} the session waits for an incoming message, 338 | processes that message and sends a response, then the session is complete 339 | \end{enumerate} 340 | 341 | -------------------------------------------------------------------------------- /Paper/content/motivate.tex: -------------------------------------------------------------------------------- 1 | \section{Type-level State Machines} 2 | 3 | \label{sect:motivate} 4 | 5 | -------------------------------------------------------------------------------- /Paper/diagrams/doorstate.graphml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | DoorClosed 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | DoorOpen 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | Open 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | Close 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | RingBell 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | -------------------------------------------------------------------------------- /Paper/diagrams/doorstate.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/Vars/007fb0e06dfcf913bae25db1221e48d6ba1d16e5/Paper/diagrams/doorstate.pdf -------------------------------------------------------------------------------- /Paper/diagrams/login.graphml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | LoggedOut 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | LoggedIn 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | login 58 | (success) 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | logout 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | readSecret 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | login 110 | (failure) 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | -------------------------------------------------------------------------------- /Paper/diagrams/login.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/Vars/007fb0e06dfcf913bae25db1221e48d6ba1d16e5/Paper/diagrams/login.pdf -------------------------------------------------------------------------------- /Paper/diagrams/login2.graphml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | LoggedOut 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | LoggedIn 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | login 58 | (success) 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | logout 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | readSecret 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | login 110 | (failure) 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | -------------------------------------------------------------------------------- /Paper/diagrams/login2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/Vars/007fb0e06dfcf913bae25db1221e48d6ba1d16e5/Paper/diagrams/login2.pdf -------------------------------------------------------------------------------- /Paper/diagrams/netstate.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/Vars/007fb0e06dfcf913bae25db1221e48d6ba1d16e5/Paper/diagrams/netstate.pdf -------------------------------------------------------------------------------- /Paper/diagrams/randarch.graphml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | RandServer 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | Net 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | Var 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | Execute Net IO 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | Execute Var m 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | -------------------------------------------------------------------------------- /Paper/diagrams/randarch.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/Vars/007fb0e06dfcf913bae25db1221e48d6ba1d16e5/Paper/diagrams/randarch.pdf -------------------------------------------------------------------------------- /Paper/diagrams/randclient.graphml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | Closed 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | ReadySend 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | Open (success) 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | ReadyRecv 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | Done 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | Send 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | Recv 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | Close 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | Open (failure) 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | 243 | 244 | 245 | 246 | 247 | 248 | 249 | 250 | 251 | 252 | 253 | 254 | 255 | 256 | 257 | 258 | 259 | 260 | 261 | 262 | 263 | 264 | 265 | 266 | 267 | 268 | 269 | 270 | 271 | -------------------------------------------------------------------------------- /Paper/diagrams/randclient.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/Vars/007fb0e06dfcf913bae25db1221e48d6ba1d16e5/Paper/diagrams/randclient.pdf -------------------------------------------------------------------------------- /Paper/diagrams/randserver.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/Vars/007fb0e06dfcf913bae25db1221e48d6ba1d16e5/Paper/diagrams/randserver.pdf -------------------------------------------------------------------------------- /Paper/idrislang.sty: -------------------------------------------------------------------------------- 1 | %% --------------------------------------------------- [ Idris Styling Package ] 2 | %% 3 | %% A set of LaTeX macros and styling for working with Idris in LaTeX 4 | %% 5 | %% + Provides a listings bindings: 6 | %% + idris :: default ascii 7 | %% + literateidris :: convert ascii maths to math symbols. 8 | %% + Defines a `numbers' and `default' listings style. 9 | %% + Defines a `code' environment for typesetting idris. 10 | %% + \begin{code}[...] ... \end{code} 11 | %% + Defines commands typesetting the name Idris. 12 | %% + \Idris{} 13 | %% + \idris{} 14 | %% 15 | %% Options: 16 | %% - literate :: turn on literate idris for code environments. 17 | %% - numbers :: turn on numbers for code environments. 18 | %% 19 | %% ----------------------------------------------------------- [ Begin Package ] 20 | \ProvidesPackage{idrislang} 21 | 22 | \RequirePackage{ifthen} 23 | \RequirePackage{listings} 24 | \RequirePackage{xspace} 25 | %% ----------------------------------------------------------------- [ Options ] 26 | \newboolean{literate} 27 | \setboolean{literate}{false} 28 | \newboolean{numbers} 29 | \setboolean{numbers}{false} 30 | 31 | \DeclareOption{literate}{% 32 | \setboolean{literate}{true} 33 | } 34 | 35 | \DeclareOption{numbers}{% 36 | \setboolean{numbers}{true} 37 | } 38 | 39 | \ProcessOptions\relax 40 | 41 | %% ---------------------------------------------------------------- [ Commands ] 42 | \newcommand{\Idris}{\textsc{Idris}\xspace} 43 | \newcommand{\idris}{\textsc{Idris}\xspace} 44 | 45 | %% --------------------------------------------------- [ Define Idris Listings ] 46 | \lstdefinelanguage{idris}{% 47 | sensitive,% 48 | %% ----------------------------------------------------------- [ Default Style ] 49 | basicstyle=\ttfamily, 50 | flexiblecolumns=false, 51 | commentstyle=\footnotesize\sffamily, 52 | %% ---------------------------------------------------------------- [ Keywords ] 53 | %% From Idris Parser and idris-mode and vimscript 54 | keywords={% 55 | abstract, attack, case, compute, do, dsl, else, exact, focus, if, 56 | import, in, infix, infixl, infixr, instance, intros, module, 57 | mutual, namespace, of, let, parameters, partial, pattern, prefix, 58 | private, public, refine, rewrite, syntax, term, then, 59 | total, trivial, try, using, where, with 60 | }, 61 | %% ------------------------------------------------------- [ Prelude Functions ] 62 | %% Generated using 63 | %% find lib/ -name "*.idr" | xargs grep -e "^[a-zA-Z0-9]* :" | awk -F : '{printf $2", "}' 64 | morekeywords={% 65 | class, data, instance, record, dsl, postulate, default, assert_total, 66 | lambda, variable, index_first, index_next, interface, implementation 67 | % trace, unsafePerformPrimIO, FInt, FChar, FByte, FShort, FLong, 68 | % FBits8, FBits16, FBits32, FBits64, FBits8x16, FBits16x8, 69 | % FBits32x4, FBits64x2, interpFTy, ForeignTy, mkForeignPrim, 70 | % mkLazyForeignPrim, liftPrimIO, fork, unsafePerformIO, listens, 71 | % censor, Writer, liftReaderT, asks, Reader, modify, gets, State, 72 | % RWS, nGTSm, decideNatLTE, lte, vectInjective1, vectInjective2, 73 | % run, myID, send, msgWaiting, recv, recvWithSender, create, 74 | % sendToThread, checkMsgs, getMsg, viewB8x16, viewB16x8, viewB32x4, 75 | % viewB64x2, pow, exp, log, pi, sin, cos, tan, asin, acos, atan, 76 | % atan2, sinh, cosh, tanh, sqrt, floor, ceiling, count, countFrom, 77 | % curry, uncurry, uniformB8x16, uniformB16x8, uniformB32x4, 78 | % uniformB64x2, putStr, putStrLn, print, getLine, putChar, getChar, 79 | % fopen, openFile, closeFile, fread, fwrite, feof, ferror, nullPtr, 80 | % nullStr, validFile, while, readFile, userSuppliedName, seq, try, 81 | % mkPair, getUName, unApply, mkApp, binderTy, divCeil, nextPow2, 82 | % nextBytes, machineTy, bitsUsed, natToBits, getPad, pad8, pad16, 83 | % pad32, pad64, shiftLeft, shiftRightLogical, shiftRightArithmetic, 84 | % and, or, xor, plus, minus, times, sdiv, udiv, srem, urem, lt, lte, 85 | % eq, gte, gt, complement, zeroExtend, intToBits, bitsToInt, bitAt, 86 | % getBit, setBit, unsetBit, bitsToStr, findElem, replaceElem, 87 | % replaceByElem, mapElem, anyNilAbsurd, anyElim, any, negAnyAll, 88 | % notAllHere, notAllThere, all, length, index, weaken, take, toList, 89 | % fromList, replicate, foldl, foldr, map, pad, zeroBoundIsEmpty, 90 | % empty, insert, delete, contains, fromList, toList, applyKleisli, 91 | % applyMor, applyEndo, absZ, negZ, negNat, minusNatZ, plusZ, subZ, 92 | % multZ, fromInt, natPlusZPlus, natMultZMult, doubleNegElim, 93 | % posInjective, negSInjective, posNotNeg, plusZeroLeftNeutralZ, 94 | % plusZeroRightNeutralZ, plusCommutativeZ, modBin, modComp, div, 95 | % rem, intToMod, modToStr, branch4, branch5, branch6, branch7, 96 | % merge1, merge2, merge3, treeLookup, treeInsert, delType, 97 | % treeDelete, treeToList, empty, lookup, insert, delete, fromList, 98 | % toList, getWitness, getProof, FalseElim, replace, sym, trans, 99 | % lazy, par, malloc, Not, id, the, const, fst, snd, flip, cong, 100 | % boolElim, not, intToBool, boolOp, div, mod, strHead, strTail, 101 | % strCons, strIndex, reverse, null, getArgs, getEnv, setEnv, 102 | % unsetEnv, getEnvironment, exit, usleep, sequence, toHexDigit, 103 | % b8ToString, b16ToString, b32ToString, b64ToString, tail, head, 104 | % last, init, index, deleteAt, replaceAt, take, drop, fromList, 105 | % replicate, zipWith, zip, unzip, concat, elemBy, elem, lookupBy, 106 | % lookup, hasAnyBy, hasAny, find, findIndex, elemIndexBy, elemIndex, 107 | % nubBy, nub, isPrefixOfBy, isPrefixOf, isSuffixOfBy, isSuffixOf, 108 | % catMaybes, diag, range, isLeft, isRight, choose, either, lefts, 109 | % rights, partitionEithers, fromEither, maybeToEither, strM, unpack, 110 | % pack, span, break, split, ltrim, trim, words, lines, foldr1, 111 | % unwords, length, realPart, imagPart, mkPolar, cis, magnitude, 112 | % phase, conjugate, isNothing, isJust, maybe, fromMaybe, toMaybe, 113 | % justInjective, lowerMaybe, raiseToMaybe, isNil, isCons, head, 114 | % tail, last, init, take, drop, takeWhile, dropWhile, list, length, 115 | % repeat, replicate, zipWith, zipWith3, zip, zip3, unzip, unzip3, 116 | % mapMaybe, toList, reverse, intersperse, intercalate, elemBy, elem, 117 | % lookupBy, lookup, hasAnyBy, hasAny, find, findIndex, findIndices, 118 | % elemIndexBy, elemIndex, elemIndicesBy, elemIndices, filter, nubBy, 119 | % nub, span, break, split, partition, isPrefixOfBy, isPrefixOf, 120 | % isSuffixOfBy, isSuffixOf, sorted, mergeBy, merge, sort, 121 | % maybeToList, listToMaybe, catMaybes, appendNilRightNeutral, 122 | % appendAssociative, lengthAppend, mapPreservesLength, 123 | % mapDistributesOverAppend, mapFusion, hasAnyByNilFalse, 124 | % hasAnyNilFalse, fromIntegerNat, toIntegerNat, hyper, log2, gcd, 125 | % liftA, liftA2, liftA3, guard, when, finToNat, finToInt, weaken, 126 | % strengthen, last, natToFin, integerToFin, fromInteger, flatten, 127 | % return, isUpper, isLower, isAlpha, isDigit, isAlphaNum, isSpace, 128 | % isNL, toUpper, toLower, isHexDigit, isValidHeap, merge, insert, 129 | % findMinimum, deleteMinimum, toList, fromList, sort, main, foldl, 130 | % concat, concatMap, and, or, any, all, sum, product, Vars, 131 | % getAction, setInfo, getInfo, lift, output, queryVars, postVars, 132 | % cookieVars, queryVar, getOutput, getHeaders, flushHeaders, flush, 133 | % getVars, getContent, getCgiEnv, runCGI, mult 134 | }, 135 | %% ---------------------------------------------------------------- [ Comments ] 136 | morecomment=[l]--,% 137 | morecomment=[n]{\{-}{-\}} 138 | }[keywords,comments,strings]% 139 | 140 | %% ---------------------------------------- [ Define Idris with Literate Stuff ] 141 | \lstdefinelanguage{literateidris}[]{idris}{ 142 | literate= {+}{{$+$}}1 143 | {/}{{$/$}}1 144 | {*}{{$*$}}1 145 | {=}{{$=$}}1 146 | {>}{{$>$}}1 147 | {<}{{$<$}}1 148 | {\\}{{$\lambda$}}1 149 | {\\\\}{{\char`\\\char`\\}}1 150 | {->}{{$\rightarrow$}}2 151 | {>=}{{$\geq$}}2 152 | {<-}{{$\leftarrow$}}2 153 | {<=}{{$\leq$}}2 154 | {=>}{{$\Rightarrow$}}2 155 | {==}{{$\equiv$}}2 156 | {\ .}{{$\circ$}}2 157 | {\ .\ }{{$\circ$}}2 158 | {>>}{{>>}}2 159 | {>>=}{{>>=}}2 160 | {|}{{$\mid$}}1, 161 | } 162 | %% -------------------------------------------------- [ Default Listings Style ] 163 | 164 | \lstdefinestyle{default}{% 165 | xleftmargin=\parindent, 166 | tabsize=2 167 | } 168 | \lstdefinestyle{numbers}{% 169 | xleftmargin=\parindent, 170 | tabsize=2, 171 | numbers=left, 172 | numbersep=10pt, 173 | numberstyle=\footnotesize\sffamily, 174 | frame=leftline 175 | } 176 | 177 | %% ------------------------------------------------------ [ A Code Environment ] 178 | %% Replicate the existence of literate haskell code environments, 179 | %% option to make pretty with numbers. 180 | \lstnewenvironment{code}[1][] 181 | {\ifthenelse{\boolean{literate}}{% 182 | \lstset{language=literateidris}}{% 183 | \lstset{language=idris}} 184 | \ifthenelse{\boolean{numbers}}{% 185 | \lstset{style=numbers, #1}}{% 186 | \lstset{style=default, #1}} 187 | } 188 | {} 189 | \endinput 190 | %% --------------------------------------------------------------------- [ EOF ] 191 | -------------------------------------------------------------------------------- /Paper/idrisvars.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/Vars/007fb0e06dfcf913bae25db1221e48d6ba1d16e5/Paper/idrisvars.pdf -------------------------------------------------------------------------------- /Paper/idrisvars.tex: -------------------------------------------------------------------------------- 1 | \documentclass[british,format=acmlarge,screen=true,anonymous=false,review=false]{acmart} 2 | 3 | \usepackage[l2tabu,orthodox]{nag} 4 | \usepackage{fixltx2e} 5 | \usepackage{babel} 6 | \usepackage[iso]{isodate} 7 | \usepackage[utf8]{inputenc} 8 | \usepackage[T1]{fontenc} 9 | \usepackage{xspace} 10 | 11 | %\usepackage{mathpazo} 12 | %\usepackage[scaled=0.95]{helvet} 13 | \usepackage{courier} 14 | 15 | \usepackage{graphicx} 16 | %\usepackage{hyperref} 17 | \usepackage[missing=0.9.12]{gitinfo} 18 | 19 | \usepackage{fpmacros} 20 | \usepackage{idrislang} 21 | \usepackage{url} 22 | \usepackage{natbib} 23 | 24 | %\input{conf.ltx} 25 | \input{library.ltx} 26 | 27 | \title{State Machines All The Way Down} 28 | \subtitle{An Architecture for Dependently Typed Applications} 29 | 30 | \author{Edwin Brady} 31 | \affiliation{ 32 | \institution{University of St Andrews} 33 | \department{School of Computer Science} 34 | \city{St Andrews} 35 | \country{Scotland} 36 | } 37 | \email{ecb10@st-andrews.ac.uk} 38 | 39 | \newcommand{\states}{\texttt{ST}} 40 | 41 | \begin{abstract} 42 | A useful pattern in dependently typed programming is to define a state 43 | transition system, for example the states and operations in a network 44 | protocol, as an indexed monad. We index each operation by its input 45 | and output states, thus guaranteeing that operations satisfy pre- and 46 | post-conditions, by typechecking. However, what if we want to write a 47 | program using several systems at once? What if we want to define a high 48 | level state transition system, such as a network application protocol, in 49 | terms of lower level states, such as network sockets and mutable variables? 50 | 51 | In this paper, we present an architecture for dependently typed 52 | applications based on a hierarchy of state transition systems, implemented 53 | in a generic data type \states{}. This is based on a monad 54 | indexed by \emph{contexts} of resources, allowing us to reason about 55 | multiple state transition systems in the type of a function. 56 | Using \states{}, we show: how to implement a state transition system as a 57 | dependent type, with type level guarantees on its operations; how to 58 | account for operations which could fail; how to 59 | \emph{combine} state transition systems into a larger system; and, how to 60 | implement larger systems as a hierarchy of state transition systems. 61 | We illustrate the system by implementing a number of examples, including a 62 | graphics API, POSIX network sockets, asynchronous programming with threads, 63 | and a high level network application protocol. 64 | \end{abstract} 65 | 66 | 67 | \begin{document} 68 | \bibliographystyle{ACM-Reference-Format} 69 | \citestyle{acmauthoryear} 70 | 71 | \maketitle 72 | 73 | \input{content/intro.tex} 74 | %\input{content/motivate.tex} 75 | \input{content/sttutorial.tex} 76 | \input{content/implement.tex} 77 | \input{content/examples.tex} 78 | \input{content/conclusions.tex} 79 | 80 | \bibliography{dtp} 81 | 82 | \end{document} 83 | 84 | -------------------------------------------------------------------------------- /Paper/library.ltx: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%% library file for datatypes etc. 2 | 3 | %%% Identifiers 4 | 5 | \newcommand{\va}{\VV{a}} 6 | \newcommand{\vb}{\VV{b}} 7 | \newcommand{\vc}{\VV{c}} 8 | \newcommand{\vd}{\VV{d}} 9 | \newcommand{\ve}{\VV{e}} 10 | \newcommand{\vf}{\VV{f}} 11 | \newcommand{\vg}{\VV{g}} 12 | \newcommand{\vh}{\VV{h}} 13 | \newcommand{\vi}{\VV{i}} 14 | \newcommand{\vj}{\VV{j}} 15 | \newcommand{\vk}{\VV{k}} 16 | \newcommand{\vl}{\VV{l}} 17 | \newcommand{\vm}{\VV{m}} 18 | \newcommand{\vn}{\VV{n}} 19 | \newcommand{\vo}{\VV{o}} 20 | \newcommand{\vp}{\VV{p}} 21 | \newcommand{\vq}{\VV{q}} 22 | \newcommand{\vr}{\VV{r}} 23 | \newcommand{\vs}{\VV{s}} 24 | \newcommand{\vt}{\VV{t}} 25 | \newcommand{\vu}{\VV{u}} 26 | \newcommand{\vv}{\VV{v}} 27 | \newcommand{\vw}{\VV{w}} 28 | \newcommand{\vx}{\VV{x}} 29 | \newcommand{\vy}{\VV{y}} 30 | \newcommand{\vz}{\VV{z}} 31 | \newcommand{\vA}{\VV{A}} 32 | \newcommand{\vB}{\VV{B}} 33 | \newcommand{\vC}{\VV{C}} 34 | \newcommand{\vD}{\VV{D}} 35 | \newcommand{\vE}{\VV{E}} 36 | \newcommand{\vF}{\VV{F}} 37 | \newcommand{\vG}{\VV{G}} 38 | \newcommand{\vH}{\VV{H}} 39 | \newcommand{\vI}{\VV{I}} 40 | \newcommand{\vJ}{\VV{J}} 41 | \newcommand{\vK}{\VV{K}} 42 | \newcommand{\vL}{\VV{L}} 43 | \newcommand{\vM}{\VV{M}} 44 | \newcommand{\vN}{\VV{N}} 45 | \newcommand{\vO}{\VV{O}} 46 | \newcommand{\vP}{\VV{P}} 47 | \newcommand{\vQ}{\VV{Q}} 48 | \newcommand{\vR}{\VV{R}} 49 | \newcommand{\vS}{\VV{S}} 50 | \newcommand{\vT}{\VV{T}} 51 | \newcommand{\vU}{\VV{U}} 52 | \newcommand{\vV}{\VV{V}} 53 | \newcommand{\vW}{\VV{W}} 54 | \newcommand{\vX}{\VV{X}} 55 | \newcommand{\vY}{\VV{Y}} 56 | \newcommand{\vZ}{\VV{Z}} 57 | \newcommand{\vas}{\VV{as}} 58 | \newcommand{\vbs}{\VV{bs}} 59 | \newcommand{\vcs}{\VV{cs}} 60 | \newcommand{\vds}{\VV{ds}} 61 | \newcommand{\ves}{\VV{es}} 62 | \newcommand{\vfs}{\VV{fs}} 63 | \newcommand{\vgs}{\VV{gs}} 64 | \newcommand{\vhs}{\VV{hs}} 65 | \newcommand{\vis}{\VV{is}} 66 | \newcommand{\vjs}{\VV{js}} 67 | \newcommand{\vks}{\VV{ks}} 68 | \newcommand{\vls}{\VV{ls}} 69 | \newcommand{\vms}{\VV{ms}} 70 | \newcommand{\vns}{\VV{ns}} 71 | \newcommand{\vos}{\VV{os}} 72 | \newcommand{\vps}{\VV{ps}} 73 | \newcommand{\vqs}{\VV{qs}} 74 | \newcommand{\vrs}{\VV{rs}} 75 | %\newcommand{\vss}{\VV{ss}} 76 | \newcommand{\vts}{\VV{ts}} 77 | \newcommand{\vus}{\VV{us}} 78 | \newcommand{\vvs}{\VV{vs}} 79 | \newcommand{\vws}{\VV{ws}} 80 | \newcommand{\vxs}{\VV{xs}} 81 | \newcommand{\vys}{\VV{ys}} 82 | \newcommand{\vzs}{\VV{zs}} 83 | 84 | %%% Telescope Identifiers 85 | 86 | \newcommand{\ta}{\vec{\VV{a}}} 87 | \newcommand{\tb}{\vec{\VV{b}}} 88 | \newcommand{\tc}{\vec{\VV{c}}} 89 | \newcommand{\td}{\vec{\VV{d}}} 90 | \newcommand{\te}{\vec{\VV{e}}} 91 | \newcommand{\tf}{\vec{\VV{f}}} 92 | \newcommand{\tg}{\vec{\VV{g}}} 93 | %\newcommand{\th}{\vec{\VV{h}}} 94 | \newcommand{\ti}{\vec{\VV{i}}} 95 | \newcommand{\tj}{\vec{\VV{j}}} 96 | \newcommand{\tk}{\vec{\VV{k}}} 97 | \newcommand{\tl}{\vec{\VV{l}}} 98 | \newcommand{\tm}{\vec{\VV{m}}} 99 | \newcommand{\tn}{\vec{\VV{n}}} 100 | %\newcommand{\to}{\vec{\VV{o}}} 101 | \newcommand{\tp}{\vec{\VV{p}}} 102 | \newcommand{\tq}{\vec{\VV{q}}} 103 | \newcommand{\tr}{\vec{\VV{r}}} 104 | \newcommand{\tts}{\vec{\VV{s}}} 105 | \newcommand{\ttt}{\vec{\VV{t}}} 106 | \newcommand{\tu}{\vec{\VV{u}}} 107 | %\newcommand{\tv}{\vec{\VV{v}}} 108 | \newcommand{\tw}{\vec{\VV{w}}} 109 | \newcommand{\tx}{\vec{\VV{x}}} 110 | \newcommand{\ty}{\vec{\VV{y}}} 111 | \newcommand{\tz}{\vec{\VV{z}}} 112 | \newcommand{\tA}{\vec{\VV{A}}} 113 | \newcommand{\tB}{\vec{\VV{B}}} 114 | \newcommand{\tC}{\vec{\VV{C}}} 115 | \newcommand{\tD}{\vec{\VV{D}}} 116 | \newcommand{\tE}{\vec{\VV{E}}} 117 | \newcommand{\tF}{\vec{\VV{F}}} 118 | \newcommand{\tG}{\vec{\VV{G}}} 119 | \newcommand{\tH}{\vec{\VV{H}}} 120 | \newcommand{\tI}{\vec{\VV{I}}} 121 | \newcommand{\tJ}{\vec{\VV{J}}} 122 | \newcommand{\tK}{\vec{\VV{K}}} 123 | \newcommand{\tL}{\vec{\VV{L}}} 124 | \newcommand{\tM}{\vec{\VV{M}}} 125 | \newcommand{\tN}{\vec{\VV{N}}} 126 | \newcommand{\tO}{\vec{\VV{O}}} 127 | \newcommand{\tP}{\vec{\VV{P}}} 128 | \newcommand{\tQ}{\vec{\VV{Q}}} 129 | \newcommand{\tR}{\vec{\VV{R}}} 130 | \newcommand{\tS}{\vec{\VV{S}}} 131 | \newcommand{\tT}{\vec{\VV{T}}} 132 | \newcommand{\tU}{\vec{\VV{U}}} 133 | \newcommand{\tV}{\vec{\VV{V}}} 134 | \newcommand{\tW}{\vec{\VV{W}}} 135 | \newcommand{\tX}{\vec{\VV{X}}} 136 | \newcommand{\tY}{\vec{\VV{Y}}} 137 | \newcommand{\tZ}{\vec{\VV{Z}}} 138 | 139 | 140 | 141 | %%% Nat 142 | 143 | \newcommand{\NatPackage}{ 144 | \newcommand{\Nat}{\TC{\mathbb{N}}} 145 | \newcommand{\Z}{\DC{0}} 146 | \newcommand{\suc}{\DC{s}} 147 | \newcommand{\NatDecl}{ 148 | \Data \hg 149 | \Axiom{\Nat\Hab\Type} \hg 150 | \Where \hg 151 | \Axiom{\Z\Hab\Nat} \hg 152 | \Rule{\vn\Hab\Nat} 153 | {\suc\:\vn\Hab\Nat} 154 | }} 155 | 156 | %%% Bool 157 | 158 | \newcommand{\BoolPackage}{ 159 | \newcommand{\Bool}{\TC{Bool}} 160 | \newcommand{\true}{\DC{true}} 161 | \newcommand{\false}{\DC{false}} 162 | \newcommand{\BoolDecl}{ 163 | \Data \hg 164 | \Axiom{\Bool\Hab\Type} \hg 165 | \Where \hg 166 | \Axiom{\true\Hab\Bool} \hg 167 | \Axiom{\false\Hab\Bool} 168 | }} 169 | 170 | %%% So 171 | 172 | \newcommand{\SoPackage}{ 173 | \newcommand{\So}{\TC{So}} 174 | \newcommand{\oh}{\DC{oh}} 175 | \newcommand{\SoDecl}{ 176 | \Data \hg 177 | \Rule{\vb\Hab\Bool} 178 | {\So\:\vb\Hab\Type} \hg 179 | \Where \hg 180 | \Axiom{\oh\Hab\So\:\true} 181 | }} 182 | 183 | %%% Unit 184 | 185 | \newcommand{\UnitPackage}{ 186 | \newcommand{\Unit}{\TC{Unit}} 187 | \newcommand{\void}{\DC{void}} 188 | \newcommand{\UnitDecl}{ 189 | \Data \hg 190 | \Axiom{\Unit\Hab\Type} \hg 191 | \Where \hg 192 | \Axiom{\void\Hab\Unit} 193 | }} 194 | 195 | %%% Maybe 196 | 197 | \newcommand{\MaybePackage}{ 198 | \newcommand{\Maybe}{\TC{Maybe}} 199 | \newcommand{\yes}{\DC{yes}} 200 | \newcommand{\no}{\DC{no}} 201 | \newcommand{\MaybeDecl}{ 202 | \Data \hg 203 | \Rule{\vA\Hab\Type} 204 | {\Maybe\:\vA\Hab\Type} \hg 205 | \Where \hg 206 | \Rule{\va \Hab \vA} 207 | {\yes\:\va\Hab\Maybe\:\vA} \hg 208 | \Axiom{\no\Hab\Maybe\:\vA} 209 | }} 210 | 211 | %%% Cross 212 | 213 | \newcommand{\pr}[2]{(#1\DC{,}#2)} %grrrr 214 | \newcommand{\CrossPackage}{ 215 | \newcommand{\Cross}{\times} 216 | \newcommand{\CrossDecl}{ 217 | \Data \hg 218 | \Rule{\vA,\vB\Hab\Type} 219 | {\vA\Cross\vB\Hab\Type} \hg 220 | \Where \hg 221 | \Rule{\va \Hab \vA \hg \vb\Hab\vB} 222 | {\pr{\va}{\vb}\Hab\vA\Cross\vB} 223 | }} 224 | 225 | %%% Fin 226 | 227 | \newcommand{\FinPackage}{ 228 | \newcommand{\Fin}{\TC{Fin}} 229 | \newcommand{\fz}{\DC{f0}} 230 | \newcommand{\fs}{\DC{fs}} 231 | \newcommand{\FinDecl}{ 232 | \AR{ 233 | \Data \hg 234 | \Rule{\vn\Hab\Nat} 235 | {\Fin\:\vn\Hab\Type} \hg \\ 236 | \Where \hg 237 | \begin{array}[t]{c} 238 | \Axiom{\fz\Hab\Fin\:(\suc\:\vn)} \hg 239 | \Rule{\vi\Hab\Fin\:\vn} 240 | {\fs\:\vi\Hab\Fin\:(\suc\:\vn)} 241 | \end{array} 242 | } 243 | }} 244 | 245 | %%% Vect 246 | 247 | \newcommand{\VectPackage}{ 248 | \newcommand{\Vect}{\TC{Vect}} 249 | \newcommand{\vnil}{\varepsilon} 250 | \newcommand{\vcons}{\,\dcolon\,} 251 | \newcommand{\vsnoc}{\,\dcolon\,} 252 | \newcommand{\VectConsDecl}{ 253 | \Data \hg 254 | \Rule{\vA \Hab \Type \hg \vn\Hab\Nat} 255 | {\Vect\:\vA\:\vn\Hab\Type} \hg 256 | \Where \hg \begin{array}[t]{c} 257 | \Axiom{\vnil \Hab \Vect\:\vA\:\Z} \\ 258 | \Rule{\vx\Hab\vA \hg \vxs\Hab \Vect\:\vA\:\vn } 259 | {\vx\vcons\vxs\Hab\Vect\:\vA\:(\suc\vn)} 260 | \end{array} 261 | } 262 | \newcommand{\VectSnocDecl}{ 263 | \Data \hg 264 | \Rule{\vA \Hab \Type \hg \vn\Hab\Nat} 265 | {\Vect\:\vA\:\vn\Hab\Type} \hg 266 | \Where \hg \begin{array}[t]{c} 267 | \Axiom{\vnil \Hab \Vect\:\vA\:\Z} \\ 268 | \Rule{\vxs\Hab \Vect\:\vA\:\vn \hg \vx\Hab\vA} 269 | {\vxs\vsnoc\vx\Hab\Vect\:\vA\:(\suc\vn)} 270 | \end{array} 271 | } 272 | } 273 | 274 | %%% Compare 275 | 276 | %Data Compare : (x:nat)(y:nat)Type 277 | % = lt : (x:nat)(y:nat)(Compare x (plus (S y) x)) 278 | % | eq : (x:nat)(Compare x x) 279 | % | gt : (x:nat)(y:nat)(Compare (plus (S x) y) y); 280 | 281 | 282 | \newcommand{\ComparePackage}{ 283 | \newcommand{\Compare}{\TC{Compare}} 284 | \newcommand{\ltComp}{\DC{lt}} 285 | \newcommand{\eqComp}{\DC{eq}} 286 | \newcommand{\gtComp}{\DC{gt}} 287 | \newcommand{\CompareDecl}{ 288 | \Data \hg 289 | \Rule{\vm\Hab\Nat\hg\vn\Hab\Nat} 290 | {\Compare\:\vm\:\vn\Hab\Type} \\ 291 | \Where \hg\begin{array}[t]{c} 292 | \Rule{\vx\Hab\Nat\hg\vy\Hab\Nat} 293 | {\ltComp_{\vx}\:\vy\Hab\Compare\:\vx\:(\FN{plus}\:\vx\:(\suc\:\vy))} \\ 294 | \Rule{\vx\Hab\Nat} 295 | {\eqComp_{\vx}\Hab\Compare\:\vx\:\vx}\\ 296 | \Rule{\vx\Hab\Nat\hg\vy\Hab\Nat} 297 | {\gtComp_{\vy}\:\vx\Hab\Compare\:(\FN{plus}\:\vy\:(\suc\:\vx))\:\vy} \\ 298 | \end{array} 299 | } 300 | 301 | %Data CompareM : Type 302 | % = ltM : (ydiff:nat)CompareM 303 | % | eqM : CompareM 304 | % | gtM : (xdiff:nat)CompareM; 305 | 306 | \newcommand{\CompareM}{\TC{Compare^-}} 307 | \newcommand{\ltCompM}{\DC{lt^-}} 308 | \newcommand{\eqCompM}{\DC{eq^-}} 309 | \newcommand{\gtCompM}{\DC{gt^-}} 310 | \newcommand{\CompareMDecl}{ 311 | 312 | \Data \hg 313 | \Axiom{\CompareM\Hab\Type} \\ 314 | \Where \hg\begin{array}[t]{c} 315 | \Rule{\vy\Hab\Nat} 316 | {\ltCompM\:\vy\Hab\CompareM} \\ 317 | \Axiom{\eqCompM\Hab\CompareM}\\ 318 | \Rule{\vx\Hab\Nat} 319 | {\gtCompM\:\vx\Hab\CompareM} \\ 320 | \end{array} 321 | } 322 | \newcommand{\CompareRec}{\FN{CompareRec}} 323 | \newcommand{\CompareRecM}{\FN{CompareRec^-}} 324 | 325 | } 326 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A small library for tracking dependently typed mutable state, allowing 2 | creation of APIs which describe precisely the resources they create, 3 | modify and destroy. 4 | 5 | Work in progress, please don't send issues/PRs just yet. 6 | -------------------------------------------------------------------------------- /examples/Async.idr: -------------------------------------------------------------------------------- 1 | import System 2 | import Control.ST 3 | import System.Concurrency.Channels 4 | 5 | -- Simple asynchronous calls 6 | interface Async (m : Type -> Type) where 7 | Promise : Type -> Type 8 | 9 | -- Run an asynchronous action in another thread. Creates a 'promise' as 10 | -- a variable which will contain the result when it's done 11 | async : (action : ST m a []) -> 12 | ST m (Maybe Var) [Add (maybe [] (\p => [p ::: Promise a]))] 13 | 14 | -- Get the result from a promise, and delete it 15 | getResult : (p : Var) -> ST m (Maybe a) [Remove p (Promise a)] 16 | 17 | -- A channel for transmitting a specific type 18 | data TChannel : Type -> Type where 19 | MkTChannel : Channel -> TChannel a 20 | 21 | {- Asynchronous programming using channels in IO. The error checking here 22 | leaves something to be desired... if creating a channel fails between 23 | the caller and the callee then getResult will block. However, if creating 24 | a channel has failed, it's probably a more disastrous RTS problem like 25 | running out of memory... -} 26 | Async IO where 27 | Promise ty = State (TChannel ty) 28 | 29 | -- In IO, spawn a thread and create a channel for communicating with it 30 | -- Store the channel in the Promise 31 | async prog = do Just pid <- lift $ spawn (do Just chan <- listen 10 32 | | Nothing => pure () 33 | res <- run prog 34 | unsafeSend chan res 35 | pure ()) 36 | | Nothing => pure Nothing 37 | Just chan <- lift $ connect pid 38 | | Nothing => pure Nothing 39 | promise <- new (MkTChannel chan) 40 | pure (Just promise) 41 | -- Receive a message on the channel in the promise. unsafeRecv will block 42 | -- until it's there 43 | getResult {a} p = do MkTChannel chan <- read p 44 | delete p 45 | lift $ unsafeRecv a chan 46 | 47 | calcThread : Nat -> IO Nat 48 | calcThread Z = pure Z 49 | calcThread (S k) = do putStrLn "Counting" 50 | usleep 1000000 51 | v <- calcThread k 52 | pure (v + k) 53 | 54 | asyncMain : ST IO () [] 55 | asyncMain = do Just promise <- async (lift (calcThread 10)) 56 | | Nothing => lift (putStrLn "Async call failed") 57 | lift (putStrLn "Main thread") 58 | lift (putStr "What's your name? ") 59 | name <- lift getLine 60 | lift (putStrLn ("Hello " ++ name)) 61 | lift (putStrLn "Waiting for the answer") 62 | Just result <- getResult promise 63 | | Nothing => lift (putStrLn "Getting result failed") 64 | lift (printLn result) 65 | 66 | main : IO () 67 | main = run asyncMain 68 | 69 | -------------------------------------------------------------------------------- /examples/Composite.idr: -------------------------------------------------------------------------------- 1 | import Control.ST 2 | import Control.ST.ImplicitCall 3 | 4 | swap : (comp : Var) -> ST m () [comp ::: Composite [State Int, State Int]] 5 | swap comp = do [val1, val2] <- split comp 6 | combine comp [val2, val1] 7 | 8 | -------------------------------------------------------------------------------- /examples/Door.idr: -------------------------------------------------------------------------------- 1 | import Control.ST 2 | 3 | data DoorState = DoorOpen | DoorClosed 4 | data Result = Jammed | OK 5 | 6 | interface Door (m : Type -> Type) where 7 | DoorType : DoorState -> Type 8 | 9 | -- Create a new door in the closed state 10 | newDoor : ST m Var [Add (\d => [d ::: DoorType DoorClosed])] 11 | 12 | -- Ring the bell on a closed door 13 | ringBell : (d : Var) -> ST m () [d ::: DoorType DoorClosed] 14 | 15 | -- Attempt to open a door. If it jams, the door remains DoorClosed, 16 | -- if successful it becomes DoorOpen 17 | doorOpen : (d : Var) -> 18 | ST m Result 19 | [d ::: DoorType DoorClosed :-> 20 | (\res => DoorType (case res of 21 | Jammed => DoorClosed 22 | OK => DoorOpen))] 23 | -- Close an open door 24 | doorClose : (d : Var) -> 25 | ST m () [d ::: DoorType DoorOpen :-> DoorType DoorClosed] 26 | 27 | deleteDoor : (d : Var) -> ST m () [Remove d (DoorType DoorClosed)] 28 | 29 | doorProg : Door m => ST m () [] 30 | doorProg = do d <- newDoor 31 | ringBell d 32 | OK <- doorOpen d 33 | | Jammed => deleteDoor d 34 | doorClose d 35 | deleteDoor d 36 | 37 | 38 | -------------------------------------------------------------------------------- /examples/Graphics/Draw.idr: -------------------------------------------------------------------------------- 1 | module Draw 2 | 3 | import public Graphics.SDL 4 | import Control.ST 5 | import Control.ST.ImplicitCall 6 | 7 | %default total 8 | %access public export 9 | 10 | data Col = MkCol Int Int Int Int 11 | 12 | black : Col 13 | black = MkCol 0 0 0 255 14 | 15 | red : Col 16 | red = MkCol 255 0 0 255 17 | 18 | green : Col 19 | green = MkCol 0 255 0 255 20 | 21 | blue : Col 22 | blue = MkCol 0 0 255 255 23 | 24 | cyan : Col 25 | cyan = MkCol 0 255 255 255 26 | 27 | magenta : Col 28 | magenta = MkCol 255 0 255 255 29 | 30 | yellow : Col 31 | yellow = MkCol 255 255 0 255 32 | 33 | white : Col 34 | white = MkCol 255 255 255 255 35 | 36 | interface Draw (m : Type -> Type) where 37 | Surface : Type 38 | 39 | initWindow : Int -> Int -> ST m (Maybe Var) [addIfJust Surface] 40 | closeWindow : (win : Var) -> ST m () [Remove win Surface] 41 | 42 | flip : (win : Var) -> ST m () [win ::: Surface] 43 | poll : ST m (Maybe Event) [] 44 | 45 | filledRectangle : (win : Var) -> (Int, Int) -> (Int, Int) -> Col -> 46 | ST m () [win ::: Surface] 47 | drawLine : (win : Var) -> (Int, Int) -> (Int, Int) -> Col -> 48 | ST m () [win ::: Surface] 49 | 50 | 51 | Draw IO where 52 | Surface = State SDLSurface 53 | 54 | initWindow x y = do srf <- lift (startSDL x y) 55 | var <- new srf 56 | pure (Just var) 57 | 58 | closeWindow win = do lift endSDL 59 | delete win 60 | 61 | flip win = do srf <- read win 62 | lift (flipBuffers srf) 63 | poll = lift pollEvent 64 | 65 | filledRectangle win (x, y) (ex, ey) (MkCol r g b a) 66 | = do srf <- read win 67 | lift $ filledRect srf x y ex ey r g b a 68 | drawLine win (x, y) (ex, ey) (MkCol r g b a) 69 | = do srf <- read win 70 | lift $ drawLine srf x y ex ey r g b a 71 | 72 | -------------------------------------------------------------------------------- /examples/Graphics/Turtle.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Control.ST 4 | import Control.ST.ImplicitCall 5 | import Draw 6 | 7 | interface TurtleGraphics (m : Type -> Type) where 8 | Turtle : Type 9 | 10 | start : Int -> Int -> ST m (Maybe Var) [addIfJust Turtle] 11 | end : (t : Var) -> ST m () [Remove t Turtle] 12 | 13 | fd : (t : Var) -> Int -> ST m () [t ::: Turtle] 14 | rt : (t : Var) -> Int -> ST m () [t ::: Turtle] 15 | 16 | penup : (t : Var) -> ST m () [t ::: Turtle] 17 | pendown : (t : Var) -> ST m () [t ::: Turtle] 18 | col : (t : Var) -> Col -> ST m () [t ::: Turtle] 19 | 20 | -- Render the picture drawn so far in a window, and wait for a key press 21 | render : (t : Var) -> ST m () [t ::: Turtle] 22 | 23 | Line : Type 24 | Line = ((Int, Int), (Int, Int), Col) 25 | 26 | -- Implement turtle graphics in terms of existing stateful systems; 27 | -- 'Draw' provides a Surface to draw on, and three states. 28 | Draw m => TurtleGraphics m where 29 | Turtle = Composite [Surface {m}, -- surface to draw on 30 | State Col, -- pen colour 31 | State (Int, Int, Int, Bool), -- pen location/direction/down 32 | State (List Line)] -- lines to draw on render 33 | 34 | start x y = with ST do 35 | Just srf <- initWindow x y 36 | | Nothing => pure Nothing 37 | col <- new white 38 | pos <- new (320, 200, 0, True) 39 | lines <- new [] 40 | turtle <- new () 41 | combine turtle [srf, col, pos, lines] 42 | pure (Just turtle) 43 | 44 | end t = do [srf, col, pos, lines] <- split t 45 | closeWindow srf; delete col; delete pos; delete lines; delete t 46 | 47 | fd t dist = with ST do 48 | [srf, col, pos, lines] <- split t 49 | (x, y, d, p) <- read pos 50 | let x' = cast x + cast dist * sin (rad d) 51 | let y' = cast y + cast dist * cos (rad d) 52 | c <- read col 53 | ls <- read lines 54 | write lines (if p then ((x, y), (cast x', cast y'), c) :: ls 55 | else ls) 56 | write pos (cast x', cast y', d, p) 57 | combine t [srf, col, pos, lines] 58 | where rad : Int -> Double 59 | rad x = (cast x * pi) / 180.0 60 | 61 | rt t angle = with ST do 62 | [srf, col, pos, lines] <- split t 63 | (x, y, d, p) <- read pos 64 | write pos (x, y, d + angle `mod` 360, p) 65 | combine t [srf, col, pos, lines] 66 | 67 | penup t = with ST do 68 | [srf, col, pos, lines] <- split t 69 | (x, y, d, _) <- read pos 70 | write pos (x, y, d, False) 71 | combine t [srf, col, pos, lines] 72 | pendown t = with ST do 73 | [srf, col, pos, lines] <- split t 74 | (x, y, d, _) <- read pos 75 | write pos (x, y, d, True) 76 | combine t [srf, col, pos, lines] 77 | col t c = with ST do 78 | [srf, col, pos, lines] <- split t 79 | write col c 80 | combine t [srf, col, pos, lines] 81 | 82 | render t = with ST do 83 | [srf, col, pos, lines] <- split t 84 | filledRectangle srf (0, 0) (640, 480) black 85 | drawAll srf !(read lines) 86 | flip srf 87 | combine t [srf, col, pos, lines] 88 | Just ev <- poll 89 | | Nothing => render t 90 | case ev of 91 | KeyUp _ => pure () 92 | _ => render t 93 | where drawAll : (srf : Var) -> List Line -> ST m () [srf ::: Surface {m}] 94 | drawAll srf [] = pure () 95 | drawAll srf ((start, end, col) :: xs) 96 | = do drawLine srf start end col 97 | drawAll srf xs 98 | 99 | turtle : (ConsoleIO m, TurtleGraphics m) => ST m () [] 100 | turtle = with ST do 101 | Just t <- start 640 480 102 | | Nothing => putStr "Can't make turtle\n" 103 | col t yellow 104 | fd t 100; rt t 90 105 | col t green 106 | fd t 100; rt t 90 107 | col t red 108 | fd t 100; rt t 90 109 | col t blue 110 | fd t 100; rt t 90 111 | render t 112 | end t 113 | 114 | main : IO () 115 | main = run turtle 116 | 117 | -------------------------------------------------------------------------------- /examples/HTTP/HTTPMessage.idr: -------------------------------------------------------------------------------- 1 | module HTTPMessage 2 | 3 | import Control.ST 4 | 5 | public export 6 | data ReqType = GET String | POST String -- Just support the basics... 7 | 8 | public export 9 | data Connection = KeepAlive | Close 10 | 11 | public export 12 | record HTTPContent where 13 | constructor MkContent 14 | keep : Connection 15 | header : List (String, String) 16 | content : String 17 | 18 | public export 19 | record HTTPRequest where 20 | constructor MkReq 21 | reqType : ReqType 22 | version : String 23 | content : HTTPContent 24 | 25 | public export 26 | data RespCode = MkCode Int 27 | 28 | public export 29 | record HTTPResponse where 30 | constructor MkResponse 31 | code : RespCode 32 | version : String 33 | content : HTTPContent 34 | 35 | export 36 | parseRequest : String -> Maybe HTTPRequest 37 | parseRequest _ = Nothing 38 | 39 | public export 40 | HTTPProc : (Type -> Type) -> Type 41 | HTTPProc m = HTTPRequest -> ST m HTTPResponse [] 42 | 43 | public export 44 | Show HTTPResponse where 45 | show x = ?show_rhs 46 | 47 | -------------------------------------------------------------------------------- /examples/HTTP/HTTPServer.idr: -------------------------------------------------------------------------------- 1 | import Network.Socket 2 | import Control.ST 3 | import Control.ST.ImplicitCall 4 | 5 | import Network 6 | import Threads 7 | import HTTPMessage 8 | 9 | %default covering 10 | 11 | -- States of a connected session. 12 | data SessionState = Waiting -- waiting for the client to send 13 | | Processing Connection -- calculating a response to send back 14 | -- 'Connection' is either 'Close' or 'KeepAlive' and notes whether the 15 | -- session should continue waiting for client requests after the response 16 | -- is sent 17 | | Done -- received message, replied to it, no more requests expected 18 | 19 | onResponse : Connection -> SessionState 20 | onResponse KeepAlive = Waiting -- keep alive, so go back to the start 21 | onResponse Close = Done -- not keep alive, so don't accept any more requests 22 | 23 | interface HTTPSession (m : Type -> Type) where 24 | -- A connected session 25 | Session : SessionState -> Type 26 | -- A server listening for connections 27 | Server : Type 28 | 29 | -- Receive an HTTP request. If nothing is received (timeout) move to the 30 | -- 'Done' state. Otherwise move to the 'Processing' state and note whether 31 | -- the request wanted to keep the connection alive 32 | recvReq : (conn : Var) -> (timeout : Int) -> 33 | ST m (Maybe HTTPRequest) 34 | [conn ::: Session Waiting :-> 35 | \res => Session (case res of 36 | Nothing => Done -- timeout 37 | Just req => Processing (keep (content req)))] 38 | 39 | -- Send a response. Move to the 'Done' state if keep-alive is not set, 40 | -- otherwise move back to the Waiting state. (See 'onResponse') 41 | sendResp : (conn : Var) -> (resp : HTTPResponse) -> 42 | ST m () 43 | [conn ::: Session (Processing keepalive) :-> 44 | Session (onResponse (keep (content resp)))] 45 | 46 | -- Create a server 47 | start : (port : Int) -> ST m (Maybe Var) [addIfJust Server] 48 | -- Close a server 49 | quit : (srv : Var) -> ST m () [remove srv Server] 50 | -- Finish a connection 51 | done : (conn : Var) -> ST m () [remove conn (Session Done)] 52 | 53 | -- Listen for an incoming connection. If there is one, create a session 54 | -- with a connection in the Waiting state 55 | accept : (srv : Var) -> 56 | ST m (Maybe Var) 57 | [srv ::: Server, addIfJust (Session Waiting)] 58 | 59 | using (ConsoleIO io, HTTPSession io, Conc io) 60 | httpSession : (conn : Var) -> 61 | HTTPProc io -> -- Function to process request 62 | ST io () [remove conn (Session {m=io} Waiting)] 63 | httpSession conn proc = 64 | do Just req <- recvReq conn 30 65 | | Nothing => done conn -- Nothing received/timeout 66 | response <- proc req 67 | sendResp conn response 68 | continue (keep (content response)) proc -- continue if keep-alive is set in response 69 | where continue : (keep : _) -> HTTPProc io -> 70 | ST io () [remove conn (Session {m=io} (onResponse keep))] 71 | continue KeepAlive proc = httpSession conn proc 72 | continue Close proc = done conn 73 | 74 | httpLoop : (srv : Var) -> HTTPProc io -> ST io () [srv ::: Server {m=io}] 75 | httpLoop srv proc 76 | = do Just conn <- accept srv 77 | | Nothing => putStr "accept failed\n" 78 | putStr "Connection received\n" 79 | fork (httpSession conn proc) 80 | httpLoop srv proc 81 | 82 | httpServer : HTTPProc io -> ST io () [] 83 | httpServer proc 84 | = do Just srv <- start 8080 85 | | Nothing => putStr "Can't start server\n" 86 | httpLoop srv proc 87 | quit srv 88 | 89 | implementation (ConsoleIO io, BufferedSocket io) => HTTPSession io where 90 | Session st = OpenSocket {m=io} 91 | Server = Sock {m=io} Listening 92 | 93 | recvReq conn timeout = ?recvReq_rhs 94 | 95 | sendResp conn resp = sendLine conn (show resp) 96 | 97 | start port = do Right sock <- socket Stream 98 | | Left err => pure Nothing 99 | Right () <- bind sock Nothing port 100 | | Left err => do remove sock; pure Nothing 101 | Right () <- listen sock 102 | | Left err => do remove sock; pure Nothing 103 | putStrLn "Off we go!" 104 | pure (Just sock) 105 | 106 | quit sock = do close sock; remove sock 107 | done conn = closeBuffered conn 108 | accept sock = do Right conn <- accept sock 109 | | Left err => pure Nothing 110 | bsock <- makeBuffered conn 111 | pure (Just bsock) 112 | 113 | -- A dummy response, for a hello world web server 114 | dummyResp : HTTPProc io 115 | dummyResp req 116 | = pure $ MkResponse (MkCode 200) "HTTP/1.1" 117 | (MkContent (keep (content req)) 118 | [("Content-type", "text/html")] "Hello!") 119 | 120 | main : IO () 121 | main = run (httpServer dummyResp) 122 | 123 | -------------------------------------------------------------------------------- /examples/HTTP/Network.idr: -------------------------------------------------------------------------------- 1 | module Network 2 | 3 | import Control.ST 4 | import Control.ST.ImplicitCall 5 | import Network.Socket 6 | 7 | public export 8 | data SocketState = Ready 9 | | Bound 10 | | Listening 11 | | Open 12 | | Closed 13 | 14 | public export 15 | data CloseOK : SocketState -> Type where 16 | CloseOpen : CloseOK Open 17 | CloseListening : CloseOK Listening 18 | 19 | -- Sockets API. By convention, the methods return 'Left' on failure or 20 | -- 'Right' on success (even if the error/result is merely unit). 21 | public export 22 | interface Sockets (m : Type -> Type) where 23 | Sock : SocketState -> Type 24 | 25 | -- Create a new socket. If successful, it's in the Closed state 26 | socket : SocketType -> 27 | ST m (Either () Var) [addIfRight (Sock Ready)] 28 | 29 | -- Bind a socket to a port. If successful, it's moved to the Bound state. 30 | bind : (sock : Var) -> (addr : Maybe SocketAddress) -> (port : Port) -> 31 | ST m (Either () ()) 32 | [sock ::: Sock Ready :-> (Sock Closed `or` Sock Bound)] 33 | -- Listen for connections on a socket. If successful, it's moved to the 34 | -- Listening state 35 | listen : (sock : Var) -> 36 | ST m (Either () ()) 37 | [sock ::: Sock Bound :-> (Sock Closed `or` Sock Listening)] 38 | -- Accept an incoming connection on a Listening socket. If successful, 39 | -- creates a new socket in the Open Server state, and keeps the existing 40 | -- socket in the Listening state 41 | accept : (sock : Var) -> 42 | ST m (Either () Var) 43 | [sock ::: Sock Listening, addIfRight (Sock Open)] 44 | 45 | -- Connect to a remote address on a socket. If successful, moves to the 46 | -- Open Client state 47 | connect : (sock : Var) -> SocketAddress -> Port -> 48 | ST m (Either () ()) 49 | [sock ::: Sock Ready :-> (Sock Closed `or` Sock Open)] 50 | 51 | -- Close an Open or Listening socket 52 | close : (sock : Var) -> 53 | {auto prf : CloseOK st} -> 54 | ST m () [sock ::: Sock st :-> Sock Closed] 55 | 56 | remove : (sock : Var) -> 57 | ST m () [Remove sock (Sock Closed)] 58 | 59 | -- Send a message on a connected socket. 60 | send : (sock : Var) -> String -> 61 | ST m (Either () ()) [sock ::: Sock Open] 62 | -- Receive a message on a connected socket 63 | recv : (sock : Var) -> 64 | ST m (Either () String) [sock ::: Sock Open] 65 | export 66 | implementation Sockets IO where 67 | Sock _ = State Socket 68 | 69 | socket ty = do Right sock <- lift $ Socket.socket AF_INET ty 0 70 | | Left err => pure (Left ()) 71 | lbl <- new sock 72 | pure (Right lbl) 73 | 74 | bind sock addr port = do ok <- lift $ bind !(read sock) addr port 75 | if ok /= 0 76 | then pure (Left ()) 77 | else pure (Right ()) 78 | listen sock = do ok <- lift $ listen !(read sock) 79 | if ok /= 0 80 | then pure (Left ()) 81 | else pure (Right ()) 82 | accept sock = do Right (conn, addr) <- lift $ accept !(read sock) 83 | | Left err => pure (Left ()) 84 | lbl <- new conn 85 | returning (Right lbl) (toEnd lbl) 86 | 87 | connect sock addr port 88 | = do ok <- lift $ connect !(read sock) addr port 89 | if ok /= 0 90 | then pure (Left ()) 91 | else pure (Right ()) 92 | close sock = do lift $ close !(read sock) 93 | pure () 94 | remove sock = delete sock 95 | 96 | send sock msg = do Right _ <- lift $ send !(read sock) msg 97 | | Left _ => pure (Left ()) 98 | pure (Right ()) 99 | recv sock = do Right (msg, len) <- lift $ recv !(read sock) 1024 -- Yes, yes... 100 | | Left _ => pure (Left ()) 101 | pure (Right msg) 102 | 103 | -- A socket which buffers what has been read so far, and allows access to 104 | -- data received line by line rather than chunk by chunk. 105 | public export 106 | interface Sockets m => BufferedSocket (m : Type -> Type) where 107 | OpenSocket : Type 108 | 109 | makeBuffered : (sock : Var) -> 110 | ST m Var [remove sock (Sock {m} Open), add OpenSocket] 111 | closeBuffered : (sock : Var) -> ST m () [remove sock OpenSocket] 112 | 113 | -- Get the next line from a socket, if any 114 | readLine : (sock : Var) -> ST m (Maybe String) [sock ::: OpenSocket] 115 | 116 | sendLine : (sock : Var) -> String -> ST m () [sock ::: OpenSocket] 117 | 118 | -- Receive all the messages from a socket and buffer them 119 | bufferedRecv : (sock : Var) -> ST m () [sock ::: OpenSocket] 120 | 121 | getFirstLine : String -> Maybe (String, String) 122 | getFirstLine "" = Nothing 123 | getFirstLine str = case span (/='\n') str of 124 | (str', "") => Just (str', "") 125 | (str', rest) => Just (str', assert_total (strTail rest)) 126 | 127 | -- Receive until something received has a '\n' in it 128 | keepRecv : Sockets m => (sock : Var) -> (acc : String) -> 129 | ST m String [sock ::: Sock {m} Open] 130 | keepRecv sock acc = if elem '\n' (unpack acc) 131 | then pure acc 132 | else do Right dat <- recv sock 133 | | Left () => pure acc 134 | keepRecv sock (acc ++ dat) 135 | 136 | export 137 | implementation Sockets m => BufferedSocket m where 138 | OpenSocket = Composite [Sock {m} Open, -- underlying socket 139 | State String] -- data so far 140 | 141 | makeBuffered sock = do str <- new "" 142 | buf <- new () 143 | combine buf [sock, str] 144 | pure buf 145 | 146 | closeBuffered rec = do [sock, buf] <- split rec 147 | delete rec; delete buf; close sock; remove sock 148 | 149 | readLine rec = do bufferedRecv rec 150 | [sock, buf] <- split rec 151 | str <- read buf 152 | case getFirstLine str of 153 | Nothing => do combine rec [sock, buf] 154 | pure Nothing 155 | Just (str', rest) => 156 | do write buf rest 157 | combine rec [sock, buf] 158 | pure (Just str') 159 | 160 | sendLine rec msg = do [sock, buf] <- split rec 161 | send sock msg 162 | combine rec [sock, buf] 163 | 164 | bufferedRecv rec = do [sock, buf] <- split rec 165 | str <- read buf 166 | dat <- keepRecv sock str 167 | write buf dat 168 | combine rec [sock, buf] 169 | 170 | -------------------------------------------------------------------------------- /examples/HTTP/Threads.idr: -------------------------------------------------------------------------------- 1 | module Threads 2 | 3 | import Control.ST 4 | import System.Concurrency.Channels 5 | import System 6 | 7 | public export 8 | interface Conc (m : Type -> Type) where 9 | -- 'Fork' sends some resources to the spawned thread, and keeps the rest 10 | -- for the parent 11 | -- TODO: Note that there is nothing here yet about how the threads 12 | -- communicate with each other... 13 | fork : (thread : STrans m () thread_res (const [])) -> 14 | {auto tprf : SubRes thread_res all} -> 15 | STrans m () all (const (kept tprf)) 16 | 17 | export 18 | implementation Conc IO where 19 | fork thread 20 | = do threadEnv <- dropSub 21 | lift $ spawn (do runWith threadEnv thread 22 | pure ()) 23 | pure () 24 | -------------------------------------------------------------------------------- /examples/Login.idr: -------------------------------------------------------------------------------- 1 | import Control.ST 2 | 3 | data Access = LoggedOut | LoggedIn 4 | data LoginResult = OK | BadPassword 5 | 6 | interface DataStore (m : Type -> Type) where 7 | Store : Access -> Type 8 | 9 | connect : ST m Var [add (Store LoggedOut)] 10 | disconnect : (store : Var) -> 11 | ST m () [Remove store (Store LoggedOut)] 12 | login : (store : Var) -> 13 | ST m LoginResult [store ::: Store LoggedOut :-> 14 | (\res => Store (case res of 15 | OK => LoggedIn 16 | BadPassword => LoggedOut))] 17 | logout : (store : Var) -> 18 | ST m () [store ::: Store LoggedIn :-> Store LoggedOut] 19 | readSecret : (store : Var) -> 20 | ST m String [store ::: Store LoggedIn] 21 | 22 | getData : (ConsoleIO m, DataStore m) => ST m () [] 23 | getData = do st <- connect 24 | OK <- login st 25 | | BadPassword => do putStr "Failure\n" 26 | disconnect st 27 | secret <- readSecret st 28 | putStr ("Secret is: " ++ show secret ++ "\n") 29 | logout st 30 | disconnect st 31 | 32 | -- badGet : DataStore m => ST m () [] 33 | -- badGet = do st <- connect 34 | -- secret <- readSecret st 35 | -- ?more 36 | 37 | DataStore IO where 38 | Store x = State String -- represents secret data 39 | 40 | connect = do store <- new "Secret Data" 41 | pure store 42 | 43 | disconnect store = delete store 44 | 45 | login store = do putStr "Enter password: " 46 | p <- getStr 47 | if p == "Mornington Crescent" 48 | then pure OK 49 | else pure BadPassword 50 | logout store = pure () 51 | 52 | readSecret store = read store 53 | 54 | main : IO () 55 | main = run getData 56 | 57 | -------------------------------------------------------------------------------- /examples/Net/EchoSimple.idr: -------------------------------------------------------------------------------- 1 | import Network.Socket 2 | import Network 3 | import Control.ST 4 | import Control.ST.ImplicitCall 5 | 6 | echoServer : (ConsoleIO m, Sockets m) => (sock : Var) -> 7 | ST m () [Remove sock (Sock {m} Listening)] 8 | echoServer sock = 9 | do Right new <- accept sock 10 | | Left err => do close sock; remove sock 11 | Right msg <- recv new 12 | | Left err => do close sock; remove sock; remove new 13 | putStr (msg ++ "\n") 14 | Right ok <- send new ("You said " ++ msg) 15 | | Left err => do remove new; close sock; remove sock 16 | close new; remove new; echoServer sock 17 | 18 | startServer : (ConsoleIO m, Sockets m) => ST m () [] 19 | startServer = 20 | do Right sock <- socket Stream | Left err => pure () 21 | Right ok <- bind sock Nothing 9442 | Left err => remove sock 22 | Right ok <- listen sock | Left err => remove sock 23 | echoServer sock 24 | 25 | main : IO () 26 | main = run startServer 27 | 28 | -------------------------------------------------------------------------------- /examples/Net/Network.idr: -------------------------------------------------------------------------------- 1 | module Network 2 | 3 | import Control.ST 4 | import Network.Socket 5 | 6 | public export 7 | data SocketState = Ready 8 | | Bound 9 | | Listening 10 | | Open 11 | | Closed 12 | 13 | public export 14 | data CloseOK : SocketState -> Type where 15 | CloseOpen : CloseOK Open 16 | CloseListening : CloseOK Listening 17 | 18 | -- Sockets API. By convention, the methods return 'Left' on failure or 19 | -- 'Right' on success (even if the error/result is merely unit). 20 | public export 21 | interface Sockets (m : Type -> Type) where 22 | Sock : SocketState -> Type 23 | 24 | -- Create a new socket. If successful, it's in the Closed state 25 | socket : SocketType -> 26 | ST m (Either () Var) [addIfRight (Sock Ready)] 27 | 28 | -- Bind a socket to a port. If successful, it's moved to the Bound state. 29 | bind : (sock : Var) -> (addr : Maybe SocketAddress) -> (port : Port) -> 30 | ST m (Either () ()) 31 | [sock ::: Sock Ready :-> (Sock Closed `or` Sock Bound)] 32 | -- Listen for connections on a socket. If successful, it's moved to the 33 | -- Listening state 34 | listen : (sock : Var) -> 35 | ST m (Either () ()) 36 | [sock ::: Sock Bound :-> (Sock Closed `or` Sock Listening)] 37 | -- Accept an incoming connection on a Listening socket. If successful, 38 | -- creates a new socket in the Open Server state, and keeps the existing 39 | -- socket in the Listening state 40 | accept : (sock : Var) -> 41 | ST m (Either () Var) 42 | [sock ::: Sock Listening, addIfRight (Sock Open)] 43 | 44 | -- Connect to a remote address on a socket. If successful, moves to the 45 | -- Open Client state 46 | connect : (sock : Var) -> SocketAddress -> Port -> 47 | ST m (Either () ()) 48 | [sock ::: Sock Ready :-> (Sock Closed `or` Sock Open)] 49 | 50 | -- Close an Open or Listening socket 51 | close : (sock : Var) -> 52 | {auto prf : CloseOK st} -> 53 | ST m () [sock ::: Sock st :-> Sock Closed] 54 | 55 | remove : (sock : Var) -> 56 | ST m () [Remove sock (Sock Closed)] 57 | 58 | -- Send a message on a connected socket. 59 | -- On failure, move the socket to the Closed state 60 | send : (sock : Var) -> String -> 61 | ST m (Either () ()) 62 | [sock ::: Sock Open :-> (Sock Closed `or` Sock Open)] 63 | -- Receive a message on a connected socket 64 | -- On failure, move the socket to the Closed state 65 | recv : (sock : Var) -> 66 | ST m (Either () String) 67 | [sock ::: Sock Open :-> (Sock Closed `or` Sock Open)] 68 | 69 | export 70 | implementation Sockets IO where 71 | Sock _ = State Socket 72 | 73 | socket ty = do Right sock <- lift $ Socket.socket AF_INET ty 0 74 | | Left err => pure (Left ()) 75 | lbl <- new sock 76 | pure (Right lbl) 77 | 78 | bind sock addr port = do ok <- lift $ bind !(read sock) addr port 79 | if ok /= 0 80 | then pure (Left ()) 81 | else pure (Right ()) 82 | listen sock = do ok <- lift $ listen !(read sock) 83 | if ok /= 0 84 | then pure (Left ()) 85 | else pure (Right ()) 86 | accept sock = do Right (conn, addr) <- lift $ accept !(read sock) 87 | | Left err => pure (Left ()) 88 | lbl <- new conn 89 | toEnd lbl 90 | pure (Right lbl) 91 | 92 | connect sock addr port 93 | = do ok <- lift $ connect !(read sock) addr port 94 | if ok /= 0 95 | then pure (Left ()) 96 | else pure (Right ()) 97 | close sock = do lift $ close !(read sock) 98 | pure () 99 | remove sock = delete sock 100 | 101 | send sock msg = do Right _ <- lift $ send !(read sock) msg 102 | | Left _ => pure (Left ()) 103 | pure (Right ()) 104 | recv sock = do Right (msg, len) <- lift $ recv !(read sock) 1024 -- Yes, yes... 105 | | Left _ => pure (Left ()) 106 | pure (Right msg) 107 | 108 | -------------------------------------------------------------------------------- /examples/Net/RandServer.idr: -------------------------------------------------------------------------------- 1 | import Network.Socket 2 | import Control.ST 3 | import Control.ST.ImplicitCall 4 | import System 5 | 6 | import Network 7 | import Threads 8 | 9 | {- A random number server. 10 | 11 | This receives requests from a client, as a number, and sends a reply 12 | which is a random number within the requested bound. 13 | 14 | There are two states: one for the server, and one for a connected session. 15 | The server repeatedly listens for requests and creats a session for each 16 | incoming request. 17 | -} 18 | 19 | -- States of a connected session 20 | data SessionState = Waiting -- waiting for the client to send 21 | | Processing -- calculating a response to send back 22 | | Done -- received message and replied to it 23 | 24 | interface RandomSession (m : Type -> Type) where 25 | -- A connected session 26 | Connection : SessionState -> Type 27 | -- A server listening for connections 28 | Server : Type 29 | 30 | -- Receive a request on a Waiting connection. If there is a request 31 | -- available, move to the Processing state 32 | recvReq : (conn : Var) -> 33 | ST m (Maybe Integer) 34 | [conn ::: Connection Waiting :-> 35 | \res => Connection (case res of 36 | Nothing => Done 37 | Just _ => Processing)] 38 | -- Send a reply, and move the connection to the Done state 39 | sendResp : (conn : Var) -> Integer -> 40 | ST m () [conn ::: Connection Processing :-> Connection Done] 41 | 42 | -- Create a server 43 | start : ST m (Maybe Var) [addIfJust Server] 44 | -- Close a server 45 | quit : (srv : Var) -> ST m () [Remove srv Server] 46 | -- Finish a connection 47 | done : (conn : Var) -> ST m () [Remove conn (Connection Done)] 48 | 49 | -- Listen for an incoming connection. If there is one, create a session 50 | -- with a connection in the Waiting state 51 | accept : (srv : Var) -> 52 | ST m (Maybe Var) 53 | [srv ::: Server, addIfJust (Connection Waiting)] 54 | 55 | interface Sleep (m : Type -> Type) where 56 | usleep : (i : Int) -> { auto prf : So (i >= 0 && i <= 1000000) } -> 57 | STrans m () xs (const xs) 58 | 59 | Sleep IO where 60 | usleep x = lift (System.usleep x) 61 | 62 | 63 | using (Sleep io, ConsoleIO io, RandomSession io, Conc io) 64 | rndSession : (conn : Var) -> 65 | ST io () [Remove conn (Connection {m=io} Waiting)] 66 | rndSession conn = 67 | do Just bound <- call (recvReq conn) 68 | | Nothing => do putStr "Nothing received\n" 69 | call (done conn) 70 | putStr "Calculating reply...\n" 71 | usleep 1000000 72 | sendResp conn bound -- (seed `mod` (bound + 1)) 73 | call (done conn) 74 | 75 | rndLoop : (srv : Var) -> ST io () [srv ::: Server {m=io}] 76 | rndLoop srv 77 | = do Just conn <- accept srv 78 | | Nothing => putStr "accept failed\n" 79 | putStr "Connection received\n" 80 | fork (rndSession conn) 81 | rndLoop srv 82 | 83 | rndServer : ST io () [] 84 | rndServer 85 | = do Just srv <- start 86 | | Nothing => putStr "Can't start server\n" 87 | call (rndLoop srv) 88 | quit srv 89 | 90 | implementation (ConsoleIO io, Sockets io) => RandomSession io where 91 | 92 | -- Connections and servers are composite states, so to implement things 93 | -- in terms of them we need to 'split' at the state and 'combine' at the 94 | -- end, in every method 95 | Connection Waiting = Composite [State Integer, Sock {m=io} Open] 96 | Connection Processing = Composite [State Integer, Sock {m=io} Open] 97 | Connection Done = Composite [State Integer, Sock {m=io} Closed] 98 | 99 | Server = Composite [State Integer, Sock {m=io} Listening] 100 | 101 | recvReq rec = do [seed, conn] <- split rec 102 | Right msg <- recv conn 103 | | Left err => do combine rec [seed, conn] 104 | pure Nothing 105 | putStr ("Incoming " ++ show msg ++ "\n") 106 | combine rec [seed, conn] 107 | pure (Just (cast msg)) 108 | 109 | sendResp rec val = do [seed, conn] <- split rec 110 | Right () <- send conn (cast (!(read seed) `mod` val) ++ "\n") 111 | | Left err => do combine rec [seed, conn] 112 | pure () 113 | close conn 114 | combine rec [seed, conn] 115 | 116 | start = do srv <- new () 117 | Right sock <- socket Stream 118 | | Left err => do delete srv; pure Nothing 119 | Right () <- bind sock Nothing 9442 120 | | Left err => do call (remove sock) 121 | delete srv 122 | pure Nothing 123 | Right () <- listen sock 124 | | Left err => do call (remove sock) 125 | delete srv 126 | pure Nothing 127 | putStr "Started server\n" 128 | seed <- new 12345 129 | combine srv [seed, sock] 130 | pure (Just srv) 131 | 132 | quit srv = do [seed, sock] <- split srv -- need to delete everything 133 | close sock; remove sock; delete seed; delete srv 134 | done conn = do [seed, sock] <- split conn -- need to delete connection data 135 | remove sock; delete seed; delete conn 136 | 137 | accept srv = do [seed, sock] <- split srv 138 | seedVal <- read seed 139 | write seed ((1664525 * seedVal + 1013904223) 140 | `prim__sremBigInt` (pow 2 32)) 141 | Right conn <- accept sock 142 | | Left err => do combine srv [seed, sock] 143 | pure Nothing -- no incoming message 144 | -- We're sending the seed to the child process and keeping 145 | -- a copy ourselves, so we need to explicitly make a new 146 | -- one 147 | rec <- new () 148 | seed' <- new seedVal 149 | combine rec [seed', conn] 150 | combine srv [seed, sock] 151 | toEnd rec 152 | pure (Just rec) 153 | 154 | main : IO () 155 | main = run rndServer 156 | 157 | -------------------------------------------------------------------------------- /examples/Net/Threads.idr: -------------------------------------------------------------------------------- 1 | module Threads 2 | 3 | import Control.ST 4 | import System.Concurrency.Channels 5 | import System 6 | 7 | public export 8 | interface Conc (m : Type -> Type) where 9 | -- 'Fork' sends some resources to the spawned thread, and keeps the rest 10 | -- for the parent 11 | -- TODO: Note that there is nothing here yet about how the threads 12 | -- communicate with each other... 13 | fork : (thread : STrans m () thread_res (const [])) -> 14 | {auto tprf : SubCtxt thread_res all} -> 15 | STrans m () all (const (kept tprf)) 16 | 17 | export 18 | implementation Conc IO where 19 | fork thread 20 | = do threadEnv <- dropSubCtxt 21 | lift $ spawn (do runWith threadEnv thread 22 | pure ()) 23 | pure () 24 | -------------------------------------------------------------------------------- /examples/Sessions/Conc.idr: -------------------------------------------------------------------------------- 1 | import Control.ST 2 | import Control.ST.ImplicitCall 3 | import System.Concurrency.Channels 4 | 5 | data Actions : Type where 6 | Send : (a : Type) -> (a -> Actions) -> Actions 7 | Recv : (a : Type) -> (a -> Actions) -> Actions 8 | Done : Actions 9 | 10 | dual : Actions -> Actions 11 | dual (Send a f) = Recv a (\x => dual (f x)) 12 | dual (Recv a f) = Send a (\x => dual (f x)) 13 | dual Done = Done 14 | 15 | data ServerState = Ready | Processed 16 | 17 | interface Conc (m : Type -> Type) where 18 | data Channel : Actions -> Type 19 | data Server : Actions -> Type 20 | Accepting : ServerState -> Actions -> Type 21 | 22 | -- Fork a child thread. Share current resources (all) between child 23 | -- thread (thread_res) and parent thread (kept tprf). 24 | -- The child thread has a channel with the 'child' protocol, and the parent 25 | -- thread has its dual 26 | fork : (thread : (chan : Var) -> 27 | STrans m () ((chan ::: Channel child) :: thread_res) 28 | (const [])) -> 29 | {auto tprf : SubRes thread_res all} -> 30 | STrans m Var all (\chan => 31 | ((chan ::: Channel (dual child)) :: kept tprf)) 32 | 33 | -- Start a server running, ready to accept connections to create a channel 34 | -- which runs 'proto'. We don't provide a way to delete 'Accepting', so 35 | -- this has to run forever... (or crash...) 36 | -- Returns a reference to the server which we can connect to as many 37 | -- times as we like. 38 | -- (TODO: Make this work as a total, productive function) 39 | start : (server : (acc : Var) -> 40 | STrans m () ((acc ::: Accepting Ready proto) :: thread_res) 41 | (const ((acc ::: Accepting Processed proto) :: thread_res))) -> 42 | {auto tprf : SubRes thread_res all} -> 43 | STrans m (Server proto) all (const (kept tprf)) 44 | 45 | -- Listen for a connection on acc, making a new channel 46 | listen : (acc : Var) -> (timeout : Int) -> 47 | ST m (Maybe Var) [acc ::: Accepting Ready proto :-> 48 | Accepting Processed proto, 49 | addIfJust (Channel proto)] 50 | -- Connect to a server and make a new channel for talking to it with 51 | -- the appropriate protocol 52 | connect : Server proto -> ST m Var [add (Channel (dual proto))] 53 | 54 | -- Can only 'send' if the channel is ready to send a ty 55 | send : (chan : Var) -> (val : ty) -> 56 | ST m () [chan ::: Channel (Send ty f) :-> Channel (f val)] 57 | -- Can only 'recv' if the channel is ready to receive a ty 58 | recv : (chan : Var) -> 59 | ST m ty [chan ::: Channel (Recv ty f) :-> (\res => Channel (f res))] 60 | 61 | -- Can only 'close' when a protocol is Done 62 | close : (chan : Var) -> ST m () [Remove chan (Channel Done)] 63 | 64 | ChildProc : Var -> (m : Type -> Type) -> Conc m => Actions -> Action () 65 | ChildProc chan m proto = Remove chan (Channel {m} proto) 66 | 67 | ServerProc : Var -> (m : Type -> Type) -> Conc m => Actions -> Action () 68 | ServerProc chan m proto = chan ::: Accepting {m} Ready proto :-> 69 | Accepting {m} Processed proto 70 | 71 | -- A server which receives two Ints then sends an Int back 72 | AddServer : Actions 73 | AddServer = Recv Int (const (Recv Int (const (Send Int (const Done))))) 74 | 75 | -- addServer sits there waiting for connections. When they arrive, talk 76 | -- to the client using the 'AddServer' protocol. 77 | -- The type says that we start ready to receive connections on the 78 | -- 'server' resource, and by the end we've deleted the 'server' resource. 79 | 80 | -- Since there's no way to delete the 'server' resource, we'll have to 81 | -- keep looping... (TODO: We don't actually guarantee that we'll respond 82 | -- to any requests either... so when we work out how to make this total, 83 | -- make sure we do that as well.) 84 | addServer : (ConsoleIO m, Conc m) => 85 | (counter : Var) -> 86 | (server : Var) -> 87 | ST m () [ServerProc server m AddServer, 88 | counter ::: State Int] 89 | addServer counter server = with ST do 90 | Just chan <- listen server 1 91 | | Nothing => pure () 92 | val <- read counter 93 | putStr $ "Request number " ++ show val ++ "\n" 94 | write counter (val + 1) 95 | num1 <- recv chan 96 | num2 <- recv chan 97 | send chan (num1 + num2) 98 | close chan 99 | 100 | 101 | -- Connect to a server which is using the 'AddServer' protocol and ask 102 | -- it to add things 103 | callAdd : (ConsoleIO m, Conc m) => 104 | Server {m} AddServer -> Int -> Int -> ST m () [] 105 | callAdd server x y = with ST do 106 | chan <- connect server 107 | send chan x 108 | send chan y 109 | putStr "Adding is happening\n" 110 | ans <- recv chan 111 | close chan 112 | putStr $ "Result: " ++ show ans ++ "\n" 113 | 114 | -- Start up an addition server, and ask it a couple of questions 115 | runAddServer : (ConsoleIO m, Conc m) => ST m () [] 116 | runAddServer = with ST do 117 | putStr "Starting server\n" 118 | counter <- new 0 119 | serverID <- start (addServer counter) 120 | callAdd serverID 20 22 121 | callAdd serverID 40 54 122 | 123 | %hint 124 | inStateEnd : InState lbl st (xs ++ [lbl ::: st]) 125 | inStateEnd {xs = []} = Here 126 | inStateEnd {xs = (x :: xs)} = There inStateEnd 127 | 128 | -- To run our programs, we need to implement the 'Conc' interface under IO 129 | -- This is really hacky and involves lots of unsafe primitives. Fortunately, 130 | -- we only have to get this right once... but we do have to get it right. 131 | 132 | -- So. Move along. Nothing to see here :). 133 | 134 | -- If any of the believe_mes in here get executed, we have a disastrous 135 | -- failure caused by being out of memory (or other similar problem). 136 | -- Nevertheless, TODO: clean them up. (It can be done with proper error 137 | -- handling) 138 | Conc IO where 139 | Channel x = State Channels.Channel 140 | Server x = PID 141 | Accepting _ _ = () 142 | 143 | fork thread {tprf} = do 144 | threadEnv <- dropSub {prf=tprf} 145 | -- Need to create a dummy resource to feed to the new 146 | -- thread, to stand for the 'Channel' variable which 147 | -- we'll create a proper value for when we spawn. 148 | dummy <- new () 149 | Just pid <- lift $ spawn (do Just chan <- listen 1 150 | runWith (Value chan :: threadEnv) 151 | (thread dummy) 152 | pure ()) 153 | | Nothing => believe_me () -- Disastrous failure... 154 | delete dummy 155 | Just ch <- lift $ connect pid 156 | | Nothing => believe_me () -- Disastrous failure... 157 | new ch 158 | 159 | start server {thread_res} {tprf} = do 160 | threadEnv <- dropSub {prf=tprf} 161 | -- Need to create a dummy resource to feed to the new 162 | -- thread, to stand for the 'Accepting' resource which 163 | -- is only there to say what kind of protocols it will 164 | -- work with 165 | dummy <- new () 166 | Just pid <- lift $ spawn (do runWithLoop 167 | (() :: threadEnv) 168 | forever 169 | (serverLoop server dummy) 170 | pure ()) 171 | | Nothing => believe_me () -- Disastrous failure... 172 | delete dummy 173 | pure pid 174 | where serverLoop : ((acc : Var) -> 175 | STrans IO () ((acc ::: ()) :: thread_res) 176 | (const ((acc ::: ()) :: thread_res))) -> 177 | (acc : Var) -> STransLoop IO () ((acc ::: ()) :: thread_res) 178 | (const ((acc ::: ()) :: thread_res)) 179 | serverLoop f acc = do f acc 180 | serverLoop f acc 181 | 182 | listen acc timeout = do Just ch <- lift $ listen timeout 183 | | Nothing => pure Nothing 184 | chvar <- new ch 185 | toEnd chvar 186 | pure (Just chvar) 187 | connect pid = do Just ch <- lift $ connect pid 188 | | Nothing => believe_me () -- Disastrous failure... 189 | new ch 190 | send chan val = do ch <- read chan 191 | lift $ unsafeSend ch val 192 | pure () 193 | recv {ty} chan = do ch <- read chan 194 | Just val <- lift $ unsafeRecv ty ch 195 | | Nothing => believe_me () -- Can't happen! 196 | pure val 197 | close chan = delete chan 198 | 199 | -- Finally, run the thing 200 | main : IO () 201 | main = run runAddServer 202 | 203 | -- Local Variables: 204 | -- idris-packages: ("contrib") 205 | -- End: 206 | -------------------------------------------------------------------------------- /src/Control/ST.idr: -------------------------------------------------------------------------------- 1 | module Control.ST 2 | 3 | import Language.Reflection.Utils 4 | 5 | %default total 6 | 7 | infix 5 ::: 8 | 9 | {- A resource is a pair of a label and the current type stored there -} 10 | public export 11 | data Resource : Type where 12 | MkRes : label -> Type -> Resource 13 | 14 | %error_reverse 15 | public export 16 | (:::) : label -> Type -> Resource 17 | (:::) = MkRes 18 | 19 | export 20 | data Var = MkVar -- Phantom, just for labelling purposes 21 | 22 | {- Contexts for holding current resources states -} 23 | namespace Context 24 | public export 25 | data Context : Type where 26 | Nil : Context 27 | (::) : Resource -> Context -> Context 28 | 29 | public export 30 | (++) : Context -> Context -> Context 31 | (++) [] ys = ys 32 | (++) (x :: xs) ys = x :: xs ++ ys 33 | 34 | {- Proof that a label has a particular type in a given context -} 35 | public export 36 | data InState : lbl -> Type -> Context -> Type where 37 | Here : InState lbl st (MkRes lbl st :: rs) 38 | There : InState lbl st rs -> InState lbl st (r :: rs) 39 | 40 | {- Update an entry in a context with a new state -} 41 | public export 42 | updateCtxt : (ctxt : Context) -> 43 | InState lbl st ctxt -> Type -> Context 44 | updateCtxt (MkRes lbl _ :: rs) Here val = (MkRes lbl val :: rs) 45 | updateCtxt (r :: rs) (There x) ty = r :: updateCtxt rs x ty 46 | 47 | {- Remove an entry from a context -} 48 | public export 49 | drop : (ctxt : Context) -> (prf : InState lbl st ctxt) -> 50 | Context 51 | drop (MkRes lbl st :: rs) Here = rs 52 | drop (r :: rs) (There p) = r :: drop rs p 53 | 54 | {- Proof that a resource state (label/type) is in a context -} 55 | public export 56 | data ElemCtxt : Resource -> Context -> Type where 57 | HereCtxt : ElemCtxt a (a :: as) 58 | ThereCtxt : ElemCtxt a as -> ElemCtxt a (b :: as) 59 | 60 | public export %error_reduce 61 | dropEl : (ys: _) -> ElemCtxt x ys -> Context 62 | dropEl (x :: as) HereCtxt = as 63 | dropEl (x :: as) (ThereCtxt p) = x :: dropEl as p 64 | 65 | {- Proof that a variable name is in a context -} 66 | public export 67 | data VarInCtxt : Var -> Context -> Type where 68 | VarHere : VarInCtxt a (MkRes a st :: as) 69 | VarThere : VarInCtxt a as -> VarInCtxt a (b :: as) 70 | 71 | public export %error_reduce 72 | dropVarIn : (ys: _) -> VarInCtxt x ys -> Context 73 | dropVarIn ((MkRes x _) :: as) VarHere = as 74 | dropVarIn (x :: as) (VarThere p) = x :: dropVarIn as p 75 | 76 | public export 77 | data Composite : List Type -> Type where 78 | CompNil : Composite [] 79 | CompCons : (x : a) -> Composite as -> Composite (a :: as) 80 | 81 | namespace VarList 82 | public export 83 | data VarList : List Type -> Type where 84 | Nil : VarList [] 85 | (::) : Var -> VarList ts -> VarList (t :: ts) 86 | 87 | public export 88 | mkCtxt : VarList tys -> Context 89 | mkCtxt [] = [] 90 | mkCtxt {tys = (t :: ts)} (v :: vs) = (v ::: t) :: mkCtxt vs 91 | 92 | {- Proof that a context is a subset of another context -} 93 | public export 94 | data SubCtxt : Context -> Context -> Type where 95 | SubNil : SubCtxt [] [] 96 | InCtxt : (el : ElemCtxt x ys) -> SubCtxt xs (dropEl ys el) -> 97 | SubCtxt (x :: xs) ys 98 | Skip : SubCtxt xs ys -> SubCtxt xs (y :: ys) 99 | 100 | %hint 101 | public export 102 | subCtxtId : SubCtxt xs xs 103 | subCtxtId {xs = []} = SubNil 104 | subCtxtId {xs = (x :: xs)} = InCtxt HereCtxt subCtxtId 105 | 106 | public export 107 | subCtxtNil : SubCtxt [] xs 108 | subCtxtNil {xs = []} = SubNil 109 | subCtxtNil {xs = (x :: xs)} = Skip subCtxtNil 110 | 111 | {- Proof that every variable in the list appears once in the context -} 112 | public export 113 | data VarsIn : List Var -> Context -> Type where 114 | VarsNil : VarsIn [] [] 115 | InCtxtVar : (el : VarInCtxt x ys) -> VarsIn xs (dropVarIn ys el) -> 116 | VarsIn (x :: xs) ys 117 | SkipVar : VarsIn xs ys -> VarsIn xs (y :: ys) 118 | 119 | public export 120 | Uninhabited (ElemCtxt x []) where 121 | uninhabited HereCtxt impossible 122 | uninhabited (ThereCtxt _) impossible 123 | 124 | public export %error_reduce 125 | updateWith : (new : Context) -> (xs : Context) -> 126 | SubCtxt ys xs -> Context 127 | -- At the end, add the ones which were updated by the subctxt 128 | updateWith new [] SubNil = new 129 | updateWith new [] (InCtxt el z) = absurd el 130 | -- Don't add the ones which were consumed by the subctxt 131 | updateWith [] (x :: xs) (InCtxt el p) 132 | = updateWith [] (dropEl _ el) p 133 | updateWith (n :: ns) (x :: xs) (InCtxt el p) 134 | = n :: updateWith ns (dropEl _ el) p 135 | -- Do add the ones we didn't use in the subctxt 136 | updateWith new (x :: xs) (Skip p) = x :: updateWith new xs p 137 | 138 | public export 139 | getVarType : (xs : Context) -> VarInCtxt v xs -> Type 140 | getVarType ((MkRes v st) :: as) VarHere = st 141 | getVarType (b :: as) (VarThere x) = getVarType as x 142 | 143 | public export 144 | getCombineType : VarsIn ys xs -> List Type 145 | getCombineType VarsNil = [] 146 | getCombineType (InCtxtVar el y) = getVarType _ el :: getCombineType y 147 | getCombineType (SkipVar x) = getCombineType x 148 | 149 | public export 150 | dropCombined : VarsIn vs ctxt -> Context 151 | dropCombined {ctxt = []} VarsNil = [] 152 | dropCombined {ctxt} (InCtxtVar el y) = dropCombined y 153 | dropCombined {ctxt = (y :: ys)} (SkipVar x) = y :: dropCombined x 154 | 155 | public export 156 | combineVarsIn : (ctxt : Context) -> VarsIn (comp :: vs) ctxt -> Context 157 | combineVarsIn {comp} ctxt (InCtxtVar el x) 158 | = ((comp ::: Composite (getCombineType x)) :: dropCombined (InCtxtVar el x)) 159 | combineVarsIn (y :: ys) (SkipVar x) = y :: combineVarsIn ys x 160 | 161 | namespace Env 162 | public export 163 | data Env : Context -> Type where 164 | Nil : Env [] 165 | (::) : ty -> Env xs -> Env ((lbl ::: ty) :: xs) 166 | 167 | lookupEnv : InState lbl ty ctxt -> Env ctxt -> ty 168 | lookupEnv Here (x :: xs) = x 169 | lookupEnv (There p) (x :: xs) = lookupEnv p xs 170 | 171 | updateEnv : (prf : InState lbl ty ctxt) -> Env ctxt -> ty' -> 172 | Env (updateCtxt ctxt prf ty') 173 | updateEnv Here (x :: xs) val = val :: xs 174 | updateEnv (There p) (x :: xs) val = x :: updateEnv p xs val 175 | 176 | dropVal : (prf : InState lbl st ctxt) -> Env ctxt -> Env (drop ctxt prf) 177 | dropVal Here (x :: xs) = xs 178 | dropVal (There p) (x :: xs) = x :: dropVal p xs 179 | 180 | envElem : ElemCtxt x xs -> Env xs -> Env [x] 181 | envElem HereCtxt (x :: xs) = [x] 182 | envElem (ThereCtxt p) (x :: xs) = envElem p xs 183 | 184 | dropDups : Env xs -> (el : ElemCtxt x xs) -> Env (dropEl xs el) 185 | dropDups (y :: ys) HereCtxt = ys 186 | dropDups (y :: ys) (ThereCtxt p) = y :: dropDups ys p 187 | 188 | 189 | dropEntry : Env ctxt -> (prf : VarInCtxt x ctxt) -> Env (dropVarIn ctxt prf) 190 | dropEntry (x :: env) VarHere = env 191 | dropEntry (x :: env) (VarThere y) = x :: dropEntry env y 192 | 193 | dropVarsIn : Env ctxt -> (prf : VarsIn vs ctxt) -> Env (dropCombined prf) 194 | dropVarsIn [] VarsNil = [] 195 | dropVarsIn env (InCtxtVar el z) = dropVarsIn (dropEntry env el) z 196 | dropVarsIn (x :: env) (SkipVar z) = x :: dropVarsIn env z 197 | 198 | getVarEntry : Env ctxt -> (prf : VarInCtxt v ctxt) -> getVarType ctxt prf 199 | getVarEntry (x :: xs) VarHere = x 200 | getVarEntry (x :: env) (VarThere p) = getVarEntry env p 201 | 202 | mkComposite : Env ctxt -> (prf : VarsIn vs ctxt) -> Composite (getCombineType prf) 203 | mkComposite [] VarsNil = CompNil 204 | mkComposite env (InCtxtVar el z) 205 | = CompCons (getVarEntry env el) (mkComposite (dropEntry env el) z) 206 | mkComposite (x :: env) (SkipVar z) = mkComposite env z 207 | 208 | rebuildVarsIn : Env ctxt -> (prf : VarsIn (comp :: vs) ctxt) -> 209 | Env (combineVarsIn ctxt prf) 210 | rebuildVarsIn env (InCtxtVar el p) 211 | = mkComposite (dropEntry env el) p :: dropVarsIn env (InCtxtVar el p) 212 | rebuildVarsIn (x :: env) (SkipVar p) = x :: rebuildVarsIn env p 213 | 214 | {- Some things to make STrans interfaces look prettier -} 215 | 216 | infix 6 :-> 217 | 218 | public export 219 | data Action : Type -> Type where 220 | Stable : lbl -> Type -> Action ty 221 | Trans : lbl -> Type -> (ty -> Type) -> Action ty 222 | Remove : lbl -> Type -> Action ty 223 | Add : (ty -> Context) -> Action ty 224 | 225 | namespace Stable 226 | public export %error_reduce 227 | (:::) : lbl -> Type -> Action ty 228 | (:::) = Stable 229 | 230 | namespace Trans 231 | public export 232 | data Trans ty = (:->) Type Type 233 | 234 | public export %error_reduce 235 | (:::) : lbl -> Trans ty -> Action ty 236 | (:::) lbl (st :-> st') = Trans lbl st (const st') 237 | 238 | namespace DepTrans 239 | public export 240 | data DepTrans ty = (:->) Type (ty -> Type) 241 | 242 | public export %error_reduce 243 | (:::) : lbl -> DepTrans ty -> Action ty 244 | (:::) lbl (st :-> st') = Trans lbl st st' 245 | 246 | public export 247 | or : a -> a -> Either b c -> a 248 | or x y = either (const x) (const y) 249 | 250 | public export 251 | add : Type -> Action a 252 | add ty = Add (\var => [var ::: ty]) 253 | 254 | public export 255 | addIfRight : Type -> Action (Either a b) 256 | addIfRight ty = Add (either (const []) (\var => [var ::: ty])) 257 | 258 | public export 259 | addIfJust : Type -> Action (Maybe a) 260 | addIfJust ty = Add (maybe [] (\var => [var ::: ty])) 261 | 262 | public export 263 | kept : SubCtxt xs ys -> Context 264 | kept SubNil = [] 265 | kept (InCtxt el p) = kept p 266 | kept (Skip {y} p) = y :: kept p 267 | 268 | -- We can only use new/delete/read/write on things wrapped in State. Only an 269 | -- interface implementation should know that a thing is defined as State, 270 | -- so it's the only thing that's able to peek at the internals 271 | public export 272 | data State : Type -> Type where 273 | Value : ty -> State ty 274 | 275 | export 276 | data STrans : (m : Type -> Type) -> 277 | (ty : Type) -> 278 | Context -> (ty -> Context) -> 279 | Type where 280 | Pure : (result : ty) -> 281 | STrans m ty (out_fn result) out_fn 282 | Bind : STrans m a st1 st2_fn -> 283 | ((result : a) -> 284 | STrans m b (st2_fn result) st3_fn) -> 285 | STrans m b st1 st3_fn 286 | Lift : Monad m => m t -> STrans m t ctxt (const ctxt) 287 | 288 | New : (val : state) -> 289 | STrans m Var ctxt (\lbl => (lbl ::: state) :: ctxt) 290 | Delete : (lbl : Var) -> 291 | (prf : InState lbl st ctxt) -> 292 | STrans m () ctxt (const (drop ctxt prf)) 293 | DropSubCtxt : (prf : SubCtxt ys xs) -> 294 | STrans m (Env ys) xs (const (kept prf)) 295 | 296 | Split : (lbl : Var) -> 297 | (prf : InState lbl (Composite vars) ctxt) -> 298 | STrans m (VarList vars) ctxt 299 | (\ vs => mkCtxt vs ++ 300 | updateCtxt ctxt prf (State ())) 301 | Combine : (comp : Var) -> (vs : List Var) -> 302 | (prf : VarsIn (comp :: vs) ctxt) -> 303 | STrans m () ctxt 304 | (const (combineVarsIn ctxt prf)) 305 | 306 | Call : STrans m t sub new_f -> (ctxt_prf : SubCtxt sub old) -> 307 | STrans m t old (\res => updateWith (new_f res) old ctxt_prf) 308 | 309 | Read : (lbl : Var) -> 310 | (prf : InState lbl ty ctxt) -> 311 | STrans m ty ctxt (const ctxt) 312 | Write : (lbl : Var) -> 313 | (prf : InState lbl ty ctxt) -> 314 | (val : ty') -> 315 | STrans m () ctxt (const (updateCtxt ctxt prf ty')) 316 | 317 | export 318 | dropEnv : Env ys -> SubCtxt xs ys -> Env xs 319 | dropEnv [] SubNil = [] 320 | dropEnv [] (InCtxt idx rest) = absurd idx 321 | dropEnv (z :: zs) (InCtxt idx rest) 322 | = let [e] = envElem idx (z :: zs) in 323 | e :: dropEnv (dropDups (z :: zs) idx) rest 324 | dropEnv (z :: zs) (Skip p) = dropEnv zs p 325 | 326 | keepEnv : Env ys -> (prf : SubCtxt xs ys) -> Env (kept prf) 327 | keepEnv env SubNil = env 328 | keepEnv env (InCtxt el prf) = keepEnv (dropDups env el) prf 329 | keepEnv (z :: zs) (Skip prf) = z :: keepEnv zs prf 330 | 331 | -- Corresponds pretty much exactly to 'updateWith' 332 | rebuildEnv : Env new -> Env old -> (prf : SubCtxt sub old) -> 333 | Env (updateWith new old prf) 334 | rebuildEnv new [] SubNil = new 335 | rebuildEnv new [] (InCtxt el p) = absurd el 336 | rebuildEnv [] (x :: xs) (InCtxt el p) 337 | = rebuildEnv [] (dropDups (x :: xs) el) p 338 | rebuildEnv (e :: es) (x :: xs) (InCtxt el p) 339 | = e :: rebuildEnv es (dropDups (x :: xs) el) p 340 | rebuildEnv new (x :: xs) (Skip p) = x :: rebuildEnv new xs p 341 | 342 | runST : Env invars -> STrans m a invars outfn -> 343 | ((x : a) -> Env (outfn x) -> m b) -> m b 344 | runST env (Pure result) k = k result env 345 | runST env (Bind prog next) k 346 | = runST env prog (\prog', env' => runST env' (next prog') k) 347 | runST env (Lift action) k 348 | = do res <- action 349 | k res env 350 | runST env (New val) k = k MkVar (val :: env) 351 | runST env (Delete lbl prf) k = k () (dropVal prf env) 352 | runST env (DropSubCtxt prf) k = k (dropEnv env prf) (keepEnv env prf) 353 | runST env (Split lbl prf) k = let val = lookupEnv prf env 354 | env' = updateEnv prf env (Value ()) in 355 | k (mkVars val) (addToEnv val env') 356 | where 357 | mkVars : Composite ts -> VarList ts 358 | mkVars CompNil = [] 359 | mkVars (CompCons x xs) = MkVar :: mkVars xs 360 | 361 | addToEnv : (comp : Composite ts) -> Env xs -> Env (mkCtxt (mkVars comp) ++ xs) 362 | addToEnv CompNil env = env 363 | addToEnv (CompCons x xs) env = x :: addToEnv xs env 364 | runST env (Combine lbl vs prf) k = k () (rebuildVarsIn env prf) 365 | runST env (Call prog ctxt_prf) k 366 | = let env' = dropEnv env ctxt_prf in 367 | runST env' prog 368 | (\prog', envk => k prog' (rebuildEnv envk env ctxt_prf)) 369 | runST env (Read lbl prf) k = k (lookupEnv prf env) env 370 | runST env (Write lbl prf val) k = k () (updateEnv prf env val) 371 | 372 | 373 | export 374 | pure : (result : ty) -> STrans m ty (out_fn result) out_fn 375 | pure = Pure 376 | 377 | export 378 | (>>=) : STrans m a st1 st2_fn -> 379 | ((result : a) -> STrans m b (st2_fn result) st3_fn) -> 380 | STrans m b st1 st3_fn 381 | (>>=) = Bind 382 | 383 | export 384 | lift : Monad m => m t -> STrans m t ctxt (const ctxt) 385 | lift = Lift 386 | 387 | export 388 | new : (val : state) -> 389 | STrans m Var ctxt (\lbl => (lbl ::: State state) :: ctxt) 390 | new val = New (Value val) 391 | 392 | export 393 | delete : (lbl : Var) -> 394 | {auto prf : InState lbl (State st) ctxt} -> 395 | STrans m () ctxt (const (drop ctxt prf)) 396 | delete lbl {prf} = Delete lbl prf 397 | 398 | -- Keep only a subset of the current set of resources. Returns the 399 | -- environment corresponding to the dropped portion. 400 | export 401 | dropSubCtxt : {auto prf : SubCtxt ys xs} -> 402 | STrans m (Env ys) xs (const (kept prf)) 403 | dropSubCtxt {prf} = DropSubCtxt prf 404 | 405 | export 406 | split : (lbl : Var) -> 407 | {auto prf : InState lbl (Composite vars) ctxt} -> 408 | STrans m (VarList vars) ctxt 409 | (\ vs => mkCtxt vs ++ 410 | updateCtxt ctxt prf (State ())) 411 | split lbl {prf} = Split lbl prf 412 | 413 | export 414 | combine : (comp : Var) -> (vs : List Var) -> 415 | {auto prf : InState comp (State ()) ctxt} -> 416 | {auto var_prf : VarsIn (comp :: vs) ctxt} -> 417 | STrans m () ctxt 418 | (const (combineVarsIn ctxt var_prf)) 419 | combine comp vs {var_prf} = Combine comp vs var_prf 420 | 421 | export -- implicit ??? 422 | call : STrans m t sub new_f -> 423 | {auto ctxt_prf : SubCtxt sub old} -> 424 | STrans m t old (\res => updateWith (new_f res) old ctxt_prf) 425 | call prog {ctxt_prf} = Call prog ctxt_prf 426 | 427 | export 428 | read : (lbl : Var) -> 429 | {auto prf : InState lbl (State ty) ctxt} -> 430 | STrans m ty ctxt (const ctxt) 431 | read lbl {prf} = do Value x <- Read lbl prf 432 | pure x 433 | 434 | export 435 | write : (lbl : Var) -> 436 | {auto prf : InState lbl ty ctxt} -> 437 | (val : ty') -> 438 | STrans m () ctxt (const (updateCtxt ctxt prf (State ty'))) 439 | write lbl {prf} val = Write lbl prf (Value val) 440 | 441 | public export %error_reduce 442 | out_res : ty -> (as : List (Action ty)) -> Context 443 | out_res x [] = [] 444 | out_res x ((Stable lbl inr) :: xs) = (lbl ::: inr) :: out_res x xs 445 | out_res x ((Trans lbl inr outr) :: xs) 446 | = (lbl ::: outr x) :: out_res x xs 447 | out_res x ((Remove lbl inr) :: xs) = out_res x xs 448 | out_res x (Add outf :: xs) = outf x ++ out_res x xs 449 | 450 | public export %error_reduce 451 | in_res : (as : List (Action ty)) -> Context 452 | in_res [] = [] 453 | in_res ((Stable lbl inr) :: xs) = (lbl ::: inr) :: in_res xs 454 | in_res ((Trans lbl inr outr) :: xs) = (lbl ::: inr) :: in_res xs 455 | in_res ((Remove lbl inr) :: xs) = (lbl ::: inr) :: in_res xs 456 | in_res (Add outf :: xs) = in_res xs 457 | 458 | public export 459 | %error_reduce -- always evaluate this before showing errors 460 | ST : (m : Type -> Type) -> 461 | (ty : Type) -> 462 | List (Action ty) -> Type 463 | ST m ty xs = STrans m ty (in_res xs) (\result : ty => out_res result xs) 464 | 465 | -- Console IO is useful sufficiently often that let's have it here 466 | public export 467 | interface ConsoleIO (m : Type -> Type) where 468 | putStr : String -> STrans m () xs (const xs) 469 | getStr : STrans m String xs (const xs) 470 | 471 | export 472 | ConsoleIO IO where 473 | putStr str = lift (Interactive.putStr str) 474 | getStr = lift Interactive.getLine 475 | 476 | 477 | export 478 | run : Applicative m => ST m a [] -> m a 479 | run prog = runST [] prog (\res, env' => pure res) 480 | 481 | ||| runWith allows running an STrans program with an initial environment, 482 | ||| which must be consumed. 483 | ||| It's only allowed in the IO monad, because it's inherently unsafe, so 484 | ||| we don't want to be able to use it under a 'lift in just *any* ST program - 485 | ||| if we have access to an 'Env' we can easily duplicate it - so it's the 486 | ||| responsibility of an implementation of an interface in IO which uses it 487 | ||| to ensure that it isn't duplicated. 488 | export 489 | runWith : {ctxtf : _} -> 490 | Env ctxt -> STrans IO a ctxt (\res => ctxtf res) -> 491 | IO (res ** Env (ctxtf res)) 492 | runWith env prog = runST env prog (\res, env' => pure (res ** env')) 493 | 494 | export 495 | runPure : ST Basics.id a [] -> a 496 | runPure prog = runST [] prog (\res, env' => res) 497 | 498 | %language ErrorReflection 499 | 500 | %error_handler 501 | export 502 | st_precondition : Err -> Maybe (List ErrorReportPart) 503 | st_precondition (CantSolveGoal `(SubCtxt ~sub ~all) _) 504 | = pure 505 | [TextPart "'call' is not valid here. ", 506 | TextPart "The operation has preconditions ", 507 | TermPart sub, 508 | TextPart " which is not a sub set of ", 509 | TermPart all] 510 | st_precondition (CantUnify _ tm1 tm2 _ _ _) 511 | = do reqPre <- getPreconditions tm1 512 | gotPre <- getPreconditions tm2 513 | reqPost <- getPostconditions tm1 514 | gotPost <- getPostconditions tm2 515 | pure $ [TextPart "Error in state transition:"] ++ 516 | renderPre gotPre reqPre ++ 517 | renderPost gotPost reqPost 518 | 519 | where 520 | getPreconditions : TT -> Maybe TT 521 | getPreconditions `(STrans ~m ~ret ~pre ~post) = Just pre 522 | getPreconditions _ = Nothing 523 | 524 | getPostconditions : TT -> Maybe TT 525 | getPostconditions `(STrans ~m ~ret ~pre ~post) = Just post 526 | getPostconditions _ = Nothing 527 | 528 | renderPre : TT -> TT -> List (ErrorReportPart) 529 | renderPre got req 530 | = [SubReport [TextPart "Operation has preconditions: ", 531 | TermPart req], 532 | SubReport [TextPart "States here are: ", 533 | TermPart got]] 534 | renderPost : TT -> TT -> List (ErrorReportPart) 535 | renderPost got req 536 | = [SubReport [TextPart "Operation has postconditions: ", 537 | TermPart req], 538 | SubReport [TextPart "Required result states here are: ", 539 | TermPart got]] 540 | 541 | st_precondition _ = Nothing 542 | -------------------------------------------------------------------------------- /src/Control/ST/ImplicitCall.idr: -------------------------------------------------------------------------------- 1 | module Control.ST.ImplicitCall 2 | 3 | import Control.ST 4 | 5 | ||| Make 'call' implicit. 6 | ||| This makes ST programs less verbose, at the cost of making error messages 7 | ||| potentially more difficult to read. 8 | export implicit 9 | imp_call : STrans m t ys ys' -> 10 | {auto ctxt_prf : SubCtxt ys xs} -> 11 | STrans m t xs (\res => updateWith (ys' res) xs ctxt_prf) 12 | imp_call = call 13 | 14 | -------------------------------------------------------------------------------- /vars.ipkg: -------------------------------------------------------------------------------- 1 | package vars 2 | 3 | version = 0.1 4 | 5 | sourcedir = src 6 | modules = Control.ST, 7 | Control.ST.ImplicitCall 8 | --------------------------------------------------------------------------------