├── Examples ├── Resources │ ├── State.agda │ └── TicTacToe │ │ ├── Core.agda │ │ ├── Main.agda │ │ ├── Prelude.agda │ │ ├── SafeGame.agda │ │ ├── TestSafe.agda │ │ └── UnsafeGame.agda └── Simple │ └── NonDet.agda ├── Lifts.agda ├── Loop.agda ├── Loop ├── Core.agda ├── Effect │ ├── Break.agda │ ├── General.agda │ ├── LNSTLC.agda │ ├── State.agda │ ├── Vars.agda │ └── Writer.agda └── Simple.agda ├── Map.agda ├── Prelude.agda ├── Resources.agda ├── Resources ├── Core.agda ├── Dep.agda ├── Effect │ ├── Error.agda │ ├── LiftM.agda │ ├── State.agda │ └── Writer.agda └── Membership.agda ├── Simple.agda ├── Simple ├── Core.agda ├── Effect │ ├── Error.agda │ └── NonDet.agda └── Membership.agda └── readme.md /Examples/Resources/State.agda: -------------------------------------------------------------------------------- 1 | module Examples.Resources.State where 2 | 3 | open import Resources 4 | open import Resources.Effect.State 5 | 6 | import Data.Vec as V 7 | 8 | eff₁ : Eff (State , tt) ℕ (ℕ , tt) (λ n -> V.Vec Bool n , tt) 9 | eff₁ = get >>= λ n -> zap ℕ (V.replicate true) >> return n 10 | 11 | eff₂ : ∀ {α} -> Eff (State , State , tt) ℕ (ℕ , Set α , tt) (λ _ -> ℕ , Set α , tt) 12 | eff₂ = get >>= λ n -> put n >> return (suc n) 13 | 14 | -- 3 , true ∷ true ∷ true ∷ [] 15 | test₁ : ∃ (V.Vec Bool) 16 | test₁ = runEff $ execState 3 eff₁ 17 | 18 | -- 4 , 3 19 | test₂ : ℕ × ℕ 20 | test₂ = proj₁ $ runEff $ execState ℕ $ execState 3 eff₂ 21 | -------------------------------------------------------------------------------- /Examples/Resources/TicTacToe/Core.agda: -------------------------------------------------------------------------------- 1 | open import Examples.Resources.TicTacToe.Prelude 2 | 3 | module Examples.Resources.TicTacToe.Core (n m : ℕ) where 4 | 5 | data Player : Set where 6 | x o : Player 7 | 8 | data Cell : Set where 9 | empty : Cell 10 | filled : Player -> Cell 11 | 12 | data Empty : Cell -> Set where 13 | really : Empty empty 14 | 15 | data Filled : Cell -> Set where 16 | player : ∀ p -> Filled (filled p) 17 | 18 | Contents : Cell -> Set 19 | Contents c = Empty c ⊎ Filled c 20 | 21 | data Δ : Set where 22 | -1ᵈ 0ᵈ +1ᵈ : Δ 23 | 24 | Board = Vec (Vec Cell n) n 25 | Coord = Fin n × Fin n 26 | Direction = Δ × Δ 27 | 28 | switch : Player -> Player 29 | switch x = o 30 | switch o = x 31 | 32 | _==ᵖ_ : Player -> Player -> Bool 33 | x ==ᵖ x = true 34 | o ==ᵖ o = true 35 | _ ==ᵖ _ = false 36 | 37 | contents : ∀ c -> Contents c 38 | contents empty = inj₁ really 39 | contents (filled p) = inj₂ (player p) 40 | 41 | revert : Δ -> Δ 42 | revert -1ᵈ = +1ᵈ 43 | revert 0ᵈ = 0ᵈ 44 | revert +1ᵈ = -1ᵈ 45 | 46 | opposite : Direction -> Direction 47 | opposite = pmap revert revert 48 | 49 | add : ∀ {n} -> Δ -> Fin n -> Maybe (Fin n) 50 | add -1ᵈ i = mpred i 51 | add 0ᵈ i = just i 52 | add +1ᵈ i = msuc i 53 | 54 | next : Direction -> Coord -> Maybe Coord 55 | next (δᵢ , δⱼ) (i , j) = _,_ <$>ₘ add δᵢ i <*>ₘ add δⱼ j 56 | 57 | get : Coord -> Board -> Cell 58 | get (i , j) = vlookup j ∘ vlookup i 59 | 60 | set : Coord -> Player -> Board -> Board 61 | set (i , j) = mapᵢ i ∘ mapᵢ j ∘ const ∘ filled 62 | 63 | {-# TERMINATING #-} 64 | line : Direction -> Coord -> Board -> List Cell 65 | line d c b = maybe′ (λ c' -> get c' b ∷ line d c' b) [] (next d c) 66 | 67 | lineOf : Player -> Direction -> Coord -> Board -> List Cell 68 | lineOf p d c b = takeWhile (λ{ empty -> false ; (filled q) -> p ==ᵖ q }) (line d c b) 69 | 70 | checkDirection : Coord -> Board -> Direction -> Bool 71 | checkDirection c b d with get c b 72 | ... | empty = false 73 | ... | filled p = ⌊ m ≤? length cs ⌋ where 74 | cs = lineOf p d c b l++ [ filled p ] l++ lineOf p (opposite d) c b 75 | 76 | directions : List Direction 77 | directions = (-1ᵈ , -1ᵈ) 78 | ∷ (-1ᵈ , 0ᵈ) 79 | ∷ (-1ᵈ , +1ᵈ) 80 | ∷ ( 0ᵈ , +1ᵈ) 81 | ∷ [] 82 | 83 | checkAround : Coord -> Board -> Bool 84 | checkAround c b = any (checkDirection c b) directions 85 | 86 | -------------------- 87 | 88 | record GameState : Set where 89 | constructor State: 90 | field 91 | moves : ℕ 92 | turn : Player 93 | board : Board 94 | open GameState public 95 | 96 | data Non-moveable : GameState -> Set where 97 | non-moveable : ∀ p b -> Non-moveable (State: 0 p b) 98 | 99 | data Moveable : GameState -> Set where 100 | moveable : ∀ n p b -> Moveable (State: (suc n) p b) 101 | 102 | Moveability : GameState -> Set 103 | Moveability s = Non-moveable s ⊎ Moveable s 104 | 105 | data EmptyCoord s : Set where 106 | emptyAt : ∀ c -> Empty (get c (board s)) -> EmptyCoord s 107 | 108 | data Outcome s : Set where 109 | Victory : ∀ c -> True (checkAround c (board s)) -> Outcome s 110 | Draw : Non-moveable s -> Outcome s 111 | 112 | record GameOver : Set where 113 | constructor gameOver 114 | field 115 | {state} : GameState 116 | result : Outcome state 117 | open GameOver public 118 | 119 | moveability : ∀ s -> Moveability s 120 | moveability (State: 0 p b) = inj₁ (non-moveable p b) 121 | moveability (State: (suc n) p b) = inj₂ (moveable n p b) 122 | 123 | moveMoveable : ∀ {s} -> Moveable s -> EmptyCoord s -> GameState 124 | moveMoveable (moveable n p b) (emptyAt c _) = State: n (switch p) (set c p b) 125 | 126 | -------------------- 127 | 128 | showPlayer : Player -> Char 129 | showPlayer x = 'x' 130 | showPlayer o = 'o' 131 | 132 | showCell : Cell -> Char 133 | showCell empty = '-' 134 | showCell (filled p) = showPlayer p 135 | 136 | showBoard : Board -> String 137 | showBoard = unlines ∘ vtoList ∘ vmap (vecToString ∘ vmap showCell) 138 | 139 | showGameOver : GameOver -> String 140 | showGameOver (gameOver {s} (Victory c _)) = 141 | "the winner is " 142 | s++ fromList (showCell (get c (board s)) ∷ '\n' ∷ '\n' ∷ []) 143 | s++ showBoard (board s) 144 | showGameOver (gameOver {s} (Draw _)) = 145 | "it's draw\n\n" 146 | s++ showBoard (board s) 147 | -------------------------------------------------------------------------------- /Examples/Resources/TicTacToe/Main.agda: -------------------------------------------------------------------------------- 1 | module Examples.Resources.TicTacToe.Main where 2 | 3 | open import Examples.Resources.TicTacToe.Prelude 4 | open import Examples.Resources.TicTacToe.UnsafeGame 3 3 5 | 6 | main = runPlayed (play new) >>=ᵢₒ putStr ∘ showGameOver 7 | -------------------------------------------------------------------------------- /Examples/Resources/TicTacToe/Prelude.agda: -------------------------------------------------------------------------------- 1 | module Examples.Resources.TicTacToe.Prelude where 2 | 3 | open import Resources hiding (replicate) public 4 | 5 | open import Relation.Nullary.Decidable using (⌊_⌋) public 6 | open import Data.Char.Base public 7 | open import Data.Vec as Vec using (Vec; []; _∷_; replicate) 8 | renaming (toList to vtoList; map to vmap; lookup to vlookup) public 9 | open import Data.String using (String; Costring; toCostring; toList; fromList; unlines) 10 | renaming (_++_ to _s++_) public 11 | open import IO.Primitive 12 | renaming (return to returnᵢₒ; _>>=_ to _>>=ᵢₒ_; 13 | putStr to putCostr; putStrLn to putCostrLn) public 14 | 15 | open import Coinduction 16 | open import Relation.Binary.PropositionalEquality renaming ([_] to hide) using () 17 | open import Data.Char 18 | open import Data.Fin using (toℕ; inject₁) 19 | open import Data.Colist hiding (fromList) 20 | 21 | postulate getLine : IO Costring 22 | {-# COMPILED getLine getLine #-} 23 | 24 | infixr 2 _>>ᵢₒ_ 25 | infixl 6 _<$>ᵢₒ_ 26 | 27 | {-# NON_TERMINATING #-} 28 | fromColist : ∀ {α} {A : Set α} -> Colist A -> List A 29 | fromColist [] = [] 30 | fromColist (x ∷ xs) = x ∷ fromColist (♭ xs) 31 | 32 | _>>ᵢₒ_ : ∀ {α β} {A : Set α} {B : Set β} -> IO A -> IO B -> IO B 33 | a >>ᵢₒ b = a >>=ᵢₒ const b 34 | 35 | _<$>ᵢₒ_ : ∀ {α β} {A : Set α} {B : Set β} -> (A -> B) -> IO A -> IO B 36 | f <$>ᵢₒ a = a >>=ᵢₒ returnᵢₒ ∘ f 37 | 38 | putStrLn : String -> IO _ 39 | putStrLn = putCostrLn ∘ toCostring 40 | 41 | putStr : String -> IO _ 42 | putStr = putCostr ∘ toCostring 43 | 44 | suc-inj : ∀ {n} {i j : Fin n} -> Fin.suc i ≡ suc j -> i ≡ j 45 | suc-inj refl = refl 46 | 47 | fromInj₂ : ∀ {α β γ δ} {A : Set α} {B : Set β} {C : Set γ} {D : Set δ} 48 | {f : A -> C} {g : B -> D} {z} 49 | -> ∀ s -> smap f g s ≡ inj₂ z -> B 50 | fromInj₂ (inj₁ x) () 51 | fromInj₂ (inj₂ y) p = y 52 | 53 | uninj₂ : ∀ {α β γ δ} {A : Set α} {B : Set β} {C : Set γ} {D : Set δ} {g : B -> D} {z} 54 | -> (f : A -> C) -> ∀ s -> (p : smap f g s ≡ inj₂ z) -> g (fromInj₂ s p) ≡ z 55 | uninj₂ f (inj₁ x) () 56 | uninj₂ f (inj₂ y) refl = refl 57 | 58 | back-inj₂ : ∀ {α β γ δ} {A : Set α} {B : Set β} {C : Set γ} {D : Set δ} 59 | {f : A -> C} {g : B -> D} {z w} 60 | -> ∀ s -> (p : smap f g s ≡ inj₂ z) -> fromInj₂ s p ≡ w -> s ≡ inj₂ w 61 | back-inj₂ (inj₁ x) () q 62 | back-inj₂ (inj₂ y) p refl = refl 63 | 64 | mpred : ∀ {n} -> Fin n -> Maybe (Fin n) 65 | mpred zero = nothing 66 | mpred (suc i) = just (inject₁ i) 67 | 68 | msuc : ∀ {n} -> Fin n -> Maybe (Fin n) 69 | msuc {1} zero = nothing 70 | msuc {suc (suc _)} zero = just (suc zero) 71 | msuc (suc i) = suc <$>ₘ msuc i 72 | 73 | sfromℕ : ∀ {n} m -> n ≤ m ⊎ Fin n 74 | sfromℕ {0} m = inj₁ z≤n 75 | sfromℕ {suc n} 0 = inj₂ zero 76 | sfromℕ {suc n} (suc m) = smap s≤s suc (sfromℕ m) 77 | 78 | sfromℕ→toℕ : ∀ {n i} m -> sfromℕ {n} m ≡ inj₂ i -> m ≡ toℕ i 79 | sfromℕ→toℕ {i = zero} 0 p = refl 80 | sfromℕ→toℕ {i = suc i} 0 () 81 | sfromℕ→toℕ {i = zero} (suc m) p = case uninj₂ s≤s (sfromℕ m) p of λ() 82 | sfromℕ→toℕ {i = suc i} (suc m) p = 83 | cong suc (sfromℕ→toℕ m (back-inj₂ (sfromℕ m) p (suc-inj (uninj₂ s≤s (sfromℕ m) p)))) 84 | 85 | data OutOfBounds n p : Set where 86 | outOfBoundsₗ : n ≤ proj₁ p -> OutOfBounds n p 87 | outOfBoundsᵣ : n ≤ proj₂ p -> OutOfBounds n p 88 | 89 | record InBounds n p : Set where 90 | constructor inBounds 91 | field 92 | runInBounds : Fin n × Fin n 93 | isInBounds : p ≡ pmap toℕ toℕ runInBounds 94 | open InBounds public 95 | 96 | inBounds? : ∀ n p -> OutOfBounds n p ⊎ InBounds n p 97 | inBounds? n (m , p) with sfromℕ {n} m | inspect (sfromℕ {n}) m 98 | ... | inj₁ le₁ | hide r = inj₁ (outOfBoundsₗ le₁) 99 | ... | inj₂ i | hide r with sfromℕ {n} p | inspect (sfromℕ {n}) p 100 | ... | inj₁ le₂ | hide s = inj₁ (outOfBoundsᵣ le₂) 101 | ... | inj₂ j | hide s = inj₂ (inBounds (i , j) (cong₂ _,_ (sfromℕ→toℕ m r) (sfromℕ→toℕ p s))) 102 | 103 | mapᵢ : ∀ {n α} {A : Set α} -> Fin n -> (A -> A) -> Vec A n -> Vec A n 104 | mapᵢ zero f (x ∷ xs) = f x ∷ xs 105 | mapᵢ (suc i) f (x ∷ xs) = x ∷ mapᵢ i f xs 106 | 107 | vecToString : ∀ {n} -> Vec Char n -> String 108 | vecToString = fromList ∘ Vec.toList 109 | 110 | fromDigits : List ℕ -> ℕ 111 | fromDigits = foldl (λ a d -> a * 10 + d) 0 112 | 113 | _∺_ : ∀ {α} {A : Set α} -> List A -> List (List A) -> List (List A) 114 | [] ∺ xss = xss 115 | xs ∺ xss = xs ∷ xss 116 | 117 | groupMaybe : ∀ {α β} {A : Set α} {B : Set β} -> (A -> Maybe B) -> List A -> List (List B) 118 | groupMaybe {A = A} {B} f = uncurry′ _∺_ ∘ lfoldr step ([] , []) where 119 | step : A -> List B × List (List B) -> List B × List (List B) 120 | step x (ys , yss) = maybe′ (λ y -> y ∷ ys , yss) ([] , ys ∺ yss) (f x) 121 | 122 | List→× : ∀ {α} {A : Set α} -> List A -> Maybe (A × A) 123 | List→× (x ∷ y ∷ []) = just (x , y) 124 | List→× _ = nothing 125 | 126 | charToℕ : Char -> Maybe ℕ 127 | charToℕ '0' = just 0 128 | charToℕ '1' = just 1 129 | charToℕ '2' = just 2 130 | charToℕ '3' = just 3 131 | charToℕ '4' = just 4 132 | charToℕ '5' = just 5 133 | charToℕ '6' = just 6 134 | charToℕ '7' = just 7 135 | charToℕ '8' = just 8 136 | charToℕ '9' = just 9 137 | charToℕ _ = nothing 138 | 139 | readℕ : String -> Maybe ℕ 140 | readℕ = (fromDigits <$>ₘ_) ∘ sequence monad ∘ lmap charToℕ ∘ toList where 141 | open import Data.List using (sequence) 142 | open import Data.Maybe using (monad) 143 | 144 | words : List Char -> List (List Char) 145 | words = groupMaybe (λ c -> if c == ' ' then nothing else just c) 146 | -------------------------------------------------------------------------------- /Examples/Resources/TicTacToe/SafeGame.agda: -------------------------------------------------------------------------------- 1 | open import Examples.Resources.TicTacToe.Prelude 2 | 3 | module Examples.Resources.TicTacToe.SafeGame (n : ℕ) (m : ℕ) where 4 | 5 | open import Examples.Resources.TicTacToe.Core n m public 6 | 7 | data Game (s : GameState) : Effectful lzero lzero where 8 | Move : (m : Moveable s) -> Game s (EmptyCoord s) (moveMoveable m) 9 | 10 | move : ∀ {n} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 11 | {Ψs : Effects Rs αψs} {rs : Resources Rs} {s} {{q : Game , s ∈ Ψs , rs}} 12 | -> (m : Moveable s) -> Eff Ψs _ rs _ 13 | move = invoke′ ∘′ Move 14 | 15 | Play : GameState -> Set₁ 16 | Play s = Eff (Game , tt) GameOver (s , tt) (λ g -> state g , tt) 17 | 18 | {-# TERMINATING #-} 19 | game : ∀ s -> Play s 20 | game s with moveability s 21 | ... | inj₁ nm = return $ gameOver $ Draw nm 22 | ... | inj₂ m = move m >>= k where 23 | k : ∀ ec -> Play (moveMoveable m ec) 24 | k (emptyAt c _) = if′ checkAround c _ 25 | then return ∘′ gameOver ∘ Victory c 26 | else const (game _) 27 | 28 | new : Play _ 29 | new = game $ State: (n * n) x (replicate (replicate empty)) 30 | 31 | {-# TERMINATING #-} 32 | execGame : ∀ {s} -> List (ℕ × ℕ) -> Play s -> Maybe GameOver 33 | execGame [] (return g) = just g 34 | execGame _ (return g) = nothing 35 | execGame {s} ms (call i p) with runLifts i p 36 | ... | , , a , f with i 37 | ... | suc () 38 | ... | zero with a 39 | ... | Move _ with ms 40 | ... | [] = nothing 41 | ... | m ∷ ms' with inBounds? n m 42 | ... | inj₁ _ = nothing 43 | ... | inj₂ (inBounds c _) with contents (get c (board s)) 44 | ... | inj₁ e = execGame ms' (f (emptyAt c e)) 45 | ... | inj₂ _ = nothing 46 | 47 | simulate : List (ℕ × ℕ) -> Maybe GameOver 48 | simulate ms = execGame ms new 49 | -------------------------------------------------------------------------------- /Examples/Resources/TicTacToe/TestSafe.agda: -------------------------------------------------------------------------------- 1 | module Examples.Resources.TicTacToe.TestSafe where 2 | 3 | open import Examples.Resources.TicTacToe.Prelude 4 | open import Examples.Resources.TicTacToe.SafeGame 3 3 5 | 6 | -- x-- 7 | -- ox- 8 | -- o-x 9 | test₁ : Maybe GameOver 10 | test₁ = simulate $ (0 , 0) ∷ (1 , 0) ∷ (1 , 1) ∷ (2 , 0) ∷ (2 , 2) ∷ [] 11 | 12 | -- xox 13 | -- oxx 14 | -- oxo 15 | test₂ : Maybe GameOver 16 | test₂ = simulate $ 17 | (0 , 0) ∷ (1 , 0) ∷ (1 , 1) ∷ (2 , 0) ∷ (2 , 1) ∷ (2 , 2) ∷ (1 , 2) ∷ (0 , 1) ∷ (0 , 2) ∷ [] 18 | 19 | -- xox 20 | -- oxx 21 | -- xoo 22 | test₃ : Maybe GameOver 23 | test₃ = simulate $ 24 | (0 , 0) ∷ (1 , 0) ∷ (1 , 1) ∷ (2 , 1) ∷ (2 , 0) ∷ (2 , 2) ∷ (1 , 2) ∷ (0 , 1) ∷ (0 , 2) ∷ [] 25 | 26 | -- oo- 27 | -- xx- 28 | -- --- 29 | test₄ : Maybe GameOver 30 | test₄ = simulate $ (1 , 0) ∷ (0 , 0) ∷ (1 , 2) ∷ (0 , 1) ∷ [] 31 | 32 | -- oo- 33 | -- xxx 34 | -- --- 35 | test₅ : Maybe GameOver 36 | test₅ = simulate $ (1 , 0) ∷ (0 , 0) ∷ (1 , 2) ∷ (0 , 1) ∷ (1 , 1) ∷ [] 37 | -------------------------------------------------------------------------------- /Examples/Resources/TicTacToe/UnsafeGame.agda: -------------------------------------------------------------------------------- 1 | open import Examples.Resources.TicTacToe.Prelude 2 | 3 | module Examples.Resources.TicTacToe.UnsafeGame (n m : ℕ) where 4 | 5 | open import Examples.Resources.TicTacToe.Core n m public 6 | 7 | open import Resources.Effect.Error 8 | open import Resources.Effect.LiftM 9 | 10 | data GetCoord s : Set where 11 | Interrupted : GetCoord s 12 | Bounds : ∀ {c} 13 | -> (Σ (InBounds n c) λ ib -> Contents (get (runInBounds ib) (board s))) 14 | ⊎ OutOfBounds n c 15 | -> GetCoord s 16 | 17 | data Raised : Set where 18 | RInterrupted : Raised 19 | ROutOfBounds : ∀ {c} -> OutOfBounds n c -> Raised 20 | RFilled : ∀ c b -> Filled (get c b) -> Raised 21 | 22 | prettyRaised : Raised -> String 23 | prettyRaised RInterrupted = "interrupted" 24 | prettyRaised (ROutOfBounds ob) = "out of bounds" 25 | prettyRaised (RFilled c b f) = "this cell is already filled" 26 | 27 | runGetCoord : ∀ {s} -> Moveable s -> GetCoord s -> GameState 28 | runGetCoord m (Bounds (inj₁ (inBounds c _ , inj₁ e))) = moveMoveable m (emptyAt c e) 29 | runGetCoord {s} m _ = s 30 | 31 | data Game (s : GameState) : Effectful lzero lzero where 32 | Move : (m : Moveable s) -> Game s (GetCoord s) (runGetCoord m) 33 | 34 | move : ∀ {n} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 35 | {Ψs : Effects Rs αψs} {rs : Resources Rs} {s} {{q : Game , s ∈ Ψs , rs}} 36 | -> (m : Moveable s) -> Eff Ψs (GetCoord s) rs _ 37 | move = invoke′ ∘′ Move 38 | 39 | Play : GameState -> Set₁ 40 | Play s = Eff ( Error {lzero} , Game , tt) 41 | GameOver 42 | ( Raised , s , tt) 43 | (λ g -> Raised , state g , tt) 44 | 45 | {-# TERMINATING #-} 46 | game : ∀ s -> Play s 47 | game s with moveability s 48 | ... | inj₁ nm = return $ gameOver $ Draw nm 49 | ... | inj₂ m = move m >>= k where 50 | k : ∀ gc -> Play (runGetCoord m gc) 51 | k Interrupted = throw RInterrupted 52 | k (Bounds (inj₂ ob)) = throw (ROutOfBounds ob) 53 | k (Bounds (inj₁ (inBounds c _ , inj₂ f))) = throw (RFilled c _ f) 54 | k (Bounds (inj₁ (inBounds c _ , inj₁ e))) = 55 | if′ checkAround c _ 56 | then return ∘′ gameOver ∘ Victory c 57 | else const (game _) 58 | 59 | new : Play _ 60 | new = game $ State: (n * n) x (replicate (replicate empty)) 61 | 62 | Played : GameState -> Set₁ 63 | Played s = Eff ( Lift[ IO ] , Game , tt) 64 | GameOver 65 | ( tt , s , tt) 66 | (λ g -> tt , state g , tt) 67 | 68 | {-# TERMINATING #-} 69 | play : ∀ {s} -> Play s -> Played s 70 | play g = handleError g λ 71 | { {s , _} r -> (case r of λ 72 | { RInterrupted -> liftM IO $ putStrLn 73 | "naughty boy, you can't interrupt the game -- that's what the type signature says" 74 | ; _ -> liftM IO $ putStrLn $ prettyRaised r 75 | }) >> play (game s) 76 | } 77 | 78 | data Command s : Set where 79 | CShow : Command s 80 | CCoord : GetCoord s -> Command s 81 | 82 | parseCommand : ∀ {s} -> List Char -> Maybe (Command s) 83 | parseCommand cs = case ws of λ 84 | { ("show" ∷ []) -> just CShow 85 | ; ("interrupt" ∷ []) -> just (CCoord Interrupted) 86 | ; ("move" ∷ w1 ∷ w2 ∷ []) -> 87 | (λ m1 m2 -> CCoord ∘ Bounds $ 88 | [ inj₂ 89 | , inj₁ ∘ < id , contents ∘′ flip get _ ∘′ runInBounds > 90 | ]′ (inBounds? n (m1 , m2))) 91 | <$>ₘ readℕ w1 92 | <*>ₘ readℕ w2 93 | ; _ -> nothing 94 | } where ws = lmap fromList $ words cs 95 | 96 | mutual 97 | {-# NON_TERMINATING #-} 98 | getCoord : ∀ {s} -> IO (GetCoord s) 99 | getCoord = putStrLn "enter command" >>ᵢₒ 100 | getLine >>=ᵢₒ λ s -> 101 | maybe′ runCommand 102 | (putStrLn "wrong input, try again" >>ᵢₒ getCoord) 103 | (parseCommand (fromColist s)) 104 | 105 | runCommand : ∀ {s} -> Command s -> IO (GetCoord s) 106 | runCommand {s} CShow = putStr (showBoard (board s)) >>ᵢₒ getCoord 107 | runCommand (CCoord c) = returnᵢₒ c 108 | 109 | {-# NON_TERMINATING #-} 110 | runPlayed : ∀ {s} -> Played s -> IO GameOver 111 | runPlayed {s} = runEffM returnᵢₒ _>>=ᵢₒ_ k where 112 | k : ∀ i {s' A r′} -> lookupᵉ i (Lift[ IO ] , Game , tt) s' A r′ -> IO A 113 | k zero (LiftM a) = a 114 | k (suc zero) (Move m) = getCoord 115 | k (suc (suc ())) a 116 | -------------------------------------------------------------------------------- /Examples/Simple/NonDet.agda: -------------------------------------------------------------------------------- 1 | module Examples.Simple.NonDet where 2 | 3 | open import Simple 4 | open import Simple.Effect.NonDet 5 | 6 | open import Data.Nat.DivMod 7 | open import Data.Nat.Properties 8 | 9 | run-≤′ : ∀ {n m} -> n ≤′ m -> List ℕ 10 | run-≤′ = go [] where 11 | mutual 12 | go : ∀ {m n} -> List ℕ -> n ≤′ m -> List ℕ 13 | go {m} ms = go' (m ∷ ms) 14 | 15 | go' : ∀ {m n} -> List ℕ -> n ≤′ m -> List ℕ 16 | go' ms ≤′-refl = ms 17 | go' ms (≤′-step le) = go ms le 18 | 19 | -- primes 15 = 2 ∷ 3 ∷ 5 ∷ 7 ∷ 11 ∷ 13 ∷ [] 20 | primes : ℕ -> List ℕ 21 | primes n = runEff ∘ execNonDet $ 22 | gen n >>= λ m -> 23 | ifte (gen (pred m) >>= λ d -> dguard $ m mod (suc (pred d)) ≟ zero) 24 | (const ⟨⟩) 25 | (return m) 26 | where 27 | gen : ℕ -> _ 28 | gen 0 = ⟨⟩ 29 | gen 1 = ⟨⟩ 30 | gen (suc (suc n)) = msum ∘ lmap return ∘ run-≤′ $ ≤⇒≤′ (s≤s (s≤s (z≤n {n}))) 31 | -------------------------------------------------------------------------------- /Lifts.agda: -------------------------------------------------------------------------------- 1 | module Lifts where 2 | 3 | open import Prelude 4 | open import Map 5 | 6 | -- ∀′ : ∀ {α β} {A : Set α} -> (A -> Set β) -> Set (α ⊔ β) 7 | -- ∀′ B = ∀ x -> B x 8 | 9 | -- Liftᵐ-go : ∀ {n α γ} {A : Set α} 10 | -- β (k : A -> Level) i (xs : A ^ n) {B : Set (k (lookup i xs))} 11 | -- -> ((B -> Set γ) -> Set (k (lookup i xs) ⊔ γ)) 12 | -- -> (B -> Set γ) 13 | -- -> Set (β ⊔ max (map k xs) ⊔ γ) 14 | -- Liftᵐ-go β k zero xs F C = Lift {ℓ = β ⊔ max (map k xs)} (F C) 15 | -- Liftᵐ-go β k (suc i) (x , xs) F C = Liftᵐ-go (β ⊔ k x) k i xs F C 16 | 17 | -- This generalizes `Lift∃ᵐ' and `Lift∀ᵐ', but not very much, 18 | -- and we then also need to generalize `Lift∃ᶻ', so I decided to use ad hoc versions. 19 | -- Liftᵐ : ∀ {n α γ} {A : Set α} 20 | -- (k : A -> Level) i (xs : A ^ n) {B : Set (k (lookup i xs))} 21 | -- -> ((B -> Set γ) -> Set (k (lookup i xs) ⊔ γ)) 22 | -- -> (B -> Set γ) 23 | -- -> Set (max (map k xs) ⊔ γ) 24 | -- Liftᵐ = Liftᵐ-go lzero 25 | 26 | Lift∃ᵐ-go : ∀ {n α γ} {A : Set α} 27 | β (k : A -> Level) i (xs : A ^ n) {B : Set (k (lookup i xs))} 28 | -> (B -> Set γ) -> Set (β ⊔ max (map k xs) ⊔ γ) 29 | Lift∃ᵐ-go β k zero xs C = Lift {ℓ = β ⊔ max (map k xs)} (∃ C) 30 | Lift∃ᵐ-go β k (suc i) (x , xs) C = Lift∃ᵐ-go (β ⊔ k x) k i xs C 31 | 32 | Lift∃ᵐ : ∀ {n α γ} {A : Set α} 33 | (k : A -> Level) i (xs : A ^ n) {B : Set (k (lookup i xs))} 34 | -> (B -> Set γ) -> Set (max (map k xs) ⊔ γ) 35 | Lift∃ᵐ = Lift∃ᵐ-go lzero 36 | 37 | lift∃ᵐ-go : ∀ {n α γ} {A : Set α} {k : A -> Level} {xs : A ^ n} 38 | β i {B : Set (k (lookup i xs))} {C : B -> Set γ} 39 | -> ∃ C -> Lift∃ᵐ-go β k i xs C 40 | lift∃ᵐ-go β zero p = lift p 41 | lift∃ᵐ-go {k = k} {x , _} β (suc i) p = lift∃ᵐ-go (β ⊔ k x) i p 42 | 43 | lift∃ᵐ : ∀ {n α γ} {A : Set α} {k : A -> Level} {xs : A ^ n} 44 | i {B : Set (k (lookup i xs))} {C : B -> Set γ} 45 | -> ∃ C -> Lift∃ᵐ k i xs C 46 | lift∃ᵐ = lift∃ᵐ-go lzero 47 | 48 | lower∃ᵐ-go : ∀ {n α γ} {A : Set α} {k : A -> Level} {xs : A ^ n} 49 | β i {B : Set (k (lookup i xs))} {C : B -> Set γ} 50 | -> Lift∃ᵐ-go β k i xs C -> ∃ C 51 | lower∃ᵐ-go β zero p = lower p 52 | lower∃ᵐ-go {k = k} {x , _} β (suc i) p = lower∃ᵐ-go (β ⊔ k x) i p 53 | 54 | lower∃ᵐ : ∀ {n α γ} {A : Set α} {k : A -> Level} {xs : A ^ n} 55 | i {B : Set (k (lookup i xs))} {C : B -> Set γ} 56 | -> Lift∃ᵐ k i xs C -> ∃ C 57 | lower∃ᵐ = lower∃ᵐ-go lzero 58 | 59 | Lift∃ᶻ-go : ∀ {n α β δ} {A : Set α} {B : Set β} 60 | γ (k : A -> B -> Level) i (xs : A ^ n) (ys : B ^ n) 61 | {C : Set (k (lookup i xs) (lookup i ys))} 62 | -> (C -> Set δ) -> Set (γ ⊔ max (zipWith k xs ys) ⊔ δ) 63 | Lift∃ᶻ-go γ k zero xs ys D = Lift {ℓ = γ ⊔ max (zipWith k xs ys)} (∃ D) 64 | Lift∃ᶻ-go γ k (suc i) (x , xs) (y , ys) D = Lift∃ᶻ-go (γ ⊔ k x y) k i xs ys D 65 | 66 | Lift∃ᶻ : ∀ {n α β δ} {A : Set α} {B : Set β} 67 | (k : A -> B -> Level) i (xs : A ^ n) (ys : B ^ n) 68 | {C : Set (k (lookup i xs) (lookup i ys))} 69 | -> (C -> Set δ) -> Set (max (zipWith k xs ys) ⊔ δ) 70 | Lift∃ᶻ = Lift∃ᶻ-go lzero 71 | 72 | lift∃ᶻ-go : ∀ {n α β δ} {A : Set α} {B : Set β} 73 | {k : A -> B -> Level} {xs : A ^ n} {ys : B ^ n} 74 | γ i {C : Set (k (lookup i xs) (lookup i ys))} {D : C -> Set δ} 75 | -> ∃ D -> Lift∃ᶻ-go γ k i xs ys D 76 | lift∃ᶻ-go γ zero p = lift p 77 | lift∃ᶻ-go {k = k} {x , _} {y , _} γ (suc i) p = lift∃ᶻ-go (γ ⊔ k x y) i p 78 | 79 | lift∃ᶻ : ∀ {n α β δ} {A : Set α} {B : Set β} 80 | {k : A -> B -> Level} {xs : A ^ n} {ys : B ^ n} 81 | i {C : Set (k (lookup i xs) (lookup i ys))} {D : C -> Set δ} 82 | -> ∃ D -> Lift∃ᶻ k i xs ys D 83 | lift∃ᶻ = lift∃ᶻ-go lzero 84 | 85 | lower∃ᶻ-go : ∀ {n α β δ} {A : Set α} {B : Set β} 86 | {k : A -> B -> Level} {xs : A ^ n} {ys : B ^ n} 87 | γ i {C : Set (k (lookup i xs) (lookup i ys))} {D : C -> Set δ} 88 | -> Lift∃ᶻ-go γ k i xs ys D -> ∃ D 89 | lower∃ᶻ-go γ zero p = lower p 90 | lower∃ᶻ-go {k = k} {x , _} {y , _} γ (suc i) p = lower∃ᶻ-go (γ ⊔ k x y) i p 91 | 92 | lower∃ᶻ : ∀ {n α β δ} {A : Set α} {B : Set β} 93 | {k : A -> B -> Level} {xs : A ^ n} {ys : B ^ n} 94 | i {C : Set (k (lookup i xs) (lookup i ys))} {D : C -> Set δ} 95 | -> Lift∃ᶻ k i xs ys D -> ∃ D 96 | lower∃ᶻ = lower∃ᶻ-go lzero 97 | 98 | Lift∀ᵐ-go : ∀ {n α γ} {A : Set α} 99 | β (k : A -> Level) i (xs : A ^ n) {B : Set (k (lookup i xs))} 100 | -> (B -> Set γ) -> Set (β ⊔ max (map k xs) ⊔ γ) 101 | Lift∀ᵐ-go β k zero xs C = Lift {ℓ = β ⊔ max (map k xs)} (∀ y -> C y) 102 | Lift∀ᵐ-go β k (suc i) (x , xs) C = Lift∀ᵐ-go (β ⊔ k x) k i xs C 103 | 104 | Lift∀ᵐ : ∀ {n α γ} {A : Set α} 105 | (k : A -> Level) i (xs : A ^ n) {B : Set (k (lookup i xs))} 106 | -> (B -> Set γ) -> Set (max (map k xs) ⊔ γ) 107 | Lift∀ᵐ = Lift∀ᵐ-go lzero 108 | 109 | lift∀ᵐ-go : ∀ {n α γ} {A : Set α} {k : A -> Level} {xs : A ^ n} 110 | β i {B : Set (k (lookup i xs))} {C : B -> Set γ} 111 | -> (∀ y -> C y) -> Lift∀ᵐ-go β k i xs C 112 | lift∀ᵐ-go β zero h = lift h 113 | lift∀ᵐ-go {k = k} {x , _} β (suc i) h = lift∀ᵐ-go (β ⊔ k x) i h 114 | 115 | lift∀ᵐ : ∀ {n α γ} {A : Set α} {k : A -> Level} {xs : A ^ n} 116 | i {B : Set (k (lookup i xs))} {C : B -> Set γ} 117 | -> (∀ y -> C y) -> Lift∀ᵐ k i xs C 118 | lift∀ᵐ = lift∀ᵐ-go lzero 119 | 120 | lower∀ᵐ-go : ∀ {n α γ} {A : Set α} {k : A -> Level} {xs : A ^ n} 121 | β i {B : Set (k (lookup i xs))} {C : B -> Set γ} 122 | -> Lift∀ᵐ-go β k i xs C -> (∀ y -> C y) 123 | lower∀ᵐ-go β zero h = lower h 124 | lower∀ᵐ-go {k = k} {x , _} β (suc i) h = lower∀ᵐ-go (β ⊔ k x) i h 125 | 126 | lower∀ᵐ : ∀ {n α γ} {A : Set α} {k : A -> Level} {xs : A ^ n} 127 | i {B : Set (k (lookup i xs))} {C : B -> Set γ} 128 | -> Lift∀ᵐ k i xs C -> (∀ y -> C y) 129 | lower∀ᵐ = lower∀ᵐ-go lzero 130 | -------------------------------------------------------------------------------- /Loop.agda: -------------------------------------------------------------------------------- 1 | module Loop where 2 | 3 | open import Prelude public 4 | open import Loop.Core public 5 | -------------------------------------------------------------------------------- /Loop/Core.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Loop.Core where 4 | 5 | open import Prelude 6 | 7 | infix 3 _∈_ _∈₁_ _∈²_ 8 | infixl 2 _>>=_ 9 | infixr 1 _>>_ 10 | infixl 6 _<$>_ _<*>_ 11 | 12 | List₁ : ∀ {A} (B : A -> Set) -> List A -> Set 13 | List₁ B [] = ⊤ 14 | List₁ B (x ∷ xs) = B x × List₁ B xs 15 | 16 | lmap₁ : ∀ {A} {B : A -> Set} -> (∀ x -> B x) -> (xs : List A) -> List₁ B xs 17 | lmap₁ f [] = tt 18 | lmap₁ f (x ∷ xs) = f x , lmap₁ f xs 19 | 20 | head₁ : ∀ {A} {B : A -> Set} {x xs} -> List₁ B (x ∷ xs) -> B x 21 | head₁ (y , ys) = y 22 | 23 | tail₁ : ∀ {A} {B : A -> Set} {x xs} -> List₁ B (x ∷ xs) -> List₁ B xs 24 | tail₁ (y , ys) = ys 25 | 26 | _∈_ : ∀ {A} -> A -> List A -> Set 27 | y ∈ [] = ⊥ 28 | y ∈ (x ∷ xs) = y ≡ x ⊎ y ∈ xs 29 | 30 | data _∈₁_ {A} {B : A -> Set} {x} (y : B x) : ∀ {xs} -> List₁ B xs -> Set where 31 | here₁ : ∀ {xs} {ys : List₁ B xs} -> y ∈₁ y , ys 32 | there₁ : ∀ {x xs} {z : B x} {ys : List₁ B xs} -> y ∈₁ ys -> y ∈₁ z , ys 33 | 34 | _∈²_ : ∀ {A} {B C : A -> Set} {x xs} -> B x × C x -> List₁ B xs × List₁ C xs -> Set 35 | _∈²_ {x = x₁} {[]} (y₁ , z₁) (tt , tt ) = ⊥ 36 | _∈²_ {x = x₁} {x₂ ∷ _} (y₁ , z₁) ((y₂ , ys) , (z₂ , zs)) = x₁ ≡ x₂ × y₁ ≅ y₂ × z₁ ≅ z₂ 37 | ⊎ y₁ , z₁ ∈² ys , zs 38 | 39 | un∈ʳ : ∀ {A} {B C : A -> Set} {x xs} {y : B x} {z : C x} {ys : List₁ B xs} {zs : List₁ C xs} 40 | -> y , z ∈² ys , zs -> z ∈₁ zs 41 | un∈ʳ {xs = []} () 42 | un∈ʳ {xs = _ ∷ _} (inj₁ (refl , hrefl , hrefl)) = here₁ 43 | un∈ʳ {xs = _ ∷ _} (inj₂ p) = there₁ (un∈ʳ p) 44 | 45 | replace₁ : ∀ {A} {B : A -> Set} {x} {xs : List A} {y : B x} {ys : List₁ B xs} 46 | -> B x -> y ∈₁ ys -> List₁ B xs 47 | replace₁ {ys = y , ys} z here₁ = z , ys 48 | replace₁ {ys = y , ys} z (there₁ p) = y , replace₁ z p 49 | 50 | -------------------- 51 | 52 | Sets : Set 53 | Sets = List Set 54 | 55 | HList : Sets -> Set 56 | HList = List₁ id 57 | 58 | Resources = HList 59 | 60 | Effectful : ∀ {R} -> Set 61 | Effectful {R} = (A : Set) -> (A -> R) -> Set 62 | 63 | Effect : Set -> Set 64 | Effect R = R -> Effectful {R} 65 | 66 | Effects : Sets -> Set 67 | Effects = List₁ Effect 68 | 69 | -- The (∀ {Rs}) part might be too restrictive. 70 | HigherEffect : Set 71 | HigherEffect = ∀ {Rs} -> Effects Rs -> Effect (Resources Rs) 72 | 73 | HigherEffects : Set 74 | HigherEffects = List HigherEffect 75 | 76 | data Unionᵉ : HigherEffect where 77 | hereᵉ : ∀ {R Rs r A r′ rs} {Ψ : Effect R} {Ψs : Effects Rs} 78 | -> Ψ r A r′ -> Unionᵉ (Ψ , Ψs) (r , rs) A (λ x -> r′ x , rs) 79 | thereᵉ : ∀ {R Rs r A rs rs′} {Ψ : Effect R} {Ψs : Effects Rs} 80 | -> Unionᵉ Ψs rs A rs′ -> Unionᵉ (Ψ , Ψs) (r , rs) A (λ x -> r , rs′ x) 81 | 82 | data Unionʰᵉ : HigherEffects -> HigherEffect where 83 | hereʰᵉ : ∀ {Φs Rs rs A rs′} {Φ : HigherEffect} {Ψs : Effects Rs} 84 | -> Φ {Rs} Ψs rs A rs′ -> Unionʰᵉ (Φ ∷ Φs) Ψs rs A rs′ 85 | thereʰᵉ : ∀ {Φs Rs rs A rs′} {Φ : HigherEffect} {Ψs : Effects Rs} 86 | -> Unionʰᵉ Φs Ψs rs A rs′ -> Unionʰᵉ (Φ ∷ Φs) Ψs rs A rs′ 87 | 88 | -------------------- 89 | 90 | data IFreer {R : Set} (Ψ : Effect R) : Effect R where 91 | return : ∀ {B r′} y -> IFreer Ψ (r′ y) B r′ 92 | call : ∀ {r A r′ B r′′} -> Ψ r A r′ -> (∀ x -> IFreer Ψ (r′ x) B r′′) -> IFreer Ψ r B r′′ 93 | 94 | liftᶠ : ∀ {R Ψ r A r′} -> Ψ r A r′ -> IFreer {R} Ψ r A r′ 95 | liftᶠ a = call a return 96 | 97 | _>>=_ : ∀ {R Ψ r B r′ C r′′} 98 | -> IFreer {R} Ψ r B r′ -> (∀ y -> IFreer Ψ (r′ y) C r′′) -> IFreer Ψ r C r′′ 99 | return y >>= g = g y 100 | call a f >>= g = call a λ x -> f x >>= g 101 | 102 | _>>_ : ∀ {R Ψ r₁ B r₂ C r′′} 103 | -> IFreer {R} Ψ r₁ B (const r₂) -> IFreer Ψ r₂ C r′′ -> IFreer Ψ r₁ C r′′ 104 | b >> c = b >>= const c 105 | 106 | _<$>_ : ∀ {R Ψ r₁ B r₂ C} -> (B -> C) -> IFreer {R} Ψ r₁ B (const r₂) -> IFreer Ψ r₁ C (const r₂) 107 | g <$> b = b >>= return ∘ g 108 | 109 | _<*>_ : ∀ {R Ψ r₁ B r₂ C r₃} 110 | -> IFreer {R} Ψ r₁ (B -> C) (const r₂) 111 | -> IFreer {R} Ψ r₂ B (const r₃) 112 | -> IFreer {R} Ψ r₁ C (const r₃) 113 | h <*> b = h >>= _<$> b 114 | 115 | -------------------- 116 | 117 | EffOver : HigherEffects -> HigherEffect 118 | EffOver Φs Ψs = IFreer (Unionʰᵉ (Unionᵉ ∷ Φs) Ψs) 119 | 120 | inj′ : ∀ {R} {Ψ : Effect R} {r A r′ Rs rs} {Ψs : Effects Rs} 121 | -> (p : Ψ , r ∈² Ψs , rs) -> Ψ r A r′ -> Unionᵉ Ψs rs A (λ x -> replace₁ (r′ x) (un∈ʳ p)) 122 | inj′ {Rs = []} () 123 | inj′ {Rs = _ ∷ _} (inj₁ (refl , hrefl , hrefl)) = hereᵉ 124 | inj′ {Rs = _ ∷ _} (inj₂ p) = thereᵉ ∘ inj′ p 125 | 126 | inj : ∀ {R} {Ψ : Effect R} {r A Rs rs} {Ψs : Effects Rs} 127 | -> Ψ , r ∈² Ψs , rs -> Ψ r A (const r) -> Unionᵉ Ψs rs A (const rs) 128 | inj {Rs = []} () 129 | inj {Rs = _ ∷ _} (inj₁ (refl , hrefl , hrefl)) = hereᵉ 130 | inj {Rs = _ ∷ _} (inj₂ p) = thereᵉ ∘ inj p 131 | 132 | invoke′ : ∀ {Φs R} {Ψ : Effect R} {r A r′ Rs rs} {Ψs : Effects Rs} {{p : Ψ , r ∈² Ψs , rs}} 133 | -> Ψ r A r′ -> EffOver Φs Ψs rs A _ 134 | invoke′ {{p}} = liftᶠ ∘ hereʰᵉ ∘ inj′ p 135 | 136 | invoke : ∀ {Φs R} {Ψ : Effect R} {r A Rs rs} {Ψs : Effects Rs} {{p : Ψ , r ∈² Ψs , rs}} 137 | -> Ψ r A (const r) -> EffOver Φs Ψs rs A _ 138 | invoke {{p}} = liftᶠ ∘ hereʰᵉ ∘ inj p 139 | 140 | invoke₀ : ∀ {Φs R} {Ψ : Effect R} {r A r′ Rs rs} {Ψs : Effects Rs} 141 | -> Ψ r A r′ -> EffOver Φs (Ψ , Ψs) (r , rs) A _ 142 | invoke₀ {Φs} {Ψ = Ψ} = invoke′ {Φs} {Ψ = Ψ} 143 | 144 | hinj : ∀ {Φs Φ Rs rs A rs′} {Ψs : Effects Rs} 145 | -> Φ ∈ Φs -> Φ Ψs rs A rs′ -> Unionʰᵉ Φs Ψs rs A rs′ 146 | hinj {[]} () 147 | hinj {Ξ ∷ Φs} (inj₁ refl) = hereʰᵉ 148 | hinj {Ξ ∷ Φs} (inj₂ p) = thereʰᵉ ∘ hinj p 149 | 150 | hinvoke : ∀ {Φs Φ Rs rs A rs′} {Ψs : Effects Rs} {{p : Φ ∈ Φs}} 151 | -> Φ Ψs rs A rs′ -> EffOver Φs Ψs rs A rs′ 152 | hinvoke {{p}} = liftᶠ ∘ thereʰᵉ ∘ hinj p 153 | 154 | Eff : HigherEffect 155 | Eff = EffOver [] 156 | 157 | runEff : ∀ {A} -> Eff tt tt A (const tt) -> A 158 | runEff (return x) = x 159 | runEff (call (hereʰᵉ ()) k) 160 | runEff (call (thereʰᵉ ()) k) 161 | 162 | runEffM : ∀ {Rs rs A rs′} {M : Set -> Set} {Ψs : Effects Rs} 163 | -> (∀ {A} -> A -> M A) 164 | -> (∀ {A B} -> M A -> (A -> M B) -> M B) 165 | -> (∀ {r A r′} -> Unionᵉ Ψs r A r′ -> M A) 166 | -> Eff Ψs rs A rs′ 167 | -> M A 168 | runEffM ret bind h (return x) = ret x 169 | runEffM ret bind h (call (hereʰᵉ a ) k) = bind (h a) (λ x -> runEffM ret bind h (k x)) 170 | runEffM ret bind h (call (thereʰᵉ ()) k) 171 | -------------------------------------------------------------------------------- /Loop/Effect/Break.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-positivity-check #-} 2 | 3 | module Loop.Effect.Break where 4 | 5 | open import Loop 6 | 7 | mutual 8 | Break : ∀ {Rs} -> Effects Rs -> Resources Rs -> Set -> Resources Rs -> Set 9 | Break Ψs rs₁ A rs₂ = HBreak Ψs rs₁ A (const rs₂) 10 | 11 | Breakᴱ : ∀ {Rs} -> Effects Rs -> Resources Rs -> Set -> Resources Rs -> Set 12 | Breakᴱ Ψs rs₁ A rs₂ = EffOver (HBreak ∷ []) Ψs rs₁ A (const rs₂) 13 | 14 | -- The name due to the fact that this effect breaks purity. 15 | -- E.g. in (lam λ x -> get >>= λ f -> e) `f' has a pure type and impure behaviour. 16 | data HBreak : HigherEffect where 17 | Lam : ∀ {Rs rs₁ A rs₂} {B : A -> Set} {Ψs : Effects Rs} 18 | -> (∀ x -> Breakᴱ Ψs rs₁ (B x) rs₂) -> Break Ψs rs₁ (∀ x -> B x) rs₂ 19 | 20 | lam : ∀ {Rs rs₁ A rs₂} {B : A -> Set} {Ψs : Effects Rs} 21 | -> (∀ x -> Breakᴱ Ψs rs₁ (B x) rs₂) -> Breakᴱ Ψs rs₁ (∀ x -> B x) rs₂ 22 | lam = hinvoke ∘ Lam 23 | 24 | open import Loop.Effect.State 25 | 26 | private 27 | test₁ : Breakᴱ (State , tt) (⊤ , tt) ((ℕ -> ℕ) -> ℕ -> ℕ) (ℕ , tt) 28 | test₁ = lam λ f -> zap ⊤ (f 0) >> lam λ n -> put n >> return (f n) 29 | 30 | test₂ : Breakᴱ (State , tt) (⊤ , tt) ℕ (⊤ , tt) 31 | test₂ = test₁ >>= λ f -> zap ℕ tt >> return (f id 0) 32 | -------------------------------------------------------------------------------- /Loop/Effect/General.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Loop.Effect.General where 4 | 5 | open import Loop 6 | 7 | data General A (B : A -> Set) : Effect ⊤ where 8 | Rec : ∀ x -> General A B tt (B x) (const tt) 9 | 10 | grec : ∀ {Φs Rs rs A} {Ψs : Effects Rs} {B : A -> Set} {{p : General A B , tt ∈² Ψs , rs}} 11 | -> ∀ x -> EffOver Φs Ψs rs (B x) _ 12 | grec = invoke ∘′ Rec 13 | 14 | Generalᴱ : (A : Set) -> (A -> Set) -> Set -> Set 15 | Generalᴱ A B C = Eff (General A B , tt) _ C _ 16 | 17 | Π : (A : Set) -> (A -> Set) -> Set 18 | Π A B = ∀ x -> Generalᴱ A B (B x) 19 | 20 | rec : ∀ {A} {B : A -> Set} -> Π A B 21 | rec = invoke₀ ∘′ Rec 22 | 23 | _⇒_ : Set -> Set -> Set 24 | A ⇒ B = Π A λ _ -> B 25 | 26 | runGeneralM : ∀ {A B C} {M : Set -> Set} 27 | -> (∀ {A} -> A -> M A) 28 | -> (∀ {A B} -> M A -> (A -> M B) -> M B) 29 | -> (∀ x -> M (B x)) 30 | -> Generalᴱ A B C 31 | -> M C 32 | runGeneralM {A} {B} {M = M} ret bind h = runEffM ret bind hₑ where 33 | hₑ : ∀ {r C r′} -> Unionᵉ (General A B , tt) r C r′ -> M C 34 | hₑ (hereᵉ (Rec x)) = h x 35 | hₑ (thereᵉ ()) 36 | 37 | petrol : ∀ {A B} -> ℕ -> Π A B -> ∀ x -> Maybe (B x) 38 | petrol 0 f x = nothing 39 | petrol (suc n) f x = runGeneralM just _>>=ₘ_ (petrol n f) (f x) 40 | -------------------------------------------------------------------------------- /Loop/Effect/LNSTLC.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-positivity-check #-} 2 | 3 | -- The whole module doesn't make any sense. 4 | -- The only way to interpret (Termᴱ Ψs rs₁ Γ σ rs₂) where `Ψs' is non-empty 5 | -- is via the `HBreak' effect (see the `evalTermᴱ' function), which breaks purity. 6 | -- Still, it's a nice example of why higher-order effects might be useful. 7 | 8 | -- Doesn't type check currently, because `Loop.Core` is under reconstruction. 9 | module Loop.Effect.LNSTLC where 10 | 11 | open import Loop 12 | open import Loop.Effect.Break 13 | 14 | infixr 6 _⇒_ 15 | infixl 5 _▻_ 16 | infixr 4 vs_ 17 | infixr 0 ƛ_ 18 | infixl 6 _·_ 19 | infixr 5 _::_ 20 | 21 | data Type : Set where 22 | nat : Type 23 | list : Type -> Type 24 | _⇒_ : Type -> Type -> Type 25 | 26 | ⟦_⟧ : Type -> Set 27 | ⟦ nat ⟧ = ℕ 28 | ⟦ list σ ⟧ = List ⟦ σ ⟧ 29 | ⟦ σ ⇒ τ ⟧ = ⟦ σ ⟧ -> ⟦ τ ⟧ 30 | 31 | data Con : Set where 32 | ε : Con 33 | _▻_ : Con -> Type -> Con 34 | 35 | data In σ : Con -> Set where 36 | vz : ∀ {Γ} -> In σ (Γ ▻ σ) 37 | vs_ : ∀ {Γ τ} -> In σ Γ -> In σ (Γ ▻ τ) 38 | 39 | data Env : Con -> Set where 40 | ∅ : Env ε 41 | _▷_ : ∀ {Γ σ} -> Env Γ -> ⟦ σ ⟧ -> Env (Γ ▻ σ) 42 | 43 | lookupEnv : ∀ {Γ σ} -> In σ Γ -> Env Γ -> ⟦ σ ⟧ 44 | lookupEnv vz (ρ ▷ x) = x 45 | lookupEnv (vs v) (ρ ▷ x) = lookupEnv v ρ 46 | 47 | mutual 48 | Term : ∀ {Rs} -> Effects Rs -> Resources Rs -> Con -> Type -> Resources Rs -> Set 49 | Term Ψs rs₁ Γ σ rs₂ = HTerm Γ Ψs rs₁ ⟦ σ ⟧ (const rs₂) 50 | 51 | -- A funny problem: we need to put contexts somewhere, no matter where, 52 | -- but they just don't fit anywhere. The current version (`HTerm' is indexed by a context) 53 | -- looks restrictive (that claim needs a proof). We could put contexts into resources 54 | -- at the cost of introducing a dummy effect, but it looks silly and doesn't solve all problems. 55 | -- We could make `EffOver' return contexts, but then it would be impossible to use simple _>>=_ 56 | -- and other combinators, which is annoying (and I also haven't tried this solution). 57 | Termᴱ : ∀ {Rs} -> Effects Rs -> Resources Rs -> Con -> Type -> Resources Rs -> Set 58 | Termᴱ Ψs rs₁ Γ σ rs₂ = EffOver (HTerm Γ ∷ []) Ψs rs₁ ⟦ σ ⟧ (const rs₂) 59 | 60 | data HTerm Γ : HigherEffect where 61 | Pure : ∀ {Rs rs σ} {Ψs : Effects Rs} -> ⟦ σ ⟧ -> Term Ψs rs Γ σ rs 62 | Var : ∀ {Rs rs σ} {Ψs : Effects Rs} -> In σ Γ -> Term Ψs rs Γ σ rs 63 | Lam : ∀ {Rs rs₁ rs₂ σ τ} {Ψs : Effects Rs} 64 | -> Termᴱ Ψs rs₁ (Γ ▻ σ) τ rs₂ 65 | -> Term Ψs rs₁ Γ (σ ⇒ τ) rs₂ 66 | App : ∀ {Rs rs₁ rs₂ rs₃ σ τ} {Ψs : Effects Rs} 67 | -> Termᴱ Ψs rs₁ Γ (σ ⇒ τ) rs₂ 68 | -> Termᴱ Ψs rs₂ Γ σ rs₃ 69 | -> Term Ψs rs₁ Γ τ rs₃ 70 | Z : ∀ {Rs rs } {Ψs : Effects Rs} 71 | -> Term Ψs rs Γ nat rs 72 | S : ∀ {Rs rs₁ rs₂ } {Ψs : Effects Rs} 73 | -> Termᴱ Ψs rs₁ Γ nat rs₂ 74 | -> Term Ψs rs₁ Γ nat rs₂ 75 | Fold : ∀ {Rs rs₁ rs₂ rs₃ σ } {Ψs : Effects Rs} 76 | -> Termᴱ Ψs rs₃ Γ (σ ⇒ σ) rs₃ 77 | -> Termᴱ Ψs rs₂ Γ σ rs₃ 78 | -> Termᴱ Ψs rs₁ Γ nat rs₂ 79 | -> Term Ψs rs₁ Γ σ rs₃ 80 | Nil : ∀ {Rs rs σ } {Ψs : Effects Rs} 81 | -> Term Ψs rs Γ (list σ) rs 82 | Cons : ∀ {Rs rs₁ rs₂ rs₃ σ } {Ψs : Effects Rs} 83 | -> Termᴱ Ψs rs₁ Γ σ rs₂ 84 | -> Termᴱ Ψs rs₂ Γ (list σ) rs₃ 85 | -> Term Ψs rs₁ Γ (list σ) rs₃ 86 | Foldr : ∀ {Rs rs₁ rs₂ rs₃ σ τ} {Ψs : Effects Rs} 87 | -> Termᴱ Ψs rs₃ Γ (σ ⇒ τ ⇒ τ) rs₃ 88 | -> Termᴱ Ψs rs₂ Γ τ rs₃ 89 | -> Termᴱ Ψs rs₁ Γ (list σ) rs₂ 90 | -> Term Ψs rs₁ Γ τ rs₃ 91 | 92 | var : ∀ {Rs rs Γ σ} {Ψs : Effects Rs} -> In σ Γ -> Termᴱ Ψs rs Γ σ rs 93 | var v = hinvoke (Var v) 94 | 95 | ƛ_ : ∀ {Rs rs₁ rs₂ Γ σ τ} {Ψs : Effects Rs} 96 | -> Termᴱ Ψs rs₁ (Γ ▻ σ) τ rs₂ -> Termᴱ Ψs rs₁ Γ (σ ⇒ τ) rs₂ 97 | ƛ b = hinvoke (Lam b) 98 | 99 | _·_ : ∀ {Rs rs₁ rs₂ rs₃ Γ σ τ} {Ψs : Effects Rs} 100 | -> Termᴱ Ψs rs₁ Γ (σ ⇒ τ) rs₂ -> Termᴱ Ψs rs₂ Γ σ rs₃ -> Termᴱ Ψs rs₁ Γ τ rs₃ 101 | f · x = hinvoke (App f x) 102 | 103 | z : ∀ {Rs rs Γ} {Ψs : Effects Rs} -> Termᴱ Ψs rs Γ nat rs 104 | z = hinvoke Z 105 | 106 | s : ∀ {Rs rs₁ rs₂ Γ} {Ψs : Effects Rs} -> Termᴱ Ψs rs₁ Γ nat rs₂ -> Termᴱ Ψs rs₁ Γ nat rs₂ 107 | s n = hinvoke (S n) 108 | 109 | tfold : ∀ {Rs rs₁ rs₂ rs₃ Γ σ} {Ψs : Effects Rs} 110 | -> Termᴱ Ψs rs₃ Γ (σ ⇒ σ) rs₃ 111 | -> Termᴱ Ψs rs₂ Γ σ rs₃ 112 | -> Termᴱ Ψs rs₁ Γ nat rs₂ 113 | -> Termᴱ Ψs rs₁ Γ σ rs₃ 114 | tfold f z n = hinvoke (Fold f z n) 115 | 116 | nil : ∀ {Rs rs Γ σ} {Ψs : Effects Rs} -> Termᴱ Ψs rs Γ (list σ) rs 117 | nil = hinvoke Nil 118 | 119 | _::_ : ∀ {Rs rs₁ rs₂ rs₃ Γ σ} {Ψs : Effects Rs} 120 | -> Termᴱ Ψs rs₁ Γ σ rs₂ -> Termᴱ Ψs rs₂ Γ (list σ) rs₃ -> Termᴱ Ψs rs₁ Γ (list σ) rs₃ 121 | x :: xs = hinvoke (Cons x xs) 122 | 123 | tfoldr : ∀ {Rs rs₁ rs₂ rs₃ Γ σ τ} {Ψs : Effects Rs} 124 | -> Termᴱ Ψs rs₃ Γ (σ ⇒ τ ⇒ τ) rs₃ 125 | -> Termᴱ Ψs rs₂ Γ τ rs₃ 126 | -> Termᴱ Ψs rs₁ Γ (list σ) rs₂ 127 | -> Termᴱ Ψs rs₁ Γ τ rs₃ 128 | tfoldr f z xs = hinvoke (Foldr f z xs) 129 | 130 | runTermᴱ : ∀ {Γ σ} -> Env Γ -> Termᴱ tt tt Γ σ tt -> ⟦ σ ⟧ 131 | runTermᴱ ρ (return x) = x 132 | runTermᴱ ρ (wcall (inj₁ ()) k) 133 | runTermᴱ ρ (wcall (inj₂ (inj₂ ())) k) 134 | runTermᴱ ρ (wcall (inj₂ (inj₁ (Pure x))) k) = runTermᴱ ρ (k x) 135 | runTermᴱ ρ (wcall (inj₂ (inj₁ (Var v))) k) = runTermᴱ ρ (k (lookupEnv v ρ)) 136 | runTermᴱ ρ (wcall (inj₂ (inj₁ (Lam b))) k) = runTermᴱ ρ (k (λ x -> runTermᴱ (ρ ▷ x) b)) 137 | runTermᴱ ρ (wcall (inj₂ (inj₁ (App f x))) k) = runTermᴱ ρ (k (runTermᴱ ρ f (runTermᴱ ρ x))) 138 | runTermᴱ ρ (wcall (inj₂ (inj₁ Z)) k) = runTermᴱ ρ (k 0) 139 | runTermᴱ ρ (wcall (inj₂ (inj₁ (S n))) k) = runTermᴱ ρ (k (suc (runTermᴱ ρ n))) 140 | runTermᴱ ρ (wcall (inj₂ (inj₁ (Fold f z n))) k) = runTermᴱ ρ (k (fold (runTermᴱ ρ z) 141 | (runTermᴱ ρ f) 142 | (runTermᴱ ρ n))) 143 | runTermᴱ ρ (wcall (inj₂ (inj₁ Nil)) k) = runTermᴱ ρ (k []) 144 | runTermᴱ ρ (wcall (inj₂ (inj₁ (Cons x xs))) k) = runTermᴱ ρ (k (runTermᴱ ρ x ∷ runTermᴱ ρ xs)) 145 | runTermᴱ ρ (wcall (inj₂ (inj₁ (Foldr f z xs))) k) = runTermᴱ ρ (k (lfoldr (runTermᴱ ρ f) 146 | (runTermᴱ ρ z) 147 | (runTermᴱ ρ xs))) 148 | 149 | {-# TERMINATING #-} 150 | evalTermᴱ : ∀ {Rs rs₁ rs₂ Γ σ} {Ψs : Effects Rs} 151 | -> Env Γ -> Termᴱ Ψs rs₁ Γ σ rs₂ -> Breakᴱ Ψs rs₁ ⟦ σ ⟧ rs₂ 152 | evalTermᴱ ρ (return x) = return x 153 | evalTermᴱ ρ (wcall (inj₁ a) k) = wcall (inj₁ a) (evalTermᴱ ρ ∘′ k) 154 | evalTermᴱ ρ (wcall (inj₂ (inj₂ ())) k) 155 | evalTermᴱ ρ (wcall (inj₂ (inj₁ (Pure x))) k) = evalTermᴱ ρ (k x) 156 | evalTermᴱ ρ (wcall (inj₂ (inj₁ (Var v))) k) = evalTermᴱ ρ (k (lookupEnv v ρ)) 157 | evalTermᴱ ρ (wcall (inj₂ (inj₁ (Lam b))) k) = 158 | (lam λ x -> evalTermᴱ (ρ ▷ x) b) >>= evalTermᴱ ρ ∘ k 159 | evalTermᴱ ρ (wcall (inj₂ (inj₁ (App f x))) k) = 160 | evalTermᴱ ρ f <*> evalTermᴱ ρ x >>= evalTermᴱ ρ ∘ k 161 | evalTermᴱ ρ (wcall (inj₂ (inj₁ Z)) k) = evalTermᴱ ρ (k 0) 162 | evalTermᴱ ρ (wcall (inj₂ (inj₁ (S n))) k) = evalTermᴱ ρ n >>= evalTermᴱ ρ ∘ k ∘ suc 163 | evalTermᴱ ρ (wcall (inj₂ (inj₁ (Fold f z n))) k) = 164 | evalTermᴱ ρ n >>= λ nₚ -> fold (evalTermᴱ ρ z) 165 | (λ x -> flip _$_ <$> x <*> evalTermᴱ ρ f) 166 | nₚ 167 | >>= evalTermᴱ ρ ∘ k 168 | evalTermᴱ ρ (wcall (inj₂ (inj₁ Nil)) k) = evalTermᴱ ρ (k []) 169 | evalTermᴱ ρ (wcall (inj₂ (inj₁ (Cons x xs))) k) = 170 | _∷_ <$> evalTermᴱ ρ x <*> evalTermᴱ ρ xs >>= evalTermᴱ ρ ∘ k 171 | evalTermᴱ ρ (wcall (inj₂ (inj₁ (Foldr f z xs))) k) = 172 | evalTermᴱ ρ xs >>= λ xsₚ -> lfoldr (λ xₚ y -> (λ yₚ fₚ -> fₚ xₚ yₚ) <$> y <*> evalTermᴱ ρ f) 173 | (evalTermᴱ ρ z) 174 | xsₚ 175 | >>= evalTermᴱ ρ ∘ k 176 | 177 | 178 | 179 | open import Loop.Effect.State 180 | 181 | A : ∀ {σ τ} -> Termᴱ tt tt ε ((σ ⇒ τ) ⇒ σ ⇒ τ) tt 182 | A = ƛ ƛ var (vs vz) · var vz 183 | 184 | private 185 | test₁ : Termᴱ (State , tt) (⊤ , tt) ε ((nat ⇒ nat) ⇒ nat ⇒ nat) (ℕ , tt) 186 | test₁ = ƛ ƛ var vz >>= zap ⊤ >> var (vs vz) · get 187 | 188 | test₂ : Termᴱ (State , tt) (⊤ , tt) ε ((nat ⇒ nat) ⇒ nat ⇒ nat) (ℕ , tt) 189 | test₂ = ƛ var vz >>= (λ f -> zap ⊤ (f 0)) >> (ƛ var (vs vz) · get) 190 | -------------------------------------------------------------------------------- /Loop/Effect/State.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Loop.Effect.State where 4 | 5 | open import Loop 6 | 7 | data State A : Effectful where 8 | Get : State A A (const A) 9 | Put : ∀ {B} -> B -> State A ⊤ (const B) 10 | 11 | get : ∀ {Φs Rs rs A} {Ψs : Effects Rs} {{p : State , A ∈² Ψs , rs}} -> EffOver Φs Ψs rs A _ 12 | get = invoke Get 13 | 14 | zap : ∀ {Φs Rs rs B} {Ψs : Effects Rs} A {{p : State , A ∈² Ψs , rs}} -> B -> EffOver Φs Ψs rs ⊤ _ 15 | zap _ = invoke′ ∘ Put 16 | 17 | put : ∀ {Φs Rs rs A} {Ψs : Effects Rs} {{p : State , A ∈² Ψs , rs}} -> A -> EffOver Φs Ψs rs ⊤ _ 18 | put = invoke ∘ Put 19 | 20 | {-# TERMINATING #-} 21 | execState : ∀ {Rs A rs B rs′} {Ψs : Effects Rs} 22 | -> A 23 | -> Eff (State , Ψs) (A , rs) B rs′ 24 | -> Eff Ψs rs (Σ B (head₁ ∘ rs′)) (tail₁ ∘ rs′ ∘ proj₁) 25 | execState s (return y) = return (y , s) 26 | execState s (call (hereʰᵉ (thereᵉ a)) k) = call (hereʰᵉ a) (λ x -> execState s (k x)) 27 | execState s (call (thereʰᵉ ()) k) 28 | execState s (call (hereʰᵉ (hereᵉ a)) k) with a 29 | ... | Get = execState s (k s) 30 | ... | Put s' = execState s' (k tt) 31 | 32 | private 33 | open import Data.Vec as V hiding (_>>=_) 34 | 35 | test : Eff (State , tt) (ℕ , tt) ℕ (λ n -> V.Vec Bool n , tt) 36 | test = get >>= λ n -> zap ℕ (V.replicate true) >> return n 37 | 38 | test-test : runEff (execState 3 test) ≡ (3 , true ∷ true ∷ true ∷ []) 39 | test-test = refl 40 | -------------------------------------------------------------------------------- /Loop/Effect/Vars.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-positivity-check #-} 2 | 3 | module Loop.Effect.Vars where 4 | 5 | open import Loop 6 | open import Loop.Effect.Break 7 | 8 | open import Data.List.Any 9 | open Membership-≡ renaming (_∈_ to _∈ₗ_) 10 | 11 | pattern phere = here refl 12 | 13 | hlookup : ∀ {A Γ} -> A ∈ₗ Γ -> HList Γ -> A 14 | hlookup phere (x , xs) = x 15 | hlookup (there v) (x , xs) = hlookup v xs 16 | 17 | mutual 18 | Term : ∀ {Rs} -> Effects Rs -> Resources Rs -> List Set -> Set -> Resources Rs -> Set 19 | Term Ψs rs₁ Γ A rs₂ = HTerm Γ Ψs rs₁ A (const rs₂) 20 | 21 | Termᴱ : ∀ {Rs} -> Effects Rs -> Resources Rs -> List Set -> Set -> Resources Rs -> Set 22 | Termᴱ Ψs rs₁ Γ A rs₂ = EffOver (HTerm Γ ∷ []) Ψs rs₁ A (const rs₂) 23 | 24 | data HTerm Γ : HigherEffect where 25 | Var : ∀ {Rs rs A} {Ψs : Effects Rs} -> A ∈ₗ Γ -> Term Ψs rs Γ A rs 26 | App : ∀ {Rs rs₁ rs₂ rs₃ A B} {Ψs : Effects Rs} 27 | -> Termᴱ Ψs rs₁ Γ (A -> B) rs₂ -> Termᴱ Ψs rs₂ Γ A rs₃ -> Term Ψs rs₁ Γ B rs₃ 28 | 29 | var : ∀ {Rs rs Γ A} {Ψs : Effects Rs} -> A ∈ₗ Γ -> Termᴱ Ψs rs Γ A rs 30 | var v = hinvoke (Var v) 31 | 32 | _·_ : ∀ {Rs rs₁ rs₂ rs₃ Γ A B} {Ψs : Effects Rs} 33 | -> Termᴱ Ψs rs₁ Γ (A -> B) rs₂ -> Termᴱ Ψs rs₂ Γ A rs₃ -> Termᴱ Ψs rs₁ Γ B rs₃ 34 | f · x = hinvoke (App f x) 35 | 36 | evalTermᴱ : ∀ {Rs rs₁ rs₂ Γ A} {Ψs : Effects Rs} 37 | -> HList Γ -> Termᴱ Ψs rs₁ Γ A rs₂ -> Eff Ψs rs₁ A (const rs₂) 38 | evalTermᴱ ρ (return x) = return x 39 | evalTermᴱ ρ (call (hereʰᵉ a ) k) = call (hereʰᵉ a) (λ x -> evalTermᴱ ρ (k x)) 40 | evalTermᴱ ρ (call (thereʰᵉ (thereʰᵉ () )) k) 41 | evalTermᴱ ρ (call (thereʰᵉ (hereʰᵉ (Var v ))) k) = evalTermᴱ ρ (k (hlookup v ρ)) 42 | evalTermᴱ ρ (call (thereʰᵉ (hereʰᵉ (App f x))) k) = 43 | evalTermᴱ ρ f <*> evalTermᴱ ρ x >>= λ fx -> evalTermᴱ ρ (k fx) 44 | 45 | 46 | 47 | open import Loop.Effect.State 48 | open import Data.String.Base hiding (show) 49 | open import Data.Nat.Show 50 | 51 | private 52 | test : Termᴱ (State , tt) (⊤ , tt) ((ℕ -> String) ∷ ℕ ∷ []) String (ℕ , tt) 53 | test = var (there phere) >>= zap ⊤ >> var phere · get 54 | 55 | -- "2" , 2 56 | test-test : String × ℕ 57 | test-test = runEff $ execState tt $ evalTermᴱ (show , 2 , tt) test 58 | -------------------------------------------------------------------------------- /Loop/Effect/Writer.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Loop.Effect.Writer where 4 | 5 | open import Loop 6 | 7 | data Writer A : Effectful where 8 | Tell : A -> Writer A ⊤ (const A) 9 | 10 | tell : ∀ {Φs Rs rs A} {Ψs : Effects Rs} {{p : Writer , A ∈² Ψs , rs}} -> A -> EffOver Φs Ψs rs ⊤ _ 11 | tell = invoke ∘ Tell 12 | -------------------------------------------------------------------------------- /Loop/Simple.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Loop.Simple where 4 | 5 | open import Prelude 6 | 7 | infix 3 _∈_ 8 | infixl 2 _>>=_ 9 | infixr 1 _>>_ 10 | infixl 6 _<$>_ 11 | 12 | _∈_ : ∀ {A} -> A -> List A -> Set 13 | y ∈ xs = lfoldr (λ x R -> y ≡ x ⊎ R) ⊥ xs 14 | 15 | Effect : Set 16 | Effect = Set -> Set 17 | 18 | Effects : Set 19 | Effects = List Effect 20 | 21 | HigherEffect : Set 22 | HigherEffect = Effects -> Effect 23 | 24 | HigherEffects : Set 25 | HigherEffects = List HigherEffect 26 | 27 | -- Expanded (lfoldr (λ Ψ R -> Ψ A ⊎ R) ⊥ Ψs) to make the function constructor-headed. 28 | Unionᵉ : HigherEffect 29 | Unionᵉ [] A = ⊥ 30 | Unionᵉ (Ψ ∷ Ψs) A = Ψ A ⊎ Unionᵉ Ψs A 31 | 32 | _⊎ʰᵉ_ : HigherEffect -> HigherEffect -> HigherEffect 33 | (Φ ⊎ʰᵉ Ξ) Ψs A = Φ Ψs A ⊎ Ξ Ψs A 34 | 35 | Unionʰᵉ : HigherEffects -> HigherEffect 36 | Unionʰᵉ = lfoldr _⊎ʰᵉ_ (λ _ _ -> ⊥) 37 | 38 | -------------------- 39 | 40 | data Freer (Ψ : Effect) : Effect where 41 | return : ∀ {B} -> B -> Freer Ψ B 42 | call : ∀ {A B} -> Ψ A -> (A -> Freer Ψ B) -> Freer Ψ B 43 | 44 | liftᶠ : ∀ {Ψ A} -> Ψ A -> Freer Ψ A 45 | liftᶠ a = call a return 46 | 47 | _>>=_ : ∀ {Ψ B C} -> Freer Ψ B -> (B -> Freer Ψ C) -> Freer Ψ C 48 | return y >>= g = g y 49 | call a f >>= g = call a λ x -> f x >>= g 50 | 51 | _>>_ : ∀ {Ψ B C} -> Freer Ψ B -> Freer Ψ C -> Freer Ψ C 52 | b >> c = b >>= const c 53 | 54 | _<$>_ : ∀ {Ψ B C} -> (B -> C) -> Freer Ψ B -> Freer Ψ C 55 | g <$> b = b >>= return ∘ g 56 | 57 | -------------------- 58 | 59 | record WUnionʰᵉ Φs Ψs A : Set where 60 | constructor wUnionʰᵉ 61 | field unwUnionʰᵉ : Unionʰᵉ Φs Ψs A 62 | 63 | pattern wcall a f = call (wUnionʰᵉ a) f 64 | 65 | EffOver : HigherEffects -> HigherEffect 66 | EffOver Φs Ψs = Freer (WUnionʰᵉ (Unionᵉ ∷ Φs) Ψs) 67 | 68 | inj : ∀ {Ψs Ψ A} -> Ψ ∈ Ψs -> Ψ A -> Unionᵉ Ψs A 69 | inj {[]} () a 70 | inj {Ψ ∷ Ψs} (inj₁ refl) a = inj₁ a 71 | inj {Ψ ∷ Ψs} (inj₂ p) a = inj₂ (inj p a) 72 | 73 | invoke : ∀ {Φs Ψ Ψs A} {{p : Ψ ∈ Ψs}} -> Ψ A -> EffOver Φs Ψs A 74 | invoke {{p}} = liftᶠ ∘ wUnionʰᵉ ∘ inj₁ ∘ inj p 75 | 76 | invoke₀ : ∀ {Φs Ψ Ψs A} -> Ψ A -> EffOver Φs (Ψ ∷ Ψs) A 77 | invoke₀ = invoke 78 | 79 | Eff : HigherEffect 80 | Eff = EffOver [] 81 | -------------------------------------------------------------------------------- /Map.agda: -------------------------------------------------------------------------------- 1 | module Map where 2 | 3 | open import Prelude 4 | 5 | infixl 6 _^_ 6 | 7 | _^_ : ∀ {α} -> Set α -> ℕ -> Set α 8 | A ^ 0 = ⊤ 9 | A ^ suc n = A × A ^ n 10 | 11 | _²^_ : ∀ {α} -> Set α -> ℕ -> Set α 12 | A ²^ n = (A × A) ^ n 13 | 14 | foldr : ∀ {n α β} {A : Set α} 15 | -> (B : ℕ -> Set β) -> (∀ {n} -> A -> B n -> B (suc n)) -> B 0 -> A ^ n -> B n 16 | foldr {0} B f z tt = z 17 | foldr {suc n} B f z (x , xs) = f x (foldr B f z xs) 18 | 19 | head : ∀ {n α} {A : Set α} -> A ^ suc n -> A 20 | head (x , xs) = x 21 | 22 | tail : ∀ {n α} {A : Set α} -> A ^ suc n -> A ^ n 23 | tail (x , xs) = xs 24 | 25 | map : ∀ {n α β} {A : Set α} {B : Set β} -> (A -> B) -> A ^ n -> B ^ n 26 | map f = foldr (_ ^_) (_,_ ∘ f) tt 27 | 28 | _++_ : ∀ {n m α} {A : Set α} -> A ^ n -> A ^ m -> A ^ (n + m) 29 | xs ++ ys = foldr (λ n -> _ ^ (n + _)) _,_ ys xs 30 | 31 | lookup : ∀ {n α} {A : Set α} -> Fin n -> A ^ n -> A 32 | lookup zero (x , xs) = x 33 | lookup (suc i) (x , xs) = lookup i xs 34 | 35 | replace : ∀ {n α} {A : Set α} -> Fin n -> A -> A ^ n -> A ^ n 36 | replace zero y (x , xs) = y , xs 37 | replace (suc i) y (x , xs) = x , replace i y xs 38 | 39 | zipWith : ∀ {n α β γ} {A : Set α} {B : Set β} {C : Set γ} 40 | -> (A -> B -> C) -> A ^ n -> B ^ n -> C ^ n 41 | zipWith {0} f tt tt = tt 42 | zipWith {suc n} f (x , xs) (y , ys) = f x y , zipWith f xs ys 43 | 44 | zip : ∀ {n α β} {A : Set α} {B : Set β} -> A ^ n -> B ^ n -> (A × B) ^ n 45 | zip = zipWith _,_ 46 | 47 | projs₁ : ∀ {n α β} {A : Set α} {B : Set β} -> (A × B) ^ n -> A ^ n 48 | projs₁ = map proj₁ 49 | 50 | _⊔ⁿ_ : ∀ {n} -> Level ^ n -> Level -> Level 51 | _⊔ⁿ_ = flip $ foldr _ _⊔_ 52 | 53 | max : ∀ {n} -> Level ^ n -> Level 54 | max = _⊔ⁿ lzero 55 | 56 | Setsʰ : ∀ α -> ℕ -> Set (lsuc α) 57 | Setsʰ α n = Set α ^ n 58 | 59 | Unionʰ : ∀ {n α} -> Setsʰ α n -> Set α 60 | Unionʰ = foldr _ _⊎_ ⊥ 61 | 62 | Setₛ : ∀ {n} -> (αs : Level ^ n) -> Set _ 63 | Setₛ αs = Set (max αs) 64 | 65 | Setᵐ : ∀ {n α} {A : Set α} -> (k : A -> Level) -> (xs : A ^ n) -> Set _ 66 | Setᵐ k xs = Setₛ (map k xs) 67 | 68 | Map : ∀ {n α} {A : Set α} {k : A -> Level} 69 | -> (∀ x -> Set (k x)) -> (xs : A ^ n) -> Setᵐ k xs 70 | Map {0} B tt = ⊤ 71 | Map {suc n} B (x , xs) = B x × Map B xs 72 | 73 | headᵐ : ∀ {n α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} {xs : A ^ suc n} 74 | -> Map B xs -> B (head xs) 75 | headᵐ (y , ys) = y 76 | 77 | tailᵐ : ∀ {n α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} {xs : A ^ suc n} 78 | -> Map B xs -> Map B (tail xs) 79 | tailᵐ (y , ys) = ys 80 | 81 | foldrᵐ : ∀ {n α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} 82 | {kₛ : ∀ {n} -> A ^ n -> Level} {xs : A ^ n} 83 | -> (C : ∀ {n} -> (xs : A ^ n) -> Set (kₛ xs)) 84 | -> (∀ {n x} {xs : A ^ n} -> B x -> C xs -> C (x , xs)) 85 | -> C {0} _ 86 | -> Map B xs 87 | -> C xs 88 | foldrᵐ {0} B f z tt = z 89 | foldrᵐ {suc n} B f z (y , ys) = f y (foldrᵐ B f z ys) 90 | 91 | homo : ∀ {n α β} {A : Set α} {B : Set β} {xs : A ^ n} -> Map (λ _ -> B) xs -> B ^ n 92 | homo {B = B} = foldrᵐ (λ {n} _ -> B ^ n) _,_ tt 93 | 94 | hetero : ∀ {n α β} {A : Set α} {B : Set β} {xs : A ^ n} -> B ^ n -> Map (λ _ -> B) xs 95 | hetero {0} tt = tt 96 | hetero {suc n} (y , ys) = y , hetero ys 97 | 98 | mapᵐ : ∀ {n α} {A : Set α} {k₀ : A -> Level} {k₁ : A -> Level} 99 | {B : ∀ x -> Set (k₀ x)} {C : ∀ x -> Set (k₁ x)} {xs : A ^ n} 100 | -> (∀ {x} -> B x -> C x) -> Map B xs -> Map C xs 101 | mapᵐ {C = C} f = foldrᵐ (Map C) (_,_ ∘ f) tt 102 | 103 | _++ᵐ_ : ∀ {n m α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} {xs : A ^ n} {ys : A ^ m} 104 | -> Map B xs -> Map B ys -> Map B (xs ++ ys) 105 | yz ++ᵐ zs = foldrᵐ (λ xs -> Map _ (xs ++ _)) _,_ zs yz 106 | 107 | lookupᵐ : ∀ {n α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} {xs : A ^ n} 108 | -> (i : Fin n) -> Map B xs -> B (lookup i xs) 109 | lookupᵐ zero (y , ys) = y 110 | lookupᵐ (suc i) (y , ys) = lookupᵐ i ys 111 | 112 | replaceᵐ : ∀ {n α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} {xs : A ^ n} 113 | -> (i : Fin n) -> B (lookup i xs) -> Map B xs -> Map B xs 114 | replaceᵐ zero y (z , ys) = y , ys 115 | replaceᵐ (suc i) y (z , ys) = z , replaceᵐ i y ys 116 | 117 | Sets : ∀ {n} -> (αs : Level ^ n) -> _ 118 | Sets = Map (λ α -> Set α) 119 | 120 | HList : ∀ {n} {αs : Level ^ n} -> Sets αs -> Setₛ αs 121 | HList = foldrᵐ Setₛ _×_ ⊤ 122 | 123 | headʰ : ∀ n {αs : Level ^ suc n} {As : Sets αs} -> HList As -> headᵐ As 124 | headʰ n (x , xs) = x 125 | 126 | tailʰ : ∀ n {αs : Level ^ suc n} {As : Sets αs} -> HList As -> HList (tailᵐ As) 127 | tailʰ n (x , xs) = xs 128 | 129 | lookupʰ : ∀ {n} {αs : Level ^ n} {As : Sets αs} 130 | -> (i : Fin n) -> HList As -> lookupᵐ i As 131 | lookupʰ zero (x , xs) = x 132 | lookupʰ (suc i) (x , xs) = lookupʰ i xs 133 | 134 | replaceʰ : ∀ {n} {αs : Level ^ n} {As : Sets αs} 135 | -> (i : Fin n) -> lookupᵐ i As -> HList As -> HList As 136 | replaceʰ zero x (y , xs) = x , xs 137 | replaceʰ (suc i) x (y , xs) = y , replaceʰ i x xs 138 | -------------------------------------------------------------------------------- /Prelude.agda: -------------------------------------------------------------------------------- 1 | module Prelude where 2 | 3 | open import Level renaming (zero to lzero; suc to lsuc) public 4 | open import Function renaming (_∘′_ to _∘_; _∘_ to _∘′_) public 5 | open import Relation.Nullary public 6 | open import Relation.Binary.PropositionalEquality hiding ([_]) public 7 | open import Data.Nat.Base hiding (_⊔_; _≟_) public 8 | open import Data.Bool.Base hiding (_≟_) public 9 | open import Data.Fin using (Fin; zero; suc) public 10 | open import Data.Fin.Properties using (_≟_) public 11 | open import Data.Maybe.Base hiding (map) public 12 | open import Data.Sum renaming (map to smap) public 13 | open import Data.Product renaming (map to pmap; zip to pzip) hiding (,_) public 14 | open import Data.List.Base renaming (map to lmap; zip to lzip; zipWith to lzipWith; 15 | foldr to lfoldr; _++_ to _l++_) public 16 | 17 | infix 4 ,_ 18 | infixr 10 _% 19 | infix 3 _≅_ 20 | infixr 5 _<∨>_ 21 | infixl 2 _>>=ₘ_ 22 | infixl 6 _<$>ₘ_ _<*>ₘ_ 23 | 24 | pattern ,_ y = _ , y 25 | 26 | _% = _∘_ 27 | 28 | data ⊥ {α} : Set α where 29 | record ⊤ {α} : Set α where 30 | constructor tt 31 | 32 | ⊥₀ = ⊥ {lzero} 33 | ⊤₀ = ⊤ {lzero} 34 | 35 | ⊥-elim : ∀ {α β} {A : Set α} -> ⊥ {β} -> A 36 | ⊥-elim () 37 | 38 | _<∨>_ : ∀ {α} {B : Bool -> Set α} -> B true -> B false -> ∀ b -> B b 39 | (x <∨> y) true = x 40 | (x <∨> y) false = y 41 | 42 | True : Bool -> Set 43 | True false = ⊥ 44 | True true = ⊤ 45 | 46 | False : Bool -> Set 47 | False = True ∘ not 48 | 49 | if′_then_else_ : ∀ {α} {A : Set α} b -> (True b -> A) -> (False b -> A) -> A 50 | if′ true then f else g = f tt 51 | if′ false then f else g = g tt 52 | 53 | _>>=ₘ_ : ∀ {α β} {A : Set α} {B : Set β} -> Maybe A -> (A -> Maybe B) -> Maybe B 54 | a >>=ₘ f = maybe′ f nothing a 55 | 56 | _<$>ₘ_ : ∀ {α β} {A : Set α} {B : Set β} -> (A -> B) -> Maybe A -> Maybe B 57 | f <$>ₘ a = a >>=ₘ just ∘ f 58 | 59 | _<*>ₘ_ : ∀ {α β} {A : Set α} {B : Set β} -> Maybe (A -> B) -> Maybe A -> Maybe B 60 | h <*>ₘ a = h >>=ₘ _<$>ₘ a 61 | 62 | data _≅_ {α} {A : Set α} (x : A) : ∀ {β} {B : Set β} -> B -> Set where 63 | hrefl : x ≅ x 64 | 65 | hsym : ∀ {α β} {A : Set α} {B : Set β} {x : A} {y : B} -> x ≅ y -> y ≅ x 66 | hsym hrefl = hrefl 67 | 68 | ≅→≡ : ∀ {α} {A : Set α} {x y : A} -> x ≅ y -> x ≡ y 69 | ≅→≡ hrefl = refl 70 | 71 | module TrustMe where 72 | import Relation.Binary.PropositionalEquality.TrustMe as T 73 | 74 | trustMe : ∀ {α} {A : Set α} -> (x y : A) -> x ≡ y 75 | trustMe _ _ = T.trustMe 76 | 77 | Coerce : ∀ {β α} -> Set α -> Set β 78 | Coerce {β} {α} rewrite trustMe α β = id 79 | 80 | uncoerce-cong : ∀ {β α} {A : Set α} -> (F : ∀ {α} -> Set α -> Set α) -> F (Coerce {β} A) -> F A 81 | uncoerce-cong {β} {α} F rewrite trustMe α β = id 82 | 83 | uncoerce : ∀ {β α} {A : Set α} -> Coerce {β} A -> A 84 | uncoerce = uncoerce-cong id 85 | 86 | Coerce-≅→≡ : ∀ {α β} {A : Set α} {B : Set β} -> A ≅ B -> Coerce A ≡ B 87 | Coerce-≅→≡ {α} {β} rewrite trustMe α β = ≅→≡ 88 | 89 | instance 90 | refl-instance : ∀ {α} {A : Set α} {x : A} -> x ≡ x 91 | refl-instance = refl 92 | 93 | hrefl-instance : ∀ {α} {A : Set α} {x : A} -> x ≅ x 94 | hrefl-instance = hrefl 95 | 96 | ,-instance : ∀ {α β} {A : Set α} {B : A -> Set β} {{x : A}} {{y : B x}} -> Σ A B 97 | ,-instance {{x}} {{y}} = x , y 98 | 99 | inj₁-instance : ∀ {α β} {A : Set α} {B : Set β} {{x : A}} -> A ⊎ B 100 | inj₁-instance {{x}} = inj₁ x 101 | 102 | inj₂-instance : ∀ {α β} {A : Set α} {B : Set β} {{x : B}} -> A ⊎ B 103 | inj₂-instance {{y}} = inj₂ y 104 | 105 | first : ∀ {α β γ} {A : Set α} {B : Set β} {C : A -> Set γ} 106 | -> (∀ x -> C x) -> (p : A × B) -> C (proj₁ p) × B 107 | first f (x , y) = f x , y 108 | 109 | second : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : A -> Set γ} 110 | -> (∀ {x} -> B x -> C x) -> Σ A B -> Σ A C 111 | second g (x , y) = x , g y 112 | 113 | third : ∀ {α β γ δ} {A : Set α} {B : A -> Set β} 114 | {C : ∀ {x} -> B x -> Set γ} {D : ∀ {x} -> B x -> Set δ} 115 | -> (∀ {x} {y : B x} -> C y -> D y) -> (∃ λ x -> Σ (B x) C) -> ∃ λ x -> Σ (B x) D 116 | third h (x , y , z) = x , y , h z 117 | 118 | fourth : ∀ {α β γ δ ε} {A : Set α} {B : A -> Set β} {C : ∀ {x} -> B x -> Set γ} 119 | {D : ∀ {x} {y : B x} -> C y -> Set δ} {E : ∀ {x} {y : B x} -> C y -> Set ε} 120 | -> (∀ {x} {y : B x} {z : C y} -> D z -> E z) 121 | -> (∃ λ x -> Σ (B x) λ y -> Σ (C y) D) 122 | -> ∃ λ x -> Σ (B x) λ y -> Σ (C y) E 123 | fourth f (x , y , z , w) = x , y , z , f w 124 | 125 | _[>_<]_ : ∀ {α β γ δ ε} {A : Set α} {B : A -> Set β} 126 | {C : A -> Set γ} {D : ∀ {x} -> B x -> Set δ} 127 | {E : ∀ {x} {y : B x} -> C x -> D y -> Set ε} 128 | -> (f : ∀ x -> C x) 129 | -> (∀ {x y} -> (c : C x) -> (d : D y) -> E c d) 130 | -> (g : ∀ {x} -> (y : B x) -> D y) 131 | -> (p : Σ A B) 132 | -> E (f (proj₁ p)) (g (proj₂ p)) 133 | (f [> h <] g) (x , y) = h (f x) (g y) 134 | 135 | uncurryᵏ : ∀ {α β} {A : Set α} {B : A -> Set β} {k : Σ A B -> Level} {C : ∀ p -> Set (k p)} 136 | -> (∀ x -> (y : B x) -> C (x , y)) -> (p : Σ A B) -> C p 137 | uncurryᵏ f (x , y) = f x y 138 | -------------------------------------------------------------------------------- /Resources.agda: -------------------------------------------------------------------------------- 1 | module Resources where 2 | 3 | open import Prelude public 4 | open import Map public 5 | open import Resources.Core public 6 | open import Resources.Membership public 7 | -------------------------------------------------------------------------------- /Resources/Core.agda: -------------------------------------------------------------------------------- 1 | module Resources.Core where 2 | 3 | open import Prelude 4 | open import Map 5 | open import Lifts 6 | 7 | infixl 2 _>>=_ 8 | infixr 1 _>=>_ 9 | infixr 1 _>>_ 10 | infixl 6 _<$>_ _<*>_ 11 | 12 | Effectful : ∀ {ρ} {R : Set ρ} α ψ -> Set (ρ ⊔ lsuc (α ⊔ ψ)) 13 | Effectful {R = R} α ψ = (A : Set α) -> (A -> R) -> Set ψ 14 | 15 | Effect : ∀ {ρ} (R : Set ρ) α ψ -> Set (ρ ⊔ lsuc (α ⊔ ψ)) 16 | Effect R α ψ = R -> Effectful {R = R} α ψ 17 | 18 | Simple : ∀ α ψ -> Set (lsuc (α ⊔ ψ)) 19 | Simple = Effect ⊤₀ 20 | 21 | effectsˡ : ∀ {n} -> Level ^ n -> Level ²^ n -> Level 22 | effectsˡ ρs αψs = max (zipWith (λ{ ρ (α , ψ) -> ρ ⊔ lsuc (α ⊔ ψ) }) ρs αψs) 23 | 24 | Effects : ∀ {n} {ρs : Level ^ n} -> Sets ρs -> (αψs : Level ²^ n) -> Set (effectsˡ ρs αψs) 25 | Effects {0} tt tt = ⊤ 26 | Effects {suc n} (R , Rs) ((α , ψ) , αψs) = Effect R α ψ × Effects Rs αψs 27 | 28 | lookupᵉ : ∀ {n} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 29 | -> (i : Fin n) 30 | -> Effects Rs αψs 31 | -> Effect (lookupᵐ i Rs) (proj₁ (lookup i αψs)) (proj₂ (lookup i αψs)) 32 | lookupᵉ zero (Ψ , Ψs) = Ψ 33 | lookupᵉ (suc i) (Ψ , Ψs) = lookupᵉ i Ψs 34 | 35 | Resources = HList 36 | 37 | r′ˡ : Level × Level -> Level -> Level 38 | r′ˡ (α , ψ) ρ = α ⊔ ρ 39 | 40 | effˡ : ∀ {n} -> Level ^ n -> Level ²^ n -> Level -> Level 41 | effˡ ρs αψs β = max (map (lsuc ∘ proj₁) αψs) 42 | ⊔ max (zipWith r′ˡ αψs ρs) 43 | ⊔ max (map proj₂ αψs) 44 | ⊔ max (map proj₁ αψs) 45 | ⊔ β 46 | 47 | data Eff {n β} {ρs : Level ^ n} {αψs : Level ²^ n} 48 | {Rs : Sets ρs} (Ψs : Effects Rs αψs) (B : Set β) 49 | : Resources Rs -> (B -> Resources Rs) -> Set (effˡ ρs αψs β) where 50 | return : ∀ {rs′} y -> Eff Ψs B (rs′ y) rs′ 51 | call : ∀ {rs rs′} 52 | -> (i : Fin n) 53 | -> (Lift∃ᵐ (lsuc ∘ proj₁) i αψs λ A -> 54 | Lift∃ᶻ r′ˡ i αψs ρs λ r′ -> 55 | Lift∃ᵐ proj₂ i αψs {lookupᵉ i Ψs (lookupʰ i rs) A r′} λ _ -> 56 | Lift∀ᵐ proj₁ i αψs λ x -> 57 | Eff Ψs B (replaceʰ i (r′ x) rs) rs′) 58 | -> Eff Ψs B rs rs′ 59 | 60 | call′ : ∀ {n β} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 61 | {Ψs : Effects Rs αψs} {B : Set β} {rs rs′} 62 | i {A r′} 63 | -> lookupᵉ i Ψs (lookupʰ i rs) A r′ 64 | -> (∀ x -> Eff Ψs B (replaceʰ i (r′ x) rs) rs′) 65 | -> Eff Ψs B rs rs′ 66 | call′ i a f = call i (lift∃ᵐ i (, lift∃ᶻ i (, lift∃ᵐ i (a , lift∀ᵐ i f)))) 67 | 68 | runLifts : ∀ {n β} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 69 | {Ψs : Effects Rs αψs} {B : Set β} {rs rs′} 70 | i 71 | -> (Lift∃ᵐ (lsuc ∘ proj₁) i αψs λ A -> 72 | Lift∃ᶻ r′ˡ i αψs ρs λ R′ -> 73 | Lift∃ᵐ proj₂ i αψs {lookupᵉ i Ψs (lookupʰ i rs) A R′} λ _ -> 74 | Lift∀ᵐ proj₁ i αψs λ x -> 75 | Eff Ψs B (replaceʰ i (R′ x) rs) rs′) 76 | -> ∃₂ λ A R′ -> lookupᵉ i Ψs (lookupʰ i rs) A R′ 77 | × ∀ x -> Eff Ψs B (replaceʰ i (R′ x) rs) rs′ 78 | runLifts i = second (second (second (lower∀ᵐ i) ∘ lower∃ᵐ i) ∘ lower∃ᶻ i) ∘ lower∃ᵐ i 79 | 80 | runEff : ∀ {β} {B : Set β} -> Eff tt B tt _ -> B 81 | runEff (return y) = y 82 | runEff (call () p) 83 | 84 | invoke# : ∀ {n} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} {Ψs : Effects Rs αψs} {rs} 85 | i {A r′} 86 | -> lookupᵉ i Ψs (lookupʰ i rs) A r′ -> Eff Ψs A rs (λ x -> replaceʰ i (r′ x) rs) 87 | invoke# i a = call′ i a return 88 | 89 | invoke₀ : ∀ {n ρ α ψ} {ρs : Level ^ n} {αψs : Level ²^ n} {R : Set ρ} 90 | {Rs : Sets ρs} {Ψ : Effect R α ψ} {Ψs : Effects Rs αψs} {r A r′ rs} 91 | -> Ψ r A r′ -> Eff (Ψ , Ψs) A (r , rs) (λ x -> r′ x , rs) 92 | invoke₀ = invoke# zero 93 | 94 | {-# TERMINATING #-} 95 | _>>=_ : ∀ {n β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 96 | {Ψs : Effects Rs αψs} {B : Set β} {C : Set γ} {rs rs′ rs′′} 97 | -> Eff Ψs B rs rs′ -> (∀ y -> Eff Ψs C (rs′ y) rs′′) -> Eff Ψs C rs rs′′ 98 | return y >>= g = g y 99 | call i p >>= g = let , , a , f = runLifts i p in call′ i a λ x -> f x >>= g 100 | 101 | _>=>_ : ∀ {n α β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} {Ψs : Effects Rs αψs} 102 | {A : Set α} {B : Set β} {C : Set γ} {rs₁′ : A -> Resources Rs} {rs₂′ rs₃′} 103 | -> (∀ x -> Eff Ψs B (rs₁′ x) rs₂′) 104 | -> (∀ y -> Eff Ψs C (rs₂′ y) rs₃′) 105 | -> (∀ x -> Eff Ψs C (rs₁′ x) rs₃′) 106 | (f >=> g) x = f x >>= g 107 | 108 | _>>_ : ∀ {n β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 109 | {Ψs : Effects Rs αψs} {B : Set β} {C : Set γ} {rs₁ rs₂ rs′′} 110 | -> Eff Ψs B rs₁ (const rs₂) -> Eff Ψs C rs₂ rs′′ -> Eff Ψs C rs₁ rs′′ 111 | b >> c = b >>= const c 112 | 113 | _<$>_ : ∀ {n β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 114 | {Ψs : Effects Rs αψs} {B : Set β} {C : Set γ} {rs₁ rs₂} 115 | -> (B -> C) -> Eff Ψs B rs₁ (const rs₂) -> Eff Ψs C rs₁ (const rs₂) 116 | g <$> b = b >>= return ∘ g 117 | 118 | _<*>_ : ∀ {n β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 119 | {Ψs : Effects Rs αψs} {B : Set β} {C : Set γ} {rs₁ rs₂ rs₃} 120 | -> Eff Ψs (B -> C) rs₁ (const rs₂) -> Eff Ψs B rs₂ (const rs₃) -> Eff Ψs C rs₁ (const rs₃) 121 | d <*> b = d >>= _<$> b 122 | 123 | {-# TERMINATING #-} 124 | shift : ∀ {n α ρ ψ β} {ρs : Level ^ n} {αψs : Level ²^ n} {R : Set ρ} {Rs : Sets ρs} 125 | {Ψ : Effect R α ψ} {r} {Ψs : Effects Rs αψs} {B : Set β} {rs rs′} 126 | -> Eff Ψs B rs rs′ -> Eff (Ψ , Ψs) B (r , rs) (λ y -> r , rs′ y) 127 | shift (return y) = return y 128 | shift (call i p) = let , , a , f = runLifts i p in call′ (suc i) a (shift ∘′ f) 129 | 130 | embed : ∀ {n α ρ ψ} {ρs : Level ^ n} {αψs : Level ²^ n} {R : Set ρ} {Rs : Sets ρs} 131 | {Ψ : Effect R α ψ} {r A r′} {Ψs : Effects Rs αψs} {rs₁ rs₂} 132 | -> Eff Ψs (Ψ r A r′) rs₁ (const rs₂) -> Eff (Ψ , Ψs) A (r , rs₁) (λ x -> r′ x , rs₂) 133 | embed a = shift a >>= invoke₀ 134 | 135 | {-# TERMINATING #-} 136 | runEffM : ∀ {n α} {ρs : Level ^ n} {αψs : Level ²^ n} {M : ∀ {α} -> Set α -> Set α} 137 | {Rs : Sets ρs} {Ψs : Effects Rs αψs} {B : Set α} {rs rs′} 138 | -> (∀ {α} {A : Set α} -> A -> M A) 139 | -> (∀ {α β} {A : Set α} {B : Set β} -> M A -> (A -> M B) -> M B) 140 | -> (∀ i {r A r′} -> lookupᵉ i Ψs r A r′ -> M A) 141 | -> Eff Ψs B rs rs′ 142 | -> M B 143 | runEffM ret bind h (return y) = ret y 144 | runEffM ret bind h (call i p) = let , , a , f = runLifts i p in 145 | bind (h i a) (runEffM ret bind h ∘′ f) 146 | 147 | -- Too weak, just for demonstration purposes. 148 | {-# TERMINATING #-} 149 | execEff : ∀ {n ρ α ψ β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {R : Set ρ} {Rs : Sets ρs} 150 | {Ψ : Effect R α ψ} {Ψs : Effects Rs αψs} {B : Set β} {C : B -> Set γ} {rs rs′} 151 | -> (∀ y -> C y) 152 | -> (∀ {r A r′ rs rs′} -> Ψ r A r′ -> (A -> Eff Ψs (Σ B C) rs rs′) -> Eff Ψs (Σ B C) rs rs′) 153 | -> Eff (Ψ , Ψs) B rs rs′ 154 | -> Eff Ψs (Σ B C) (tailʰ n rs) (tailʰ n ∘ rs′ ∘ proj₁) 155 | execEff h k (return y) = return (y , h y) 156 | execEff h k (call i p) with runLifts i p 157 | ... | , , a , f with i 158 | ... | zero = k a (execEff h k ∘′ f) 159 | ... | suc i' = call′ i' a (execEff h k ∘′ f) 160 | -------------------------------------------------------------------------------- /Resources/Dep.agda: -------------------------------------------------------------------------------- 1 | module Resources.Dep where 2 | 3 | open import Prelude 4 | open import Map 5 | open import Resources.Core 6 | 7 | infixl 1 _↓>>=_ _↑>>=_ 8 | infixl 6 _<$>ᵈ_ 9 | 10 | data _↓>>=_ {n β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 11 | {Ψs : Effects Rs αψs} {B : Set β} {rs rs′} 12 | (b : Eff Ψs B rs rs′) (C : B -> Set γ) : Set (β ⊔ γ) where 13 | call : (∀ y -> C y) -> b ↓>>= C 14 | 15 | Call : ∀ {n β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 16 | {Ψs : Effects Rs αψs} {B : Set β} {rs rs′} {b : Eff Ψs B rs rs′} 17 | -> (B -> Set γ) -> Set (β ⊔ γ) 18 | Call {b = b} C = b ↓>>= C 19 | 20 | ⟨_⟩_ : ∀ {n β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} {B : Set β} {rs rs′} 21 | -> (Ψs : Effects Rs αψs) {b : Eff Ψs B rs rs′} -> (B -> Set γ) -> Set (β ⊔ γ) 22 | ⟨_⟩_ Ψs {b} C = b ↓>>= C 23 | 24 | _↑>>=_ : ∀ {n β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 25 | {Ψs : Effects Rs αψs} {B : Set β} {rs rs′} {C : B -> Set γ} 26 | -> (b : Eff Ψs B rs rs′) -> (∀ y -> C y) -> b ↓>>= C 27 | b ↑>>= g = call g 28 | 29 | execDep : ∀ {n β γ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} {Ψs : Effects Rs αψs} 30 | {B : Set β} {rs rs′} {b : Eff Ψs B rs rs′} {C : B -> Set γ} 31 | -> (run : Eff Ψs B rs rs′ -> B) -> b ↓>>= C -> C (run b) 32 | execDep run (call g) = g _ 33 | 34 | _<$>ᵈ_ : ∀ {n β γ δ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} {Ψs : Effects Rs αψs} 35 | {B : Set β} {rs rs′} {b : Eff Ψs B rs rs′} {C : B -> Set γ} {D : B -> Set δ} 36 | -> (∀ {y} -> C y -> D y) -> b ↓>>= C -> b ↓>>= D 37 | h <$>ᵈ call g = call (h ∘′ g) 38 | 39 | -- _↓>>=_ is a "higher-kinded applicative functor". 40 | _<*>ᵈ_ : ∀ {n β γ δ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} {Ψs : Effects Rs αψs} 41 | {B : Set β} {rs rs′} {b : Eff Ψs B rs rs′} {C : B -> Set γ} {D : B -> Set δ} 42 | -> b ↓>>= (λ y -> C y -> D y) -> b ↓>>= C -> b ↓>>= D 43 | call h <*>ᵈ call g = call (h ˢ g) 44 | -------------------------------------------------------------------------------- /Resources/Effect/Error.agda: -------------------------------------------------------------------------------- 1 | module Resources.Effect.Error where 2 | 3 | open import Resources 4 | 5 | data Error {ε} (E : Set ε) : Effectful lzero ε where 6 | Throw : E -> Error E ⊥ (const E) 7 | 8 | -- TODO: describe why this is bad: 9 | -- data Error {β ε} (E : Set ε) : Effectful β ε where 10 | -- Throw : {B : Set β} -> E -> Error E B (const E) 11 | 12 | throw : ∀ {n β ε} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 13 | {Ψs : Effects Rs αψs} {B : Set β} {E : Set ε} {rs rs′} {{p : Error , E ∈ Ψs , rs}} 14 | -> E -> Eff Ψs B rs rs′ 15 | throw e = invoke (Throw e) >>= ⊥-elim 16 | 17 | self-throw : ∀ {n ε} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 18 | {Ψs : Effects Rs αψs} {E : Set ε} {rs rs′} {{p : Error , E ∈ Ψs , rs}} 19 | -> E -> Eff Ψs E rs rs′ 20 | self-throw = throw 21 | 22 | runError : ∀ {ε} {E : Set ε} -> Error E ⊥ (const E) -> E 23 | runError (Throw e) = e 24 | 25 | {-# TERMINATING #-} 26 | catchError : ∀ {n β ε} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 27 | {Ψs : Effects Rs αψs} {B : Set β} {E : Set ε} {rs rs′} 28 | -> Eff (Error , Ψs) B (E , rs) rs′ 29 | -> (∀ {rs} -> E -> Eff Ψs B rs (tailʰ n ∘ rs′)) 30 | -> Eff Ψs B rs (tailʰ n ∘ rs′) 31 | catchError (return y) h = return y 32 | catchError (call i p) h with runLifts i p 33 | ... | , , a , f with i 34 | ... | suc i' = call′ i' a (flip catchError h ∘′ f) 35 | ... | zero with a 36 | ... | Throw e = h e 37 | 38 | {-# TERMINATING #-} 39 | handleError : ∀ {n β ε ρ α ψ} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 40 | {Ψs : Effects Rs αψs} {B : Set β} {E : Set ε} {rs rs′} 41 | {R : Set ρ} {Ψ : Effect R α ψ} {r} 42 | -> Eff (Error , Ψs) B (E , rs) rs′ 43 | -> (∀ {rs} -> E -> Eff (Ψ , Ψs) B (r , rs) (λ y -> r , tailʰ n (rs′ y))) 44 | -> Eff (Ψ , Ψs) B (r , rs) (λ y -> r , tailʰ n (rs′ y)) 45 | handleError (return y) h = return y 46 | handleError (call i p) h with runLifts i p 47 | ... | , , a , f with i 48 | ... | suc i' = call′ (suc i') a (flip handleError h ∘′ f) 49 | ... | zero with a 50 | ... | Throw e = h e 51 | -------------------------------------------------------------------------------- /Resources/Effect/LiftM.agda: -------------------------------------------------------------------------------- 1 | module Resources.Effect.LiftM where 2 | 3 | open import Resources 4 | 5 | data Lift[_] {α β} (M : Set α -> Set β) : Simple α (lsuc α ⊔ β) where 6 | LiftM : ∀ {A} -> M A -> Lift[ M ] tt A _ 7 | 8 | liftM : ∀ {n α β} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 9 | {Ψs : Effects Rs αψs} {A : Set α} {rs} 10 | -> (M : Set α -> Set β) {{p : Lift[ M ] , tt ∈ Ψs , rs}} -> M A -> Eff Ψs A rs _ 11 | liftM M = invoke ∘ LiftM 12 | -------------------------------------------------------------------------------- /Resources/Effect/State.agda: -------------------------------------------------------------------------------- 1 | module Resources.Effect.State where 2 | 3 | open import Resources 4 | 5 | data State {α} (A : Set α) : Effectful α (lsuc α) where 6 | Get : State A A (const A) 7 | Put : ∀ {B} -> B -> State A ⊤ (const B) 8 | 9 | get : ∀ {n α} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 10 | {Ψs : Effects Rs αψs} {rs} {A : Set α} {{p : State , A ∈ Ψs , rs}} 11 | -> Eff Ψs A rs _ 12 | get = invoke Get 13 | 14 | zap : ∀ {n α} {ρs : Level ^ n} {αψs : Level ²^ n} 15 | {Rs : Sets ρs} {Ψs : Effects Rs αψs} {rs} 16 | (A {B} : Set α) {{p : State , A ∈ Ψs , rs}} 17 | -> B -> Eff Ψs ⊤ rs _ 18 | zap _ {{p}} = invoke′ {{p}} ∘ Put 19 | 20 | -- It may seem we can define `put' as (put = zap _), but we can't. 21 | -- That would change the value behind the wildcard. 22 | put : ∀ {n α} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 23 | {Ψs : Effects Rs αψs} {rs} {A : Set α} {{p : State , A ∈ Ψs , rs}} 24 | -> A -> Eff Ψs ⊤ rs _ 25 | put = invoke ∘ Put 26 | 27 | {-# TERMINATING #-} 28 | execState : ∀ {n α β} {ρs : Level ^ n} {αψs : Level ²^ n} {A : Set α} 29 | {Rs : Sets ρs} {Ψs : Effects Rs αψs} {B : Set β} {rs rs′} 30 | -> A 31 | -> Eff (State , Ψs) B (A , rs) rs′ 32 | -> Eff Ψs (Σ B (headʰ n ∘ rs′)) rs (tailʰ n ∘ rs′ ∘ proj₁) 33 | execState s (return y) = return (y , s) 34 | execState s (call i p) with runLifts i p 35 | ... | , , a , f with i 36 | ... | suc i' = call′ i' a (execState s ∘′ f) 37 | ... | zero with a 38 | ... | Get = execState s (f s) 39 | ... | Put s' = execState s' (f tt) 40 | -------------------------------------------------------------------------------- /Resources/Effect/Writer.agda: -------------------------------------------------------------------------------- 1 | module Resources.Effect.Writer where 2 | 3 | open import Resources 4 | 5 | data Writer {α} (A : Set α) : Effectful α α where 6 | Tell : A -> Writer A ⊤ (const A) 7 | 8 | tell : ∀ {n α} {ρs : Level ^ n} {αψs : Level ²^ n} {Rs : Sets ρs} 9 | {Ψs : Effects Rs αψs} {rs} {A : Set α} {{p : Writer , A ∈ Ψs , rs}} 10 | -> A -> Eff Ψs ⊤ rs _ 11 | tell = invoke ∘ Tell 12 | 13 | {-# TERMINATING #-} 14 | execWriter : ∀ {n α β} {ρs : Level ^ n} {αψs : Level ²^ n} {A : Set α} 15 | {Rs : Sets ρs} {Ψs : Effects Rs αψs} {B : Set β} {rs rs′} 16 | -> Eff (Writer , Ψs) B (A , rs) rs′ 17 | -> Eff Ψs (B × List A) rs (tailʰ n ∘ rs′ ∘ proj₁) 18 | execWriter (return y) = return (y , []) 19 | execWriter (call i p) with runLifts i p 20 | ... | , , a , f with i 21 | ... | suc i' = call′ i' a (execWriter ∘′ f) 22 | ... | zero with a 23 | ... | Tell x = execWriter (f tt) >>= return ∘′ second (x ∷_) 24 | -------------------------------------------------------------------------------- /Resources/Membership.agda: -------------------------------------------------------------------------------- 1 | module Resources.Membership where 2 | 3 | open import Prelude 4 | open import Map 5 | open import Resources.Core 6 | 7 | infix 3 _∈_ 8 | 9 | open TrustMe 10 | 11 | private 12 | Subst : ∀ {α₁ α₂ ψ₁ ψ₂ ρ} {R : Set ρ} {A : Set α₁} {r f} 13 | {Ψ₁ : Effect R α₁ ψ₁} {Ψ₂ : Effect R α₂ ψ₂} 14 | -> Ψ₁ ≅ Ψ₂ 15 | -> Ψ₁ r A f 16 | -> Ψ₂ r (Coerce A) (f ∘ uncoerce) 17 | Subst {α₁} {α₂} {ψ₁} {ψ₂} p rewrite trustMe α₁ α₂ | trustMe ψ₁ ψ₂ = subst (λ F -> F _ _ _) (≅→≡ p) 18 | 19 | _∈_ : ∀ {n ρ α ψ} {ρs : Level ^ n} {αψs : Level ²^ n} {R : Set ρ} {Rs : Sets ρs} 20 | -> Effect R α ψ × R -> Effects Rs αψs × Resources Rs -> Set 21 | _∈_ {0} (Φ , s) ( tt , tt) = ⊥ 22 | _∈_ {suc n} (Φ , s) ((Ψ , Ψs) , (r , rs)) = Φ ≅ Ψ × s ≅ r ⊎ Φ , s ∈ Ψs , rs 23 | 24 | ∈→Fin : ∀ {n ρ α ψ} {ρs : Level ^ n} {αψs : Level ²^ n} {R : Set ρ} {Rs : Sets ρs} 25 | {Ψr : Effect R α ψ × R} {Ψrs : Effects Rs αψs × Resources Rs} 26 | -> Ψr ∈ Ψrs -> Fin n 27 | ∈→Fin {0} () 28 | ∈→Fin {suc n} (inj₁ _) = zero 29 | ∈→Fin {suc n} (inj₂ p) = suc (∈→Fin p) 30 | 31 | coerce : ∀ {n ρ α ψ} {ρs : Level ^ n} {αψs : Level ²^ n} {R : Set ρ} 32 | {Rs : Sets ρs} {r rs} {Ψ : Effect R α ψ} {Ψs : Effects Rs αψs} 33 | -> (p : Ψ , r ∈ Ψs , rs) -> R -> lookupᵐ (∈→Fin p) Rs 34 | coerce {0} () r 35 | coerce {suc n} (inj₁ (_ , hrefl)) r = r 36 | coerce {suc n} (inj₂ p) r = coerce p r 37 | 38 | invoke′ : ∀ {n ρ α ψ} {ρs : Level ^ n} {αψs : Level ²^ n} 39 | {R : Set ρ} {Ψ : Effect R α ψ} {Rs : Sets ρs} 40 | {r A r′ rs} {Ψs : Effects Rs αψs} {{p : Ψ , r ∈ Ψs , rs}} 41 | -> Ψ r A r′ -> Eff Ψs A rs (λ x -> replaceʰ (∈→Fin p) (coerce p (r′ x)) rs) 42 | invoke′ {0} {{()}} a 43 | invoke′ {suc n} {{inj₁ (q , hrefl)}} a = call′ zero (Subst q a) (return ∘′ uncoerce) 44 | invoke′ {suc n} {{inj₂ p}} a = shift (invoke′ a) 45 | 46 | invoke : ∀ {n ρ α ψ} {ρs : Level ^ n} {αψs : Level ²^ n} {R : Set ρ} {Ψ : Effect R α ψ} 47 | {Rs : Sets ρs} {r A rs} {Ψs : Effects Rs αψs} {{p : Ψ , r ∈ Ψs , rs}} 48 | -> Ψ r A (const r) -> Eff Ψs A rs (const rs) 49 | invoke {0} {{()}} a 50 | invoke {suc n} {{inj₁ (q , hrefl)}} a = call′ zero (Subst q a) (return ∘ uncoerce) 51 | invoke {suc n} {{inj₂ p}} a = shift (invoke a) 52 | 53 | unfold-lookupᵐ : ∀ {n ρ α ψ} {ρs : Level ^ n} {αψs : Level ²^ n} {R : Set ρ} 54 | {Rs : Sets ρs} {Ψ : Effect R α ψ} {Ψs : Effects Rs αψs} {r rs} 55 | -> (p : Ψ , r ∈ Ψs , rs) -> R -> lookupᵐ (∈→Fin p) Rs 56 | unfold-lookupᵐ {0} () r 57 | unfold-lookupᵐ {suc n} (inj₁ (q , hrefl)) r = r 58 | unfold-lookupᵐ {suc n} (inj₂ p) r = unfold-lookupᵐ p r 59 | 60 | unfold-lookupᵉ : ∀ {n ρ α ψ} {ρs : Level ^ n} {αψs : Level ²^ n} {R : Set ρ} 61 | {Rs : Sets ρs} {Ψ : Effect R α ψ} {Ψs : Effects Rs αψs} {r rs} 62 | -> ∀ (p : Ψ , r ∈ Ψs , rs) {A r′} 63 | -> Ψ r A r′ 64 | -> lookupᵉ (∈→Fin p) 65 | Ψs 66 | (lookupʰ (∈→Fin p) rs) (Coerce A) 67 | (unfold-lookupᵐ p ∘ r′ ∘ uncoerce) 68 | unfold-lookupᵉ {0} () a 69 | unfold-lookupᵉ {suc n} (inj₁ (q , hrefl)) a = Subst q a 70 | unfold-lookupᵉ {suc n} (inj₂ p) a = unfold-lookupᵉ p a 71 | -------------------------------------------------------------------------------- /Simple.agda: -------------------------------------------------------------------------------- 1 | module Simple where 2 | 3 | open import Prelude public 4 | open import Map public 5 | open import Simple.Core public 6 | open import Simple.Membership public 7 | -------------------------------------------------------------------------------- /Simple/Core.agda: -------------------------------------------------------------------------------- 1 | module Simple.Core where 2 | 3 | open import Prelude 4 | open import Map 5 | open import Lifts 6 | 7 | infixl 2 _>>=_ 8 | infixr 1 _>>_ 9 | infixl 6 _<$>_ _<*>_ 10 | 11 | Effect : ∀ α ψ -> Set (lsuc (α ⊔ ψ)) 12 | Effect α ψ = Set α -> Set ψ 13 | 14 | Effects : ∀ {n} -> (αψs : Level ²^ n) -> Set _ 15 | Effects = Map (uncurryᵏ Effect) 16 | 17 | effˡ : ∀ {n} -> Level ²^ n -> Level -> Level 18 | effˡ αψs β = max (map (lsuc ∘ proj₁) αψs) 19 | ⊔ max (map proj₂ αψs) 20 | ⊔ max (map proj₁ αψs) 21 | ⊔ β 22 | 23 | data Eff {n β} {αψs : Level ²^ n} (Ψs : Effects αψs) (B : Set β) : Set (effˡ αψs β) where 24 | return : B -> Eff Ψs B 25 | call : ∀ i 26 | -> (Lift∃ᵐ (lsuc ∘ proj₁) i αψs λ A -> 27 | Lift∃ᵐ proj₂ i αψs {lookupᵐ i Ψs A} λ _ -> 28 | Lift∀ᵐ proj₁ i αψs {A} λ _ -> 29 | Eff Ψs B) 30 | -> Eff Ψs B 31 | 32 | call′ : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} 33 | i {A} 34 | -> lookupᵐ i Ψs A -> (A -> Eff Ψs B) -> Eff Ψs B 35 | call′ i a f = call i (lift∃ᵐ i (, lift∃ᵐ i (a , lift∀ᵐ i f))) 36 | 37 | runLifts : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} 38 | i 39 | -> (Lift∃ᵐ (lsuc ∘ proj₁) i αψs λ A -> 40 | Lift∃ᵐ proj₂ i αψs {lookupᵐ i Ψs A} λ _ -> 41 | Lift∀ᵐ proj₁ i αψs {A} λ _ -> 42 | Eff Ψs B) 43 | -> ∃ λ A -> lookupᵐ i Ψs A × (A -> Eff Ψs B) 44 | runLifts i = second (second (lower∀ᵐ i) ∘ lower∃ᵐ i) ∘ lower∃ᵐ i 45 | 46 | runEff : ∀ {β} {B : Set β} -> Eff tt B -> B 47 | runEff (return y) = y 48 | runEff (call () p) 49 | 50 | invoke# : ∀ {n} {αψs : Level ²^ n} {Ψs : Effects αψs} 51 | -> ∀ i {A} -> lookupᵐ i Ψs A -> Eff Ψs A 52 | invoke# i a = call′ i a return 53 | 54 | {-# TERMINATING #-} 55 | _>>=_ : ∀ {n β γ} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} {C : Set γ} 56 | -> Eff Ψs B -> (B -> Eff Ψs C) -> Eff Ψs C 57 | return y >>= g = g y 58 | call i p >>= g = let , a , f = runLifts i p in call′ i a λ x -> f x >>= g 59 | 60 | _>>_ : ∀ {n β γ} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} {C : Set γ} 61 | -> Eff Ψs B -> Eff Ψs C -> Eff Ψs C 62 | b >> c = b >>= const c 63 | 64 | _<$>_ : ∀ {n β γ} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} {C : Set γ} 65 | -> (B -> C) -> Eff Ψs B -> Eff Ψs C 66 | g <$> b = b >>= return ∘ g 67 | 68 | _<*>_ : ∀ {n β γ} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} {C : Set γ} 69 | -> Eff Ψs (B -> C) -> Eff Ψs B -> Eff Ψs C 70 | d <*> b = d >>= _<$> b 71 | 72 | {-# TERMINATING #-} 73 | shift : ∀ {n α ψ β} {αψs : Level ²^ n} {Ψ : Effect α ψ} {Ψs : Effects αψs} {B : Set β} 74 | -> Eff Ψs B -> Eff (Ψ , Ψs) B 75 | shift (return y) = return y 76 | shift (call i p) = let , a , f = runLifts i p in call′ (suc i) a (shift ∘ f) 77 | 78 | {-# TERMINATING #-} 79 | execEff : ∀ {n α ψ β γ} {αψs : Level ²^ n} {Ψ : Effect α ψ} 80 | {Ψs : Effects αψs} {B : Set β} {C : Set γ} 81 | -> (B -> Eff Ψs C) 82 | -> (∀ {A} -> Ψ A -> (A -> Eff Ψs C) -> Eff Ψs C) 83 | -> Eff (Ψ , Ψs) B 84 | -> Eff Ψs C 85 | execEff ret k (return y) = ret y 86 | execEff ret k (call i p) with runLifts i p 87 | ... | , a , f with i 88 | ... | zero = k a (execEff ret k ∘ f) 89 | ... | suc i' = call′ i' a (execEff ret k ∘ f) 90 | -------------------------------------------------------------------------------- /Simple/Effect/Error.agda: -------------------------------------------------------------------------------- 1 | module Simple.Effect.Error where 2 | 3 | open import Simple 4 | 5 | data Error {ε} (E : Set ε) : ∀ {β} -> Set β -> Set ε where 6 | Throw : ∀ {β} {B : Set β} -> E -> Error E B 7 | 8 | throw : ∀ {n ε β} {αψs : Level ²^ n} {Ψs : Effects αψs} 9 | {B : Set β} {E : Set ε} {{p : Error E ∈ Ψs}} 10 | -> E -> Eff Ψs B 11 | throw = invoke ∘ Throw 12 | 13 | runError : ∀ {ε β} {E : Set ε} {B : Set β} -> Error E B -> E 14 | runError (Throw e) = e 15 | 16 | catch : ∀ {n ε β} {αψs : Level ²^ n} {Ψs : Effects αψs} 17 | {B : Set β} {E : Set ε} {{p : Error E {β} ∈ Ψs}} 18 | -> Eff Ψs B -> (E -> Eff Ψs B) -> Eff Ψs B 19 | catch {{p}} b h = procEff {{p}} return (const ∘ h ∘ runError) b 20 | 21 | execError : ∀ {n ε β} {αψs : Level ²^ n} {Ψs : Effects αψs} {E : Set ε} {B : Set β} 22 | -> Eff (Error E {β} , Ψs) B -> Eff Ψs (E ⊎ B) 23 | execError = execEff (return ∘ inj₂) (const ∘ return ∘ inj₁ ∘ runError) 24 | 25 | catchError : ∀ {n ε β} {αψs : Level ²^ n} {Ψs : Effects αψs} {E : Set ε} {B : Set β} 26 | -> Eff (Error E {β} , Ψs) B -> (E -> Eff Ψs B) -> Eff Ψs B 27 | catchError b h = execEff return (const ∘ h ∘ runError) b 28 | -------------------------------------------------------------------------------- /Simple/Effect/NonDet.agda: -------------------------------------------------------------------------------- 1 | module Simple.Effect.NonDet where 2 | 3 | open import Simple 4 | 5 | LBool : ∀ {α} -> Set α 6 | LBool = Lift Bool 7 | 8 | lfalse : ∀ {α} -> LBool {α} 9 | lfalse = lift false 10 | 11 | ltrue : ∀ {α} -> LBool {α} 12 | ltrue = lift true 13 | 14 | data NonDet {α} : Effect α α where 15 | MZero : ∀ {A} -> NonDet A 16 | MPlus : NonDet LBool 17 | 18 | ⟨⟩ : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} {{p : NonDet ∈ Ψs}} 19 | -> Eff Ψs B 20 | ⟨⟩ = invoke MZero 21 | 22 | _<>_ : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} {{p : NonDet {β} ∈ Ψs}} 23 | -> Eff Ψs B -> Eff Ψs B -> Eff Ψs B 24 | m₁ <> m₂ = invoke MPlus >>= (m₁ <∨> m₂) ∘ lower 25 | 26 | execNonDet : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} 27 | -> Eff (NonDet {β} , Ψs) B -> Eff Ψs (List B) 28 | execNonDet {Ψs = Ψs} {B} = execEff (return ∘ [_]) k where 29 | k : ∀ {A} -> NonDet A -> (A -> Eff Ψs (List B)) -> Eff Ψs (List B) 30 | k MZero f = return [] 31 | k MPlus f = _l++_ <$> f ltrue <*> f lfalse 32 | 33 | dguard : ∀ {n α β} {αψs : Level ²^ n} {A : Set α} {Ψs : Effects αψs} {{p : NonDet {β} ∈ Ψs}} 34 | -> Dec A -> Eff Ψs (⊤ {β}) 35 | dguard (yes _) = return tt 36 | dguard (no _) = ⟨⟩ 37 | 38 | msum : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} {{p : NonDet {β} ∈ Ψs}} 39 | -> List (Eff Ψs B) -> Eff Ψs B 40 | msum = lfoldr _<>_ ⟨⟩ 41 | 42 | {-# TERMINATING #-} 43 | mutual 44 | msplit : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} {{p : NonDet {β} ∈ Ψs}} 45 | -> Eff Ψs B -> Eff Ψs (Maybe (B × Eff Ψs B)) 46 | msplit {Ψs = Ψs} {B} {{p}} = procEff {{p}} (λ y -> return (just (y , ⟨⟩))) k where 47 | k : ∀ {A} -> NonDet A -> (A -> Eff Ψs B) -> Eff Ψs (Maybe (B × Eff Ψs B)) 48 | k MZero f = return nothing 49 | k MPlus f = rec-msplit (return ∘ just ∘ second (_<> f ltrue)) (msplit (f ltrue)) (f lfalse) 50 | 51 | rec-msplit : ∀ {n β γ} {αψs : Level ²^ n} {Ψs : Effects αψs} 52 | {B : Set β} {C : Set γ} {{p : NonDet {β} ∈ Ψs}} 53 | -> (B × Eff Ψs B -> Eff Ψs C) -> Eff Ψs C -> Eff Ψs B -> Eff Ψs C 54 | rec-msplit g c b = msplit b >>= maybe′ g c 55 | 56 | {-# TERMINATING #-} 57 | interleave : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B : Set β} {{p : NonDet {β} ∈ Ψs}} 58 | -> Eff Ψs B -> Eff Ψs B -> Eff Ψs B 59 | interleave b₁ b₂ = rec-msplit (return [> _<>_ <] interleave b₂) b₂ b₁ 60 | 61 | -- `B' and `C' are in the same universe, because `NonDet' is instantiated to `β'. 62 | -- Should we consider something like (PolyEffect = ∀ {α} -> Set α -> Set α)? 63 | -- Probably not due to the untypeability of this expression. 64 | {-# TERMINATING #-} 65 | _>>-_ : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B C : Set β} {{p : NonDet {β} ∈ Ψs}} 66 | -> Eff Ψs B -> (B -> Eff Ψs C) -> Eff Ψs C 67 | b >>- g = rec-msplit (g [> interleave <] (_>>- g)) ⟨⟩ b 68 | 69 | ifte : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B C : Set β} {{p : NonDet {β} ∈ Ψs}} 70 | -> Eff Ψs B -> (B -> Eff Ψs C) -> Eff Ψs C -> Eff Ψs C 71 | ifte b g c = rec-msplit (g [> _<>_ <] (_>>= g)) c b 72 | 73 | once : ∀ {n β} {αψs : Level ²^ n} {Ψs : Effects αψs} {B C : Set β} {{p : NonDet {β} ∈ Ψs}} 74 | -> Eff Ψs B -> Eff Ψs B 75 | once = rec-msplit (return ∘ proj₁) ⟨⟩ 76 | -------------------------------------------------------------------------------- /Simple/Membership.agda: -------------------------------------------------------------------------------- 1 | module Simple.Membership where 2 | 3 | open import Prelude 4 | open import Map 5 | open import Simple.Core 6 | 7 | infix 3 _∈_ 8 | 9 | open TrustMe 10 | 11 | private 12 | Subst : ∀ {α₁ α₂ β₁ β₂} {A : Set α₁} {F₁ : Set α₁ -> Set β₁} {F₂ : Set α₂ -> Set β₂} 13 | -> F₁ ≅ F₂ -> F₁ A -> F₂ (Coerce A) 14 | Subst {α₁} {α₂} {β₁} {β₂} p rewrite trustMe α₁ α₂ | trustMe β₁ β₂ = subst (_$ _) (≅→≡ p) 15 | 16 | _∈_ : ∀ {n α ψ} {αψs : Level ²^ n} -> Effect α ψ -> Effects αψs -> Set 17 | _∈_ {0} Φ tt = ⊥ 18 | _∈_ {suc n} Φ (Ψ , Ψs) = Φ ≅ Ψ ⊎ Φ ∈ Ψs 19 | 20 | ∈→Fin : ∀ {n α ψ} {αψs : Level ²^ n} {Ψ : Effect α ψ} {Ψs : Effects αψs} -> Ψ ∈ Ψs -> Fin n 21 | ∈→Fin {0} () 22 | ∈→Fin {suc n} (inj₁ _) = zero 23 | ∈→Fin {suc n} (inj₂ p) = suc (∈→Fin p) 24 | 25 | -- ((Set α₁ -> Set β₁) ≅ (Set α₂ -> Set β₂)) doesn't imply (α₁ ≡ α₂). 26 | -- ∈→ˡ≡ : ∀ {n α ψ} {αψs : Level ²^ n} {Ψ : Effect α ψ} {Ψs : Effects αψs} 27 | -- -> (p : Ψ ∈ Ψs) -> α ≡ proj₁ (lookup (∈→Fin p) αψs) 28 | -- ∈→ˡ≡ {0} () 29 | -- ∈→ˡ≡ {suc n} (inj₁ q) = {!!} 30 | -- ∈→ˡ≡ {suc n} (inj₂ p) = ∈→ˡ≡ p 31 | 32 | fold-lookupᵐ : ∀ {n α ψ} {αψs : Level ²^ n} {Ψ : Effect α ψ} {Ψs : Effects αψs} 33 | -> ∀ (p : Ψ ∈ Ψs) {A} -> lookupᵐ (∈→Fin p) Ψs A -> Ψ (Coerce A) 34 | fold-lookupᵐ {0} () a 35 | fold-lookupᵐ {suc n} (inj₁ q) a = Subst (hsym q) a 36 | fold-lookupᵐ {suc n} (inj₂ p) a = fold-lookupᵐ p a 37 | 38 | unfold-lookupᵐ : ∀ {n α ψ} {αψs : Level ²^ n} {Ψ : Effect α ψ} {Ψs : Effects αψs} 39 | -> ∀ (p : Ψ ∈ Ψs) {A} -> Ψ A -> lookupᵐ (∈→Fin p) Ψs (Coerce A) 40 | unfold-lookupᵐ {0} () a 41 | unfold-lookupᵐ {suc n} (inj₁ q) a = Subst q a 42 | unfold-lookupᵐ {suc n} (inj₂ p) a = unfold-lookupᵐ p a 43 | 44 | proj : ∀ {n α ψ} {αψs : Level ²^ n} {Ψ : Effect α ψ} {Ψs : Effects αψs} 45 | -> ∀ i (p : Ψ ∈ Ψs) {A} -> lookupᵐ i Ψs A -> Maybe (Ψ (Coerce A)) 46 | proj i p a with i ≟ ∈→Fin p 47 | ... | yes r rewrite r = just (fold-lookupᵐ p a) 48 | ... | no _ = nothing 49 | 50 | invoke : ∀ {n α ψ} {αψs : Level ²^ n} {Ψ : Effect α ψ} {A} {Ψs : Effects αψs} {{p : Ψ ∈ Ψs}} 51 | -> Ψ A -> Eff Ψs A 52 | invoke {{p}} a = uncoerce <$> call′ (∈→Fin p) (unfold-lookupᵐ p a) return 53 | 54 | -- Alternatively. 55 | -- invoke : ∀ {n α ψ} {αψs : Level ²^ n} {Ψ : Effect α ψ} {A} {Ψs : Effects αψs} {{p : Ψ ∈ Ψs}} 56 | -- -> Ψ A -> Eff Ψs A 57 | -- invoke {0} {{()}} a 58 | -- invoke {suc n} {{inj₁ q}} a = call′ zero (Subst q a) (return ∘ uncoerce) 59 | -- invoke {suc n} {{inj₂ p}} a = shift (invoke a) 60 | 61 | {-# TERMINATING #-} 62 | procEff : ∀ {n α ψ β γ} {αψs : Level ²^ n} {Ψ : Effect α ψ} 63 | {Ψs : Effects αψs} {B : Set β} {C : Set γ} {{q : Ψ ∈ Ψs}} 64 | -> (B -> Eff Ψs C) 65 | -> (∀ {A} -> Ψ A -> (A -> Eff Ψs B) -> Eff Ψs C) 66 | -> Eff Ψs B 67 | -> Eff Ψs C 68 | procEff ret k (return y) = ret y 69 | procEff {{q}} ret k (call i p) with runLifts i p 70 | ... | , a , f with proj i q a 71 | ... | nothing = call′ i a (procEff ret k ∘ f) 72 | ... | just ca = k ca (f ∘ uncoerce) 73 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # Eff 2 | 3 | Most of the code is about constructing a fully universe polymorphic effect system in Agda. It's unreadable as always with generic universe polymorphic stuff. 4 | 5 | `Loop.Core` is the most readable version as it enables `--type-in-type`, so I'll describe its content rather than the content of `Resources.Core`, which is properly universe polymorphic and less powerful ("for historical reasons"). 6 | 7 | Effects are represented like in the Idris [Effects](https://github.com/edwinb/Eff-dev/blob/master/effects/Effects.idr) library, but resources are values rather than types: 8 | 9 | ``` 10 | Effect : Set -> Set 11 | Effect R = R -> (A : Set) -> (A -> R) -> Set 12 | ``` 13 | 14 | Instead of defining `Eff` directly, we define the indexed version of the Oleg Kiselyov's [`Freer`](http://okmij.org/ftp/Haskell/extensible/more.pdf) monad, which is an effect transformer: 15 | 16 | ``` 17 | data IFreer {R : Set} (Ψ : Effect R) : Effect R where 18 | return : ∀ {B r′} y -> IFreer Ψ (r′ y) B r′ 19 | call : ∀ {r A r′ B r′′} -> Ψ r A r′ -> (∀ x -> IFreer Ψ (r′ x) B r′′) -> IFreer Ψ r B r′′ 20 | ``` 21 | 22 | As well as `Eff` in Idris it's a Hoare state monad (HST in [Verifying Higher-order Programs with the Dijkstra Monad](http://research.microsoft.com/en-us/um/people/nswamy/papers/dijkstra-submitted-pldi13.pdf)) as witnessed by 23 | 24 | ``` 25 | _>>=_ : ∀ {R Ψ r B r′ C r′′} 26 | -> IFreer {R} Ψ r B r′ -> (∀ y -> IFreer Ψ (r′ y) C r′′) -> IFreer Ψ r C r′′ 27 | return y >>= g = g y 28 | call a f >>= g = call a λ x -> f x >>= g 29 | ``` 30 | 31 | We also have higher effects which operate on lists of simple effects and transform heterogeneous lists of resources: 32 | 33 | ``` 34 | Resources = HList 35 | 36 | Effects : Sets -> Set 37 | Effects = List₁ Effect 38 | 39 | HigherEffect : Set 40 | HigherEffect = ∀ {Rs} -> Effects Rs -> Effect (Resources Rs) 41 | ``` 42 | 43 | The union of a list of effects is a higher effect: 44 | 45 | ``` 46 | data Unionᵉ : HigherEffect where 47 | hereᵉ : ∀ {R Rs r A r′ rs} {Ψ : Effect R} {Ψs : Effects Rs} 48 | -> Ψ r A r′ -> Unionᵉ (Ψ , Ψs) (r , rs) A (λ x -> r′ x , rs) 49 | thereᵉ : ∀ {R Rs r A rs rs′} {Ψ : Effect R} {Ψs : Effects Rs} 50 | -> Unionᵉ Ψs rs A rs′ -> Unionᵉ (Ψ , Ψs) (r , rs) A (λ x -> r , rs′ x) 51 | ``` 52 | 53 | `Unionʰᵉ` unions a list of higher effects: 54 | 55 | ``` 56 | data Unionʰᵉ : HigherEffects -> HigherEffect where 57 | hereʰᵉ : ∀ {Φs Rs rs A rs′} {Φ : HigherEffect} {Ψs : Effects Rs} 58 | -> Φ {Rs} Ψs rs A rs′ -> Unionʰᵉ (Φ ∷ Φs) Ψs rs A rs′ 59 | thereʰᵉ : ∀ {Φs Rs rs A rs′} {Φ : HigherEffect} {Ψs : Effects Rs} 60 | -> Unionʰᵉ Φs Ψs rs A rs′ -> Unionʰᵉ (Φ ∷ Φs) Ψs rs A rs′ 61 | ``` 62 | 63 | Here is the main definition: 64 | 65 | ``` 66 | EffOver : HigherEffects -> HigherEffect 67 | EffOver Φs Ψs = IFreer (Unionʰᵉ (Unionᵉ ∷ Φs) Ψs) 68 | ``` 69 | 70 | `EffOver` describes computations over a list of higher effects `Φs` and a list of simple effects `Ψs`. 71 | 72 | The usual `Eff` is recovered by 73 | 74 | ``` 75 | Eff : HigherEffect 76 | Eff = EffOver [] 77 | ``` 78 | 79 | I.e. no higher effects except for the union of simple effects. 80 | 81 | So while a computation can't change the set of effects like in Idris, it can change the resources. A canonical example is the indexed `State`: 82 | 83 | ``` 84 | test : Eff (State , tt) (ℕ , tt) ℕ (λ n -> V.Vec Bool n , tt) 85 | test = get >>= λ n -> put (V.replicate true) >> return n 86 | ``` 87 | 88 | (`put` is `zap ℕ` actually, because instance search needs an additional hint in this case) 89 | 90 | So we start from `State ℕ` and get `State (Vec Bool n)`, where `n` comes from `State ℕ`. 91 | 92 | We can run this computation: 93 | 94 | ``` 95 | test-test : runEff (execState 3 test) ≡ (3 , true ∷ true ∷ true ∷ []) 96 | test-test = refl 97 | ``` 98 | 99 | There is also an effectful [tic-tac-toe](https://github.com/effectfully/Eff/blob/master/Examples/Resources/TicTacToe/UnsafeGame.agda) game that [compiles](https://github.com/effectfully/Eff/blob/master/Examples/Resources/TicTacToe/Main.agda). --------------------------------------------------------------------------------