├── README.md ├── scope.agda-lib ├── rewrite-rules.yaml ├── .gitignore ├── src ├── Utils │ ├── Misc.agda │ ├── Either.agda │ ├── List.agda │ └── Tactics.agda ├── Scope.agda └── Scope │ ├── Notations.md │ ├── Diff.agda │ ├── Renaming.agda │ ├── Cut.agda │ ├── Reverse.agda │ ├── Sub.agda │ ├── In.agda │ ├── All.agda │ ├── Split.agda │ └── Core.agda ├── scope.nix ├── .github └── workflows │ ├── flake-lock-update.yml │ └── nix-ci.yml ├── Makefile ├── test └── LinearLambdaCalculus.agda ├── scope.cabal ├── LICENSE ├── flake.nix └── flake.lock /README.md: -------------------------------------------------------------------------------- 1 | Scope 2 | ===== 3 | 4 | Scope is a `agda2hs`-compatible Agda library for representing well-scoped syntax. -------------------------------------------------------------------------------- /scope.agda-lib: -------------------------------------------------------------------------------- 1 | name: scope 2 | include: src test 3 | depend: agda2hs-base 4 | flags: --erasure --erase-record-parameters 5 | -------------------------------------------------------------------------------- /rewrite-rules.yaml: -------------------------------------------------------------------------------- 1 | rewrites: 2 | 3 | - from: "Haskell.Prim.Tuple.second" 4 | to: "second" 5 | importing: "Data.Bifunctor" 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | agda-ffi/dist 2 | *.agdai 3 | MAlonzo 4 | *.prof 5 | *.treeless 6 | *.hi 7 | *.o 8 | *.agda# 9 | .#*.agda 10 | *~ 11 | lib 12 | dist-newstyle 13 | src/**/*.hs 14 | -------------------------------------------------------------------------------- /src/Utils/Misc.agda: -------------------------------------------------------------------------------- 1 | module Utils.Misc where 2 | 3 | open import Agda.Builtin.Equality 4 | 5 | subst 6 | : ∀ {ℓ ℓ′} {@0 a : Set ℓ} 7 | (@0 f : @0 a → Set ℓ′) 8 | {@0 x y : a} 9 | → @0 x ≡ y → f x → f y 10 | subst f refl x = x 11 | {-# COMPILE AGDA2HS subst transparent #-} 12 | -------------------------------------------------------------------------------- /scope.nix: -------------------------------------------------------------------------------- 1 | # this package is produced by calling `cabal2nix .` 2 | # and then doing the following: 3 | # add an agda2hs argument 4 | # add buildTools = [agda2hs]; 5 | # add preBuild = ''make alllib''; 6 | { mkDerivation, base, lib, agda2hs }: 7 | mkDerivation { 8 | pname = "scope"; 9 | version = "0.1.0.0"; 10 | src = ./.; 11 | buildTools = [agda2hs]; 12 | preBuild = ''make alllib''; 13 | libraryHaskellDepends = [ base ]; 14 | license = lib.licenses.unlicense; 15 | } 16 | -------------------------------------------------------------------------------- /src/Scope.agda: -------------------------------------------------------------------------------- 1 | module Scope where 2 | 3 | open import Scope.Core public 4 | open import Scope.Reverse 5 | open import Scope.Split public 6 | open import Scope.Sub public 7 | open import Scope.In public 8 | open import Scope.Cut public 9 | open import Scope.Diff public 10 | open import Scope.Renaming public 11 | open import Scope.All public 12 | 13 | opaque 14 | unfolding ScopeCoreThings ReverseThings SplitThings SubThings InThings DiffThings AllThings 15 | 16 | ScopeThings : Set₁ 17 | ScopeThings = Set 18 | -------------------------------------------------------------------------------- /.github/workflows/flake-lock-update.yml: -------------------------------------------------------------------------------- 1 | name: "Update all dependencies in flake.lock" 2 | on: 3 | workflow_dispatch: # allows manual triggering 4 | 5 | jobs: 6 | lockfile: 7 | permissions: 8 | contents: write 9 | pull-requests: write 10 | runs-on: ubuntu-latest 11 | steps: 12 | - name: Checkout repository 13 | uses: actions/checkout@v4 14 | - name: Install Nix 15 | uses: DeterminateSystems/nix-installer-action@v14 16 | - name: Update flake.lock 17 | uses: DeterminateSystems/update-flake-lock@v24 18 | with: 19 | pr-title: "Update flake.lock" -------------------------------------------------------------------------------- /src/Utils/Either.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | module Utils.Either where 5 | 6 | mapEither : (a → c) → (b → d) → (Either a b → Either c d) 7 | mapEither f g = either (λ x → Left (f x)) (λ y → Right (g y)) 8 | 9 | {-# COMPILE AGDA2HS mapEither #-} 10 | 11 | mapLeft : (a → c) → (Either a b → Either c b) 12 | mapLeft f = mapEither f id 13 | 14 | {-# COMPILE AGDA2HS mapLeft #-} 15 | 16 | mapRight : (b → d) → (Either a b → Either a d) 17 | mapRight = mapEither id 18 | 19 | {-# COMPILE AGDA2HS mapRight #-} 20 | 21 | swapEither : Either a b → Either b a 22 | swapEither = either (λ x → Right x) (λ y → Left y) 23 | 24 | {-# COMPILE AGDA2HS swapEither #-} 25 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | AGDA2HS = agda2hs 2 | FLAGS = 3 | LIBRARIES = 4 | 5 | .PHONY: build alllib clean clean-lib clean-agdai nix-tc nix-build 6 | 7 | build: cabal-build 8 | 9 | alllib: lib lib/Scope.hs lib/Scope/All.hs lib/Scope/Core.hs lib/Scope/Diff.hs lib/Scope/In.hs lib/Scope/Split.hs lib/Scope/Sub.hs lib/Scope/Cut.hs 10 | 11 | # alllib: lib lib/*.hs 12 | 13 | lib: 14 | mkdir lib 15 | 16 | lib/%.hs: src/%.agda 17 | $(AGDA2HS) $(FLAGS) $(LIBRARIES) $< -o lib 18 | 19 | clean: clean-lib clean-agdai 20 | 21 | clean-lib: 22 | rm -rf lib 23 | 24 | clean-agdai: 25 | rm -f src/*.agdai 26 | 27 | cabal-build: alllib 28 | cabal build 29 | 30 | nix-tc: 31 | nix build .#scope-lib --print-build-logs 32 | 33 | nix-build: 34 | nix build .#scope-hs --print-build-logs 35 | -------------------------------------------------------------------------------- /test/LinearLambdaCalculus.agda: -------------------------------------------------------------------------------- 1 | 2 | 3 | module LinearLambdaCalculus where 4 | 5 | open import Haskell.Prelude 6 | open import Scope 7 | 8 | postulate 9 | name : Set 10 | 11 | variable 12 | @0 α α₁ α₂ : Scope name 13 | 14 | data Term (@0 α : Scope name) : Set where 15 | Var : (@0 x : name) → @0 (α ≡ [ x ]) → Term α 16 | Lam : (@0 y : name) → Term (α ▸ y) → Term α 17 | App : α₁ ⋈ α₂ ≡ α → Term α₁ → Term α₂ → Term α 18 | {-# COMPILE AGDA2HS Term deriving Show #-} 19 | 20 | postulate 21 | i j k : name 22 | 23 | var! : (@0 x : name) → Term [ x ] 24 | var! x = Var x refl 25 | {-# INLINE var! #-} 26 | 27 | opaque 28 | unfolding singleton 29 | 30 | myterm : Term mempty 31 | myterm = Lam i (Lam j (App (splitBindRight splitEmptyRight) (var! i) (var! j))) 32 | 33 | {-# COMPILE AGDA2HS myterm #-} 34 | -------------------------------------------------------------------------------- /src/Utils/List.agda: -------------------------------------------------------------------------------- 1 | module Utils.List where 2 | 3 | open import Haskell.Prelude hiding (All; a; b) 4 | open import Agda.Primitive 5 | 6 | {- NOTE(flupe): 7 | maybe we don't need this compiled to Haskell 8 | but this compiles to a list anyways 9 | -} 10 | 11 | private variable 12 | ℓ ℓ′ : Level 13 | a : Set ℓ 14 | b : @0 a → Set ℓ′ 15 | x : a 16 | xs : List a 17 | 18 | data All {a : Set ℓ} (b : @0 a → Set ℓ′) : @0 List a → Set (ℓ ⊔ ℓ′) where 19 | ANil : All b [] 20 | ACons : ∀ {@0 x xs} → b x → All b xs → All b (x ∷ xs) 21 | {-# COMPILE AGDA2HS All deriving Show #-} 22 | 23 | data @0 _∈_ {a : Set ℓ} (@0 x : a) : List a → Set ℓ where 24 | here : ∀ {@0 xs : List a} → x ∈ (x ∷ xs) 25 | there : ∀ {@0 y xs} → x ∈ xs → x ∈ (y ∷ xs) 26 | 27 | @0 lookupAll : ∀ {@0 x xs} → All b xs → x ∈ xs → b x 28 | lookupAll (ACons p _ ) (here) = p 29 | lookupAll (ACons _ ps) (there i) = lookupAll ps i 30 | -------------------------------------------------------------------------------- /scope.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: scope 3 | version: 0.1.0.0 4 | -- synopsis: 5 | -- description: 6 | license: Unlicense 7 | license-file: LICENSE 8 | author: Jesper Cockx, Lucas Escot 9 | maintainer: jesper@sikanda.be, lucas@escot.me 10 | -- copyright: 11 | build-type: Simple 12 | --extra-doc-files: CHANGELOG.md 13 | -- extra-source-files: 14 | 15 | common warnings 16 | ghc-options: 17 | -Wall 18 | -fno-warn-incomplete-patterns 19 | -fno-warn-unused-matches 20 | 21 | library 22 | import: warnings 23 | exposed-modules: Scope 24 | , Scope.All 25 | , Scope.Core 26 | , Scope.Diff 27 | , Scope.In 28 | , Scope.Split 29 | , Scope.Sub 30 | other-modules: Utils.List 31 | -- other-extensions: 32 | build-depends: base >=4.17 && < 4.21 33 | hs-source-dirs: lib 34 | default-language: GHC2021 35 | -------------------------------------------------------------------------------- /.github/workflows/nix-ci.yml: -------------------------------------------------------------------------------- 1 | name: "CI" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | nix-build: 7 | name: ${{ matrix.pretty }} with nix (${{ matrix.derivation }}) 8 | runs-on: ubuntu-latest 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | derivation: [scope-hs, scope-lib] 13 | include: 14 | - pretty: "Build Haskell library" 15 | derivation: scope-hs 16 | - pretty: "Typecheck with Agda" 17 | derivation: scope-lib 18 | steps: 19 | - uses: actions/checkout@v4 20 | - uses: nixbuild/nix-quick-install-action@v34 21 | with: 22 | nix_conf: | 23 | keep-env-derivations = true 24 | keep-outputs = true 25 | - name: Restore and save Nix store 26 | uses: nix-community/cache-nix-action@v6 27 | with: 28 | # restore and save a cache using this key 29 | primary-key: nix-${{ matrix.derivation }}-${{ hashFiles('**/*.nix', '**/flake.lock') }} 30 | - run: nix build .#${{ matrix.derivation }} --cores 0 --print-build-logs 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /src/Scope/Notations.md: -------------------------------------------------------------------------------- 1 | Notations used in Scope (updated on 31/03/2025) 2 | 3 | --------------------------------------------------------------------------------------------------- 4 | symbols input via agda latex 5 | ≡ == \equiv 6 | ◂ lb \blacktriangleleft 7 | ▸ lb→ \blacktriangleright 8 | ∈ in \in 9 | ⊆ sub= \subseteq 10 | ⋈ join \bowtie 11 | ↦ r-| \mapsto 12 | ≟ ?= 13 | --------------------------------------------------------------------------------------------------- 14 | 15 | α <> β α <> β Concatenation for Scope and Rscope 16 | α ⊆ β Sub α β α is a sub-scope of β 17 | [ x ] singleton x Scope of one element x 18 | x ◂ rsingleton x RScope of one element x 19 | x ∈ α In x α singleton x ⊆ α 20 | α ▸ x bind α x Adds element x to Scope α 21 | x ◂ rα rbind x rα Adds element x to RScope rα 22 | α ⋈ β ≡ γ Split α β γ scope γ is a mix of elements of α and β 23 | α \[ xp ] diffVar α xp Scope α in which x is retired, xp : x ∈ α 24 | p ⋈-≟ q decSplit p q for p q : α ⋈ β ≡ γ, proof that p ≡ q is decidable 25 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Agda scope library"; 3 | 4 | inputs.nixpkgs.url = github:NixOS/nixpkgs/nixpkgs-unstable; 5 | inputs.flake-utils.url = github:numtide/flake-utils; 6 | inputs.agda2hs = { 7 | url = "github:agda/agda2hs/stable"; 8 | inputs.nixpkgs.follows = "nixpkgs"; 9 | inputs.flake-utils.follows = "flake-utils"; 10 | }; 11 | 12 | outputs = {self, nixpkgs, flake-utils, agda2hs}: 13 | flake-utils.lib.eachDefaultSystem (system: 14 | let 15 | pkgs = import nixpkgs {inherit system;}; 16 | agda2hs-lib = agda2hs.packages.${system}.base-lib; 17 | agda2hsWithPackages = agda2hs.lib.${system}.withPackages; 18 | agda2hs-custom = agda2hsWithPackages [agda2hs-lib]; 19 | scope-lib = pkgs.agdaPackages.mkDerivation 20 | { pname = "scope"; 21 | meta = {}; 22 | version = "0.1.0.0"; 23 | buildInputs = [ 24 | agda2hs-lib 25 | ]; 26 | preBuild = '' 27 | echo "module Everything where" > Everything.agda 28 | find src -name '*.agda' | sed -e 's/src\///;s/\//./g;s/\.agda$//;s/^/import /' >> Everything.agda 29 | ''; 30 | src = ./.; 31 | }; 32 | scope-pkg = import ./scope.nix; 33 | scope-hs = pkgs.haskellPackages.callPackage scope-pkg {agda2hs = agda2hs-custom;}; 34 | in { 35 | packages = { 36 | inherit scope-hs scope-lib; 37 | default = scope-hs; 38 | }; 39 | lib = { 40 | inherit scope-pkg; 41 | }; 42 | 43 | devShells.default = pkgs.haskellPackages.shellFor { 44 | packages = p: with p; [scope-hs]; 45 | buildInputs = with pkgs.haskellPackages; [ 46 | cabal-install 47 | cabal2nix 48 | haskell-language-server 49 | agda2hs-custom 50 | (pkgs.agda.withPackages [ agda2hs-lib ]) 51 | ]; 52 | }; 53 | }); 54 | } 55 | -------------------------------------------------------------------------------- /src/Scope/Diff.agda: -------------------------------------------------------------------------------- 1 | module Scope.Diff where 2 | 3 | open import Haskell.Prelude hiding (coerce) 4 | open import Haskell.Extra.Erase 5 | 6 | open import Scope.Core 7 | open import Scope.Split 8 | open import Scope.Sub 9 | open import Scope.In 10 | 11 | private variable 12 | @0 name : Set 13 | @0 x y : name 14 | @0 α α₁ α₂ β β₁ β₂ γ : Scope name 15 | 16 | opaque 17 | unfolding Sub 18 | 19 | @0 diff : ∀ {α β : Scope name} → α ⊆ β → Scope name 20 | diff (⟨ p ⟩ _) = p 21 | 22 | diff-left : (p : α ⋈ β ≡ γ) → diff (subLeft p) ≡ β 23 | diff-left p = refl 24 | 25 | diff-right : (p : α ⋈ β ≡ γ) → diff (subRight p) ≡ α 26 | diff-right p = refl 27 | 28 | splitDiff : (p : α ⊆ β) → α ⋈ diff p ≡ β 29 | splitDiff p = proj₂ p 30 | {-# COMPILE AGDA2HS splitDiff transparent #-} 31 | 32 | diffSub : (p : α ⊆ β) → diff p ⊆ β 33 | diffSub p = subRight (splitDiff p) 34 | {-# COMPILE AGDA2HS diffSub inline #-} 35 | 36 | diffCase : (p : α ⊆ β) → x ∈ β 37 | → (x ∈ α → a) → (x ∈ diff p → a) → a 38 | diffCase p = inSplitCase (splitDiff p) 39 | {-# COMPILE AGDA2HS diffCase inline #-} 40 | 41 | @0 diffVar : ∀ {α : Scope name} → x ∈ α → Scope name 42 | diffVar xp = diff (inToSub xp) 43 | 44 | infix 10 diffVar 45 | syntax diffVar {α = α} xp = α \[ xp ] 46 | 47 | diffVarCase : (xp : x ∈ α) → (yp : y ∈ α) 48 | → (@0 x ≡ y → a) → (x ∈ α \[ yp ] → a) → a 49 | diffVarCase xp yp ce cd = diffCase (inToSub yp) xp (λ p → inSingCase p ce) cd 50 | 51 | opaque 52 | unfolding diff 53 | 54 | diffSubTrans : (p : α ⊆ β) (q : β ⊆ γ) → diff p ⊆ diff (subTrans p q) 55 | diffSubTrans < p > < q > = 56 | let < _ , s > = splitAssoc p q 57 | in < s > 58 | {-# COMPILE AGDA2HS diffSubTrans #-} 59 | 60 | diffCoerce : (p : α ⊆ β) (q : x ∈ α) → diff (inToSub q) ⊆ diff (subTrans (inToSub q) p) 61 | diffCoerce p q = diffSubTrans (inToSub q) p 62 | {-# COMPILE AGDA2HS diffCoerce inline #-} 63 | 64 | opaque 65 | unfolding diff diffSubTrans 66 | DiffThings : Set₁ 67 | DiffThings = Set 68 | -------------------------------------------------------------------------------- /src/Utils/Tactics.agda: -------------------------------------------------------------------------------- 1 | module Utils.Tactics where 2 | 3 | open import Haskell.Prelude hiding (_>>_; _>>=_) 4 | 5 | import Agda.Builtin.String as BuiltinString 6 | open import Agda.Builtin.Reflection public using ( Term ; TC ) 7 | open Agda.Builtin.Reflection renaming ( returnTC to return ; bindTC to _>>=_ ) 8 | 9 | private 10 | _>>_ : ∀ {ℓa ℓb} {A : Set ℓa} {B : Set ℓb} → TC A → TC B → TC B 11 | m >> n = m >>= λ _ → n 12 | 13 | downFrom : Nat → List Nat 14 | downFrom (suc n) = suc n ∷ downFrom n 15 | downFrom zero = zero ∷ [] 16 | 17 | -- NOTE(flupe): move upstream? 18 | instance 19 | iIsStringBuiltinString : IsString BuiltinString.String 20 | iIsStringBuiltinString .IsString.Constraint _ = ⊤ 21 | iIsStringBuiltinString .fromString s = s 22 | 23 | macro 24 | run : (Term → TC ⊤) → Term → TC ⊤ 25 | run f hole = f hole 26 | 27 | oneOf : ∀ {ℓ} {A : Set ℓ} → List (TC A) → TC A 28 | oneOf [] = typeError [] 29 | oneOf (a ∷ as) = catchTC a (oneOf as) 30 | 31 | -- A simple macro that tries to resolve the goal automatically. 32 | -- Currently it just tries local variables and instances. 33 | 34 | auto : Term → TC ⊤ 35 | auto hole = do 36 | hole ← reduce hole 37 | case hole of λ where 38 | (meta m _) → do 39 | let trySolution v = do 40 | debugPrint "auto" 10 (strErr "auto trying " ∷ termErr v ∷ []) 41 | unify hole v 42 | let debugSolutions vs = do 43 | `vs ← quoteTC vs 44 | debugPrint "auto" 10 (strErr "auto trying list " ∷ termErr `vs ∷ []) 45 | ctx ← getContext 46 | let vars = map (λ n → var n []) (downFrom (lengthNat ctx)) 47 | debugSolutions vars 48 | catchTC (oneOf (map trySolution vars)) do 49 | debugPrint "auto" 10 (strErr "auto getting instances" ∷ []) 50 | cs ← getInstances m 51 | debugSolutions cs 52 | catchTC (oneOf (map trySolution cs)) do 53 | goal ← inferType hole 54 | typeError (strErr "auto could not find a value of type " ∷ termErr goal ∷ []) 55 | _ → typeError (strErr "auto called on already solved hole " ∷ termErr hole ∷ []) 56 | -------------------------------------------------------------------------------- /src/Scope/Renaming.agda: -------------------------------------------------------------------------------- 1 | module Scope.Renaming where 2 | 3 | open import Haskell.Prelude hiding (coerce) 4 | 5 | open import Haskell.Extra.Erase 6 | open import Haskell.Extra.Refinement 7 | open import Haskell.Law.Equality 8 | 9 | open import Scope.Core 10 | open import Scope.Sub 11 | open import Scope.In 12 | open import Scope.Diff 13 | 14 | private variable 15 | @0 name : Set 16 | @0 α β : Scope name 17 | 18 | {- 19 | data Permutation {@0 name : Set} : (@0 α β : Scope name) → Set where 20 | PNil : Permutation mempty mempty 21 | PCons : {@0 x : name} 22 | (xp : x ∈ β) 23 | → Permutation α (β \[ xp ]) 24 | → Permutation (x ◃ α) β 25 | {-# COMPILE AGDA2HS Permutation deriving Show #-} 26 | 27 | pattern ⌈⌉ = PNil 28 | infix 6 ⌈_~>_◃_⌉ 29 | pattern ⌈_~>_◃_⌉ x xp σ = PCons {x = x} xp σ 30 | infix 4 ⌈_~>_◃⌉ 31 | pattern ⌈_~>_◃⌉ x xp = ⌈ x ~> xp ◃ ⌈⌉ ⌉ 32 | -} 33 | 34 | Renaming : (@0 α β : Scope name) → Set 35 | Renaming {name = name} α β = {@0 x : name} → x ∈ α → x ∈ β 36 | {-# COMPILE AGDA2HS Renaming inline #-} 37 | 38 | opaque 39 | unfolding Scope 40 | @0 RenamingInEmpty : ∀ {@0 α : Scope name} → Renaming α mempty → α ≡ mempty 41 | RenamingInEmpty {α = []} r = refl 42 | RenamingInEmpty {α = x ∷ α} r = inEmptyCase (r inHere) 43 | 44 | {- 45 | opaque 46 | unfolding Scope 47 | permutationToRenaming : ∀ {@0 α β : Scope name} → Permutation α β → Renaming α β 48 | permutationToRenaming ⌈⌉ = id 49 | permutationToRenaming ⌈ x ~> xp ◃ _ ⌉ (Zero ⟨ IsZero refl ⟩) = xp 50 | permutationToRenaming ⌈ x ~> xp ◃ p ⌉ (Suc n ⟨ IsSuc np ⟩) = 51 | let res = permutationToRenaming p (n ⟨ np ⟩) in 52 | (coerce (diffSub (inToSub xp)) res) 53 | {-# COMPILE AGDA2HS permutationToRenaming #-} 54 | 55 | opaque 56 | permutationToRenamingRev : ∀ {@0 α β : Scope name} → Permutation α β → Renaming β α 57 | permutationToRenamingRev ⌈⌉ = id 58 | permutationToRenamingRev ⌈ x ~> xp ◃ p ⌉ yp = 59 | diffVarCase yp xp 60 | (λ refl → Zero ⟨ IsZero refl ⟩ ) 61 | (λ yp' → let res = permutationToRenamingRev p yp' in (inThere res)) 62 | {-# COMPILE AGDA2HS permutationToRenamingRev #-} 63 | 64 | opaque 65 | unfolding Scope diff 66 | idPerm : Singleton α → Permutation α α 67 | idPerm (sing []) = ⌈⌉ 68 | idPerm (sing (Erased x ∷ α)) = ⌈ x ~> Zero ⟨ IsZero refl ⟩ ◃ idPerm (sing α) ⌉ 69 | {-# COMPILE AGDA2HS idPerm inline #-} 70 | 71 | -} 72 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "agda2hs": { 4 | "inputs": { 5 | "flake-utils": [ 6 | "flake-utils" 7 | ], 8 | "nixpkgs": [ 9 | "nixpkgs" 10 | ] 11 | }, 12 | "locked": { 13 | "lastModified": 1757086409, 14 | "narHash": "sha256-ZhemGUY6V0cplSwDAXkny+s6yQWKDDShTiUotIDhTXY=", 15 | "owner": "agda", 16 | "repo": "agda2hs", 17 | "rev": "abc5e129424a42cebf9730c35401a8823667b595", 18 | "type": "github" 19 | }, 20 | "original": { 21 | "owner": "agda", 22 | "ref": "stable", 23 | "repo": "agda2hs", 24 | "type": "github" 25 | } 26 | }, 27 | "flake-utils": { 28 | "inputs": { 29 | "systems": "systems" 30 | }, 31 | "locked": { 32 | "lastModified": 1731533236, 33 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 34 | "owner": "numtide", 35 | "repo": "flake-utils", 36 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 37 | "type": "github" 38 | }, 39 | "original": { 40 | "owner": "numtide", 41 | "repo": "flake-utils", 42 | "type": "github" 43 | } 44 | }, 45 | "nixpkgs": { 46 | "locked": { 47 | "lastModified": 1762286042, 48 | "narHash": "sha256-OD5HsZ+sN7VvNucbrjiCz7CHF5zf9gP51YVJvPwYIH8=", 49 | "owner": "NixOS", 50 | "repo": "nixpkgs", 51 | "rev": "12c1f0253aa9a54fdf8ec8aecaafada64a111e24", 52 | "type": "github" 53 | }, 54 | "original": { 55 | "owner": "NixOS", 56 | "ref": "nixpkgs-unstable", 57 | "repo": "nixpkgs", 58 | "type": "github" 59 | } 60 | }, 61 | "root": { 62 | "inputs": { 63 | "agda2hs": "agda2hs", 64 | "flake-utils": "flake-utils", 65 | "nixpkgs": "nixpkgs" 66 | } 67 | }, 68 | "systems": { 69 | "locked": { 70 | "lastModified": 1681028828, 71 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 72 | "owner": "nix-systems", 73 | "repo": "default", 74 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 75 | "type": "github" 76 | }, 77 | "original": { 78 | "owner": "nix-systems", 79 | "repo": "default", 80 | "type": "github" 81 | } 82 | } 83 | }, 84 | "root": "root", 85 | "version": 7 86 | } 87 | -------------------------------------------------------------------------------- /src/Scope/Cut.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude hiding (coerce) 2 | open import Haskell.Extra.Refinement 3 | open import Haskell.Extra.Erase 4 | open import Haskell.Law.Equality 5 | 6 | open import Scope.Core 7 | open import Scope.Split 8 | open import Scope.Sub 9 | open import Scope.In 10 | 11 | module Scope.Cut where 12 | 13 | private variable 14 | @0 name : Set 15 | @0 x : name 16 | @0 α α' : Scope name 17 | 18 | opaque 19 | unfolding Scope 20 | @0 cut : {α : Scope name} → x ∈ α → Scope name × Scope name 21 | cut {α = _ ∷ α'} (Zero ⟨ p ⟩) = α' , [] 22 | cut {α = iErased ∷ α} (Suc n ⟨ IsSuc p ⟩) = do 23 | let α₀ , α₁ = cut (n ⟨ p ⟩) 24 | α₀ , iErased ∷ α₁ 25 | {-# COMPILE AGDA2HS cut #-} 26 | 27 | @0 cutDrop : {α : Scope name} → x ∈ α → Scope name 28 | cutDrop x = fst (cut x) 29 | {-# COMPILE AGDA2HS cutDrop inline #-} 30 | 31 | @0 cutTake : {α : Scope name} → x ∈ α → Scope name 32 | cutTake x = snd (cut x) 33 | {-# COMPILE AGDA2HS cutTake inline #-} 34 | 35 | opaque 36 | unfolding cut Split Scope 37 | @0 cutEq : (xp : x ∈ α) → ((cutDrop xp) ▸ x) <> (cutTake xp) ≡ α 38 | cutEq {α = iErased ∷ α'} (Zero ⟨ IsZero refl ⟩) = refl 39 | cutEq {α = iErased ∷ α'} (Suc n ⟨ IsSuc p ⟩) = cong (λ α → iErased ∷ α ) (cutEq (n ⟨ p ⟩)) 40 | 41 | {- cutSplit without unfolding use SplitRefl and therefore needs Singleton α -} 42 | cutSplit : (xp : x ∈ α) → cutTake xp ⋈ ((cutDrop xp) ▸ x) ≡ α 43 | cutSplit (Zero ⟨ IsZero refl ⟩) = EmptyL 44 | cutSplit (Suc n ⟨ IsSuc p ⟩) = ConsL _ (cutSplit (n ⟨ p ⟩)) 45 | {-# COMPILE AGDA2HS cutSplit #-} 46 | 47 | singCutDrop : {xp : x ∈ α} → Singleton α → Singleton (cutDrop xp) 48 | singCutDrop αRun = singUnbind (singSplitRight (cutSplit _) αRun) 49 | {-# COMPILE AGDA2HS singCutDrop inline #-} 50 | 51 | singCutTake : {xp : x ∈ α} → Singleton α → Singleton (cutTake xp) 52 | singCutTake αRun = singSplitLeft (cutSplit _) αRun 53 | {-# COMPILE AGDA2HS singCutTake inline #-} 54 | 55 | 56 | subCut : {xp : x ∈ α} → Singleton α → (cutDrop xp <> cutTake xp) ⊆ α 57 | subCut {xp = xp} αRun = 58 | subst0 (λ α' → (cutDrop xp <> cutTake xp) ⊆ α') 59 | (cutEq xp) (subJoin (singCutTake αRun) (subBindDrop subRefl) subRefl) 60 | {-# COMPILE AGDA2HS subCut inline #-} 61 | 62 | subCutDrop : {xp : x ∈ α} → cutDrop xp ⊆ α 63 | subCutDrop = subTrans (subBindDrop subRefl) (subRight (cutSplit _)) 64 | {-# COMPILE AGDA2HS subCutDrop inline #-} 65 | 66 | subCutTake : {xp : x ∈ α} → cutTake xp ⊆ α 67 | subCutTake = subLeft (cutSplit _) 68 | {-# COMPILE AGDA2HS subCutTake inline #-} 69 | -------------------------------------------------------------------------------- /src/Scope/Reverse.agda: -------------------------------------------------------------------------------- 1 | 2 | module Scope.Reverse where 3 | 4 | open import Haskell.Prelude hiding (All; _∘_) 5 | 6 | open import Haskell.Law.Semigroup.Def using (IsLawfulSemigroup; associativity) 7 | open import Haskell.Law.Semigroup.List using (iLawfulSemigroupList) 8 | open import Haskell.Law.Monoid.Def 9 | open import Haskell.Law.Equality 10 | open import Haskell.Extra.Erase 11 | open import Haskell.Extra.Dec as Dec 12 | 13 | open import Scope.Core 14 | 15 | 16 | private variable 17 | @0 name : Set 18 | 19 | opaque 20 | unfolding Scope 21 | 22 | revScopeAcc : Scope name → Scope name → Scope name 23 | revScopeAcc [] acc = acc 24 | revScopeAcc (x ∷ s) acc = revScopeAcc s (x ∷ acc) 25 | {-# COMPILE AGDA2HS revScopeAcc #-} 26 | 27 | revScope : Scope name → Scope name 28 | revScope s = revScopeAcc s [] 29 | {-# COMPILE AGDA2HS revScope #-} 30 | 31 | infix 7 revScope 32 | syntax revScope r = ~ r 33 | 34 | opaque 35 | unfolding revScope 36 | 37 | revScopeAccComp : (s p : Scope name) → revScopeAcc s p ≡ p <> ~ s 38 | revScopeAccComp [] p = refl 39 | revScopeAccComp (x ∷ s) p 40 | rewrite (revScopeAccComp s (x ∷ p)) 41 | rewrite (revScopeAccComp s (x ∷ [])) 42 | = associativity ⦃ iSemigroupA = iSemigroupList ⦄ (revScopeAcc s []) (x ∷ []) p 43 | 44 | private 45 | rev' : Scope name → Scope name 46 | rev' [] = [] 47 | rev' (Erased x ∷ s) = rev' s ++ [ x ] 48 | 49 | revsrev' : (s : Scope name) → revScope s ≡ rev' s 50 | revsrev' [] = refl 51 | revsrev' (x ∷ s) 52 | rewrite (revScopeAccComp s (x ∷ [])) 53 | = cong (λ t → t ++ (x ∷ [])) (revsrev' s) 54 | 55 | rev'Dist : (s p : Scope name) → rev' (p <> s) ≡ (rev' s) <> (rev' p) 56 | rev'Dist [] p = sym (leftIdentity ⦃ iMonoidA = iMonoidScope ⦄ (rev' p)) 57 | rev'Dist (x ∷ s) p = 58 | begin 59 | rev' (s ++ p) ++ (x ∷ []) 60 | ≡⟨ cong (λ a → a ++ (x ∷ [])) (rev'Dist s p) ⟩ 61 | (rev' p ++ rev' s) ++ (x ∷ []) 62 | ≡⟨ sym (associativity ⦃ iSemigroupA = iSemigroupList ⦄ (rev' p) (rev' s) (x ∷ [])) ⟩ 63 | (rev' p) ++ (rev' (x ∷ s)) 64 | ∎ 65 | 66 | rev'Involution : (s : Scope name) → rev' (rev' s) ≡ s 67 | rev'Involution [] = refl 68 | rev'Involution (x ∷ s) 69 | = trans (rev'Dist (rev' s) (x ∷ [])) (cong (λ a → x ∷ a) (rev'Involution s)) 70 | 71 | revsIdentity : revScope {name = name} mempty ≡ mempty 72 | revsIdentity = refl 73 | 74 | revsDist : (s p : Scope name) → ~ (s <> p) ≡ ~ p <> ~ s 75 | revsDist s p 76 | rewrite revsrev' s 77 | rewrite revsrev' p 78 | = trans (revsrev' (p ++ s)) (rev'Dist p s) 79 | 80 | revsInvolution : (s : Scope name) → ~ ~ s ≡ s 81 | revsInvolution s 82 | rewrite revsrev' s 83 | rewrite revsrev' (rev' s) 84 | = rev'Involution s 85 | 86 | opaque 87 | unfolding revScope revScopeAccComp 88 | 89 | ReverseThings : Set₁ 90 | ReverseThings = Set 91 | -------------------------------------------------------------------------------- /src/Scope/Sub.agda: -------------------------------------------------------------------------------- 1 | module Scope.Sub where 2 | 3 | open import Haskell.Prelude 4 | open import Haskell.Extra.Erase 5 | 6 | open import Scope.Core 7 | open import Scope.Split 8 | 9 | private variable 10 | @0 name : Set 11 | @0 x y : name 12 | @0 α α₁ α₂ β β₁ β₂ γ : Scope name 13 | 14 | opaque 15 | Sub : (@0 α β : Scope name) → Set 16 | Sub α β = Σ0 _ (λ γ → α ⋈ γ ≡ β) 17 | {-# COMPILE AGDA2HS Sub inline #-} 18 | 19 | infixr 4 Sub 20 | syntax Sub α β = α ⊆ β 21 | 22 | subTrans : α ⊆ β → β ⊆ γ → α ⊆ γ 23 | subTrans < p > < q > = 24 | let < r , _ > = splitAssoc p q 25 | in < r > 26 | {-# COMPILE AGDA2HS subTrans #-} 27 | 28 | subLeft : α ⋈ β ≡ γ → α ⊆ γ 29 | subLeft p = < p > 30 | {-# COMPILE AGDA2HS subLeft transparent #-} 31 | 32 | subRight : α ⋈ β ≡ γ → β ⊆ γ 33 | subRight p = < splitComm p > 34 | {-# COMPILE AGDA2HS subRight #-} 35 | 36 | subWeaken : α ⊆ β → α ⊆ β ▸ x 37 | subWeaken < p > = < splitBindRight p > 38 | {-# COMPILE AGDA2HS subWeaken #-} 39 | 40 | subEmpty : mempty ⊆ α 41 | subEmpty = subLeft splitEmptyLeft 42 | {-# COMPILE AGDA2HS subEmpty #-} 43 | 44 | subRefl : α ⊆ α 45 | subRefl = subLeft splitEmptyRight 46 | {-# COMPILE AGDA2HS subRefl #-} 47 | 48 | singSub : α ⊆ β → Singleton β → Singleton α 49 | singSub < p > = singSplitLeft p 50 | {-# COMPILE AGDA2HS singSub #-} 51 | 52 | subJoin : Singleton β₂ 53 | → α₁ ⊆ α₂ 54 | → β₁ ⊆ β₂ 55 | → (α₁ <> β₁) ⊆ (α₂ <> β₂) 56 | subJoin r < p > < q > = < splitJoin r p q > 57 | {-# COMPILE AGDA2HS subJoin #-} 58 | 59 | subJoinKeep : Singleton β → α₁ ⊆ α₂ → (α₁ <> β) ⊆ (α₂ <> β) 60 | subJoinKeep r < p > = < splitJoinLeft r p > 61 | {-# COMPILE AGDA2HS subJoinKeep #-} 62 | 63 | subJoinDrop : Singleton β → α₁ ⊆ α₂ → α₁ ⊆ (α₂ <> β) 64 | subJoinDrop r < p > = < splitJoinRight r p > 65 | {-# COMPILE AGDA2HS subJoinDrop #-} 66 | 67 | subJoinHere : Singleton β → α₁ ⊆ β → α₁ ⊆ (α₂ <> β) 68 | subJoinHere r < p > = < splitJoinRightr r p > 69 | {-# COMPILE AGDA2HS subJoinHere #-} 70 | 71 | opaque 72 | unfolding Sub 73 | 74 | subBindKeep : α ⊆ β → α ▸ y ⊆ β ▸ y 75 | subBindKeep {y = y} = subJoinKeep (sing (singleton y)) 76 | {-# COMPILE AGDA2HS subBindKeep #-} 77 | 78 | subBindDrop : α ⊆ β → α ⊆ β ▸ y 79 | subBindDrop = subWeaken 80 | {-# COMPILE AGDA2HS subBindDrop #-} 81 | 82 | opaque 83 | unfolding Sub 84 | 85 | joinSubLeft : Singleton α₂ → (α₁ <> α₂) ⊆ β → α₁ ⊆ β 86 | joinSubLeft r < p > = 87 | let < q , _ > = splitAssoc (splitRefl r) p 88 | in < q > 89 | {-# COMPILE AGDA2HS joinSubLeft #-} 90 | 91 | joinSubRight : Singleton α₂ → (α₁ <> α₂) ⊆ β → α₂ ⊆ β 92 | joinSubRight r < p > = 93 | let < q , _ > = splitAssoc (splitComm (splitRefl r)) p 94 | in < q > 95 | {-# COMPILE AGDA2HS joinSubRight #-} 96 | 97 | opaque 98 | unfolding RScope Sub Split extScope 99 | subExtScopeKeep : {@0 rγ : RScope name} → Singleton rγ → α ⊆ β → (extScope α rγ) ⊆ (extScope β rγ) 100 | subExtScopeKeep (sing []) s = s 101 | subExtScopeKeep (sing (Erased x ∷ rγ)) (⟨ δ ⟩ s) = subExtScopeKeep (sing rγ) (⟨ δ ⟩ (ConsL x s)) 102 | {-# COMPILE AGDA2HS subExtScopeKeep #-} 103 | 104 | 105 | subExtScope : {@0 rγ : RScope name} → Singleton rγ → α ⊆ β → α ⊆ (extScope β rγ) 106 | subExtScope (sing []) s = s 107 | subExtScope (sing (Erased x ∷ rγ)) (⟨ δ ⟩ s) = subExtScope (sing rγ) (⟨ δ ▸ x ⟩ (ConsR x s)) 108 | {-# COMPILE AGDA2HS subExtScope #-} 109 | 110 | opaque 111 | unfolding Sub subBindKeep joinSubLeft subExtScope 112 | SubThings : Set₁ 113 | SubThings = Set 114 | -------------------------------------------------------------------------------- /src/Scope/In.agda: -------------------------------------------------------------------------------- 1 | module Scope.In where 2 | 3 | open import Haskell.Prelude hiding (coerce) 4 | 5 | open import Haskell.Extra.Dec 6 | open import Haskell.Extra.Erase 7 | open import Haskell.Extra.Refinement 8 | open import Haskell.Law.Equality 9 | 10 | open import Utils.Misc 11 | 12 | open import Scope.Core 13 | open import Scope.Split 14 | open import Scope.Sub 15 | 16 | private variable 17 | @0 name : Set 18 | @0 x y : name 19 | @0 α β γ : Scope name 20 | @0 rα rβ : RScope name 21 | 22 | data Index : Set where 23 | Zero : Index 24 | Suc : Index → Index 25 | {-# COMPILE AGDA2HS Index deriving Show #-} 26 | 27 | 28 | data IsNth (@0 x : name) : @0 Scope name → Index → Set where 29 | IsZero : x ≡ y → IsNth x (α ▸ y) Zero 30 | IsSuc : {n : Index} → IsNth x α n → IsNth x (α ▸ y) (Suc n) 31 | 32 | In : @0 name → @0 Scope name → Set 33 | In x α = ∃ Index (λ n → IsNth x α n) 34 | {-# COMPILE AGDA2HS In inline #-} 35 | 36 | infix 6 In 37 | syntax In x α = x ∈ α 38 | 39 | data IsNthR (@0 x : name) : @0 RScope name → Index → Set where 40 | IsZeroR : x ≡ y → IsNthR x (y ◂ rα) Zero 41 | IsSucR : {n : Index} → IsNthR x rα n → IsNthR x (y ◂ rα) (Suc n) 42 | 43 | InR : @0 name → @0 RScope name → Set 44 | InR x rα = ∃ Index (λ n → IsNthR x rα n) 45 | {-# COMPILE AGDA2HS InR inline #-} 46 | 47 | infix 6 InR 48 | syntax InR x rα = rα ∋ x 49 | 50 | inToSub : x ∈ α → [ x ] ⊆ α 51 | inToSub {x = x} (Zero ⟨ IsZero refl ⟩) = subRight (splitRefl (sing [ x ])) 52 | inToSub (Suc n ⟨ IsSuc p ⟩) = subBindDrop (inToSub (n ⟨ p ⟩)) 53 | {-# COMPILE AGDA2HS inToSub #-} 54 | 55 | opaque 56 | unfolding Sub Split 57 | subToIn : [ x ] ⊆ α → x ∈ α 58 | subToIn < EmptyR > = Zero ⟨ IsZero refl ⟩ 59 | subToIn < ConsL _ _ > = Zero ⟨ IsZero refl ⟩ 60 | subToIn < ConsR _ p > = do 61 | let n ⟨ np ⟩ = subToIn < p > 62 | Suc n ⟨ IsSuc np ⟩ 63 | {-# COMPILE AGDA2HS subToIn #-} 64 | 65 | opaque 66 | unfolding Sub Split 67 | coerce : α ⊆ β → x ∈ α → x ∈ β 68 | coerce < EmptyR > p = p 69 | coerce < ConsL _ _ > (Zero ⟨ IsZero refl ⟩) = Zero ⟨ IsZero refl ⟩ 70 | coerce < ConsL _ j > (Suc n ⟨ IsSuc p ⟩) = do 71 | let n' ⟨ p' ⟩ = coerce < j > (n ⟨ p ⟩) 72 | Suc n' ⟨ IsSuc p' ⟩ 73 | coerce (⟨ _ ⟩ ConsR _ j) (n ⟨ p ⟩) = do 74 | let n' ⟨ p' ⟩ = coerce < j > (n ⟨ p ⟩) 75 | Suc n' ⟨ IsSuc p' ⟩ 76 | {-# COMPILE AGDA2HS coerce #-} 77 | 78 | opaque 79 | 80 | inHere : x ∈ (α ▸ x) 81 | inHere = Zero ⟨ IsZero refl ⟩ 82 | {-# COMPILE AGDA2HS inHere #-} 83 | 84 | inThere : x ∈ α → x ∈ (α ▸ y) 85 | inThere (n ⟨ p ⟩) = Suc n ⟨ IsSuc p ⟩ 86 | {-# COMPILE AGDA2HS inThere #-} 87 | 88 | bindSubToIn : (α ▸ x) ⊆ β → x ∈ β 89 | bindSubToIn s = coerce s inHere 90 | {-# COMPILE AGDA2HS bindSubToIn #-} 91 | 92 | opaque 93 | 94 | inRHere : (x ◂ rα) ∋ x 95 | inRHere = Zero ⟨ IsZeroR refl ⟩ 96 | {-# COMPILE AGDA2HS inRHere #-} 97 | 98 | inRThere : rα ∋ x → (y ◂ rα) ∋ x 99 | inRThere (n ⟨ p ⟩) = Suc n ⟨ IsSucR p ⟩ 100 | {-# COMPILE AGDA2HS inRThere #-} 101 | 102 | opaque 103 | unfolding Split 104 | 105 | @0 inEmptyToBot : x ∈ mempty → ⊥ 106 | inEmptyToBot () 107 | 108 | inEmptyCase : @0 (x ∈ mempty) → a 109 | inEmptyCase p = error {i = inEmptyToBot p} "impossible" 110 | {-# COMPILE AGDA2HS inEmptyCase #-} 111 | 112 | inSingCase : x ∈ [ y ] → (@0 x ≡ y → a) → a 113 | inSingCase (Zero ⟨ IsZero refl ⟩) f = f refl 114 | inSingCase (Suc n ⟨ IsSuc () ⟩) f 115 | {-# COMPILE AGDA2HS inSingCase #-} 116 | 117 | inSplitCase : α ⋈ β ≡ γ → x ∈ γ → (x ∈ α → a) → (x ∈ β → a) → a 118 | inSplitCase EmptyL (Zero ⟨ IsZero refl ⟩) f g = g inHere 119 | inSplitCase EmptyL (Suc n ⟨ IsSuc p ⟩) f g = g (inThere (n ⟨ p ⟩)) 120 | inSplitCase EmptyR (Zero ⟨ IsZero refl ⟩) f g = f inHere 121 | inSplitCase EmptyR (Suc n ⟨ IsSuc p ⟩) f g = f (inThere (n ⟨ p ⟩)) 122 | inSplitCase (ConsL _ j) (Zero ⟨ IsZero refl ⟩) f g = f inHere 123 | inSplitCase (ConsL _ j) (Suc n ⟨ IsSuc p ⟩) f g = inSplitCase j (n ⟨ p ⟩) (f ∘ inThere) g 124 | inSplitCase (ConsR _ j) (Zero ⟨ IsZero refl ⟩) f g = g inHere 125 | inSplitCase (ConsR _ j) (Suc n ⟨ IsSuc p ⟩) f g = inSplitCase j (n ⟨ p ⟩) f (g ∘ inThere) 126 | {-# COMPILE AGDA2HS inSplitCase #-} 127 | 128 | opaque 129 | inJoinCase 130 | : Singleton β 131 | → x ∈ (α <> β) → (x ∈ α → a) → (x ∈ β → a) → a 132 | inJoinCase r = inSplitCase (splitRefl r) 133 | {-# COMPILE AGDA2HS inJoinCase #-} 134 | 135 | opaque 136 | inBindCase : x ∈ (α ▸ y) → (x ∈ α → a) → (@0 x ≡ y → a) → a 137 | inBindCase {α = α} {y = y} p g f = inJoinCase (sing ([ y ])) p g ((λ q → (inSingCase q f))) 138 | {-# COMPILE AGDA2HS inBindCase #-} 139 | 140 | inScopeInExtScope : Singleton rβ → x ∈ α → x ∈ (extScope α rβ) 141 | inScopeInExtScope r = coerce (subExtScope r subRefl) 142 | {-# COMPILE AGDA2HS inScopeInExtScope inline #-} 143 | 144 | opaque 145 | unfolding Scope 146 | 147 | decIn 148 | : {@0 x y : name} (p : x ∈ α) (q : y ∈ α) 149 | → Dec (_≡_ {A = Σ0 name (λ n → n ∈ α)} (⟨ x ⟩ p) (⟨ y ⟩ q)) 150 | decIn (Zero ⟨ IsZero refl ⟩) (Zero ⟨ IsZero refl ⟩) = True ⟨ refl ⟩ 151 | decIn (Zero ⟨ _ ⟩) (Suc m ⟨ _ ⟩) = False ⟨ (λ ()) ⟩ 152 | decIn (Suc n ⟨ _ ⟩) (Zero ⟨ _ ⟩) = False ⟨ (λ ()) ⟩ 153 | decIn (Suc n ⟨ IsSuc p ⟩) (Suc m ⟨ IsSuc q ⟩) = mapDec aux (λ where refl → refl) (decIn (n ⟨ p ⟩) (m ⟨ q ⟩)) 154 | where 155 | @0 aux : ∀ {@0 x y z γ n m} {p : IsNth x γ n} {q : IsNth y γ m} → 156 | _≡_ {A = Σ0 name (λ w → w ∈ γ)} (⟨ x ⟩ n ⟨ p ⟩) (⟨ y ⟩ m ⟨ q ⟩) → 157 | _≡_ {A = Σ0 name (λ w → w ∈ (Erased z ∷ γ))} 158 | (⟨ x ⟩ Suc n ⟨ IsSuc p ⟩) 159 | (⟨ y ⟩ Suc m ⟨ IsSuc q ⟩) 160 | aux refl = refl 161 | {-# COMPILE AGDA2HS decIn #-} 162 | 163 | opaque 164 | unfolding RScope 165 | decInR 166 | : {@0 x y : name} (p : rα ∋ x) (q : rα ∋ y) 167 | → Dec (_≡_ {A = Σ0 name (λ n → rα ∋ n)} (⟨ x ⟩ p) (⟨ y ⟩ q)) 168 | decInR (Zero ⟨ IsZeroR refl ⟩) (Zero ⟨ IsZeroR refl ⟩) = True ⟨ refl ⟩ 169 | decInR (Zero ⟨ _ ⟩) (Suc m ⟨ _ ⟩) = False ⟨ (λ ()) ⟩ 170 | decInR (Suc n ⟨ _ ⟩) (Zero ⟨ _ ⟩) = False ⟨ (λ ()) ⟩ 171 | decInR (Suc n ⟨ IsSucR p ⟩) (Suc m ⟨ IsSucR q ⟩) = mapDec aux (λ where refl → refl) (decInR (n ⟨ p ⟩) (m ⟨ q ⟩)) 172 | where 173 | @0 aux : ∀ {@0 x y z γ n m} {p : IsNthR x γ n} {q : IsNthR y γ m} → 174 | _≡_ {A = Σ0 name (λ w → γ ∋ w)} (⟨ x ⟩ n ⟨ p ⟩) (⟨ y ⟩ m ⟨ q ⟩) → 175 | _≡_ {A = Σ0 name (λ w → (Erased z ∷ γ) ∋ w)} 176 | (⟨ x ⟩ Suc n ⟨ IsSucR p ⟩) 177 | (⟨ y ⟩ Suc m ⟨ IsSucR q ⟩) 178 | aux refl = refl 179 | {-# COMPILE AGDA2HS decInR #-} 180 | 181 | opaque 182 | unfolding subToIn coerce inHere inEmptyCase inJoinCase inBindCase decIn inRHere decInR 183 | InThings : Set₁ 184 | InThings = Set 185 | -------------------------------------------------------------------------------- /src/Scope/All.agda: -------------------------------------------------------------------------------- 1 | module Scope.All where 2 | 3 | open import Haskell.Prelude hiding (All) 4 | open import Haskell.Extra.Dec 5 | open import Haskell.Extra.Erase 6 | open import Haskell.Extra.Refinement 7 | open import Haskell.Law.Equality 8 | open import Haskell.Prim.Tuple using (second) 9 | 10 | import Utils.List as List 11 | open import Utils.Tactics 12 | 13 | open import Scope.Core 14 | open import Scope.In 15 | open import Scope.Sub 16 | open import Scope.Split 17 | 18 | private variable 19 | @0 name : Set 20 | @0 α β : Scope name 21 | @0 rα rβ : RScope name 22 | @0 x y : name 23 | p q : @0 name → Set 24 | 25 | opaque 26 | unfolding Scope 27 | 28 | {- All p α is a proof that ∀ (x ∈ α), p x -} 29 | All : (p : @0 name → Set) → @0 Scope name → Set 30 | All p = List.All λ x → p (get x) 31 | {-# COMPILE AGDA2HS All #-} 32 | 33 | allEmpty : All p mempty 34 | allEmpty = List.ANil 35 | {-# COMPILE AGDA2HS allEmpty #-} 36 | 37 | allSingl : p x → All p [ x ] 38 | allSingl p = List.ACons p List.ANil 39 | {-# COMPILE AGDA2HS allSingl #-} 40 | 41 | getAllSingl : All p [ x ] → p x 42 | getAllSingl (List.ACons p List.ANil) = p 43 | {-# COMPILE AGDA2HS getAllSingl #-} 44 | 45 | allJoin : All p α → All p β → All p (α <> β) 46 | allJoin {p = p} pas List.ANil = pas 47 | allJoin {p = p} pas (List.ACons px pbs) = List.ACons px (allJoin pas pbs) 48 | {-# COMPILE AGDA2HS allJoin #-} 49 | 50 | opaque 51 | unfolding RScope 52 | 53 | {- All p α is a proof that ∀ (x ∈ rα), p x -} 54 | AllR : (p : @0 name → Set) → @0 RScope name → Set 55 | AllR p = List.All λ x → p (get x) 56 | {-# COMPILE AGDA2HS AllR #-} 57 | 58 | allEmptyR : AllR p mempty 59 | allEmptyR = List.ANil 60 | {-# COMPILE AGDA2HS allEmptyR #-} 61 | 62 | allSinglR : p x → AllR p (x ◂) 63 | allSinglR p = List.ACons p List.ANil 64 | {-# COMPILE AGDA2HS allSinglR #-} 65 | 66 | getAllSinglR : AllR p (x ◂) → p x 67 | getAllSinglR (List.ACons p List.ANil) = p 68 | {-# COMPILE AGDA2HS getAllSinglR #-} 69 | 70 | allJoinR : AllR p rα → AllR p rβ → AllR p (rβ <> rα) 71 | allJoinR {p = p} pas List.ANil = pas 72 | allJoinR {p = p} pas (List.ACons px pbs) = List.ACons px (allJoinR pas pbs) 73 | {-# COMPILE AGDA2HS allJoinR #-} 74 | 75 | opaque 76 | unfolding All 77 | 78 | lookupAll : All p α → x ∈ α → p x 79 | lookupAll (List.ACons pz pzs) (Zero ⟨ IsZero refl ⟩) = pz 80 | lookupAll (List.ACons _ pzs) (Suc n ⟨ IsSuc pn ⟩) = lookupAll pzs (n ⟨ pn ⟩) 81 | {-# COMPILE AGDA2HS lookupAll #-} 82 | 83 | findAll : {q : Set} 84 | → All p α 85 | → ({@0 el : name} → (pel : p el) → (ela : el ∈ α) → Maybe q) 86 | → Maybe q 87 | findAll List.ANil qc = Nothing 88 | findAll (List.ACons px al) qc = 89 | case qc px (inHere) of λ where 90 | (Just qt) → Just qt 91 | Nothing → findAll al (λ pel i → qc pel (inThere i)) 92 | {-# COMPILE AGDA2HS findAll #-} 93 | 94 | opaque 95 | unfolding AllR 96 | 97 | lookupAllR : AllR p rα → rα ∋ x → p x 98 | lookupAllR (List.ACons pz pzs) (Zero ⟨ IsZeroR refl ⟩) = pz 99 | lookupAllR (List.ACons _ pzs) (Suc n ⟨ IsSucR pn ⟩) = lookupAllR pzs (n ⟨ pn ⟩) 100 | {-# COMPILE AGDA2HS lookupAllR #-} 101 | 102 | findAllR : {q : Set} 103 | → AllR p rα 104 | → ({@0 el : name} → (pel : p el) → (ela : rα ∋ el) → Maybe q) 105 | → Maybe q 106 | findAllR List.ANil qc = Nothing 107 | findAllR (List.ACons px al) qc = 108 | case qc px (inRHere) of λ where 109 | (Just qt) → Just qt 110 | Nothing → findAllR al (λ pel i → qc pel (inRThere i)) 111 | {-# COMPILE AGDA2HS findAllR #-} 112 | 113 | opaque 114 | unfolding All Sub Split lookupAll inHere splitRefl 115 | 116 | lookupHere : (l : All p α) (ph : p x) 117 | → lookupAll (allJoin l (allSingl ph)) inHere ≡ ph 118 | lookupHere _ _ = refl 119 | 120 | opaque 121 | unfolding All Sub Split lookupAll inThere subBindDrop subJoinDrop splitJoinRight 122 | 123 | lookupThere : {ph : p y} {pi : p x} {l : All p α} {i : x ∈ α} 124 | → lookupAll l i ≡ pi 125 | → lookupAll (allJoin l (allSingl ph)) (inThere i) ≡ pi 126 | lookupThere p = p 127 | 128 | _!_ : {p : @0 name → Set} {@0 α : Scope name} 129 | → All p α → (@0 x : name) → {@(tactic auto) ok : x ∈ α} → p x 130 | (ps ! _) {s} = lookupAll ps s 131 | 132 | {-# INLINE _!_ #-} 133 | 134 | opaque 135 | unfolding All 136 | 137 | mapAll : (f : ∀ {@0 x} → p x → q x) → All p α → All q α 138 | mapAll f List.ANil = List.ANil 139 | mapAll f (List.ACons p ps) = List.ACons (f p) (mapAll f ps) 140 | {-# COMPILE AGDA2HS mapAll #-} 141 | 142 | tabulateAll : Singleton α → (f : ∀ {@0 x} → (x ∈ α) → p x) → All p α 143 | tabulateAll (sing []) f = List.ANil 144 | tabulateAll (sing (x ∷ α)) f = List.ACons (f inHere) (tabulateAll (sing-id) (f ∘ inThere)) 145 | {-# COMPILE AGDA2HS tabulateAll #-} 146 | 147 | allIn : All p α → All (λ el → p el × el ∈ α) α 148 | allIn List.ANil = List.ANil 149 | allIn (List.ACons x al) = List.ACons (x , inHere) (mapAll (second inThere) (allIn al)) 150 | {-# COMPILE AGDA2HS allIn #-} 151 | 152 | singAll : All p α → Singleton α 153 | singAll List.ANil = sing [] 154 | singAll (List.ACons {x = x} _ xs) = singCong2 (_∷_) singErase (singAll xs) 155 | {-# COMPILE AGDA2HS singAll #-} 156 | 157 | allInScope : ∀ {@0 γ} 158 | (als : All (λ c → c ∈ γ) α) 159 | (bls : All (λ c → c ∈ γ) β) 160 | → Maybe (Erase (α ≡ β)) 161 | allInScope List.ANil List.ANil = Just (Erased refl) 162 | allInScope List.ANil (List.ACons _ _) = Nothing 163 | allInScope (List.ACons _ _) List.ANil = Nothing 164 | allInScope (List.ACons {x = x} p als) (List.ACons q bls) = do 165 | rt ← allInScope als bls 166 | ifDec (decIn p q) 167 | (λ where {{refl}} → Just (Erased (cong (λ t → t ▸ (get x)) (get rt)))) 168 | Nothing 169 | {-# COMPILE AGDA2HS allInScope #-} 170 | 171 | opaque 172 | unfolding AllR 173 | 174 | mapAllR : (f : ∀ {@0 x} → p x → q x) → AllR p rα → AllR q rα 175 | mapAllR f List.ANil = List.ANil 176 | mapAllR f (List.ACons p ps) = List.ACons (f p) (mapAllR f ps) 177 | {-# COMPILE AGDA2HS mapAllR #-} 178 | 179 | tabulateAllR : Singleton rα → (f : ∀ {@0 x} → (rα ∋ x) → p x) → AllR p rα 180 | tabulateAllR (sing []) f = List.ANil 181 | tabulateAllR (sing (x ∷ α)) f = List.ACons (f inRHere) (tabulateAllR (sing-id) (f ∘ inRThere)) 182 | {-# COMPILE AGDA2HS tabulateAllR #-} 183 | 184 | allInR : AllR p rα → AllR (λ el → p el × rα ∋ el) rα 185 | allInR List.ANil = List.ANil 186 | allInR (List.ACons x al) = List.ACons (x , inRHere) (mapAllR (second inRThere) (allInR al)) 187 | {-# COMPILE AGDA2HS allInR #-} 188 | 189 | singAllR : AllR p rα → Singleton rα 190 | singAllR List.ANil = sing [] 191 | singAllR (List.ACons {x = x} _ xs) = singCong2 (_∷_) singErase (singAllR xs) 192 | {-# COMPILE AGDA2HS singAllR #-} 193 | 194 | allInRScope : ∀ {@0 γ} 195 | (als : AllR (λ c → c ∈ γ) rα) 196 | (bls : AllR (λ c → c ∈ γ) rβ) 197 | → Maybe (Erase (rα ≡ rβ)) 198 | allInRScope List.ANil List.ANil = Just (Erased refl) 199 | allInRScope List.ANil (List.ACons _ _) = Nothing 200 | allInRScope (List.ACons _ _) List.ANil = Nothing 201 | allInRScope (List.ACons {x = x} p als) (List.ACons q bls) = do 202 | rt ← allInRScope als bls 203 | ifDec (decIn p q) 204 | (λ where {{refl}} → Just (Erased (cong (λ t → (get x) ◂ t) (get rt)))) 205 | Nothing 206 | {-# COMPILE AGDA2HS allInRScope #-} 207 | 208 | opaque 209 | unfolding All lookupAll 210 | 211 | allLookup : (ls : All p α) 212 | → All (λ el → ∃ (el ∈ α × p el) (λ (i , pri) → lookupAll ls i ≡ pri)) α 213 | allLookup List.ANil = List.ANil 214 | allLookup (List.ACons ph ls) = 215 | List.ACons 216 | ((inHere , ph) ⟨ lookupHere ls ph ⟩) 217 | (mapAll (λ where ((i , pri) ⟨ lp ⟩) → ((inThere i) , pri) ⟨ lookupThere lp ⟩) 218 | (allLookup ls)) 219 | {-# COMPILE AGDA2HS allLookup #-} 220 | 221 | opaque 222 | unfolding All findAll lookupAll lookupHere lookupThere 223 | unfolding mapAll tabulateAll allIn singAll allInScope allLookup 224 | unfolding AllR mapAllR 225 | 226 | AllThings : Set₁ 227 | AllThings = Set 228 | -------------------------------------------------------------------------------- /src/Scope/Split.agda: -------------------------------------------------------------------------------- 1 | module Scope.Split where 2 | 3 | open import Haskell.Prelude 4 | 5 | open import Haskell.Extra.Dec 6 | open import Haskell.Extra.Erase 7 | open import Haskell.Extra.Refinement 8 | open import Haskell.Law.Equality hiding (subst) 9 | open import Haskell.Law.Monoid 10 | 11 | open import Scope.Core 12 | 13 | open import Utils.Misc 14 | 15 | private variable 16 | @0 name : Set 17 | @0 x : name 18 | @0 α α₁ α₂ β β₁ β₂ γ δ ε : Scope name 19 | 20 | -- This datatype has to use the actual [] and _∷_ constructors instead of 21 | -- ∅ and _◃_, because otherwise the erased constructor arguments are not 22 | -- recognized as being forced (see https://github.com/agda/agda/issues/6744). 23 | 24 | data ListSplit {@0 name : Set} : (@0 α β γ : List (Erase name)) → Set where 25 | EmptyL : ∀ {@0 β} → ListSplit [] β β 26 | EmptyR : ∀ {@0 α} → ListSplit α [] α 27 | ConsL : ∀ {@0 α β γ} (@0 x : name) 28 | → ListSplit α β γ 29 | → ListSplit (Erased x ∷ α) β (Erased x ∷ γ) 30 | ConsR : ∀ {@0 α β γ} (@0 y : name) 31 | → ListSplit α β γ 32 | → ListSplit α (Erased y ∷ β) (Erased y ∷ γ) 33 | {-# COMPILE AGDA2HS ListSplit deriving Show #-} 34 | 35 | opaque 36 | unfolding Scope 37 | 38 | -- OPI (Order-Preserving Interleaving) 39 | Split : (@0 α β γ : Scope name) → Set 40 | Split = ListSplit 41 | 42 | {-# COMPILE AGDA2HS Split inline #-} 43 | 44 | syntax Split α β γ = α ⋈ β ≡ γ 45 | 46 | opaque 47 | unfolding Split 48 | 49 | splitEmptyLeft : mempty ⋈ β ≡ β 50 | splitEmptyLeft = EmptyL 51 | {-# COMPILE AGDA2HS splitEmptyLeft inline #-} 52 | 53 | splitEmptyRight : α ⋈ mempty ≡ α 54 | splitEmptyRight = EmptyR 55 | {-# COMPILE AGDA2HS splitEmptyRight inline #-} 56 | 57 | splitRefl : Singleton β → α ⋈ β ≡ (α <> β) 58 | splitRefl (sing []) = splitEmptyRight 59 | splitRefl (sing (Erased x ∷ β)) = ConsR x (splitRefl (sing β)) 60 | {-# COMPILE AGDA2HS splitRefl #-} 61 | 62 | splitComm : α ⋈ β ≡ γ → β ⋈ α ≡ γ 63 | splitComm EmptyL = EmptyR 64 | splitComm EmptyR = EmptyL 65 | splitComm (ConsL x p) = ConsR x (splitComm p) 66 | splitComm (ConsR y p) = ConsL y (splitComm p) 67 | {-# COMPILE AGDA2HS splitComm #-} 68 | 69 | splitAssoc 70 | : α ⋈ β ≡ γ 71 | → γ ⋈ δ ≡ ε 72 | → Σ0 _ λ ζ → (α ⋈ ζ ≡ ε) × (β ⋈ δ ≡ ζ) 73 | splitAssoc EmptyL q = < EmptyL , q > 74 | splitAssoc EmptyR q = < q , EmptyL > 75 | splitAssoc p EmptyR = < p , EmptyR > 76 | splitAssoc (ConsL x p) (ConsL .x q) = 77 | let < r , s > = splitAssoc p q 78 | in < ConsL x r , s > 79 | splitAssoc (ConsR y p) (ConsL .y q) = 80 | let < r , s > = splitAssoc p q 81 | in < ConsR y r , ConsL y s > 82 | splitAssoc p (ConsR y q) = 83 | let < r , s > = splitAssoc p q 84 | in < ConsR y r , ConsR y s > 85 | {-# COMPILE AGDA2HS splitAssoc #-} 86 | 87 | -- NOTE(flupe): we force the use of 2-uples instead of 3/4-uples 88 | -- because compilation of the latter is buggy 89 | 90 | splitQuad 91 | : α₁ ⋈ α₂ ≡ γ 92 | → β₁ ⋈ β₂ ≡ γ 93 | → Σ0 ((Scope name × Scope name) × (Scope name × Scope name)) λ ((γ₁ , γ₂) , (γ₃ , γ₄)) → 94 | ((γ₁ ⋈ γ₂ ≡ α₁) × (γ₃ ⋈ γ₄ ≡ α₂)) × 95 | ((γ₁ ⋈ γ₃ ≡ β₁) × (γ₂ ⋈ γ₄ ≡ β₂)) 96 | splitQuad EmptyL q = < (EmptyL , q) , (EmptyL , EmptyL) > 97 | splitQuad EmptyR q = < (q , EmptyR) , (EmptyR , EmptyR) > 98 | splitQuad p EmptyL = < (EmptyL , EmptyL) , (EmptyL , p) > 99 | splitQuad p EmptyR = < (EmptyR , EmptyR) , (p , EmptyR) > 100 | splitQuad (ConsL x p) (ConsL x q) = 101 | let < ( r , s) , ( t , u) > = splitQuad p q 102 | in < (ConsL x r , s) , (ConsL x t , u) > 103 | splitQuad (ConsL x p) (ConsR x q) = 104 | let < ( r , s) , (t , u) > = splitQuad p q 105 | in < (ConsR x r , s) , (t , ConsL x u) > 106 | splitQuad (ConsR x p) (ConsL x q) = 107 | let < (r , s) , ( t , u) > = splitQuad p q 108 | in < (r , ConsL x s) , (ConsR x t , u) > 109 | splitQuad (ConsR x p) (ConsR x q) = 110 | let < (r , s) , (t , u) > = splitQuad p q 111 | in < (r , ConsR x s) , (t , ConsR x u) > 112 | {-# COMPILE AGDA2HS splitQuad #-} 113 | 114 | opaque 115 | unfolding Split 116 | 117 | singSplit : α ⋈ β ≡ γ → Singleton γ → Singleton α × Singleton β 118 | singSplit EmptyL r = sing [] , r 119 | singSplit EmptyR r = r , sing [] 120 | singSplit (ConsL x p) r = 121 | let (r1 , r2) = singSplit p (singTail r) 122 | in (singBind r1) , r2 123 | singSplit (ConsR x p) r = 124 | let (r1 , r2) = singSplit p (singTail r) 125 | in r1 , singBind r2 126 | {-# COMPILE AGDA2HS singSplit #-} 127 | 128 | opaque 129 | unfolding Split 130 | 131 | singSplitLeft : α ⋈ β ≡ γ → Singleton γ → Singleton α 132 | singSplitLeft p r = fst (singSplit p r) 133 | {-# COMPILE AGDA2HS singSplitLeft #-} 134 | 135 | singSplitRight : α ⋈ β ≡ γ → Singleton γ → Singleton β 136 | singSplitRight p r = snd (singSplit p r) 137 | {-# COMPILE AGDA2HS singSplitRight #-} 138 | 139 | splitJoinLeft : Singleton β → α₁ ⋈ α₂ ≡ α → (α₁ <> β) ⋈ α₂ ≡ (α <> β) 140 | splitJoinLeft (sing []) p = p 141 | splitJoinLeft (sing (Erased x ∷ α)) p = ConsL x (splitJoinLeft (sing α) p) 142 | {-# COMPILE AGDA2HS splitJoinLeft #-} 143 | 144 | splitJoinRight : Singleton β → α₁ ⋈ α₂ ≡ α → α₁ ⋈ (α₂ <> β) ≡ (α <> β) 145 | splitJoinRight (sing []) p = p 146 | splitJoinRight (sing (Erased x ∷ α)) p = ConsR x (splitJoinRight (sing α) p) 147 | {-# COMPILE AGDA2HS splitJoinRight #-} 148 | 149 | splitJoin 150 | : Singleton β 151 | → α₁ ⋈ α₂ ≡ α 152 | → β₁ ⋈ β₂ ≡ β 153 | → (α₁ <> β₁) ⋈ (α₂ <> β₂) ≡ (α <> β) 154 | splitJoin r p EmptyL = splitJoinRight r p 155 | splitJoin r p EmptyR = splitJoinLeft r p 156 | splitJoin r p (ConsL x q) = ConsL x (splitJoin (singTail r) p q) 157 | splitJoin r p (ConsR x q) = ConsR x (splitJoin (singTail r) p q) 158 | {-# COMPILE AGDA2HS splitJoin #-} 159 | 160 | splitJoinLeftr : Singleton β → β₁ ⋈ β₂ ≡ β → (α <> β₁) ⋈ β₂ ≡ (α <> β) 161 | splitJoinLeftr {β = β} {β₁ = β₁} {β₂ = β₂} {α = α} r p = 162 | subst (λ γ → (α <> β₁) ⋈ γ ≡ (α <> β)) (leftIdentity β₂) (splitJoin r splitEmptyRight p) 163 | {-# COMPILE AGDA2HS splitJoinLeftr #-} 164 | 165 | splitJoinRightr : Singleton β → β₁ ⋈ β₂ ≡ β → β₁ ⋈ (α <> β₂) ≡ (α <> β) 166 | splitJoinRightr {β = β} {β₁ = β₁} {β₂ = β₂} {α = α} r p = 167 | subst (λ γ → γ ⋈ (α <> β₂) ≡ (α <> β)) (leftIdentity β₁) (splitJoin r splitEmptyLeft p) 168 | {-# COMPILE AGDA2HS splitJoinRightr #-} 169 | 170 | opaque 171 | unfolding Split 172 | 173 | splitBindLeft : α ⋈ β ≡ γ → (α ▸ x) ⋈ β ≡ (γ ▸ x) 174 | splitBindLeft {x = x} = splitJoinLeft (sing [ x ]) 175 | {-# COMPILE AGDA2HS splitBindLeft #-} 176 | 177 | splitBindRight : α ⋈ β ≡ γ → α ⋈ (β ▸ x) ≡ (γ ▸ x) 178 | splitBindRight {x = x} = splitJoinRight (sing [ x ]) 179 | {-# COMPILE AGDA2HS splitBindRight #-} 180 | 181 | {- 182 | The following statement is FALSE: 183 | ⋈-unique-left : α₁ ⋈ β ≡ γ → α₂ ⋈ β ≡ γ → α₁ ≡ α₂ 184 | 185 | Counterexample: 186 | 187 | left left right right done : 1 2 ⋈ 1 2 ≡ 1 2 1 2 188 | right left left right done : 2 1 ⋈ 1 2 ≡ 1 2 1 2 189 | 190 | -} 191 | 192 | opaque 193 | unfolding Split 194 | 195 | decSplit : (p q : α ⋈ β ≡ γ) → Dec (p ≡ q) 196 | decSplit (EmptyL ) (EmptyL ) = True ⟨ refl ⟩ 197 | decSplit (EmptyR ) (EmptyR ) = True ⟨ refl ⟩ 198 | decSplit (ConsL x p) (ConsL x q) = mapDec (cong (ConsL x)) (λ where refl → refl) (decSplit p q) 199 | decSplit (ConsR x p) (ConsR x q) = mapDec (cong (ConsR x)) (λ where refl → refl) (decSplit p q) 200 | decSplit (EmptyL ) (EmptyR ) = False ⟨ (λ ()) ⟩ 201 | decSplit (EmptyL ) (ConsR y q) = False ⟨ (λ ()) ⟩ 202 | decSplit (EmptyR ) (EmptyL ) = False ⟨ (λ ()) ⟩ 203 | decSplit (EmptyR ) (ConsL x q) = False ⟨ (λ ()) ⟩ 204 | decSplit (ConsL x p) (EmptyR ) = False ⟨ (λ ()) ⟩ 205 | decSplit (ConsL x p) (ConsR x q) = False ⟨ (λ ()) ⟩ 206 | decSplit (ConsR x p) (EmptyL ) = False ⟨ (λ ()) ⟩ 207 | decSplit (ConsR x p) (ConsL x q) = False ⟨ (λ ()) ⟩ 208 | {-# COMPILE AGDA2HS decSplit #-} 209 | 210 | syntax decSplit p q = p ⋈-≟ q 211 | 212 | @0 ∅-⋈-injective : mempty ⋈ α ≡ β → α ≡ β 213 | ∅-⋈-injective EmptyL = refl 214 | ∅-⋈-injective EmptyR = refl 215 | ∅-⋈-injective (ConsR x p) rewrite ∅-⋈-injective p = refl 216 | 217 | opaque 218 | unfolding Split splitRefl singSplit splitJoin splitBindLeft decSplit 219 | SplitThings : Set₁ 220 | SplitThings = Set 221 | -------------------------------------------------------------------------------- /src/Scope/Core.agda: -------------------------------------------------------------------------------- 1 | 2 | module Scope.Core where 3 | 4 | open import Haskell.Prelude hiding (All; _∘_) 5 | 6 | open import Haskell.Law.Semigroup.Def using (IsLawfulSemigroup; associativity) 7 | open import Haskell.Law.Monoid.Def using (IsLawfulMonoid; rightIdentity; leftIdentity; concatenation) 8 | open import Haskell.Extra.Erase 9 | 10 | open import Utils.Tactics 11 | import Utils.List as List 12 | 13 | private variable 14 | @0 name : Set 15 | 16 | --------------------------------------------------------------------------------------------------- 17 | {- PART ONE : Scope -} 18 | --------------------------------------------------------------------------------------------------- 19 | module DefScope where 20 | open import Haskell.Law.List 21 | 22 | opaque 23 | Scope : (@0 name : Set) → Set 24 | Scope name = List (Erase name) 25 | {-# COMPILE AGDA2HS Scope #-} 26 | 27 | singleton : @0 name → Scope name 28 | singleton x = Erased x ∷ [] 29 | {-# COMPILE AGDA2HS singleton #-} 30 | 31 | syntax singleton x = [ x ] 32 | 33 | instance 34 | iSemigroupScope : Semigroup (Scope name) 35 | iSemigroupScope ._<>_ α β = β ++ α 36 | 37 | private 38 | -- we do this to get a transparent super field in the monoid instance 39 | scopeMempty : Scope name 40 | scopeMempty = mempty 41 | 42 | scopeMappend : Scope name → Scope name → Scope name 43 | scopeMappend α β = mappend β α 44 | 45 | scopeMConcat : List (Scope name) → Scope name 46 | scopeMConcat [] = mempty 47 | scopeMConcat (x ∷ xs) = (scopeMConcat xs) ++ x 48 | 49 | instance 50 | iMonoidScope : Monoid (Scope name) 51 | Monoid.super iMonoidScope = iSemigroupScope 52 | Monoid.mempty iMonoidScope = scopeMempty 53 | Monoid.mappend iMonoidScope = scopeMappend 54 | Monoid.mconcat iMonoidScope = scopeMConcat 55 | 56 | opaque 57 | unfolding Scope 58 | instance 59 | iLawfulSemigroupScope : IsLawfulSemigroup (Scope name) 60 | iLawfulSemigroupScope .associativity _ _ [] = refl 61 | iLawfulSemigroupScope .associativity xs ys (z ∷ zs) 62 | rewrite (++-assoc zs ys xs) 63 | = refl 64 | 65 | iLawfulMonoidScope : IsLawfulMonoid (Scope name) 66 | iLawfulMonoidScope .rightIdentity [] = refl 67 | iLawfulMonoidScope .rightIdentity (x ∷ xs) = refl 68 | 69 | iLawfulMonoidScope .leftIdentity [] = refl 70 | iLawfulMonoidScope .leftIdentity (x ∷ xs) 71 | rewrite ++-[] (x ∷ xs) 72 | = refl 73 | 74 | iLawfulMonoidScope .concatenation [] = refl 75 | iLawfulMonoidScope .concatenation (x ∷ xs) 76 | rewrite concatenation ⦃ iMonoidA = iMonoidScope ⦄ xs 77 | = refl 78 | 79 | bind : Scope name → @0 name → Scope name 80 | bind α x = α <> [ x ] 81 | {-# COMPILE AGDA2HS bind #-} 82 | 83 | infixl 5 bind 84 | syntax bind α x = α ▸ x 85 | 86 | {- end of module DefScope -} 87 | open DefScope public 88 | 89 | --------------------------------------------------------------------------------------------------- 90 | {- PART TWO : RScope -} 91 | --------------------------------------------------------------------------------------------------- 92 | module DefRScope where 93 | open import Haskell.Law.Monoid.List using (iLawfulMonoidList) 94 | open import Haskell.Law.Semigroup.List using (iLawfulSemigroupList) 95 | 96 | opaque 97 | RScope : (@0 name : Set) → Set 98 | RScope name = List (Erase name) 99 | {-# COMPILE AGDA2HS RScope #-} 100 | 101 | rsingleton : @0 name → RScope name 102 | rsingleton x = Erased x ∷ [] 103 | {-# COMPILE AGDA2HS rsingleton #-} 104 | 105 | syntax rsingleton x = x ◂ 106 | 107 | instance 108 | iSemigroupRScope : Semigroup (RScope name) 109 | iSemigroupRScope ._<>_ = _++_ 110 | 111 | private 112 | -- we do this to get a transparent super field in the monoid instance 113 | rscopeMempty : RScope name 114 | rscopeMempty = mempty 115 | 116 | rscopeMappend : RScope name → RScope name → RScope name 117 | rscopeMappend = mappend 118 | 119 | rscopeMConcat : List (RScope name) → RScope name 120 | rscopeMConcat = mconcat 121 | 122 | instance 123 | iMonoidRScope : Monoid (RScope name) 124 | Monoid.super iMonoidRScope = iSemigroupRScope 125 | Monoid.mempty iMonoidRScope = rscopeMempty 126 | Monoid.mappend iMonoidRScope = rscopeMappend 127 | Monoid.mconcat iMonoidRScope = rscopeMConcat 128 | 129 | opaque 130 | unfolding RScope 131 | instance 132 | iLawfulSemigroupRScope : IsLawfulSemigroup (RScope name) 133 | iLawfulSemigroupRScope = iLawfulSemigroupList 134 | 135 | iLawfulMonoidRScope : IsLawfulMonoid (RScope name) 136 | iLawfulMonoidRScope = iLawfulMonoidList 137 | 138 | rbind : @0 name → RScope name → RScope name 139 | rbind x α = x ◂ <> α 140 | {-# COMPILE AGDA2HS rbind #-} 141 | 142 | infixr 5 rbind 143 | syntax rbind x α = x ◂ α 144 | 145 | {- end of module DefRScope -} 146 | open DefRScope public 147 | 148 | --------------------------------------------------------------------------------------------------- 149 | {- PART THREE : Combinations -} 150 | --------------------------------------------------------------------------------------------------- 151 | module Combinations where 152 | open import Haskell.Law.Equality 153 | 154 | opaque 155 | unfolding RScope 156 | 157 | extScope : Scope name → RScope name → Scope name 158 | extScope s [] = s 159 | extScope α (Erased x ∷ rs) = extScope (α ▸ x) rs 160 | {-# COMPILE AGDA2HS extScope #-} 161 | 162 | extScopeEmpty : {α : Scope name} → (extScope α mempty) ≡ α 163 | extScopeEmpty = refl 164 | 165 | extScopeBind : {α : Scope name} {y : name} {rγ : RScope name} → extScope α (y ◂ rγ) ≡ extScope (α ▸ y) rγ 166 | extScopeBind = refl 167 | 168 | @0 extScopeConcatBind : (@0 α : Scope name) (@0 y : name) (@0 rγ : RScope name) → (extScope (α ▸ y) rγ) ≡ α <> (extScope [ y ] rγ) 169 | extScopeConcatBind α y [] = refl 170 | extScopeConcatBind α y (Erased z ∷ rγ) = 171 | let e₀ : (extScope (α ▸ y) (z ◂ rγ)) ≡ (α ▸ y) <> (extScope [ z ] rγ) 172 | e₀ = extScopeConcatBind (α ▸ y) z rγ 173 | e₁ : (α <> [ y ]) <> (extScope [ z ] rγ) ≡ α <> ([ y ] <> (extScope [ z ] rγ)) 174 | e₁ = sym (associativity α [ y ] (extScope [ z ] rγ)) 175 | e₂ : (extScope ([ y ] ▸ z) rγ) ≡ [ y ] <> (extScope [ z ] rγ) 176 | e₂ = extScopeConcatBind [ y ] z rγ 177 | in 178 | trans (trans e₀ e₁) (sym (cong (λ δ → α <> δ) e₂)) 179 | 180 | opaque 181 | unfolding Scope extScope 182 | @0 extScopeConcatEmpty : (@0 α : Scope name) (@0 rγ : RScope name) → (extScope α rγ) ≡ α <> (extScope mempty rγ) 183 | extScopeConcatEmpty α [] = refl 184 | extScopeConcatEmpty α (Erased z ∷ rγ) = extScopeConcatBind α z rγ 185 | 186 | @0 extScopeConcat : (@0 α β : Scope name) (@0 rγ : RScope name) → (extScope (α <> β) rγ) ≡ α <> (extScope β rγ) 187 | extScopeConcat α [] rγ = 188 | extScopeConcatEmpty α rγ 189 | extScopeConcat α (Erased y ∷ β) rγ = 190 | extScopeConcat α β (y ◂ rγ) 191 | 192 | opaque 193 | unfolding extScope 194 | singExtScope : {@0 α : Scope name} {@0 rβ : RScope name} 195 | → Singleton α → Singleton rβ → Singleton (extScope α rβ) 196 | singExtScope αRun (sing []) = αRun 197 | singExtScope (sing α) (sing (Erased x ∷ rβ)) = singExtScope (sing (α ▸ x)) (sing rβ) 198 | {-# COMPILE AGDA2HS singExtScope #-} 199 | 200 | {- end of module Combinations -} 201 | open Combinations public 202 | 203 | 204 | opaque 205 | unfolding Scope 206 | 207 | caseScope : (α : Scope name) 208 | → (@0 {{α ≡ mempty}} → c) 209 | → ((@0 x : name) (β : Scope name) → @0 {{α ≡ β ▸ x}} → c) 210 | → c 211 | caseScope [] emptyCase bindCase = emptyCase 212 | caseScope (Erased x ∷ β) emptyCase bindCase = bindCase x β 213 | {-# COMPILE AGDA2HS caseScope #-} 214 | 215 | opaque 216 | unfolding RScope 217 | 218 | caseRScope : (rα : RScope name) 219 | → (@0 {{rα ≡ mempty}} → c) 220 | → ((@0 x : name) (rβ : RScope name) → @0 {{rα ≡ x ◂ rβ}} → c) 221 | → c 222 | caseRScope [] emptyCase bindCase = emptyCase 223 | caseRScope (Erased x ∷ β) emptyCase bindCase = bindCase x β 224 | {-# COMPILE AGDA2HS caseRScope #-} 225 | 226 | opaque 227 | unfolding Scope 228 | singBind 229 | : {@0 α : Scope name} {@0 x : name} 230 | → Singleton α → Singleton (bind α x) 231 | singBind s = singCong2 _∷_ singErase s 232 | {-# COMPILE AGDA2HS singBind #-} 233 | 234 | singUnbind : {@0 x : name} {@0 α : Scope name} → Singleton (α ▸ x) → Singleton α 235 | singUnbind s = singTail s 236 | {-# COMPILE AGDA2HS singUnbind #-} 237 | 238 | opaque 239 | unfolding Scope iLawfulMonoidScope RScope iLawfulMonoidRScope extScope extScopeConcatEmpty singExtScope caseScope caseRScope singBind 240 | ScopeCoreThings : Set₁ 241 | ScopeCoreThings = Set 242 | --------------------------------------------------------------------------------