├── .circleci └── config.yml ├── .gitignore ├── LICENSE ├── MANIFEST ├── Makefile ├── README.md └── src ├── .gitignore ├── ANF.agda ├── Aexamples.agda ├── Async.agda ├── Channel.agda ├── DSession.agda ├── DSyntax.agda ├── Examples.agda ├── Global.agda ├── ProcessRun.agda ├── ProcessSyntax.agda ├── Progress.agda ├── Properties.agda ├── Properties ├── Base.agda ├── StepBeta.agda ├── StepCloseWait.agda ├── StepFork.agda ├── StepNew.agda └── StepPair.agda ├── Run.agda ├── Schedule.agda ├── Session.agda ├── Syntax.agda ├── Typing.agda └── Values.agda /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | docker: 5 | - image: terrorjack/pixie 6 | 7 | steps: 8 | - run: 9 | name: Initialize nix environment 10 | command: | 11 | nix-channel --add https://nixos.org/channels/nixpkgs-unstable && nix-channel --update 12 | nix-env -iA nixpkgs.haskellPackages.Agda nixpkgs.gitMinimal nixpkgs.openssh 13 | agda --version 14 | - checkout 15 | 16 | # - run: 17 | # name: Install Agda 18 | # command: | 19 | # stack --resolver nightly install alex cpphs happy Agda 20 | # agda --version 21 | # no_output_timeout: 1.2h 22 | 23 | - run: 24 | name: Install the Agda Standard lib 25 | command: | 26 | git clone https://github.com/agda/agda-stdlib.git ~/agda-stdlib/ 27 | mkdir ~/.agda 28 | echo "~/agda-stdlib/standard-library.agda-lib" >> ~/.agda/libraries 29 | echo "standard-library" >> ~/.agda/defaults 30 | - run: 31 | name: Build the development 32 | working_directory: src 33 | command: agda Schedule.agda 34 | - run: 35 | name: Build the examples 36 | working_directory: src 37 | command: agda Examples.agda 38 | 39 | # workflows: 40 | # version: 2 41 | # build_and_test: 42 | # jobs: 43 | # - build 44 | # - test 45 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2018, Peter Thiemann 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | README.md 2 | src/Session.agda 3 | src/Properties.agda 4 | src/Channel.agda 5 | src/Examples.agda 6 | src/ProcessRun.agda 7 | src/DSession.agda 8 | src/ANF.agda 9 | src/ProcessSyntax.agda 10 | src/DSyntax.agda 11 | src/Async.agda 12 | src/Aexamples.agda 13 | src/Properties/StepBeta.agda 14 | src/Properties/StepNew.agda 15 | src/Properties/StepPair.agda 16 | src/Properties/StepFork.agda 17 | src/Properties/Base.agda 18 | src/Properties/StepCloseWait.agda 19 | src/Schedule.agda 20 | src/Progress.agda 21 | src/Global.agda 22 | src/Run.agda 23 | src/Syntax.agda 24 | src/Values.agda 25 | src/Typing.agda 26 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | FILES = $(shell cat MANIFEST) 2 | 3 | AgdaSession.tgz: $(FILES) 4 | tar cvfz $@ $(FILES) 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Intrisically-Typed Small-Step Semantics for a Functional Language with Session Types # 2 | 3 | This repository contains the Agda implementation. It compiles with 4 | Agda 2.5.4.2 and works with the standard library version 0.13. 5 | The development is structured in several modules and may be read in the following order. 6 | 7 | * `Typing.agda` types, session types, equivalence, subtyping, duality, along with some lemmas 8 | * `Syntax.agda` typed expressions (A normal form), some auxiliary lemmas 9 | * `Global.agda` session contexts, splitting, inactive, (very technical) splitting lemmas 10 | * `Channel.agda` valid channel references, several versions of vcr-match for different rendezvous 11 | * `Values.agda` values, environments, and auxiliary lemmas 12 | * `Session.agda` continuations, commands, interpreter for expressions `run`, lifting, thread pools, several matchWait functions 13 | * `Schedule.agda` step function and interpreter for thread pools `schedule`, **main entry point** `start` 14 | 15 | Furthermore, there are some auxiliary modules. 16 | 17 | * `DSyntax.agda` syntax in direct style 18 | * `ANF.agda` transformer from direct style DSyntax to Syntax 19 | * `Examples.agda` several example programs exercising progressively difficult features 20 | * `Run.agda` running a couple of examples (**very** inefficient) 21 | * `ProcessSyntax.agda` typed syntax for process terms 22 | * `ProcessRun.agda` definitions to run a process term + many auxiliary lemmas 23 | * `Async.agda` definitions for asynchronous session types and 24 | operations thereon 25 | * `Aexample.agda` examples using asynchronous channels 26 | -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /src/ANF.agda: -------------------------------------------------------------------------------- 1 | module ANF where 2 | 3 | open import Data.List 4 | open import Data.List.All 5 | 6 | open import Typing 7 | open import DSyntax 8 | open import Syntax 9 | 10 | -- transform a direct style expression into and anf expression 11 | 12 | anf : ∀ {φ t} → DExpr φ t → Expr φ t 13 | anf (var x) = var x 14 | anf (nat unr-φ i) = nat unr-φ i 15 | anf (unit unr-φ) = unit unr-φ 16 | anf (pair sp de de₁) = letbind sp (anf de) (letbind (rght (split-all-left _)) (anf de₁) (pair (rght (left [])) (here []) (here []))) 17 | anf (letpair sp de de₁) = letbind sp (anf de) (letpair (left (split-all-right _)) (here []) (anf de₁)) 18 | anf (fork de) = fork (anf de) 19 | anf (new unr-φ s) = new unr-φ s 20 | anf (send sp de de₁) = letbind sp (anf de) (letbind (rght (split-all-left _)) (anf de₁) (send (rght (left [])) (here []) (here []))) 21 | anf (recv de) = letbind (split-all-left _) (anf de) (recv (here [])) 22 | anf (close de) = letbind (split-all-left _) (anf de) (close (here [])) 23 | anf (wait de) = letbind (split-all-left _) (anf de) (wait (here [])) 24 | anf (select lab de) = letbind (split-all-left _) (anf de) (select lab (here [])) 25 | anf (branch sp de de₁ de₂) = letbind sp (anf de) (branch (left (split-all-right _)) (here []) (anf de₁) (anf de₂)) 26 | anf (ulambda unr-φ de) = ulambda (split-all-left _) unr-φ [] (anf de) 27 | anf (llambda de) = llambda (split-all-left _) [] (anf de) 28 | anf (app sp de de₁) = letbind sp (anf de) (letbind (rght (split-all-left _)) (anf de₁) (app (rght (left [])) (here []) (here []))) 29 | anf (subsume de t≤t') = subsume (anf de) t≤t' 30 | -------------------------------------------------------------------------------- /src/Aexamples.agda: -------------------------------------------------------------------------------- 1 | module Aexamples where 2 | 3 | open import Data.List hiding (reverse) 4 | open import Data.List.All 5 | open import Data.Nat 6 | 7 | open import Typing 8 | open import Syntax 9 | open import Async 10 | 11 | {- 12 | Lithmus test for asynchronous operations 13 | A thread send something to an asynchronous channel and receives it afterwards. 14 | -} 15 | aex1 : Expr [] TUnit 16 | aex1 = letbind [] (anew [] (delay send!)) 17 | (letpair (left []) (here []) 18 | (letbind (left (rght [])) (aclose (here [])) 19 | (await (there UUnit (here []))))) 20 | 21 | -- just replace synchronous operations by the asynchronous ones 22 | asyncex1 : Expr [] TUnit 23 | asyncex1 = 24 | letbind [] (anew [] (delay send!)) 25 | (letpair (left []) (here []) 26 | (letbind (rght (left [])) 27 | (fork (await (here []))) 28 | (aclose (there UUnit (here []))))) 29 | 30 | -- sending and receiving 31 | asyncex2 : Expr [] TUnit 32 | asyncex2 = 33 | letbind [] (anew [] (delay (send TInt (delay send!)))) 34 | (letpair (left []) (here []) 35 | (letbind (left (rght [])) 36 | (fork (letbind (rght []) (nat [] 42) 37 | (letbind (left (left [])) (asend (rght (left [])) (here []) (here [])) 38 | (letbind (left []) (aclose (here [])) 39 | (var (here [])))))) 40 | (letbind (rght (left [])) (arecv (here [])) 41 | (letpair (left (rght [])) (here []) 42 | (letbind (left (left (rght []))) (await (here (UInt ∷ []))) 43 | (var (here (UUnit ∷ [])))))))) 44 | -------------------------------------------------------------------------------- /src/Async.agda: -------------------------------------------------------------------------------- 1 | module Async where 2 | 3 | open import Data.Fin 4 | open import Data.List hiding (drop) 5 | open import Data.List.All 6 | 7 | open import Typing renaming (send to ssend ; recv to srecv) 8 | open import Syntax 9 | open import Values 10 | 11 | -- an asynchronous channel is a promise for a channel 12 | ASession DSession : STypeF SType → STypeF SType 13 | ASession s = srecv (TChan s) (delay send!) 14 | DSession s = dualF (ASession s) 15 | 16 | AChan DChan : STypeF SType → Type 17 | AChan s = TChan (ASession s) 18 | DChan s = TChan (DSession s) 19 | 20 | Promise : (s : SType) → Type 21 | Promise s = TPair (AChan (SType.force s)) (DChan (SType.force s)) 22 | 23 | new-promise : ∀ {Φ} → All Unr Φ → (s : SType) → Expr Φ (Promise s) 24 | new-promise unr-Φ s = new unr-Φ (delay (ASession (SType.force s))) 25 | 26 | -- create an async channel 27 | anew : ∀ {Φ} 28 | → (unr-Φ : All Unr Φ) 29 | → (s : SType) 30 | → Expr Φ (TPair (AChan (SType.force s)) (AChan (SType.force (dual s)))) 31 | anew unr-Φ s = 32 | letbind (split-all-unr unr-Φ) (new unr-Φ s) 33 | (letpair (left (split-all-unr unr-Φ)) (here unr-Φ) 34 | (letbind (rght (rght (split-all-unr unr-Φ))) (new-promise unr-Φ s) 35 | (letpair (left (rght (rght (split-all-unr unr-Φ)))) (here unr-Φ) 36 | (letbind (rght (rght (rght (rght (split-all-unr unr-Φ))))) (new-promise unr-Φ (dual s)) 37 | (letpair (left (rght (rght (rght (rght (split-all-unr unr-Φ)))))) (here unr-Φ) 38 | (letbind (rght (rght (rght (left (left (rght (split-all-unr unr-Φ))))))) 39 | (fork (letbind (left (left (split-all-unr unr-Φ))) (send (left (rght (split-all-unr unr-Φ))) (here unr-Φ) (here unr-Φ)) 40 | (wait (here unr-Φ)))) 41 | (letbind (drop UUnit (rght (left (rght (left (split-all-unr unr-Φ)))))) 42 | (fork (letbind (left (left (split-all-unr unr-Φ))) (send (left (rght (split-all-unr unr-Φ))) (here unr-Φ) (here unr-Φ)) 43 | (wait (here unr-Φ)))) 44 | (pair (drop UUnit (rght (left (split-all-unr unr-Φ)))) 45 | (here unr-Φ) (here unr-Φ))))))))) 46 | 47 | asend : ∀ {Φ Φ₁ Φ₂ s t} 48 | → (sp : Split Φ Φ₁ Φ₂) 49 | → (ch : (AChan (ssend t s)) ∈ Φ₁) 50 | → (vt : t ∈ Φ₂) 51 | → Expr Φ (AChan (SType.force s)) 52 | asend {Φ} {s = s} sp ch vt = 53 | letbind (split-all-right Φ) (new-promise [] s) 54 | (letpair (left (split-all-right Φ)) (here []) 55 | (letbind (rght (left (split-all-left Φ))) 56 | -- read actual channel & actual send & send depleted channel & close 57 | (fork (letbind (rght sp) (recv ch) 58 | (letpair (left (split-all-right _)) (here []) 59 | (letbind (left (split-all-right _)) (close (here [])) 60 | (letbind (drop UUnit (left (rght (split-all-left _)))) (send (left (split-all-right _)) (here []) vt) 61 | (letbind (left (left [])) (send (rght (left [])) (here []) (here [])) 62 | (letbind (left []) (wait (here [])) 63 | (var (here []))))))))) 64 | (var (there UUnit (here []))))) 65 | 66 | -- receive is a blocking operation! 67 | arecv : ∀ {Φ s t} 68 | → (ch : (AChan (srecv t s)) ∈ Φ) 69 | → Expr Φ (TPair (AChan (SType.force s)) t) 70 | arecv {s = s} ch = 71 | letbind (split-all-right _) (new-promise [] s) 72 | (letpair (left (split-all-right _)) (here []) 73 | (letbind (rght (rght (split-all-left _))) (recv ch) 74 | (letpair (left (rght (rght (split-all-right _)))) (here []) 75 | (letbind (left (rght (rght (rght [])))) (close (here [])) 76 | (letbind (drop UUnit (left (rght (rght [])))) (recv (here [])) 77 | (letpair (left (rght (rght []))) (here []) 78 | (letbind (left (rght (rght (left [])))) 79 | (fork (letbind (left (left [])) 80 | (send (rght (left [])) (here []) (here [])) 81 | (wait (here [])))) 82 | (pair (drop UUnit (rght (left []))) (here []) (here []))))))))) 83 | 84 | aclose : ∀ {Φ} 85 | → (ch : AChan send! ∈ Φ) 86 | → Expr Φ TUnit 87 | aclose ch = 88 | fork (letbind (split-all-left _) (recv ch) 89 | (letpair (left []) (here []) 90 | (letbind (left (rght [])) (close (here [])) 91 | (close (there UUnit (here [])))))) 92 | 93 | await : ∀ {Φ} 94 | → (ch : AChan send? ∈ Φ) 95 | → Expr Φ TUnit 96 | await ch = 97 | fork (letbind (split-all-left _) (recv ch) 98 | (letpair (left []) (here []) 99 | (letbind (left (rght [])) (close (here [])) 100 | (wait (there UUnit (here [])))))) 101 | 102 | anselect : ∀ {Φ m alt} 103 | → (lab : Fin m) 104 | → (ch : AChan (sintN m alt) ∈ Φ) 105 | → Expr Φ (AChan (SType.force (alt lab))) 106 | anselect {alt = alt} lab ch = 107 | letbind (split-all-right _) 108 | (new-promise [] (alt lab)) 109 | (letpair (left (split-all-right _)) (here []) 110 | (letbind (rght (left (split-all-left _))) 111 | (fork (letbind (rght (split-all-left _)) (recv ch) 112 | (letpair (left (rght [])) (here []) 113 | (letbind (left (rght (rght []))) (close (here [])) 114 | (letbind (drop UUnit (left (rght []))) (nselect lab (here [])) 115 | (letbind (left (left [])) (send (rght (left [])) (here []) (here [])) 116 | (wait (here [])))))))) 117 | (var (there UUnit (here []))))) 118 | 119 | -- branching is a blocking operation! 120 | anbranch : ∀ {Φ m alt Φ₁ Φ₂ t} 121 | → (sp : Split Φ Φ₁ Φ₂) 122 | → (ch : AChan (sextN m alt) ∈ Φ₁) 123 | → (ealts : (i : Fin m) → Expr (AChan (SType.force (alt i)) ∷ Φ₂) t) 124 | → Expr Φ t 125 | anbranch{alt = alt} sp ch ealts = 126 | letbind sp (recv ch) 127 | (letpair (left (split-all-right _)) (here []) 128 | (letbind (left (split-all-right _)) (close (here [])) 129 | (nbranch (drop UUnit (left (split-all-right _))) (here []) 130 | (λ i → letbind (split-all-right _) (new-promise [] (alt i)) 131 | (letpair (left (split-all-right _)) (here []) 132 | (letbind (rght (left (left (split-all-right _)))) 133 | (fork (letbind (left (left [])) (send (left (rght [])) (here []) (here [])) 134 | (wait (here [])))) 135 | (letbind (drop UUnit (left (split-all-right _))) (var (here [])) 136 | (ealts i)))))))) 137 | 138 | -------------------------------------------------------------------------------- /src/Channel.agda: -------------------------------------------------------------------------------- 1 | module Channel where 2 | 3 | open import Data.Bool hiding (_≤_) 4 | open import Data.Fin hiding (_≤_) 5 | open import Data.List hiding (map) 6 | open import Data.Maybe 7 | open import Data.Nat 8 | open import Data.Nat.Properties 9 | open import Data.Product hiding (map) 10 | open import Relation.Binary.PropositionalEquality 11 | 12 | open import Typing 13 | open import Syntax hiding (send ; recv) 14 | open import Global 15 | 16 | 17 | data ChannelEnd : Set where 18 | POS NEG : ChannelEnd 19 | 20 | otherEnd : ChannelEnd → ChannelEnd 21 | otherEnd POS = NEG 22 | otherEnd NEG = POS 23 | 24 | -- the main part of a channel endpoint value is a valid channel reference 25 | -- the channel end determines whether it's the front end or the back end of the channel 26 | -- enforces that the session context has only one channel 27 | data ChannelRef : (G : SCtx) (ce : ChannelEnd) (s : STypeF SType) → Set where 28 | here-pos : ∀ {s s'} {G : SCtx} 29 | → (ina-G : Inactive G) 30 | → s ≲' s' 31 | → ChannelRef (just (s , POS) ∷ G) POS s' 32 | here-neg : ∀ {s s'} {G : SCtx} 33 | → (ina-G : Inactive G) 34 | → dualF s ≲' s' 35 | → ChannelRef (just (s , NEG) ∷ G) NEG s' 36 | there : ∀ {b s} {G : SCtx} 37 | → (vcr : ChannelRef G b s) 38 | → ChannelRef (nothing ∷ G) b s 39 | 40 | -- coerce channel ref to a supertype 41 | vcr-coerce : ∀ {G b s s'} → ChannelRef G b s → s ≲' s' → ChannelRef G b s' 42 | vcr-coerce (here-pos ina-G x) s≤s' = here-pos ina-G (subF-trans x s≤s') 43 | vcr-coerce (here-neg ina-G x) s≤s' = here-neg ina-G (subF-trans x s≤s') 44 | vcr-coerce (there vcr) s≤s' = there (vcr-coerce vcr s≤s') 45 | 46 | -- find matching wait instruction in thread pool 47 | vcr-match : ∀ {G G₁ G₂ b₁ b₂ s₁ s₂} 48 | → SSplit G G₁ G₂ 49 | → ChannelRef G₁ b₁ s₁ 50 | → ChannelRef G₂ b₂ s₂ 51 | → Maybe (b₁ ≡ otherEnd b₂ × dualF s₂ ≲' s₁) 52 | vcr-match () (here-pos _ _) (here-pos _ _) 53 | vcr-match (ss-posneg ss) (here-pos{s} ina-G s<=s') (here-neg ina-G₁ ds<=s'') = just (refl , subF-trans (dual-subF ds<=s'') (subF-trans (eqF-implies-subF (eqF-sym (dual-involutionF s))) s<=s')) 54 | vcr-match (ss-left ss) (here-pos _ _) (there vcr2) = nothing 55 | vcr-match (ss-negpos ss) (here-neg ina-G ds<=s') (here-pos ina-G₁ s<=s'') = just (refl , subF-trans (dual-subF s<=s'') ds<=s') 56 | vcr-match (ss-left ss) (here-neg _ _) (there vcr2) = nothing 57 | vcr-match (ss-right ss) (there vcr1) (here-pos _ ina-G) = nothing 58 | vcr-match (ss-right ss) (there vcr1) (here-neg _ ina-G) = nothing 59 | vcr-match (ss-both ss) (there vcr1) (there vcr2) = vcr-match ss vcr1 vcr2 60 | 61 | -- ok. brute force for a fixed tree with three levels 62 | data SSplit2 (G G₁ G₂ G₁₁ G₁₂ : SCtx) : Set where 63 | ssplit2 : 64 | (ss1 : SSplit G G₁ G₂) 65 | → (ss2 : SSplit G₁ G₁₁ G₁₂) 66 | → SSplit2 G G₁ G₂ G₁₁ G₁₂ 67 | 68 | vcr-match-2-sr : ∀ {G G₁ G₂ G₁₁ G₁₂ b₁ b₂ s₁ s₂ t₁ t₂} 69 | → SSplit2 G G₁ G₂ G₁₁ G₁₂ 70 | → ChannelRef G₁₁ b₁ (recv t₁ s₁) 71 | → ChannelRef G₁₂ b₂ (send t₂ s₂) 72 | → Maybe (SubT t₂ t₁ × dual s₂ ≲ s₁ × 73 | ∃ λ G' → ∃ λ G₁' → ∃ λ G₁₁' → ∃ λ G₁₂' → 74 | SSplit2 G' G₁' G₂ G₁₁' G₁₂' × 75 | ChannelRef G₁₁' b₁ (SType.force s₁) × 76 | ChannelRef G₁₂' b₂ (SType.force s₂)) 77 | vcr-match-2-sr (ssplit2 ss-[] ()) (here-pos ina-G x) (here-pos ina-G₁ x₁) 78 | vcr-match-2-sr (ssplit2 (ss-both ss1) ()) (here-pos ina-G x) (here-pos ina-G₁ x₁) 79 | vcr-match-2-sr (ssplit2 (ss-left ss1) ()) (here-pos ina-G x) (here-pos ina-G₁ x₁) 80 | vcr-match-2-sr (ssplit2 (ss-right ss1) ()) (here-pos ina-G x) (here-pos ina-G₁ x₁) 81 | vcr-match-2-sr (ssplit2 (ss-posneg ss1) ()) (here-pos ina-G x) (here-pos ina-G₁ x₁) 82 | vcr-match-2-sr (ssplit2 (ss-negpos ss1) ()) (here-pos ina-G x) (here-pos ina-G₁ x₁) 83 | vcr-match-2-sr (ssplit2 ss-[] ()) (here-pos ina-G x) (here-neg ina-G₁ x₁) 84 | vcr-match-2-sr (ssplit2 (ss-both ss1) ()) (here-pos ina-G x) (here-neg ina-G₁ x₁) 85 | vcr-match-2-sr (ssplit2 (ss-left ss1) (ss-posneg ss2)) (here-pos ina-G (sub-recv{s1} t t' t<=t' s1<=s1')) (here-neg ina-G₁ (sub-send .t t'' t'<=t s1<=s1'')) = just ((subt-trans t'<=t t<=t') , (sub-trans (dual-sub s1<=s1'') (sub-trans (eq-implies-sub (eq-sym (dual-involution s1))) s1<=s1')) , _ , _ , _ , _ , ssplit2 (ss-left ss1) (ss-posneg ss2) , here-pos ina-G (Sub.force s1<=s1') , here-neg ina-G₁ (Sub.force s1<=s1'')) 86 | vcr-match-2-sr (ssplit2 (ss-right ss1) ()) (here-pos ina-G x) (here-neg ina-G₁ x₁) 87 | vcr-match-2-sr (ssplit2 (ss-posneg ss1) ()) (here-pos ina-G x) (here-neg ina-G₁ x₁) 88 | vcr-match-2-sr (ssplit2 (ss-negpos ss1) ()) (here-pos ina-G x) (here-neg ina-G₁ x₁) 89 | vcr-match-2-sr (ssplit2 ss-[] ()) (here-pos ina-G x) (there vcr2) 90 | vcr-match-2-sr (ssplit2 (ss-both ss1) ()) (here-pos ina-G x) (there vcr2) 91 | vcr-match-2-sr (ssplit2 (ss-left ss1) (ss-left ss2)) (here-pos ina-G x) (there vcr2) = nothing 92 | vcr-match-2-sr (ssplit2 (ss-right ss1) ()) (here-pos ina-G x) (there vcr2) 93 | vcr-match-2-sr (ssplit2 (ss-posneg ss1) (ss-left ss2)) (here-pos ina-G x) (there vcr2) = nothing 94 | vcr-match-2-sr (ssplit2 (ss-negpos ss1) ()) (here-pos ina-G x) (there vcr2) 95 | vcr-match-2-sr (ssplit2 ss-[] ()) (here-neg ina-G x) (here-pos ina-G₁ x₁) 96 | vcr-match-2-sr (ssplit2 (ss-both ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ x₁) 97 | vcr-match-2-sr {s₁ = s₁} {s₂} (ssplit2 (ss-left ss1) (ss-negpos ss2)) (here-neg ina-G (sub-recv .t t'' t<=t' s1<=s1'')) (here-pos ina-G₁ (sub-send t t' t'<=t s1<=s1')) = just ((subt-trans t'<=t t<=t') , ((sub-trans (dual-sub s1<=s1') s1<=s1'') , (_ , (_ , (_ , (_ , ((ssplit2 (ss-left ss1) (ss-negpos ss2)) , ((here-neg ina-G (Sub.force s1<=s1'')) , (here-pos ina-G₁ (Sub.force s1<=s1')))))))))) 98 | vcr-match-2-sr (ssplit2 (ss-right ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ x₁) 99 | vcr-match-2-sr (ssplit2 (ss-posneg ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ x₁) 100 | vcr-match-2-sr (ssplit2 (ss-negpos ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ x₁) 101 | vcr-match-2-sr (ssplit2 ss-[] ()) (here-neg ina-G x) (here-neg ina-G₁ x₁) 102 | vcr-match-2-sr (ssplit2 (ss-both ss1) ()) (here-neg ina-G x) (here-neg ina-G₁ x₁) 103 | vcr-match-2-sr (ssplit2 (ss-right ss1) ()) (here-neg ina-G x) (here-neg ina-G₁ x₁) 104 | vcr-match-2-sr (ssplit2 (ss-posneg ss1) ()) (here-neg ina-G x) (here-neg ina-G₁ x₁) 105 | vcr-match-2-sr (ssplit2 (ss-negpos ss1) ()) (here-neg ina-G x) (here-neg ina-G₁ x₁) 106 | vcr-match-2-sr (ssplit2 ss-[] ()) (here-neg ina-G x) (there vcr2) 107 | vcr-match-2-sr (ssplit2 (ss-both ss1) ()) (here-neg ina-G x) (there vcr2) 108 | vcr-match-2-sr (ssplit2 (ss-left ss1) (ss-left ss2)) (here-neg ina-G x) (there vcr2) = nothing 109 | vcr-match-2-sr (ssplit2 (ss-right ss1) ()) (here-neg ina-G x) (there vcr2) 110 | vcr-match-2-sr (ssplit2 (ss-posneg ss1) ()) (here-neg ina-G x) (there vcr2) 111 | vcr-match-2-sr (ssplit2 (ss-negpos ss1) (ss-left ss2)) (here-neg ina-G x) (there vcr2) = nothing 112 | vcr-match-2-sr (ssplit2 ss-[] ()) (there vcr1) (here-pos ina-G x) 113 | vcr-match-2-sr (ssplit2 (ss-both ss1) ()) (there vcr1) (here-pos ina-G x) 114 | vcr-match-2-sr (ssplit2 (ss-left ss1) (ss-right ss2)) (there vcr1) (here-pos ina-G x) = nothing 115 | vcr-match-2-sr (ssplit2 (ss-right ss1) ()) (there vcr1) (here-pos ina-G x) 116 | vcr-match-2-sr (ssplit2 (ss-posneg ss1) (ss-right ss2)) (there vcr1) (here-pos ina-G x) = nothing 117 | vcr-match-2-sr (ssplit2 (ss-negpos ss1) ()) (there vcr1) (here-pos ina-G x) 118 | vcr-match-2-sr (ssplit2 ss-[] ()) (there vcr1) (here-neg ina-G x) 119 | vcr-match-2-sr (ssplit2 (ss-both ss1) ()) (there vcr1) (here-neg ina-G x) 120 | vcr-match-2-sr (ssplit2 (ss-left ss1) (ss-right ss2)) (there vcr1) (here-neg ina-G x) = nothing 121 | vcr-match-2-sr (ssplit2 (ss-right ss1) ()) (there vcr1) (here-neg ina-G x) 122 | vcr-match-2-sr (ssplit2 (ss-negpos ss1) (ss-right ss2)) (there vcr1) (here-neg ina-G x) = nothing 123 | vcr-match-2-sr (ssplit2 ss-[] ()) (there vcr1) (there vcr2) 124 | vcr-match-2-sr (ssplit2 (ss-both ss1) (ss-both ss2)) (there vcr1) (there vcr2) with vcr-match-2-sr (ssplit2 ss1 ss2) vcr1 vcr2 125 | ... | nothing = nothing 126 | ... | just (t2<=t1 , ds2<=s1 , _ , _ , _ , _ , ssplit2 ss1' ss2' , vcr1' , vcr2') = just (t2<=t1 , ds2<=s1 , _ , _ , _ , _ , (ssplit2 (ss-both ss1') (ss-both ss2')) , ((there vcr1') , (there vcr2'))) 127 | vcr-match-2-sr (ssplit2 (ss-right ss1) (ss-both ss2)) (there vcr1) (there vcr2) = map (λ { (t2<=t1 , ds2<=s1 , _ , _ , _ , _ , ssplit2 ss1' ss2' , vcr1' , vcr2') → t2<=t1 , ds2<=s1 , _ , _ , _ , _ , (ssplit2 (ss-right ss1') (ss-both ss2')) , (there vcr1') , (there vcr2') }) (vcr-match-2-sr (ssplit2 ss1 ss2) vcr1 vcr2) 128 | vcr-match-2-sr (ssplit2 (ss-negpos ss1) ()) (there vcr1) (there vcr2) 129 | 130 | 131 | vcr-match-2-sb : ∀ {G G₁ G₂ G₁₁ G₁₂ b₁ b₂ s₁₁ s₁₂ s₂₁ s₂₂} 132 | → SSplit2 G G₁ G₂ G₁₁ G₁₂ 133 | → ChannelRef G₁₁ b₁ (sintern s₁₁ s₁₂) 134 | → ChannelRef G₁₂ b₂ (sextern s₂₁ s₂₂) 135 | → (lab : Selector) 136 | → Maybe (dual s₂₁ ≲ s₁₁ × dual s₂₂ ≲ s₁₂ × 137 | ∃ λ G' → ∃ λ G₁' → ∃ λ G₁₁' → ∃ λ G₁₂' → 138 | SSplit2 G' G₁' G₂ G₁₁' G₁₂' × 139 | ChannelRef G₁₁' b₁ (selection lab (SType.force s₁₁) (SType.force s₁₂)) × 140 | ChannelRef G₁₂' b₂ (selection lab (SType.force s₂₁) (SType.force s₂₂))) 141 | vcr-match-2-sb (ssplit2 ss1 ss2) (here-pos ina-G (sub-sintern s1<=s1' s2<=s2')) (here-pos ina-G₁ (sub-sextern s1<=s1'' s2<=s2'')) lab = nothing 142 | vcr-match-2-sb (ssplit2 ss-[] ()) (here-pos ina-G (sub-sintern s1<=s1' s2<=s2')) (here-neg ina-G₁ x₁) lab 143 | vcr-match-2-sb (ssplit2 (ss-both ss1) ()) (here-pos ina-G (sub-sintern s1<=s1' s2<=s2')) (here-neg ina-G₁ x₁) lab 144 | vcr-match-2-sb (ssplit2 (ss-left ss1) (ss-posneg ss2)) (here-pos ina-G (sub-sintern s1<=s1' s2<=s2')) (here-neg ina-G₁ (sub-sextern s1<=s1'' s2<=s2'')) Left = just ((sub-trans (dual-sub s1<=s1'') (sub-trans (eq-implies-sub (eq-sym (dual-involution _))) s1<=s1')) , (sub-trans (dual-sub s2<=s2'') (sub-trans (eq-implies-sub (eq-sym (dual-involution _))) s2<=s2')) , _ , _ , _ , _ , (ssplit2 (ss-left ss1) (ss-posneg ss2)) , (here-pos ina-G (Sub.force s1<=s1')) , (here-neg ina-G₁ (Sub.force s1<=s1''))) 145 | vcr-match-2-sb (ssplit2 (ss-left ss1) (ss-posneg ss2)) (here-pos ina-G (sub-sintern s1<=s1' s2<=s2')) (here-neg ina-G₁ (sub-sextern s1<=s1'' s2<=s2'')) Right = just ((sub-trans (dual-sub s1<=s1'') (sub-trans (eq-implies-sub (eq-sym (dual-involution _))) s1<=s1')) , (sub-trans (dual-sub s2<=s2'') (sub-trans (eq-implies-sub (eq-sym (dual-involution _))) s2<=s2')) , _ , _ , _ , _ , (ssplit2 (ss-left ss1) (ss-posneg ss2)) , (here-pos ina-G (Sub.force s2<=s2')) , (here-neg ina-G₁ (Sub.force s2<=s2''))) 146 | vcr-match-2-sb (ssplit2 (ss-right ss1) ()) (here-pos ina-G (sub-sintern s1<=s1' s2<=s2')) (here-neg ina-G₁ x₁) lab 147 | vcr-match-2-sb (ssplit2 (ss-posneg ss1) ()) (here-pos ina-G (sub-sintern s1<=s1' s2<=s2')) (here-neg ina-G₁ x₁) lab 148 | vcr-match-2-sb (ssplit2 (ss-negpos ss1) ()) (here-pos ina-G (sub-sintern s1<=s1' s2<=s2')) (here-neg ina-G₁ x₁) lab 149 | vcr-match-2-sb (ssplit2 ss1 ss2) (here-pos ina-G x) (there vcr2) lab = nothing 150 | vcr-match-2-sb (ssplit2 ss-[] ()) (here-neg ina-G x) (here-pos ina-G₁ (sub-sextern s1<=s1' s2<=s2')) lab 151 | vcr-match-2-sb (ssplit2 (ss-both ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ (sub-sextern s1<=s1' s2<=s2')) lab 152 | vcr-match-2-sb (ssplit2 (ss-left ss1) (ss-negpos ss2)) (here-neg ina-G (sub-sintern s1<=s1'' s2<=s2'')) (here-pos ina-G₁ (sub-sextern s1<=s1' s2<=s2')) Left = just ((sub-trans (dual-sub s1<=s1') s1<=s1'') , ((sub-trans (dual-sub s2<=s2') s2<=s2'') , (_ , (_ , (_ , (_ , ((ssplit2 (ss-left ss1) (ss-negpos ss2)) , ((here-neg ina-G (Sub.force s1<=s1'')) , (here-pos ina-G₁ (Sub.force s1<=s1')))))))))) 153 | vcr-match-2-sb (ssplit2 (ss-left ss1) (ss-negpos ss2)) (here-neg ina-G (sub-sintern s1<=s1'' s2<=s2'')) (here-pos ina-G₁ (sub-sextern s1<=s1' s2<=s2')) Right = just ((sub-trans (dual-sub s1<=s1') s1<=s1'') , ((sub-trans (dual-sub s2<=s2') s2<=s2'') , (_ , (_ , (_ , (_ , ((ssplit2 (ss-left ss1) (ss-negpos ss2)) , ((here-neg ina-G (Sub.force s2<=s2'')) , (here-pos ina-G₁ (Sub.force s2<=s2')))))))))) 154 | vcr-match-2-sb (ssplit2 (ss-right ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ (sub-sextern s1<=s1' s2<=s2')) lab 155 | vcr-match-2-sb (ssplit2 (ss-posneg ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ (sub-sextern s1<=s1' s2<=s2')) lab 156 | vcr-match-2-sb (ssplit2 (ss-negpos ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ (sub-sextern s1<=s1' s2<=s2')) lab 157 | vcr-match-2-sb (ssplit2 ss1 ss2) (here-neg ina-G x) (here-neg ina-G₁ x₁) lab = nothing 158 | vcr-match-2-sb (ssplit2 ss1 ss2) (here-neg ina-G x) (there vcr2) lab = nothing 159 | vcr-match-2-sb (ssplit2 ss1 ss2) (there vcr1) (here-pos ina-G x) lab = nothing 160 | vcr-match-2-sb (ssplit2 ss1 ss2) (there vcr1) (here-neg ina-G x) lab = nothing 161 | vcr-match-2-sb (ssplit2 ss-[] ()) (there vcr1) (there vcr2) lab 162 | vcr-match-2-sb (ssplit2 (ss-both ss1) (ss-both ss2)) (there vcr1) (there vcr2) lab = map (λ { (ds21<=s11 , ds22<=s12 , _ , _ , _ , _ , ssplit2 ss1' ss2' , vcr1' , vcr2') → ds21<=s11 , ds22<=s12 , _ , _ , _ , _ , (ssplit2 (ss-both ss1') (ss-both ss2')) , ((there vcr1') , (there vcr2')) }) (vcr-match-2-sb (ssplit2 ss1 ss2) vcr1 vcr2 lab) 163 | vcr-match-2-sb (ssplit2 (ss-left ss1) ()) (there vcr1) (there vcr2) lab 164 | vcr-match-2-sb (ssplit2 (ss-right ss1) (ss-both ss2)) (there vcr1) (there vcr2) lab = map (λ { (ds21<=s11 , ds22<=s12 , _ , _ , _ , _ , ssplit2 ss1' ss2' , vcr1' , vcr2') → ds21<=s11 , ds22<=s12 , _ , _ , _ , _ , (ssplit2 (ss-right ss1') (ss-both ss2')) , ((there vcr1') , (there vcr2')) }) (vcr-match-2-sb (ssplit2 ss1 ss2) vcr1 vcr2 lab) 165 | vcr-match-2-sb (ssplit2 (ss-posneg ss1) ()) (there vcr1) (there vcr2) lab 166 | vcr-match-2-sb (ssplit2 (ss-negpos ss1) ()) (there vcr1) (there vcr2) lab 167 | 168 | vcr-match-2-nsb : ∀ {G G₁ G₂ G₁₁ G₁₂ b₁ b₂ m₁ m₂ alti alte} 169 | → SSplit2 G G₁ G₂ G₁₁ G₁₂ 170 | → ChannelRef G₁₁ b₁ (sintN m₁ alti) 171 | → ChannelRef G₁₂ b₂ (sextN m₂ alte) 172 | → (lab : Fin m₁) 173 | → Maybe (Σ (m₁ ≤ m₂) λ { p → 174 | ((i : Fin m₁) → dual (alti i) ≲ alte (inject≤ i p)) × 175 | ∃ λ G' → ∃ λ G₁' → ∃ λ G₁₁' → ∃ λ G₁₂' → 176 | SSplit2 G' G₁' G₂ G₁₁' G₁₂' × 177 | ChannelRef G₁₁' b₁ (SType.force (alti lab)) × 178 | ChannelRef G₁₂' b₂ (SType.force (alte (inject≤ lab p)))}) 179 | vcr-match-2-nsb (ssplit2 ss1 ss2) (here-pos ina-G _) (here-pos ina-G₁ _) lab = nothing 180 | vcr-match-2-nsb (ssplit2 ss-[] ()) (here-pos ina-G (sub-sintN m'≤m x)) (here-neg ina-G₁ x₁) lab 181 | vcr-match-2-nsb (ssplit2 (ss-both ss1) ()) (here-pos ina-G (sub-sintN m'≤m x)) (here-neg ina-G₁ x₁) lab 182 | vcr-match-2-nsb {m₁ = m₁} {alti = alti} {alte = alte} (ssplit2 (ss-left ss1) (ss-posneg ss2)) (here-pos ina-G (sub-sintN {alt = alt} m'≤m subint)) (here-neg ina-G₁ (sub-sextN m≤m' subext)) lab = just (≤-trans m'≤m m≤m' , auxSub , _ , _ , _ , _ , (ssplit2 (ss-left ss1) (ss-posneg ss2)) , (here-pos ina-G (Sub.force (subint lab))) , (here-neg ina-G₁ auxExt)) 183 | where 184 | auxSub : (i : Fin m₁) → dual (alti i) ≲ alte (inject≤ i (≤-trans m'≤m m≤m')) 185 | auxSub i with subext (inject≤ i m'≤m) 186 | ... | r rewrite (inject-trans m≤m' m'≤m i) = sub-trans (dual-sub (subint i)) r 187 | auxExt : dualF (SType.force (alt (inject≤ lab m'≤m))) ≲' SType.force (alte (inject≤ lab (≤-trans m'≤m m≤m'))) 188 | auxExt with Sub.force (subext (inject≤ lab m'≤m)) 189 | ... | se rewrite inject-trans m≤m' m'≤m lab = se 190 | vcr-match-2-nsb (ssplit2 (ss-right ss1) ()) (here-pos ina-G (sub-sintN m'≤m x)) (here-neg ina-G₁ x₁) lab 191 | vcr-match-2-nsb (ssplit2 (ss-posneg ss1) ()) (here-pos ina-G (sub-sintN m'≤m x)) (here-neg ina-G₁ x₁) lab 192 | vcr-match-2-nsb (ssplit2 (ss-negpos ss1) ()) (here-pos ina-G (sub-sintN m'≤m x)) (here-neg ina-G₁ x₁) lab 193 | vcr-match-2-nsb (ssplit2 ss1 ss2) (here-pos ina-G x) (there vcr2) lab = nothing 194 | vcr-match-2-nsb (ssplit2 ss-[] ()) (here-neg ina-G x) (here-pos ina-G₁ (sub-sextN m≤m' x₁)) lab 195 | vcr-match-2-nsb (ssplit2 (ss-both ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ (sub-sextN m≤m' x₁)) lab 196 | vcr-match-2-nsb {m₁ = m₁} {alti = alti} {alte = alte} (ssplit2 (ss-left ss1) (ss-negpos ss2)) (here-neg ina-G (sub-sintN m'≤m subint)) (here-pos ina-G₁ (sub-sextN {alt = alt} m≤m' subext)) lab = just ((≤-trans m'≤m m≤m') , auxSub , _ , _ , _ , _ , ssplit2 (ss-left ss1) (ss-negpos ss2) , here-neg ina-G (Sub.force (subint lab)) , here-pos ina-G₁ auxExt) 197 | where 198 | auxSub : (i : Fin m₁) → dual (alti i) ≲ alte (inject≤ i (≤-trans m'≤m m≤m')) 199 | auxSub i with subext (inject≤ i m'≤m) 200 | ... | sub2 rewrite (inject-trans m≤m' m'≤m i) = 201 | sub-trans (sub-trans (dual-sub (subint i)) (eq-implies-sub (eq-sym (dual-involution _)))) sub2 202 | auxExt : SType.force (alt (inject≤ lab m'≤m)) ≲' SType.force (alte (inject≤ lab (≤-trans m'≤m m≤m'))) 203 | auxExt with Sub.force (subext (inject≤ lab m'≤m)) 204 | ... | se rewrite (inject-trans m≤m' m'≤m lab) = se 205 | vcr-match-2-nsb (ssplit2 (ss-right ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ (sub-sextN m≤m' x₁)) lab 206 | vcr-match-2-nsb (ssplit2 (ss-posneg ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ (sub-sextN m≤m' x₁)) lab 207 | vcr-match-2-nsb (ssplit2 (ss-negpos ss1) ()) (here-neg ina-G x) (here-pos ina-G₁ (sub-sextN m≤m' x₁)) lab 208 | vcr-match-2-nsb (ssplit2 ss1 ss2) (here-neg ina-G x) (here-neg ina-G₁ x₁) lab = nothing 209 | vcr-match-2-nsb (ssplit2 ss1 ss2) (here-neg ina-G x) (there vcr2) lab = nothing 210 | vcr-match-2-nsb (ssplit2 ss1 ss2) (there vcr1) (here-pos ina-G x) lab = nothing 211 | vcr-match-2-nsb (ssplit2 ss1 ss2) (there vcr1) (here-neg ina-G x) lab = nothing 212 | vcr-match-2-nsb (ssplit2 ss-[] ()) (there vcr1) (there vcr2) lab 213 | vcr-match-2-nsb (ssplit2 (ss-both ss1) (ss-both ss2)) (there vcr1) (there vcr2) lab = 214 | map (λ { (m1≤m2 , fdi≤e , _ , _ , _ , _ , ssplit2 ss1' ss2' , vcr1' , vcr2') → m1≤m2 , fdi≤e , _ , _ , _ , _ , (ssplit2 (ss-both ss1') (ss-both ss2')) , there vcr1' , there vcr2' }) 215 | (vcr-match-2-nsb (ssplit2 ss1 ss2) vcr1 vcr2 lab) 216 | vcr-match-2-nsb (ssplit2 (ss-left ss1) ()) (there vcr1) (there vcr2) lab 217 | vcr-match-2-nsb (ssplit2 (ss-right ss1) (ss-both ss2)) (there vcr1) (there vcr2) lab = 218 | map (λ { (m1≤m2 , fdi≤e , _ , _ , _ , _ , ssplit2 ss1' ss2' , vcr1' , vcr2') → m1≤m2 , fdi≤e , _ , _ , _ , _ , (ssplit2 (ss-right ss1') (ss-both ss2')) , there vcr1' , there vcr2' }) 219 | (vcr-match-2-nsb (ssplit2 ss1 ss2) vcr1 vcr2 lab) 220 | vcr-match-2-nsb (ssplit2 (ss-posneg ss1) ()) (there vcr1) (there vcr2) lab 221 | vcr-match-2-nsb (ssplit2 (ss-negpos ss1) ()) (there vcr1) (there vcr2) lab 222 | 223 | -------------------------------------------------------------------------------- /src/DSession.agda: -------------------------------------------------------------------------------- 1 | module DSession where 2 | 3 | open import Data.Bool 4 | open import Data.Fin 5 | open import Data.Empty 6 | open import Data.List 7 | open import Data.List.All 8 | open import Data.Maybe hiding (All) 9 | open import Data.Nat 10 | open import Data.Product 11 | open import Data.Sum 12 | open import Data.Unit 13 | open import Function using (_$_) 14 | open import Relation.Nullary 15 | open import Relation.Binary.PropositionalEquality 16 | 17 | open import Typing 18 | open import Syntax 19 | open import Global 20 | open import Channel 21 | open import Values 22 | 23 | -- this is really just a Kleisli arrow 24 | data Cont (G : SCtx) (φ : TCtx) (t : Type) : Type → Set where 25 | ident : 26 | (ina-G : Inactive G) 27 | → (unr-φ : All Unr φ) 28 | → Cont G φ t t 29 | 30 | bind : ∀ {φ₁ φ₂ G₁ G₂ t₂ t₃} 31 | → (ts : Split φ φ₁ φ₂) 32 | → (ss : SSplit G G₁ G₂) 33 | → (e₂ : Expr (t ∷ φ₁) t₂) 34 | → (ϱ₂ : VEnv G₁ φ₁) 35 | → (κ₂ : Cont G₂ φ₂ t₂ t₃) 36 | → Cont G φ t t₃ 37 | 38 | subsume : ∀ {t₁ t₂} 39 | → (t≤t1 : SubT t t₁) 40 | → (κ : Cont G φ t₁ t₂) 41 | → Cont G φ t t₂ 42 | 43 | compose : ∀ {G G₁ G₂ φ φ₁ φ₂ t₁ t₂ t₃} 44 | → Split φ φ₁ φ₂ 45 | → SSplit G G₁ G₂ 46 | → Cont G₁ φ₁ t₁ t₂ 47 | → Cont G₂ φ₂ t₂ t₃ 48 | → Cont G φ t₁ t₃ 49 | compose ss ssp (ident ina-G unr-φ) (ident ina-G₁ unr-φ₁) = 50 | ident (ssplit-inactive ssp ina-G ina-G₁) (split-unr ss unr-φ unr-φ₁) 51 | compose ss ssp (ident ina-G unr-φ) (bind ts ss₁ e₂ ϱ₂ κ₂) = bind {!!} {!!} e₂ ϱ₂ κ₂ 52 | compose ss ssp (ident ina-G unr-φ) (subsume t≤t1 κ₂) 53 | with inactive-left-ssplit ssp ina-G 54 | ... | refl 55 | = subsume t≤t1 {!!} 56 | compose ss ssp (bind ts ss₁ e₂ ϱ₂ κ₁) (ident ina-G unr-φ) = {!!} 57 | compose ss ssp (bind ts ss₁ e₂ ϱ₂ κ₁) (bind ts₁ ss₂ e₃ ϱ₃ κ₂) = {!!} 58 | compose ss ssp (bind ts ss₁ e₂ ϱ₂ κ₁) (subsume t≤t1 κ₂) = {!!} 59 | compose ss ssp (subsume t≤t1 κ₁) (ident ina-G unr-φ) = {!!} 60 | compose ss ssp (subsume t≤t1 κ₁) (bind ts ss₁ e₂ ϱ₂ κ₂) = {!!} 61 | compose ss ssp (subsume t≤t1 κ₁) (subsume t≤t2 κ₂) = {!!} 62 | 63 | -- command is a monad 64 | data Command (G : SCtx) (t : Type) : Set where 65 | 66 | Return : (v : Val G t) 67 | → Command G t 68 | 69 | Fork : ∀ {φ₁ φ₂ G₁ G₂} 70 | → (ss : SSplit G G₁ G₂) 71 | → (κ₁ : Cont G₁ φ₁ TUnit TUnit) 72 | → (κ₂ : Cont G₂ φ₂ TUnit t) 73 | → Command G t 74 | 75 | New : ∀ {φ} 76 | → (s : SType) 77 | → (κ : Cont G φ (TPair (TChan (SType.force s)) (TChan (SType.force (dual s)))) t) 78 | → Command G t 79 | 80 | Close : ∀ {φ G₁ G₂} 81 | → (ss : SSplit G G₁ G₂) 82 | → (v : Val G₁ (TChan send!)) 83 | → (κ : Cont G₂ φ TUnit t) 84 | → Command G t 85 | 86 | Wait : ∀ {φ G₁ G₂} 87 | → (ss : SSplit G G₁ G₂) 88 | → (v : Val G₁ (TChan send?)) 89 | → (κ : Cont G₂ φ TUnit t) 90 | → Command G t 91 | 92 | Send : ∀ {φ G₁ G₂ G₁₁ G₁₂ tv s} 93 | → (ss : SSplit G G₁ G₂) 94 | → (ss-args : SSplit G₁ G₁₁ G₁₂) 95 | → (vch : Val G₁₁ (TChan (send tv s))) 96 | → (v : Val G₁₂ tv) 97 | → (κ : Cont G₂ φ (TChan (SType.force s)) t) 98 | → Command G t 99 | 100 | Recv : ∀ {φ G₁ G₂ tv s} 101 | → (ss : SSplit G G₁ G₂) 102 | → (vch : Val G₁ (TChan (recv tv s))) 103 | → (κ : Cont G₂ φ (TPair (TChan (SType.force s)) tv) t) 104 | → Command G t 105 | 106 | Select : ∀ {φ G₁ G₂ s₁ s₂} 107 | → (ss : SSplit G G₁ G₂) 108 | → (lab : Selector) 109 | → (vch : Val G₁ (TChan (sintern s₁ s₂))) 110 | → (κ : Cont G₂ φ (TChan (selection lab (SType.force s₁) (SType.force s₂))) t) 111 | → Command G t 112 | 113 | Branch : ∀ {φ G₁ G₂ s₁ s₂} 114 | → (ss : SSplit G G₁ G₂) 115 | → (vch : Val G₁ (TChan (sextern s₁ s₂))) 116 | → (dcont : (lab : Selector) → Cont G₂ φ (TChan (selection lab (SType.force s₁) (SType.force s₂))) t) 117 | → Command G t 118 | 119 | NSelect : ∀ {φ G₁ G₂ m alt} 120 | → (ss : SSplit G G₁ G₂) 121 | → (lab : Fin m) 122 | → (vch : Val G₁ (TChan (sintN m alt))) 123 | → (κ : Cont G₂ φ (TChan (SType.force (alt lab))) t) 124 | → Command G t 125 | 126 | NBranch : ∀ {φ G₁ G₂ m alt} 127 | → (ss : SSplit G G₁ G₂) 128 | → (vch : Val G₁ (TChan (sextN m alt))) 129 | → (dcont : (lab : Fin m) → Cont G₂ φ (TChan (SType.force (alt lab))) t) 130 | → Command G t 131 | 132 | -- cont G = ∀ G' → G ≤ G' → SSplit G' Gval Gcont → Val Gval t → 133 | 134 | data _≼_ G : SCtx → Set where 135 | ≼-rfl : G ≼ G 136 | ≼-ext : ∀ {G'} → G ≼ G' → G ≼ (nothing ∷ G') 137 | 138 | {- 139 | mbindf : ∀ {Gin G1in G2in G1out G2out t t'} → SSplit Gin G1in G2in 140 | → Command G1in G1out t 141 | → (∀ G2in' G1out' G2out' → G2in ≼ G2in' → G1out ≼ G1out' → G2out ≼ G2out' 142 | → Val G1out' t → Command G2in' G2out' t') 143 | → Command Gin G2out t' 144 | mbindf = {!!} 145 | -} 146 | 147 | mbind : ∀ {G G₁ G₂ Φ t t'} → SSplit G G₁ G₂ → Command G₁ t → Cont G₂ Φ t t' → Command G t' 148 | mbind ssp (Return v) (ident x x₁) 149 | with inactive-right-ssplit ssp x 150 | ... | refl 151 | = Return v 152 | mbind ssp (Return v) (bind ts ss e₂ ϱ₂ cont) = {!!} 153 | mbind ssp (Return v) (subsume t≤t1 cont) = {!!} 154 | mbind ssp (Fork ss κ₁ κ₂) cont = Fork {!!} κ₁ {!!} 155 | mbind ssp (New s κ) cont = {!!} 156 | mbind ssp (Close ss v κ) cont = {!!} 157 | mbind ssp (Wait ss v κ) cont = {!!} 158 | mbind ssp (Send ss ss-args vch v κ) cont = {!!} 159 | mbind ssp (Recv ss vch κ) cont = {!!} 160 | mbind ssp (Select ss lab vch κ) cont = {!!} 161 | mbind ssp (Branch ss vch dcont) cont = {!!} 162 | mbind ssp (NSelect ss lab vch κ) cont = {!!} 163 | mbind ssp (NBranch ss vch dcont) cont = {!!} 164 | -------------------------------------------------------------------------------- /src/DSyntax.agda: -------------------------------------------------------------------------------- 1 | module DSyntax where 2 | 3 | open import Data.List 4 | open import Data.List.All 5 | open import Data.Nat 6 | 7 | open import Typing 8 | 9 | data DExpr φ : Type → Set where 10 | var : ∀ {t} 11 | → (x : t ∈ φ) 12 | → DExpr φ t 13 | 14 | nat : (unr-φ : All Unr φ) 15 | → (i : ℕ) 16 | → DExpr φ TInt 17 | 18 | unit : (unr-φ : All Unr φ) 19 | → DExpr φ TUnit 20 | 21 | pair : ∀ {φ₁ φ₂ t₁ t₂} 22 | → (sp : Split φ φ₁ φ₂) 23 | → (e₁ : DExpr φ₁ t₁) 24 | → (e₂ : DExpr φ₂ t₂) 25 | → DExpr φ (TPair t₁ t₂) 26 | 27 | letpair : ∀ {φ₁ φ₂ t₁ t₂ t} 28 | → (sp : Split φ φ₁ φ₂) 29 | → (epair : DExpr φ₁ (TPair t₁ t₂)) 30 | → (ebody : DExpr (t₁ ∷ t₂ ∷ φ₂) t) 31 | → DExpr φ t 32 | 33 | fork : (e : DExpr φ TUnit) 34 | → DExpr φ TUnit 35 | 36 | new : (unr-φ : All Unr φ) 37 | → (s : SType) 38 | → DExpr φ (TPair (TChan (SType.force s)) (TChan (SType.force (dual s)))) 39 | 40 | send : ∀ {φ₁ φ₂ s t} 41 | → (sp : Split φ φ₁ φ₂) 42 | → (ech : DExpr φ₁ (TChan (send t s))) 43 | → (earg : DExpr φ₂ t) 44 | → DExpr φ (TChan (SType.force s)) 45 | 46 | recv : ∀ {s t} 47 | → (ech : DExpr φ (TChan (recv t s))) 48 | → DExpr φ (TPair (TChan (SType.force s)) t) 49 | 50 | close : (ech : DExpr φ (TChan send!)) 51 | → DExpr φ TUnit 52 | 53 | wait : (ech : DExpr φ (TChan send?)) 54 | → DExpr φ TUnit 55 | 56 | select : ∀ {s₁ s₂} 57 | → (lab : Selector) 58 | → (ech : DExpr φ (TChan (sintern s₁ s₂))) 59 | → DExpr φ (TChan (selection lab (SType.force s₁) (SType.force s₂))) 60 | 61 | branch : ∀ {s₁ s₂ φ₁ φ₂ t} 62 | → (sp : Split φ φ₁ φ₂) 63 | → (ech : DExpr φ₁ (TChan (sextern s₁ s₂))) 64 | → (eleft : DExpr (TChan (SType.force s₁) ∷ φ₂) t) 65 | → (erght : DExpr (TChan (SType.force s₂) ∷ φ₂) t) 66 | → DExpr φ t 67 | 68 | ulambda : ∀ {t₁ t₂} 69 | → (unr-φ : All Unr φ) 70 | → (ebody : DExpr (t₁ ∷ φ) t₂) 71 | → DExpr φ (TFun UU t₁ t₂) 72 | 73 | llambda : ∀ {t₁ t₂} 74 | → (ebody : DExpr (t₁ ∷ φ) t₂) 75 | → DExpr φ (TFun LL t₁ t₂) 76 | 77 | app : ∀ {φ₁ φ₂ lu t₁ t₂} 78 | → (sp : Split φ φ₁ φ₂) 79 | → (efun : DExpr φ₁ (TFun lu t₁ t₂)) 80 | → (earg : DExpr φ₂ t₁) 81 | → DExpr φ t₂ 82 | 83 | subsume : ∀ {t₁ t₂} 84 | → (e : DExpr φ t₁) 85 | → (t≤t' : SubT t₁ t₂) 86 | → DExpr φ t₂ 87 | -------------------------------------------------------------------------------- /src/Examples.agda: -------------------------------------------------------------------------------- 1 | module Examples where 2 | 3 | open import Data.List hiding (reverse) 4 | open import Data.List.All 5 | open import Data.Nat 6 | 7 | open import Typing 8 | open import Syntax 9 | 10 | ex1 : Expr [] TUnit 11 | ex1 = 12 | letbind [] (new [] (delay send!)) 13 | (letpair (left []) (here []) 14 | (letbind (rght (left [])) 15 | (fork (wait (here []))) 16 | (close (there UUnit (here []))))) 17 | 18 | ex1dual : Expr [] TUnit 19 | ex1dual = 20 | letbind [] (new [] (delay send!)) 21 | (letpair (left []) (here []) 22 | (letbind (left (rght [])) 23 | (fork (close (here []))) 24 | (wait (there UUnit (here []))))) 25 | 26 | -- sending and receiving 27 | ex2 : Expr [] TUnit 28 | ex2 = 29 | letbind [] (new [] (delay (Typing.send TInt (delay send!)))) 30 | (letpair (left []) (here []) 31 | (letbind (left (rght [])) 32 | (fork (letbind (rght []) (nat [] 42) 33 | (letbind (left (left [])) (Expr.send (rght (left [])) (here []) (here [])) 34 | (letbind (left []) (close (here [])) 35 | (var (here [])))))) 36 | (letbind (rght (left [])) (Expr.recv (here [])) 37 | (letpair (left (rght [])) (here []) 38 | (letbind (left (left (rght []))) (wait (here (UInt ∷ []))) 39 | (var (here (UUnit ∷ [])))))))) 40 | 41 | -- higher order sending and receiving 42 | ex3 : Expr [] TUnit 43 | ex3 = 44 | letbind [] (new [] (delay (Typing.send (TChan send!) (delay send!)))) 45 | (letbind (rght []) (new [] (delay send!)) 46 | (letpair (left (rght [])) (here []) 47 | (letpair (rght (rght (left []))) (here []) 48 | (letbind (left (rght (left (left [])))) 49 | (fork (letbind (left (left (rght []))) (Expr.send (left (rght [])) (here []) (here [])) 50 | (letbind (left (rght [])) (close (here [])) 51 | (wait (there UUnit (here [])))))) 52 | (letbind (left (left [])) (Expr.recv (there UUnit (here []))) 53 | (letpair (left []) (here []) 54 | (letbind (left (rght [])) (wait (here [])) 55 | (letbind (left (left [])) (close (there UUnit (here []))) 56 | (var (here [])))))))))) 57 | 58 | -- branching 59 | ex4 : Expr [] TUnit 60 | ex4 = 61 | letbind [] (new [] (delay (sintern (delay send!) (delay send?)))) 62 | (letpair (left []) (here []) 63 | (letbind (left (rght [])) 64 | (fork (letbind (left []) (select Left (here [])) 65 | (close (here [])))) 66 | (branch (left (left [])) (there UUnit (here [])) 67 | (wait (here [])) 68 | (close (here []))))) 69 | 70 | -- simple lambda: (λx.x)() 71 | ex5 : Expr [] TUnit 72 | ex5 = letbind [] (llambda [] [] (var (here []))) 73 | (letbind (rght []) (unit []) 74 | (app (rght (left [])) (here []) (here []))) 75 | 76 | -- lambda app: (λfx.fx) (λx.x)() 77 | ex6 : Expr [] TUnit 78 | ex6 = letbind [] (llambda [] [] (llambda (left []) [] (app (rght (left [])) (here []) (here [])))) 79 | (letbind (rght []) (llambda [] [] (var (here []))) 80 | (letbind (rght (rght [])) (unit []) 81 | (letbind (rght (left (left []))) (app (rght (left [])) (here []) (here [])) 82 | (app (left (rght [])) (here []) (here []))))) 83 | -------------------------------------------------------------------------------- /src/Global.agda: -------------------------------------------------------------------------------- 1 | module Global where 2 | 3 | open import Data.List 4 | open import Data.Maybe 5 | open import Data.Product 6 | open import Relation.Binary.PropositionalEquality 7 | 8 | open import Typing 9 | 10 | -- specific 11 | data PosNeg : Set where 12 | POS NEG POSNEG : PosNeg 13 | 14 | -- global session context 15 | SEntry = Maybe (STypeF SType × PosNeg) 16 | SCtx = List SEntry 17 | 18 | -- SSplit G G₁ G₂ 19 | -- split G into G₁ and G₂ 20 | -- length and position preserving 21 | data SSplit : SCtx → SCtx → SCtx → Set where 22 | ss-[] : SSplit [] [] [] 23 | ss-both : ∀ { G G₁ G₂ } 24 | → SSplit G G₁ G₂ 25 | → SSplit (nothing ∷ G) (nothing ∷ G₁) (nothing ∷ G₂) 26 | ss-left : ∀ { spn G G₁ G₂ } 27 | → SSplit G G₁ G₂ 28 | → SSplit (just spn ∷ G) (just spn ∷ G₁) (nothing ∷ G₂) 29 | ss-right : ∀ { spn G G₁ G₂ } 30 | → SSplit G G₁ G₂ 31 | → SSplit (just spn ∷ G) (nothing ∷ G₁) (just spn ∷ G₂) 32 | ss-posneg : ∀ { s G G₁ G₂ } 33 | → SSplit G G₁ G₂ 34 | → SSplit (just (s , POSNEG) ∷ G) (just (s , POS) ∷ G₁) (just (s , NEG) ∷ G₂) 35 | ss-negpos : ∀ { s G G₁ G₂ } 36 | → SSplit G G₁ G₂ 37 | → SSplit (just (s , POSNEG) ∷ G) (just (s , NEG) ∷ G₁) (just (s , POS) ∷ G₂) 38 | 39 | ssplit-sym : ∀ {G G₁ G₂} → SSplit G G₁ G₂ → SSplit G G₂ G₁ 40 | ssplit-sym ss-[] = ss-[] 41 | ssplit-sym (ss-both ss12) = ss-both (ssplit-sym ss12) 42 | ssplit-sym (ss-left ss12) = ss-right (ssplit-sym ss12) 43 | ssplit-sym (ss-right ss12) = ss-left (ssplit-sym ss12) 44 | ssplit-sym (ss-posneg ss12) = ss-negpos (ssplit-sym ss12) 45 | ssplit-sym (ss-negpos ss12) = ss-posneg (ssplit-sym ss12) 46 | 47 | -- tedious but easy to prove 48 | ssplit-compose : {G G₁ G₂ G₃ G₄ : SCtx} 49 | → (ss : SSplit G G₁ G₂) 50 | → (ss₁ : SSplit G₁ G₃ G₄) 51 | → ∃ λ Gi → SSplit G G₃ Gi × SSplit Gi G₄ G₂ 52 | ssplit-compose ss-[] ss-[] = [] , (ss-[] , ss-[]) 53 | ssplit-compose (ss-both ss) (ss-both ss₁) with ssplit-compose ss ss₁ 54 | ssplit-compose (ss-both ss) (ss-both ss₁) | Gi , ss₁₃ , ss₂₄ = nothing ∷ Gi , ss-both ss₁₃ , ss-both ss₂₄ 55 | ssplit-compose (ss-left ss) (ss-left ss₁) with ssplit-compose ss ss₁ 56 | ... | Gi , ss₁₃ , ss₂₄ = nothing ∷ Gi , ss-left ss₁₃ , ss-both ss₂₄ 57 | ssplit-compose (ss-left ss) (ss-right ss₁) with ssplit-compose ss ss₁ 58 | ... | Gi , ss₁₃ , ss₂₄ = just _ ∷ Gi , ss-right ss₁₃ , ss-left ss₂₄ 59 | ssplit-compose (ss-left ss) (ss-posneg ss₁) with ssplit-compose ss ss₁ 60 | ... | Gi , ss₁₃ , ss₂₄ = just ( _ , NEG) ∷ Gi , ss-posneg ss₁₃ , ss-left ss₂₄ 61 | ssplit-compose (ss-left ss) (ss-negpos ss₁) with ssplit-compose ss ss₁ 62 | ... | Gi , ss₁₃ , ss₂₄ = just ( _ , POS) ∷ Gi , ss-negpos ss₁₃ , ss-left ss₂₄ 63 | ssplit-compose (ss-right ss) (ss-both ss₁) with ssplit-compose ss ss₁ 64 | ... | Gi , ss₁₃ , ss₂₄ = just _ ∷ Gi , ss-right ss₁₃ , ss-right ss₂₄ 65 | ssplit-compose (ss-posneg ss) (ss-left ss₁) with ssplit-compose ss ss₁ 66 | ... | Gi , ss₁₃ , ss₂₄ = just ( _ , NEG) ∷ Gi , ss-posneg ss₁₃ , ss-right ss₂₄ 67 | ssplit-compose (ss-posneg ss) (ss-right ss₁) with ssplit-compose ss ss₁ 68 | ... | Gi , ss₁₃ , ss₂₄ = just ( _ , POSNEG) ∷ Gi , ss-right ss₁₃ , ss-posneg ss₂₄ 69 | ssplit-compose (ss-negpos ss) (ss-left ss₁) with ssplit-compose ss ss₁ 70 | ... | Gi , ss₁₃ , ss₂₄ = just ( _ , POS) ∷ Gi , ss-negpos ss₁₃ , ss-right ss₂₄ 71 | ssplit-compose (ss-negpos ss) (ss-right ss₁) with ssplit-compose ss ss₁ 72 | ... | Gi , ss₁₃ , ss₂₄ = just ( _ , POSNEG) ∷ Gi , ss-right ss₁₃ , ss-negpos ss₂₄ 73 | 74 | ssplit-compose2 : {G G₁ G₂ G₂₁ G₂₂ : SCtx} 75 | → SSplit G G₁ G₂ 76 | → SSplit G₂ G₂₁ G₂₂ 77 | → ∃ λ Gi → (SSplit G Gi G₂₁ × SSplit Gi G₁ G₂₂) 78 | ssplit-compose2 ss-[] ss-[] = [] , ss-[] , ss-[] 79 | ssplit-compose2 (ss-both ss) (ss-both ss₂) with ssplit-compose2 ss ss₂ 80 | ... | Gi , ssx , ssy = nothing ∷ Gi , ss-both ssx , ss-both ssy 81 | ssplit-compose2 (ss-left ss) (ss-both ss₂) with ssplit-compose2 ss ss₂ 82 | ... | Gi , ssx , ssy = just _ ∷ Gi , ss-left ssx , ss-left ssy 83 | ssplit-compose2 (ss-right ss) (ss-left ss₂) with ssplit-compose2 ss ss₂ 84 | ... | Gi , ssx , ssy = nothing ∷ Gi , ss-right ssx , ss-both ssy 85 | ssplit-compose2 (ss-right ss) (ss-right ss₂) with ssplit-compose2 ss ss₂ 86 | ... | Gi , ssx , ssy = just _ ∷ Gi , ss-left ssx , ss-right ssy 87 | ssplit-compose2 (ss-right ss) (ss-posneg ss₂) with ssplit-compose2 ss ss₂ 88 | ... | Gi , ssx , ssy = just (_ , NEG) ∷ Gi , ss-negpos ssx , ss-right ssy 89 | ssplit-compose2 (ss-right ss) (ss-negpos ss₂) with ssplit-compose2 ss ss₂ 90 | ... | Gi , ssx , ssy = just (_ , POS) ∷ Gi , ss-posneg ssx , ss-right ssy 91 | ssplit-compose2 (ss-posneg ss) (ss-left ss₂) with ssplit-compose2 ss ss₂ 92 | ... | Gi , ssx , ssy = just (_ , POS) ∷ Gi , ss-posneg ssx , ss-left ssy 93 | ssplit-compose2 (ss-posneg ss) (ss-right ss₂) with ssplit-compose2 ss ss₂ 94 | ... | Gi , ssx , ssy = just (_ , POSNEG) ∷ Gi , ss-left ssx , ss-posneg ssy 95 | ssplit-compose2 (ss-negpos ss) (ss-left ss₂) with ssplit-compose2 ss ss₂ 96 | ... | Gi , ssx , ssy = just (_ , NEG) ∷ Gi , ss-negpos ssx , ss-left ssy 97 | ssplit-compose2 (ss-negpos ss) (ss-right ss₂) with ssplit-compose2 ss ss₂ 98 | ... | Gi , ssx , ssy = just (_ , POSNEG) ∷ Gi , ss-left ssx , ss-negpos ssy 99 | 100 | ssplit-compose3 : {G G₁ G₂ G₃ G₄ : SCtx} 101 | → SSplit G G₁ G₂ 102 | → SSplit G₂ G₃ G₄ 103 | → ∃ λ Gi → (SSplit G Gi G₄ × SSplit Gi G₁ G₃) 104 | ssplit-compose3 ss-[] ss-[] = [] , ss-[] , ss-[] 105 | ssplit-compose3 (ss-both ss12) (ss-both ss234) with ssplit-compose3 ss12 ss234 106 | ... | Gi , ssi4 , ssi13 = nothing ∷ Gi , ss-both ssi4 , ss-both ssi13 107 | ssplit-compose3 (ss-left ss12) (ss-both ss234) with ssplit-compose3 ss12 ss234 108 | ... | Gi , ssi4 , ssi13 = just _ ∷ Gi , ss-left ssi4 , ss-left ssi13 109 | ssplit-compose3 (ss-right ss12) (ss-left ss234) with ssplit-compose3 ss12 ss234 110 | ... | Gi , ssi4 , ssi13 = just _ ∷ Gi , ss-left ssi4 , ss-right ssi13 111 | ssplit-compose3 (ss-right ss12) (ss-right ss234) with ssplit-compose3 ss12 ss234 112 | ... | Gi , ssi4 , ssi13 = nothing ∷ Gi , ss-right ssi4 , ss-both ssi13 113 | ssplit-compose3 (ss-right ss12) (ss-posneg ss234) with ssplit-compose3 ss12 ss234 114 | ... | Gi , ssi4 , ssi13 = just ( _ , POS) ∷ Gi , ss-posneg ssi4 , ss-right ssi13 115 | ssplit-compose3 (ss-right ss12) (ss-negpos ss234) with ssplit-compose3 ss12 ss234 116 | ... | Gi , ssi4 , ssi13 = just ( _ , NEG) ∷ Gi , ss-negpos ssi4 , ss-right ssi13 117 | ssplit-compose3 (ss-posneg ss12) (ss-left ss234) with ssplit-compose3 ss12 ss234 118 | ... | Gi , ssi4 , ssi13 = just ( _ , POSNEG) ∷ Gi , ss-left ssi4 , ss-posneg ssi13 119 | ssplit-compose3 (ss-posneg ss12) (ss-right ss234) with ssplit-compose3 ss12 ss234 120 | ... | Gi , ssi4 , ssi13 = just ( _ , POS) ∷ Gi , ss-posneg ssi4 , ss-left ssi13 121 | ssplit-compose3 (ss-negpos ss12) (ss-left ss234) with ssplit-compose3 ss12 ss234 122 | ... | Gi , ssi4 , ssi13 = just ( _ , POSNEG) ∷ Gi , ss-left ssi4 , ss-negpos ssi13 123 | ssplit-compose3 (ss-negpos ss12) (ss-right ss234) with ssplit-compose3 ss12 ss234 124 | ... | Gi , ssi4 , ssi13 = just ( _ , NEG) ∷ Gi , ss-negpos ssi4 , ss-left ssi13 125 | 126 | 127 | ssplit-compose4 128 | : {G G₁ G₂ G₂₁ G₂₂ : SCtx} 129 | → (ss : SSplit G G₁ G₂) 130 | → (ss₁ : SSplit G₂ G₂₁ G₂₂) 131 | → ∃ λ Gi → SSplit G G₂₁ Gi × SSplit Gi G₁ G₂₂ 132 | ssplit-compose4 ss-[] ss-[] = [] , ss-[] , ss-[] 133 | ssplit-compose4 (ss-both ss) (ss-both ss₁) with ssplit-compose4 ss ss₁ 134 | ... | Gi , ss-21i , ss-122 = nothing ∷ Gi , ss-both ss-21i , ss-both ss-122 135 | ssplit-compose4 (ss-left ss) (ss-both ss₁) with ssplit-compose4 ss ss₁ 136 | ... | Gi , ss-21i , ss-122 = just _ ∷ Gi , ss-right ss-21i , ss-left ss-122 137 | ssplit-compose4 (ss-right ss) (ss-left ss₁) with ssplit-compose4 ss ss₁ 138 | ... | Gi , ss-21i , ss-122 = nothing ∷ Gi , ss-left ss-21i , ss-both ss-122 139 | ssplit-compose4 (ss-right ss) (ss-right ss₁) with ssplit-compose4 ss ss₁ 140 | ... | Gi , ss-21i , ss-122 = just _ ∷ Gi , ss-right ss-21i , ss-right ss-122 141 | ssplit-compose4 (ss-right ss) (ss-posneg ss₁) with ssplit-compose4 ss ss₁ 142 | ... | Gi , ss-21i , ss-122 = just (_ , NEG) ∷ Gi , ss-posneg ss-21i , ss-right ss-122 143 | ssplit-compose4 (ss-right ss) (ss-negpos ss₁) with ssplit-compose4 ss ss₁ 144 | ... | Gi , ss-21i , ss-122 = just (_ , POS) ∷ Gi , ss-negpos ss-21i , ss-right ss-122 145 | ssplit-compose4 (ss-posneg ss) (ss-left ss₁) with ssplit-compose4 ss ss₁ 146 | ... | Gi , ss-21i , ss-122 = just (_ , POS) ∷ Gi , ss-negpos ss-21i , ss-left ss-122 147 | ssplit-compose4 (ss-posneg ss) (ss-right ss₁) with ssplit-compose4 ss ss₁ 148 | ... | Gi , ss-21i , ss-122 = just (_ , POSNEG) ∷ Gi , ss-right ss-21i , ss-posneg ss-122 149 | ssplit-compose4 (ss-negpos ss) (ss-left ss₁) with ssplit-compose4 ss ss₁ 150 | ... | Gi , ss-21i , ss-122 = just (_ , NEG) ∷ Gi , ss-posneg ss-21i , ss-left ss-122 151 | ssplit-compose4 (ss-negpos ss) (ss-right ss₁) with ssplit-compose4 ss ss₁ 152 | ... | Gi , ss-21i , ss-122 = just (_ , POSNEG) ∷ Gi , ss-right ss-21i , ss-negpos ss-122 153 | 154 | ssplit-compose5 155 | : ∀ {G G₁ G₂ G₁₁ G₁₂ : SCtx} 156 | → (ss : SSplit G G₁ G₂) 157 | → (ss₁ : SSplit G₁ G₁₁ G₁₂) 158 | → ∃ λ Gi → SSplit G G₁₂ Gi × SSplit Gi G₁₁ G₂ 159 | ssplit-compose5 ss-[] ss-[] = [] , ss-[] , ss-[] 160 | ssplit-compose5 (ss-both ss) (ss-both ss₁) with ssplit-compose5 ss ss₁ 161 | ... | Gi , ss-12i , ss-112 = nothing ∷ Gi , ss-both ss-12i , ss-both ss-112 162 | ssplit-compose5 (ss-left ss) (ss-left ss₁) with ssplit-compose5 ss ss₁ 163 | ... | Gi , ss-12i , ss-112 = just _ ∷ Gi , ss-right ss-12i , ss-left ss-112 164 | ssplit-compose5 (ss-left ss) (ss-right ss₁) with ssplit-compose5 ss ss₁ 165 | ... | Gi , ss-12i , ss-112 = nothing ∷ Gi , ss-left ss-12i , ss-both ss-112 166 | ssplit-compose5 (ss-left ss) (ss-posneg ss₁) with ssplit-compose5 ss ss₁ 167 | ... | Gi , ss-12i , ss-112 = just (_ , POS) ∷ Gi , ss-negpos ss-12i , ss-left ss-112 168 | ssplit-compose5 (ss-left ss) (ss-negpos ss₁) with ssplit-compose5 ss ss₁ 169 | ... | Gi , ss-12i , ss-112 = just (_ , NEG) ∷ Gi , ss-posneg ss-12i , ss-left ss-112 170 | ssplit-compose5 (ss-right ss) (ss-both ss₁) with ssplit-compose5 ss ss₁ 171 | ... | Gi , ss-12i , ss-112 = just _ ∷ Gi , ss-right ss-12i , ss-right ss-112 172 | ssplit-compose5 (ss-posneg ss) (ss-left ss₁) with ssplit-compose5 ss ss₁ 173 | ... | Gi , ss-12i , ss-112 = just (_ , POSNEG) ∷ Gi , ss-right ss-12i , ss-posneg ss-112 174 | ssplit-compose5 (ss-posneg ss) (ss-right ss₁) with ssplit-compose5 ss ss₁ 175 | ... | Gi , ss-12i , ss-112 = just (_ , NEG) ∷ Gi , ss-posneg ss-12i , ss-right ss-112 176 | ssplit-compose5 (ss-negpos ss) (ss-left ss₁) with ssplit-compose5 ss ss₁ 177 | ... | Gi , ss-12i , ss-112 = just (_ , POSNEG) ∷ Gi , ss-right ss-12i , ss-negpos ss-112 178 | ssplit-compose5 (ss-negpos ss) (ss-right ss₁) with ssplit-compose5 ss ss₁ 179 | ... | Gi , ss-12i , ss-112 = just (_ , POS) ∷ Gi , ss-negpos ss-12i , ss-right ss-112 180 | 181 | ssplit-compose6 182 | : ∀ {G G₁ G₂ G₁₁ G₁₂ : SCtx} 183 | → (ss : SSplit G G₁ G₂) 184 | → (ss₁ : SSplit G₁ G₁₁ G₁₂) 185 | → ∃ λ Gi → SSplit G G₁₁ Gi × SSplit Gi G₁₂ G₂ 186 | ssplit-compose6 ss-[] ss-[] = [] , ss-[] , ss-[] 187 | ssplit-compose6 (ss-both ss) (ss-both ss₁) with ssplit-compose6 ss ss₁ 188 | ... | Gi , ss-g11i , ss-g122 = nothing ∷ Gi , ss-both ss-g11i , ss-both ss-g122 189 | ssplit-compose6 (ss-left ss) (ss-left ss₁) with ssplit-compose6 ss ss₁ 190 | ... | Gi , ss-g11i , ss-g122 = nothing ∷ Gi , ss-left ss-g11i , ss-both ss-g122 191 | ssplit-compose6 (ss-left ss) (ss-right ss₁) with ssplit-compose6 ss ss₁ 192 | ... | Gi , ss-g11i , ss-g122 = just _ ∷ Gi , ss-right ss-g11i , ss-left ss-g122 193 | ssplit-compose6 (ss-left ss) (ss-posneg ss₁) with ssplit-compose6 ss ss₁ 194 | ... | Gi , ss-g11i , ss-g122 = just (_ , NEG) ∷ Gi , ss-posneg ss-g11i , ss-left ss-g122 195 | ssplit-compose6 (ss-left ss) (ss-negpos ss₁) with ssplit-compose6 ss ss₁ 196 | ... | Gi , ss-g11i , ss-g122 = just (_ , POS) ∷ Gi , ss-negpos ss-g11i , ss-left ss-g122 197 | ssplit-compose6 (ss-right ss) (ss-both ss₁) with ssplit-compose6 ss ss₁ 198 | ... | Gi , ss-g11i , ss-g122 = just _ ∷ Gi , ss-right ss-g11i , ss-right ss-g122 199 | ssplit-compose6 (ss-posneg ss) (ss-left ss₁) with ssplit-compose6 ss ss₁ 200 | ... | Gi , ss-g11i , ss-g122 = just (_ , NEG) ∷ Gi , ss-posneg ss-g11i , ss-right ss-g122 201 | ssplit-compose6 (ss-posneg ss) (ss-right ss₁) with ssplit-compose6 ss ss₁ 202 | ... | Gi , ss-g11i , ss-g122 = just (_ , POSNEG) ∷ Gi , ss-right ss-g11i , ss-posneg ss-g122 203 | ssplit-compose6 (ss-negpos ss) (ss-left ss₁) with ssplit-compose6 ss ss₁ 204 | ... | Gi , ss-g11i , ss-g122 = just (_ , POS) ∷ Gi , ss-negpos ss-g11i , ss-right ss-g122 205 | ssplit-compose6 (ss-negpos ss) (ss-right ss₁) with ssplit-compose6 ss ss₁ 206 | ... | Gi , ss-g11i , ss-g122 = just (_ , POSNEG) ∷ Gi , ss-right ss-g11i , ss-negpos ss-g122 207 | 208 | ssplit-join 209 | : ∀ {G G₁ G₂ G₁₁ G₁₂ G₂₁ G₂₂} 210 | → (ss : SSplit G G₁ G₂) 211 | → (ss₁ : SSplit G₁ G₁₁ G₁₂) 212 | → (ss₂ : SSplit G₂ G₂₁ G₂₂) 213 | → ∃ λ G₁' → ∃ λ G₂' → SSplit G G₁' G₂' × SSplit G₁' G₁₁ G₂₁ × SSplit G₂' G₁₂ G₂₂ 214 | ssplit-join ss-[] ss-[] ss-[] = [] , [] , ss-[] , ss-[] , ss-[] 215 | ssplit-join (ss-both ss) (ss-both ss₁) (ss-both ss₂) with ssplit-join ss ss₁ ss₂ 216 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = nothing ∷ G₁' , nothing ∷ G₂' , ss-both ss-12 , ss-both ss-1121 , ss-both ss-2122 217 | ssplit-join (ss-left ss) (ss-left ss₁) (ss-both ss₂) with ssplit-join ss ss₁ ss₂ 218 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , nothing ∷ G₂' , ss-left ss-12 , ss-left ss-1121 , ss-both ss-2122 219 | ssplit-join (ss-left ss) (ss-right ss₁) (ss-both ss₂) with ssplit-join ss ss₁ ss₂ 220 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = nothing ∷ G₁' , 221 | just _ ∷ G₂' , 222 | ss-right ss-12 , ss-both ss-1121 , ss-left ss-2122 223 | ssplit-join (ss-left ss) (ss-posneg ss₁) (ss-both ss₂) with ssplit-join ss ss₁ ss₂ 224 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , just _ ∷ G₂' , ss-posneg ss-12 , ss-left ss-1121 , ss-left ss-2122 225 | ssplit-join (ss-left ss) (ss-negpos ss₁) (ss-both ss₂) with ssplit-join ss ss₁ ss₂ 226 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , just _ ∷ G₂' , ss-negpos ss-12 , ss-left ss-1121 , ss-left ss-2122 227 | ssplit-join (ss-right ss) (ss-both ss₁) (ss-left ss₂) with ssplit-join ss ss₁ ss₂ 228 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , 229 | nothing ∷ G₂' , ss-left ss-12 , ss-right ss-1121 , ss-both ss-2122 230 | ssplit-join (ss-right ss) (ss-both ss₁) (ss-right ss₂) with ssplit-join ss ss₁ ss₂ 231 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = nothing ∷ G₁' , 232 | just _ ∷ G₂' , 233 | ss-right ss-12 , ss-both ss-1121 , ss-right ss-2122 234 | ssplit-join (ss-right ss) (ss-both ss₁) (ss-posneg ss₂) with ssplit-join ss ss₁ ss₂ 235 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , just _ ∷ G₂' , ss-posneg ss-12 , ss-right ss-1121 , ss-right ss-2122 236 | ssplit-join (ss-right ss) (ss-both ss₁) (ss-negpos ss₂) with ssplit-join ss ss₁ ss₂ 237 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , just _ ∷ G₂' , ss-negpos ss-12 , ss-right ss-1121 , ss-right ss-2122 238 | ssplit-join (ss-posneg ss) (ss-left ss₁) (ss-left ss₂) with ssplit-join ss ss₁ ss₂ 239 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , nothing ∷ G₂' , ss-left ss-12 , ss-posneg ss-1121 , ss-both ss-2122 240 | ssplit-join (ss-posneg ss) (ss-left ss₁) (ss-right ss₂) with ssplit-join ss ss₁ ss₂ 241 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , just _ ∷ G₂' , ss-posneg ss-12 , ss-left ss-1121 , ss-right ss-2122 242 | ssplit-join (ss-posneg ss) (ss-right ss₁) (ss-left ss₂) with ssplit-join ss ss₁ ss₂ 243 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , just _ ∷ G₂' , ss-negpos ss-12 , ss-right ss-1121 , ss-left ss-2122 244 | ssplit-join (ss-posneg ss) (ss-right ss₁) (ss-right ss₂) with ssplit-join ss ss₁ ss₂ 245 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = nothing ∷ G₁' , 246 | just (_ , POSNEG) ∷ G₂' , 247 | ss-right ss-12 , ss-both ss-1121 , ss-posneg ss-2122 248 | ssplit-join (ss-negpos ss) (ss-left ss₁) (ss-left ss₂) with ssplit-join ss ss₁ ss₂ 249 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , nothing ∷ G₂' , ss-left ss-12 , ss-negpos ss-1121 , ss-both ss-2122 250 | ssplit-join (ss-negpos ss) (ss-left ss₁) (ss-right ss₂) with ssplit-join ss ss₁ ss₂ 251 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , just _ ∷ G₂' , ss-negpos ss-12 , ss-left ss-1121 , ss-right ss-2122 252 | ssplit-join (ss-negpos ss) (ss-right ss₁) (ss-left ss₂) with ssplit-join ss ss₁ ss₂ 253 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = just _ ∷ G₁' , just _ ∷ G₂' , ss-posneg ss-12 , ss-right ss-1121 , ss-left ss-2122 254 | ssplit-join (ss-negpos ss) (ss-right ss₁) (ss-right ss₂) with ssplit-join ss ss₁ ss₂ 255 | ... | G₁' , G₂' , ss-12 , ss-1121 , ss-2122 = nothing ∷ G₁' , 256 | just (_ , POSNEG) ∷ G₂' , 257 | ss-right ss-12 , ss-both ss-1121 , ss-negpos ss-2122 258 | 259 | -- another rotation 260 | ssplit-rotate : ∀ {G G1 G2 G21 G22 G211 G212 : SCtx} 261 | → SSplit G G1 G2 262 | → SSplit G2 G21 G22 263 | → SSplit G21 G211 G212 264 | → ∃ λ G2' 265 | → ∃ λ G21' 266 | → SSplit G G211 G2' × SSplit G2' G21' G22 × SSplit G21' G1 G212 267 | ssplit-rotate ss-[] ss-[] ss-[] = 268 | [] , [] , ss-[] , ss-[] , ss-[] 269 | ssplit-rotate (ss-both ss-g12) (ss-both ss-g2122) (ss-both ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 270 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 271 | nothing ∷ G2' , nothing ∷ G21' , (ss-both ss-g12') , (ss-both ss-g2122') , (ss-both ss-g211212') 272 | ssplit-rotate (ss-left ss-g12) (ss-both ss-g2122) (ss-both ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 273 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 274 | _ , _ , (ss-right ss-g12') , ss-left ss-g2122' , ss-left ss-g211212' 275 | ssplit-rotate (ss-right ss-g12) (ss-left ss-g2122) (ss-left ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 276 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 277 | _ , _ , ss-left ss-g12' , ss-both ss-g2122' , ss-both ss-g211212' 278 | ssplit-rotate (ss-right ss-g12) (ss-left ss-g2122) (ss-right ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 279 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 280 | _ , _ , ss-right ss-g12' , ss-left ss-g2122' , ss-right ss-g211212' 281 | ssplit-rotate (ss-right ss-g12) (ss-left ss-g2122) (ss-posneg ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 282 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 283 | _ , _ , ss-posneg ss-g12' , ss-left ss-g2122' , ss-right ss-g211212' 284 | ssplit-rotate (ss-right ss-g12) (ss-left ss-g2122) (ss-negpos ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 285 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 286 | _ , _ , ss-negpos ss-g12' , ss-left ss-g2122' , ss-right ss-g211212' 287 | ssplit-rotate (ss-right ss-g12) (ss-right ss-g2122) (ss-both ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 288 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 289 | _ , _ , ss-right ss-g12' , ss-right ss-g2122' , ss-both ss-g211212' 290 | ssplit-rotate (ss-right ss-g12) (ss-posneg ss-g2122) (ss-left ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 291 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 292 | _ , _ , ss-posneg ss-g12' , ss-right ss-g2122' , ss-both ss-g211212' 293 | ssplit-rotate (ss-right ss-g12) (ss-posneg ss-g2122) (ss-right ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 294 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 295 | _ , _ , ss-right ss-g12' , ss-posneg ss-g2122' , ss-right ss-g211212' 296 | ssplit-rotate (ss-right ss-g12) (ss-negpos ss-g2122) (ss-left ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 297 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 298 | _ , _ , ss-negpos ss-g12' , ss-right ss-g2122' , ss-both ss-g211212' 299 | ssplit-rotate (ss-right ss-g12) (ss-negpos ss-g2122) (ss-right ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 300 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 301 | _ , _ , ss-right ss-g12' , ss-negpos ss-g2122' , ss-right ss-g211212' 302 | ssplit-rotate (ss-posneg ss-g12) (ss-left ss-g2122) (ss-left ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 303 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 304 | _ , _ , ss-negpos ss-g12' , ss-left ss-g2122' , ss-left ss-g211212' 305 | ssplit-rotate (ss-posneg ss-g12) (ss-left ss-g2122) (ss-right ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 306 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 307 | _ , _ , ss-right ss-g12' , ss-left ss-g2122' , ss-posneg ss-g211212' 308 | ssplit-rotate (ss-posneg ss-g12) (ss-right ss-g2122) (ss-both ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 309 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 310 | _ , _ , ss-right ss-g12' , ss-posneg ss-g2122' , ss-left ss-g211212' 311 | ssplit-rotate (ss-negpos ss-g12) (ss-left ss-g2122) (ss-left ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 312 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 313 | _ , _ , ss-posneg ss-g12' , ss-left ss-g2122' , ss-left ss-g211212' 314 | ssplit-rotate (ss-negpos ss-g12) (ss-left ss-g2122) (ss-right ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 315 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 316 | _ , _ , ss-right ss-g12' , ss-left ss-g2122' , ss-negpos ss-g211212' 317 | ssplit-rotate (ss-negpos ss-g12) (ss-right ss-g2122) (ss-both ss-g211212) with ssplit-rotate ss-g12 ss-g2122 ss-g211212 318 | ... | G2' , G21' , ss-g12' , ss-g2122' , ss-g211212' = 319 | _ , _ , ss-right ss-g12' , ss-negpos ss-g2122' , ss-left ss-g211212' 320 | 321 | -- a session context is inactive if all its entries are void 322 | data Inactive : (G : SCtx) → Set where 323 | []-inactive : Inactive [] 324 | ::-inactive : ∀ {G : SCtx} → Inactive G → Inactive (nothing ∷ G) 325 | 326 | inactive-ssplit-trivial : ∀ {G} → Inactive G → SSplit G G G 327 | inactive-ssplit-trivial []-inactive = ss-[] 328 | inactive-ssplit-trivial (::-inactive ina) = ss-both (inactive-ssplit-trivial ina) 329 | 330 | ssplit-inactive : ∀ {G G₁ G₂} → SSplit G G₁ G₂ → Inactive G₁ → Inactive G₂ → Inactive G 331 | ssplit-inactive ss-[] []-inactive []-inactive = []-inactive 332 | ssplit-inactive (ss-both ssp) (::-inactive ina1) (::-inactive ina2) = ::-inactive (ssplit-inactive ssp ina1 ina2) 333 | ssplit-inactive (ss-left ssp) () ina2 334 | ssplit-inactive (ss-right ssp) ina1 () 335 | ssplit-inactive (ss-posneg ssp) () ina2 336 | ssplit-inactive (ss-negpos ssp) ina1 () 337 | 338 | ssplit-inactive-left : ∀ {G G'} → SSplit G G G' → Inactive G' 339 | ssplit-inactive-left ss-[] = []-inactive 340 | ssplit-inactive-left (ss-both ssp) = ::-inactive (ssplit-inactive-left ssp) 341 | ssplit-inactive-left (ss-left ssp) = ::-inactive (ssplit-inactive-left ssp) 342 | 343 | ssplit-refl-left : (G : SCtx) → Σ SCtx λ G' → SSplit G G G' 344 | ssplit-refl-left [] = [] , ss-[] 345 | ssplit-refl-left (just x ∷ G) with ssplit-refl-left G 346 | ... | G' , ssp' = nothing ∷ G' , ss-left ssp' 347 | ssplit-refl-left (nothing ∷ G) with ssplit-refl-left G 348 | ... | G' , ssp' = nothing ∷ G' , ss-both ssp' 349 | 350 | ssplit-refl-left-inactive : (G : SCtx) → Σ SCtx λ G' → Inactive G' × SSplit G G G' 351 | ssplit-refl-left-inactive [] = [] , []-inactive , ss-[] 352 | ssplit-refl-left-inactive (x ∷ G) with ssplit-refl-left-inactive G 353 | ssplit-refl-left-inactive (just x ∷ G) | G' , ina-G' , ss-GG' = nothing ∷ G' , ::-inactive ina-G' , ss-left ss-GG' 354 | ssplit-refl-left-inactive (nothing ∷ G) | G' , ina-G' , ss-GG' = nothing ∷ G' , ::-inactive ina-G' , ss-both ss-GG' 355 | 356 | ssplit-inactive-right : ∀ {G G'} → SSplit G G' G → Inactive G' 357 | ssplit-inactive-right ss-[] = []-inactive 358 | ssplit-inactive-right (ss-both ss) = ::-inactive (ssplit-inactive-right ss) 359 | ssplit-inactive-right (ss-right ss) = ::-inactive (ssplit-inactive-right ss) 360 | 361 | ssplit-refl-right : (G : SCtx) → Σ SCtx λ G' → SSplit G G' G 362 | ssplit-refl-right [] = [] , ss-[] 363 | ssplit-refl-right (just x ∷ G) with ssplit-refl-right G 364 | ... | G' , ssp' = nothing ∷ G' , ss-right ssp' 365 | ssplit-refl-right (nothing ∷ G) with ssplit-refl-right G 366 | ... | G' , ssp' = nothing ∷ G' , ss-both ssp' 367 | 368 | ssplit-refl-right-inactive : (G : SCtx) → Σ SCtx λ G' → Inactive G' × SSplit G G' G 369 | ssplit-refl-right-inactive [] = [] , []-inactive , ss-[] 370 | ssplit-refl-right-inactive (x ∷ G) with ssplit-refl-right-inactive G 371 | ssplit-refl-right-inactive (just x ∷ G) | G' , ina-G' , ssp' = nothing ∷ G' , ::-inactive ina-G' , ss-right ssp' 372 | ssplit-refl-right-inactive (nothing ∷ G) | G' , ina-G' , ssp' = nothing ∷ G' , ::-inactive ina-G' , ss-both ssp' 373 | 374 | inactive-left-ssplit : ∀ {G G₁ G₂} → SSplit G G₁ G₂ → Inactive G₁ → G ≡ G₂ 375 | inactive-left-ssplit ss-[] []-inactive = refl 376 | inactive-left-ssplit (ss-both ss) (::-inactive inG₁) = 377 | cong (_∷_ nothing) (inactive-left-ssplit ss inG₁) 378 | inactive-left-ssplit (ss-right ss) (::-inactive inG₁) = 379 | cong (_∷_ (just _)) (inactive-left-ssplit ss inG₁) 380 | 381 | inactive-right-ssplit : ∀ {G G₁ G₂} → SSplit G G₁ G₂ → Inactive G₂ → G ≡ G₁ 382 | inactive-right-ssplit ss-[] []-inactive = refl 383 | inactive-right-ssplit (ss-both ssp) (::-inactive ina) = 384 | cong (_∷_ nothing) (inactive-right-ssplit ssp ina) 385 | inactive-right-ssplit (ss-left ssp) (::-inactive ina) = 386 | cong (_∷_ (just _)) (inactive-right-ssplit ssp ina) 387 | 388 | inactive-right-ssplit-sym : ∀ {G G₁ G₂} → SSplit G G₁ G₂ → Inactive G₂ → G₁ ≡ G 389 | inactive-right-ssplit-sym ssp ina = sym (inactive-right-ssplit ssp ina) 390 | 391 | inactive-right-ssplit-transform : ∀ {G G₁ G₂} → SSplit G G₁ G₂ → Inactive G₂ → SSplit G G G₂ 392 | inactive-right-ssplit-transform ss-[] []-inactive = ss-[] 393 | inactive-right-ssplit-transform (ss-both ss-GG1G2) (::-inactive ina-G2) = ss-both (inactive-right-ssplit-transform ss-GG1G2 ina-G2) 394 | inactive-right-ssplit-transform (ss-left ss-GG1G2) (::-inactive ina-G2) = ss-left (inactive-right-ssplit-transform ss-GG1G2 ina-G2) 395 | inactive-right-ssplit-transform (ss-right ss-GG1G2) () 396 | inactive-right-ssplit-transform (ss-posneg ss-GG1G2) () 397 | inactive-right-ssplit-transform (ss-negpos ss-GG1G2) () 398 | 399 | ssplit-function : ∀ {G G' G₁ G₂} → SSplit G G₁ G₂ → SSplit G' G₁ G₂ → G ≡ G' 400 | ssplit-function ss-[] ss-[] = refl 401 | ssplit-function (ss-both ssp-GG1G2) (ss-both ssp-G'G1G2) = 402 | cong (_∷_ nothing) (ssplit-function ssp-GG1G2 ssp-G'G1G2) 403 | ssplit-function (ss-left ssp-GG1G2) (ss-left ssp-G'G1G2) = 404 | cong (_∷_ (just _)) (ssplit-function ssp-GG1G2 ssp-G'G1G2) 405 | ssplit-function (ss-right ssp-GG1G2) (ss-right ssp-G'G1G2) = 406 | cong (_∷_ (just _)) (ssplit-function ssp-GG1G2 ssp-G'G1G2) 407 | ssplit-function (ss-posneg ssp-GG1G2) (ss-posneg ssp-G'G1G2) = 408 | cong (_∷_ (just _)) (ssplit-function ssp-GG1G2 ssp-G'G1G2) 409 | ssplit-function (ss-negpos ssp-GG1G2) (ss-negpos ssp-G'G1G2) = 410 | cong (_∷_ (just _)) (ssplit-function ssp-GG1G2 ssp-G'G1G2) 411 | 412 | ssplit-function1 : ∀ {G G₁ G₁' G₂} → SSplit G G₁ G₂ → SSplit G G₁' G₂ → G₁ ≡ G₁' 413 | ssplit-function1 ss-[] ss-[] = refl 414 | ssplit-function1 (ss-both ssp-GG1G2) (ss-both ssp-GG1'G2) = 415 | cong (_∷_ nothing) (ssplit-function1 ssp-GG1G2 ssp-GG1'G2) 416 | ssplit-function1 (ss-left ssp-GG1G2) (ss-left ssp-GG1'G2) = 417 | cong (_∷_ (just _)) (ssplit-function1 ssp-GG1G2 ssp-GG1'G2) 418 | ssplit-function1 (ss-right ssp-GG1G2) (ss-right ssp-GG1'G2) = 419 | cong (_∷_ nothing) (ssplit-function1 ssp-GG1G2 ssp-GG1'G2) 420 | ssplit-function1 (ss-posneg ssp-GG1G2) (ss-posneg ssp-GG1'G2) = 421 | cong (_∷_ (just _)) (ssplit-function1 ssp-GG1G2 ssp-GG1'G2) 422 | ssplit-function1 (ss-negpos ssp-GG1G2) (ss-negpos ssp-GG1'G2) = 423 | cong (_∷_ (just _)) (ssplit-function1 ssp-GG1G2 ssp-GG1'G2) 424 | 425 | ssplit-function2 : ∀ {G G₁ G₂ G₂'} → SSplit G G₁ G₂ → SSplit G G₁ G₂' → G₂ ≡ G₂' 426 | ssplit-function2 ss-[] ss-[] = refl 427 | ssplit-function2 (ss-both ssp-GG1G2) (ss-both ssp-GG1G2') = 428 | cong (_∷_ nothing) (ssplit-function2 ssp-GG1G2 ssp-GG1G2') 429 | ssplit-function2 (ss-left ssp-GG1G2) (ss-left ssp-GG1G2') = 430 | cong (_∷_ nothing) (ssplit-function2 ssp-GG1G2 ssp-GG1G2') 431 | ssplit-function2 (ss-right ssp-GG1G2) (ss-right ssp-GG1G2') = 432 | cong (_∷_ (just _)) (ssplit-function2 ssp-GG1G2 ssp-GG1G2') 433 | ssplit-function2 (ss-posneg ssp-GG1G2) (ss-posneg ssp-GG1G2') = 434 | cong (_∷_ (just _)) (ssplit-function2 ssp-GG1G2 ssp-GG1G2') 435 | ssplit-function2 (ss-negpos ssp-GG1G2) (ss-negpos ssp-GG1G2') = 436 | cong (_∷_ (just _)) (ssplit-function2 ssp-GG1G2 ssp-GG1G2') 437 | -------------------------------------------------------------------------------- /src/ProcessRun.agda: -------------------------------------------------------------------------------- 1 | module ProcessRun where 2 | 3 | open import Data.Bool 4 | open import Data.List 5 | open import Data.Maybe 6 | open import Data.Product 7 | 8 | open import Relation.Binary.PropositionalEquality 9 | 10 | open import Typing 11 | open import ProcessSyntax 12 | 13 | open import Channel 14 | open import Global 15 | open import Values 16 | open import Session 17 | open import Schedule 18 | 19 | -- auxiliary lemmas 20 | list-right-zero : ∀ {A : Set} → (xs : List A) → xs ++ [] ≡ xs 21 | list-right-zero [] = refl 22 | list-right-zero (x ∷ xs) = cong (_∷_ x) (list-right-zero xs) 23 | 24 | list-assoc : ∀ {A : Set} → (xs ys zs : List A) → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs) 25 | list-assoc [] ys zs = refl 26 | list-assoc (x ∷ xs) ys zs = cong (_∷_ x) (list-assoc xs ys zs) 27 | 28 | cons-assoc : ∀ {A : Set} → (x : A) (xs ys : List A) → (x ∷ xs) ++ ys ≡ x ∷ (xs ++ ys) 29 | cons-assoc x xs ys = refl 30 | 31 | inactive-clone : (G : SCtx) → SCtx 32 | inactive-clone [] = [] 33 | inactive-clone (x ∷ G) = nothing ∷ inactive-clone G 34 | 35 | inactive-extension : ∀ {G} → Inactive G → (G' : SCtx) → Inactive (inactive-clone G' ++ G) 36 | inactive-extension inaG [] = inaG 37 | inactive-extension inaG (x ∷ G') = ::-inactive (inactive-extension inaG G') 38 | 39 | splitting-extension : ∀ {G G₁ G₂} (G' : SCtx) 40 | → SSplit G G₁ G₂ → SSplit (inactive-clone G' ++ G) (inactive-clone G' ++ G₁) (inactive-clone G' ++ G₂) 41 | splitting-extension [] ss = ss 42 | splitting-extension (x ∷ G') ss = ss-both (splitting-extension G' ss) 43 | 44 | left-right : (G' G'' : SCtx) 45 | → SSplit (G' ++ G'') (G' ++ inactive-clone G'') (inactive-clone G' ++ G'') 46 | left-right [] [] = ss-[] 47 | left-right [] (just x ∷ G'') = ss-right (left-right [] G'') 48 | left-right [] (nothing ∷ G'') = ss-both (left-right [] G'') 49 | left-right (x ∷ G') G'' with left-right G' G'' 50 | ... | ss-G'G'' with x 51 | left-right (x ∷ G') G'' | ss-G'G'' | just x₁ = ss-left ss-G'G'' 52 | left-right (x ∷ G') G'' | ss-G'G'' | nothing = ss-both ss-G'G'' 53 | 54 | ssplit-append : { G11 G12 G21 G22 : SCtx} (G1 G2 : SCtx) → SSplit G1 G11 G12 → SSplit G2 G21 G22 → SSplit (G1 ++ G2) (G11 ++ G21) (G12 ++ G22) 55 | ssplit-append _ _ ss-[] ss2 = ss2 56 | ssplit-append _ _ (ss-both ss1) ss2 = ss-both (ssplit-append _ _ ss1 ss2) 57 | ssplit-append _ _ (ss-left ss1) ss2 = ss-left (ssplit-append _ _ ss1 ss2) 58 | ssplit-append _ _ (ss-right ss1) ss2 = ss-right (ssplit-append _ _ ss1 ss2) 59 | ssplit-append _ _ (ss-posneg ss1) ss2 = ss-posneg (ssplit-append _ _ ss1 ss2) 60 | ssplit-append _ _ (ss-negpos ss1) ss2 = ss-negpos (ssplit-append _ _ ss1 ss2) 61 | 62 | -- weakening #1 63 | weaken1-cr : ∀ {G b s} G' → ChannelRef G b s → ChannelRef (inactive-clone G' ++ G) b s 64 | weaken1-cr [] cr = cr 65 | weaken1-cr (x ∷ G') cr = there (weaken1-cr G' cr) 66 | 67 | weaken1-val : ∀ {G t} G' → Val G t → Val (inactive-clone G' ++ G) t 68 | weaken1-venv : ∀ {G Φ} G' → VEnv G Φ → VEnv (inactive-clone G' ++ G) Φ 69 | 70 | weaken1-val G' (VUnit inaG) = VUnit (inactive-extension inaG G') 71 | weaken1-val G' (VInt i inaG) = VInt i (inactive-extension inaG G') 72 | weaken1-val G' (VPair ss-GG₁G₂ v v₁) = VPair (splitting-extension G' ss-GG₁G₂) (weaken1-val G' v) (weaken1-val G' v₁) 73 | weaken1-val G' (VChan b vcr) = VChan b (weaken1-cr G' vcr) 74 | weaken1-val G' (VFun x ϱ e) = VFun x (weaken1-venv G' ϱ) e 75 | weaken1-venv G' (vnil ina) = vnil (inactive-extension ina G') 76 | weaken1-venv G' (vcons ssp v ϱ) = vcons (splitting-extension G' ssp) (weaken1-val G' v) (weaken1-venv G' ϱ) 77 | 78 | weaken1-cont : ∀ {G t φ} G' → Cont G φ t → Cont (inactive-clone G' ++ G) φ t 79 | weaken1-cont G' (halt inaG un-t) = halt (inactive-extension inaG G') un-t 80 | weaken1-cont G' (bind ts ss e₂ ϱ₂ κ) = bind ts (splitting-extension G' ss) e₂ (weaken1-venv G' ϱ₂) (weaken1-cont G' κ) 81 | weaken1-cont G' (bind-thunk ts ss e₂ ϱ₂ κ) = bind-thunk ts (splitting-extension G' ss) e₂ (weaken1-venv G' ϱ₂) (weaken1-cont G' κ) 82 | weaken1-cont G' (subsume x κ) = subsume x (weaken1-cont G' κ) 83 | 84 | weaken1-command : ∀ {G} G' → Command G → Command (inactive-clone G' ++ G) 85 | weaken1-command G' (Fork ss κ₁ κ₂) = Fork (splitting-extension G' ss) (weaken1-cont G' κ₁) (weaken1-cont G' κ₂) 86 | weaken1-command G' (Ready ss v κ) = Ready (splitting-extension G' ss) (weaken1-val G' v) (weaken1-cont G' κ) 87 | weaken1-command G' (Halt x x₁ x₂) = Halt (inactive-extension x G') x₁ (weaken1-val G' x₂) 88 | weaken1-command G' (New s κ) = New s (weaken1-cont G' κ) 89 | weaken1-command G' (Close ss v κ) = Close (splitting-extension G' ss) (weaken1-val G' v) (weaken1-cont G' κ) 90 | weaken1-command G' (Wait ss v κ) = Wait (splitting-extension G' ss) (weaken1-val G' v) (weaken1-cont G' κ) 91 | weaken1-command G' (Send ss ss-args vch v κ) = Send (splitting-extension G' ss) (splitting-extension G' ss-args) (weaken1-val G' vch) (weaken1-val G' v) (weaken1-cont G' κ) 92 | weaken1-command G' (Recv ss vch κ) = Recv (splitting-extension G' ss) (weaken1-val G' vch) (weaken1-cont G' κ) 93 | weaken1-command G' (Select ss lab vch κ) = Select (splitting-extension G' ss) lab (weaken1-val G' vch) (weaken1-cont G' κ) 94 | weaken1-command G' (Branch ss vch dcont) = Branch (splitting-extension G' ss) (weaken1-val G' vch) λ lab → weaken1-cont G' (dcont lab) 95 | weaken1-command G' (NSelect ss lab vch κ) = NSelect (splitting-extension G' ss) lab (weaken1-val G' vch) (weaken1-cont G' κ) 96 | weaken1-command G' (NBranch ss vch dcont) = NBranch (splitting-extension G' ss) (weaken1-val G' vch) λ lab → weaken1-cont G' (dcont lab) 97 | 98 | weaken1-threadpool : ∀ {G} G' → ThreadPool G → ThreadPool (inactive-clone G' ++ G) 99 | weaken1-threadpool G' (tnil ina) = tnil (inactive-extension ina G') 100 | weaken1-threadpool G' (tcons ss cmd tp) = tcons (splitting-extension G' ss) (weaken1-command G' cmd) (weaken1-threadpool G' tp) 101 | 102 | -- auxiliary 103 | 104 | inactive-insertion : ∀ {G} G' G'' → Inactive (G' ++ G) → Inactive (G' ++ inactive-clone G'' ++ G) 105 | inactive-insertion [] G'' ina-G'G = inactive-extension ina-G'G G'' 106 | inactive-insertion (just x ∷ G') G'' () 107 | inactive-insertion (nothing ∷ G') G'' (::-inactive ina-G'G) = ::-inactive (inactive-insertion G' G'' ina-G'G) 108 | 109 | splitting-insertion : ∀ {G G₁ G₂} {G' G₁' G₂'} G'' 110 | → SSplit G' G₁' G₂' 111 | → SSplit G G₁ G₂ 112 | → SSplit (G' ++ inactive-clone G'' ++ G) (G₁' ++ inactive-clone G'' ++ G₁) (G₂' ++ inactive-clone G'' ++ G₂) 113 | splitting-insertion G'' ss-[] ss = splitting-extension G'' ss 114 | splitting-insertion G'' (ss-both ss') ss = ss-both (splitting-insertion G'' ss' ss) 115 | splitting-insertion G'' (ss-left ss') ss = ss-left (splitting-insertion G'' ss' ss) 116 | splitting-insertion G'' (ss-right ss') ss = ss-right (splitting-insertion G'' ss' ss) 117 | splitting-insertion G'' (ss-posneg ss') ss = ss-posneg (splitting-insertion G'' ss' ss) 118 | splitting-insertion G'' (ss-negpos ss') ss = ss-negpos (splitting-insertion G'' ss' ss) 119 | 120 | split-append : ∀ {G G1 G2} G' 121 | → SSplit (G' ++ G) G1 G2 122 | → ∃ λ G₁' → ∃ λ G₂' → ∃ λ G₁ → ∃ λ G₂ 123 | → SSplit G' G₁' G₂' × SSplit G G₁ G₂ × G1 ≡ G₁' ++ G₁ × G2 ≡ G₂' ++ G₂ 124 | split-append [] ss = _ , _ , _ , _ , ss-[] , ss , refl , refl 125 | split-append (.nothing ∷ G') (ss-both ss) with split-append G' ss 126 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = _ , _ , _ , _ , (ss-both ss') , ss0 , refl , refl 127 | split-append (.(just _) ∷ G') (ss-left ss) with split-append G' ss 128 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = _ , _ , _ , _ , (ss-left ss') , ss0 , refl , refl 129 | split-append (.(just _) ∷ G') (ss-right ss) with split-append G' ss 130 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = _ , _ , _ , _ , (ss-right ss') , ss0 , refl , refl 131 | split-append (.(just (_ , POSNEG)) ∷ G') (ss-posneg ss) with split-append G' ss 132 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = _ , _ , _ , _ , (ss-posneg ss') , ss0 , refl , refl 133 | split-append (.(just (_ , POSNEG)) ∷ G') (ss-negpos ss) with split-append G' ss 134 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = _ , _ , _ , _ , (ss-negpos ss') , ss0 , refl , refl 135 | 136 | -- weakening #2 137 | 138 | weaken2-cr : ∀ {G b s} G' G'' → ChannelRef (G' ++ G) b s → ChannelRef (G' ++ inactive-clone G'' ++ G) b s 139 | weaken2-cr [] G'' cr = weaken1-cr G'' cr 140 | weaken2-cr (.(just (_ , POS)) ∷ G') G'' (here-pos ina-G x) = here-pos (inactive-insertion G' G'' ina-G) x 141 | weaken2-cr (.(just (_ , NEG)) ∷ G') G'' (here-neg ina-G x) = here-neg (inactive-insertion G' G'' ina-G) x 142 | weaken2-cr (.nothing ∷ G') G'' (there cr) = there (weaken2-cr G' G'' cr) 143 | 144 | weaken2-val : ∀ {G t} G' G'' → Val (G' ++ G) t → Val (G' ++ inactive-clone G'' ++ G) t 145 | weaken2-venv : ∀ {G Φ} G' G'' → VEnv (G' ++ G) Φ → VEnv (G' ++ inactive-clone G'' ++ G) Φ 146 | 147 | weaken2-val G' G'' (VUnit inaG) = VUnit (inactive-insertion G' G'' inaG) 148 | weaken2-val G' G'' (VInt i inaG) = VInt i (inactive-insertion G' G'' inaG) 149 | weaken2-val G' G'' (VPair ss-GG₁G₂ v₁ v₂) with split-append G' ss-GG₁G₂ 150 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = VPair (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' v₁) (weaken2-val G₂' G'' v₂) 151 | weaken2-val G' G'' (VChan b vcr) = VChan b (weaken2-cr G' G'' vcr) 152 | weaken2-val G' G'' (VFun x ϱ e) = VFun x (weaken2-venv G' G'' ϱ) e 153 | 154 | weaken2-venv G' G'' (vnil ina) = vnil (inactive-insertion G' G'' ina) 155 | weaken2-venv G' G'' (vcons{G₁ = Gv}{G₂ = Gϱ} ssp v ϱ) with split-append G' ssp 156 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = vcons (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' v) (weaken2-venv G₂' G'' ϱ) 157 | 158 | weaken2-cont : ∀ {G t φ} G' G'' → Cont (G' ++ G) φ t → Cont (G' ++ inactive-clone G'' ++ G) φ t 159 | weaken2-cont G' G'' (halt x un-t) = halt (inactive-insertion G' G'' x) un-t 160 | weaken2-cont G' G'' (bind ts ss e₂ ϱ₂ κ) with split-append G' ss 161 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = bind ts (splitting-insertion G'' ss' ss0) e₂ (weaken2-venv G₁' G'' ϱ₂) (weaken2-cont G₂' G'' κ) 162 | weaken2-cont G' G'' (bind-thunk ts ss e₂ ϱ₂ κ) with split-append G' ss 163 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = bind-thunk ts (splitting-insertion G'' ss' ss0) e₂ (weaken2-venv G₁' G'' ϱ₂) (weaken2-cont G₂' G'' κ) 164 | weaken2-cont G' G'' (subsume x κ) = subsume x (weaken2-cont G' G'' κ) 165 | 166 | weaken2-command : ∀ {G} G' G'' → Command (G' ++ G) → Command (G' ++ inactive-clone G'' ++ G) 167 | weaken2-command G' G'' (Fork ss κ₁ κ₂) with split-append G' ss 168 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Fork (splitting-insertion G'' ss' ss0) (weaken2-cont G₁' G'' κ₁) (weaken2-cont G₂' G'' κ₂) 169 | weaken2-command G' G'' (Ready ss v κ) with split-append G' ss 170 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Ready (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' v) (weaken2-cont G₂' G'' κ) 171 | weaken2-command G' G'' (Halt x x₁ x₂) = Halt (inactive-insertion G' G'' x) x₁ (weaken2-val G' G'' x₂) 172 | weaken2-command G' G'' (New s κ) = New s (weaken2-cont G' G'' κ) 173 | weaken2-command G' G'' (Close ss v κ) with split-append G' ss 174 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Close (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' v) (weaken2-cont G₂' G'' κ) 175 | weaken2-command G' G'' (Wait ss v κ) with split-append G' ss 176 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Wait (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' v) (weaken2-cont G₂' G'' κ) 177 | weaken2-command G' G'' (Send ss ss-args vch v κ) with split-append G' ss 178 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl with split-append G₁' ss-args 179 | ... | G₁₁' , G₁₂' , G₁₁ , G₁₂ , ss-args' , ss0-args , refl , refl = Send (splitting-insertion G'' ss' ss0) (splitting-insertion G'' ss-args' ss0-args) (weaken2-val G₁₁' G'' vch) (weaken2-val G₁₂' G'' v) (weaken2-cont G₂' G'' κ) 180 | weaken2-command G' G'' (Recv ss vch κ) with split-append G' ss 181 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Recv (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' vch) (weaken2-cont G₂' G'' κ) 182 | weaken2-command G' G'' (Select ss lab vch κ) with split-append G' ss 183 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Select (splitting-insertion G'' ss' ss0) lab (weaken2-val G₁' G'' vch) (weaken2-cont G₂' G'' κ) 184 | weaken2-command G' G'' (Branch ss vch dcont) with split-append G' ss 185 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Branch (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' vch) λ lab → weaken2-cont G₂' G'' (dcont lab) 186 | weaken2-command G' G'' (NSelect ss lab vch κ) with split-append G' ss 187 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = NSelect (splitting-insertion G'' ss' ss0) lab (weaken2-val G₁' G'' vch) (weaken2-cont G₂' G'' κ) 188 | weaken2-command G' G'' (NBranch ss vch dcont) with split-append G' ss 189 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = NBranch (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' vch) λ lab → weaken2-cont G₂' G'' (dcont lab) 190 | 191 | weaken2-threadpool : ∀ {G} G' G'' → ThreadPool (G' ++ G) → ThreadPool (G' ++ inactive-clone G'' ++ G) 192 | weaken2-threadpool G' G'' (tnil ina) = tnil (inactive-insertion G' G'' ina) 193 | weaken2-threadpool G' G'' (tcons ss cmd tp) with split-append G' ss 194 | ... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = tcons (splitting-insertion G'' ss' ss0) (weaken2-command G₁' G'' cmd) (weaken2-threadpool G₂' G'' tp) 195 | 196 | 197 | -- translate a process term to semantics (i.e., a list of commands) 198 | runProc : ∀ {Φ} → (G : SCtx) → Proc Φ → VEnv G Φ → ∃ λ G' → ThreadPool (G' ++ G) 199 | 200 | runProc G (exp e) ϱ with ssplit-refl-left-inactive G 201 | ... | G' , ina-G' , sp-GGG' = [] , (tcons sp-GGG' (run (split-all-left _) sp-GGG' e ϱ (halt ina-G' UUnit)) (tnil ina-G')) 202 | 203 | runProc G (par sp P₁ P₂) ϱ with split-env sp ϱ 204 | ... | (G₁ , G₂) , ss-GG1G2 , ϱ₁ , ϱ₂ with runProc G₁ P₁ ϱ₁ | runProc G₂ P₂ ϱ₂ 205 | ... | (G₁' , tp1) | (G₂' , tp2) with weaken1-threadpool G₁' tp2 206 | ... | tp2' with weaken2-threadpool G₁' G₂' tp1 207 | ... | tp1' with left-right G₁' G₂' 208 | ... | ss-G1'G2' rewrite sym (list-assoc G₁' (inactive-clone G₂') G₁) | sym (list-assoc (inactive-clone G₁') G₂' G₂) = (G₁' ++ G₂') , tappend ssfinal tp1' tp2' 209 | where 210 | ssfinal : SSplit ((G₁' ++ G₂') ++ G) ((G₁' ++ inactive-clone G₂') ++ G₁) ((inactive-clone G₁' ++ G₂') ++ G₂) 211 | ssfinal = ssplit-append (G₁' ++ G₂') G ss-G1'G2' ss-GG1G2 212 | 213 | runProc G (res s P) ϱ with ssplit-refl-right-inactive G 214 | ... | G1 , ina-G1 , ss-GG1G with runProc (just (SType.force s , POSNEG) ∷ G) P (vcons (ss-posneg ss-GG1G) (VChan POS (here-pos ina-G1 (subF-refl _))) (vcons (ss-left ss-GG1G) (VChan NEG (here-neg ina-G1 (subF-refl _))) (lift-venv ϱ))) 215 | ... | G' , tp = G' ++ just (SType.force s , POSNEG) ∷ [] , tp' 216 | where 217 | tp' : ThreadPool ((G' ++ just (SType.force s , POSNEG) ∷ []) ++ G) 218 | tp' rewrite list-assoc G' (just (SType.force s , POSNEG) ∷ []) G = tp 219 | 220 | 221 | startProc : Gas → Proc [] → Outcome 222 | startProc f P with runProc [] P (vnil []-inactive) 223 | ... | G , tp = schedule f tp 224 | 225 | -------------------------------------------------------------------------------- /src/ProcessSyntax.agda: -------------------------------------------------------------------------------- 1 | module ProcessSyntax where 2 | 3 | open import Data.List 4 | 5 | open import Typing 6 | open import Syntax 7 | 8 | -- processes 9 | data Proc (Φ : TCtx) : Set where 10 | exp : (e : Expr Φ TUnit) 11 | → Proc Φ 12 | 13 | par : ∀ {Φ₁ Φ₂} 14 | → (sp : Split Φ Φ₁ Φ₂) 15 | → (P₁ : Proc Φ₁) 16 | → (P₂ : Proc Φ₂) 17 | → Proc Φ 18 | 19 | res : (s : SType) 20 | → (P : Proc (TChan (SType.force s) ∷ TChan (SType.force (dual s)) ∷ Φ)) 21 | → Proc Φ 22 | 23 | -------------------------------------------------------------------------------- /src/Progress.agda: -------------------------------------------------------------------------------- 1 | module Progress where 2 | 3 | open import Data.Bool 4 | open import Data.Empty 5 | open import Data.Maybe hiding (Any ; All) 6 | open import Data.Nat 7 | open import Data.List 8 | open import Data.List.All 9 | open import Data.List.Any 10 | open import Data.Product 11 | open import Data.Unit 12 | 13 | open import Relation.Nullary 14 | open import Relation.Binary.PropositionalEquality 15 | 16 | open import Typing 17 | open import Syntax 18 | open import Global 19 | open import Channel 20 | open import Values 21 | open import Session 22 | open import Schedule 23 | 24 | open import ProcessSyntax 25 | open import ProcessRun 26 | 27 | -- resources appear in pairs 28 | data Paired : SEntry → Set where 29 | aon-nothing : Paired nothing 30 | aon-all : ∀ {s} → Paired (just (s , POSNEG)) 31 | 32 | -- need lemmas for matchXAndGo ... 33 | -- matchXandGo-preserves-paired 34 | 35 | 36 | matchWaitAndGo-preserves-paired : 37 | ∀ {G G₁ G₂ G₁₁ G₁₂ φ G₂₁ G₂₂ Gnext tpnext} 38 | {ss : SSplit G G₁ G₂} 39 | {ss-cl : SSplit G₁ G₁₁ G₁₂} 40 | {v : Val G₁₁ (TChan send!)} 41 | {cl-κ : Cont G₁₂ φ TUnit} 42 | {ss-GG' : SSplit G₂ G₂₁ G₂₂} 43 | → All Paired G 44 | → (tp' : ThreadPool G₂₁) 45 | → (tp'' : ThreadPool G₂₂) 46 | → matchWaitAndGo ss (ss-cl , v , cl-κ) ss-GG' tp' tp'' ≡ just (Gnext , tpnext) 47 | → All Paired Gnext 48 | matchWaitAndGo-preserves-paired all-paired (tnil ina) tp'' () 49 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(Fork ss₁ κ₁ κ₂) tp') tp'' match-≡ 50 | with ssplit-compose5 ss-GG' ss 51 | ... | Gi , ss-tp' , ss' = 52 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 53 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(Ready ss₁ v κ) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss 54 | ... | Gi , ss-tp' , ss' = 55 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 56 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(Halt x x₁ x₂) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss 57 | ... | Gi , ss-tp' , ss' = 58 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 59 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(New s κ) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss 60 | ... | Gi , ss-tp' , ss' = 61 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 62 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(Close ss₁ v κ) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss 63 | ... | Gi , ss-tp' , ss' = 64 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 65 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(Send ss₁ ss-args vch v κ) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss 66 | ... | Gi , ss-tp' , ss' = 67 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 68 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(Recv ss₁ vch κ) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss 69 | ... | Gi , ss-tp' , ss' = 70 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 71 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(Select ss₁ lab vch κ) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss 72 | ... | Gi , ss-tp' , ss' = 73 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 74 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(Branch ss₁ vch dcont) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss 75 | ... | Gi , ss-tp' , ss' = 76 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 77 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(NSelect ss₁ lab vch κ) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss 78 | ... | Gi , ss-tp' , ss' = 79 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 80 | matchWaitAndGo-preserves-paired {ss-GG' = ss-GG'} all-paired (tcons ss cmd@(NBranch ss₁ vch dcont) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss 81 | ... | Gi , ss-tp' , ss' = 82 | matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡ 83 | matchWaitAndGo-preserves-paired {ss = ss-top} {ss-cl = ss-cl} {v = VChan cl-b cl-vcr} {ss-GG' = ss-tp} 84 | all-paired (tcons ss cmd@(Wait ss₁ (VChan w-b w-vcr) κ) tp-wl) tp-acc match-≡ 85 | with ssplit-compose6 ss ss₁ 86 | ... | Gi , ss-g3gi , ss-g4g2 87 | with ssplit-compose6 ss-tp ss-g3gi 88 | ... | Gi' , ss-g3gi' , ss-gtpacc 89 | with ssplit-join ss-top ss-cl ss-g3gi' 90 | ... | Gchannels , Gother , ss-top' , ss-channels , ss-others 91 | with vcr-match ss-channels cl-vcr w-vcr 92 | matchWaitAndGo-preserves-paired {ss = ss-top} {ss-cl} {VChan cl-b cl-vcr} {ss-GG' = ss-tp} all-paired (tcons ss cmd@(Wait ss₁ (VChan w-b w-vcr) κ) tp-wl) tp-acc match-≡ | Gi , ss-g3gi , ss-g4g2 | Gi' , ss-g3gi' , ss-gtpacc | Gchannels , Gother , ss-top' , ss-channels , ss-others | nothing with ssplit-compose5 ss-tp ss 93 | ... | _ , ss-tp' , ss' = 94 | matchWaitAndGo-preserves-paired all-paired tp-wl (tcons ss' cmd tp-acc) match-≡ 95 | matchWaitAndGo-preserves-paired {ss = ss-top} {ss-cl} {VChan cl-b cl-vcr} {ss-GG' = ss-tp} all-paired (tcons ss cmd@(Wait ss₁ (VChan w-b w-vcr) κ) tp-wl) tp-acc refl | Gi , ss-g3gi , ss-g4g2 | Gi' , ss-g3gi' , ss-gtpacc | Gchannels , Gother , ss-top' , ss-channels , ss-others | just x = {!!} 96 | -- remains to prove All Paired Gother 97 | 98 | step-preserves-paired : ∀ {G G' ev tp'} → All Paired G → (tp : ThreadPool G) → Original.step tp ≡ (_,_ {G'} ev tp') → All Paired G' 99 | step-preserves-paired all-paired tp step-≡ with tp 100 | step-preserves-paired all-paired tp refl | tnil ina = all-paired 101 | step-preserves-paired all-paired tp refl | tcons ss (Fork ss₁ κ₁ κ₂) tp' = all-paired 102 | step-preserves-paired all-paired tp refl | tcons ss (Ready ss₁ v κ) tp' = all-paired 103 | step-preserves-paired all-paired tp step-≡ | tcons ss (Halt x x₁ x₂) tp' with inactive-left-ssplit ss x 104 | step-preserves-paired all-paired tp refl | tcons ss (Halt x x₁ x₂) tp' | refl = all-paired 105 | step-preserves-paired all-paired tp refl | tcons ss (New s κ) tp' = aon-all ∷ all-paired 106 | step-preserves-paired all-paired tp step-≡ | tcons{G₁}{G₂} ss (Close ss-vκ v κ) tp' 107 | with ssplit-refl-left-inactive G₂ 108 | ... | G' , ina-G' , ss-GG' 109 | with matchWaitAndGo ss (ss-vκ , v , κ) ss-GG' tp' (tnil ina-G') 110 | step-preserves-paired all-paired tp refl | tcons {G₁} {G₂} ss (Close ss-vκ v κ) tp' | G' , ina-G' , ss-GG' | just (Gnext , tpnext) = matchWaitAndGo-preserves-paired {ss = ss}{ss-cl = ss-vκ}{v = v}{cl-κ = κ}{ss-GG'} all-paired tp' (tnil ina-G') p 111 | where 112 | p : matchWaitAndGo ss (ss-vκ , v , κ) ss-GG' tp' (tnil ina-G') ≡ just (Gnext , tpnext) 113 | p = sym {!refl!} 114 | step-preserves-paired all-paired tp refl | tcons {G₁} {G₂} ss (Close ss-vκ v κ) tp' | G' , ina-G' , ss-GG' | nothing = all-paired 115 | step-preserves-paired all-paired tp refl | tcons ss (Wait ss₁ v κ) tp' = all-paired 116 | step-preserves-paired all-paired tp refl | tcons ss (Send ss₁ ss-args vch v κ) tp' = all-paired 117 | step-preserves-paired all-paired tp step-≡ | tcons{G₁}{G₂} ss (Recv ss-vκ vch κ) tp' with ssplit-refl-left-inactive G₂ 118 | ... | G' , ina-G' , ss-GG' with matchSendAndGo ss (ss-vκ , vch , κ) ss-GG' tp' (tnil ina-G') 119 | ... | just (G-next , tp-next) = {!!} 120 | step-preserves-paired all-paired tp refl | tcons {G₁} {G₂} ss (Recv ss-vκ vch κ) tp' | G' , ina-G' , ss-GG' | nothing = all-paired 121 | step-preserves-paired all-paired tp step-≡ | tcons{G₁}{G₂} ss (Select ss-vκ lab vch κ) tp' with ssplit-refl-left-inactive G₂ 122 | ... | G' , ina-G' , ss-GG' with matchBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp' (tnil ina-G') 123 | ... | just (G-next , tp-next) = {!!} 124 | step-preserves-paired all-paired tp refl | tcons {G₁} {G₂} ss (Select ss-vκ lab vch κ) tp' | G' , ina-G' , ss-GG' | nothing = all-paired 125 | step-preserves-paired all-paired tp refl | tcons ss (Branch ss₁ vch dcont) tp' = all-paired 126 | step-preserves-paired all-paired tp step-≡ | tcons{G₁}{G₂} ss (NSelect ss-vκ lab vch κ) tp' with ssplit-refl-left-inactive G₂ 127 | ... | G' , ina-G' , ss-GG' with matchNBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp' (tnil ina-G') 128 | ... | just (G-next , tp-next) = {!!} 129 | step-preserves-paired all-paired tp refl | tcons {G₁} {G₂} ss (NSelect ss-vκ lab vch κ) tp' | G' , ina-G' , ss-GG' | nothing = all-paired 130 | step-preserves-paired all-paired tp refl | tcons ss (NBranch ss₁ vch dcont) tp' = all-paired 131 | 132 | 133 | -- check if the first thread can make a step 134 | topCanStep : ∀ {G} → ThreadPool G → Set 135 | topCanStep (tnil ina) = ⊥ 136 | topCanStep (tcons ss (Fork ss₁ κ₁ κ₂) tp) = ⊤ 137 | topCanStep (tcons ss (Ready ss₁ v κ) tp) = ⊤ 138 | topCanStep (tcons ss (Halt x x₁ x₂) tp) = ⊤ 139 | topCanStep (tcons ss (New s κ) tp) = ⊤ 140 | topCanStep (tcons{G₁}{G₂} ss (Close ss-vκ v κ) tp) with ssplit-refl-left-inactive G₂ 141 | ... | G' , ina-G' , ss-GG' = Is-just (matchWaitAndGo ss (ss-vκ , v , κ) ss-GG' tp (tnil ina-G')) 142 | topCanStep (tcons ss (Wait ss₁ v κ) tp) = ⊥ 143 | topCanStep (tcons ss (Send ss₁ ss-args vch v κ) tp) = ⊥ 144 | topCanStep (tcons{G₁}{G₂} ss (Recv ss-vκ vch κ) tp) with ssplit-refl-left-inactive G₂ 145 | ... | G' , ina-G' , ss-GG' = Is-just (matchSendAndGo ss (ss-vκ , vch , κ) ss-GG' tp (tnil ina-G')) 146 | topCanStep (tcons{G₁}{G₂} ss (Select ss-vκ lab vch κ) tp) with ssplit-refl-left-inactive G₂ 147 | ... | G' , ina-G' , ss-GG' = Is-just (matchBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp (tnil ina-G')) 148 | topCanStep (tcons ss (Branch ss₁ vch dcont) tp) = ⊥ 149 | topCanStep (tcons{G₁}{G₂} ss (NSelect ss-vκ lab vch κ) tp) with ssplit-refl-left-inactive G₂ 150 | ... | G' , ina-G' , ss-GG' = Is-just (matchNBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp (tnil ina-G')) 151 | topCanStep (tcons ss (NBranch ss₁ vch dcont) tp) = ⊥ 152 | 153 | 154 | tpLength : ∀ {G} → ThreadPool G → ℕ 155 | tpLength (tnil ina) = 0 156 | tpLength (tcons ss cmd tp) = suc (tpLength tp) 157 | 158 | allRotations : ∀ {G} → ThreadPool G → List (ThreadPool G) 159 | allRotations tp = nRotations (tpLength tp) tp 160 | where 161 | rotate : ∀ {G} → ThreadPool G → ThreadPool G 162 | rotate (tnil ina) = tnil ina 163 | rotate (tcons ss cmd tp) = tsnoc ss tp cmd 164 | nRotations : ∀ {G} ℕ → ThreadPool G → List (ThreadPool G) 165 | nRotations zero tp = [] 166 | nRotations (suc n) tp = tp ∷ nRotations n (rotate tp) 167 | 168 | -- the thread pool can step if any command in the pool can make a step 169 | canStep : ∀ {G} → ThreadPool G → Set 170 | canStep tp = Any topCanStep (allRotations tp) 171 | 172 | deadlocked : ∀ {G} → ThreadPool G → Set 173 | deadlocked (tnil ina) = ⊥ 174 | deadlocked tp@(tcons _ _ _) = ¬ canStep tp 175 | 176 | -- progress 177 | -------------------------------------------------------------------------------- /src/Properties.agda: -------------------------------------------------------------------------------- 1 | module Properties where 2 | 3 | open import Data.Bool 4 | open import Data.Empty 5 | open import Data.Maybe hiding (Any ; All) 6 | open import Data.Nat 7 | open import Data.List 8 | open import Data.List.All 9 | open import Data.List.Any 10 | open import Data.Product 11 | open import Data.Sum 12 | open import Data.Unit 13 | 14 | open import Relation.Nullary 15 | open import Relation.Binary.PropositionalEquality 16 | 17 | open import Typing 18 | open import Syntax 19 | open import Global 20 | open import Channel 21 | open import Values 22 | open import Session 23 | open import Schedule 24 | 25 | open import ProcessSyntax 26 | open import ProcessRun 27 | 28 | 29 | -- adequacy 30 | open import Properties.Base 31 | 32 | import Properties.StepBeta 33 | import Properties.StepPair 34 | import Properties.StepFork 35 | import Properties.StepNew 36 | import Properties.StepCloseWait 37 | 38 | -------------------------------------------------------------------------------- /src/Properties/Base.agda: -------------------------------------------------------------------------------- 1 | module Properties.Base where 2 | 3 | open import Data.Maybe hiding (All) 4 | open import Data.List 5 | open import Data.List.All 6 | open import Data.Product 7 | open import Data.Sum 8 | 9 | open import Relation.Nullary 10 | open import Relation.Binary.PropositionalEquality 11 | 12 | open import Typing 13 | open import Global 14 | open import Values 15 | open import Session 16 | open import Schedule 17 | 18 | one-step : ∀ {G} → (∃ λ G' → ThreadPool (G' ++ G)) → Event × (∃ λ G → ThreadPool G) 19 | one-step{G} (G1 , tp) 20 | with ssplit-refl-left-inactive (G1 ++ G) 21 | ... | G' , ina-G' , ss-GG' 22 | with Alternative.step ss-GG' tp (tnil ina-G') 23 | ... | ev , tp' = ev , ( _ , tp') 24 | 25 | restart : ∀ {G} → Command G → Command G 26 | restart (Ready ss v κ) = apply-cont ss κ v 27 | restart cmd = cmd 28 | 29 | -- auxiliary lemmas 30 | 31 | lift-unrestricted : 32 | ∀ {t G} (unrt : Unr t) (v : Val G t) 33 | → unrestricted-val unrt (lift-val v) ≡ ::-inactive (unrestricted-val unrt v) 34 | lift-unrestricted-venv : 35 | ∀ {Φ G} (unrt : All Unr Φ) (ϱ : VEnv G Φ) 36 | → unrestricted-venv unrt (lift-venv ϱ) ≡ ::-inactive (unrestricted-venv unrt ϱ) 37 | 38 | lift-unrestricted UUnit (VUnit inaG) = refl 39 | lift-unrestricted UInt (VInt i inaG) = refl 40 | lift-unrestricted (UPair unrt unrt₁) (VPair ss-GG₁G₂ v v₁) 41 | rewrite lift-unrestricted unrt v | lift-unrestricted unrt₁ v₁ 42 | = refl 43 | lift-unrestricted UFun (VFun (inj₁ ()) ϱ e) 44 | lift-unrestricted UFun (VFun (inj₂ y) ϱ e) = lift-unrestricted-venv y ϱ 45 | 46 | lift-unrestricted-venv [] (vnil ina) = refl 47 | lift-unrestricted-venv (px ∷ unrt) (vcons ssp v ϱ) 48 | rewrite lift-unrestricted px v | lift-unrestricted-venv unrt ϱ 49 | = refl 50 | 51 | unrestricted-empty : ∀ {t} → (unrt : Unr t) (v : Val [] t) → unrestricted-val unrt v ≡ []-inactive 52 | unrestricted-empty-venv : ∀ {t} → (unrt : All Unr t) (v : VEnv [] t) → unrestricted-venv unrt v ≡ []-inactive 53 | 54 | unrestricted-empty UUnit (VUnit []-inactive) = refl 55 | unrestricted-empty UInt (VInt i []-inactive) = refl 56 | unrestricted-empty (UPair unrt unrt₁) (VPair ss-[] v v₁) 57 | rewrite unrestricted-empty unrt v | unrestricted-empty unrt₁ v₁ 58 | = refl 59 | unrestricted-empty UFun (VFun (inj₁ ()) ϱ e) 60 | unrestricted-empty UFun (VFun (inj₂ y) ϱ e) = unrestricted-empty-venv y ϱ 61 | 62 | unrestricted-empty-venv [] (vnil []-inactive) = refl 63 | unrestricted-empty-venv (px ∷ unrt) (vcons ss-[] v v₁) 64 | rewrite unrestricted-empty px v | unrestricted-empty-venv unrt v₁ 65 | = refl 66 | 67 | split-env-lemma : 68 | ∀ { Φ Φ₁ Φ₂ } 69 | (sp : Split Φ Φ₁ Φ₂) 70 | (ϱ : VEnv [] Φ) 71 | → ∃ λ ϱ₁ → ∃ λ ϱ₂ → 72 | split-env sp (lift-venv ϱ) ≡ 73 | (((nothing ∷ []) , (nothing ∷ [])) , (ss-both ss-[]) , lift-venv ϱ₁ , lift-venv ϱ₂) 74 | 75 | split-env-lemma [] (vnil []-inactive) = 76 | (vnil []-inactive) , ((vnil []-inactive) , refl) 77 | split-env-lemma (dupl unrt sp) (vcons ss-[] v ϱ) 78 | with split-env-lemma sp ϱ | unrestricted-val unrt v 79 | ... | ϱ₁ , ϱ₂ , spe== | unr-v 80 | rewrite inactive-left-ssplit ss-[] unr-v | lift-unrestricted unrt v | unrestricted-empty unrt v | spe== 81 | with ssplit-compose3 (ss-both ss-[]) (ss-both ss-[]) 82 | ... | ssc3 83 | = (vcons ss-[] v ϱ₁) 84 | , (vcons ss-[] v ϱ₂) 85 | , refl 86 | split-env-lemma (Split.drop unrt sp) (vcons ss-[] v ϱ) 87 | with split-env-lemma sp ϱ | unrestricted-val unrt v 88 | ... | ϱ₁ , ϱ₂ , spe== | unr-v 89 | rewrite lift-unrestricted unrt v | unrestricted-empty unrt v 90 | = ϱ₁ , ϱ₂ , spe== 91 | split-env-lemma (left sp) (vcons ss-[] v ϱ) 92 | with split-env-lemma sp ϱ 93 | ... | ϱ₁ , ϱ₂ , spe== 94 | rewrite spe== 95 | with ssplit-compose3 (ss-both ss-[]) (ss-both ss-[]) 96 | ... | ssc3 97 | = (vcons ss-[] v ϱ₁) , (ϱ₂ , refl) 98 | split-env-lemma (rght sp) (vcons ss-[] v ϱ) 99 | with split-env-lemma sp ϱ 100 | ... | ϱ₁ , ϱ₂ , spe== 101 | rewrite spe== 102 | with ssplit-compose4 (ss-both ss-[]) (ss-both ss-[]) 103 | ... | ssc4 104 | = ϱ₁ , (vcons ss-[] v ϱ₂) , refl 105 | 106 | split-env-right-lemma : 107 | ∀ {Φ} (ϱ : VEnv [] Φ) → 108 | split-env (split-all-right Φ) (lift-venv ϱ) 109 | ≡ 110 | (((nothing ∷ []) , (nothing ∷ [])) , (ss-both ss-[]) , vnil (::-inactive []-inactive) , lift-venv ϱ) 111 | split-env-right-lemma (vnil []-inactive) = refl 112 | split-env-right-lemma (vcons ss-[] v ϱ) 113 | with split-env-right-lemma ϱ 114 | ... | sperl 115 | rewrite sperl 116 | with ssplit-compose4 (ss-both ss-[]) (ss-both ss-[]) 117 | ... | ssc4 118 | = refl 119 | 120 | split-env-right-lemma0 : 121 | ∀ {Φ} (ϱ : VEnv [] Φ) → 122 | split-env (split-all-right Φ) ϱ 123 | ≡ 124 | (([] , []) , ss-[] , vnil []-inactive , ϱ) 125 | split-env-right-lemma0 (vnil []-inactive) = refl 126 | split-env-right-lemma0 (vcons ss-[] v ϱ) 127 | rewrite split-env-right-lemma0 ϱ 128 | = refl 129 | 130 | split-env-left-lemma0 : 131 | ∀ {Φ} (ϱ : VEnv [] Φ) → 132 | split-env (split-all-left Φ) ϱ 133 | ≡ 134 | (([] , []) , ss-[] , ϱ , vnil []-inactive) 135 | split-env-left-lemma0 (vnil []-inactive) = refl 136 | split-env-left-lemma0 (vcons ss-[] v ϱ) 137 | rewrite split-env-left-lemma0 ϱ 138 | = refl 139 | 140 | 141 | split-env-lemma-2T : Set 142 | split-env-lemma-2T = 143 | ∀ { Φ Φ₁ Φ₂ } 144 | (sp : Split Φ Φ₁ Φ₂) 145 | (ϱ : VEnv [] Φ) 146 | → ∃ λ ϱ₁ → ∃ λ ϱ₂ → 147 | split-env sp (lift-venv ϱ) ≡ 148 | (_ , (ss-both ss-[]) , lift-venv ϱ₁ , lift-venv ϱ₂) 149 | × 150 | split-env sp ϱ ≡ 151 | (_ , ss-[] , ϱ₁ , ϱ₂) 152 | 153 | split-env-lemma-2 : split-env-lemma-2T 154 | split-env-lemma-2 [] (vnil []-inactive) 155 | = (vnil []-inactive) , ((vnil []-inactive) , (refl , refl)) 156 | split-env-lemma-2 (dupl unrt sp) (vcons ss-[] v ϱ) 157 | with split-env-lemma-2 sp ϱ 158 | ... | ϱ₁ , ϱ₂ , selift-ind , se-ind 159 | rewrite se-ind | lift-unrestricted unrt v 160 | with unrestricted-val unrt v 161 | ... | []-inactive 162 | rewrite selift-ind 163 | with ssplit-compose3 (ss-both ss-[]) (ss-both ss-[]) 164 | ... | ssc3 165 | = (vcons ss-[] v ϱ₁) , (vcons ss-[] v ϱ₂) , refl , refl 166 | split-env-lemma-2 (Split.drop unrt sp) (vcons ss-[] v ϱ) 167 | with split-env-lemma-2 sp ϱ 168 | ... | ϱ₁ , ϱ₂ , selift-ind , se-ind 169 | rewrite se-ind | lift-unrestricted unrt v 170 | with unrestricted-val unrt v 171 | ... | []-inactive 172 | = ϱ₁ , ϱ₂ , selift-ind , se-ind 173 | split-env-lemma-2 (left sp) (vcons ss-[] v ϱ) 174 | with split-env-lemma-2 sp ϱ 175 | ... | ϱ₁ , ϱ₂ , selift-ind , se-ind 176 | rewrite se-ind | selift-ind 177 | with ssplit-compose3 (ss-both ss-[]) (ss-both ss-[]) 178 | ... | ssc3 179 | = (vcons ss-[] v ϱ₁) , ϱ₂ , refl , refl 180 | split-env-lemma-2 (rght sp) (vcons ss-[] v ϱ) 181 | with split-env-lemma-2 sp ϱ 182 | ... | ϱ₁ , ϱ₂ , selift-ind , se-ind 183 | rewrite se-ind | selift-ind 184 | with ssplit-compose4 (ss-both ss-[]) (ss-both ss-[]) 185 | ... | ssc4 186 | = ϱ₁ , (vcons ss-[] v ϱ₂) , refl , refl 187 | 188 | split-rotate-lemma : ∀ {Φ} → 189 | split-rotate (split-all-left Φ) (split-all-right Φ) 190 | ≡ 191 | (Φ , split-all-right Φ , split-all-left Φ) 192 | 193 | split-rotate-lemma {[]} = refl 194 | split-rotate-lemma {x ∷ Φ} 195 | rewrite split-rotate-lemma {Φ} 196 | = refl 197 | 198 | split-rotate-lemma' : ∀ {Φ Φ₁ Φ₂} 199 | (sp : Split Φ Φ₁ Φ₂) → 200 | split-rotate (split-all-left Φ) sp 201 | ≡ 202 | (Φ₂ , sp , split-all-left Φ₂) 203 | 204 | split-rotate-lemma' {[]} [] = refl 205 | split-rotate-lemma' {x ∷ Φ} (dupl un-x sp) 206 | rewrite split-rotate-lemma' {Φ} sp 207 | = refl 208 | split-rotate-lemma' {x ∷ Φ} {Φ₁} {Φ₂} (Split.drop un-x sp) 209 | rewrite split-rotate-lemma' {Φ} sp 210 | = refl 211 | split-rotate-lemma' {x ∷ Φ} (left sp) 212 | rewrite split-rotate-lemma' {Φ} sp 213 | = refl 214 | split-rotate-lemma' {x ∷ Φ} (rght sp) 215 | rewrite split-rotate-lemma' {Φ} sp 216 | = refl 217 | 218 | 219 | ssplit-compose-lemma : ∀ ss → 220 | ssplit-compose ss-[] ss ≡ ([] , ss-[] , ss-[]) 221 | ssplit-compose-lemma ss-[] = refl 222 | 223 | -------------------------------------------------------------------------------- /src/Properties/StepBeta.agda: -------------------------------------------------------------------------------- 1 | module Properties.StepBeta where 2 | 3 | open import Data.List 4 | open import Data.List.All 5 | open import Data.Product 6 | 7 | open import Relation.Nullary 8 | open import Relation.Binary.PropositionalEquality 9 | 10 | open import Typing 11 | open import Syntax 12 | open import Global 13 | open import Channel 14 | open import Values 15 | open import Session 16 | open import Schedule 17 | 18 | open import ProcessSyntax 19 | open import ProcessRun 20 | 21 | open import Properties.Base 22 | 23 | -- V: (λx.e)v = e[v/x] 24 | -- let f = λx.e in let r = f v in E --> [let x = v in] let r = e in E 25 | 26 | mklhs : ∀ {Φ tin tout} (e : Expr (tin ∷ []) tout) (E : Expr (tout ∷ Φ) TUnit) → Expr (tin ∷ Φ) TUnit 27 | mklhs {Φ} e E = 28 | letbind (rght (split-all-right Φ)) (ulambda [] [] [] e) 29 | (letbind (left (left (split-all-right Φ))) (app (left (rght [])) (here []) (here [])) 30 | E) 31 | 32 | mkrhs : ∀ {Φ tin tout} (e : Expr (tin ∷ []) tout) (E : Expr (tout ∷ Φ) TUnit) → Expr (tin ∷ Φ) TUnit 33 | mkrhs {Φ} e E = 34 | letbind (left (split-all-right Φ)) e E 35 | 36 | reductionT : Set 37 | reductionT = ∀ {tin tout} 38 | (e : Expr (tin ∷ []) tout) (E : Expr (tout ∷ []) TUnit) 39 | (v : Val [] tin) 40 | → let ϱ = vcons ss-[] v (vnil []-inactive) in 41 | let lhs = run (left []) ss-[] (mklhs e E) ϱ (halt []-inactive UUnit) in 42 | let rhs = run (left []) ss-[] (mkrhs e E) ϱ (halt []-inactive UUnit) in 43 | restart (restart lhs) ≡ rhs 44 | 45 | reduction : reductionT 46 | reduction e E v 47 | with split-env (rght []) (vcons ss-[] v (vnil []-inactive)) 48 | ... | sperght 49 | = refl 50 | 51 | -- open reduction 52 | 53 | reduction-open-type : Set 54 | reduction-open-type = ∀ {Φ tin tout} 55 | (e : Expr (tin ∷ []) tout) (E : Expr (tout ∷ Φ) TUnit) 56 | (ϱ : VEnv [] (tin ∷ Φ)) 57 | → let lhs = run (left (split-all-left Φ)) ss-[] (mklhs e E) ϱ (halt []-inactive UUnit) in 58 | let rhs = run (left (split-all-left Φ)) ss-[] (mkrhs e E) ϱ (halt []-inactive UUnit) in 59 | restart (restart lhs) ≡ rhs 60 | 61 | reduction-open : reduction-open-type 62 | reduction-open {Φ} e E (vcons ss-[] v ϱ) 63 | rewrite split-rotate-lemma {Φ} 64 | | split-env-right-lemma0 ϱ 65 | with ssplit-compose3 ss-[] ss-[] 66 | ... | ssc3 67 | rewrite split-env-right-lemma0 ϱ 68 | | split-rotate-lemma {Φ} 69 | = refl 70 | 71 | -- open reduction with split between closure and context 72 | 73 | mktype' : Set 74 | mktype' = ∀ {Φ Φ₁ Φ₂ tin tout} 75 | (sp : Split Φ Φ₁ Φ₂) (un-Φ₁ : All Unr Φ₁) (e : Expr (tin ∷ Φ₁) tout) (E : Expr (tout ∷ Φ₂) TUnit) 76 | → Expr (tin ∷ Φ) TUnit 77 | 78 | mklhs' : mktype' 79 | mklhs' {Φ} {Φ₁} {Φ₂} sp un-Φ₁ e E = 80 | letbind (rght sp) (ulambda (split-all-left Φ₁) un-Φ₁ [] e) 81 | (letbind (left (left (split-all-right Φ₂))) (app (left (rght [])) (here []) (here [])) 82 | E) 83 | 84 | mkrhs' : mktype' 85 | mkrhs' {Φ} {Φ₁} {Φ₂} sp un-Φ₁ e E = 86 | letbind (left sp) e E 87 | 88 | reduction-open-type' : Set 89 | reduction-open-type' = ∀ {Φ Φ₁ Φ₂ tin tout} 90 | (sp : Split Φ Φ₁ Φ₂) (un-Φ₁ : All Unr Φ₁) 91 | (e : Expr (tin ∷ Φ₁) tout) (E : Expr (tout ∷ Φ₂) TUnit) 92 | (ϱ : VEnv [] (tin ∷ Φ)) 93 | → let lhs = run (left (split-all-left Φ)) ss-[] (mklhs' sp un-Φ₁ e E) ϱ (halt []-inactive UUnit) in 94 | let rhs = run (left (split-all-left Φ)) ss-[] (mkrhs' sp un-Φ₁ e E) ϱ (halt []-inactive UUnit) in 95 | restart (restart lhs) ≡ rhs 96 | 97 | -- this runs into the split-from-disjoint, which was hacked into function application 98 | -- it's not clear if there's a way round 99 | -- hence the proposition needs to be proved with a more specific assumption 100 | {- 101 | reduction-open' : reduction-open-type' 102 | reduction-open' {Φ} {Φ₁} {Φ₂} sp un-Φ₁ e E (vcons ss-[] v ϱ) 103 | rewrite split-rotate-lemma' sp 104 | with split-env sp ϱ 105 | ... | ([] , []) , ss-[] , ϱ₁ , ϱ₂ 106 | rewrite split-env-left-lemma0 ϱ₁ 107 | with ssplit-compose3 ss-[] ss-[] 108 | ... | ssc3 109 | rewrite split-env-right-lemma0 ϱ₂ 110 | with ssplit-compose3 ss-[] ss-[] 111 | ... | ssc3' 112 | rewrite split-rotate-lemma {Φ₂} 113 | = {!!} 114 | -} 115 | 116 | -- straightforward generalization of the inspect pattern 117 | record Reveal2_·_·_is_ {A B : Set} {C : A → B → Set} 118 | (f : (x : A) (y : B) → C x y) (x : A) (y : B) (z : C x y) : 119 | Set₁ where 120 | constructor [[_]] 121 | field eq : f x y ≡ z 122 | 123 | inspect2 : ∀ {A B : Set} {C : A → B → Set} 124 | (f : (x : A) (y : B) → C x y) (x : A) (y : B) → Reveal2 f · x · y is f x y 125 | inspect2 f x y = [[ refl ]] 126 | 127 | 128 | reduction-open-type'' : Set 129 | reduction-open-type'' = ∀ {Φ₁ Φ₂ tin tout} → 130 | let Φ,sp = split-from-disjoint Φ₁ Φ₂ in 131 | let Φ = proj₁ Φ,sp in 132 | let sp = proj₂ Φ,sp in 133 | (un-Φ₁ : All Unr Φ₁) 134 | (e : Expr (tin ∷ Φ₁) tout) (E : Expr (tout ∷ Φ₂) TUnit) 135 | (ϱ : VEnv [] (tin ∷ Φ)) 136 | → let lhs = run (left (split-all-left Φ)) ss-[] (mklhs' sp un-Φ₁ e E) ϱ (halt []-inactive UUnit) in 137 | let rhs = run (left (split-all-left Φ)) ss-[] (mkrhs' sp un-Φ₁ e E) ϱ (halt []-inactive UUnit) in 138 | restart (restart lhs) ≡ rhs 139 | 140 | reduction-open'' : reduction-open-type'' 141 | reduction-open'' {Φ₁} {Φ₂} un-Φ₁ e E (vcons ss-[] v ϱ) 142 | with split-from-disjoint Φ₁ Φ₂ | inspect2 split-from-disjoint Φ₁ Φ₂ 143 | ... | Φ , sp | [[ eq ]] 144 | rewrite split-rotate-lemma' sp 145 | with split-env sp ϱ 146 | ... | ([] , []) , ss-[] , ϱ₁ , ϱ₂ 147 | rewrite split-env-left-lemma0 ϱ₁ 148 | with ssplit-compose3 ss-[] ss-[] 149 | ... | ssc3 150 | rewrite split-env-right-lemma0 ϱ₂ 151 | with ssplit-compose3 ss-[] ss-[] 152 | ... | ssc3' 153 | rewrite split-rotate-lemma {Φ₂} | eq 154 | = refl 155 | -------------------------------------------------------------------------------- /src/Properties/StepCloseWait.agda: -------------------------------------------------------------------------------- 1 | -- P: (vcd) | --> (vcd) | 2 | 3 | -- P: (vcd) | --> (vcd) | 4 | module Properties.StepCloseWait where 5 | 6 | open import Data.Maybe hiding (All) 7 | open import Data.List 8 | open import Data.List.All 9 | open import Data.Product 10 | open import Data.Sum 11 | 12 | open import Relation.Nullary 13 | open import Relation.Binary.PropositionalEquality 14 | 15 | open import Typing 16 | open import Syntax 17 | open import Global 18 | open import Channel 19 | open import Values 20 | open import Session 21 | open import Schedule 22 | 23 | open import ProcessSyntax 24 | open import ProcessRun 25 | 26 | open import Properties.Base 27 | 28 | mkclose : ∀ {Φ} → Expr (TUnit ∷ Φ) TUnit → Expr (TChan send! ∷ Φ) TUnit 29 | mkclose = λ e → letbind (left (split-all-right _)) (close (here [])) e 30 | 31 | mkwait : ∀ {Φ} → Expr (TUnit ∷ Φ) TUnit → Expr (TChan send? ∷ Φ) TUnit 32 | mkwait = λ e → letbind (left (split-all-right _)) (wait (here [])) e 33 | 34 | module General where 35 | 36 | mklhs : ∀ {Φ Φ₁ Φ₂} 37 | → Split Φ Φ₁ Φ₂ 38 | → Expr (TUnit ∷ Φ₁) TUnit 39 | → Expr (TUnit ∷ Φ₂) TUnit 40 | → Proc Φ 41 | mklhs sp e f = 42 | res (delay send!) 43 | (par (left (rght sp)) 44 | (exp (mkclose e)) (exp (mkwait f))) 45 | 46 | mkrhs : ∀ {Φ Φ₁ Φ₂} 47 | → Split Φ Φ₁ Φ₂ 48 | → Expr (TUnit ∷ Φ₁) TUnit 49 | → Expr (TUnit ∷ Φ₂) TUnit 50 | → Proc Φ 51 | mkrhs sp e f = 52 | par sp (exp (letbind (split-all-right _) (unit []) e)) 53 | (exp (letbind (split-all-right _) (unit []) f)) 54 | 55 | 56 | -- obviously true, but requires a nasty inductive proof 57 | postulate 58 | weaken2-ident : ∀ {G Φ} (ϱ : VEnv G Φ) → weaken2-venv [] [] ϱ ≡ ϱ 59 | 60 | postulate 61 | weaken1-ident : ∀ {G Φ} (ϱ : VEnv G Φ) → weaken1-venv [] ϱ ≡ ϱ 62 | 63 | reductionT : Set 64 | reductionT = 65 | ∀ { Φ Φ₁ Φ₂ } 66 | (sp : Split Φ Φ₁ Φ₂) 67 | (ϱ : VEnv [] Φ) 68 | (p : ∃ λ ϱ₁ → ∃ λ ϱ₂ → 69 | split-env sp (lift-venv ϱ) ≡ (((nothing ∷ []) , (nothing ∷ [])) , (ss-both ss-[]) , ϱ₁ , ϱ₂)) 70 | (e : Expr (TUnit ∷ Φ₁) TUnit) 71 | (f : Expr (TUnit ∷ Φ₂) TUnit) → 72 | let lhs = (runProc [] (mklhs sp e f) ϱ) in 73 | let rhs = (runProc [] (mkrhs sp e f) ϱ) in 74 | one-step lhs ≡ 75 | (Closed , nothing ∷ proj₁ rhs , lift-threadpool (proj₂ rhs)) 76 | 77 | reduction : reductionT 78 | reduction{Φ}{Φ₁}{Φ₂} sp ϱ p e f 79 | with ssplit-refl-left-inactive [] 80 | ... | G' , ina-G' , ss-GG' 81 | with split-env-lemma-2 sp ϱ 82 | ... | ϱ₁ , ϱ₂ , spe== , sp== 83 | rewrite spe== | sp== 84 | with ssplit-compose{just (send! , POSNEG) ∷ []} (ss-posneg ss-[]) (ss-left ss-[]) 85 | ... | ssc 86 | rewrite split-env-right-lemma ϱ₁ 87 | with ssplit-compose{just (send! , POSNEG) ∷ []} (ss-left ss-[]) (ss-left ss-[]) 88 | ... | ssc-ll 89 | rewrite split-env-right-lemma ϱ₂ 90 | with ssplit-compose2 (ss-both ss-[]) (ss-both ss-[]) 91 | ... | ssc2 92 | rewrite weaken2-ident (lift-venv ϱ₁) 93 | | split-rotate-lemma {Φ₁} 94 | | split-rotate-lemma {Φ₂} 95 | | split-env-right-lemma0 ϱ₁ 96 | | split-env-right-lemma0 ϱ₂ 97 | | weaken2-ident ϱ₁ 98 | | weaken1-ident (lift-venv ϱ₂) 99 | | weaken1-ident ϱ₂ 100 | = refl 101 | 102 | module ClosedWithContext where 103 | mklhs : Expr (TUnit ∷ []) TUnit 104 | → Expr (TUnit ∷ []) TUnit 105 | → Proc [] 106 | mklhs e f = 107 | res (delay send!) 108 | (par (left (rght [])) 109 | (exp (mkclose e)) (exp (mkwait f))) 110 | 111 | mkrhs : Expr (TUnit ∷ []) TUnit 112 | → Expr (TUnit ∷ []) TUnit 113 | → Proc [] 114 | mkrhs e f = 115 | par [] (exp (letbind [] (unit []) e)) 116 | (exp (letbind [] (unit []) f)) 117 | 118 | reduction : 119 | (e f : Expr (TUnit ∷ []) TUnit) → 120 | let lhs = (runProc [] (mklhs e f) (vnil []-inactive)) in 121 | let rhs = (runProc [] (mkrhs e f) (vnil []-inactive)) in 122 | one-step lhs ≡ 123 | (Closed , nothing ∷ proj₁ rhs , lift-threadpool (proj₂ rhs)) 124 | reduction e f 125 | with ssplit-refl-left-inactive [] 126 | ... | G' , ina-G' , ss-GG' 127 | = refl 128 | -------------------------------------------------------------------------------- /src/Properties/StepFork.agda: -------------------------------------------------------------------------------- 1 | -- P: --> | 2 | module Properties.StepFork where 3 | 4 | open import Data.List 5 | open import Data.List.All 6 | open import Data.Product 7 | 8 | open import Relation.Nullary 9 | open import Relation.Binary.PropositionalEquality 10 | 11 | open import Typing 12 | open import Syntax 13 | open import Global 14 | open import Channel 15 | open import Values 16 | open import Session 17 | open import Schedule 18 | 19 | open import ProcessSyntax 20 | open import ProcessRun 21 | 22 | open import Properties.Base 23 | 24 | mkfork : ∀ {Φ Φ₁ Φ₂} → Split Φ Φ₁ Φ₂ → Expr Φ₁ TUnit → Expr (TUnit ∷ Φ₂) TUnit → Expr Φ TUnit 25 | mkfork sp e E = letbind sp (fork e) E 26 | 27 | mklhs : ∀ {Φ Φ₁ Φ₂} → Split Φ Φ₁ Φ₂ 28 | → Expr Φ₁ TUnit → Expr (TUnit ∷ Φ₂) TUnit → Proc Φ 29 | mklhs sp e E = 30 | exp (mkfork sp e E) 31 | 32 | mkrhs : ∀ {Φ Φ₁ Φ₂} → Split Φ Φ₁ Φ₂ 33 | → Expr Φ₁ TUnit → Expr (TUnit ∷ Φ₂) TUnit → Proc Φ 34 | mkrhs sp e E = 35 | par sp (exp e) (exp (letbind (split-all-right _) (unit []) E)) 36 | 37 | -- weaken2-command : ∀ {G} G' G'' → Command (G' ++ G) → Command (G' ++ inactive-clone G'' ++ G) 38 | 39 | -- obviously true, but requires a nasty inductive proof 40 | postulate 41 | weaken2-ident : ∀ {G} → (cmd : Command G) → weaken2-command [] [] cmd ≡ cmd 42 | 43 | reduction : (e : Expr [] TUnit) → (E : Expr (TUnit ∷ []) TUnit) 44 | → 45 | let lhs = (runProc [] (mklhs [] e E) (vnil []-inactive)) in 46 | let rhs = (runProc [] (mkrhs [] e E) (vnil []-inactive)) in 47 | let rhs' = one-step rhs in 48 | one-step lhs ≡ 49 | (Forked , proj₁ rhs , proj₂ rhs) 50 | reduction e E 51 | with ssplit-refl-left-inactive [] 52 | ... | G' , ina-G' , ss-GG' 53 | rewrite weaken2-ident (run [] ss-[] e (vnil []-inactive) (halt []-inactive UUnit)) 54 | = refl 55 | 56 | -------------------------------------------------------------------------------- /src/Properties/StepNew.agda: -------------------------------------------------------------------------------- 1 | -- P: --> (vcd) 2 | module Properties.StepNew where 3 | 4 | 5 | open import Data.Maybe hiding (All) 6 | open import Data.List 7 | open import Data.List.All 8 | open import Data.Product 9 | 10 | open import Relation.Nullary 11 | open import Relation.Binary.PropositionalEquality 12 | 13 | open import Typing 14 | open import Syntax 15 | open import Global 16 | open import Channel 17 | open import Values 18 | open import Session 19 | open import Schedule 20 | 21 | open import ProcessSyntax 22 | open import ProcessRun 23 | 24 | open import Properties.Base 25 | 26 | tch : SType → Type 27 | tch s = (TPair (TChan (SType.force s)) (TChan (SType.force (dual s)))) 28 | 29 | mknew : ∀ {Φ} → (s : SType) → Expr (tch s ∷ Φ) TUnit → Expr Φ TUnit 30 | mknew s E = letbind (split-all-right _) (new [] s) E 31 | 32 | mklhs : ∀ {Φ} → (s : SType) → Expr (tch s ∷ Φ) TUnit → Proc Φ 33 | mklhs s E = exp (mknew s E) 34 | 35 | mkrhs : ∀ {Φ} → (s : SType) → Expr (tch s ∷ Φ) TUnit → Proc Φ 36 | mkrhs s E = res s (exp (letbind (left (left (split-all-right _))) (pair (left (rght [])) (here []) (here [])) E)) 37 | 38 | reduction : (s : SType) (E : Expr (tch s ∷ []) TUnit) → 39 | let lhs = (runProc [] (mklhs s E) (vnil []-inactive)) in 40 | let rhs = (runProc [] (mkrhs s E) (vnil []-inactive)) in 41 | one-step lhs ≡ 42 | (New , proj₁ rhs , proj₂ rhs) 43 | reduction s E 44 | with ssplit-refl-left-inactive [] 45 | ... | G' , ina-G' , ss-GG' 46 | = refl 47 | 48 | -- reduction in open context 49 | 50 | open-reduction-type : Set 51 | open-reduction-type = ∀ {Φ} (s : SType) (E : Expr (tch s ∷ Φ) TUnit) (ϱ : VEnv [] Φ) → 52 | let lhs = (runProc [] (mklhs s E) ϱ) in 53 | let rhs = (runProc [] (mkrhs s E) ϱ) in 54 | one-step lhs ≡ (New , proj₁ rhs , proj₂ rhs) 55 | 56 | open-reduction : open-reduction-type 57 | open-reduction{Φ} s E ϱ 58 | with runProc [] (exp (mknew s E)) ϱ 59 | ... | rpse 60 | rewrite split-env-right-lemma0 ϱ 61 | | split-rotate-lemma {Φ} 62 | | split-env-right-lemma ϱ 63 | with ssplit-compose (ss-left{(SType.force s) , POSNEG} ss-[]) (ss-left ss-[]) 64 | ... | ssc 65 | = refl 66 | 67 | {- 68 | 69 | -- reduction in open context with further resources 70 | 71 | pairs : ∀ {A : Set} {B : A → Set} {p1 p2 : Σ A λ x → B x } 72 | → p1 ≡ p2 → Σ (proj₁ p1 ≡ proj₁ p2) λ { refl → proj₂ p1 ≡ proj₂ p2 } 73 | pairs {A} {B} refl = refl , refl 74 | 75 | split-env-right-lemma0' : 76 | ∀ {Φ G} (ϱ : VEnv G Φ) → 77 | let gis = ssplit-refl-right-inactive G in 78 | (split-env (split-all-right Φ) ϱ 79 | ≡ 80 | ((proj₁ gis , G) , proj₂ (proj₂ gis) , vnil (proj₁ (proj₂ gis)) , ϱ)) 81 | split-env-right-lemma0' (vnil []-inactive) = refl 82 | split-env-right-lemma0' (vnil (::-inactive ina)) 83 | with split-env-right-lemma0' (vnil ina) 84 | ... | ih 85 | with pairs ih 86 | ... | p1== , p2== 87 | = {!!} 88 | split-env-right-lemma0'{t ∷ Φ} (vcons ssp v ϱ) 89 | with split-env-right-lemma0' ϱ 90 | ... | ih 91 | with split-env (split-all-right Φ) ϱ 92 | ... | sesar 93 | = {!!} 94 | 95 | 96 | full-reduction-type : Set 97 | full-reduction-type = ∀ {Φ G} (s : SType) (E : Expr (tch s ∷ Φ) TUnit) (ϱ : VEnv G Φ) → 98 | let lhs = runProc G (mklhs s E) ϱ in 99 | let rhs = runProc G (mkrhs s E) ϱ in 100 | single-step (proj₁ lhs ++ G , proj₂ lhs) ≡ (New , proj₁ rhs ++ G , proj₂ rhs) 101 | 102 | full-reduction : full-reduction-type 103 | full-reduction{Φ}{G} s E ϱ 104 | with ssplit-refl-left-inactive G 105 | ... | ssrli 106 | rewrite split-env-right-lemma0' ϱ 107 | | split-rotate-lemma {Φ} 108 | = {!!} 109 | 110 | -} 111 | -------------------------------------------------------------------------------- /src/Properties/StepPair.agda: -------------------------------------------------------------------------------- 1 | -- V: letpair (x,y) = (V,W) in E --> E[ V,W / x,y ] 2 | module Properties.StepPair where 3 | 4 | open import Data.List 5 | open import Data.List.All 6 | open import Data.Product 7 | 8 | open import Relation.Nullary 9 | open import Relation.Binary.PropositionalEquality 10 | 11 | open import Typing 12 | open import Syntax 13 | open import Global 14 | open import Values 15 | open import Session 16 | 17 | open import Properties.Base 18 | 19 | -- this will require multiple steps to execute 20 | mklhs : ∀ {Φ t₁ t₂} → Expr (t₁ ∷ t₂ ∷ Φ) TUnit → Expr (t₁ ∷ t₂ ∷ Φ) TUnit 21 | mklhs {Φ} E = 22 | letbind (left (left (split-all-right Φ))) (pair (left (rght [])) (here []) (here [])) 23 | (letpair (left (split-all-right Φ)) (here []) E) 24 | 25 | reduction : ∀ {t₁ t₂} 26 | → (E : Expr (t₁ ∷ t₂ ∷ []) TUnit) 27 | → (v₁ : Val [] t₁) 28 | → (v₂ : Val [] t₂) 29 | → let ϱ = vcons ss-[] v₁ (vcons ss-[] v₂ (vnil []-inactive)) in 30 | let lhs = (run (left (left [])) ss-[] (mklhs E) ϱ (halt []-inactive UUnit)) in 31 | let rhs = (run (left (left [])) ss-[] E ϱ (halt []-inactive UUnit)) in 32 | restart lhs ≡ 33 | rhs 34 | reduction E v₁ v₂ 35 | with split-env (left (left [])) (vcons ss-[] v₁ (vcons ss-[] v₂ (vnil []-inactive))) 36 | ... | spe 37 | = refl 38 | 39 | reduction-open-type : Set 40 | reduction-open-type = ∀ {Φ t₁ t₂} 41 | (E : Expr (t₁ ∷ t₂ ∷ Φ) TUnit) 42 | (ϱ : VEnv [] (t₁ ∷ t₂ ∷ Φ)) 43 | → 44 | let lhs = run (left (left (split-all-left Φ))) ss-[] (mklhs E) ϱ (halt []-inactive UUnit) in 45 | let rhs = run (left (left (split-all-left _))) ss-[] E ϱ (halt []-inactive UUnit) in 46 | restart lhs ≡ rhs 47 | 48 | reduction-open : reduction-open-type 49 | reduction-open {Φ} E (vcons ss-[] v (vcons ss-[] v₁ ϱ)) 50 | rewrite split-rotate-lemma {Φ} 51 | | split-env-right-lemma0 ϱ 52 | with ssplit-compose3 ss-[] ss-[] 53 | ... | ssc3 54 | rewrite split-env-right-lemma0 ϱ 55 | | split-rotate-lemma {Φ} 56 | = refl 57 | 58 | -------------------------------------------------------------------------------- /src/Run.agda: -------------------------------------------------------------------------------- 1 | module Run where 2 | 3 | open import Data.Bool 4 | open import Data.Maybe 5 | open import Data.Nat 6 | open import Data.List 7 | open import Data.List.All 8 | 9 | open import Typing 10 | open import Syntax 11 | open import Global 12 | open import Channel 13 | open import Values 14 | open import Session 15 | open import Schedule 16 | 17 | open import Examples 18 | open import Aexamples 19 | 20 | gas : ℕ → Gas 21 | gas zero = Empty 22 | gas (suc n) = More (gas n) 23 | 24 | -- the magic number shows the last state before termination 25 | 26 | -- runs to completion: the magic number is 7 27 | runex1 : Outcome 28 | runex1 = start (gas 8) ex1 29 | 30 | -- runs to completion, but gets slow at 9 31 | runex2 : Outcome 32 | runex2 = start (gas 14) ex2 33 | 34 | -- need more steps, but gets *very* slow 35 | runex3 : Outcome 36 | runex3 = start (gas 6) ex3 37 | 38 | -- runs to completion 39 | runex4 : Outcome 40 | runex4 = start (gas 11) ex4 41 | 42 | -- just lambda calculus 43 | -- runs to completion: the magic number is 2 44 | runex5 : Outcome 45 | runex5 = start (gas 3) ex5 46 | 47 | -- just lambda calculus 48 | -- magic number is 6 49 | runex6 : Outcome 50 | runex6 = start (gas 7) ex6 51 | 52 | -- now asynchronous examples 53 | runaex1 : Outcome 54 | runaex1 = start (gas 40) aex1 55 | 56 | runasyncex1 : Outcome 57 | runasyncex1 = start (gas 40) asyncex1 58 | 59 | runasyncex2 : Outcome 60 | runasyncex2 = start (gas 80) asyncex2 61 | -------------------------------------------------------------------------------- /src/Schedule.agda: -------------------------------------------------------------------------------- 1 | module Schedule where 2 | 3 | open import Data.Bool 4 | open import Data.Fin 5 | open import Data.Empty 6 | open import Data.List 7 | open import Data.List.All 8 | open import Data.Maybe 9 | open import Data.Nat 10 | open import Data.Product 11 | open import Data.Sum 12 | open import Data.Unit 13 | open import Function using (_$_) 14 | open import Relation.Nullary 15 | open import Relation.Binary.PropositionalEquality 16 | 17 | open import Typing 18 | open import Syntax 19 | open import Global 20 | open import Channel 21 | open import Values 22 | open import Session 23 | 24 | -- outcomes of step 25 | data Event : Set where 26 | Terminated Forked Restarted Halted New Closed NotClosed WaitSkipped : Event 27 | SendSkipped Received NotReceived : Event 28 | Stuck : Event 29 | Selected NotSelected : Event 30 | NSelected NotNSelected BranchSkipped NBranchSkipped : Event 31 | 32 | data NextPool : Set where 33 | _,_ : ∀ {G} → Event → ThreadPool G → NextPool 34 | 35 | module Alternative where 36 | step : ∀ {Gtop G1 G2} → SSplit Gtop G1 G2 → ThreadPool G1 → ThreadPool G2 → NextPool 37 | step ss-top (tnil ina) tp2@(tnil _) = Terminated , tp2 38 | 39 | step ss-top (tnil ina) tp2 = Stuck , tp2 40 | 41 | step ss-top (tcons ss (Fork{G₁ = G₁}{G₂ = G₂} ss₁ κ₁ κ₂) tp) tp2 42 | with ssplit-compose ss ss₁ 43 | ... | Gi , ss₁₃ , ss₂₄ with ssplit-refl-right G₁ | ssplit-refl-right G₂ 44 | ... | Gunit , ss-G1GunitG1 | G2unit , ss-G2GuG2 = 45 | Forked , (tappend ss-top ((tcons ss₁₃ (apply-cont ss-G1GunitG1 κ₁ (VUnit (ssplit-inactive-right ss-G1GunitG1))) 46 | (tcons ss₂₄ (Ready ss-G2GuG2 (VUnit (ssplit-inactive-right ss-G2GuG2)) κ₂) tp))) tp2) 47 | 48 | step ss-top (tcons ss (Ready ss₁ v κ) tp) tp2 = 49 | Restarted , (tappend ss-top (tsnoc ss tp (apply-cont ss₁ κ v)) tp2) 50 | 51 | step ss-top (tcons ss (Halt inaG x₁ x₂) tp) tp2 52 | rewrite inactive-left-ssplit ss inaG = Halted , (tappend ss-top tp tp2) 53 | 54 | step ss-top (tcons{G₁} ss (New s κ) tp) tp2 55 | with ssplit-refl-right G₁ 56 | ... | Gi , ss-GiG1 57 | with ssplit-inactive-right ss-GiG1 58 | ... | ina-Gi = New , (tappend (ss-left ss-top) ((tcons (ss-left ss) 59 | (Ready (ss-left ss-GiG1) (VPair (ss-posneg (inactive-ssplit-trivial ina-Gi)) (VChan POS (here-pos ina-Gi (subF-refl _))) (VChan NEG (here-neg ina-Gi (subF-refl _)))) (lift-cont κ)) 60 | (lift-threadpool tp))) (lift-threadpool tp2)) 61 | 62 | step ss-top (tcons{G₁}{G₂} ss cmd@(Close ss-vκ v κ) tp) tp2 63 | with ssplit-compose ss-top ss 64 | ... | Gi , ss-top1 , ss-top2 65 | with ssplit-refl-left-inactive Gi 66 | ... | G' , ina-G' , ss-GG' 67 | with matchWaitAndGo ss-top1 (ss-vκ , v , κ) ss-GG' (tappend ss-top2 tp tp2) (tnil ina-G') 68 | ... | just (Gnext , tpnext) = Closed , tpnext 69 | ... | nothing 70 | with ssplit-compose5 ss-top ss 71 | ... | Gi' , ss-top1' , ss-top2' = step ss-top1' tp (tsnoc ss-top2' tp2 cmd) 72 | 73 | step ss-top (tcons ss cmd@(Wait ss₁ v κ) tp) tp2 74 | with ssplit-compose5 ss-top ss 75 | ... | Gi , ss-top1 , ss-top2 = 76 | step ss-top1 tp (tsnoc ss-top2 tp2 cmd) 77 | 78 | step ss-top (tcons ss cmd@(Send ss₁ ss-args vch v κ) tp) tp2 79 | with ssplit-compose5 ss-top ss 80 | ... | Gi , ss-top1 , ss-top2 = 81 | step ss-top1 tp (tsnoc ss-top2 tp2 cmd) 82 | 83 | step ss-top (tcons{G₁}{G₂} ss cmd@(Recv ss-vκ vch κ) tp) tp2 84 | with ssplit-compose ss-top ss 85 | ... | Gi , ss-top1 , ss-top2 86 | with ssplit-refl-left-inactive Gi 87 | ... | G' , ina-G' , ss-GG' 88 | with matchSendAndGo ss-top1 (ss-vκ , vch , κ) ss-GG' (tappend ss-top2 tp tp2) (tnil ina-G') 89 | ... | just (G-next , tp-next) = 90 | Received , tp-next 91 | ... | nothing 92 | with ssplit-compose5 ss-top ss 93 | ... | Gi' , ss-top1' , ss-top2' = 94 | step ss-top1' tp (tsnoc ss-top2' tp2 cmd) 95 | 96 | step ss-top (tcons{G₁}{G₂} ss cmd@(Select ss-vκ lab vch κ) tp) tp2 97 | with ssplit-compose ss-top ss 98 | ... | Gi , ss-top1 , ss-top2 99 | with ssplit-refl-left-inactive Gi 100 | ... | G' , ina-G' , ss-GG' 101 | with matchBranchAndGo ss-top1 (ss-vκ , lab , vch , κ) ss-GG' (tappend ss-top2 tp tp2) (tnil ina-G') 102 | ... | just (G-next , tp-next) = 103 | Selected , tp-next 104 | ... | nothing 105 | with ssplit-compose5 ss-top ss 106 | ... | Gi' , ss-top1' , ss-top2' = 107 | step ss-top1' tp (tsnoc ss-top2' tp2 cmd) 108 | 109 | step ss-top (tcons ss cmd@(Branch ss₁ vch dcont) tp) tp2 110 | with ssplit-compose5 ss-top ss 111 | ... | Gi , ss-top1 , ss-top2 = 112 | step ss-top1 tp (tsnoc ss-top2 tp2 cmd) 113 | 114 | step ss-top (tcons{G₁}{G₂} ss cmd@(NSelect ss-vκ lab vch κ) tp) tp2 115 | with ssplit-compose ss-top ss 116 | ... | Gi , ss-top1 , ss-top2 117 | with ssplit-refl-left-inactive Gi 118 | ... | G' , ina-G' , ss-GG' 119 | with matchNBranchAndGo ss-top1 (ss-vκ , lab , vch , κ) ss-GG' (tappend ss-top2 tp tp2) (tnil ina-G') 120 | ... | just (G-next , tp-next) = NSelected , tp-next 121 | ... | nothing 122 | with ssplit-compose5 ss-top ss 123 | ... | Gi' , ss-top1' , ss-top2' = 124 | step ss-top1' tp (tsnoc ss-top2' tp2 cmd) 125 | 126 | step ss-top (tcons ss cmd@(NBranch ss₁ vch dcont) tp) tp2 127 | with ssplit-compose5 ss-top ss 128 | ... | Gi , ss-top1 , ss-top2 = 129 | step ss-top1 tp (tsnoc ss-top2 tp2 cmd) 130 | 131 | module Original where 132 | step : ∀ {G} → ThreadPool G → NextPool 133 | step (tnil ina) = 134 | Terminated , tnil ina 135 | step (tcons ss (Fork{G₁ = G₁}{G₂ = G₂} ss₁ κ₁ κ₂) tp) with ssplit-compose ss ss₁ 136 | ... | Gi , ss₁₃ , ss₂₄ with ssplit-refl-right G₁ | ssplit-refl-right G₂ 137 | ... | Gunit , ss-G1GunitG1 | G2unit , ss-G2GuG2 = 138 | Forked , (tcons ss₁₃ (apply-cont ss-G1GunitG1 κ₁ (VUnit (ssplit-inactive-right ss-G1GunitG1))) 139 | (tcons ss₂₄ (apply-cont ss-G2GuG2 κ₂ (VUnit (ssplit-inactive-right ss-G2GuG2))) tp)) 140 | step (tcons ss (Ready ss₁ v κ) tp) = 141 | Restarted , (tsnoc ss tp (apply-cont ss₁ κ v)) 142 | step (tcons ss (Halt inaG x₁ x₂) tp) rewrite inactive-left-ssplit ss inaG = 143 | Halted , tp 144 | step (tcons{G₁} ss (New s κ) tp) with ssplit-refl-right G₁ 145 | ... | Gi , ss-GiG1 with ssplit-inactive-right ss-GiG1 146 | ... | ina-Gi = 147 | New , (tcons (ss-left ss) 148 | (apply-cont (ss-left ss-GiG1) (lift-cont κ) (VPair (ss-posneg (inactive-ssplit-trivial ina-Gi)) (VChan POS (here-pos ina-Gi (subF-refl _))) (VChan NEG (here-neg ina-Gi (subF-refl _))))) 149 | (lift-threadpool tp)) 150 | step (tcons{G₁}{G₂} ss cmd@(Close ss-vκ v κ) tp) with ssplit-refl-left-inactive G₂ 151 | ... | G' , ina-G' , ss-GG' with matchWaitAndGo ss (ss-vκ , v , κ) ss-GG' tp (tnil ina-G') 152 | ... | just (Gnext , tpnext) = Closed , tpnext 153 | ... | nothing = NotClosed , (tsnoc ss tp cmd) 154 | step (tcons ss cmd@(Wait ss₁ v κ) tp) = 155 | WaitSkipped , (tsnoc ss tp cmd) 156 | step (tcons ss cmd@(Send ss₁ ss-args vch v κ) tp) = 157 | SendSkipped , (tsnoc ss tp cmd) 158 | step (tcons{G₁}{G₂} ss cmd@(Recv ss-vκ vch κ) tp) with ssplit-refl-left-inactive G₂ 159 | ... | G' , ina-G' , ss-GG' with matchSendAndGo ss (ss-vκ , vch , κ) ss-GG' tp (tnil ina-G') 160 | ... | just (G-next , tp-next) = Received , tp-next 161 | ... | nothing = NotReceived , (tsnoc ss tp cmd) 162 | step (tcons{G₁}{G₂} ss cmd@(Select ss-vκ lab vch κ) tp) with ssplit-refl-left-inactive G₂ 163 | ... | G' , ina-G' , ss-GG' with matchBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp (tnil ina-G') 164 | ... | just (G-next , tp-next) = Selected , tp-next 165 | ... | nothing = NotSelected , (tsnoc ss tp cmd) 166 | step (tcons ss cmd@(Branch ss-vκ vch dcont) tp) = 167 | BranchSkipped , (tsnoc ss tp cmd) 168 | step (tcons{G₁}{G₂} ss cmd@(NSelect ss-vκ lab vch κ) tp) with ssplit-refl-left-inactive G₂ 169 | ... | G' , ina-G' , ss-GG' with matchNBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp (tnil ina-G') 170 | ... | just (G-next , tp-next) = NSelected , tp-next 171 | ... | nothing = NotNSelected , (tsnoc ss tp cmd) 172 | step (tcons ss cmd@(NBranch ss-vκ vch dcont) tp) = 173 | NBranchSkipped , (tsnoc ss tp cmd) 174 | 175 | open Alternative 176 | 177 | single-step : (∃ λ G → ThreadPool G) → Event × (∃ λ G → ThreadPool G) 178 | single-step (G , tp) 179 | with ssplit-refl-left-inactive G 180 | ... | G' , ina-G' , ss-GG' 181 | with step ss-GG' tp (tnil ina-G') 182 | ... | ev , tp' = ev , ( _ , tp') 183 | 184 | -- stuff to run ... 185 | data Gas : Set where 186 | Empty : Gas 187 | More : Gas → Gas 188 | 189 | -- outcomes of scheduling 190 | data Outcome : Set where 191 | Terminated : Outcome 192 | _,_ : Event → Outcome → Outcome 193 | OutOfGas : ∀ {G} → ThreadPool G → Outcome 194 | 195 | -- thread scheduling 196 | schedule : {G : SCtx} → Gas → ThreadPool G → Outcome 197 | schedule Empty tp = OutOfGas tp 198 | schedule{G} (More gas) tp 199 | with single-step (_ , tp) 200 | ... | Terminated , _ , tp' = Terminated 201 | ... | ev , _ , tp' = ev , (schedule gas tp') 202 | 203 | -- start main thread 204 | start : Gas → Expr [] TUnit → Outcome 205 | start f e = 206 | schedule f (tcons ss-[] (run [] ss-[] e (vnil []-inactive) (halt []-inactive UUnit)) (tnil []-inactive)) 207 | -------------------------------------------------------------------------------- /src/Session.agda: -------------------------------------------------------------------------------- 1 | module Session where 2 | 3 | open import Data.Bool 4 | open import Data.Fin 5 | open import Data.Empty 6 | open import Data.List 7 | open import Data.List.All 8 | open import Data.Maybe 9 | open import Data.Nat 10 | open import Data.Product 11 | open import Data.Sum 12 | open import Data.Unit 13 | open import Function using (_$_) 14 | open import Relation.Nullary 15 | open import Relation.Binary.PropositionalEquality 16 | 17 | open import Typing 18 | open import Syntax 19 | open import Global 20 | open import Channel 21 | open import Values 22 | 23 | 24 | data Cont (G : SCtx) (φ : TCtx) : (t : Type) → Set where 25 | halt : ∀ {t} 26 | → Inactive G 27 | → (un-t : Unr t) 28 | → Cont G φ t 29 | 30 | bind : ∀ {φ₁ φ₂ G₁ G₂ t t₂} 31 | → (ts : Split φ φ₁ φ₂) 32 | → (ss : SSplit G G₁ G₂) 33 | → (e₂ : Expr (t ∷ φ₁) t₂) 34 | → (ϱ₂ : VEnv G₁ φ₁) 35 | → (κ₂ : Cont G₂ φ₂ t₂) 36 | → Cont G φ t 37 | 38 | bind-thunk : ∀ {φ₁ φ₂ G₁ G₂ t₂} 39 | → (ts : Split φ φ₁ φ₂) 40 | → (ss : SSplit G G₁ G₂) 41 | → (e₂ : Expr φ₁ t₂) 42 | → (ϱ₂ : VEnv G₁ φ₁) 43 | → (κ₂ : Cont G₂ φ₂ t₂) 44 | → Cont G φ TUnit 45 | 46 | subsume : ∀ {t t₁} 47 | → SubT t t₁ 48 | → Cont G φ t₁ 49 | → Cont G φ t 50 | 51 | data Command (G : SCtx) : Set where 52 | 53 | Fork : ∀ {φ₁ φ₂ G₁ G₂} 54 | → (ss : SSplit G G₁ G₂) 55 | → (κ₁ : Cont G₁ φ₁ TUnit) 56 | → (κ₂ : Cont G₂ φ₂ TUnit) 57 | → Command G 58 | 59 | Ready : ∀ {φ t G₁ G₂} 60 | → (ss : SSplit G G₁ G₂) 61 | → (v : Val G₁ t) 62 | → (κ : Cont G₂ φ t) 63 | → Command G 64 | 65 | Halt : ∀ {t} 66 | → Inactive G 67 | → Unr t 68 | → Val G t 69 | → Command G 70 | New : ∀ {φ} 71 | → (s : SType) 72 | → (κ : Cont G φ (TPair (TChan (SType.force s)) (TChan (SType.force (dual s))))) 73 | → Command G 74 | Close : ∀ {φ G₁ G₂} 75 | → (ss : SSplit G G₁ G₂) 76 | → (v : Val G₁ (TChan send!)) 77 | → (κ : Cont G₂ φ TUnit) 78 | → Command G 79 | Wait : ∀ {φ G₁ G₂} 80 | → (ss : SSplit G G₁ G₂) 81 | → (v : Val G₁ (TChan send?)) 82 | → (κ : Cont G₂ φ TUnit) 83 | → Command G 84 | Send : ∀ {φ G₁ G₂ G₁₁ G₁₂ t s} 85 | → (ss : SSplit G G₁ G₂) 86 | → (ss-args : SSplit G₁ G₁₁ G₁₂) 87 | → (vch : Val G₁₁ (TChan (Typing.send t s))) 88 | → (v : Val G₁₂ t) 89 | → (κ : Cont G₂ φ (TChan (SType.force s))) 90 | → Command G 91 | Recv : ∀ {φ G₁ G₂ t s} 92 | → (ss : SSplit G G₁ G₂) 93 | → (vch : Val G₁ (TChan (Typing.recv t s))) 94 | → (κ : Cont G₂ φ (TPair (TChan (SType.force s)) t)) 95 | → Command G 96 | Select : ∀ {φ G₁ G₂ s₁ s₂} 97 | → (ss : SSplit G G₁ G₂) 98 | → (lab : Selector) 99 | → (vch : Val G₁ (TChan (sintern s₁ s₂))) 100 | → (κ : Cont G₂ φ (TChan (selection lab (SType.force s₁) (SType.force s₂)))) 101 | → Command G 102 | Branch : ∀ {φ G₁ G₂ s₁ s₂} 103 | → (ss : SSplit G G₁ G₂) 104 | → (vch : Val G₁ (TChan (sextern s₁ s₂))) 105 | → (dcont : (lab : Selector) → Cont G₂ φ (TChan (selection lab (SType.force s₁) (SType.force s₂)))) 106 | → Command G 107 | NSelect : ∀ {φ G₁ G₂ m alt} 108 | → (ss : SSplit G G₁ G₂) 109 | → (lab : Fin m) 110 | → (vch : Val G₁ (TChan (sintN m alt))) 111 | → (κ : Cont G₂ φ (TChan (SType.force (alt lab)))) 112 | → Command G 113 | NBranch : ∀ {φ G₁ G₂ m alt} 114 | → (ss : SSplit G G₁ G₂) 115 | → (vch : Val G₁ (TChan (sextN m alt))) 116 | → (dcont : (lab : Fin m) → Cont G₂ φ (TChan (SType.force (alt lab)))) 117 | → Command G 118 | 119 | -- 120 | 121 | rewrite-helper : ∀ {G G1 G2 G'' φ'} → Inactive G2 → SSplit G G1 G2 → SSplit G G G'' → VEnv G2 φ' → VEnv G'' φ' 122 | rewrite-helper ina-G2 ssp-GG1G2 ssp-GGG'' ϱ with inactive-right-ssplit ssp-GG1G2 ina-G2 123 | ... | p with rewrite-ssplit1 (sym p) ssp-GG1G2 124 | ... | ssp rewrite ssplit-function2 ssp ssp-GGG'' = ϱ 125 | 126 | -- interpret an expression 127 | run : ∀ {φ φ₁ φ₂ t G G₁ G₂} 128 | → Split φ φ₁ φ₂ 129 | → SSplit G G₁ G₂ 130 | → Expr φ₁ t 131 | → VEnv G₁ φ₁ 132 | → Cont G₂ φ₂ t 133 | → Command G 134 | 135 | run{G = G}{G₁ = G₁}{G₂ = G₂} tsp ssp (var x) ϱ κ with access ϱ x 136 | ... | Gx , Gϱ , ina , ssp12 , v rewrite inactive-right-ssplit ssp12 ina = 137 | Ready ssp v κ 138 | run tsp ssp (nat unr-φ i) ϱ κ = 139 | Ready ssp (VInt i (unrestricted-venv unr-φ ϱ)) κ 140 | run tsp ssp (unit unr-φ) ϱ κ = 141 | Ready ssp (VUnit (unrestricted-venv unr-φ ϱ)) κ 142 | run{φ}{φ₁}{φ₂} tsp ssp (letbind{φ₁₁}{φ₁₂}{t₁}{t₂} sp e₁ e₂) ϱ κ₂ with split-env sp ϱ | split-rotate tsp sp 143 | ... | (G₁ , G₂) , ssp-G1G2 , ϱ₁ , ϱ₂ | φ' , tsp-φ' , φ'-tsp with ssplit-compose ssp ssp-G1G2 144 | ... | Gi , ssp-3i , ssp-42 = 145 | run tsp-φ' ssp-3i e₁ ϱ₁ 146 | (bind φ'-tsp ssp-42 e₂ ϱ₂ κ₂) 147 | run tsp ssp (pair sp x₁ x₂) ϱ κ with split-env sp ϱ 148 | ... | (G₁' , G₂') , ss-G1G1'G2' , ϱ₁ , ϱ₂ with access ϱ₁ x₁ | access ϱ₂ x₂ 149 | ... | Gv₁ , Gr₁ , ina-Gr₁ , ss-v1r1 , v₁ | Gv₂ , Gr₂ , ina-Gr₂ , ss-v2r2 , v₂ rewrite inactive-right-ssplit ss-v1r1 ina-Gr₁ | inactive-right-ssplit ss-v2r2 ina-Gr₂ = 150 | Ready ssp (VPair ss-G1G1'G2' v₁ v₂) κ 151 | run tsp ssp (letpair sp p e) ϱ κ with split-env sp ϱ 152 | ... | (G₁' , G₂') , ss-G1G1'G2' , ϱ₁ , ϱ₂ with access ϱ₁ p 153 | run tsp ssp (letpair sp p e) ϱ κ | (G₁' , G₂') , ss-G1G1'G2' , ϱ₁ , ϱ₂ | Gvp , Gr , ina-Gr , ss-vpr , VPair ss-GG₁G₂ v₁ v₂ with split-rotate tsp sp 154 | ... | φ' , ts-φφ1φ' , ts-φ'φ3φ4 rewrite inactive-right-ssplit ss-vpr ina-Gr with ssplit-compose ss-G1G1'G2' ss-GG₁G₂ 155 | ... | Gi , ss-G3G1Gi , ss-G1G2G2' = run (left (left ts-φ'φ3φ4)) ssp e (vcons ss-G3G1Gi v₁ (vcons ss-G1G2G2' v₂ ϱ₂)) κ 156 | run{φ}{φ₁}{G = G}{G₁ = G₁} tsp ssp (fork e) ϱ κ with ssplit-refl-left G₁ | split-refl-left φ₁ 157 | ... | Gi , ss-g1g1g2 | φ' , unr-φ' , sp-φφφ' with split-env sp-φφφ' ϱ 158 | ... | (Gp1 , Gp2) , ss-Gp , ϱ₁ , ϱ₂ with unrestricted-venv unr-φ' ϱ₂ 159 | ... | ina-Gp2 with inactive-right-ssplit-transform ss-Gp ina-Gp2 160 | ... | ss-Gp' rewrite sym (ssplit-function2 ss-g1g1g2 ss-Gp') = 161 | Fork ssp (bind-thunk sp-φφφ' ss-g1g1g2 e ϱ (halt ina-Gp2 UUnit)) κ 162 | run tsp ssp (new unr-φ s) ϱ κ with unrestricted-venv unr-φ ϱ 163 | ... | ina rewrite inactive-left-ssplit ssp ina = New s κ 164 | run tsp ssp (close ch) ϱ κ with access ϱ ch 165 | ... | Gch , Gϱ , ina , ssp12 , vch with vch | inactive-right-ssplit ssp12 ina 166 | run tsp ssp (close ch) ϱ κ | Gch , Gϱ , ina , ssp12 , vch | vch' | refl = Close ssp vch' κ 167 | run tsp ssp (wait ch) ϱ κ with access ϱ ch 168 | ... | Gch , Gϱ , ina , ssp12 , vch with vch | inactive-right-ssplit ssp12 ina 169 | ... | vch' | refl = Wait ssp vch' κ 170 | run tsp ssp (Expr.send sp ch vv) ϱ κ with split-env sp ϱ 171 | ... | (G₁ , G₂) , ss-gg , ϱ₁ , ϱ₂ with access ϱ₁ ch 172 | ... | G₃ , G₄ , ina-G₄ , ss-g1g3g4 , vch with access ϱ₂ vv 173 | ... | G₅ , G₆ , ina-G₆ , ss-g2g5g6 , vvv with ssplit-join ss-gg ss-g1g3g4 ss-g2g5g6 174 | ... | G₁' , G₂' , ss-g1'g2' , ss-g3g5 , ss-g4g6 rewrite sym (inactive-right-ssplit ss-g1g3g4 ina-G₄) | sym (inactive-right-ssplit ss-g2g5g6 ina-G₆) = Send ssp ss-gg vch vvv κ 175 | run tsp ssp (Expr.recv ch) ϱ κ with access ϱ ch 176 | ... | G₁ , G₂ , ina-G₂ , ss-vi , vch rewrite inactive-right-ssplit ss-vi ina-G₂ = Recv ssp vch κ 177 | run tsp ssp (nselect lab ch) ϱ κ with access ϱ ch 178 | ... | G₁ , G₂ , ina-G₂ , ss-vi , vch rewrite inactive-right-ssplit ss-vi ina-G₂ = NSelect ssp lab vch κ 179 | run tsp ssp (nbranch{m}{alt} sp ch ealts) ϱ κ with split-env sp ϱ 180 | ... | (G₁' , G₂') , ss-G1G1'G2' , ϱ₁ , ϱ₂ with access ϱ₁ ch 181 | ... | G₁ , G₂ , ina-G₂ , ss-vi , vch with ssplit-compose ssp ss-G1G1'G2' 182 | ... | Gi , ss-G-G1'Gi , ss-Gi-G2'-G2 with split-rotate tsp sp 183 | ... | φ' , sp-φφ1φ' , sp-φ'φ3φ4 with inactive-right-ssplit ss-vi ina-G₂ 184 | ... | refl = NBranch ss-G-G1'Gi vch dcont 185 | where 186 | dcont : (lab : Fin m) → Cont Gi _ (TChan (SType.force (alt lab))) 187 | dcont lab = bind sp-φ'φ3φ4 ss-Gi-G2'-G2 (ealts lab) ϱ₂ κ 188 | run tsp ssp (select lab ch) ϱ κ with access ϱ ch 189 | ... | G₁ , G₂ , ina-G₂ , ss-vi , vch rewrite inactive-right-ssplit ss-vi ina-G₂ = Select ssp lab vch κ 190 | run tsp ssp (branch{s₁}{s₂} sp ch e-left e-rght) ϱ κ with split-env sp ϱ 191 | ... | (G₁' , G₂') , ss-G1G1'G2' , ϱ₁ , ϱ₂ with access ϱ₁ ch 192 | ... | G₁ , G₂ , ina-G₂ , ss-vi , vch with ssplit-compose ssp ss-G1G1'G2' 193 | ... | Gi , ss-G-G1'Gi , ss-Gi-G2'-G2 with split-rotate tsp sp 194 | ... | φ' , sp-φφ1φ' , sp-φ'φ3φ4 with inactive-right-ssplit ss-vi ina-G₂ 195 | ... | refl = Branch ss-G-G1'Gi vch dcont 196 | where 197 | dcont : (lab : Selector) → Cont Gi _ (TChan (selection lab (SType.force s₁) (SType.force s₂))) 198 | dcont Left = bind sp-φ'φ3φ4 ss-Gi-G2'-G2 e-left ϱ₂ κ 199 | dcont Right = bind sp-φ'φ3φ4 ss-Gi-G2'-G2 e-rght ϱ₂ κ 200 | run tsp ssp (ulambda sp unr-φ unr-φ₃ ebody) ϱ κ with split-env sp ϱ 201 | ... | (G₁' , G₂') , ss-g1-g1'-g2' , ϱ₁ , ϱ₂ with unrestricted-venv unr-φ₃ ϱ₂ 202 | ... | ina-G2' with inactive-right-ssplit ss-g1-g1'-g2' ina-G2' 203 | ... | refl = Ready ssp (VFun (inj₂ unr-φ) ϱ₁ ebody) κ 204 | run tsp ssp (llambda sp unr-φ₂ ebody) ϱ κ with split-env sp ϱ 205 | ... | (G₁' , G₂') , ss-g1-g1'-g2' , ϱ₁ , ϱ₂ with unrestricted-venv unr-φ₂ ϱ₂ 206 | ... | ina-G2' with inactive-right-ssplit ss-g1-g1'-g2' ina-G2' 207 | ... | refl = Ready ssp (VFun (inj₁ refl) ϱ₁ ebody) κ 208 | run{φ}{φ₁}{φ₂} tsp ssp e@(rec unr-φ ebody) ϱ κ with unrestricted-venv unr-φ ϱ 209 | ... | ina-G2' with inactive-right-ssplit (ssplit-sym ssp) ina-G2' 210 | ... | refl = Ready ssp (VFun (inj₂ unr-φ) ϱ (unr-subst UFun (rght (split-all-unr unr-φ)) unr-φ e ebody)) κ 211 | run tsp ssp (app sp efun earg) ϱ κ with split-env sp ϱ 212 | ... | (G₁ , G₂) , ss-gg , ϱ₁ , ϱ₂ with access ϱ₁ efun 213 | ... | G₃ , G₄ , ina-G₄ , ss-g1g3g4 , vfun with access ϱ₂ earg 214 | run{φ}{φ₁}{φ₂} tsp ssp (app sp efun earg) ϱ κ | (G₁ , G₂) , ss-gg , ϱ₁ , ϱ₂ | G₃ , G₄ , ina-G₄ , ss-g1g3g4 , VFun{φ'} x ϱ₃ e | G₅ , G₆ , ina-G₆ , ss-g2g5g6 , varg with ssplit-compose4 ss-gg ss-g2g5g6 215 | ... | Gi , ss-g1-g5-gi , ss-gi-g1-g6 with ssplit-compose ssp ss-g1-g5-gi 216 | ... | Gi₁ , ss-g-g5-gi1 , ss-gi1-gi-g2 with inactive-right-ssplit ss-g1g3g4 ina-G₄ 217 | ... | refl with inactive-right-ssplit ss-gi-g1-g6 ina-G₆ 218 | ... | refl with split-from-disjoint φ' φ₂ 219 | ... | φ₀ , sp' = Ready ss-g-g5-gi1 varg (bind sp' ss-gi1-gi-g2 e ϱ₃ κ) 220 | run tsp ssp (subsume e t≤t') ϱ κ = 221 | run tsp ssp e ϱ (subsume t≤t' κ) 222 | 223 | -- apply a continuation 224 | apply-cont : ∀ {G G₁ G₂ t φ} 225 | → (ssp : SSplit G G₁ G₂) 226 | → (κ : Cont G₂ φ t) 227 | → Val G₁ t 228 | → Command G 229 | apply-cont ssp (halt inG un-t) v with unrestricted-val un-t v 230 | ... | inG2 with inactive-right-ssplit ssp inG 231 | ... | refl = Halt (ssplit-inactive ssp inG2 inG) un-t v 232 | apply-cont ssp (bind ts ss e₂ ϱ₂ κ) v with ssplit-compose3 ssp ss 233 | ... | Gi , ss-GGiG4 , ss-GiG1G3 = 234 | run (left ts) ss-GGiG4 e₂ (vcons ss-GiG1G3 v ϱ₂) κ 235 | apply-cont ssp (bind-thunk ts ss e₂ ϱ₂ κ) v with unrestricted-val UUnit v 236 | ... | inG1 with inactive-left-ssplit ssp inG1 237 | ... | refl = 238 | run ts ss e₂ ϱ₂ κ 239 | apply-cont ssp (subsume t≤t' κ) v = 240 | apply-cont ssp κ (coerce v t≤t') 241 | 242 | extract-inactive-from-cont : ∀ {G t φ} → Unr t → Cont G φ t → ∃ λ G' → Inactive G' × SSplit G G' G 243 | extract-inactive-from-cont{G} un-t κ = ssplit-refl-right-inactive G 244 | 245 | -- lifting through a trivial extension 246 | 247 | lift-val : ∀ {G t} → Val G t → Val (nothing ∷ G) t 248 | lift-venv : ∀ {G φ} → VEnv G φ → VEnv (nothing ∷ G) φ 249 | 250 | lift-val (VUnit x) = VUnit (::-inactive x) 251 | lift-val (VInt i x) = VInt i (::-inactive x) 252 | lift-val (VPair x v v₁) = VPair (ss-both x) (lift-val v) (lift-val v₁) 253 | lift-val (VChan b vcr) = VChan b (there vcr) 254 | lift-val (VFun lu ϱ e) = VFun lu (lift-venv ϱ) e 255 | 256 | lift-venv (vnil ina) = vnil (::-inactive ina) 257 | lift-venv (vcons ssp v ϱ) = vcons (ss-both ssp) (lift-val v) (lift-venv ϱ) 258 | 259 | lift-cont : ∀ {G t φ} → Cont G φ t → Cont (nothing ∷ G) φ t 260 | lift-cont (halt inG un-t) = halt (::-inactive inG) un-t 261 | lift-cont (bind ts ss e₂ ϱ₂ κ) = bind ts (ss-both ss) e₂ (lift-venv ϱ₂) (lift-cont κ) 262 | lift-cont (bind-thunk ts ss e₂ ϱ₂ κ) = bind-thunk ts (ss-both ss) e₂ (lift-venv ϱ₂) (lift-cont κ) 263 | lift-cont (subsume t≤t' κ) = subsume t≤t' (lift-cont κ) 264 | 265 | lift-command : ∀ {G} → Command G → Command (nothing ∷ G) 266 | lift-command (Fork ss κ₁ κ₂) = Fork (ss-both ss) (lift-cont κ₁) (lift-cont κ₂) 267 | lift-command (Ready ss v κ) = Ready (ss-both ss) (lift-val v) (lift-cont κ) 268 | lift-command (Halt x unr-t v) = Halt (::-inactive x) unr-t (lift-val v) 269 | lift-command (New s κ) = New s (lift-cont κ) 270 | lift-command (Close ss v κ) = Close (ss-both ss) (lift-val v) (lift-cont κ) 271 | lift-command (Wait ss v κ) = Wait (ss-both ss) (lift-val v) (lift-cont κ) 272 | lift-command (Send ss ss-args vch v κ) = Send (ss-both ss) (ss-both ss-args) (lift-val vch) (lift-val v) (lift-cont κ) 273 | lift-command (Recv ss vch κ) = Recv (ss-both ss) (lift-val vch) (lift-cont κ) 274 | lift-command (Select ss lab vch κ) = Select (ss-both ss) lab (lift-val vch) (lift-cont κ) 275 | lift-command (Branch ss vch dcont) = Branch (ss-both ss) (lift-val vch) λ lab → lift-cont (dcont lab) 276 | lift-command (NSelect ss lab vch κ) = NSelect (ss-both ss) lab (lift-val vch) (lift-cont κ) 277 | lift-command (NBranch ss vch dcont) = NBranch (ss-both ss) (lift-val vch) λ lab → lift-cont (dcont lab) 278 | -- threads 279 | data ThreadPool (G : SCtx) : Set where 280 | tnil : (ina : Inactive G) → ThreadPool G 281 | tcons : ∀ {G₁ G₂} → (ss : SSplit G G₁ G₂) → (cmd : Command G₁) → (tp : ThreadPool G₂) → ThreadPool G 282 | 283 | -- tack a task to the end of a thread pool to implement round robin scheduling 284 | tsnoc : ∀ {G Gpool Gcmd} → SSplit G Gcmd Gpool → ThreadPool Gpool → Command Gcmd → ThreadPool G 285 | tsnoc ss (tnil ina) cmd = tcons ss cmd (tnil ina) 286 | tsnoc ss (tcons ss₁ cmd₁ tp) cmd with ssplit-compose2 ss ss₁ 287 | ... | Gi , ss-top , ss-rec = tcons (ssplit-sym ss-top) cmd₁ (tsnoc ss-rec tp cmd) 288 | 289 | -- append thread pools 290 | tappend : ∀ {G G1 G2} → SSplit G G1 G2 → ThreadPool G1 → ThreadPool G2 → ThreadPool G 291 | tappend ss-top (tnil ina) tp2 rewrite inactive-left-ssplit ss-top ina = tp2 292 | tappend ss-top (tcons ss cmd tp1) tp2 with ssplit-compose ss-top ss 293 | ... | Gi , ss-top' , ss-rec = tcons ss-top' cmd (tappend ss-rec tp1 tp2) 294 | 295 | -- apply the inactive extension to a thread pool 296 | lift-threadpool : ∀ {G} → ThreadPool G → ThreadPool (nothing ∷ G) 297 | lift-threadpool (tnil ina) = tnil (::-inactive ina) 298 | lift-threadpool (tcons ss cmd tp) = tcons (ss-both ss) (lift-command cmd) (lift-threadpool tp) 299 | 300 | matchWaitAndGo : ∀ {G Gc Gc₁ Gc₂ Gtp Gtpwl Gtpacc φ} 301 | → SSplit G Gc Gtp 302 | -- close command 303 | → SSplit Gc Gc₁ Gc₂ × Val Gc₁ (TChan send!) × Cont Gc₂ φ TUnit 304 | -- focused thread pool 305 | → SSplit Gtp Gtpwl Gtpacc → ThreadPool Gtpwl → ThreadPool Gtpacc 306 | → Maybe (∃ λ G' → ThreadPool G') 307 | matchWaitAndGo ss-top cl-info ss-tp (tnil ina) tp-acc = nothing 308 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss (Fork ss₁ κ₁ κ₂) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 309 | ... | Gi , ss-tp' , ss' = 310 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' (Fork ss₁ κ₁ κ₂) tp-acc) 311 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss (Ready ss₁ v κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 312 | ... | Gi , ss-tp' , ss' = 313 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' (Ready ss₁ v κ) tp-acc) 314 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss cmd@(Halt x _ _) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 315 | ... | Gi , ss-tp' , ss' = 316 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 317 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss (New s κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 318 | ... | Gi , ss-tp' , ss' = 319 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' (New s κ) tp-acc) 320 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss cmd@(NSelect ss-args lab vch κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 321 | ... | Gi , ss-tp' , ss' = 322 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 323 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss cmd@(Select ss-args lab vch κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 324 | ... | Gi , ss-tp' , ss' = 325 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 326 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss cmd@(NBranch _ _ _) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 327 | ... | Gi , ss-tp' , ss' = 328 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 329 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss cmd@(Branch _ _ _) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 330 | ... | Gi , ss-tp' , ss' = 331 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 332 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss cmd@(Send _ ss-args vch v κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 333 | ... | Gi , ss-tp' , ss' = 334 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 335 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss cmd@(Recv _ vch κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 336 | ... | Gi , ss-tp' , ss' = 337 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 338 | matchWaitAndGo ss-top cl-info ss-tp (tcons ss (Close ss₁ v κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 339 | ... | Gi , ss-tp' , ss' = 340 | matchWaitAndGo ss-top cl-info ss-tp' tp-wl (tcons ss' (Close ss₁ v κ) tp-acc) 341 | matchWaitAndGo ss-top (ss-cl , VChan cl-b cl-vcr , cl-κ) ss-tp (tcons ss (Wait ss₁ (VChan w-b w-vcr) κ) tp-wl) tp-acc with ssplit-compose6 ss ss₁ 342 | ... | Gi , ss-g3gi , ss-g4g2 with ssplit-compose6 ss-tp ss-g3gi 343 | ... | Gi' , ss-g3gi' , ss-gtpacc with ssplit-join ss-top ss-cl ss-g3gi' 344 | ... | Gchannels , Gother , ss-top' , ss-channels , ss-others with vcr-match ss-channels cl-vcr w-vcr 345 | matchWaitAndGo ss-top (ss-cl , VChan cl-b cl-vcr , cl-κ) ss-tp (tcons ss (Wait ss₁ (VChan w-b w-vcr) κ) tp-wl) tp-acc | Gi , ss-g3gi , ss-g4g2 | Gi' , ss-g3gi' , ss-gtpacc | Gchannels , Gother , ss-top' , ss-channels , ss-others | nothing with ssplit-compose5 ss-tp ss 346 | ... | _ , ss-tp' , ss' = matchWaitAndGo ss-top (ss-cl , VChan cl-b cl-vcr , cl-κ) ss-tp' tp-wl (tcons ss' (Wait ss₁ (VChan w-b w-vcr) κ) tp-acc) 347 | matchWaitAndGo{Gc₂ = Gc₂} ss-top (ss-cl , VChan cl-b cl-vcr , cl-κ) ss-tp (tcons ss (Wait ss₁ (VChan w-b w-vcr) κ) tp-wl) tp-acc | Gi , ss-g3gi , ss-g4g2 | Gi' , ss-g3gi' , ss-gtpacc | Gchannels , Gother , ss-top' , ss-channels , ss-others | just x with ssplit-refl-right-inactive Gc₂ 348 | ... | Gunit , ina-Gunit , ss-stopped with extract-inactive-from-cont UUnit κ 349 | ... | Gunit' , ina-Gunit' , ss-stopped' with ssplit-compose ss-gtpacc (ssplit-sym ss-g4g2) 350 | ... | Gi'' , ss-int , ss-g2gacc with ssplit-compose2 ss-others ss-int 351 | ... | Gi''' , ss-other , ss-outer-cons = just (Gother , tappend (ssplit-sym ss-other) tp-wl (tcons ss-outer-cons (Ready ss-stopped (VUnit ina-Gunit) cl-κ) (tcons ss-g2gacc (Ready ss-stopped' (VUnit ina-Gunit') κ) tp-acc))) 352 | 353 | matchSendAndGo : ∀ {G Gc Gc₁ Gc₂ Gtp Gtpwl Gtpacc φ t s} 354 | → SSplit G Gc Gtp 355 | -- read command 356 | → SSplit Gc Gc₁ Gc₂ × Val Gc₁ (TChan (Typing.recv t s)) × Cont Gc₂ φ (TPair (TChan (SType.force s)) t) 357 | -- focused thread pool 358 | → SSplit Gtp Gtpwl Gtpacc → ThreadPool Gtpwl → ThreadPool Gtpacc 359 | → Maybe (∃ λ G' → ThreadPool G') 360 | matchSendAndGo ss-top recv-info ss-tp (tnil ina) tp-acc = nothing 361 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(Fork ss₁ κ₁ κ₂) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 362 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 363 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(Ready ss₁ v κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 364 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 365 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(Halt _ _ _) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 366 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 367 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(New s κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 368 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 369 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(NSelect ss-arg lab vch κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 370 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 371 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(Select ss-arg lab vch κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 372 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 373 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(NBranch _ _ _) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 374 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 375 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(Branch _ _ _) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 376 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 377 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(Close ss₁ v κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 378 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 379 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(Wait ss₁ v κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 380 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 381 | matchSendAndGo ss-top recv-info ss-tp (tcons ss cmd@(Recv ss₁ vch κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 382 | ... | Gi , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 383 | matchSendAndGo ss-top recv-info@(ss-rv , VChan b₁ vcr₁ , κ-rv) ss-tp (tcons ss cmd@(Send ss₁ ss-args (VChan b vcr) v κ) tp-wl) tp-acc with ssplit-compose6 ss₁ ss-args 384 | ... | Gi , ss-g1g11gi , ss-gig12g3 with ssplit-compose6 ss ss-g1g11gi 385 | ... | Gi' , ss-gtpwlg11g2 , ss-gi'gig2 with ssplit-compose6 ss-tp ss-gtpwlg11g2 386 | ... | Gi'' , ss-gtpg11gi'' , ss-gi''gi'gtpacc with ssplit-join ss-top ss-rv ss-gtpg11gi'' 387 | ... | G₁' , G₂' , ss-gg1'g2' , ss-g1'gc1g11 , ss-g2'gc2gi'' with vcr-match-2-sr (ssplit2 ss-gg1'g2' ss-g1'gc1g11) vcr₁ vcr 388 | ... | just (t≤t1 , ds1≡s , GG , GG1 , GG11 , G12 , ssplit2 ss-out1 ss-out2 , vcr-recv , vcr-send) with ssplit-compose ss-gi''gi'gtpacc ss-gi'gig2 389 | ... | GSi , ss-Gi''GiGi1 , ss-Gi1G2Gtpacc with ssplit-join ss-out1 ss-out2 ss-g2'gc2gi'' 390 | ... | GG1' , GG2' , ss-GG-GG1'-GG2' , ss-GG1'-GG11-Gc2 , ss-GG2'-G12-Gi'' with ssplit-rotate ss-GG2'-G12-Gi'' ss-Gi''GiGi1 ss-gig12g3 391 | ... | Gi''+ , Gi+ , ss-GG2-G12-Gi''+ , ss-Gi''+Gi+Gsi , ss-Gi+-G12-G4 with ssplit-join ss-GG-GG1'-GG2' ss-GG1'-GG11-Gc2 ss-GG2-G12-Gi''+ 392 | ... | GG1'' , GG2'' , ss-GG-GG1''-GG2'' , ss-GG1''-GG11-G12 , ss-GG2''-Gc2-Gi''+ with ssplit-compose3 ss-GG-GG1''-GG2'' ss-GG2''-Gc2-Gi''+ 393 | ... | _ , ss-GG-Gii-Gi''+ , ss-Gii-GG1''-Gc2 = just (GG , (tcons ss-GG-Gii-Gi''+ (Ready ss-Gii-GG1''-Gc2 (VPair ss-GG1''-GG11-G12 (VChan b₁ vcr-recv) (coerce v t≤t1)) κ-rv {-κ-rv-}) (tcons ss-Gi''+Gi+Gsi (Ready ss-Gi+-G12-G4 (VChan b vcr-send) κ) (tappend ss-Gi1G2Gtpacc tp-wl tp-acc)))) 394 | matchSendAndGo ss-top recv-info@(ss-rv , VChan b₁ vcr₁ , κ-rv) ss-tp (tcons ss cmd@(Send ss₁ ss-args (VChan b vcr) v κ) tp-wl) tp-acc | Gi , ss-g1g11gi , ss-gig12g3 | Gi' , ss-gtpwlg11g2 , ss-gi'gig2 | Gi'' , ss-gtpg11gi'' , ss-gi''gi'gtpacc | G₁' , G₂' , ss-gg1'g2' , ss-g1'gc1g11 , ss-g2'gc2gi'' | nothing with ssplit-compose5 ss-tp ss 395 | ... | Gi0 , ss-tp' , ss' = matchSendAndGo ss-top recv-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 396 | 397 | matchBranchAndGo : ∀ {G Gc Gc₁ Gc₂ Gtp Gtpwl Gtpacc φ s₁ s₂} 398 | → SSplit G Gc Gtp 399 | -- select command 400 | → (SSplit Gc Gc₁ Gc₂ × ∃ λ lab → Val Gc₁ (TChan (sintern s₁ s₂)) × Cont Gc₂ φ (TChan (selection lab (SType.force s₁) (SType.force s₂)))) 401 | -- focused thread pool 402 | → SSplit Gtp Gtpwl Gtpacc → ThreadPool Gtpwl → ThreadPool Gtpacc 403 | → Maybe (∃ λ G' → ThreadPool G') 404 | matchBranchAndGo ss-top select-info ss-tp (tnil ina) tp-acc = nothing 405 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(Fork ss₁ κ₁ κ₂) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 406 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 407 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(Ready ss₁ v κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 408 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 409 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(Halt _ _ _) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 410 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 411 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(New s κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 412 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 413 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(Close ss₁ v κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 414 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 415 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(Wait ss₁ v κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 416 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 417 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(Send ss₁ ss-args vch v κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 418 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 419 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(Recv ss₁ vch κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 420 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 421 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(NSelect ss₁ lab vch κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 422 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 423 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(NBranch _ _ _) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 424 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 425 | matchBranchAndGo ss-top select-info ss-tp (tcons ss cmd@(Select ss₁ lab vch κ) tp-wl) tp-acc with ssplit-compose5 ss-tp ss 426 | ... | Gi , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 427 | matchBranchAndGo ss-top (ss-vκ , lab , VChan b₁ vcr₁ , κ) ss-tp (tcons ss (Branch ss₁ (VChan b vcr) dcont) tp-wl) tp-acc with ssplit-compose6 ss ss₁ 428 | ... | Gi , ss-gtpwl-g3-gi , ss-gi-g4-g2 with ssplit-compose6 ss-tp ss-gtpwl-g3-gi 429 | ... | Gi1 , ss-gtp-g3-gi1 , ss-gi1-gi-gtpacc with ssplit-join ss-top ss-vκ ss-gtp-g3-gi1 430 | ... | Gc' , Gtp' , ss-g-gc'-gtp' , ss-gc'-gc1-g1 , ss-gtp'-gc2-gi1 with vcr-match-2-sb (ssplit2 ss-g-gc'-gtp' ss-gc'-gc1-g1) vcr₁ vcr lab 431 | matchBranchAndGo ss-top select-info@(ss-vκ , lab , VChan b₁ vcr₁ , κ) ss-tp (tcons ss cmd@(Branch ss₁ (VChan b vcr) dcont) tp-wl) tp-acc | Gi , ss-gtpwl-g3-gi , ss-gi-g4-g2 | Gi1 , ss-gtp-g3-gi1 , ss-gi1-gi-gtpacc | Gc' , Gtp' , ss-g-gc'-gtp' , ss-gc'-gc1-g1 , ss-gtp'-gc2-gi1 | nothing with ssplit-compose5 ss-tp ss 432 | ... | Gix , ss-tp' , ss' = matchBranchAndGo ss-top select-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 433 | matchBranchAndGo ss-top (ss-vκ , lab , VChan b₁ vcr₁ , κ) ss-tp (tcons ss (Branch ss₁ (VChan b vcr) dcont) tp-wl) tp-acc | Gi , ss-gtpwl-g3-gi , ss-gi-g4-g2 | Gi1 , ss-gtp-g3-gi1 , ss-gi1-gi-gtpacc | Gc' , Gtp' , ss-g-gc'-gtp' , ss-gc'-gc1-g1 , ss-gtp'-gc2-gi1 | just (ds3=s1 , ds4=s2 , GG , GG1 , GG11 , GG12 , ssplit2 ss1' ss2' , vcr-sel , vcr-bra) with ssplit-compose ss-gi1-gi-gtpacc ss-gi-g4-g2 434 | ... | Gi2 , ss-gi1-g3-gi2 , ss-gi2-g2-gtpacc with ssplit-join ss1' ss2' ss-gtp'-gc2-gi1 435 | ... | GGG1 , GGG2 , ss-GG-ggg1-ggg2 , ss-ggg1-gc1-gc2 , ss-ggg2-g1-gi1 with ssplit-compose3 ss-ggg2-g1-gi1 ss-gi1-g3-gi2 436 | ... | Gi3 , ss-ggg2-gi3-gi2 , ss-gi3-gg12-g2 = just (GG , tcons ss-GG-ggg1-ggg2 (Ready ss-ggg1-gc1-gc2 (VChan b₁ vcr-sel) κ) (tcons ss-ggg2-gi3-gi2 (Ready ss-gi3-gg12-g2 (VChan b vcr-bra) (dcont lab)) (tappend ss-gi2-g2-gtpacc tp-wl tp-acc))) 437 | 438 | matchNBranchAndGo : ∀ {G Gc Gc₁ Gc₂ Gtp Gtpwl Gtpacc φ m alt} 439 | → SSplit G Gc Gtp 440 | -- select command 441 | → (SSplit Gc Gc₁ Gc₂ × Σ (Fin m) λ lab → Val Gc₁ (TChan (sintN m alt)) × Cont Gc₂ φ (TChan (SType.force (alt lab)))) 442 | -- focused thread pool 443 | → SSplit Gtp Gtpwl Gtpacc → ThreadPool Gtpwl → ThreadPool Gtpacc 444 | → Maybe (∃ λ G' → ThreadPool G') 445 | matchNBranchAndGo ss-top nselect-info ss-tp (tnil ina) tp-acc = nothing 446 | matchNBranchAndGo ss-top (ss-vκ , lab , VChan b₁ vcr₁ , κ) ss-tp (tcons ss cmd@(NBranch ss₁ (VChan b vcr) dcont) tp-wl) tp-acc with ssplit-compose6 ss ss₁ 447 | ... | Gi , ss-gtpwl-g3-gi , ss-gi-g4-g2 with ssplit-compose6 ss-tp ss-gtpwl-g3-gi 448 | ... | Gi1 , ss-gtp-g3-gi1 , ss-gi1-gi-gtpacc with ssplit-join ss-top ss-vκ ss-gtp-g3-gi1 449 | ... | Gc' , Gtp' , ss-g-gc'-gtp' , ss-gc'-gc1-g1 , ss-gtp'-gc2-gi1 with vcr-match-2-nsb (ssplit2 ss-g-gc'-gtp' ss-gc'-gc1-g1) vcr₁ vcr lab 450 | matchNBranchAndGo ss-top nselect-info@(ss-vκ , lab , VChan b₁ vcr₁ , κ) ss-tp (tcons ss cmd@(NBranch ss₁ (VChan b vcr) dcont) tp-wl) tp-acc | Gi , ss-gtpwl-g3-gi , ss-gi-g4-g2 | Gi1 , ss-gtp-g3-gi1 , ss-gi1-gi-gtpacc | Gc' , Gtp' , ss-g-gc'-gtp' , ss-gc'-gc1-g1 , ss-gtp'-gc2-gi1 | nothing with ssplit-compose5 ss-tp ss 451 | ... | Gix , ss-tp' , ss' = matchNBranchAndGo ss-top nselect-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 452 | matchNBranchAndGo ss-top (ss-vκ , lab , VChan b₁ vcr₁ , κ) ss-tp (tcons ss (NBranch ss₁ (VChan b vcr) dcont) tp-wl) tp-acc | Gi , ss-gtpwl-g3-gi , ss-gi-g4-g2 | Gi1 , ss-gtp-g3-gi1 , ss-gi1-gi-gtpacc | Gc' , Gtp' , ss-g-gc'-gtp' , ss-gc'-gc1-g1 , ss-gtp'-gc2-gi1 | just (m1≤m , ds3=s1 , GG , GG1 , GG11 , GG12 , ssplit2 ss1' ss2' , vcr-sel , vcr-bra) with ssplit-compose ss-gi1-gi-gtpacc ss-gi-g4-g2 453 | ... | Gi2 , ss-gi1-g3-gi2 , ss-gi2-g2-gtpacc with ssplit-join ss1' ss2' ss-gtp'-gc2-gi1 454 | ... | GGG1 , GGG2 , ss-GG-ggg1-ggg2 , ss-ggg1-gc1-gc2 , ss-ggg2-g1-gi1 with ssplit-compose3 ss-ggg2-g1-gi1 ss-gi1-g3-gi2 455 | ... | Gi3 , ss-ggg2-gi3-gi2 , ss-gi3-gg12-g2 = just (GG , tcons ss-GG-ggg1-ggg2 (Ready ss-ggg1-gc1-gc2 (VChan b₁ vcr-sel) κ) (tcons ss-ggg2-gi3-gi2 (Ready ss-gi3-gg12-g2 (VChan b vcr-bra) (dcont (inject≤ lab m1≤m))) (tappend ss-gi2-g2-gtpacc tp-wl tp-acc))) 456 | matchNBranchAndGo ss-top nselect-info ss-tp (tcons ss cmd tp-wl) tp-acc with ssplit-compose5 ss-tp ss 457 | ... | Gi , ss-tp' , ss' = matchNBranchAndGo ss-top nselect-info ss-tp' tp-wl (tcons ss' cmd tp-acc) 458 | -------------------------------------------------------------------------------- /src/Syntax.agda: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | 3 | open import Data.Fin 4 | open import Data.List hiding (reverse) 5 | open import Data.List.All 6 | open import Data.Nat 7 | open import Data.Product 8 | 9 | open import Typing hiding (send ; recv) 10 | 11 | -- expressions 12 | data Expr Φ : Type → Set where 13 | var : ∀ {t} 14 | → (x : t ∈ Φ) 15 | → Expr Φ t 16 | 17 | nat : (unr-Φ : All Unr Φ) 18 | → (i : ℕ) 19 | → Expr Φ TInt 20 | 21 | unit : (unr-Φ : All Unr Φ) 22 | → Expr Φ TUnit 23 | 24 | letbind : ∀ {Φ₁ Φ₂ t₁ t₂} 25 | → (sp : Split Φ Φ₁ Φ₂) 26 | → (e₁ : Expr Φ₁ t₁) 27 | → (e₂ : Expr (t₁ ∷ Φ₂) t₂) 28 | → Expr Φ t₂ 29 | 30 | pair : ∀ {Φ₁ Φ₂ t₁ t₂} 31 | → (sp : Split Φ Φ₁ Φ₂) 32 | → (x₁ : t₁ ∈ Φ₁) 33 | → (x₂ : t₂ ∈ Φ₂) 34 | → Expr Φ (TPair t₁ t₂) 35 | 36 | letpair : ∀ {Φ₁ Φ₂ t₁ t₂ t} 37 | → (sp : Split Φ Φ₁ Φ₂) 38 | → (p : TPair t₁ t₂ ∈ Φ₁) 39 | → (e : Expr (t₁ ∷ t₂ ∷ Φ₂) t) 40 | → Expr Φ t 41 | 42 | fork : (e : Expr Φ TUnit) 43 | → Expr Φ TUnit 44 | 45 | new : (unr-Φ : All Unr Φ) 46 | → (s : SType) 47 | → Expr Φ (TPair (TChan (SType.force s)) (TChan (SType.force (dual s)))) 48 | 49 | send : ∀ {Φ₁ Φ₂ s t} 50 | → (sp : Split Φ Φ₁ Φ₂) 51 | → (ch : (TChan (transmit SND t s)) ∈ Φ₁) 52 | → (vv : t ∈ Φ₂) 53 | → Expr Φ (TChan (SType.force s)) 54 | 55 | recv : ∀ {s t} 56 | → (ch : (TChan (transmit RCV t s)) ∈ Φ) 57 | → Expr Φ (TPair (TChan (SType.force s)) t) 58 | 59 | close : (ch : TChan send! ∈ Φ) 60 | → Expr Φ TUnit 61 | 62 | wait : (ch : TChan send? ∈ Φ) 63 | → Expr Φ TUnit 64 | 65 | select : ∀ {s₁ s₂} 66 | → (lab : Selector) 67 | → (ch : TChan (sintern s₁ s₂) ∈ Φ) 68 | → Expr Φ (TChan (selection lab (SType.force s₁) (SType.force s₂))) 69 | 70 | branch : ∀ {s₁ s₂ Φ₁ Φ₂ t} 71 | → (sp : Split Φ Φ₁ Φ₂) 72 | → (ch : TChan (sextern s₁ s₂) ∈ Φ₁) 73 | → (eleft : Expr (TChan (SType.force s₁) ∷ Φ₂) t) 74 | → (erght : Expr (TChan (SType.force s₂) ∷ Φ₂) t) 75 | → Expr Φ t 76 | 77 | nselect : ∀ {m alt} 78 | → (lab : Fin m) 79 | → (ch : TChan (sintN m alt) ∈ Φ) 80 | → Expr Φ (TChan (SType.force (alt lab))) 81 | 82 | nbranch : ∀ {m alt Φ₁ Φ₂ t} 83 | → (sp : Split Φ Φ₁ Φ₂) 84 | → (ch : TChan (sextN m alt) ∈ Φ₁) 85 | → (ealts : (i : Fin m) → Expr (TChan (SType.force (alt i)) ∷ Φ₂) t) 86 | → Expr Φ t 87 | 88 | ulambda : ∀ {Φ₁ Φ₂ t₁ t₂} 89 | → (sp : Split Φ Φ₁ Φ₂) 90 | → (unr-Φ₁ : All Unr Φ₁) 91 | → (unr-Φ₂ : All Unr Φ₂) 92 | → (ebody : Expr (t₁ ∷ Φ₁) t₂) 93 | → Expr Φ (TFun UU t₁ t₂) 94 | 95 | llambda : ∀ {Φ₁ Φ₂ t₁ t₂} 96 | → (sp : Split Φ Φ₁ Φ₂) 97 | → (unr-Φ₂ : All Unr Φ₂) 98 | → (ebody : Expr (t₁ ∷ Φ₁) t₂) 99 | → Expr Φ (TFun LL t₁ t₂) 100 | 101 | app : ∀ {Φ₁ Φ₂ lu t₁ t₂} 102 | → (sp : Split Φ Φ₁ Φ₂) 103 | → (xfun : TFun lu t₁ t₂ ∈ Φ₁) 104 | → (xarg : t₁ ∈ Φ₂) 105 | → Expr Φ t₂ 106 | 107 | rec : ∀ {t₁ t₂} 108 | → (unr-Φ : All Unr Φ) 109 | → let t = TFun UU t₁ t₂ in 110 | (ebody : Expr (t ∷ t₁ ∷ Φ) t₂) 111 | → Expr Φ t 112 | 113 | subsume : ∀ {t₁ t₂} 114 | → (e : Expr Φ t₁) 115 | → (t≤t' : SubT t₁ t₂) 116 | → Expr Φ t₂ 117 | 118 | unr-weaken : ∀ {Φ Φ₁ Φ₂ t} → Split Φ Φ₁ Φ₂ → All Unr Φ₂ → Expr Φ₁ t → Expr Φ t 119 | unr-weaken sp un-Φ₂ (var x) = var (unr-weaken-var sp un-Φ₂ x) 120 | unr-weaken sp un-Φ₂ (nat unr-Φ i) = letbind sp (nat unr-Φ i) (var (here un-Φ₂)) 121 | unr-weaken sp un-Φ₂ (unit unr-Φ) = letbind sp (unit unr-Φ) (var (here un-Φ₂)) 122 | unr-weaken sp un-Φ₂ (letbind sp₁ e e₁) = letbind sp (letbind sp₁ e e₁) (var (here un-Φ₂)) 123 | unr-weaken sp un-Φ₂ (pair sp₁ x₁ x₂) = letbind sp (pair sp₁ x₁ x₂) (var (here un-Φ₂)) 124 | unr-weaken sp un-Φ₂ (letpair sp₁ p e) = letbind sp (letpair sp₁ p e) (var (here un-Φ₂)) 125 | unr-weaken sp un-Φ₂ (fork e) = unr-weaken sp un-Φ₂ e 126 | unr-weaken sp un-Φ₂ (new unr-Φ s) = letbind sp (new unr-Φ s) (var (here un-Φ₂)) 127 | unr-weaken sp un-Φ₂ (send sp₁ ch vv) = letbind sp (send sp₁ ch vv) (var (here un-Φ₂)) 128 | unr-weaken sp un-Φ₂ (recv ch) = letbind sp (recv ch) (var (here un-Φ₂)) 129 | unr-weaken sp un-Φ₂ (close ch) = letbind sp (close ch) (var (here un-Φ₂)) 130 | unr-weaken sp un-Φ₂ (wait ch) = letbind sp (wait ch) (var (here un-Φ₂)) 131 | unr-weaken sp un-Φ₂ (nselect lab ch) = letbind sp (nselect lab ch) (var (here un-Φ₂)) 132 | unr-weaken sp un-Φ₂ (nbranch sp₁ ch ealts) = letbind sp (nbranch sp₁ ch ealts) (var (here un-Φ₂)) 133 | unr-weaken sp un-Φ₂ (select lab ch) = letbind sp (select lab ch) (var (here un-Φ₂)) 134 | unr-weaken sp un-Φ₂ (branch sp₁ ch e e₁) with split-rotate sp sp₁ 135 | ... | Φ' , sp-ΦΦ₃Φ' , sp-Φ'Φ₄Φ₂ = branch sp-ΦΦ₃Φ' ch (unr-weaken (left sp-Φ'Φ₄Φ₂) un-Φ₂ e) (unr-weaken (left sp-Φ'Φ₄Φ₂) un-Φ₂ e₁) 136 | unr-weaken sp un-Φ₂ (ulambda sp₁ unr-Φ₁ unr-Φ₂ e) = ulambda sp (split-unr sp₁ unr-Φ₁ unr-Φ₂) un-Φ₂ (unr-weaken (left sp₁) unr-Φ₂ e) 137 | unr-weaken sp un-Φ₂ (llambda sp₁ unr-Φ₂ e) = llambda sp un-Φ₂ (unr-weaken (left sp₁) unr-Φ₂ e) 138 | unr-weaken sp un-Φ₂ (app sp₁ xfun xarg) = letbind sp (app sp₁ xfun xarg) (var (here un-Φ₂)) 139 | unr-weaken sp un-Φ₂ (rec unr-Φ e) = rec (split-unr sp unr-Φ un-Φ₂) (unr-weaken (left (left sp)) un-Φ₂ e) 140 | unr-weaken sp un-Φ₂ (subsume e t≤t') = subsume (unr-weaken sp un-Φ₂ e) t≤t' 141 | 142 | lift-expr : ∀ {Φ t tᵤ} → Unr tᵤ → Expr Φ t → Expr (tᵤ ∷ Φ) t 143 | lift-expr unrtu (var x) = var (there unrtu x) 144 | lift-expr unrtu (nat unr-Φ i) = nat (unrtu ∷ unr-Φ) i 145 | lift-expr unrtu (unit unr-Φ) = unit (unrtu ∷ unr-Φ) 146 | lift-expr unrtu (letbind sp e e₁) = letbind (left sp) (lift-expr unrtu e) e₁ 147 | lift-expr unrtu (pair sp x₁ x₂) = pair (rght sp) x₁ (there unrtu x₂) 148 | lift-expr unrtu (letpair sp p e) = letpair (left sp) (there unrtu p) e 149 | lift-expr unrtu (fork e) = lift-expr unrtu e 150 | lift-expr unrtu (new unr-Φ s) = new (unrtu ∷ unr-Φ) s 151 | lift-expr unrtu (close ch) = close (there unrtu ch) 152 | lift-expr unrtu (wait ch) = wait (there unrtu ch) 153 | lift-expr unrtu (send sp ch vv) = send (rght sp) ch (there unrtu vv) 154 | lift-expr unrtu (recv ch) = recv (there unrtu ch) 155 | lift-expr unrtu (nselect lab ch) = nselect lab (there unrtu ch) 156 | lift-expr unrtu (nbranch sp ch ealts) = nbranch (left sp) (there unrtu ch) ealts 157 | lift-expr unrtu (select lab ch) = select lab (there unrtu ch) 158 | lift-expr unrtu (branch sp ch x₁ x₂) = branch (left sp) (there unrtu ch) x₁ x₂ 159 | lift-expr unrtu (ulambda sp unr-Φ unr-Φ₂ ebody) = ulambda (rght sp) unr-Φ (unrtu ∷ unr-Φ₂) ebody 160 | lift-expr unrtu (llambda sp unr-Φ₂ ebody) = llambda (rght sp) (unrtu ∷ unr-Φ₂) ebody 161 | lift-expr unrtu (app sp xfun xarg) = app (rght sp) xfun (there unrtu xarg) 162 | lift-expr{Φ} unrtu (rec unr-Φ ebody) = letbind (left (split-all-right Φ)) (var (here [])) (rec (unrtu ∷ unr-Φ) (unr-weaken (left (left (rght (split-all-left Φ)))) (unrtu ∷ []) ebody)) 163 | lift-expr unrtu (subsume e t≤t') = subsume (lift-expr unrtu e) t≤t' 164 | 165 | unr-subst : ∀ {Φ Φ₁ Φ₂ tᵤ t} → Unr tᵤ → Split Φ Φ₁ Φ₂ → All Unr Φ₁ → Expr Φ₁ tᵤ → Expr (tᵤ ∷ Φ₂) t → Expr Φ t 166 | unr-subst unrtu sp unr-Φ₁ etu (var (here x)) = unr-weaken sp x etu 167 | unr-subst unrtu sp unr-Φ₁ etu (var (there x x₁)) = var (unr-weaken-var (split-sym sp) unr-Φ₁ x₁) 168 | unr-subst unrtu sp unr-Φ₁ etu (nat (unr-tu ∷ unr-Φ) i) = nat (split-unr sp unr-Φ₁ unr-Φ) i 169 | unr-subst unrtu sp unr-Φ₁ etu (unit (_ ∷ unr-Φ)) = unit (split-unr sp unr-Φ₁ unr-Φ) 170 | unr-subst unrtu sp unr-Φ₁ etu (letbind sp₁ e e₁) = letbind sp etu (letbind sp₁ e e₁) 171 | unr-subst unrtu sp unr-Φ₁ etu (pair sp₁ x₁ x₂) = letbind sp etu (pair sp₁ x₁ x₂) 172 | unr-subst unrtu sp unr-Φ₁ etu (letpair sp₁ p e) = letbind sp etu (letpair sp₁ p e) 173 | unr-subst unrtu sp unr-Φ₁ etu (fork e) = unr-subst unrtu sp unr-Φ₁ etu e 174 | unr-subst unrtu sp unr-Φ₁ etu (new unr-Φ s) = letbind sp etu (new unr-Φ s) 175 | unr-subst unrtu sp unr-Φ₁ etu (send sp₁ ch vv) = letbind sp etu (send sp₁ ch vv) 176 | unr-subst unrtu sp unr-Φ₁ etu (recv ch) = letbind sp etu (recv ch) 177 | unr-subst unrtu sp unr-Φ₁ etu (close ch) = letbind sp etu (close ch) 178 | unr-subst unrtu sp unr-Φ₁ etu (wait ch) = letbind sp etu (wait ch) 179 | unr-subst unrtu sp unr-Φ₁ etu (nselect lab ch) = letbind sp etu (nselect lab ch) 180 | unr-subst unrtu sp unr-Φ₁ etu (nbranch sp₁ ch ealts) = letbind sp etu (nbranch sp₁ ch ealts) 181 | unr-subst unrtu sp unr-Φ₁ etu (select lab ch) = letbind sp etu (select lab ch) 182 | unr-subst unrtu sp unr-Φ₁ etu (branch sp₁ ch e e₁) = letbind sp etu (branch sp₁ ch e e₁) 183 | unr-subst unrtu sp unr-Φ₁ etu (ulambda sp₁ unr-Φ₂ unr-Φ₃ e) = letbind sp etu (ulambda sp₁ unr-Φ₂ unr-Φ₃ e) 184 | unr-subst unrtu sp unr-Φ₁ etu (llambda sp₁ unr-Φ₂ e) = letbind sp etu (llambda sp₁ unr-Φ₂ e) 185 | unr-subst unrtu sp unr-Φ₁ etu (app sp₁ xfun xarg) = letbind sp etu (app sp₁ xfun xarg) 186 | unr-subst unrtu sp unr-Φ₁ etu (rec unr-Φ e) = letbind sp etu (rec unr-Φ e) 187 | unr-subst unrtu sp unr-Φ₁ etu (subsume e t≤t') = subsume (unr-subst unrtu sp unr-Φ₁ etu e) t≤t' 188 | 189 | expr-coerce : ∀ {Φ t₁ t₂ t₁' t₂'} → Expr (t₁ ∷ Φ) t₂ → SubT t₂ t₂' → SubT t₁' t₁ → Expr (t₁' ∷ Φ) t₂' 190 | expr-coerce e t2≤t2' t1'≤t1 = letbind (left (split-all-right _)) (subsume (var (here [])) t1'≤t1) (subsume e t2≤t2') 191 | -------------------------------------------------------------------------------- /src/Typing.agda: -------------------------------------------------------------------------------- 1 | module Typing where 2 | 3 | open import Data.Fin hiding (_≤_) 4 | open import Data.List hiding (drop) 5 | open import Data.List.All 6 | open import Data.Maybe 7 | open import Data.Nat 8 | open import Data.Nat.Properties 9 | open import Data.Product 10 | 11 | open import Relation.Binary.PropositionalEquality 12 | 13 | -- linearity indicator 14 | data LU : Set where 15 | LL UU : LU 16 | 17 | data Dir : Set where 18 | SND RCV : Dir 19 | 20 | -- coinductive view on session types 21 | -- following "Interactive Programming in Agda" 22 | -- http://www.cse.chalmers.se/~abela/ooAgda.pdf 23 | mutual 24 | data Type : Set where 25 | TUnit TInt : Type 26 | TPair : Type → Type → Type 27 | TChan : STypeF SType → Type 28 | TFun : LU → Type → Type → Type 29 | 30 | data STypeF (S : Set) : Set where 31 | transmit : (d : Dir) (t : Type) (s : S) → STypeF S 32 | choice : (d : Dir) (s1 : S) (s2 : S) → STypeF S 33 | choiceN : (d : Dir) (m : ℕ) (alt : Fin m → S) → STypeF S 34 | end : (d : Dir) → STypeF S 35 | 36 | record SType : Set where 37 | coinductive 38 | constructor delay 39 | field force : STypeF SType 40 | 41 | open SType 42 | 43 | pattern send t s = transmit SND t s 44 | pattern recv t s = transmit RCV t s 45 | 46 | pattern sintern s1 s2 = choice SND s1 s2 47 | pattern sextern s1 s2 = choice RCV s1 s2 48 | 49 | pattern sintN m a = choiceN SND m a 50 | pattern sextN m a = choiceN RCV m a 51 | 52 | pattern send! = end SND 53 | pattern send? = end RCV 54 | 55 | -- session type equivalence 56 | data EquivF (R : SType → SType → Set) : STypeF SType → STypeF SType → Set where 57 | eq-send : ∀ {s1 s1'} → (t : Type) → R s1 s1' → EquivF R (send t s1) (send t s1') 58 | eq-recv : ∀ {s1 s1'} → (t : Type) → R s1 s1' → EquivF R (recv t s1) (recv t s1') 59 | eq-sintern : ∀ {s1 s1' s2 s2'} → R s1 s1' → R s2 s2' → EquivF R (sintern s1 s2) (sintern s1' s2') 60 | eq-sextern : ∀ {s1 s1' s2 s2'} → R s1 s1' → R s2 s2' → EquivF R (sextern s1 s2) (sextern s1' s2') 61 | eq-sintN : ∀ {m alt alt'} → ((i : Fin m) → R (alt i) (alt' i)) → EquivF R (sintN m alt) (sintN m alt') 62 | eq-sextN : ∀ {m alt alt'} → ((i : Fin m) → R (alt i) (alt' i)) → EquivF R (sextN m alt) (sextN m alt') 63 | eq-send! : EquivF R send! send! 64 | eq-send? : EquivF R send? send? 65 | 66 | record Equiv (s1 : SType) (s2 : SType) : Set where 67 | coinductive 68 | field force : EquivF Equiv (force s1) (force s2) 69 | 70 | open Equiv 71 | 72 | _≈_ = Equiv 73 | _≈'_ = EquivF Equiv 74 | 75 | -- equivalence is reflexive 76 | equivF-refl : ∀ s → s ≈' s 77 | equiv-refl : ∀ s → s ≈ s 78 | 79 | force (equiv-refl s) = equivF-refl (force s) 80 | 81 | equivF-refl (send t s) = eq-send t (equiv-refl s) 82 | equivF-refl (recv t s) = eq-recv t (equiv-refl s) 83 | equivF-refl (sintern s1 s2) = eq-sintern (equiv-refl s1) (equiv-refl s2) 84 | equivF-refl (sextern s1 s2) = eq-sextern (equiv-refl s1) (equiv-refl s2) 85 | equivF-refl (sintN m alt) = eq-sintN λ i → equiv-refl (alt i) 86 | equivF-refl (sextN m alt) = eq-sextN λ i → equiv-refl (alt i) 87 | equivF-refl send! = eq-send! 88 | equivF-refl send? = eq-send? 89 | 90 | -- equivalence is symmetric 91 | 92 | eqF-sym : ∀ {s1 s2} → s1 ≈' s2 → s2 ≈' s1 93 | eq-sym : ∀ {s1 s2} → s1 ≈ s2 → s2 ≈ s1 94 | 95 | eqF-sym (eq-send t x) = eq-send t (eq-sym x) 96 | eqF-sym (eq-recv t x) = eq-recv t (eq-sym x) 97 | eqF-sym (eq-sintern x x₁) = eq-sintern (eq-sym x) (eq-sym x₁) 98 | eqF-sym (eq-sextern x x₁) = eq-sextern (eq-sym x) (eq-sym x₁) 99 | eqF-sym (eq-sintN x) = eq-sintN λ i → eq-sym (x i) 100 | eqF-sym (eq-sextN x) = eq-sextN λ i → eq-sym (x i) 101 | eqF-sym eq-send! = eq-send! 102 | eqF-sym eq-send? = eq-send? 103 | 104 | force (eq-sym s1~s2) = eqF-sym (force s1~s2) 105 | 106 | -- equivalence is transitive 107 | equivF-trans : ∀ {s1 s2 s3} → EquivF Equiv s1 s2 → EquivF Equiv s2 s3 → EquivF Equiv s1 s3 108 | equiv-trans : ∀ {s1 s2 s3} → Equiv s1 s2 → Equiv s2 s3 → Equiv s1 s3 109 | 110 | force (equiv-trans s1~s2 s2~s3) = equivF-trans (force s1~s2) (force s2~s3) 111 | 112 | equivF-trans (eq-send t x) (eq-send .t x₁) = eq-send t (equiv-trans x x₁) 113 | equivF-trans (eq-recv t x) (eq-recv .t x₁) = eq-recv t (equiv-trans x x₁) 114 | equivF-trans (eq-sintern x x₁) (eq-sintern x₂ x₃) = eq-sintern (equiv-trans x x₂) (equiv-trans x₁ x₃) 115 | equivF-trans (eq-sextern x x₁) (eq-sextern x₂ x₃) = eq-sextern (equiv-trans x x₂) (equiv-trans x₁ x₃) 116 | equivF-trans (eq-sintN x) (eq-sintN x₁) = eq-sintN λ i → equiv-trans (x i) (x₁ i) 117 | equivF-trans (eq-sextN x) (eq-sextN x₁) = eq-sextN λ i → equiv-trans (x i) (x₁ i) 118 | equivF-trans eq-send! eq-send! = eq-send! 119 | equivF-trans eq-send? eq-send? = eq-send? 120 | 121 | -- dual 122 | dual-dir : Dir → Dir 123 | dual-dir SND = RCV 124 | dual-dir RCV = SND 125 | 126 | dual : SType → SType 127 | dualF : STypeF SType → STypeF SType 128 | 129 | force (dual s) = dualF (force s) 130 | 131 | dualF (transmit d t s) = transmit (dual-dir d) t (dual s) 132 | dualF (choice d s1 s2) = choice (dual-dir d) (dual s1) (dual s2) 133 | dualF (choiceN d m alt) = choiceN (dual-dir d) m λ i → dual (alt i) 134 | dualF (end d) = end (dual-dir d) 135 | 136 | -- properties 137 | 138 | dual-involution : (s : SType) → s ≈ dual (dual s) 139 | dual-involutionF : (s : STypeF SType) → s ≈' dualF (dualF s) 140 | 141 | force (dual-involution s) = dual-involutionF (force s) 142 | 143 | dual-involutionF (send t s) = eq-send t (dual-involution s) 144 | dual-involutionF (recv t s) = eq-recv t (dual-involution s) 145 | dual-involutionF (sintern s1 s2) = eq-sintern (dual-involution s1) (dual-involution s2) 146 | dual-involutionF (sextern s1 s2) = eq-sextern (dual-involution s1) (dual-involution s2) 147 | dual-involutionF (sintN m alt) = eq-sintN λ i → dual-involution (alt i) 148 | dual-involutionF (sextN m alt) = eq-sextN λ i → dual-involution (alt i) 149 | dual-involutionF send! = eq-send! 150 | dual-involutionF send? = eq-send? 151 | 152 | 153 | mutual 154 | -- subtyping 155 | data SubT : Type → Type → Set where 156 | sub-unit : SubT TUnit TUnit 157 | sub-int : SubT TInt TInt 158 | sub-pair : ∀ {t₁ t₂ t₁' t₂'} → SubT t₁ t₁' → SubT t₂ t₂' → SubT (TPair t₁ t₂) (TPair t₁' t₂') 159 | sub-fun : ∀ {t₁ t₂ t₁' t₂' lu} → SubT t₁' t₁ → SubT t₂ t₂' → SubT (TFun lu t₁ t₂) (TFun lu t₁' t₂') 160 | sub-chan : ∀ {s s'} → SubF Sub s s' → SubT (TChan s) (TChan s') 161 | 162 | -- session type subtyping 163 | data SubF (R : SType → SType → Set) : STypeF SType → STypeF SType → Set where 164 | sub-send : ∀ {s1 s1'} → (t t' : Type) → (t'<=t : SubT t' t) → (s1<=s1' : R s1 s1') → SubF R (send t s1) (send t' s1') 165 | sub-recv : ∀ {s1 s1'} → (t t' : Type) → (t<=t' : SubT t t') → (s1<=s1' : R s1 s1') → SubF R (recv t s1) (recv t' s1') 166 | sub-sintern : ∀ {s1 s1' s2 s2'} → (s1<=s1' : R s1 s1') → (s2<=s2' : R s2 s2') → SubF R (sintern s1 s2) (sintern s1' s2') 167 | sub-sextern : ∀ {s1 s1' s2 s2'} → (s1<=s1' : R s1 s1') → (s2<=s2' : R s2 s2') → SubF R (sextern s1 s2) (sextern s1' s2') 168 | sub-sintN : ∀ {m m' alt alt'} → (m'≤m : m' ≤ m) → ((i : Fin m') → R (alt (inject≤ i m'≤m)) (alt' i)) → SubF R (sintN m alt) (sintN m' alt') 169 | sub-sextN : ∀ {m m' alt alt'} → (m≤m' : m ≤ m') → ((i : Fin m) → R (alt i) (alt' (inject≤ i m≤m'))) → SubF R (sextN m alt) (sextN m' alt') 170 | sub-send! : SubF R send! send! 171 | sub-send? : SubF R send? send? 172 | 173 | record Sub (s1 : SType) (s2 : SType) : Set where 174 | coinductive 175 | field force : SubF Sub (force s1) (force s2) 176 | 177 | open Sub 178 | 179 | _≲_ = Sub 180 | _≲'_ = SubF Sub 181 | 182 | inject-refl : ∀ {m} → (i : Fin m) → inject≤ i ≤-refl ≡ i 183 | inject-refl zero = refl 184 | inject-refl (suc i) = cong suc (inject-refl i) 185 | 186 | inject-trans : ∀ {m m' m''} → (m'≤m : m' ≤ m) → (m''≤m' : m'' ≤ m') → (i : Fin m'') 187 | → (inject≤ (inject≤ i m''≤m') m'≤m) ≡ (inject≤ i (≤-trans m''≤m' m'≤m)) 188 | inject-trans z≤n z≤n () 189 | inject-trans (s≤s m'≤m) z≤n () 190 | inject-trans (s≤s m'≤m) (s≤s m''≤m') zero = refl 191 | inject-trans (s≤s m'≤m) (s≤s m''≤m') (suc i) = cong suc (inject-trans m'≤m m''≤m' i) 192 | 193 | -- subtyping is reflexive 194 | subt-refl : ∀ t → SubT t t 195 | subF-refl : ∀ s → s ≲' s 196 | sub-refl : ∀ s → s ≲ s 197 | 198 | force (sub-refl s) = subF-refl (force s) 199 | 200 | subF-refl (send t s) = sub-send t t (subt-refl t) (sub-refl s) 201 | subF-refl (recv t s) = sub-recv t t (subt-refl t) (sub-refl s) 202 | subF-refl (sintern s1 s2) = sub-sintern (sub-refl s1) (sub-refl s2) 203 | subF-refl (sextern s1 s2) = sub-sextern (sub-refl s1) (sub-refl s2) 204 | subF-refl (sintN m alt) = sub-sintN ≤-refl auxInt 205 | where 206 | auxInt : (i : Fin m) → Sub (alt (inject≤ i ≤-refl)) (alt i) 207 | auxInt i rewrite inject-refl i = sub-refl (alt i) 208 | subF-refl (sextN m alt) = sub-sextN ≤-refl auxExt 209 | where 210 | auxExt : (i : Fin m) → Sub (alt i) (alt (inject≤ i ≤-refl)) 211 | auxExt i rewrite inject-refl i = sub-refl (alt i) 212 | subF-refl send! = sub-send! 213 | subF-refl send? = sub-send? 214 | 215 | subt-refl TUnit = sub-unit 216 | subt-refl TInt = sub-int 217 | subt-refl (TPair t t₁) = sub-pair (subt-refl t) (subt-refl t₁) 218 | subt-refl (TChan s) = sub-chan (subF-refl s) 219 | subt-refl (TFun x t t₁) = sub-fun (subt-refl t) (subt-refl t₁) 220 | 221 | -- subtyping is transitive 222 | subt-trans : ∀ {t1 t2 t3} → SubT t1 t2 → SubT t2 t3 → SubT t1 t3 223 | sub-trans : ∀ {s1 s2 s3} → s1 ≲ s2 → s2 ≲ s3 → s1 ≲ s3 224 | subF-trans : ∀ {s1 s2 s3} → s1 ≲' s2 → s2 ≲' s3 → s1 ≲' s3 225 | 226 | subt-trans sub-unit sub-unit = sub-unit 227 | subt-trans sub-int sub-int = sub-int 228 | subt-trans (sub-pair t1<:t2 t1<:t3) (sub-pair t2<:t3 t2<:t4) = sub-pair (subt-trans t1<:t2 t2<:t3) (subt-trans t1<:t3 t2<:t4) 229 | subt-trans (sub-fun t1<:t2 t1<:t3) (sub-fun t2<:t3 t2<:t4) = sub-fun (subt-trans t2<:t3 t1<:t2) (subt-trans t1<:t3 t2<:t4) 230 | subt-trans (sub-chan s1<:s2) (sub-chan s2<:s3) = sub-chan (subF-trans s1<:s2 s2<:s3) 231 | 232 | force (sub-trans s1<:s2 s2<:s3) = subF-trans (force s1<:s2) (force s2<:s3) 233 | 234 | subF-trans (sub-send t t' x x₁) (sub-send .t' t'' x₂ x₃) = sub-send t t'' (subt-trans x₂ x) (sub-trans x₁ x₃) 235 | subF-trans (sub-recv t t' x x₁) (sub-recv .t' t'' x₂ x₃) = sub-recv t t'' (subt-trans x x₂) (sub-trans x₁ x₃) 236 | subF-trans (sub-sintern x x₁) (sub-sintern x₂ x₃) = sub-sintern (sub-trans x x₂) (sub-trans x₁ x₃) 237 | subF-trans (sub-sextern x x₁) (sub-sextern x₂ x₃) = sub-sextern (sub-trans x x₂) (sub-trans x₁ x₃) 238 | subF-trans {sintN m alt}{sintN m' alt'}{sintN m'' alt''} (sub-sintN m'≤m palt) (sub-sintN m''≤m' palt') = 239 | sub-sintN (≤-trans m''≤m' m'≤m) λ i → sub-trans (auxInt i) (palt' i) 240 | where 241 | auxInt : (i : Fin m'') → Sub (alt (inject≤ i (≤-trans m''≤m' m'≤m))) (alt' (inject≤ i m''≤m')) 242 | auxInt i with palt (inject≤ i m''≤m') 243 | ... | r rewrite (inject-trans m'≤m m''≤m' i) = r 244 | subF-trans {sextN m alt}{sextN m' alt'}{sextN m'' alt''} (sub-sextN m≤m' palt) (sub-sextN m'≤m'' palt') = 245 | sub-sextN (≤-trans m≤m' m'≤m'') λ i → sub-trans (palt i) (auxExt i) 246 | where 247 | auxExt : (i : Fin m) → Sub (alt' (inject≤ i m≤m')) (alt'' (inject≤ i (≤-trans m≤m' m'≤m''))) 248 | auxExt i with palt' (inject≤ i m≤m') 249 | ... | r rewrite (inject-trans m'≤m'' m≤m' i) = r 250 | subF-trans sub-send! sub-send! = sub-send! 251 | subF-trans sub-send? sub-send? = sub-send? 252 | 253 | -- duality and subtyping 254 | dual-sub : ∀ {s1 s2} → s1 ≲ s2 → dual s2 ≲ dual s1 255 | dual-subF : ∀ {s1 s2} → s1 ≲' s2 → dualF s2 ≲' dualF s1 256 | 257 | force (dual-sub s1<=s2) = dual-subF (force s1<=s2) 258 | 259 | dual-subF (sub-send t t' t'<=t s1<=s1') = sub-recv t' t t'<=t (dual-sub s1<=s1') 260 | dual-subF (sub-recv t t' t<=t' s1<=s1') = sub-send t' t t<=t' (dual-sub s1<=s1') 261 | dual-subF (sub-sintern s1<=s1' s2<=s2') = sub-sextern (dual-sub s1<=s1') (dual-sub s2<=s2') 262 | dual-subF (sub-sextern s1<=s1' s2<=s2') = sub-sintern (dual-sub s1<=s1') (dual-sub s2<=s2') 263 | dual-subF (sub-sintN m'≤m x) = sub-sextN m'≤m λ i → dual-sub (x i) 264 | dual-subF (sub-sextN m≤m' x) = sub-sintN m≤m' λ i → dual-sub (x i) 265 | dual-subF sub-send! = sub-send? 266 | dual-subF sub-send? = sub-send! 267 | 268 | -- equivalence and subtyping 269 | eq-implies-sub : ∀ {s1 s2} → s1 ≈ s2 → s1 ≲ s2 270 | eqF-implies-subF : ∀ {s1 s2} → s1 ≈' s2 → s1 ≲' s2 271 | 272 | force (eq-implies-sub s1~s2) = eqF-implies-subF (force s1~s2) 273 | 274 | eqF-implies-subF (eq-send t x) = sub-send t t (subt-refl t) (eq-implies-sub x) 275 | eqF-implies-subF (eq-recv t x) = sub-recv t t (subt-refl t) (eq-implies-sub x) 276 | eqF-implies-subF (eq-sintern x x₁) = sub-sintern (eq-implies-sub x) (eq-implies-sub x₁) 277 | eqF-implies-subF (eq-sextern x x₁) = sub-sextern (eq-implies-sub x) (eq-implies-sub x₁) 278 | eqF-implies-subF {sintN m alt} {sintN .m alt'} (eq-sintN x) = sub-sintN ≤-refl auxInt 279 | where 280 | auxInt : (i : Fin m) → Sub (alt (inject≤ i ≤-refl)) (alt' i) 281 | auxInt i rewrite inject-refl i = eq-implies-sub (x i) 282 | eqF-implies-subF {sextN m alt} {sextN .m alt'} (eq-sextN x) = sub-sextN ≤-refl auxExt 283 | where 284 | auxExt : (i : Fin m) → Sub (alt i) (alt' (inject≤ i ≤-refl)) 285 | auxExt i rewrite inject-refl i = eq-implies-sub (x i) 286 | eqF-implies-subF eq-send! = sub-send! 287 | eqF-implies-subF eq-send? = sub-send? 288 | 289 | 290 | -- unrestricted 291 | data Unr : Type → Set where 292 | UUnit : Unr TUnit 293 | UInt : Unr TInt 294 | UPair : ∀ {t₁ t₂} → Unr t₁ → Unr t₂ → Unr (TPair t₁ t₂) 295 | UFun : ∀ {t₁ t₂} → Unr (TFun UU t₁ t₂) 296 | 297 | classify-type : (t : Type) → Maybe (Unr t) 298 | classify-type TUnit = just UUnit 299 | classify-type TInt = just UInt 300 | classify-type (TPair t₁ t₂) with classify-type t₁ | classify-type t₂ 301 | classify-type (TPair t₁ t₂) | just x | just x₁ = just (UPair x x₁) 302 | classify-type (TPair t₁ t₂) | just x | nothing = nothing 303 | classify-type (TPair t₁ t₂) | nothing | just x = nothing 304 | classify-type (TPair t₁ t₂) | nothing | nothing = nothing 305 | classify-type (TChan x) = nothing 306 | classify-type (TFun LL t₁ t₂) = nothing 307 | classify-type (TFun UU t₁ t₂) = just UFun 308 | 309 | TCtx = List Type 310 | 311 | -- context splitting, respecting linearity 312 | data Split : TCtx → TCtx → TCtx → Set where 313 | [] : Split [] [] [] 314 | dupl : ∀ {t Φ Φ₁ Φ₂} → Unr t → Split Φ Φ₁ Φ₂ → Split (t ∷ Φ) (t ∷ Φ₁) (t ∷ Φ₂) 315 | drop : ∀ {t Φ Φ₁ Φ₂} → Unr t → Split Φ Φ₁ Φ₂ → Split (t ∷ Φ) Φ₁ Φ₂ 316 | left : ∀ {t Φ Φ₁ Φ₂} → Split Φ Φ₁ Φ₂ → Split (t ∷ Φ) (t ∷ Φ₁) Φ₂ 317 | rght : ∀ {t Φ Φ₁ Φ₂} → Split Φ Φ₁ Φ₂ → Split (t ∷ Φ) Φ₁ (t ∷ Φ₂) 318 | 319 | -- split is symmetric 320 | split-sym : ∀ {φ φ₁ φ₂} → Split φ φ₁ φ₂ → Split φ φ₂ φ₁ 321 | split-sym [] = [] 322 | split-sym (dupl x sp) = dupl x (split-sym sp) 323 | split-sym (drop un-t sp) = drop un-t (split-sym sp) 324 | split-sym (left sp) = rght (split-sym sp) 325 | split-sym (rght sp) = left (split-sym sp) 326 | 327 | split-unr : ∀ {φ φ₁ φ₂} → (sp : Split φ φ₁ φ₂) → All Unr φ₁ → All Unr φ₂ → All Unr φ 328 | split-unr [] [] [] = [] 329 | split-unr (dupl x sp) (px ∷ unr1) (px₁ ∷ unr2) = px ∷ split-unr sp unr1 unr2 330 | split-unr (drop x sp) unr1 unr2 = x ∷ split-unr sp unr1 unr2 331 | split-unr (left sp) (px ∷ unr1) unr2 = px ∷ split-unr sp unr1 unr2 332 | split-unr (rght sp) unr1 (px ∷ unr2) = px ∷ split-unr sp unr1 unr2 333 | 334 | split-all-left : (φ : TCtx) → Split φ φ [] 335 | split-all-left [] = [] 336 | split-all-left (x ∷ φ) = left (split-all-left φ) 337 | 338 | split-all-right : (φ : TCtx) → Split φ [] φ 339 | split-all-right [] = [] 340 | split-all-right (x ∷ φ) = rght (split-all-right φ) 341 | 342 | -- split the unrestricted part from a typing context 343 | split-refl-left : (φ : TCtx) → ∃ λ φ' → All Unr φ' × Split φ φ φ' 344 | split-refl-left [] = [] , [] , [] 345 | split-refl-left (t ∷ φ) with split-refl-left φ | classify-type t 346 | split-refl-left (t ∷ φ) | φ' , unr-φ' , sp' | nothing = φ' , unr-φ' , left sp' 347 | split-refl-left (t ∷ φ) | φ' , unr-φ' , sp' | just y = t ∷ φ' , y ∷ unr-φ' , dupl y sp' 348 | 349 | split-all-unr : ∀ {φ} → All Unr φ → Split φ φ φ 350 | split-all-unr [] = [] 351 | split-all-unr (px ∷ un-φ) = dupl px (split-all-unr un-φ) 352 | 353 | split-from-disjoint : (φ₁ φ₂ : TCtx) → ∃ λ φ → Split φ φ₁ φ₂ 354 | split-from-disjoint [] φ₂ = φ₂ , split-all-right φ₂ 355 | split-from-disjoint (t ∷ φ₁) φ₂ with split-from-disjoint φ₁ φ₂ 356 | ... | φ' , sp = t ∷ φ' , left sp 357 | 358 | split-unr-right : ∀ {φ φ₁ φ₂ φ₃ φ₄} 359 | → Split φ φ₁ φ₂ → Split φ₁ φ₃ φ₄ → All Unr φ₂ → Split φ φ₃ φ₄ 360 | split-unr-right [] [] unr1 = [] 361 | split-unr-right (dupl x sp012) (dupl x₁ sp134) (px ∷ unr1) = dupl x₁ (split-unr-right sp012 sp134 unr1) 362 | split-unr-right (dupl x sp012) (drop x₁ sp134) (px ∷ unr1) = drop px (split-unr-right sp012 sp134 unr1) 363 | split-unr-right (dupl x sp012) (left sp134) (px ∷ unr1) = left (split-unr-right sp012 sp134 unr1) 364 | split-unr-right (dupl x sp012) (rght sp134) (px ∷ unr1) = rght (split-unr-right sp012 sp134 unr1) 365 | split-unr-right (drop x sp012) [] unr1 = drop x (split-unr-right sp012 [] unr1) 366 | split-unr-right (drop x sp012) (dupl x₁ sp134) unr1 = drop x (split-unr-right sp012 (dupl x₁ sp134) unr1) 367 | split-unr-right (drop x sp012) (drop x₁ sp134) unr1 = drop x (split-unr-right sp012 (drop x₁ sp134) unr1) 368 | split-unr-right (drop x sp012) (left sp134) unr1 = drop x (split-unr-right sp012 (left sp134) unr1) 369 | split-unr-right (drop x sp012) (rght sp134) unr1 = drop x (split-unr-right sp012 (rght sp134) unr1) 370 | split-unr-right (left sp012) (dupl x sp134) unr1 = dupl x (split-unr-right sp012 sp134 unr1) 371 | split-unr-right (left sp012) (drop x sp134) unr1 = drop x (split-unr-right sp012 sp134 unr1) 372 | split-unr-right (left sp012) (left sp134) unr1 = left (split-unr-right sp012 sp134 unr1) 373 | split-unr-right (left sp012) (rght sp134) unr1 = rght (split-unr-right sp012 sp134 unr1) 374 | split-unr-right (rght sp012) [] (px ∷ unr1) = drop px (split-unr-right sp012 [] unr1) 375 | split-unr-right (rght sp012) (dupl x sp134) (px ∷ unr1) = drop px (split-unr-right sp012 (dupl x sp134) unr1) 376 | split-unr-right (rght sp012) (drop x sp134) (px ∷ unr1) = drop px (split-unr-right sp012 (drop x sp134) unr1) 377 | split-unr-right (rght sp012) (left sp134) (px ∷ unr1) = drop px (split-unr-right sp012 (left sp134) unr1) 378 | split-unr-right (rght sp012) (rght sp134) (px ∷ unr1) = drop px (split-unr-right sp012 (rght sp134) unr1) 379 | 380 | 381 | split-unr-left : ∀ {φ φ₁ φ₂ φ₃ φ₄} 382 | → Split φ φ₁ φ₂ → Split φ₂ φ₃ φ₄ → All Unr φ₁ → Split φ φ₃ φ₄ 383 | split-unr-left [] [] [] = [] 384 | split-unr-left (dupl x sp012) (dupl x₁ sp234) (px ∷ unr1) = dupl px (split-unr-left sp012 sp234 unr1) 385 | split-unr-left (dupl x sp012) (drop x₁ sp234) (px ∷ unr1) = drop px (split-unr-left sp012 sp234 unr1) 386 | split-unr-left (dupl x sp012) (left sp234) (px ∷ unr1) = left (split-unr-left sp012 sp234 unr1) 387 | split-unr-left (dupl x sp012) (rght sp234) (px ∷ unr1) = rght (split-unr-left sp012 sp234 unr1) 388 | split-unr-left (drop x₁ sp012) [] unr1 = drop x₁ (split-unr-left sp012 [] unr1) 389 | split-unr-left (drop x₁ sp012) (dupl x₂ sp234) unr1 = drop x₁ (split-unr-left sp012 (dupl x₂ sp234) unr1) 390 | split-unr-left (drop x₁ sp012) (drop x₂ sp234) unr1 = drop x₁ (split-unr-left sp012 (drop x₂ sp234) unr1) 391 | split-unr-left (drop x₁ sp012) (left sp234) unr1 = drop x₁ (split-unr-left sp012 (left sp234) unr1) 392 | split-unr-left (drop x₁ sp012) (rght sp234) unr1 = drop x₁ (split-unr-left sp012 (rght sp234) unr1) 393 | split-unr-left (left sp012) [] (px ∷ unr1) = drop px (split-unr-left sp012 [] unr1) 394 | split-unr-left (left sp012) (dupl x sp234) (px ∷ unr1) = drop px (split-unr-left sp012 (dupl x sp234) unr1) 395 | split-unr-left (left sp012) (drop x sp234) (px ∷ unr1) = drop px (split-unr-left sp012 (drop x sp234) unr1) 396 | split-unr-left (left sp012) (left sp234) (px ∷ unr1) = drop px (split-unr-left sp012 (left sp234) unr1) 397 | split-unr-left (left sp012) (rght sp234) (px ∷ unr1) = drop px (split-unr-left sp012 (rght sp234) unr1) 398 | split-unr-left (rght sp012) (dupl x₁ sp234) unr1 = dupl x₁ (split-unr-left sp012 sp234 unr1) 399 | split-unr-left (rght sp012) (drop x₁ sp234) unr1 = drop x₁ (split-unr-left sp012 sp234 unr1) 400 | split-unr-left (rght sp012) (left sp234) unr1 = left (split-unr-left sp012 sp234 unr1) 401 | split-unr-left (rght sp012) (rght sp234) unr1 = rght (split-unr-left sp012 sp234 unr1) 402 | 403 | -- reorganize splits 404 | split-rotate : ∀ {φ φ₁ φ₂ φ₁₁ φ₁₂} 405 | → Split φ φ₁ φ₂ → Split φ₁ φ₁₁ φ₁₂ → ∃ λ φ' → Split φ φ₁₁ φ' × Split φ' φ₁₂ φ₂ 406 | split-rotate [] [] = [] , [] , [] 407 | split-rotate (drop x sp12) [] with split-rotate sp12 [] 408 | ... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , drop x φ'-sp 409 | split-rotate (dupl x sp12) (dupl x₁ sp1112) with split-rotate sp12 sp1112 410 | ... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , dupl x₁ sp-φ' , dupl x₁ φ'-sp 411 | split-rotate (dupl x sp12) (drop x₁ sp1112) with split-rotate sp12 sp1112 412 | ... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , rght φ'-sp 413 | split-rotate (dupl x sp12) (left sp1112) with split-rotate sp12 sp1112 414 | ... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , dupl x sp-φ' , rght φ'-sp 415 | split-rotate (dupl x sp12) (rght sp1112) with split-rotate sp12 sp1112 416 | ... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , dupl x φ'-sp 417 | split-rotate (drop px sp12) sp1112 with split-rotate sp12 sp1112 418 | ... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , drop px φ'-sp 419 | split-rotate (left sp12) (dupl x₁ sp1112) with split-rotate sp12 sp1112 420 | ... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , dupl x₁ sp-φ' , left φ'-sp 421 | split-rotate (left sp12) (left sp1112) with split-rotate sp12 sp1112 422 | ... | φ' , sp-φ' , φ'-sp = φ' , left sp-φ' , φ'-sp 423 | split-rotate (left sp12) (rght sp1112) with split-rotate sp12 sp1112 424 | ... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , left φ'-sp 425 | split-rotate (left sp12) (drop px sp1112) with split-rotate sp12 sp1112 426 | ... | φ' , sp-φ' , φ'-sp = φ' , drop px sp-φ' , φ'-sp 427 | split-rotate (rght sp12) sp1112 with split-rotate sp12 sp1112 428 | ... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , rght φ'-sp 429 | 430 | 431 | 432 | -- extract from type context where all other entries are unrestricted 433 | data _∈_ (x : Type) : List Type → Set where 434 | here : ∀ { xs } → All Unr xs → x ∈ (x ∷ xs) 435 | there : ∀ { x₀ xs } → Unr x₀ → x ∈ xs → x ∈ (x₀ ∷ xs) 436 | 437 | -- unrestricted weakening 438 | unr-weaken-var : ∀ {Φ Φ₁ Φ₂ t} → Split Φ Φ₁ Φ₂ → All Unr Φ₂ → t ∈ Φ₁ → t ∈ Φ 439 | unr-weaken-var [] un-Φ₂ () 440 | unr-weaken-var (dupl x₁ sp) (_ ∷ un-Φ₂) (here x) = here (split-unr sp x un-Φ₂) 441 | unr-weaken-var (dupl x₁ sp) un-Φ₂ (there x x₂) = unr-weaken-var (rght sp) un-Φ₂ x₂ 442 | unr-weaken-var (drop un-t sp) un-Φ₂ x = there un-t (unr-weaken-var sp un-Φ₂ x) 443 | unr-weaken-var {t = _} (left sp) un-Φ₂ (here x) = here (split-unr sp x un-Φ₂) 444 | unr-weaken-var {t = t} (left sp) un-Φ₂ (there x x₁) = there x (unr-weaken-var sp un-Φ₂ x₁) 445 | unr-weaken-var {t = t} (rght sp) (unr-t ∷ un-Φ₂) (here x) = there unr-t (unr-weaken-var sp un-Φ₂ (here x)) 446 | unr-weaken-var {t = t} (rght sp) (unr-t ∷ un-Φ₂) (there x x₁) = there unr-t (unr-weaken-var sp un-Φ₂ (there x x₁)) 447 | 448 | 449 | 450 | 451 | -- left and right branching 452 | data Selector : Set where 453 | Left Right : Selector 454 | 455 | selection : ∀ {A : Set} → Selector → A → A → A 456 | selection Left x y = x 457 | selection Right x y = y 458 | -------------------------------------------------------------------------------- /src/Values.agda: -------------------------------------------------------------------------------- 1 | module Values where 2 | 3 | open import Data.Bool 4 | open import Data.List 5 | open import Data.List.All 6 | open import Data.Nat 7 | open import Data.Product 8 | open import Data.Sum 9 | open import Relation.Binary.PropositionalEquality 10 | 11 | open import Typing 12 | open import Syntax 13 | open import Global 14 | open import Channel 15 | 16 | mutual 17 | -- a value indexed by a *relevant* session context, which is "used up" by the value 18 | data Val (G : SCtx) : Type → Set where 19 | VUnit : (inaG : Inactive G) 20 | → Val G TUnit 21 | VInt : (i : ℕ) 22 | → (inaG : Inactive G) 23 | → Val G TInt 24 | VPair : ∀ {t₁ t₂ G₁ G₂} 25 | → (ss-GG₁G₂ : SSplit G G₁ G₂) 26 | → (v₁ : Val G₁ t₁) 27 | → (v₂ : Val G₂ t₂) 28 | → Val G (TPair t₁ t₂) 29 | VChan : ∀ {s} 30 | → (ce : ChannelEnd) 31 | → (cr : ChannelRef G ce s) 32 | → Val G (TChan s) 33 | VFun : ∀ {φ lu t₁ t₂} 34 | → (lu ≡ LL ⊎ All Unr φ) 35 | → (ϱ : VEnv G φ) 36 | → (e : Expr (t₁ ∷ φ) t₂) 37 | → Val G (TFun lu t₁ t₂) 38 | 39 | -- type environment-indexed value environment 40 | -- session context G describes the entire environment, it splits over all (channel) values 41 | data VEnv (G : SCtx) : TCtx → Set where 42 | vnil : (ina : Inactive G) → VEnv G [] 43 | vcons : ∀{t φ G₁ G₂} → (ssp : SSplit G G₁ G₂) → (v : Val G₁ t) → (ϱ : VEnv G₂ φ) → VEnv G (t ∷ φ) 44 | 45 | unrestricted-val : ∀ {t G} → Unr t → Val G t → Inactive G 46 | unrestricted-venv : ∀ {φ G} → All Unr φ → VEnv G φ → Inactive G 47 | 48 | unrestricted-val UUnit (VUnit x) = x 49 | unrestricted-val UInt (VInt i x) = x 50 | unrestricted-val (UPair unrt unrt₁) (VPair x v v₁) = 51 | ssplit-inactive x (unrestricted-val unrt v) (unrestricted-val unrt₁ v₁) 52 | unrestricted-val {TFun UU t₁ t₂} UFun (VFun (inj₁ ()) ϱ e) 53 | unrestricted-val {TFun UU t₁ t₂} UFun (VFun (inj₂ unr-φ) ϱ e) = unrestricted-venv unr-φ ϱ 54 | 55 | unrestricted-venv unr-φ (vnil ina) = ina 56 | unrestricted-venv (px ∷ unr-φ) (vcons ssp v ϱ) = 57 | ssplit-inactive ssp (unrestricted-val px v) (unrestricted-venv unr-φ ϱ) 58 | 59 | -- access a value in an indexed environment 60 | access : ∀ {φ t} {G : SCtx} → VEnv G φ → t ∈ φ → ∃ λ G₁ → ∃ λ G₂ → Inactive G₂ × SSplit G G₁ G₂ × Val G₁ t 61 | access (vcons ssp v ϱ) (here allUnr) = _ , _ , unrestricted-venv allUnr ϱ , ssp , v 62 | access (vcons ssp x₀ ϱ) (there unrX₀ x) with access ϱ x 63 | access (vcons ssp x₀ ϱ) (there unrX₀ x) | G₁ , G₂ , inaG₂ , ssp12 , v with ssplit-compose4 ssp ssp12 64 | ... | Gi , ssp1 , ssp2 = G₁ , Gi , ssplit-inactive ssp2 (unrestricted-val unrX₀ x₀) inaG₂ , ssp1 , v 65 | 66 | -- coerce a value to a supertype 67 | coerce : ∀ {G t t'} → Val G t → SubT t t' → Val G t' 68 | coerce (VUnit inaG) sub-unit = VUnit inaG 69 | coerce (VInt i inaG) sub-int = VInt i inaG 70 | coerce (VPair ss-GG₁G₂ v v₁) (sub-pair t≤t' t≤t'') = VPair ss-GG₁G₂ (coerce v t≤t') (coerce v₁ t≤t'') 71 | coerce (VChan b vcr) (sub-chan s≲s') = VChan b (vcr-coerce vcr s≲s') 72 | coerce (VFun lu ϱ e) (sub-fun t≤t' t≤t'') = VFun lu ϱ (expr-coerce e t≤t'' t≤t') 73 | 74 | rewrite-ssplit : ∀ {G G' G₁ G₂} → G ≡ G' → SSplit G G₁ G₂ → SSplit G' G₁ G₂ 75 | rewrite-ssplit p ssp rewrite p = ssp 76 | 77 | rewrite-ssplit1 : ∀ {G G₁ G₁' G₂} → G₁ ≡ G₁' → SSplit G G₁ G₂ → SSplit G G₁' G₂ 78 | rewrite-ssplit1 p ssp rewrite p = ssp 79 | 80 | -- split environment according to type context split 81 | split-env : ∀ {Φ Φ₁ Φ₂} {G : SCtx} 82 | → Split Φ Φ₁ Φ₂ 83 | → VEnv G Φ 84 | → Σ (SCtx × SCtx) λ { (G₁ , G₂) → SSplit G G₁ G₂ × VEnv G₁ Φ₁ × VEnv G₂ Φ₂ } 85 | split-env{G = G} [] (vnil ina) = (G , G) , inactive-ssplit-trivial ina , vnil ina , vnil ina 86 | split-env (dupl unrt sp) (vcons ssp v ϱ) with split-env sp ϱ | unrestricted-val unrt v 87 | split-env (dupl unrt sp) (vcons ssp v ϱ) | (G₁' , G₂') , ssp12 , ϱ₁' , ϱ₂' | unr-v rewrite inactive-left-ssplit ssp unr-v with ssplit-compose4 ssp ssp12 | ssplit-compose3 ssp ssp12 88 | ... | Gi , ssp-GG1Gi , ssp-GiG1G2' | Gi-1 , ssp-GGiG2' , ssp-GiG1G1' = 89 | let p₁ = (inactive-left-ssplit ssp-GiG1G1' unr-v) in 90 | let p₂ = (inactive-left-ssplit ssp-GiG1G2' unr-v) in 91 | (G₁' , G₂') , ssp12 , vcons (rewrite-ssplit p₁ ssp-GiG1G1') v ϱ₁' , vcons (rewrite-ssplit p₂ ssp-GiG1G2') v ϱ₂' 92 | split-env (drop px sp) (vcons ssp v ϱ) 93 | rewrite inactive-left-ssplit ssp (unrestricted-val px v) 94 | = split-env sp ϱ 95 | split-env (left sp) (vcons ssp v ϱ) with split-env sp ϱ 96 | split-env{G = G} (left sp) (vcons ssp v ϱ) | (G₁' , G₂') , ssp12 , ϱ₁' , ϱ₂' with ssplit-compose3 ssp ssp12 97 | ... | Gi , ssp-GiG2' , ssp-GiG1G1' = (Gi , G₂') , ssp-GiG2' , vcons ssp-GiG1G1' v ϱ₁' , ϱ₂' 98 | split-env (rght sp) (vcons ssp v ϱ) with split-env sp ϱ 99 | split-env (rght sp) (vcons ssp v ϱ) | (G₁' , G₂') , ssp12 , ϱ₁' , ϱ₂' with ssplit-compose4 ssp ssp12 100 | ...| Gi , ssp-GG1'Gi , ssp-GiG1G2' = (G₁' , Gi) , ssp-GG1'Gi , ϱ₁' , vcons ssp-GiG1G2' v ϱ₂' 101 | 102 | --------------------------------------------------------------------------------