├── Effects ├── Door1.idr ├── Door2.idr ├── Expr.idr ├── FileTest.idr ├── Queens.idr ├── README ├── TreeLabel.idr ├── TreeLabelLvs.idr └── testfile ├── GuessNumber └── guessnumber.idr ├── Hangman ├── Hangman.idr ├── VectMissing.idr └── hangman.ipkg ├── Intro ├── Adder.idr ├── Elem.idr └── Vect.idr ├── Invaders ├── Aliens.idr ├── Gamestate.idr ├── Main.idr ├── Rnd.idr ├── Starfield.idr └── invaders.ipkg ├── LICENSE ├── README.md ├── RLE ├── README ├── rle-vect.idr └── rle.idr └── ResDSL ├── FileDSL.idr ├── Resimp.idr └── test /Effects/Door1.idr: -------------------------------------------------------------------------------- 1 | module Door 2 | 3 | import Effects 4 | 5 | data DoorState = Closed | Open 6 | data DoorInfo : DoorState -> Type where 7 | DI : DoorInfo s 8 | 9 | data Door : Effect where 10 | OpenDoor : sig Door () (DoorInfo Closed) (DoorInfo Open) 11 | CloseDoor : sig Door () (DoorInfo Open) (DoorInfo Closed) 12 | Knock : sig Door () (DoorInfo Closed) 13 | 14 | DOOR : DoorState -> EFFECT 15 | DOOR t = MkEff (DoorInfo t) Door 16 | 17 | openDoor : Eff () [DOOR Closed] [DOOR Open] 18 | openDoor = call OpenDoor 19 | 20 | closeDoor : Eff () [DOOR Open] [DOOR Closed] 21 | closeDoor = call CloseDoor 22 | 23 | knock : Eff () [DOOR Closed] 24 | knock = call Knock 25 | 26 | doorProg : Eff () [DOOR Closed] 27 | doorProg = do knock 28 | openDoor 29 | closeDoor 30 | 31 | 32 | -------------------------------------------------------------------------------- /Effects/Door2.idr: -------------------------------------------------------------------------------- 1 | module Door 2 | 3 | import Effects 4 | import Effect.StdIO 5 | 6 | data DoorState = Closed | Open 7 | 8 | data DoorInfo : DoorState -> Type where 9 | DI : DoorInfo s 10 | 11 | data Jam = Jammed | OK 12 | 13 | data Door : Effect where 14 | OpenDoor : sig Door Jam (DoorInfo Closed) 15 | (\jammed => 16 | DoorInfo (case jammed of 17 | Jammed => Closed 18 | OK => Open)) 19 | CloseDoor : sig Door () (DoorInfo Open) (DoorInfo Closed) 20 | Knock : sig Door () (DoorInfo Closed) 21 | 22 | DOOR : DoorState -> EFFECT 23 | DOOR t = MkEff (DoorInfo t) Door 24 | 25 | openDoor : Eff Jam [DOOR Closed] 26 | (\jammed => [DOOR (case jammed of 27 | Jammed => Closed 28 | OK => Open)]) 29 | openDoor = call OpenDoor 30 | 31 | closeDoor : Eff () [DOOR Open] [DOOR Closed] 32 | closeDoor = call CloseDoor 33 | 34 | knock : Eff () [DOOR Closed] 35 | knock = call Knock 36 | 37 | doorProg : Eff () [STDIO, DOOR Closed] 38 | doorProg = do OK <- openDoor | Jammed => putStrLn "It's stuck!" 39 | closeDoor 40 | knock 41 | OK <- openDoor | Jammed => putStrLn "It's stuck!" 42 | closeDoor 43 | 44 | 45 | 46 | -------------------------------------------------------------------------------- /Effects/Expr.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effects 4 | import Effect.State 5 | import Effect.Exception 6 | import Effect.Random 7 | import Effect.StdIO 8 | 9 | data Expr = Var String 10 | | Val Integer 11 | | Add Expr Expr 12 | | Random Integer 13 | 14 | Env : Type 15 | Env = List (String, Integer) 16 | 17 | getRnd : Integer -> Eff Integer [RND, STDIO] 18 | getRnd upper = rndInt 0 upper 19 | 20 | eval : Expr -> Eff Integer [STDIO, EXCEPTION String, STATE Env, RND] 21 | eval (Var x) 22 | = case lookup x !get of 23 | Nothing => raise ("No such variable " ++ x) 24 | Just val => return val 25 | eval (Val x) = return x 26 | eval (Add l r) = return (!(eval l) + !(eval r)) 27 | eval (Random x) = do val <- getRnd x 28 | putStrLn (show val) 29 | return val 30 | 31 | testExpr : Expr 32 | testExpr = Add (Add (Var "foo") (Val 42)) (Random 100) 33 | 34 | runEval : List (String, Integer) -> Expr -> IO Integer 35 | runEval args expr = run (eval' expr) 36 | where eval' : Expr -> Eff Integer [EXCEPTION String, RND, STDIO, STATE Env] 37 | eval' e = do put args 38 | srand 1234 39 | eval e 40 | 41 | main : IO () 42 | main = do putStr "Number: " 43 | x <- getLine 44 | val <- runEval [("foo", cast x)] testExpr 45 | putStrLn $ "Answer: " ++ show val 46 | val <- runEval [("foo", cast x)] testExpr 47 | putStrLn $ "Answer: " ++ show val 48 | 49 | -------------------------------------------------------------------------------- /Effects/FileTest.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effects 4 | import Effect.File 5 | import Effect.State 6 | import Effect.StdIO 7 | import Control.IOExcept 8 | 9 | FileIO : Type -> Type -> Type 10 | FileIO st t 11 | = Eff t [FILE_IO st, STDIO, STATE Int] 12 | 13 | readFile : FileIO (OpenFile Read) (List String) 14 | readFile = readAcc [] where 15 | readAcc : List String -> FileIO (OpenFile Read) (List String) 16 | readAcc acc = do e <- eof 17 | if (not e) 18 | then do str <- readLine 19 | put (!get + 1) 20 | readAcc (str :: acc) 21 | else return (reverse acc) 22 | 23 | dumpFile : String -> FileIO () () 24 | dumpFile fname = do ok <- open fname Read 25 | staticEff $ -- toEff [FILE_IO _, _, _] $ 26 | case ok of 27 | True => do num <- get 28 | putStrLn (show !get ++ "\n" ++ 29 | show !readFile) 30 | close 31 | False => putStrLn ("Error!") 32 | putStrLn "DONE!" 33 | return () 34 | 35 | main : IO () 36 | main = run $ dumpFile "testfile" 37 | 38 | 39 | -------------------------------------------------------------------------------- /Effects/Queens.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effects 4 | import Effect.Select 5 | 6 | no_attack : (Int, Int) -> (Int, Int) -> Bool 7 | no_attack (x, y) (x', y') 8 | = x /= x' && y /= y' && abs (x - x') /= abs (y - y') 9 | 10 | rowsIn : Int -> List (Int, Int) -> List Int 11 | rowsIn col qs = [ x | x <- [1..8], all (no_attack (x, col)) qs ] 12 | 13 | addQueens : Int -> List (Int, Int) -> Eff (List (Int, Int)) [SELECT] 14 | addQueens 0 qs = return qs 15 | addQueens col qs = do row <- select (rowsIn col qs) 16 | addQueens (col - 1) ((row, col) :: qs) 17 | 18 | getQueens : Maybe (List (Int, Int)) 19 | getQueens = run (addQueens 8 []) 20 | 21 | main : IO () 22 | main = do let qs = getQueens 23 | putStrLn ("Solution:\n" ++ show qs) 24 | 25 | -- let num = the Integer (cast (length qs)) 26 | -- putStrLn (show num ++ " solutions:\n" ++ showAll qs) 27 | -- where showAll [] = "" 28 | -- showAll (x :: xs) = show x ++ "\n" ++ showAll xs 29 | 30 | -------------------------------------------------------------------------------- /Effects/README: -------------------------------------------------------------------------------- 1 | To load these into idris, use: 2 | 3 | $ idris [filename].idr -p effects 4 | -------------------------------------------------------------------------------- /Effects/TreeLabel.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effects 4 | import Effect.State 5 | 6 | data Tree a = Leaf 7 | | Node (Tree a) a (Tree a) 8 | 9 | flattenTree : Tree a -> List a 10 | flattenTree Leaf = [] 11 | flattenTree (Node l x r) = flattenTree l ++ (x :: flattenTree r) 12 | 13 | testTree : Tree String 14 | testTree = Node (Node Leaf "One" (Node Leaf "Two" Leaf)) 15 | "Three" 16 | (Node (Node Leaf "Four" Leaf) "Five" Leaf) 17 | 18 | data Tag : Type where 19 | data Leaves : Type where 20 | 21 | label : Tree a -> Eff (Tree (Int, a)) [STATE Int] 22 | label Leaf = return Leaf 23 | label (Node l x r) = do l' <- label l 24 | lbl <- get 25 | put (lbl + 1) 26 | r' <- label r 27 | return (Node l' (lbl, x) r') 28 | 29 | main : IO () 30 | main = do let t = runPure (do put 1; label testTree) 31 | print (flattenTree t) 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | {- 47 | label Leaf = return Leaf 48 | label (Node l x r) = do l' <- label l 49 | lbl <- get 50 | put (lbl + 1) 51 | r' <- label r 52 | return (Node l' (lbl, x) r') 53 | -} 54 | -------------------------------------------------------------------------------- /Effects/TreeLabelLvs.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effects 4 | import Effect.State 5 | 6 | data Tree a = Leaf 7 | | Node (Tree a) a (Tree a) 8 | 9 | flattenTree : Tree a -> List a 10 | flattenTree Leaf = [] 11 | flattenTree (Node l x r) = flattenTree l ++ (x :: flattenTree r) 12 | 13 | testTree : Tree String 14 | testTree = Node (Node Leaf "One" (Node Leaf "Two" Leaf)) 15 | "Three" 16 | (Node (Node Leaf "Four" Leaf) "Five" Leaf) 17 | 18 | data Tag : Type where 19 | data Leaves : Type where 20 | 21 | label : Tree a -> Eff (Tree (Int, a)) [Leaves ::: STATE Int, 22 | Tag ::: STATE Int] 23 | label Leaf = do Leaves :- update (+1) 24 | return Leaf 25 | label (Node l x r) = do l' <- label l 26 | lbl <- Tag :- get 27 | Tag :- put (lbl + 1) 28 | r' <- label r 29 | return (Node l' (lbl, x) r') 30 | 31 | main : IO () 32 | main = do -- let ([Leaves := l, _], x) 33 | let x = runPureInit [default, Tag := 1] (label testTree) 34 | print (flattenTree x) 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | {- 50 | label Leaf = return Leaf 51 | label (Node l x r) = do l' <- label l 52 | lbl <- get 53 | put (lbl + 1) 54 | r' <- label r 55 | return (Node l' (lbl, x) r') 56 | -} 57 | -------------------------------------------------------------------------------- /Effects/testfile: -------------------------------------------------------------------------------- 1 | Hello 2 | Trendy 3 | Functional 4 | People! 5 | -------------------------------------------------------------------------------- /GuessNumber/guessnumber.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effects 4 | import Effect.StdIO 5 | import Effect.Random 6 | 7 | data GameState = NotRunning 8 | | Running Nat 9 | 10 | data GameInfo : GameState -> Type where 11 | Number : (guesses : Nat) -> 12 | (answer : Int) -> GameInfo (Running (S guesses)) 13 | Lost : (answer : Int) -> GameInfo (Running Z) 14 | Init : GameInfo NotRunning 15 | 16 | data Result = TooLow | Correct | TooHigh 17 | 18 | data GuessNumber : Effect where 19 | GuessNum : Int -> 20 | sig GuessNumber Result 21 | (GameInfo (Running (S k))) 22 | (\guess => 23 | GameInfo (case guess of 24 | Correct => NotRunning 25 | _ => Running k)) 26 | Quit : sig GuessNumber Int (GameInfo (Running Z)) (GameInfo NotRunning) 27 | 28 | GUESS : GameState -> EFFECT 29 | GUESS t = MkEff (GameInfo t) GuessNumber 30 | 31 | guess : Int -> { [GUESS (Running (S k))] ==> 32 | {guess} [GUESS (case guess of 33 | Correct => NotRunning 34 | _ => Running k)] } Eff Result 35 | guess n = call $ GuessNum n 36 | 37 | quit : Eff Int [GUESS (Running Z)] [GUESS NotRunning] 38 | quit = call Quit 39 | 40 | Handler GuessNumber m where 41 | handle (Number g n) (GuessNum i) k with (compare i n) 42 | handle (Number (S g) n) (GuessNum i) k | LT = k TooLow (Number g n) 43 | handle (Number Z n) (GuessNum i) k | LT = k TooLow (Lost n) 44 | handle (Number g n) (GuessNum i) k | EQ = k Correct Init 45 | handle (Number Z n) (GuessNum i) k | GT = k TooHigh (Lost n) 46 | handle (Number (S g) n) (GuessNum i) k | GT = k TooHigh (Number g n) 47 | handle (Lost n) Quit k = k n Init 48 | 49 | game : Eff () [GUESS (Running n), STDIO] [GUESS NotRunning, STDIO] 50 | game {n=Z} = do putStrLn "You lose" 51 | ans <- quit 52 | putStrLn $ "The answer was " ++ show ans 53 | game {n=S g} 54 | = do putStr "Guess: " 55 | let num = cast (trim !getStr) 56 | case !(guess num) of 57 | TooLow => do putStrLn "Too low" 58 | game 59 | Correct => putStrLn "You win!" 60 | TooHigh => do putStrLn "Too high" 61 | game 62 | 63 | main : IO () 64 | main = runInit [Number 5 42, ()] game 65 | 66 | -------------------------------------------------------------------------------- /Hangman/Hangman.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effects 4 | import Effect.StdIO 5 | import Effect.System 6 | import Effect.Random 7 | import Data.So 8 | import Data.Fin 9 | import Data.Vect 10 | import VectMissing 11 | 12 | ----------------------------------------------------------------------- 13 | -- GAME STATE 14 | ----------------------------------------------------------------------- 15 | 16 | {- First, the game state, HState, where the type specifies how many guesses 17 | are left and how many missing letters there are still to get. -} 18 | 19 | data HState = Running Nat Nat | NotRunning 20 | 21 | data Hangman : HState -> Type where 22 | Init : Hangman NotRunning -- initialising, but not ready 23 | GameWon : String -> Hangman NotRunning 24 | GameLost : String -> Hangman NotRunning 25 | MkH : (word : String) -> 26 | (guesses : Nat) -> 27 | (got : List Char) -> 28 | (missing : Vect m Char) -> 29 | Hangman (Running guesses m) 30 | 31 | Default (Hangman NotRunning) where 32 | default = Init 33 | 34 | Show (Hangman s) where 35 | show Init = "Not ready yet" 36 | show (GameWon w) = "You won! Successfully guessed " ++ w 37 | show (GameLost w) = "You lost! The word was " ++ w 38 | show (MkH w guesses got missing) 39 | = let w' = pack (map showGot (unpack w)) in 40 | w' ++ "\n\n" ++ show guesses ++ " guesses left" 41 | where showGot : Char -> Char 42 | showGot ' ' = '/' 43 | showGot c = if ((not (isAlpha c)) || (c `elem` got)) then c else '-' 44 | 45 | {- Initialise the state with the missing letters in a word -} 46 | 47 | total 48 | letters : String -> List Char 49 | letters x with (strM x) 50 | letters "" | StrNil = [] 51 | letters (strCons y xs) | (StrCons y xs) 52 | = let xs' = assert_total (letters xs) in 53 | if ((not (isAlpha y)) || (y `elem` xs')) then xs' else y :: xs' 54 | 55 | initState : (x : String) -> Hangman (Running 6 (length (letters x))) 56 | initState w = let xs = letters w in 57 | MkH w _ [] (fromList (letters w)) 58 | 59 | ----------------------------------------------------------------------- 60 | -- RULES 61 | ----------------------------------------------------------------------- 62 | 63 | {- Now, the rules of the game, written as an Effect. 64 | We can think of the rules as giving a protocol that the game player and 65 | the machine must follow for an implementation of the game to make sense. 66 | -} 67 | 68 | data HangmanRules : Effect where 69 | 70 | -- Rule: 71 | -- Precondition: we can make a guess if we have one or more guess available 72 | -- (S g) and one or more letters are still missing (S w) 73 | 74 | -- Postcondition: return whether the character was in the word. If so, reduce 75 | -- the number of missing letters, if not, reduce the number of guesses left 76 | 77 | Guess : (x : Char) -> 78 | sig HangmanRules Bool 79 | (Hangman (Running (S g) (S w))) 80 | (\inword => 81 | Hangman (case inword of 82 | True => (Running (S g) w) 83 | False => (Running g (S w)))) 84 | 85 | -- The 'Won' operation requires that there are no missing letters 86 | 87 | Won : sig HangmanRules () 88 | (Hangman (Running g 0)) 89 | (Hangman NotRunning) 90 | 91 | -- The 'Lost' operation requires that there are no guesses left 92 | 93 | Lost : sig HangmanRules () 94 | (Hangman (Running 0 g)) 95 | (Hangman NotRunning) 96 | 97 | -- Set up a new game, initialised with 6 guesses and the missing letters in 98 | -- the given word. Note that if there are no letters in the word, we won't 99 | -- be able to run 'Guess'! 100 | 101 | NewWord : (w : String) -> 102 | sig HangmanRules () h (Hangman (Running 6 (length (letters w)))) 103 | 104 | -- Finally, allow us to get the current game state 105 | 106 | Get : sig HangmanRules h h 107 | 108 | HANGMAN : HState -> EFFECT 109 | HANGMAN h = MkEff (Hangman h) HangmanRules 110 | 111 | -- Promote explicit effects to Eff programs 112 | 113 | guess : Char -> Eff Bool 114 | [HANGMAN (Running (S g) (S w))] 115 | (\inword => [HANGMAN (case inword of 116 | True => Running (S g) w 117 | False => Running g (S w))]) 118 | guess c = call (Main.Guess c) 119 | 120 | won : Eff () [HANGMAN (Running g 0)] [HANGMAN NotRunning] 121 | won = call Won 122 | 123 | lost : Eff () [HANGMAN (Running 0 g)] [HANGMAN NotRunning] 124 | lost = call Lost 125 | 126 | new_word : (w : String) -> Eff () [HANGMAN h] 127 | [HANGMAN (Running 6 (length (letters w)))] 128 | new_word w = call (NewWord w) 129 | 130 | get : Eff (Hangman h) [HANGMAN h] 131 | get = call Get 132 | 133 | ----------------------------------------------------------------------- 134 | -- IMPLEMENTATION OF THE RULES 135 | ----------------------------------------------------------------------- 136 | 137 | {- This effect handler simply updates the game state as necessary for 138 | each operation. 'Guess' is slightly tricky, in that it needs to check 139 | whether the letter is in the word, and branch accordingly (and if it 140 | is in the word, update the vector of missing letters to be the right 141 | length). -} 142 | 143 | Handler HangmanRules m where 144 | handle (MkH w g got []) Won k = k () (GameWon w) 145 | handle (MkH w Z got m) Lost k = k () (GameLost w) 146 | 147 | handle st Get k = k st st 148 | handle st (NewWord w) k = k () (initState w) 149 | 150 | handle (MkH w (S g) got m) (Guess x) k = 151 | case isElem x m of 152 | No _ => k False (MkH w _ got m) 153 | Yes p => k True (MkH w _ (x :: got) (shrink m p)) 154 | 155 | ----------------------------------------------------------------------- 156 | -- USER INTERFACE 157 | ----------------------------------------------------------------------- 158 | 159 | {- Finally, an implementation of the game which reads user input and calls 160 | the operations we defined above when appropriate. 161 | 162 | The type indicates that the game must start in a running state, with some 163 | guesses available, and get to a not running state (i.e. won or lost). 164 | Since we picked a word at random, we can't actually make the assumption there 165 | were valid letters in it! 166 | -} 167 | 168 | soRefl : So x -> (x = True) 169 | soRefl Oh = Refl 170 | 171 | game : Eff () [HANGMAN (Running (S g) w), STDIO] 172 | [HANGMAN NotRunning, STDIO] 173 | game {w=Z} = won 174 | game {w=S _} 175 | = do putStrLn (show !get) 176 | putStr "Enter guess: " 177 | let guess = trim !getStr 178 | case choose (not (guess == "")) of 179 | (Left p) => processGuess (strHead' guess (soRefl p)) 180 | (Right p) => do putStrLn "Invalid input!" 181 | game 182 | where 183 | processGuess : Char -> Eff () [HANGMAN (Running (S g) (S w)), STDIO] 184 | [HANGMAN NotRunning, STDIO] 185 | processGuess {g} c {w} 186 | = case !(guess c) of 187 | True => do putStrLn "Good guess!" 188 | case w of 189 | Z => won 190 | (S k) => game 191 | False => do putStrLn "No, sorry" 192 | case g of 193 | Z => lost 194 | (S k) => game 195 | 196 | {- Some candidate words. We'll use programming languages. We don't want to 197 | write the length explicitly, so infer it with a proof search. -} 198 | 199 | words : ?wlen 200 | words = with Vect ["idris","agda","haskell","miranda", 201 | "java","javascript","fortran","basic","racket", 202 | "coffeescript","rust","purescript","clean","links", 203 | "koka","cobol"] 204 | 205 | wlen = proof search 206 | 207 | {- It typechecks! Ship it! -} 208 | 209 | runGame : Eff () [HANGMAN NotRunning, RND, STDIO, SYSTEM] 210 | runGame = do srand !time 211 | let w = index !(rndFin _) words 212 | new_word w 213 | game 214 | putStrLn (show !get) 215 | 216 | {- I made a couple of mistakes while writing this. For example, the following 217 | were caught by the type checker: 218 | 219 | * Forgetting to check the 'Won' state before continuing with 'game' 220 | * Accidentally checking the number of missing letters rather than the number 221 | of guesses when checking if 'Lost' was callable 222 | 223 | -} 224 | 225 | main : IO () 226 | main = run runGame 227 | 228 | -- Local Variables: 229 | -- idris-load-packages: ("effects") 230 | -- End: 231 | -------------------------------------------------------------------------------- /Hangman/VectMissing.idr: -------------------------------------------------------------------------------- 1 | module VectMissing 2 | 3 | import Data.Fin 4 | import Data.Vect 5 | 6 | public export 7 | shrink : (xs : Vect (S n) a) -> Elem x xs -> Vect n a 8 | shrink (x :: ys) Here = ys 9 | shrink (y :: []) (There p) = absurd p 10 | shrink (y :: (x :: xs)) (There p) = y :: shrink (x :: xs) p 11 | 12 | 13 | -------------------------------------------------------------------------------- /Hangman/hangman.ipkg: -------------------------------------------------------------------------------- 1 | package hangman 2 | 3 | modules = VectMissing, Hangman 4 | opts = "-p effects" 5 | 6 | executable = hangman 7 | main = Hangman 8 | 9 | -------------------------------------------------------------------------------- /Intro/Adder.idr: -------------------------------------------------------------------------------- 1 | AdderType : (numargs : Nat) -> Type -> Type 2 | AdderType Z numType = numType 3 | AdderType (S k) numType = (next : numType) -> AdderType k numType 4 | 5 | adder : Num numType => 6 | (numargs : Nat) -> numType -> AdderType numargs numType 7 | adder Z acc = acc 8 | adder (S k) acc = \next => adder k (next + acc) 9 | -------------------------------------------------------------------------------- /Intro/Elem.idr: -------------------------------------------------------------------------------- 1 | module Elem 2 | 3 | data Elem : a -> List a -> Type where 4 | Here : Elem x (x :: xs) 5 | There : Elem x xs -> Elem x (y :: xs) 6 | 7 | elem_test : Elem 2 [1..4] 8 | elem_test = There Here 9 | 10 | isElem : DecEq a => (x : a) -> (xs : List a) -> Maybe (Elem x xs) 11 | isElem x [] = Nothing 12 | isElem x (y :: xs) = case decEq x y of 13 | Yes Refl => Just Here 14 | No contra => do p <- isElem x xs 15 | Just (There p) 16 | 17 | -------------------------------------------------------------------------------- /Intro/Vect.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | {- 4 | To write these functions in vim: 5 | 6 | \d to make a template definition 7 | \c over a variable to do case analysis on that variable 8 | \o to fill in a hole with the 'obvious' value 9 | 10 | -} 11 | 12 | data Vect : Nat -> Type -> Type where 13 | Nil : Vect Z a 14 | (::) : a -> Vect k a -> Vect (S k) a 15 | 16 | %name Vect xs,ys,zs 17 | 18 | append : Vect n a -> Vect m a -> Vect (n + m) a 19 | 20 | {- 21 | Try to write this using the interactive tools alone: 22 | 23 | append [] ys = ys 24 | append (x :: xs) ys = x :: append xs ys 25 | -} 26 | 27 | vZipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c 28 | 29 | 30 | {- 31 | Try to write this using the interactive tools alone: 32 | 33 | vZipWith f [] [] = [] 34 | vZipWith f (x :: xs) (y :: ys) = f x y :: vZipWith f xs ys 35 | -} 36 | 37 | 38 | -------------------------------------------------------------------------------- /Invaders/Aliens.idr: -------------------------------------------------------------------------------- 1 | module Aliens 2 | 3 | import Effect.SDL 4 | import Effects 5 | 6 | %access public export 7 | 8 | record Alien where 9 | constructor MkAlien 10 | position : (Int, Int) 11 | xmovement : Int 12 | xstep : Int 13 | ystep : Int 14 | 15 | startAliens : List Alien 16 | startAliens = alienRow (-1) 100 ++ 17 | alienRow 1 150 ++ alienRow (-1) 200 18 | where 19 | alienRow : Int -> Int -> List Alien 20 | alienRow mv y = map (\x => MkAlien (x*60, y) mv 30 15) [1..10] 21 | 22 | move : List (Int, Int) -> -- bullet position 23 | List Alien -> List Alien 24 | move bs as = map moveAlien as 25 | where moveAlien a = let xstep' = if (xstep a == 0) then 30 else xstep a - 1 in 26 | let ystep' = if (ystep a == 0) then 15 else ystep a - 1 in 27 | let (x, y) = position a in 28 | let y' = if (ystep a == 0) then y+1 else y in 29 | let xmovement' = if xstep a == 0 then -(xmovement a) 30 | else xmovement a in 31 | record { position = (x + xmovement a, y'), 32 | xmovement = xmovement', 33 | xstep = xstep', 34 | ystep = ystep' } a 35 | 36 | -- if any pair of bullet/alien collide, remove both 37 | checkHit : List (Int, Int) -> List Alien -> (List (Int, Int), List Alien) 38 | checkHit bs as = checkAll bs as [] [] 39 | where testHit : (Int, Int) -> Alien -> Bool 40 | testHit (x, y) a 41 | = let (ax, ay) = position a in 42 | (abs (x - ax) < 20 && abs (y - ay) < 15) -- hit! 43 | 44 | checkAll : List (Int, Int) -> List Alien -> List Alien -> List (Int, Int) -> 45 | (List (Int, Int), List Alien) 46 | checkAll (b :: bs) (a :: as) asAcc bsAcc 47 | = if testHit b a 48 | then checkAll bs as asAcc bsAcc 49 | else checkAll (b :: bs) as (a :: asAcc) bsAcc 50 | checkAll (b :: bs) [] asAcc bsAcc 51 | = checkAll bs asAcc [] (b :: bsAcc) 52 | checkAll [] as asAcc bsAcc = (bsAcc, as ++ asAcc) 53 | 54 | drawAliens : List Alien -> { [SDL_ON] } Eff () 55 | drawAliens [] = pure () 56 | drawAliens (a :: as) = do let (x, y) = Alien.position a 57 | drawAlien x y 58 | drawAliens as 59 | where drawAlien : Int -> Int -> { [SDL_ON] } Eff () 60 | drawAlien x y = do ellipse green x y 20 16 61 | ellipse red (x-8) (y-6) 3 3 62 | ellipse red (x-8) (y+6) 3 3 63 | rectangle red (x-2) (y-3) 16 4 64 | rectangle red (x-2) (y+3) 16 4 65 | 66 | -------------------------------------------------------------------------------- /Invaders/Gamestate.idr: -------------------------------------------------------------------------------- 1 | module Gamestate 2 | 3 | import Effects 4 | import Effect.State 5 | import Effect.SDL 6 | import Effect.StdIO 7 | 8 | import Aliens 9 | import Rnd 10 | 11 | %access public export 12 | 13 | record Gamestate where 14 | constructor MkGamestate 15 | position : (Int, Int) 16 | xmovement : Int 17 | ymovement : Int 18 | bullets : List (Int, Int) 19 | bombs : List (Int, Int) 20 | aliens : List Alien 21 | 22 | initState : Gamestate 23 | initState = MkGamestate (320,400) 0 0 [] [] startAliens 24 | 25 | --------- 26 | -- Game state effect needs access to a random number generator 27 | 28 | GS : Type -> Type 29 | GS t = { [Gamestate ::: STATE Gamestate, RND] } Eff t 30 | 31 | moveBullets : Gamestate -> Gamestate 32 | moveBullets gs = let bullets' = movebs (bullets gs) in 33 | record { bullets = bullets' } gs 34 | where movebs [] = [] 35 | movebs ((x, y) :: bs) 36 | = if y < 0 then movebs bs 37 | else ((x, y-5) :: movebs bs) 38 | 39 | moveBombs : Gamestate -> Gamestate 40 | moveBombs gs = let bombs' = movebs (bombs gs) in 41 | record { bombs = bombs' } gs 42 | where movebs [] = [] 43 | movebs ((x, y) :: bs) 44 | = if y > 480 then movebs bs 45 | else ((x, y+5) :: movebs bs) 46 | 47 | moveAliens : Gamestate -> Gamestate 48 | moveAliens gs = record { aliens = move (bullets gs) (aliens gs) } gs 49 | 50 | removeHit : Gamestate -> Gamestate 51 | removeHit gs = let bs = bullets gs in 52 | let as = aliens gs in 53 | let (bs', as') = checkHit bs as in 54 | record { bullets = bs', aliens = as' } gs 55 | 56 | drawBullets : List (Int, Int) -> { [SDL_ON] } Eff () 57 | drawBullets [] = pure () 58 | drawBullets ((x, y) :: bs) = do rectangle red (x-1) (y-4) 2 8 59 | drawBullets bs 60 | 61 | drawBombs : List (Int, Int) -> { [SDL_ON] } Eff () 62 | drawBombs [] = pure () 63 | drawBombs ((x, y) :: bs) = do rectangle yellow (x-1) (y-4) 2 8 64 | drawBombs bs 65 | 66 | randomDropBomb : GS () 67 | randomDropBomb = randomDrop (map (Alien.position) (aliens !(Gamestate :- get))) 68 | where 69 | randomDrop : List (Int, Int) -> GS () 70 | randomDrop [] = pure () 71 | randomDrop ((x, y) :: as) 72 | = do if (!(rndInt 1 3000) == 100) 73 | then (do s <- Gamestate :- get 74 | let bs = bombs s 75 | Gamestate :- put (record { bombs = (x, y+10) :: bs } s)) 76 | else randomDrop as 77 | 78 | --------- 79 | updateGamestate : GS () 80 | updateGamestate = do gs <- Gamestate :- get 81 | let (x, y) = Gamestate.position gs 82 | let (x', y') = (bounds 10 630 (x + xmovement gs), 83 | bounds 380 460 (y + ymovement gs)) 84 | 85 | let gs' = record { position = (x', y') } gs 86 | let gs'' = moveAliens (moveBombs (moveBullets gs')) 87 | Gamestate :- put (removeHit gs'') 88 | randomDropBomb 89 | 90 | where bounds : Int -> Int -> Int -> Int 91 | bounds low high v = if v < low then low 92 | else if v > high then high 93 | else v 94 | 95 | getPos : GS (Int, Int) 96 | getPos = do s <- Gamestate :- get 97 | pure (position s) 98 | 99 | xmove : Int -> GS () 100 | xmove x = do s <- Gamestate :- get 101 | Gamestate :- put (record { xmovement = x } s) 102 | 103 | ymove : Int -> GS () 104 | ymove x = do s <- Gamestate :- get 105 | Gamestate :- put (record { ymovement = x } s) 106 | 107 | addBullet : GS () 108 | addBullet = do s <- Gamestate :- get 109 | let bs = bullets s 110 | (x, y) <- getPos 111 | Gamestate :- put (record { bullets = (x, y-10) :: bs } s) 112 | 113 | -- Deal with keypresses from SDL 114 | process : Maybe Event -> GS Bool 115 | process (Just AppQuit) = pure False 116 | process (Just (KeyDown KeyLeftArrow)) = do xmove (-2); pure True 117 | process (Just (KeyUp KeyLeftArrow)) = do xmove 0; pure True 118 | process (Just (KeyDown KeyRightArrow)) = do xmove 2; pure True 119 | process (Just (KeyUp KeyRightArrow)) = do xmove 0; pure True 120 | process (Just (KeyDown KeyUpArrow)) = do ymove (-2); pure True 121 | process (Just (KeyUp KeyUpArrow)) = do ymove 0; pure True 122 | process (Just (KeyDown KeyDownArrow)) = do ymove 2; pure True 123 | process (Just (KeyUp KeyDownArrow)) = do ymove 0; pure True 124 | process (Just (KeyDown KeySpace)) = do addBullet; pure True 125 | process _ = pure True 126 | -------------------------------------------------------------------------------- /Invaders/Main.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effects 4 | 5 | import Effect.SDL 6 | import Effect.State 7 | import Effect.StdIO 8 | 9 | import Rnd 10 | import Aliens 11 | import Starfield 12 | import Gamestate 13 | 14 | data Frames : Type where -- empty type, just for labelling 15 | 16 | ------- 17 | -- SDL effect is parameterised by an underyling 'surface' resource which 18 | -- only exists when initialised. 19 | 20 | -- The program supports SDL, carries state, and supports random number 21 | -- generation and console I/O 22 | 23 | Prog : Type -> Type -> Type 24 | Prog i t = { [SDL i, 25 | Frames ::: STATE Integer, 26 | Gamestate ::: STATE Gamestate, 27 | Starfield ::: STATE (List (Int, Int)), 28 | RND, 29 | STDIO] } Eff t 30 | 31 | -- Convenient shorthand for initialised SDL 32 | Running : Type -> Type 33 | Running t = Prog SDLSurface t 34 | 35 | ------- 36 | emain : Prog () () 37 | emain = do putStrLn "Initialising" 38 | putStrLn "..." 39 | initialise 640 480 40 | putStrLn "Initialised" 41 | initStarfield [] 200 42 | eventLoop 43 | quit 44 | where 45 | draw : Running () 46 | draw = do rectangle black 0 0 640 480 47 | drawStarfield !(Starfield :- get) 48 | gs <- Gamestate :- get 49 | drawBullets (bullets gs) 50 | drawBombs (bombs gs) 51 | drawAliens (aliens gs) 52 | p <- getPos 53 | let (x, y) = p 54 | rectangle blue (x-10) (y-10) 20 20 55 | rectangle blue (x-1) (y-20) 2 10 56 | flip 57 | 58 | -- update the world state by moving the ellipse to a new position 59 | -- and scrolling the starfield. Also print the number of frames 60 | -- drawn so far every so often. 61 | 62 | updateWorld : Running () 63 | updateWorld = do f <- Frames :- get 64 | Frames :- put (f + 1) 65 | when ((f `mod` 100) == 0) (putStrLn (show f)) 66 | updateStarfield 67 | updateGamestate 68 | 69 | ------- 70 | -- Event loop simply has to draw the current state, update the 71 | -- state according to how the ellipse is moving, then process 72 | -- any incoming events 73 | 74 | eventLoop : Running () 75 | eventLoop = do draw 76 | updateWorld 77 | when !(process !poll) eventLoop 78 | 79 | 80 | main : IO () 81 | main = runInit [(), Frames := 0, 82 | Gamestate := initState, 83 | Starfield := List.Nil, 84 | 1234567890, 85 | ()] emain 86 | -------------------------------------------------------------------------------- /Invaders/Rnd.idr: -------------------------------------------------------------------------------- 1 | module Rnd 2 | 3 | import Effects 4 | 5 | %access public export 6 | 7 | data Random : Effect where 8 | GetRandom : Random Int Int (\v => Int) 9 | 10 | Handler Random m where 11 | handle seed GetRandom k 12 | = let seed' = assert_total ((1664525 * seed + 1013904223) `prim__sremInt` (pow 2 32)) in 13 | k seed' seed' 14 | 15 | RND : EFFECT 16 | RND = MkEff Int Random 17 | 18 | rndInt : Int -> Int -> { [RND] } Eff Int 19 | rndInt lower upper = do v <- call GetRandom 20 | pure (abs (v `prim__sremInt` (upper - lower)) + lower) 21 | 22 | 23 | -------------------------------------------------------------------------------- /Invaders/Starfield.idr: -------------------------------------------------------------------------------- 1 | module Starfield 2 | 3 | -- Background starfield effect 4 | 5 | import Effects 6 | import Effect.SDL 7 | import Effect.StdIO 8 | import Effect.State 9 | 10 | import Rnd 11 | 12 | %access public export 13 | 14 | data Starfield : Type where -- for labelling state 15 | 16 | StarEff : Type -> Type 17 | StarEff t = { [Starfield ::: STATE (List (Int, Int)), RND] } Eff t 18 | 19 | initStarfield : List (Int, Int) -> Nat -> StarEff () 20 | initStarfield acc Z = Starfield :- put acc 21 | initStarfield acc n 22 | = do x <- rndInt 0 639 23 | y <- rndInt 0 479 24 | initStarfield ((x, y) :: acc) (minus n 1) 25 | 26 | updateStarfield : StarEff () 27 | updateStarfield = do xs <- Starfield :- get 28 | xs' <- upd [] xs 29 | Starfield :- put xs' 30 | where 31 | upd : List (Int, Int) -> List (Int, Int) -> { [RND] } Eff (List (Int, Int)) 32 | upd acc [] = pure acc 33 | upd acc ((x, y) :: xs) 34 | = if (y > 479) then do 35 | x <- rndInt 0 639 36 | upd ((x, 0) :: acc) xs 37 | else 38 | upd ((x, y+1) :: acc) xs 39 | 40 | drawStarfield : List (Int, Int) -> { [SDL_ON] } Eff () 41 | drawStarfield [] = pure () 42 | drawStarfield ((x, y) :: xs) = do line white x y x y 43 | drawStarfield xs 44 | 45 | -------------------------------------------------------------------------------- /Invaders/invaders.ipkg: -------------------------------------------------------------------------------- 1 | package invaders 2 | 3 | modules = Starfield, Gamestate, Aliens, Rnd, Main 4 | opts = "-p effects -p sdl --warnreach" 5 | 6 | executable = invaders 7 | main = Main 8 | 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Edwin Brady 2 | School of Computer Science, University of St Andrews 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without modification, 6 | are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright notice, this 12 | list of conditions and the following disclaimer in the documentation and/or 13 | other materials provided with the distribution. 14 | 15 | * Neither the name of the {organization} nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 23 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 24 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 26 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Idris demos 2 | =========== 3 | 4 | Collection of Idris tests and demonstration programs 5 | -------------------------------------------------------------------------------- /RLE/README: -------------------------------------------------------------------------------- 1 | Run length encoding of lists or vects of characters 2 | -------------------------------------------------------------------------------- /RLE/rle-vect.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Data.Vect 4 | 5 | data RLE : Vect n Char -> Type where 6 | REnd : RLE [] 7 | RChar : {xs : Vect k Char} -> 8 | (n : Nat) -> (c : Char) -> (rs : RLE xs) -> 9 | RLE (replicate (S n) c ++ xs) 10 | 11 | ------------ 12 | 13 | rle : (xs : Vect n Char) -> RLE xs 14 | rle [] = REnd 15 | rle (x :: xs) with (rle xs) 16 | rle (x :: []) | REnd = RChar 0 x REnd 17 | rle (x :: (c :: (replicate n c ++ ys))) | (RChar n c rs) with (decEq x c) 18 | rle (x :: (x :: (replicate n x ++ ys))) | (RChar n x rs) | (Yes Refl) 19 | = RChar (S n) x rs 20 | rle (x :: (c :: (replicate n c ++ ys))) | (RChar n c rs) | (No f) 21 | = RChar 0 x (RChar n c rs) 22 | 23 | compress : Vect n Char -> String 24 | compress xs with (rle xs) 25 | compress [] | REnd = "" 26 | compress (c :: (replicate n c ++ xs1)) | (RChar n c rs) 27 | = show (the Integer (cast (S n))) ++ 28 | strCons c (compress xs1) 29 | 30 | compressString : String -> String 31 | compressString xs = compress (fromList (unpack xs)) 32 | 33 | main : IO () 34 | main = putStrLn (compressString "foooobaaaarbaaaz") 35 | -------------------------------------------------------------------------------- /RLE/rle.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | rep : (n : Nat) -> a -> List a 4 | rep Z x = [] 5 | rep (S k) x = x :: rep k x 6 | 7 | data RLE : List Char -> Type where 8 | REnd : RLE [] 9 | RChar : (n : Nat) -> (c : Char) -> (rs : RLE xs) -> 10 | RLE (rep n c ++ xs) 11 | 12 | ------------ 13 | 14 | rle : (xs : List Char) -> RLE xs 15 | rle [] = REnd 16 | rle (x :: xs) with (rle xs) 17 | rle (x :: []) | REnd = RChar 1 x REnd 18 | rle (x :: (rep n c ++ ys)) | (RChar n c rs) with (decEq x c) 19 | rle (x :: (rep n x ++ ys)) | (RChar n x rs) | (Yes Refl) 20 | = RChar (S n) x rs 21 | rle (x :: (rep n c ++ ys)) | (RChar n c rs) | (No f) 22 | = RChar 1 x (RChar n c rs) 23 | 24 | compress : List Char -> String 25 | compress xs with (rle xs) 26 | compress [] | REnd = "" 27 | compress (rep n c ++ ys) | (RChar n c rs) 28 | = show n ++ strCons c (compress ys) 29 | 30 | compressString : String -> String 31 | compressString xs = compress (unpack xs) 32 | 33 | main : IO () 34 | main = putStrLn (compressString "foooobaaaarbaaaz") 35 | -------------------------------------------------------------------------------- /ResDSL/FileDSL.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Resimp 4 | 5 | data Purpose = Reading | Writing 6 | 7 | pstring : Purpose -> String 8 | pstring Reading = "r" 9 | pstring Writing = "w" 10 | 11 | data FILE : Purpose -> Type where 12 | OpenH : File -> FILE p 13 | 14 | syntax "ifM" [test] "then" [t] "else" [e] 15 | = test >>= (\b => if b then t else e) 16 | 17 | open : String -> (p:Purpose) -> Creator (Either () (FILE p)) 18 | open fn p = ioc (do Right h <- fopen fn (pstring p) 19 | | Left err => return (Left ()) 20 | return (Right (OpenH h))) 21 | 22 | close : FILE p -> Updater () 23 | close (OpenH h) = iou (closeFile h) 24 | 25 | readLine : FILE Reading -> Reader String 26 | readLine (OpenH h) = ior (do Right str <- fGetLine h 27 | | return "" 28 | return str) 29 | 30 | eof : FILE Reading -> Reader Bool 31 | eof (OpenH h) = ior (fEOF h) 32 | 33 | syntax rclose [h] = Update close h 34 | syntax rreadLine [h] = Use readLine h 35 | syntax reof [h] = Use eof h 36 | 37 | syntax rputStrLn [s] = Lift (putStrLn s) 38 | syntax rputStr [s] = Lift (putStr s) 39 | 40 | syntax "if" "opened" [f] "then" [e] "else" [t] = Check f t e 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | -------- 57 | 58 | readH : String -> RES () 59 | readH fn = res (do let x = open fn Reading 60 | if opened x then 61 | do str <- rreadLine x 62 | rputStr str 63 | rclose x 64 | else rputStrLn "Error") 65 | 66 | main : IO () 67 | main = run (readH "test") 68 | 69 | 70 | -------------------------------------------------------------------------------- /ResDSL/Resimp.idr: -------------------------------------------------------------------------------- 1 | module Resimp 2 | 3 | import public Data.Vect 4 | import public Data.Fin 5 | 6 | -- IO operations which read a resource 7 | data Reader : Type -> Type where 8 | MkReader : IO a -> Reader a 9 | 10 | getReader : Reader a -> IO a 11 | getReader (MkReader x) = x 12 | 13 | ior : IO a -> Reader a 14 | ior = MkReader 15 | 16 | -- IO operations which update a resource 17 | data Updater : Type -> Type where 18 | MkUpdater : IO a -> Updater a 19 | 20 | getUpdater : Updater a -> IO a 21 | getUpdater (MkUpdater x) = x 22 | 23 | iou : IO a -> Updater a 24 | iou = MkUpdater 25 | 26 | -- IO operations which create a resource 27 | data Creator : Type -> Type where 28 | MkCreator : IO a -> Creator a 29 | 30 | getCreator : Creator a -> IO a 31 | getCreator (MkCreator x) = x 32 | 33 | ioc : IO a -> Creator a 34 | ioc = MkCreator 35 | 36 | infixr 5 :-> 37 | 38 | using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty) 39 | 40 | data Ty = R Type 41 | | Val Type 42 | | Choice Type Type 43 | | (:->) Type Ty 44 | 45 | interpTy : Ty -> Type 46 | interpTy (R t) = IO t 47 | interpTy (Val t) = t 48 | interpTy (Choice x y) = Either x y 49 | interpTy (a :-> b) = a -> interpTy b 50 | 51 | data HasType : Vect n Ty -> Fin n -> Ty -> Type where 52 | Stop : HasType (a :: gam) FZ a 53 | Pop : HasType gam i b -> HasType (a :: gam) (FS i) b 54 | 55 | data Env : Vect n Ty -> Type where 56 | Nil : Env Nil 57 | (::) : interpTy a -> Env gam -> Env (a :: gam) 58 | 59 | envLookup : HasType gam i a -> Env gam -> interpTy a 60 | envLookup Stop (x :: xs) = x 61 | envLookup (Pop k) (x :: xs) = envLookup k xs 62 | 63 | update : (gam : Vect n Ty) -> HasType gam i b -> Ty -> Vect n Ty 64 | update (x :: xs) Stop y = y :: xs 65 | update (x :: xs) (Pop k) y = x :: update xs k y 66 | update Nil Stop _ impossible 67 | 68 | total 69 | envUpdate : (p:HasType gam i a) -> (val:interpTy b) -> 70 | Env gam -> Env (update gam p b) 71 | envUpdate Stop val (x :: xs) = val :: xs 72 | envUpdate (Pop k) val (x :: xs) = x :: envUpdate k val xs 73 | envUpdate Stop _ Nil impossible 74 | 75 | total 76 | envUpdateVal : (p:HasType gam i a) -> (val:b) -> 77 | Env gam -> Env (update gam p (Val b)) 78 | envUpdateVal Stop val (x :: xs) = val :: xs 79 | envUpdateVal (Pop k) val (x :: xs) = x :: envUpdateVal k val xs 80 | envUpdateVal Stop _ Nil impossible 81 | 82 | envTail : Env (a :: gam) -> Env gam 83 | envTail (x :: xs) = xs 84 | 85 | data Args : Vect n Ty -> List Type -> Type where 86 | ANil : Args gam [] 87 | ACons : HasType gam i a -> 88 | Args gam as -> Args gam (interpTy a :: as) 89 | 90 | funTy : List Type -> Ty -> Ty 91 | funTy list.Nil t = t 92 | funTy (a :: as) t = a :-> funTy as t 93 | 94 | data Res : Vect n Ty -> Vect n Ty -> Ty -> Type where 95 | 96 | {-- Resource creation and usage. 'Let' creates a resource - the type 97 | at the end means that the resource must have been consumed by the time 98 | it goes out of scope, where "consumed" simply means that it has been 99 | replaced with a value of type '()'. --} 100 | 101 | Let : Creator (interpTy a) -> 102 | Res (a :: gam) (Val () :: gam') (R t) -> 103 | Res gam gam' (R t) 104 | Update : (a -> Updater b) -> (p:HasType gam i (Val a)) -> 105 | Res gam (update gam p (Val b)) (R ()) 106 | Use : (a -> Reader b) -> HasType gam i (Val a) -> 107 | Res gam gam (R b) 108 | 109 | {-- Control structures --} 110 | 111 | Lift : IO a -> Res gam gam (R a) 112 | Check : (p:HasType gam i (Choice (interpTy a) (interpTy b))) -> 113 | (failure:Res (update gam p a) (update gam p c) t) -> 114 | (success:Res (update gam p b) (update gam p c) t) -> 115 | Res gam (update gam p c) t 116 | While : Res gam gam (R Bool) -> 117 | Res gam gam (R ()) -> Res gam gam (R ()) 118 | Return : a -> Res gam gam (R a) 119 | (>>=) : Res gam gam' (R a) -> (a -> Res gam' gam'' (R t)) -> 120 | Res gam gam'' (R t) 121 | 122 | ioret : a -> IO a 123 | ioret = return 124 | 125 | interp : Env gam -> [static] (e : Res gam gam' t) -> 126 | (Env gam' -> interpTy t -> IO u) -> IO u 127 | 128 | interp env (Let val scope) k 129 | = do x <- getCreator val 130 | interp (x :: env) scope 131 | (\env', scope' => k (envTail env') scope') 132 | interp env (Update method x) k 133 | = do x' <- getUpdater (method (envLookup x env)) 134 | k (envUpdateVal x x' env) (return ()) 135 | interp env (Use method x) k 136 | = do x' <- getReader (method (envLookup x env)) 137 | k env (return x') 138 | interp env (Lift io) k 139 | = k env io 140 | interp env (Check x left right) k = 141 | either (\a => interp (envUpdate x a env) left k) 142 | (\b => interp (envUpdate x b env) right k) 143 | (envLookup x env) 144 | interp env (While test body) k 145 | = interp env test 146 | (\env', result => 147 | do r <- result 148 | if (not r) 149 | then (k env' (return ())) 150 | else (interp env' body 151 | (\env'', body' => 152 | do v <- body' -- make sure it's evalled 153 | interp env'' (While test body) k ))) 154 | interp env (Return v) k = k env (return v) 155 | interp env (v >>= f) k 156 | = interp env v (\env', v' => do n <- v' 157 | interp env' (f n) k) 158 | 159 | let_ : _ -> Creator (interpTy a) -> 160 | Res (a :: gam) (Val () :: gam') (R t) -> 161 | Res gam gam' (R t) 162 | let_ _ = Let 163 | 164 | -- run : {static} Res [] [] (R t) -> IO t 165 | -- run prog = interp [] prog (\env, res => res) 166 | 167 | syntax run [prog] = interp [] prog (\env, res => res) 168 | 169 | dsl res 170 | variable = id 171 | let = let_ 172 | index_first = Stop 173 | index_next = Pop 174 | 175 | syntax RES [x] = {gam:Vect n Ty} -> Res gam gam (R x) 176 | 177 | -------------------------------------------------------------------------------- /ResDSL/test: -------------------------------------------------------------------------------- 1 | foo 2 | bar 3 | --------------------------------------------------------------------------------