├── LICENSE ├── README.md ├── examples ├── Conc.idr ├── Hangman.idr ├── Net │ ├── Network.idr │ ├── RandClient.idr │ ├── RandProto.idr │ ├── RandSimple.idr │ └── Raw.idr └── pairres.idr ├── src ├── Interface │ ├── Exception.idr │ └── IO.idr ├── State │ └── Var.idr ├── States.idr └── Utils │ └── PList.idr └── states.ipkg /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Research in progress. Probably doesn't work, lots of things still do to. 2 | 3 | You're welcome to fork the repository, or take any code or ideas (with 4 | appropriate credit), but I'm extremely unlikely to respond to pull requests, 5 | issues, or any requests for support, for the moment. 6 | 7 | More later! 8 | -------------------------------------------------------------------------------- /examples/Conc.idr: -------------------------------------------------------------------------------- 1 | import States 2 | 3 | import System.Concurrency.Channels 4 | import Interface.IO 5 | import State.Var 6 | 7 | data ConcState 8 | = None -- Initial/Final state 9 | | Waiting (request -> Type) -- Final state (so can't listen and not reply) 10 | | Processing (request -> Type) Type 11 | | Finished 12 | 13 | data ConcFinal : ConcState -> Type where 14 | WaitingIsFinal : ConcFinal (Waiting iface) 15 | NoneIsFinal : ConcFinal None 16 | FinishedIsFinal : ConcFinal Finished 17 | 18 | data Process : (request -> Type) -> Type where 19 | MkProcess : PID -> Process iface 20 | 21 | data ForkThread : (request -> Type) -> Type where 22 | Main : (Process iface) -> ForkThread iface 23 | Child : ForkThread iface 24 | 25 | data ConcOp : SM_sig ConcState where 26 | Fork : (iface : request -> Type) -> 27 | ConcOp (ForkThread iface) None 28 | (\server => case server of 29 | Main iface => None 30 | Child => Waiting iface) 31 | Listen : {iface : request -> Type} -> 32 | (timeout: Int) -> 33 | ConcOp (Maybe request) 34 | (Waiting iface) 35 | (\res => case res of 36 | Nothing => Waiting iface 37 | Just msg => Processing iface (iface msg)) 38 | Reply : {iface : request -> Type} -> 39 | (reply : responsetype) -> 40 | ConcOp () (Processing iface responseType) 41 | (const (Waiting iface)) 42 | QuitThread : ConcOp any (Waiting iface) (const Finished) 43 | 44 | Conc : SM ConcState 45 | Conc = MkSM None ConcFinal ConcOp 46 | 47 | -- TODO: Change the types so that a server *must* run indefinitely and so 48 | -- we know we'll get a reply 49 | -- Also add loop to States so that we can have total programs that run forever 50 | fork : ((s : State Conc) -> 51 | SMTransNew m () ops [Stable s (Conc, Waiting iface)]) -> 52 | SMNew m (Process iface) (Conc :: ops) 53 | fork {iface} server 54 | = do s <- new Conc 55 | Main pid <- on s (Fork iface) 56 | | Child => do call (server s) 57 | ret <- on s QuitThread 58 | delete s 59 | pure ret 60 | delete s 61 | pure pid 62 | 63 | Execute Conc IO where 64 | resource None = () 65 | resource (Waiting f) = () 66 | resource (Processing f x) = Channel 67 | resource Finished = () 68 | 69 | initialise = () 70 | 71 | exec res (Fork iface) k 72 | = do pid <- spawn (do k Child res 73 | pure ()) 74 | k (Main (MkProcess pid)) () 75 | exec res (Listen {request} timeout) k 76 | = do Just chan <- listen timeout 77 | | Nothing => k Nothing res 78 | Just req <- unsafeRecv request chan 79 | | Nothing => k Nothing res 80 | k (Just req) chan 81 | exec res (Reply reply) k 82 | = do unsafeSend res reply 83 | k () () 84 | exec res QuitThread k = stopThread 85 | 86 | data ClientState 87 | = Disconnected -- Initial and final state 88 | | SendReady (request -> Type) 89 | | ReceiveReady (request -> Type) Type 90 | 91 | data ClientFinal : ClientState -> Type where 92 | DisconnectedIsFinal : ClientFinal Disconnected 93 | 94 | data ClientOp : SM_sig ClientState where 95 | Connect : {iface : request -> Type} -> 96 | Process iface -> 97 | ClientOp Bool Disconnected 98 | (\res => case res of 99 | False => Disconnected 100 | True => SendReady iface) 101 | Send : {iface : request -> Type} -> 102 | (msg : request) -> 103 | ClientOp () (SendReady iface) 104 | (const (ReceiveReady iface (iface msg))) 105 | Receive : {iface : request -> Type} -> 106 | ClientOp t (ReceiveReady iface t) 107 | (const Disconnected) 108 | 109 | Client : SM ClientState 110 | Client = MkSM Disconnected ClientFinal ClientOp 111 | 112 | request : {iface : request -> Type} -> 113 | (chan : State Client) -> (process : Process iface) -> 114 | (req : request) -> 115 | SMTrans m (Maybe (iface req)) [Stable chan (Client, Disconnected)] 116 | request chan proc req = do True <- on chan (Connect proc) 117 | | False => pure Nothing 118 | on chan (Send req) 119 | answer <- on chan Receive 120 | pure (Just answer) 121 | 122 | 123 | Execute Client IO where 124 | resource Disconnected = () 125 | resource (SendReady f) = Channel 126 | resource (ReceiveReady f x) = Channel 127 | 128 | initialise = () 129 | 130 | exec res (Connect (MkProcess pid)) k 131 | = do Just chan <- connect pid 132 | | Nothing => k False () 133 | k True chan 134 | exec res (Send msg) k 135 | = do unsafeSend res msg 136 | k () res 137 | exec res (Receive {t}) k 138 | = do Just res <- unsafeRecv t res 139 | | Nothing => believe_me () -- Can't Happen... 140 | k res () 141 | 142 | data Arith = Add Nat Nat | Negate Int 143 | 144 | ArithResponse : Arith -> Type 145 | ArithResponse (Add k j) = Nat 146 | ArithResponse (Negate k) = Int 147 | 148 | covering 149 | arithServer : ConsoleIO m => 150 | (s : State Conc) -> 151 | SMTrans m () [Stable s (Conc, Waiting ArithResponse)] 152 | arithServer s = do putStrLn "Waiting for message" 153 | msg <- on s (Listen 2) 154 | case msg of 155 | Nothing => arithServer s 156 | (Just (Add k j)) => do on s (Reply (k + j)) 157 | arithServer s 158 | (Just (Negate k)) => do on s (Reply (-k)) 159 | arithServer s 160 | 161 | covering 162 | arithClient : ConsoleIO m => 163 | SMNew m () [Client, Conc] 164 | arithClient = do 165 | proc <- call (fork arithServer) 166 | chan <- new Client 167 | putStr "Number: " 168 | num <- getStr 169 | 170 | Just answer <- call $ request chan proc (Add (cast num) 94) 171 | | Nothing => do putStrLn "Server died" 172 | delete chan 173 | putStrLn (num ++ " + 94 = " ++ show answer) 174 | 175 | Just answer <- call $ request chan proc (Negate (cast num)) 176 | | Nothing => do putStrLn "Server died" 177 | delete chan 178 | putStrLn ("-" ++ num ++ " = " ++ show answer) 179 | delete chan 180 | 181 | main : IO () 182 | main = run arithClient 183 | -------------------------------------------------------------------------------- /examples/Hangman.idr: -------------------------------------------------------------------------------- 1 | import Data.Vect 2 | 3 | import States 4 | import State.Var 5 | import Interface.IO 6 | 7 | {- We'll need this later... -} 8 | total 9 | removeElem : (value : a) -> (xs : Vect (S n) a) -> 10 | {auto prf : Elem value xs} -> 11 | Vect n a 12 | removeElem value (value :: ys) {prf = Here} = ys 13 | removeElem {n = Z} value (y :: []) {prf = There later} = absurd later 14 | removeElem {n = (S k)} value (y :: ys) {prf = There later} 15 | = y :: removeElem value ys 16 | 17 | {- Global states of a hangman game -} 18 | data HangmanState = Unstarted | Playing | Won | Lost 19 | 20 | {- The game is over if it's either won or lost -} 21 | data GameEnd : HangmanState -> Type where 22 | GameWon : GameEnd Won 23 | GameLost : GameEnd Lost 24 | 25 | {- We can create a new game with a target word, and play the game -} 26 | data HangmanOp : SM_sig HangmanState where 27 | NewGame : (word : String) -> HangmanOp () Unstarted (const Playing) 28 | Play : HangmanOp Bool Playing (\res => case res of 29 | True => Won 30 | False => Lost) 31 | 32 | data HangmanData : HangmanState -> Type where 33 | Word : String -> HangmanData Playing 34 | NoWord : HangmanData x 35 | 36 | Hangman : SM HangmanState 37 | Hangman = MkSM Unstarted -- Initial state 38 | GameEnd -- Predicate for final states 39 | HangmanOp -- Operations on the state machine 40 | None -- No creation 41 | 42 | {- Top level game, creates a new game then plays it -} 43 | hangman : ConsoleIO io => SMNew io () [Hangman] 44 | hangman = do game <- new Hangman 45 | on game $ NewGame "testing" 46 | result <- on game Play 47 | case result of 48 | False => do putStrLn "You lose" 49 | delete game 50 | True => do putStrLn "You win" 51 | delete game 52 | 53 | 54 | {- To implement the game, we'll define another state machine which 55 | describes the rules of the game -} 56 | data GameState = Score Nat Nat -- Number of guesses left; number of letters to guess 57 | | NotRunning 58 | 59 | data Finished : GameState -> Type where 60 | GameFinished : Finished NotRunning 61 | 62 | letters : String -> List Char 63 | letters str = map toUpper (nub (unpack str)) 64 | 65 | data GameOp : SM_sig GameState where 66 | {- We can guess a character if there are still both guesses remaining 67 | and letters to guess. The result determines whether we lose a guess, 68 | or lose a letter -} 69 | Guess : Char -> GameOp Bool (Score (S g) (S l)) 70 | (\res => case res of 71 | False => Score g (S l) 72 | True => Score (S g) l) 73 | {- Read a guess from the player -} 74 | ReadGuess : GameOp Char (Score (S g) (S l)) (const (Score (S g) (S l))) 75 | 76 | {- We can claim a win if there are no letters to guess -} 77 | ClaimWin : GameOp () (Score (S g) 0) (const NotRunning) 78 | {- We can admit defeat if there are no guesses left -} 79 | AdmitLoss : GameOp () (Score 0 (S l)) (const NotRunning) 80 | 81 | {- Get a string representation of the current game state -} 82 | GetState : GameOp String st (const st) 83 | 84 | {- Start a new game with a target word -} 85 | SetTarget : (word : String) -> GameOp () NotRunning 86 | (const (Score 6 (length (letters word)))) 87 | 88 | 89 | Game : SM GameState 90 | Game = MkSM NotRunning Finished GameOp None 91 | 92 | 93 | {- Implementation of the game rules, starts with a number of guesses and 94 | letters to guess, can only end either in victory or defeat (NotRunning) -} 95 | play : ConsoleIO io => 96 | (game : State Game) -> 97 | SMTrans io Bool [Trans game (Score (S g) l) (const NotRunning)] 98 | play {g} {l = Z} game = do on game ClaimWin 99 | pure True 100 | play {g} {l = S l} game 101 | = do st <- on game GetState 102 | putStrLn st 103 | letter <- on game ReadGuess 104 | ok <- on game (Guess letter) 105 | case ok of 106 | False => do putStrLn "Incorrect" 107 | case g of 108 | Z => do on game AdmitLoss 109 | pure False 110 | S k => play game 111 | True => do putStrLn "Correct!" 112 | play game 113 | 114 | {- Now to define how the 'Hangman' and 'Game' state machines actually run -} 115 | 116 | {- Run time representation of the game data -} 117 | data GameData : GameState -> Type where 118 | InProgress : (target : String) -> (g : Nat) -> 119 | (missing : Vect l Char) -> 120 | GameData (Score g l) 121 | MkNotRunning : (won : Bool) -> GameData NotRunning 122 | 123 | Show (GameData g) where 124 | show (MkNotRunning won) = if won then "Game won" else "Game lost" 125 | show (InProgress word guesses missing) 126 | = "\n" ++ pack (map hideMissing (unpack word)) 127 | ++ "\n" ++ show guesses ++ " guesses left" 128 | where hideMissing : Char -> Char 129 | hideMissing c = if c `elem` missing then '-' else c 130 | 131 | {- Execute 'Game' in IO using 'GameData' -} 132 | Execute Game IO where 133 | resource = GameData 134 | initialise = MkNotRunning False 135 | create res op k = pass op 136 | 137 | exec (InProgress word _ missing) (Guess x) k = 138 | case isElem x missing of 139 | Yes prf => k True (InProgress word _ (removeElem x missing)) 140 | No contra => k False (InProgress word _ missing) 141 | exec res ReadGuess k = do putStr "Guess: " 142 | x <- getLine 143 | case unpack (toUpper x) of 144 | [letter] => if isAlpha letter 145 | then k letter res 146 | else k ' ' res 147 | _ => k ' ' res 148 | exec res ClaimWin k = k () (MkNotRunning True) 149 | exec res AdmitLoss k = k () (MkNotRunning False) 150 | exec res GetState k = k (show res) res 151 | exec res (SetTarget word) k = k () (InProgress word _ (fromList (letters word))) 152 | 153 | {- Implement 'Hangman' by translating it to a lower level state machine 154 | 'Var', for storing the word. We can create a 'Game' state machine in 155 | the process. -} 156 | ConsoleIO m => Transform Hangman [Var] [Game] m where 157 | toState Unstarted = () -- No word stored 158 | toState Playing = String -- Word stored 159 | toState Won = String 160 | toState Lost = String 161 | 162 | initOK = Refl -- Initial states 'Unstarted' and '()' correspond 163 | finalOK Won GameWon = () 164 | finalOK Lost GameLost = () 165 | 166 | 167 | {- Implement 'Hangman' ops using 'Var' to store the word. 168 | We're also allowed to create 'Game' state machines as required, as it 169 | says in the implementation header. -} 170 | execAs word (NewGame x) = on word (Put x) 171 | execAs word Play = do x <- on word Get 172 | game <- new Game 173 | on game (SetTarget (toUpper x)) 174 | result <- call (play game) 175 | delete game 176 | case result of 177 | True => pure True 178 | False => pure False 179 | 180 | createAs word op = pass op 181 | 182 | {- And then run it... -} 183 | main : IO () 184 | main = run hangman 185 | -------------------------------------------------------------------------------- /examples/Net/Network.idr: -------------------------------------------------------------------------------- 1 | module Network 2 | 3 | import States 4 | import Network.Socket 5 | 6 | %access public export 7 | 8 | data Role = Client | Server 9 | 10 | data SocketState = Closed 11 | | Ready 12 | | Bound 13 | | Listening 14 | | Open Role 15 | 16 | data CloseOK : SocketState -> Type where 17 | CloseOpen : CloseOK (Open role) 18 | CloseListening : CloseOK Listening 19 | 20 | -- Operations which change a socket state. 21 | -- Use 'Either' for all the return types, for consistency (I may add 22 | -- descriptive error types later) 23 | 24 | data NetOp : SM_sig SocketState where 25 | Socket : SocketType -> 26 | NetOp (Either SocketError ()) Closed 27 | (either (const Closed) (const Ready)) 28 | Bind : (addr : Maybe SocketAddress) -> (port : Port) -> 29 | NetOp (Either () ()) Ready 30 | (either (const Closed) (const Bound)) 31 | Listen : NetOp (Either () ()) Bound 32 | (either (const Closed) (const Listening)) 33 | Connect : SocketAddress -> Port -> 34 | NetOp (Either () ()) Ready 35 | (either (const Closed) (const (Open Client))) 36 | Close : {auto prf : CloseOK st} -> NetOp () st (\res => Closed) 37 | Send : String -> NetOp (Either () ()) (Open x) 38 | (either (const Closed) (const (Open x))) 39 | Recv : NetOp (Either () String) (Open x) 40 | (either (const Closed) (const (Open x))) 41 | 42 | -- Operations which make a new socket from an existing socket 43 | data NetCreate : SM_sig SocketState where 44 | Accept : NetCreate (Either SocketError SocketAddress) Listening 45 | (either (const Closed) (const (Open Server))) 46 | 47 | -- Socket states where we can delete the socket (just 'Closed') 48 | data NetFinal : SocketState -> Type where 49 | ClosedFinal : NetFinal Closed 50 | 51 | Net : SM SocketState 52 | Net = MkSM Closed NetFinal NetOp NetCreate 53 | 54 | 55 | -- How to run socket operations under 'IO' 56 | Execute Net IO where 57 | resource Closed = () 58 | resource Ready = Socket 59 | resource Bound = Socket 60 | resource Listening = Socket 61 | resource (Open x) = Socket 62 | 63 | initialise = () 64 | 65 | exec res (Socket ty) k = do Right sock <- socket AF_INET ty 0 66 | | Left err => k (Left err) () 67 | k (Right ()) sock 68 | 69 | exec res (Bind addr port) k = do ok <- bind res addr port 70 | if ok /= 0 71 | then k (Left ()) () 72 | else k (Right ()) (case addr of 73 | Nothing => res 74 | Just _ => res) 75 | exec res Listen k = do ok <- listen res 76 | if ok /= 0 77 | then k (Left ()) () 78 | else k (Right ()) res 79 | exec res (Connect addr port) k = do ok <- connect res addr port 80 | if ok /= 0 81 | then k (Left ()) () 82 | else k (Right ()) res 83 | -- Only needs closing if it's actually open! 84 | exec res (Close {prf = CloseOpen}) k = do close res; k () () 85 | exec res (Close {prf = CloseListening}) k = do close res; k () () 86 | 87 | exec res (Send msg) k = do Right _ <- send res msg 88 | | Left _ => k (Left ()) () 89 | k (Right ()) res 90 | exec res Recv k = do Right (msg, len) <- recv res 1024 -- TMP HACK. I know :) 91 | | Left _ => k (Left ()) () 92 | k (Right msg) res 93 | 94 | -- How to run socket creation operations under 'IO' 95 | create res Accept k = do Right (conn, addr) <- accept res 96 | | Left err => k (Left err) () 97 | k (Right addr) conn 98 | 99 | 100 | -------------------------------------------------------------------------------- /examples/Net/RandClient.idr: -------------------------------------------------------------------------------- 1 | import States 2 | import Network 3 | import Network.Socket 4 | import Interface.IO 5 | 6 | client_main : ConsoleIO io => 7 | (socket : State Net) -> SMs io () [] [Stable socket Closed] 8 | client_main socket 9 | = do putStr "Bound: " 10 | x <- getStr 11 | Right ok <- on socket (Socket Stream) 12 | | Left err => putStrLn "Error on socket creation" 13 | Right ok <- on socket (Connect (Hostname "localhost") 9442) 14 | | Left err => putStrLn "Error on connect" 15 | Right ok <- on socket (Send x) 16 | | Left err => putStrLn "Send failed" 17 | Right reply <- on socket Recv 18 | | Left err => putStrLn "Error on recv" 19 | putStrLn reply 20 | on socket Close 21 | 22 | client_start : ConsoleIO io => SMs io () [Net] [] 23 | client_start = do socket <- new Net 24 | call (client_main socket) 25 | delete socket 26 | 27 | main : IO () 28 | main = run client_start 29 | -------------------------------------------------------------------------------- /examples/Net/RandProto.idr: -------------------------------------------------------------------------------- 1 | import Network 2 | import Network.Socket 3 | import States 4 | import State.Var 5 | import Interface.IO 6 | 7 | -- Possible states of a random number server 8 | data ServerState = Idle -- not started yet 9 | | Ready -- ready to accept incoming requests 10 | | Waiting -- connected, ready to receive a request 11 | | Processing -- received request, ready to send reply 12 | | Done -- reply completed 13 | 14 | -- Operations on a running server 15 | data RandOp : SM_sig ServerState where 16 | -- Start and stop the server 17 | Start : RandOp Bool Idle (\res => if res then Ready else Done) 18 | Quit : RandOp () Ready (const Idle) 19 | 20 | -- Receive a request if the server is connected to a client 21 | RecvReq : RandOp (Maybe Integer) Waiting 22 | (\res => case res of 23 | Nothing => Done 24 | Just _ => Processing) 25 | -- Send a reply if the server has received a request 26 | SendResp : Integer -> RandOp () Processing (const Done) 27 | -- Get the seed for the RNG, if the server is running 28 | GetSeed : RandOp Integer Ready (const Ready) 29 | 30 | -- Operation which allows us to create a connection 31 | data RandCreate : SM_sig ServerState where 32 | Accept : RandCreate Bool Ready (\res => if res then Waiting else Done) 33 | 34 | -- We can close a server if it's Idle (i.e. not started) or Done (i.e. 35 | -- responded to a request) 36 | data RandFinal : ServerState -> Type where 37 | IdleFinal : RandFinal Idle 38 | DoneFinal : RandFinal Done 39 | 40 | RandServer : SM ServerState 41 | RandServer = MkSM Idle RandFinal RandOp RandCreate 42 | 43 | -- A server loop keeps making connections to clients and running a session 44 | -- which reads an input, and sends a reply 45 | serverLoop : ConsoleIO io => 46 | (s : State RandServer) -> SMTrans io () [Stable s Ready] 47 | serverLoop s = do num <- on s GetSeed 48 | (True, session) <- newFrom s Accept 49 | | (False, session) => do delete session 50 | serverLoop s 51 | -- We now have the server 's' and a running session, 'session' 52 | Just bound <- on session RecvReq 53 | | Nothing => do delete session 54 | serverLoop s 55 | on session (SendResp (num `mod` (bound + 1))) 56 | -- Session is complete, we can delete it 57 | delete session 58 | serverLoop s 59 | 60 | -- Start up a server, then run the server loop 61 | startServer : ConsoleIO io => SMNew io () [RandServer] 62 | startServer = do s <- new RandServer 63 | True <- on s Start 64 | | False => do putStrLn "Couldn't start server" 65 | delete s 66 | call (serverLoop s) 67 | on s Quit 68 | delete s 69 | 70 | -- Run the RandServer by using the Network sockets API, and a 'Var' to 71 | -- hold the seed 72 | ConsoleIO io => Transform RandServer [Net, Var] [Var] io where 73 | -- Translate random number server states to states in underlying SMs 74 | toState Idle = (Closed, ()) 75 | toState Ready = (Listening, Integer) -- only have seed when running 76 | toState Waiting = (Open Server, ()) -- seed held in outer session 77 | toState Processing = (Open Server, ()) 78 | toState Done = (Closed, ()) 79 | 80 | -- Show that initial and final states are consistent 81 | initOK = Refl 82 | finalOK Idle IdleFinal = (ClosedFinal, ()) 83 | finalOK Done DoneFinal = (ClosedFinal, ()) 84 | 85 | -- Implement state transitions in terms of state transitions on Net/Var 86 | execAs (server, seed) Quit = do on server Close 87 | on seed (Put ()) 88 | execAs (server, seed) Start 89 | = do putStrLn "Starting server" 90 | Right ok <- on server (Socket Stream) 91 | | Left err => pure False 92 | Right ok <- on server (Bind Nothing 9442) 93 | | Left err => pure False 94 | Right ok <- on server Listen 95 | | Left err => pure False 96 | on seed (Put 123456789) 97 | pure True 98 | execAs (server, seed) RecvReq 99 | = do putStrLn "Received request" 100 | Right msg <- on server Recv 101 | | Left err => pure Nothing 102 | pure (Just (cast msg)) 103 | execAs (server, seed) (SendResp resp) 104 | = do Right ok <- on server (Send (show resp)) 105 | | Left err => on seed (Put ()) 106 | on server Close 107 | on seed (Put ()) 108 | execAs (server, seed) GetSeed 109 | = do sval <- on seed Get 110 | on seed (Put ((1664525 * sval + 1013904223) 111 | `prim__sremBigInt` (pow 2 32))) 112 | pure sval 113 | 114 | -- Create a new session by creating a new seed/connection 115 | createAs (server, seed) Accept 116 | = do seed' <- new Var 117 | (Right addr, conn) <- newFrom server Accept 118 | | (Left err, conn) => pure ((conn, seed'), False) 119 | pure ((conn, seed'), True) 120 | 121 | main : IO () 122 | main = run (Main.startServer) 123 | -------------------------------------------------------------------------------- /examples/Net/RandSimple.idr: -------------------------------------------------------------------------------- 1 | import States 2 | import State.Var 3 | import Network 4 | import Network.Socket 5 | import Interface.IO 6 | 7 | -- A simple server which reads an integer 'bound' and sends back a random 8 | -- number between 0 and bound 9 | rndServer : ConsoleIO io => 10 | (socket : State Net) -> 11 | (seed : State Var) -> 12 | SMs io () [] [Trans socket Listening (const Closed), 13 | Stable seed Integer] 14 | rndServer socket seed = do 15 | (Right addr, conn) <- newFrom socket Accept 16 | | (Left addr, conn) => do delete conn; on socket Close 17 | 18 | Right msg <- on conn Recv 19 | | Left err => do delete conn; on socket Close 20 | printLn msg 21 | 22 | let bound = the Integer (cast msg) 23 | val <- on seed Get 24 | let val' = (1664525 * val + 1013904223) `prim__sremBigInt` (pow 2 32) 25 | on seed (Put val') 26 | 27 | Right ok <- on conn (Send (show (val `mod` (bound + 1)))) 28 | | Left err => do delete conn; on socket Close 29 | 30 | on conn Close 31 | delete conn 32 | rndServer socket seed 33 | 34 | startServer : ConsoleIO io => SMs io () [Net, Var] [] 35 | startServer = do 36 | socket <- new Net 37 | seed <- new Var 38 | on seed (Put 123456789) 39 | Right ok <- on socket (Socket Stream) 40 | | Left err => do delete socket; delete seed 41 | Right ok <- on socket (Bind Nothing 9442) 42 | | Left err => do delete socket; delete seed 43 | Right ok <- on socket Listen 44 | | Left err => do delete socket; delete seed 45 | call (rndServer socket seed) 46 | delete socket 47 | delete seed 48 | 49 | main : IO () 50 | main = run startServer 51 | -------------------------------------------------------------------------------- /examples/Net/Raw.idr: -------------------------------------------------------------------------------- 1 | import Network.Socket 2 | 3 | acceptLoop : Integer -> Socket -> IO () 4 | acceptLoop seed sock 5 | = do Right (conn, addr) <- accept sock 6 | | Left err => putStrLn "Accept fail" 7 | Right (msg, len) <- recv conn 80 8 | 9 | let num = the Integer (cast msg) 10 | let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) 11 | 12 | printLn msg 13 | send conn (show (seed' `mod` (num + 1))) 14 | 15 | close conn 16 | acceptLoop seed' sock 17 | 18 | rnd_server : Integer -> IO () 19 | rnd_server seed = 20 | do Right sock <- socket AF_INET Stream 0 21 | | Left err => putStrLn "Socket fail" 22 | ok <- bind sock Nothing 9442 -- Socket not bound 23 | if (ok /= 0) then putStrLn "Bind fail" 24 | else 25 | do ok <- listen sock -- Socket must be bound 26 | if (ok /= 0) then putStrLn "Listen fail" 27 | else acceptLoop seed sock 28 | 29 | main : IO () 30 | main = do putStrLn "Running on 9442" 31 | rnd_server 1234 32 | -------------------------------------------------------------------------------- /examples/pairres.idr: -------------------------------------------------------------------------------- 1 | import States 2 | import State.Var 3 | 4 | data TwoVarOp : SM_sig (Type, Type) where 5 | GetA : TwoVarOp a (a, b) (const (a, b)) 6 | GetB : TwoVarOp b (a, b) (const (a, b)) 7 | 8 | SetA : c -> TwoVarOp () (a, b) (const (c, b)) 9 | SetB : c -> TwoVarOp () (a, b) (const (a, c)) 10 | 11 | TwoVar : SM (Type, Type) 12 | TwoVar = MkSM ((), ()) (\v => ()) TwoVarOp None 13 | 14 | Transform TwoVar [Var, Var] [] m where 15 | toState (a, b) = (a, b) 16 | initOK = Refl 17 | finalOK (a, b) () = ((), ()) 18 | 19 | execAs (vara, varb) GetA 20 | = on vara Get 21 | execAs (vara, varb) GetB 22 | = on varb Get 23 | execAs (vara, varb) (SetA x) 24 | = on vara (Put x) 25 | execAs (vara, varb) (SetB x) 26 | = on varb (Put x) 27 | 28 | createAs p op = pass op 29 | 30 | test : SMNew m (Int, Int) [TwoVar] 31 | test = do v <- new TwoVar 32 | on v $ SetA 42 33 | on v $ SetB 12 34 | vala <- on v $ GetA 35 | valb <- on v $ GetB 36 | delete v 37 | pure (vala, valb) 38 | 39 | -------------------------------------------------------------------------------- /src/Interface/Exception.idr: -------------------------------------------------------------------------------- 1 | module Interface.Exception 2 | 3 | import States 4 | import Control.IOExcept 5 | 6 | %default total 7 | 8 | public export 9 | interface Exception (err : Type) (m : Type -> Type) where 10 | throw : err -> SMOp m () 11 | 12 | export 13 | Exception err (IOExcept err) where 14 | throw e = lift (ioe_fail e) 15 | 16 | Exception err Maybe where 17 | throw e = lift Nothing 18 | 19 | Exception err (Either err) where 20 | throw e = lift (Left e) 21 | -------------------------------------------------------------------------------- /src/Interface/IO.idr: -------------------------------------------------------------------------------- 1 | module Interface.IO 2 | 3 | import States 4 | import Control.IOExcept 5 | 6 | %default total 7 | 8 | public export 9 | interface ConsoleIO (m : Type -> Type) where 10 | putStr : String -> SMOp m () 11 | getStr : SMOp m String 12 | 13 | export 14 | ConsoleIO IO where 15 | putStr str = lift (putStr str) 16 | getStr = lift getLine 17 | 18 | ConsoleIO (IOExcept err) where 19 | putStr str = lift (ioe_lift (putStr str)) 20 | getStr = lift (ioe_lift getLine) 21 | 22 | using (ConsoleIO io) 23 | export 24 | putStrLn : String -> SMOp io () 25 | putStrLn str = putStr (str ++ "\n") 26 | 27 | export 28 | print : Show a => a -> SMOp io () 29 | print x = putStr (show x) 30 | 31 | export 32 | printLn : Show a => a -> SMOp io () 33 | printLn x = putStrLn (show x) 34 | 35 | -------------------------------------------------------------------------------- /src/State/Var.idr: -------------------------------------------------------------------------------- 1 | module State.Var 2 | 3 | import States 4 | 5 | {- Read and write mutable values -} 6 | public export 7 | data VarOp : SM_sig Type where 8 | Get : VarOp a a (const a) 9 | Put : b -> VarOp () a (const b) 10 | 11 | -- Mutable value state machine 12 | public export 13 | Var : SM Type 14 | Var = MkSM () -- Initial state 15 | (\x => ()) -- All states are valid final states 16 | VarOp -- Operations on the state machine 17 | None -- No creators 18 | 19 | export 20 | Execute Var m where 21 | resource x = x 22 | initialise = () -- No value stored on initialisation 23 | 24 | exec res Get k = k res res 25 | exec res (Put x) k = k () x 26 | 27 | create res op k = pass op 28 | 29 | -------------------------------------------------------------------------------- /src/States.idr: -------------------------------------------------------------------------------- 1 | module States 2 | 3 | import public Utils.PList 4 | 5 | public export 6 | SM_sig : Type -> Type 7 | SM_sig state = (t : Type) -> state -> (t -> state) -> Type 8 | 9 | public export 10 | %error_reverse 11 | record SM stateType where 12 | constructor MkSM 13 | init : stateType 14 | final : stateType -> Type 15 | operations : SM_sig stateType 16 | creators : SM_sig stateType 17 | 18 | -- As a data type, helps with error_reverse and type class search, but 19 | -- really it's just Void 20 | public export 21 | data None : {stateType : Type} -> SM_sig stateType where 22 | NoCmd : {a : stateType} -> Void -> None {stateType} () a (\res => a) 23 | 24 | export 25 | pass : None {stateType} ty ins outf -> a 26 | pass (NoCmd p) = void p 27 | 28 | public export 29 | interface Execute (sm : SM state) (m : Type -> Type) where 30 | resource : state -> Type 31 | initialise : resource (init sm) 32 | 33 | covering 34 | exec : (res : resource in_state) -> 35 | (ops : operations sm ty in_state out_fn) -> 36 | (k : (x : ty) -> resource (out_fn x) -> m a) -> m a 37 | 38 | covering 39 | create : (res : resource in_state) -> 40 | (ops : creators sm ty in_state out_fn) -> 41 | (k : (x : ty) -> resource (out_fn x) -> m a) -> m a 42 | 43 | public export 44 | data State : SM state -> Type where 45 | MkState : State sm 46 | 47 | public export 48 | data Resource : SM state -> Type where 49 | MkRes : label -> (sm : SM state) -> state -> Resource sm 50 | 51 | infix 5 ::: 52 | 53 | %error_reverse 54 | public export 55 | (:::) : {sm : SM state} -> State sm -> (p : state) -> Resource sm 56 | (:::) {sm} lbl st = MkRes lbl sm st 57 | 58 | 59 | -- This needs to be a specialised type, rather than a generic List, 60 | -- because resources might contain List as a type, and we'd end up with 61 | -- a universe cycle. 62 | namespace Context 63 | public export 64 | data Context : PList SM -> Type where 65 | Nil : Context [] 66 | (::) : Resource t -> Context ts -> Context (t :: ts) 67 | 68 | public export 69 | (++) : Context ts -> Context us -> Context (ts ++ us) 70 | (++) [] ys = ys 71 | (++) (x :: xs) ys = x :: xs ++ ys 72 | 73 | public export 74 | appendNilRightNeutral : (l : Context ts) -> l ++ [] = l 75 | appendNilRightNeutral [] = Refl 76 | appendNilRightNeutral (x :: xs) = rewrite appendNilRightNeutral xs in Refl 77 | 78 | public export 79 | data InState : (sm : SM state) -> State r -> state -> Context ts -> Type where 80 | Here : InState sm lbl st (MkRes lbl sm st :: rs) 81 | There : InState sm lbl st rs -> InState sm lbl st (r :: rs) 82 | 83 | public export 84 | updateCtxt : {st : state} -> 85 | (ctxt : Context ts) -> 86 | InState sm lbl st ctxt -> state -> Context ts 87 | updateCtxt ((MkRes lbl st _) :: rs) Here val = ((MkRes lbl st val) :: rs) 88 | updateCtxt (r :: rs) (There x) ty = r :: updateCtxt rs x ty 89 | 90 | public export 91 | dropType : (ts : PList SM) -> (ctxt : Context ts) -> 92 | InState sm lbl st ctxt -> PList SM 93 | dropType (sm :: ts) (MkRes lbl sm st :: xs) Here = ts 94 | dropType (t :: ts) (x :: xs) (There p) = t :: dropType ts xs p 95 | 96 | public export 97 | drop : (ctxt : Context ts) -> (prf : InState sm lbl st ctxt) -> 98 | Context (dropType ts ctxt prf) 99 | drop ((MkRes lbl sm st) :: rs) Here = rs 100 | drop (r :: rs) (There p) = r :: drop rs p 101 | 102 | public export 103 | data ElemCtxt : Resource t -> Context ts -> Type where 104 | HereCtxt : ElemCtxt a (a :: as) 105 | ThereCtxt : ElemCtxt a as -> ElemCtxt a (b :: as) 106 | 107 | public export 108 | data SubCtxt : Context ts -> Context us -> Type where 109 | SubNil : SubCtxt [] xs 110 | InCtxt : ElemCtxt x ys -> SubCtxt xs ys -> SubCtxt (x :: xs) ys 111 | 112 | Uninhabited (ElemCtxt x []) where 113 | uninhabited HereCtxt impossible 114 | uninhabited (ThereCtxt _) impossible 115 | 116 | public export total 117 | updateAt : {xs : Context ts} -> 118 | {val : ty} -> 119 | (idx : ElemCtxt (MkRes lbl sm val) xs) -> 120 | (a : ty) -> Context ts -> Context ts 121 | updateAt HereCtxt a (MkRes lbl ops val :: xs) = MkRes lbl ops a :: xs 122 | updateAt (ThereCtxt p) a (x :: xs) = x :: updateAt p a xs 123 | 124 | public export total 125 | updateWith : {ys : Context ts} -> 126 | (ys' : Context ts) -> (xs : Context us) -> 127 | SubCtxt ys xs -> Context us 128 | updateWith [] xs prf = xs 129 | updateWith (MkRes lbl f a :: ys) xs (InCtxt {x = MkRes _ _ _} idx rest) 130 | = let rec = updateWith ys xs rest in 131 | updateAt idx a (updateWith ys xs rest) 132 | 133 | export 134 | data SMProg : (m : Type -> Type) -> 135 | (ty : Type) -> 136 | PList SM -> 137 | Context ts -> (ty -> Context us) -> 138 | Type where 139 | Pure : (result : val) -> SMProg m val ops (out_fn result) out_fn 140 | Bind : SMProg m a ops st1 st2_fn -> 141 | ((result : a) -> SMProg m b ops (st2_fn result) st3_fn) -> 142 | SMProg m b ops st1 st3_fn 143 | Lift : Monad m => m t -> SMProg m t ops ctxt (const ctxt) 144 | 145 | New : (sm : SM state) -> 146 | {auto prf : PElem sm ops} -> 147 | SMProg m (State sm) ops ctxt 148 | (\lbl => MkRes lbl sm (init sm) :: ctxt) 149 | Delete : (lbl : State iface) -> 150 | {auto prf : InState sm lbl st ctxt} -> 151 | {auto finalok : final sm st} -> 152 | SMProg m () ops ctxt (const (drop ctxt prf)) 153 | 154 | On : (lbl : State sm) -> 155 | {auto prf : InState sm lbl in_state ctxt} -> 156 | (op : operations sm t in_state out_fn) -> 157 | SMProg m t ops ctxt (\res => updateCtxt ctxt prf (out_fn res)) 158 | NewFrom : (lbl : State sm) -> 159 | {auto prf : InState sm lbl in_state ctxt} -> 160 | (op : creators sm t in_state out_fn) -> 161 | SMProg m (t, State sm) 162 | ops ctxt (\res => MkRes (snd res) sm (out_fn (fst res)) :: ctxt) 163 | Call : {auto op_prf : SubList ops' ops} -> 164 | SMProg m t ops' ys ys' -> 165 | {auto ctxt_prf : SubCtxt ys xs} -> 166 | SMProg m t ops xs (\result => updateWith (ys' result) xs ctxt_prf) 167 | 168 | using (sm : SM st) 169 | public export 170 | data Action : Type -> Type where 171 | Stable : State sm -> st -> Action ty 172 | Trans : State sm -> st -> (ty -> st) -> Action ty 173 | Add : State sm -> st -> Action ty 174 | Remove : State sm -> st -> Action ty 175 | 176 | public export 177 | SMs : (m : Type -> Type) -> 178 | (ty : Type) -> 179 | (ops : PList SM) -> 180 | List (Action ty) -> Type 181 | SMs m ty ops xs 182 | = SMProg m ty ops (in_res xs) (\result : ty => out_res result xs) 183 | where 184 | ctxt : (input : Bool) -> List (Action ty) -> PList SM 185 | ctxt inp [] = [] 186 | ctxt inp (Stable {sm} lbl inr :: xs) = sm :: ctxt inp xs 187 | ctxt inp (Trans {sm} lbl inr outr :: xs) = sm :: ctxt inp xs 188 | ctxt inp (Add {sm} lbl inr :: xs) = if inp then ctxt inp xs 189 | else sm :: ctxt inp xs 190 | ctxt inp (Remove {sm} lbl inr :: xs) = if inp then sm :: ctxt inp xs 191 | else ctxt inp xs 192 | 193 | out_res : ty -> (as : List (Action ty)) -> Context (ctxt False as) 194 | out_res x [] = [] 195 | out_res x (Stable {sm} lbl inr :: xs) = MkRes lbl sm inr :: out_res x xs 196 | out_res x (Trans {sm} lbl inr outr :: xs) 197 | = MkRes lbl sm (outr x) :: out_res x xs 198 | out_res x (Add {sm} lbl inr :: xs) = MkRes lbl sm inr :: out_res x xs 199 | out_res x (Remove {sm} lbl inr :: xs) = out_res x xs 200 | 201 | in_res : (as : List (Action ty)) -> Context (ctxt True as) 202 | in_res [] = [] 203 | in_res (Stable {sm} lbl inr :: xs) = MkRes lbl sm inr :: in_res xs 204 | in_res (Trans {sm} lbl inr outr :: xs) = MkRes lbl sm inr :: in_res xs 205 | in_res (Add {sm} lbl inr :: xs) = in_res xs 206 | in_res (Remove {sm} lbl inr :: xs) = MkRes lbl sm inr :: in_res xs 207 | 208 | public export 209 | SMTrans : (m : Type -> Type) -> (ty : Type) -> List (Action ty) -> Type 210 | SMTrans m ty xs 211 | = SMs m ty [] xs 212 | 213 | public export 214 | SMNew : (m : Type -> Type) -> (ty : Type) -> (ops : PList SM) -> Type 215 | SMNew m ty ops = SMs m ty ops [] 216 | 217 | public export 218 | SMOp : (m : Type -> Type) -> Type -> Type 219 | SMOp m ty = {ts : _ } -> {ops : _} -> {ctxt : Context ts} -> 220 | SMProg m ty ops ctxt (const ctxt) 221 | 222 | -- Some useful hints for proof construction in polymorphic programs 223 | %hint 224 | public export total 225 | dropFirst : SubCtxt xs ys -> SubCtxt xs (x :: ys) 226 | dropFirst SubNil = SubNil 227 | dropFirst (InCtxt el sub) = InCtxt (ThereCtxt el) (dropFirst sub) 228 | 229 | %hint 230 | public export total 231 | subListId : (xs : Context ts) -> SubCtxt xs xs 232 | subListId [] = SubNil 233 | subListId (x :: xs) = InCtxt HereCtxt (dropFirst (subListId xs)) 234 | 235 | public export total 236 | inSuffix : ElemCtxt x ys -> SubCtxt xs ys -> ElemCtxt x (zs ++ ys) 237 | inSuffix {zs = []} el sub = el 238 | inSuffix {zs = (x :: xs)} el sub = ThereCtxt (inSuffix el sub) 239 | 240 | %hint 241 | public export total 242 | dropPrefix : SubCtxt xs ys -> SubCtxt xs (zs ++ ys) 243 | dropPrefix SubNil = SubNil 244 | dropPrefix (InCtxt el sub) = InCtxt (inSuffix el sub) (dropPrefix sub) 245 | 246 | public export total 247 | inPrefix : ElemCtxt x ys -> SubCtxt xs ys -> ElemCtxt x (ys ++ zs) 248 | inPrefix {zs = []} {ys} el sub 249 | = rewrite appendNilRightNeutral ys in el 250 | inPrefix {zs = (x :: xs)} HereCtxt sub = HereCtxt 251 | inPrefix {zs = (x :: xs)} (ThereCtxt y) sub = ThereCtxt (inPrefix y SubNil) 252 | 253 | %hint 254 | public export total 255 | dropSuffix : SubCtxt xs ys -> SubCtxt xs (ys ++ zs) 256 | dropSuffix SubNil = SubNil 257 | dropSuffix (InCtxt el sub) = InCtxt (inPrefix el sub) (dropSuffix sub) 258 | 259 | 260 | export 261 | pure : (x : val) -> SMProg m val ops (out_fn x) out_fn 262 | pure = Pure 263 | 264 | export 265 | lift : Monad m => m t -> SMProg m t ops ctxt (const ctxt) 266 | lift = Lift 267 | 268 | export 269 | new : (sm : SM state) -> 270 | {auto prf : PElem sm ops} -> 271 | SMProg m (State sm) ops ctxt 272 | (\lbl => MkRes lbl sm (init sm) :: ctxt) 273 | new = New 274 | 275 | export 276 | delete : (lbl : State iface) -> 277 | {auto prf : InState sm lbl st ctxt} -> 278 | {auto finalok : final sm st} -> 279 | SMProg m () ops ctxt (const (drop ctxt prf)) 280 | delete = Delete 281 | 282 | export 283 | on : (lbl : State sm) -> 284 | {auto prf : InState sm lbl in_state ctxt} -> 285 | (op : operations sm t in_state out_fn) -> 286 | SMProg m t ops ctxt (\res => updateCtxt ctxt prf (out_fn res)) 287 | on = On 288 | 289 | export 290 | newFrom : (lbl : State sm) -> 291 | {auto prf : InState sm lbl in_state ctxt} -> 292 | (op : creators sm t in_state out_fn) -> 293 | SMProg m (t, State sm) 294 | ops ctxt (\ res => MkRes (snd res) sm (out_fn (fst res)) :: ctxt) 295 | newFrom = NewFrom 296 | 297 | export 298 | call : {auto op_prf : SubList ops' ops} -> 299 | SMProg m t ops' ys ys' -> 300 | {auto ctxt_prf : SubCtxt ys xs} -> 301 | SMProg m t ops xs (\result => updateWith (ys' result) xs ctxt_prf) 302 | call = Call 303 | 304 | export 305 | (>>=) : SMProg m a ops st1 st2_fn -> 306 | ((x : a) -> SMProg m b ops (st2_fn x) st3_fn) -> 307 | SMProg m b ops st1 st3_fn 308 | (>>=) = Bind 309 | 310 | public export 311 | stateTypes : PList SM -> Type 312 | stateTypes [] = () 313 | stateTypes ((::) {state} x []) = state 314 | stateTypes ((::) {state} x (y :: xs)) = (state, stateTypes (y :: xs)) 315 | 316 | public export 317 | initStates : (sms : PList SM) -> stateTypes sms 318 | initStates [] = () 319 | initStates (x :: []) = init x 320 | initStates (x :: (y :: xs)) = (init x, initStates (y :: xs)) 321 | 322 | public export 323 | Labels : PList SM -> Type 324 | Labels [] = () 325 | Labels (x :: []) = State x 326 | Labels (x :: (y :: xs)) = (State x, Labels (y :: xs)) 327 | 328 | public export 329 | mkRes : Labels sms -> stateTypes sms -> Context sms 330 | mkRes {sms = []} () () = [] 331 | mkRes {sms = (sm :: [])} l t = MkRes l sm t :: [] 332 | mkRes {sms = (sm :: sm' :: sms)} (l, ls) (t, ts) 333 | = MkRes l sm t :: mkRes ls ts 334 | 335 | public export 336 | AllFinal : (sms : _) -> stateTypes sms -> Type 337 | AllFinal [] x = () 338 | AllFinal (sm :: []) st = final sm st 339 | AllFinal (sm :: z :: zs) (st, sts) = (final sm st, AllFinal _ sts) 340 | 341 | public export 342 | interface Transform (sm : SM state) (sms' : PList SM) 343 | (ops : PList SM) 344 | (m : Type -> Type) | sm, m where 345 | -- Explain how our state corresponds to the inner machine's state 346 | toState : state -> stateTypes sms' 347 | 348 | -- Make sure the initial and final states correspond. 349 | initOK : initStates sms' = toState (init sm) -- 'Refl' should usually work 350 | 351 | finalOK : (x : state) -> (prf : final sm x) -> AllFinal sms' (toState x) 352 | 353 | -- Implement our operations in terms of the inner operations 354 | execAs : (lbls : Labels sms') -> -- State sm') -> 355 | (op : operations sm t in_state tout_fn) -> 356 | SMProg m t ops (mkRes lbls (toState in_state)) 357 | (\result => (mkRes lbls (toState (tout_fn result)))) 358 | 359 | createAs : (lbls : Labels sms') -> -- State sm') -> 360 | (op : creators sm t in_state tout_fn) -> 361 | SMProg m (Labels sms', t) ops (mkRes lbls (toState in_state)) 362 | (\result => 363 | (mkRes (fst result) (toState (tout_fn (snd result)))) 364 | ++ 365 | (mkRes lbls (toState in_state))) 366 | 367 | namespace Env 368 | public export 369 | data Env : (m : Type -> Type) -> Context ts -> Type where 370 | Nil : Env m [] 371 | (::) : (exec : Execute sm m) => 372 | resource @{exec} a -> Env m xs -> Env m (MkRes lbl sm a :: xs) 373 | 374 | namespace Execs 375 | public export 376 | data Execs : (m : Type -> Type) -> PList SM -> Type where 377 | Nil : Execs m [] 378 | (::) : Execute res m -> Execs m xs -> Execs m (res :: xs) 379 | 380 | dropVal : (prf : InState sm lbl st ctxt) -> 381 | Env m ctxt -> Env m (drop ctxt prf) 382 | dropVal Here (x :: xs) = xs 383 | dropVal (There p) (x :: xs) = x :: dropVal p xs 384 | 385 | envElem : ElemCtxt x xs -> Env m xs -> Env m [x] 386 | envElem HereCtxt (x :: xs) = [x] 387 | envElem (ThereCtxt p) (x :: xs) = envElem p xs 388 | 389 | dropEnv : Env m ys -> SubCtxt xs ys -> Env m xs 390 | dropEnv [] SubNil = [] 391 | dropEnv (x :: xs) SubNil = [] 392 | dropEnv [] (InCtxt idx rest) = absurd idx 393 | dropEnv (x :: xs) (InCtxt idx rest) 394 | = let [e] = envElem idx (x :: xs) in 395 | e :: dropEnv (x :: xs) rest 396 | 397 | getExecute : (execs : Execs m rs) -> (pos : PElem sm rs) -> 398 | Execute sm m 399 | getExecute (h :: hs) Here = h 400 | getExecute (_ :: hs) (There p) = getExecute hs p 401 | 402 | execsElem : PElem x xs -> Execs m xs -> Execs m [x] 403 | execsElem Here (x :: xs) = [x] 404 | execsElem (There p) (x :: xs) = execsElem p xs 405 | 406 | dropExecs : Execs m ys -> SubList xs ys -> Execs m xs 407 | dropExecs [] SubNil = [] 408 | dropExecs [] (InList idx rest) = absurd idx 409 | dropExecs (x :: xs) SubNil = [] 410 | dropExecs (x :: xs) (InList idx rest) 411 | = let [e] = execsElem idx (x :: xs) in 412 | e :: dropExecs (x :: xs) rest 413 | 414 | getEnvExecute : {xs, ys : Context ts} -> 415 | ElemCtxt (MkRes lbl sm val) xs -> Env m ys -> Execute sm m 416 | getEnvExecute HereCtxt (h :: hs) = %implementation 417 | getEnvExecute (ThereCtxt p) (h :: hs) = getEnvExecute p hs 418 | 419 | replaceEnvAt : (exec : Execute sm m) => 420 | {xs, ys : Context ts} -> 421 | (idx : ElemCtxt (MkRes lbl sm val) xs) -> 422 | (env : Env m ys) -> 423 | (resource @{exec} st) -> 424 | Env m (updateAt idx st ys) 425 | replaceEnvAt @{exec} HereCtxt (y :: ys) x = (::) @{exec} x ys 426 | replaceEnvAt (ThereCtxt p) (y :: ys) x = y :: replaceEnvAt p ys x 427 | 428 | rebuildEnv : {ys, ys' : Context ts} -> 429 | Env m ys' -> (prf : SubCtxt ys inr) -> Env m inr -> 430 | Env m (updateWith ys' inr prf) 431 | rebuildEnv [] SubNil env = env 432 | rebuildEnv ((::) {a} res xs) (InCtxt {x = MkRes lbl sm val} idx rest) env 433 | = replaceEnvAt idx (rebuildEnv xs rest env) res 434 | 435 | getIFaceExecute : InState sm lbl in_state ctxt -> 436 | Env m ctxt -> Execute sm m 437 | getIFaceExecute Here (h :: hs) = %implementation 438 | getIFaceExecute (There p) (h :: hs) = getIFaceExecute p hs 439 | 440 | lookupEnv : (i : InState sm lbl in_state ctxt) -> 441 | (env : Env m ctxt) -> 442 | (resource @{getIFaceExecute i env} in_state) 443 | lookupEnv Here (h :: hs) = h 444 | lookupEnv (There p) (h :: hs) = lookupEnv p hs 445 | 446 | 447 | private 448 | execRes : Env m ctxt -> 449 | (prf : InState sm lbl in_state ctxt) -> 450 | (op : operations sm t in_state out_fn) -> 451 | ((x : t) -> Env m (updateCtxt ctxt prf (out_fn x)) -> m b) -> 452 | m b 453 | execRes {sm} {in_state} {out_fn} (val :: env) Here op k 454 | = exec {sm} {in_state} {out_fn} val op (\v, res => k v (res :: env)) 455 | execRes {sm} {in_state} {out_fn} (val :: env) (There p) op k 456 | = execRes {sm} {in_state} {out_fn} env p op (\v, env' => k v (val :: env')) 457 | 458 | -- private 459 | -- createRes : Env m ctxt -> 460 | -- (op : creators sm t in_state out_fn) -> 461 | -- ((x : (t, State sm)) -> 462 | -- Env m (MkRes (snd x) sm (out_fn (fst x)) :: ctxt) -> m b) -> 463 | -- m b 464 | -- execRes {sm} {in_state} {out_fn} (val :: env) Here op k 465 | -- = exec {sm} {in_state} {out_fn} val op (\v, res => k v (res :: env)) 466 | -- execRes {sm} {in_state} {out_fn} (val :: env) (There p) op k 467 | -- = execRes {sm} {in_state} {out_fn} env p op (\v, env' => k v (val :: env')) 468 | 469 | export total 470 | runSMs : Env m inr -> Execs m ops -> 471 | SMProg m a ops inr outfn -> 472 | ((x : a) -> Env m (outfn x) -> m b) -> m b 473 | runSMs env execs (Pure x) k = k x env 474 | runSMs env execs (Bind prog next) k 475 | = runSMs env execs prog (\prog', env' => runSMs env' execs (next prog') k) 476 | runSMs env execs (Lift action) k 477 | = do res <- action 478 | k res env 479 | runSMs env execs (New {prf} sm) k 480 | = let h = getExecute execs prf 481 | res = initialise @{h} in 482 | k MkState (res :: env) 483 | runSMs env execs (Delete {prf} lbl) k 484 | = k () (dropVal prf env) 485 | runSMs env execs (On {prf} lbl op) k 486 | = execRes env prf op k 487 | runSMs env execs (NewFrom {sm} {in_state} {out_fn} {prf} lbl op) k 488 | = let envItem = lookupEnv prf env 489 | h = getIFaceExecute prf env in 490 | create {sm} {out_fn} {in_state} 491 | envItem op (\val, res => k (val, MkState) 492 | (res :: env)) 493 | runSMs env execs (Call {op_prf} prog {ctxt_prf}) k 494 | = let env' = dropEnv env ctxt_prf 495 | execs' = dropExecs execs op_prf in 496 | runSMs env' execs' prog 497 | (\prog', envk => k prog' (rebuildEnv envk ctxt_prf env)) 498 | 499 | 500 | public export 501 | interface ExecList (m : Type -> Type) (ops : PList SM) where 502 | constructor MkExecList 503 | mkExecs : Execs m ops 504 | 505 | export total 506 | run : (Applicative m, ExecList m ops) => 507 | SMProg m a ops [] (const []) -> 508 | m a 509 | run prog = runSMs [] mkExecs prog (\res, env' => pure res) 510 | 511 | export total 512 | runPure : ExecList Basics.id ops => 513 | SMProg Basics.id a ops [] (const []) -> a 514 | runPure prog = runSMs [] mkExecs prog (\res, env' => res) 515 | 516 | export 517 | ExecList m [] where 518 | mkExecs = [] 519 | 520 | export 521 | (Execute res m, ExecList m xs) => ExecList m (res :: xs) where 522 | mkExecs = %implementation :: mkExecs 523 | 524 | firstExec : ExecList m (res :: xs) -> Execute res m 525 | firstExec x with (mkExecs @{x}) 526 | firstExec x | (y :: ys) = y 527 | 528 | mkExecList : Execs m ops -> ExecList m ops 529 | mkExecList {ops = []} x = %implementation 530 | mkExecList {ops = (y :: ys)} (h :: xs) 531 | = let rec = mkExecList xs in %implementation 532 | 533 | tailExec : ExecList m (res :: xs) -> ExecList m xs 534 | tailExec es with (mkExecs @{es}) 535 | tailExec es | (y :: ys) = mkExecList ys 536 | 537 | {- Yuck. What follows is largely write only code, but at least it type checks. 538 | 539 | There is, however, a 'believe_me' in envRes. Given that at this stage there is 540 | only one possibility for the inner 'Execute', because it's a generic thing we 541 | have to pass in and there's no way of changing it in 'runSMs', this is 542 | currently fine. But: how to convince Idris? And will it always be fine? What 543 | if we change 'runSMs'? 544 | -} 545 | 546 | resources : (sms : _) -> ExecList m sms -> stateTypes sms -> Type 547 | resources [] es st = () 548 | resources (x :: []) es st = resource @{firstExec es} st 549 | resources (x :: (y :: ys)) es (st, sts) 550 | = (resource @{firstExec es} st, resources (y :: ys) @{tailExec es} sts) 551 | 552 | initAll : (sms : _) -> 553 | (es : ExecList m sms) -> resources sms es (initStates sms) 554 | initAll [] es = () 555 | initAll (x :: []) es = initialise {sm=x} @{firstExec es} 556 | initAll (x :: (y :: ys)) es 557 | = (initialise {sm=x} @{firstExec es}, initAll (y :: ys) (tailExec es)) 558 | 559 | resCtxt : (sms : _) -> (sts : stateTypes sms) -> Context sms 560 | resCtxt [] sts = [] 561 | resCtxt (sm :: []) st = [MkRes (MkState {sm}) sm st] 562 | resCtxt (sm :: (y :: ys)) (st, sts) 563 | = MkRes (MkState {sm}) sm st :: resCtxt _ sts 564 | 565 | resEnv : {lower : ExecList m sms} -> 566 | (lbls : _) -> 567 | (res : resources sms lower sts) -> Env m (mkRes lbls sts) 568 | resEnv {sms = []} {sts = ()} () res = [] 569 | resEnv {lower} {sms = (x :: [])} {sts} lbls res 570 | = (::) @{firstExec lower} res [] 571 | resEnv {lower = lower} {sts = (st, sts)} {sms = (x :: y :: ys)} 572 | (lbl, lbls) (res, rest) 573 | = (::) @{firstExec lower} res (resEnv lbls rest) 574 | 575 | mkLabels : (sms : _) -> Labels sms 576 | mkLabels [] = () 577 | mkLabels (x :: []) = MkState 578 | mkLabels (x :: y :: ys) = (MkState, mkLabels (y :: ys)) 579 | 580 | envRes : {ctxt : Context sms} -> 581 | Env m ctxt -> resources sms lower sts 582 | envRes [] = () 583 | envRes (y :: []) = believe_me y 584 | envRes {m} ((::) {m} y ((::) {sm} {m} {a} {lbl} z zs)) {sts = (st, sts)} 585 | = (believe_me y, envRes {m} ((::) {sm} {m} {a} {lbl} z zs)) 586 | 587 | take : {ctxt : Context sms} -> {ctxt' : Context sms'} -> 588 | Env m (ctxt ++ ctxt') -> Env m ctxt 589 | take {ctxt = []} env = [] 590 | take {ctxt = (_ :: hs)} (x :: env) = x :: take env 591 | 592 | using (sm : SM state, sms' : PList SM) 593 | export 594 | %overlapping -- It's not really, because of the superinterface, 595 | -- but the check isn't good enough for this yet 596 | (trans : Transform sm sms' ops m, 597 | ExecList m ops, 598 | lower : ExecList m sms') => Execute sm m where 599 | resource @{trans} @{_} @{lower} {sms'} x 600 | = resources sms' lower (toState @{trans} x) 601 | initialise @{trans} @{_} @{lower} {sms'} 602 | = rewrite sym (initOK @{trans}) in 603 | initAll sms' lower -- (initStates sms') 604 | 605 | exec @{trans} @{_} @{lower} {out_fn} {sms'} res op k = 606 | let env = resEnv (mkLabels sms') res in 607 | runSMs env mkExecs 608 | (execAs {sm} {m} {tout_fn=out_fn} (mkLabels sms') op) 609 | (\result, envk => k result (envRes envk)) 610 | 611 | create @{trans} @{_} @{lower} {out_fn} {sms'} res op k = -- ?foo -- void (noCreators @{nocreate} op) 612 | let env = resEnv (mkLabels sms') res in 613 | runSMs env mkExecs 614 | (createAs {sm} {m} {tout_fn=out_fn} (mkLabels sms') op) 615 | (\result, envk => k (snd result) (envRes (take envk))) 616 | -------------------------------------------------------------------------------- /src/Utils/PList.idr: -------------------------------------------------------------------------------- 1 | module PList 2 | 3 | import public Data.List 4 | 5 | public export 6 | data PList : (Type -> Type) -> Type where 7 | Nil : PList p 8 | (::) : p state -> PList p -> PList p 9 | 10 | public export 11 | (++) : PList p -> PList p -> PList p 12 | (++) [] ys = ys 13 | (++) (x :: xs) ys = x :: xs ++ ys 14 | 15 | public export 16 | appendNilRightNeutral : (l : PList p) -> l ++ [] = l 17 | appendNilRightNeutral [] = Refl 18 | appendNilRightNeutral (x :: xs) = cong (appendNilRightNeutral xs) 19 | 20 | public export 21 | data PElem : p state -> PList p -> Type where 22 | Here : {p : Type -> Type} -> {a : p state} -> PElem {p} a (a :: as) 23 | There : PElem a as -> PElem a (b :: as) 24 | 25 | public export 26 | Uninhabited (PElem {p} x []) where 27 | uninhabited (Here {p} {a}) impossible 28 | 29 | public export 30 | data SubList : PList a -> PList a -> Type where 31 | SubNil : SubList [] xs 32 | InList : PElem x ys -> SubList xs ys -> SubList (x :: xs) ys 33 | 34 | -- Some useful hints for proof construction in polymorphic programs 35 | %hint 36 | public export total 37 | dropFirst : SubList xs ys -> SubList xs (x :: ys) 38 | dropFirst SubNil = SubNil 39 | dropFirst (InList el sub) = InList (There el) (dropFirst sub) 40 | 41 | %hint 42 | public export total 43 | subListId : (xs : PList p) -> SubList xs xs 44 | subListId [] = SubNil 45 | subListId (x :: xs) = InList Here (dropFirst (subListId xs)) 46 | 47 | public export total 48 | inSuffix : PElem x ys -> SubList xs ys -> PElem x (zs ++ ys) 49 | inSuffix {zs = []} el sub = el 50 | inSuffix {zs = (x :: xs)} el sub = There (inSuffix el sub) 51 | 52 | %hint 53 | public export total 54 | dropPrefix : SubList xs ys -> SubList xs (zs ++ ys) 55 | dropPrefix SubNil = SubNil 56 | dropPrefix (InList el sub) = InList (inSuffix el sub) (dropPrefix sub) 57 | 58 | public export total 59 | inPrefix : PElem x ys -> SubList xs ys -> PElem x (ys ++ zs) 60 | inPrefix {zs = []} {ys} el sub 61 | = rewrite appendNilRightNeutral ys in el 62 | inPrefix {zs = (x :: xs)} Here sub = Here 63 | inPrefix {zs = (x :: xs)} (There y) sub = There (inPrefix y SubNil) 64 | 65 | 66 | -------------------------------------------------------------------------------- /states.ipkg: -------------------------------------------------------------------------------- 1 | package states 2 | 3 | version = 0.1 4 | 5 | sourcedir = src 6 | modules = States 7 | , State.Var 8 | 9 | , Interface.IO 10 | , Interface.Exception 11 | 12 | , Utils.PList 13 | --------------------------------------------------------------------------------