├── .github └── workflows │ └── ci-ubuntu.yml ├── .gitignore ├── CONTRIBUTORS ├── COPYRIGHT ├── INSTALL.md ├── LICENSE ├── Makefile ├── README.md ├── annotate.sh ├── artefact ├── .gitignore ├── Makefile ├── README.md ├── scripts │ └── load-code.sh └── velo.json ├── emacs ├── emacs ├── temp.el ├── velo-flycheck.el └── velo.el ├── paper └── 2023-EVCS │ ├── .gitignore │ ├── Code │ ├── MiniCompact.tex │ ├── MiniDeBruijn.tex │ ├── MiniExecute.tex │ └── MiniVelo.tex │ ├── Makefile │ ├── cc-by.pdf │ ├── content │ ├── compactconstant.tex │ ├── conclusion.tex │ ├── cse.tex │ ├── deBruijn.tex │ ├── efficientdeceq.tex │ ├── execution.tex │ ├── introduction.tex │ ├── lang-design.tex │ ├── positivelynegative.tex │ ├── velo-intro.tex │ └── well-typed-holes.tex │ ├── cover-letter.tex │ ├── figure │ ├── ast.tex │ ├── dynamics-smallstep.tex │ ├── statics.tex │ └── syntax.tex │ ├── idris2.sty │ ├── jfdm-plt.sty │ ├── notations.tex │ ├── oasics-logo-bw.pdf │ ├── oasics-v2021.cls │ ├── orcid.pdf │ ├── paper.bib │ ├── paper.tex │ ├── preamble.tex │ ├── robust-catch.tex │ └── velo.sty ├── presentation ├── .gitignore ├── Makefile ├── biblio.bib ├── colour-blind.sty ├── figure │ ├── .gitkeep │ ├── edwin.jpg │ ├── idris.pdf │ ├── master.jpg │ ├── novice.jpg │ ├── spoofax.png │ └── visser.jpg ├── gla-colours.sty ├── gla-tikz.sty ├── image │ ├── gla.pdf │ └── sta.pdf ├── presentation.slides.tex └── slidedeck.cls ├── src ├── Main.idr ├── PoC │ ├── CSE.idr │ └── Holes.idr ├── Toolkit │ ├── AST.idr │ ├── CoDeBruijn.idr │ ├── CoDeBruijn │ │ ├── Binding.idr │ │ └── Variable.idr │ ├── Commands.idr │ ├── Data │ │ ├── Comparison │ │ │ └── Informative.idr │ │ ├── DList.idr │ │ ├── DList │ │ │ ├── Any.idr │ │ │ ├── AtIndex.idr │ │ │ ├── Elem.idr │ │ │ └── Interleaving.idr │ │ ├── DVect.idr │ │ ├── DVect │ │ │ └── Elem.idr │ │ ├── Fin.idr │ │ ├── Graph │ │ │ ├── EdgeBounded.idr │ │ │ └── EdgeBounded │ │ │ │ ├── DegreeCommon.idr │ │ │ │ ├── HasExactDegree.idr │ │ │ │ └── HasExactDegree │ │ │ │ └── All.idr │ │ ├── List │ │ │ ├── AtIndex.idr │ │ │ ├── DeBruijn.idr │ │ │ ├── Filter.idr │ │ │ ├── Interleaving.idr │ │ │ ├── Member.idr │ │ │ ├── Occurs.idr │ │ │ ├── Occurs │ │ │ │ ├── Does.idr │ │ │ │ ├── Does │ │ │ │ │ └── Not.idr │ │ │ │ └── Error.idr │ │ │ ├── Pointwise.idr │ │ │ ├── Quantifiers.idr │ │ │ ├── Size.idr │ │ │ ├── Subset.idr │ │ │ ├── Thinning.idr │ │ │ └── View │ │ │ │ └── PairWise.idr │ │ ├── Location.idr │ │ ├── Nat.idr │ │ ├── Pair.idr │ │ ├── Relation.idr │ │ ├── Relation │ │ │ └── List.idr │ │ ├── Rig.idr │ │ ├── SnocList │ │ │ ├── AtIndex.idr │ │ │ ├── Quantifiers.idr │ │ │ ├── Subset.idr │ │ │ └── Thinning.idr │ │ ├── Spaces.idr │ │ ├── Vect │ │ │ ├── Extra.idr │ │ │ ├── Leanings.idr │ │ │ └── Quantifiers.idr │ │ └── Whole.idr │ ├── DeBruijn │ │ ├── Context.idr │ │ ├── Environment.idr │ │ ├── Evaluation.idr │ │ ├── Progress.idr │ │ ├── Renaming.idr │ │ ├── Substitution.idr │ │ └── Variable.idr │ ├── Decidable │ │ ├── Do.idr │ │ ├── Equality │ │ │ ├── Indexed.idr │ │ │ └── Views.idr │ │ └── Informative.idr │ ├── Item.idr │ ├── Logging │ │ └── Simple.idr │ ├── Options │ │ ├── ArgParse.idr │ │ └── ArgParse │ │ │ ├── Error.idr │ │ │ ├── Lexer.idr │ │ │ ├── Model.idr │ │ │ ├── Parser.idr │ │ │ ├── Parser │ │ │ └── API.idr │ │ │ └── Test.idr │ ├── System.idr │ ├── Text │ │ ├── Lexer │ │ │ └── Run.idr │ │ └── Parser │ │ │ ├── Location.idr │ │ │ ├── Run.idr │ │ │ └── Support.idr │ ├── TheRug.idr │ └── TheRug │ │ └── Logging │ │ └── Simple.idr └── Velo │ ├── Commands.idr │ ├── Core.idr │ ├── Elaborator.idr │ ├── Elaborator │ ├── CoDeBruijn.idr │ ├── Common.idr │ ├── Holey.idr │ ├── Instantiate.idr │ └── Term.idr │ ├── Error.idr │ ├── Error │ └── Pretty.idr │ ├── Eval.idr │ ├── IR │ ├── AST.idr │ ├── CoTerm.idr │ ├── Common.idr │ ├── Holey.idr │ └── Term.idr │ ├── Lexer.idr │ ├── Lexer │ └── Token.idr │ ├── Options.idr │ ├── Parser.idr │ ├── Parser │ └── API.idr │ ├── Pass │ ├── CSE.idr │ └── Folding.idr │ ├── Pipeline.idr │ ├── REPL.idr │ ├── Semantics │ ├── Progress.idr │ └── Reductions.idr │ ├── Trace.idr │ ├── Types.idr │ ├── Unelaboration.idr │ └── Values.idr ├── tests ├── .gitignore ├── Main.idr ├── Makefile ├── testing.ipkg └── working │ ├── 000-bonjour │ ├── expected │ ├── main.velo │ └── run │ ├── 001-cse │ ├── expected │ ├── main.velo │ └── run │ ├── 002-holes │ ├── expected │ ├── main.velo │ └── run │ ├── 003-shadowing │ ├── expected │ ├── main.velo │ └── run │ ├── 004-repl │ ├── expected │ ├── input │ ├── main.velo │ └── run │ ├── 005-cse │ ├── expected │ ├── input │ ├── main.velo │ └── run │ ├── 006-instantiate │ ├── expected │ ├── input │ ├── main.velo │ └── run │ └── 007-paper-intro │ ├── expected │ ├── input │ ├── main.velo │ └── run └── velo.ipkg /.gitignore: -------------------------------------------------------------------------------- 1 | artefact/code.tar.gz 2 | build/ 3 | __build/ 4 | *.ibc 5 | a.output 6 | picoverilog 7 | # For convenience 8 | custom.mk 9 | \#* 10 | .\#* 11 | tags 12 | TAGS 13 | 14 | tests/**/output 15 | 16 | # IDE and editors 17 | *.swp 18 | *~ 19 | .DS_Store 20 | .hpc 21 | *.orig 22 | *.tix 23 | *.dSYM 24 | .projectile 25 | .dir-locals.el 26 | .vscode 27 | .idea 28 | 29 | docs/build/ 30 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | We thank the following people for their help & contributions to this project. 2 | 3 | + Jan de Muijnck-Hughes 4 | + Guillaume Allais 5 | + Edwin Brady 6 | -------------------------------------------------------------------------------- /COPYRIGHT: -------------------------------------------------------------------------------- 1 | (c) Contributors 2 | -------------------------------------------------------------------------------- /INSTALL.md: -------------------------------------------------------------------------------- 1 | # Building, Installing, and Playing 2 | 3 | ## Building 4 | 5 | To build and use Velo you must first install [Idris 2](https://github.com/idris-lang/Idris2) 6 | 7 | Once Idris2 has been installed you can build the project with: 8 | 9 | ```bash 10 | make velo 11 | ``` 12 | 13 | ## Testing 14 | 15 | The test suite can be ran using: 16 | 17 | ```bash 18 | make velo-test-run 19 | ``` 20 | 21 | ## Installing 22 | 23 | We have yet to add installation scripts or turn this into a serious tool to play with. 24 | This might come later. 25 | 26 | That being said, you can copy the binary from `build/exec` to a well known location under `PATH` and you should be able to use it from there. 27 | 28 | ## Playing 29 | 30 | Velo is a very simple language with a simple UX. 31 | We do not provide anything fancy as our interest at the moment is in the tool itself and not necessarily its use by others. 32 | 33 | There are examples in the directory called `tests`. 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Clear BSD License 2 | 3 | Copyright (c) 2022+ see CONTRIBUTORS 4 | 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted (subject to the limitations in the disclaimer 9 | below) provided that the following conditions are met: 10 | 11 | * Redistributions of source code must retain the above copyright notice, 12 | this list of conditions and the following disclaimer. 13 | 14 | * Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | * Neither the name of the copyright holder nor the names of its 19 | contributors may be used to endorse or promote products derived from this 20 | software without specific prior written permission. 21 | 22 | NO EXPRESS OR IMPLIED LICENSES TO ANY PARTY'S PATENT RIGHTS ARE GRANTED BY 23 | THIS LICENSE. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 26 | PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 27 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 28 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 29 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 30 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 31 | IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 32 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33 | POSSIBILITY OF SUCH DAMAGE. 34 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Copyright : see COPRRIGHT 3 | # License : see LICENSE 4 | # 5 | 6 | PROJECT=velo 7 | IDRIS2=idris2 8 | 9 | BUILDDIR = ${CURDIR}/build 10 | TARGETDIR = ${BUILDDIR}/exec 11 | TARGET = ${TARGETDIR}/${PROJECT} 12 | 13 | # [ Core Project Definition ] 14 | 15 | .PHONY: ${PROJECT} doc ${PROJECT}-test-build ${PROJECT}-test-run ${PROJECT}-test-run-re ${PROJECT}-test-update \ 16 | # ${PROJECT}-bench 17 | 18 | velo: 19 | $(IDRIS2) --build ${PROJECT}.ipkg 20 | 21 | doc: 22 | $(IDRIS2) --mkdoc ${PROJECT}.ipkg 23 | 24 | # To be activated once frontend is completed. 25 | 26 | ${PROJECT}-test-build: 27 | ${MAKE} -C tests testbin IDRIS2=$(IDRIS2) 28 | 29 | ${PROJECT}-test-run: ${PROJECT}-test-build 30 | ${MAKE} -C tests test \ 31 | IDRIS2=$(IDRIS2) \ 32 | PROG_BIN=$(TARGET) \ 33 | UPDATE='' \ 34 | ONLY=$(ONLY) 35 | 36 | ${PROJECT}-test-run-re: ${PROJECT}-test-build 37 | ${MAKE} -C tests test-re \ 38 | IDRIS2=$(IDRIS2) \ 39 | PROG_BIN=$(TARGET) \ 40 | ONLY=$(ONLY) 41 | 42 | ${PROJECT}-test-update: ${PROJECT}-test-build 43 | ${MAKE} -C tests test \ 44 | IDRIS2=$(IDRIS2) \ 45 | PROG_BIN=$(TARGET) \ 46 | THREADS=1 \ 47 | ONLY=$(ONLY) 48 | 49 | ${PROJECT}-bench: ${PROJECT} ${PROJECT}-test-build 50 | ${ECHO} "Todo" 51 | 52 | # $(HYPERFINE) --warmup 10 '${MAKE} ${PROJECT}-test-run' 53 | 54 | # [ Artefact ] 55 | 56 | .PHONY: artefact 57 | 58 | artefact: clobber velo doc 59 | 60 | # The Source Code Archive 61 | git archive \ 62 | --prefix=velo/ \ 63 | --format=tar.gz \ 64 | HEAD \ 65 | > artefact/velo.tar.gz 66 | 67 | # Generate annotated sources 68 | bash annotate.sh 69 | tar -zcvf artefact/velo_html.tar.gz -C ${BUILDDIR} html 70 | 71 | # Generate IdrisDoc 72 | tar -zcvf artefact/velo_doc.tar.gz -C ${BUILDDIR} docs 73 | 74 | # The Paper itself 75 | ${MAKE} -C paper/2023-EVCS paper.pdf 76 | cp paper/2023-EVCS/__build/paper.pdf artefact/velo.pdf 77 | 78 | # The Artefact 79 | ${MAKE} -C artefact artefact 80 | 81 | # [ Housekeeping ] 82 | 83 | .PHONY: clobber clean 84 | 85 | clean: 86 | $(IDRIS2) --clean ${PROJECT}.ipkg 87 | ${MAKE} -C tests clean 88 | rm -rf build/ 89 | 90 | clobber: clean 91 | $(IDRIS2) --clean ${PROJECT}.ipkg 92 | ${MAKE} -C tests clobber 93 | ${RM} -rf build/ 94 | ${RM} artefact/*.tar.gz 95 | 96 | # -- [ EOF ] 97 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Velo. 2 | 3 | [![Build Status](https://github.com/jfdm/velo-lang/actions/workflows/ci-ubuntu.yml/badge.svg)](https://github.com/jfdm/velo-lang/actions/workflows/ci-ubuntu.yml) 4 | 5 | A tiny language to explore efficient verified implementations of functional languages in Idris2. 6 | 7 | ## Artefact 8 | 9 | We also include scripts to generate a reproducible artefact. 10 | 11 | Please consult the following project to generate the base virtual box image required, and how we approach the building of the artefact. 12 | 13 | https://github.com/jfdm/packer-idris 14 | 15 | You will also need to have working installations of [Katla](https://github.com/idris-community/katla) to facilitate source code highlighting. 16 | 17 | Once you have generated the image you can generate the artefact as follows: 18 | 19 | ```bash 20 | SOURCE_VM="" make artefact 21 | ``` 22 | 23 | This will generate in `artefact` the following files: 24 | 25 | 1. `velo.box` :: A Virtual Box virtual machine that contains Velo's source code & test suite; 26 | 2. `velo.tar.gz` :: A copy of Velo's source code, and generated IdrisDoc; 27 | 3. `velo_doc.tar.gz` :: A copy of the IdrisDoc for the coding project; 28 | 4. `velo_html.tar.gz` :: A copy of the katla generated html showing semantically highlighted code; 29 | 4. `velo.pdf` :: A copy of the submitted paper; 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /annotate.sh: -------------------------------------------------------------------------------- 1 | #!/bin/env bash 2 | 3 | test ! -z $1 && set -x # Show commands if first arg is non-zero 4 | 5 | mkdir -p build/html 6 | 7 | katla_run() 8 | { 9 | KATLA_EXE=$(which katla) 10 | test -x KATLA_EXE && echo "Katla not installed" 11 | test -z $2 && echo "missing ttm" 12 | FOUT=$4 13 | DOUT=${FOUT%/*} # equiv to dirname 14 | mkdir -p "$DOUT" 15 | echo "Generating $4" 16 | $KATLA_EXE "$1" "$2" "$3" > "$4" 17 | } 18 | 19 | find src -type f -iname "*.idr" -print0 |\ 20 | while IFS= read -r -d '' file; do 21 | FILE_LOCAL=${file#src/} # remove prefix 22 | FILE_ttm=${FILE_LOCAL%idr}ttm 23 | FILE_html=${FILE_LOCAL%idr}html 24 | katla_run html "./${file}" ./build/ttc/*/"${FILE_ttm}" "./build/html/${FILE_html}" 25 | done 26 | 27 | # -- [ EOF ] 28 | -------------------------------------------------------------------------------- /artefact/.gitignore: -------------------------------------------------------------------------------- 1 | output-virtualbox-ovf 2 | output 3 | velo.pdf 4 | *.tar.gz 5 | -------------------------------------------------------------------------------- /artefact/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: artefact 2 | 3 | artefact: 4 | packer build -force velo.json 5 | 6 | 7 | # -- [ EOF ] 8 | -------------------------------------------------------------------------------- /artefact/scripts/load-code.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -eux 2 | 3 | cat >>$HOME/.bashrc <<'EOF' 4 | export PATH=$HOME/.nix-profile/bin:$PATH 5 | EOF 6 | source $HOME/.bashrc 7 | 8 | 9 | echo "## Checking installation" 10 | 11 | which idris2 12 | idris2 --prefix 13 | idris2 --paths 14 | idris2 --libdir 15 | 16 | echo "## Installing Artifact" 17 | 18 | cd /tmp/ 19 | tar -zxvf /tmp/velo.tar.gz 20 | 21 | cd "$HOME" 22 | mv /tmp/velo "$HOME/velo" 23 | 24 | echo "## Testing Artifact" 25 | 26 | cd "velo" 27 | 28 | make velo 29 | make velo-test-run 30 | 31 | cd "$HOME" 32 | 33 | echo "## Finished" 34 | -------------------------------------------------------------------------------- /artefact/velo.json: -------------------------------------------------------------------------------- 1 | { 2 | "variables": { 3 | "source_vm": "{{env `SOURCE_VM`}}" 4 | }, 5 | 6 | "builders": [ 7 | { 8 | "headless": true, 9 | "shutdown_command": "echo 'idris-playground' | sudo -S poweroff", 10 | "source_path": "{{user `source_vm`}}", 11 | "ssh_password": "idris-playground", 12 | "ssh_username": "idris-playground", 13 | "type": "virtualbox-ovf" 14 | } 15 | ], 16 | "post-processors": [ 17 | { 18 | "compression_level": "8", 19 | "keep_input_artifact": true, 20 | "output": "output/velo.box", 21 | "type": "vagrant" 22 | } 23 | ], 24 | "provisioners": [ 25 | { 26 | "destination": "/tmp/velo.tar.gz", 27 | "source": "velo.tar.gz", 28 | "type": "file" 29 | }, 30 | { 31 | "execute_command": "{{.Vars}} bash '{{.Path}}'", 32 | "expect_disconnect": true, 33 | "script": "scripts/load-code.sh", 34 | "start_retry_timeout": "30m", 35 | "type": "shell" 36 | } 37 | ] 38 | } 39 | -------------------------------------------------------------------------------- /emacs/emacs: -------------------------------------------------------------------------------- 1 | ;; this should be inserted in your .emacs 2 | ;; be careful to replace PATH/TO/ with the path... 3 | 4 | (use-package velo 5 | :load-path "PATH/TO/DIR" ;; for velo.el 6 | :mode 7 | ("\\.velo\\'" . velo-mode) 8 | :config 9 | (setq velo-command "PATH/TO/EXEC" ;; for velo 10 | velo-options "" 11 | ) 12 | ) 13 | (use-package velo-flycheck 14 | :load-path "PATH/TO/DIR" ;; for velo-flycheck 15 | (setq flycheck-velo-check-executable velo-command) 16 | ) 17 | 18 | ;; EOF 19 | -------------------------------------------------------------------------------- /emacs/temp.el: -------------------------------------------------------------------------------- 1 | (load "$HOME/project/velo/velo-lang/emacs/velo.el") 2 | (load "$HOME/project/velo/velo-lang/emacs/velo-flycheck.el") 3 | (require 'velo) 4 | (require 'velo-flycheck) 5 | 6 | (flycheck-parse-error-with-patterns 7 | "poo.velo:13:1-2:[ ERROR ]\nsksksk" 8 | (flycheck-checker-get 'velo-check 'error-patterns) 9 | 'velo-check) 10 | -------------------------------------------------------------------------------- /emacs/velo-flycheck.el: -------------------------------------------------------------------------------- 1 | ;;; package --- Summary 2 | 3 | ;;; Commentary: 4 | 5 | ;;; Code: 6 | 7 | ;; define several class of keywords 8 | 9 | (require 'velo) 10 | (require 'flycheck) 11 | 12 | (flycheck-def-executable-var 13 | flycheck-velo 14 | velo-command 15 | ) 16 | 17 | ;; TODO 18 | ;;(flycheck-def-option-var 19 | ;; flycheck-velo-opts 20 | ;; '(velo-options) 21 | ;; velo 22 | ;; "Options") 23 | 24 | (flycheck-define-checker velo 25 | "A linter for Velo" 26 | :command ("velo" "--checkOnly" 27 | (source ".velo")) 28 | :error-patterns 29 | ((error line-start 30 | (file-name) ":" line ":" column "-" end-column ":\n" 31 | (message (and (* nonl) (* "\n" (* nonl)))) 32 | ) 33 | ) 34 | 35 | :modes velo-mode 36 | ) 37 | (add-to-list 'flycheck-checkers 'velo) 38 | 39 | (provide 'velo-flycheck) 40 | ;;; velo-flycheck.el ends here 41 | 42 | ;;;(flycheck-parse-error-with-patterns 43 | ;;; "test.velo:13:1-2:\nsksksk" 44 | ;;; (flycheck-checker-get 'velo 'error-patterns) 45 | ;;; 'velo-check) 46 | -------------------------------------------------------------------------------- /paper/2023-EVCS/.gitignore: -------------------------------------------------------------------------------- 1 | *.idr.tex 2 | cover-letter.pdf 3 | paper.*.synctex.gz 4 | paper.pdf 5 | paper.*.pdf 6 | *draft.pdf 7 | *blind.*.pdf 8 | *camera.pdf 9 | *preprint.pdf 10 | *submission.pdf 11 | *.fdb_latexmk 12 | *.fls 13 | *.acn 14 | *.ist 15 | *.upa 16 | *.upb 17 | auto/ 18 | sample-*.pdf 19 | *.log 20 | *.aux 21 | *.cfg 22 | *.glo 23 | *.idx 24 | *.toc 25 | *.ilg 26 | *.ind 27 | *.out 28 | *.lof 29 | *.lot 30 | *.bbl 31 | *.blg 32 | *.gls 33 | *.cut 34 | *.hd 35 | *.dvi 36 | *.ps 37 | *.thm 38 | *.tgz 39 | *.zip 40 | *.rpi 41 | *.vtc 42 | *~ 43 | *.bcf 44 | *.run.xml 45 | *.loc 46 | *.soc 47 | -------------------------------------------------------------------------------- /paper/2023-EVCS/Code/MiniCompact.tex: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | module Code.MiniCompact 3 | 4 | import Code.MiniVelo 5 | import Code.MiniDeBruijn 6 | 7 | public export 8 | \end{code} 9 | 10 | 11 | %<*PrimDef> 12 | \begin{code} 13 | data Prim : (args : List Ty) -> (ret : Ty) -> Type where 14 | Zero : Prim [] TyNat 15 | Inc : Prim [TyNat] TyNat 16 | App : Prim [TyArr dom cod, dom] cod 17 | \end{code} 18 | % 19 | 20 | \begin{code} 21 | public export 22 | data Terms : (ctxt : SnocList Ty) -> List Ty -> Type 23 | \end{code} 24 | 25 | 26 | \begin{code} 27 | public export 28 | \end{code} 29 | %<*TermDef> 30 | \begin{code} 31 | data Term : (ctxt : SnocList Ty) -> Ty -> Type where 32 | Var : IsVar ctxt ty -> Term ctxt ty 33 | Fun : Term (ctxt :< a) b -> Term ctxt (TyArr a b) 34 | Call : {tys : _} -> (operator : Prim tys ty) 35 | -> (operands : Terms ctxt tys) 36 | -> Term ctxt ty 37 | \end{code} 38 | % 39 | 40 | \begin{code} 41 | public export 42 | \end{code} 43 | %<*AllDef> 44 | \begin{code} 45 | data Terms : (ctxt : SnocList Ty) -> List Ty -> Type where 46 | Nil : Terms ctxt Nil 47 | (::) : Term ctxt ty -> Terms ctxt tys -> Terms ctxt (ty :: tys) 48 | \end{code} 49 | % 50 | -------------------------------------------------------------------------------- /paper/2023-EVCS/Code/MiniDeBruijn.tex: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | module Code.MiniDeBruijn 3 | \end{code} 4 | 5 | %<*AtIndexDef> 6 | \begin{code} 7 | data AtIndex : (ty : kind) -> (ctxt : SnocList kind) -> 8 | (idx : Nat) -> Type where 9 | Here : AtIndex ty (ctxt :< ty) 0 10 | There : AtIndex ty ctxt idx -> AtIndex ty (ctxt :< _) (1 + idx) 11 | \end{code} 12 | % 13 | 14 | \begin{code} 15 | export 16 | \end{code} 17 | %<*IsVarDef> 18 | \begin{code} 19 | data IsVar : (ctxt : SnocList kind) -> (ty : kind) -> Type where 20 | V : (idx : Nat) -> (0 prf : AtIndex ty ctxt idx) -> IsVar ctxt ty 21 | \end{code} 22 | % 23 | -------------------------------------------------------------------------------- /paper/2023-EVCS/Code/MiniExecute.tex: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | module Code.MiniExecute 3 | 4 | import Code.MiniVelo 5 | import Code.MiniCompact 6 | 7 | %hide MiniVelo.Term 8 | 9 | subst : Term ctxt a -> Term (ctxt :< a) b -> Term ctxt b 10 | 11 | data Value : Term ctxt ty -> Type 12 | \end{code} 13 | 14 | \begin{code} 15 | data Reduxes : (these,those : Terms ctxt tys) -> Type where 16 | \end{code} 17 | 18 | %<*ReduxDef> 19 | \begin{code} 20 | data Redux : (this,that : Term ctxt type) -> Type where 21 | SimplifyCall : (op : Prim tys ty) 22 | -> (step : Reduxes these those) 23 | -> Redux (Call p these) (Call p those) 24 | 25 | ReduceFuncApp : {body : Term (ctxt :< type) return} 26 | -> {arg : Term ctxt type} 27 | -> (value : Value arg) 28 | -> Redux (Call App [Fun body, arg]) 29 | (subst arg body) 30 | \end{code} 31 | % 32 | 33 | %<*ReducesDef> 34 | \begin{code} 35 | data Reduxes : (these, those : Terms ctxt tys) -> Type where 36 | (!:) : (hd : Redux this that) 37 | -> (rest : Terms ctxt tys) 38 | -> Reduxes (this :: rest) (that :: rest) 39 | 40 | (::) : (value : Value hd) 41 | -> (tl : Reduxes these those) 42 | -> Reduxes (hd :: these) (hd :: those) 43 | \end{code} 44 | % 45 | 46 | \begin{code} 47 | Pred : Type -> Type 48 | Pred a = a -> Type 49 | 50 | Rel : Type -> Type 51 | Rel a = a -> Pred a 52 | \end{code} 53 | 54 | %<*ProgressDef> 55 | \begin{code} 56 | data Progress : (0 value : Pred a) -> (0 redux : Rel a) -> (tm : a) -> Type 57 | where Done : {0 tm : a} -> (val : value tm) -> Progress value redux tm 58 | 59 | Step : {this, that : a} 60 | -> (step : redux this that) -> Progress value redux this 61 | \end{code} 62 | % 63 | 64 | \begin{code} 65 | data RTList : Rel a -> Rel a where 66 | \end{code} 67 | 68 | %<*ResultDef> 69 | \begin{code} 70 | data Result : (0 value : Pred a) -> (0 redux : Rel a) -> (this : a) -> Type 71 | where R : (that : a) -> (val : value that) 72 | -> (steps : RTList redux this that) -> Result value redux this 73 | \end{code} 74 | % 75 | -------------------------------------------------------------------------------- /paper/2023-EVCS/Code/MiniVelo.tex: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | module Code.MiniVelo 3 | 4 | public export 5 | \end{code} 6 | 7 | %<*TyDef> 8 | \begin{code} 9 | data Ty = TyNat 10 | | TyBool 11 | | TyArr Ty Ty 12 | \end{code} 13 | % 14 | 15 | \begin{code} 16 | %hide Prelude.SnocList 17 | \end{code} 18 | 19 | %<*SnocListDef> 20 | \begin{code} 21 | data SnocList a = Lin 22 | | (:<) (SnocList a) a 23 | \end{code} 24 | % 25 | 26 | %<*ElemTermDecl> 27 | \begin{code} 28 | data Elem : (gamma : SnocList ty) -> (a : ty) -> Type 29 | data Term : (gamma : SnocList Ty) -> (a : Ty) -> Type 30 | \end{code} 31 | % 32 | 33 | %<*ElemDecl> 34 | \begin{code} 35 | data Elem : (gamma : SnocList ty) -> (a : ty) -> Type 36 | \end{code} 37 | % 38 | \begin{code} 39 | where 40 | \end{code} 41 | %<*varZero> 42 | \begin{code} 43 | Here : ---------------------- 44 | Elem (gamma :< ty) ty 45 | \end{code} 46 | % 47 | 48 | \end{code} 49 | %<*varSuc> 50 | \begin{code} 51 | There : Elem gamma ty -> 52 | --------------------- 53 | Elem (gamma :< _) ty 54 | \end{code} 55 | % 56 | 57 | \begin{code} 58 | data Term : (gamma : SnocList Ty) -> (type : Ty) -> Type where 59 | \end{code} 60 | 61 | %<*inferenceZero> 62 | \begin{code} 63 | Zero : ------------------ 64 | Term gamma TyNat 65 | \end{code} 66 | % 67 | 68 | 69 | %<*inferenceVar> 70 | \begin{code} 71 | Var : Elem gamma a -> 72 | -------------- 73 | Term gamma a 74 | \end{code} 75 | % 76 | 77 | 78 | %<*inferenceInc> 79 | \begin{code} 80 | Inc : Term gamma TyNat -> 81 | ------------------ 82 | Term gamma TyNat 83 | \end{code} 84 | % 85 | 86 | 87 | %<*inferenceApp> 88 | \begin{code} 89 | App : Term gamma (TyArr a b) -> 90 | Term gamma a -> 91 | ------------------------ 92 | Term gamma b 93 | \end{code} 94 | % 95 | 96 | 97 | %<*inferenceFunc> 98 | \begin{code} 99 | Func : Term (gamma :< a) b -> 100 | ------------------------ 101 | Term gamma (TyArr a b) 102 | \end{code} 103 | % 104 | 105 | 106 | %<*Plus2Def> 107 | \begin{code} 108 | Plus2 : Term [<] (TyArr TyNat TyNat) 109 | Plus2 = Func (Inc (Inc (Var Here))) 110 | \end{code} 111 | % 112 | 113 | %<*IllScoped> 114 | \begin{code} 115 | failing "Mismatch between: ?gamma :< TyNat and [<]." 116 | 117 | Ouch : Term [<] TyNat 118 | Ouch = Var Here 119 | \end{code} 120 | % 121 | 122 | %<*IllTyped> 123 | \begin{code} 124 | failing "Mismatch between: TyBool and TyNat." 125 | 126 | Ouch : Term [<] (TyArr TyNat TyBool) 127 | Ouch = Func (Var Here) 128 | \end{code} 129 | % 130 | -------------------------------------------------------------------------------- /paper/2023-EVCS/Makefile: -------------------------------------------------------------------------------- 1 | .PRECIOUS: build/ttc/*/%.ttm build/ttc/*/%.ttc Code/%.idr.tex 2 | 3 | CODE:=\ 4 | Code/MiniVelo.tex \ 5 | Code/MiniDeBruijn.tex \ 6 | Code/MiniCompact.tex \ 7 | Code/MiniExecute.tex 8 | 9 | DEPENDS:=\ 10 | cc-by.pdf \ 11 | oasics-logo-bw.pdf \ 12 | oasics-v2021.cls \ 13 | orcid.pdf \ 14 | preamble.tex \ 15 | notations.tex \ 16 | ./content/*.tex \ 17 | ./figure/*.tex \ 18 | $(patsubst %.tex,%.idr.tex,$(CODE)) \ 19 | paper.bib 20 | 21 | all: paper.pdf 22 | 23 | build/ttc/*/%.ttm build/ttc/*/%.ttc: Code/%.tex 24 | idris2 -c $^ 25 | 26 | Code/%.idr.tex: Code/%.tex build/ttc/*/%.ttm build/ttc/*/%.ttc 27 | katla literate Code/$*.tex build/ttc/*/Code/$*.ttm > $@ 28 | 29 | %.pdf : %.tex $(DEPENDS) 30 | mkdir -p __build 31 | echo $(DEPENDS) 32 | latexmk -pdf -bibtex -outdir="__build" $*.tex 33 | ln -sf __build/$*.pdf $*.pdf 34 | 35 | clean: 36 | rm -rf __build/ 37 | rm paper.pdf 38 | -------------------------------------------------------------------------------- /paper/2023-EVCS/cc-by.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/paper/2023-EVCS/cc-by.pdf -------------------------------------------------------------------------------- /paper/2023-EVCS/content/compactconstant.tex: -------------------------------------------------------------------------------- 1 | \subsection{Compact Constant Folding} 2 | \label{sec:design:constants} 3 | 4 | Software Foundations' \emph{Programming Language Foundations} 5 | opens with a constant-folding transformation exercise~\cite[Chapter~1]{Pierce:SF2}. 6 | % 7 | Starting from a small language of expressions (containing natural numbers, variables, addition, subtraction, and multiplication) we are to deploy the semiring properties to simplify expressions. 8 | % 9 | The definition of the simplifying traversal contains much duplicated code due to the way the source language is structured: 10 | % 11 | all the binary operations are separate constructors, whose subterms need to be structurally simplified before we can decide whether a rule applies. 12 | % 13 | The correction proof has just as much duplication because it needs to follow the structure of the call graph of the function it wants to see reduced. 14 | % 15 | The only saving grace here is that Coq's tactics language lets users write scripts that apply to many similar goals thus avoiding duplication in the source file. 16 | 17 | In \Velo{}, we structure our core language's representation in an algebraic 18 | manner so that this duplication is never needed. 19 | % 20 | All builtin operators (from primitive operations on builtin types to function 21 | application itself) are represented using a single \IdrisData{Call} constructor 22 | which takes an operation and a type-indexed list of subterms. 23 | 24 | 25 | \ExecuteMetaData[Code/MiniCompact.idr.tex]{TermDef} 26 | 27 | Here \IdrisType{Terms} is the pointwise lifting of \IdrisType{Term} to lists 28 | of types. In practice we use the generic \IdrisType{All} quantifier, but this 29 | is morally equivalent to the specialised version presented below: 30 | 31 | \ExecuteMetaData[Code/MiniCompact.idr.tex]{AllDef} 32 | 33 | The primitive operations can now be enumerated in a single datatype 34 | \IdrisData{Prim} which lists the primitive operation's arguments and 35 | the associated return type. 36 | 37 | \begin{comment} 38 | \IdrisData{Zero}---which takes no argument and returns a term of type \IdrisData{TyNat}; 39 | % 40 | \IdrisData{Inc}---which takes an argument of type \IdrisData{TyNat} and returns a term 41 | of type \IdrisData{TyNat}; 42 | % 43 | and 44 | % 45 | \IdrisData{App}---which takes a function and an argument that corresponds to the type of the function's domain and returns a term that is the type of the function's co-domain. 46 | \end{comment} 47 | 48 | \ExecuteMetaData[Code/MiniCompact.idr.tex]{PrimDef} 49 | 50 | Using \IdrisType{Prim}, structural operations can now be implemented by handling recursive calls on the subterms of \IdrisData{Call} nodes uniformly before dispatching on the operator to see whether additional simplifications can be deployed. 51 | % 52 | Similarly, all of the duplication in the correction proofs is factored out in a single place where the induction hypotheses can be invoked. 53 | 54 | 55 | %%% Local Variables: 56 | %%% mode: latex 57 | %%% TeX-master: "../paper" 58 | %%% End: 59 | -------------------------------------------------------------------------------- /paper/2023-EVCS/content/efficientdeceq.tex: -------------------------------------------------------------------------------- 1 | \subsection{Efficient Decidable Equality} 2 | \label{sec:idioms:decEq} 3 | 4 | Users do not always have access to a meta-program that supports the deriving of a proof that propositional equality is decidable for their data structures~\cite{DBLP:conf/icfp/ChristiansenB16}. 5 | % 6 | In such cases, the most common strategy is to use nested pattern matching and produce 7 | clauses quadratic in the number of constructors for the specified data structure. 8 | % 9 | Na{\"i}vely one can reduce the number of contradictions to prove using symmetry breaking (\IdrisFunction{negEqSym}), but the number of cases to present is still many. 10 | % 11 | We can, however, reduce the complexity of \IdrisType{DecEq} instance creation from quadratic to linear in the number of constructors. 12 | % 13 | 14 | For example, consider the following standard definition of a binary tree: 15 | 16 | \begin{Verbatim} 17 | data Bin = Leaf | Node Bin Bin 18 | \end{Verbatim} 19 | 20 | \noindent 21 | We first define a diagonal relation (\IdrisType{Diag}) that requires that two terms must have the same top-level constructor. 22 | 23 | \begin{Verbatim} 24 | data Diag : (s, t : Bin) -> Type where 25 | Leaf2 : Diag Leaf Leaf 26 | Node2 : (s, t, u, v : Bin) -> Diag (Node s t) (Node u v) 27 | \end{Verbatim} 28 | 29 | \noindent 30 | Using \IdrisType{Diag} we can define a function, \IdrisFunction{diag}, function that, from two terms, either returns a proof that they satisfy the \IdrisType{Diag} relation or return \IdrisData{Nothing}. 31 | 32 | \begin{Verbatim} 33 | diag : (s, t : Bin) -> Maybe (Diag s t) 34 | diag Leaf Leaf = Just Leaf2 35 | diag (Node s t) (Node u v) = Just (Node2 s t u v) 36 | diag _ _ = Nothing 37 | \end{Verbatim} 38 | 39 | \noindent 40 | We can easily prove that \IdrisFunction{diag} cannot possibly return \IdrisData{Nothing} if the inputs are in fact equal. 41 | 42 | \begin{Verbatim} 43 | diagNot : (t : Bin) -> Not (diag t t === Nothing) 44 | diagNot Leaf = absurd 45 | diagNot (Node _ _) = absurd 46 | \end{Verbatim} 47 | 48 | \noindent 49 | We can use \IdrisFunction{diagNot} to implement \IdrisFunction{decEq} 50 | by only considering cases where the two input terms share the same 51 | top-level constructor. 52 | For the remaining cases we only require a generic catch-all case that handles all top-level mismatches thanks to \IdrisFunction{diagNot}. 53 | 54 | \begin{Verbatim} 55 | decEq : (s, t : Bin) -> Dec (s === t) 56 | decEq s@_ t@_ with (diag s t) proof eq 57 | _ | Just Leaf2 = Yes Refl 58 | _ | Just (Node2 a b u v) with (decEq a u) | (decEq b v) 59 | _ | Yes eq1 | Yes eq2 = Yes (cong2 Node eq1 eq2) 60 | _ | No neq1 | _ = No (\textbackslash{}case Refl => neq1 Refl) 61 | _ | _ | No neq2 = No (\textbackslash{}case Refl => neq2 Refl) 62 | _ | Nothing = No (\textbackslash{} Refl => diagNot _ eq) 63 | \end{Verbatim} 64 | 65 | 66 | %%% Local Variables: 67 | %%% mode: latex 68 | %%% TeX-master: "../paper" 69 | %%% End: 70 | -------------------------------------------------------------------------------- /paper/2023-EVCS/content/execution.tex: -------------------------------------------------------------------------------- 1 | The \Velo{} \acs*{repl} lets users reduce terms down to head-normal forms. 2 | % 3 | We can realise \Velo{}'s dynamic semantics either through definitional 4 | interpreters~\cite{10.1145/3093333.3009866,Augustsson1999edt}, 5 | or by providing a more traditional syntactic proof of 6 | type-soundness~\cite{DBLP:journals/iandc/WrightF94} 7 | but mechanised~\cite[Part 2: Properties]{plfa22.08} using inductive families. 8 | 9 | We chose the latter approach: by using inductive families, we can make explicit 10 | our language's operational semantics. 11 | % 12 | This enables us to study its meta-theoretical properties and in particular prove 13 | a progress result: every term is either a value or can take a reduction step. 14 | % 15 | By repeatedly applying the progress result, until we either reach a value or the end 16 | user runs out of patience and kills the process, this proof freely gives us an 17 | evaluator that is guaranteed to be correct with respect to \Velo{}'s operational 18 | semantics. 19 | 20 | Following existing approaches~\cite[Part 2: Properties]{plfa22.08}, we have defined 21 | inductive families describing how terms reduce. 22 | 23 | \ExecuteMetaData[Code/MiniExecute.idr.tex]{ReduxDef} 24 | 25 | As can be seen above, our setting enforces call-by-value: 26 | as described by the rule \IdrisData{ReduceFuncApp} 27 | (\exprApp{\exprLam{b}}{t}) only reduces to 28 | ($b \, \lbrace x \leftarrow t \rbrace$) 29 | if $t$ is already known to be a value. 30 | % 31 | Furthermore, our algebraic design (\Cref{sec:design:constants}) allows 32 | us to easily enforce a left-to-right evaluation order by having a generic 33 | family describing how primitive operations' arguments reduce. 34 | % 35 | As can be seen below: when considering a type-aligned list of arguments, 36 | either the \IdrisBound{hd} takes a step and the \IdrisBound{rest} is unchanged, 37 | or the \IdrisBound{hd} is already known to be a value and a further argument 38 | is therefore allowed to take a step. 39 | 40 | \ExecuteMetaData[Code/MiniExecute.idr.tex]{ReducesDef} 41 | 42 | We differ, however, from standard approaches by making our proofs of progress generic 43 | such that the boilerplate for computing the reflexive transitive closure 44 | when reducing terms is tidied away in a shareable module. 45 | % 46 | Our top-level progress definition is thus parameterised by reduction and value definitions: 47 | 48 | \ExecuteMetaData[Code/MiniExecute.idr.tex]{ProgressDef} 49 | 50 | \noindent 51 | and the result of execution, which is similarly parameterised, is as follows 52 | (where \IdrisType{RTList} is the type taking a relation and returning its 53 | reflexive-transitive closure): 54 | 55 | \ExecuteMetaData[Code/MiniExecute.idr.tex]{ResultDef} 56 | 57 | The benefit of our approach is that language designers need only provide details of 58 | what reductions are, 59 | and how to compute a single reduction, the rest comes for free. 60 | % 61 | Moreover, with the result of evaluation we also get the list of reduction steps made that can, optionally, be printed to show a trace of execution. 62 | 63 | %%% Local Variables: 64 | %%% mode: latex 65 | %%% TeX-master: "../paper" 66 | %%% End: 67 | -------------------------------------------------------------------------------- /paper/2023-EVCS/content/velo-intro.tex: -------------------------------------------------------------------------------- 1 | The design behind \Velo{} is purposefully unsurprising: 2 | % 3 | it is the \ac{stlc} extended with let-bindings, 4 | booleans and their conjunction, 5 | and natural numbers and their addition. 6 | % 7 | To promote the idea of interactive editing \Velo{} also supports well-typed holes. 8 | % 9 | Below we show an example \Velo{} program, which contains a multiply used hole, and an extract from the \acs*{repl} 10 | session that lists the current set of holes. 11 | 12 | \begin{center} 13 | \begin{minipage}[t]{0.55\linewidth} 14 | \begin{Verbatim} 15 | let b = false 16 | in let double 17 | = (fun x : nat => (add x x)) 18 | in let x = (double ?hole) 19 | in (double ?hole) 20 | \end{Verbatim} 21 | \end{minipage} 22 | \hfill 23 | \begin{minipage}[t]{0.35\linewidth} 24 | \begin{Verbatim} 25 | Velo> :holes 26 | b : Bool 27 | double : Nat -> Nat 28 | ---------- 29 | ?hole : Nat 30 | \end{Verbatim} 31 | \end{minipage} 32 | 33 | \end{center} 34 | 35 | The featherweight language design of \Velo{} helps us 36 | showcase better how we can use dependently typed languages 37 | as language workbenches~\cite{DBLP:journals/toplas/IgarashiPW01}. 38 | % 39 | Regardless of language complexity, \Velo{} is nonetheless a 40 | complete language with a standard compiler pipeline, and \acs*{repl}. 41 | % 42 | A \ac{dsl} captures the language's concrete syntax, and a parser turns \ac{dsl} instances into raw unchecked terms. 43 | % 44 | Bidirectional type checking keeps type annotations to a minimum in the concrete syntax, and helps to better elaborate raw un-typed terms into a set of well-typed \acp{ir}: 45 | % 46 | \IdrisType{Holey} to support well-scoped typed holes; 47 | % 48 | and 49 | % 50 | \IdrisType{Terms} the core representation that captures our language's abstract syntax. 51 | % 52 | We present interesting aspects of our \ac{ir} design in \Cref{sec:design}. 53 | % 54 | Further, elaboration performs standard desugarings that e.g. turns let-bindings into function application thus reducing the size of our core. 55 | % 56 | From the core representation we also provide well-scoped \ac{cse} using co-\DeBruijn{} indexing (\Cref{sec:compiler-pass}), and we provide a verified evaluator to reduce terms to values (\Cref{sec:semantics}). 57 | 58 | 59 | \todo{Show an example high-level trace of the output?} 60 | \jfdm{This would be useful for a full-length paper, but not here.} 61 | 62 | %%% Local Variables: 63 | %%% mode: latex 64 | %%% TeX-master: "../paper" 65 | %%% End: 66 | -------------------------------------------------------------------------------- /paper/2023-EVCS/content/well-typed-holes.tex: -------------------------------------------------------------------------------- 1 | \subsection{Well-Typed Holes} 2 | \label{sec:design:holes} 3 | 4 | Holes are a special kind of placeholder that programmers can use for parts of the program they have not yet written. 5 | % 6 | In a typed language, each hole will be assigned a type based on the context it is used in. 7 | 8 | \emph{Type-Driven Development}~\cite{DBLP:journals/pacmpl/OmarVCH19} 9 | is a practice by which the user enters into a dialogue 10 | \emph{with} the compiler to interactively build the program. 11 | % 12 | We can enable type-driven programming in part by providing special language support for holes and operations on them. 13 | Such operations will include the ability to inspect, refine, compute with, and instantiate (with an adequately typed term) holes. 14 | % 15 | We believe that bare-bones language support for type-driven development 16 | should at least include the ability to: 17 | % 18 | (1) inspect the type of a hole and the local context it appears in; 19 | % 20 | (2) instantiate a hole with an adequately typed term; 21 | % 22 | and as well 23 | % 24 | (3) safely evaluate programs that still contain holes. 25 | % 26 | \Velo{} provides all three. 27 | 28 | \Idris{} elaborates holes as it encounters them by turning them into 29 | global declarations with no associated definition. 30 | % 31 | Because of this design choice users cannot mention the same hole explicitly in different places to state their intention that these yet unwritten terms ought to be the same. 32 | % 33 | Users can refer to the hole's solution by its name, 34 | but that hole is placed in one specific position 35 | and it is from that position that \Idris{} infers its context. 36 | 37 | In \Velo{}, however, we allow holes to be mentioned arbitrarily many times in 38 | arbitrarily different local contexts. 39 | % 40 | In the following example, the hole \texttt{?h} occurs in two distinct contexts: 41 | $\epsilon,\,a,\,x$ and $\epsilon,\,a,\,y$. 42 | 43 | \begin{center} 44 | \holeexamplegraph{} 45 | \end{center} 46 | 47 | As a consequence, a term will only fit in that hole if it happens to live in the shared common prefix of these two contexts ($\epsilon,\,a$). 48 | % 49 | Indeed, references to $x$ will not make sense in $\epsilon,a,y$ and vice-versa for $y$. 50 | 51 | 52 | Our elaborator proceeds in two steps. 53 | % 54 | First, a bottom-up pass records holes as they are found and, in nodes with multiple subterms, reconciles conflicting hole occurrences by computing the appropriate local context restrictions. 55 | % 56 | This process produces a list of holes, their types, and local contexts, 57 | together with a \IdrisType{Holey} term that contains invariants ensuring 58 | these collected holes do fit in the term. 59 | % 60 | Second, a top-down pass produces a core \IdrisType{Term} indexed by the list of \IdrisType{Meta} (a simple record type containing the hole's name, the context it lives in, and its type). 61 | % 62 | Hole occurrences end up being assigned a thinning that embeds the metavariable's actual context into the context it appears in. 63 | We discuss thinnings and their use in \Velo{} in Section~\ref{sec:compiler-pass}. 64 | 65 | Although these intermediate representations are \Velo{}-specific, the technique 66 | and invariants are general and can be reused by anyone wanting to implement 67 | well-scoped holes in their functional \ac{dsl}. 68 | 69 | %%% Local Variables: 70 | %%% mode: latex 71 | %%% TeX-master: "../paper" 72 | %%% End: 73 | -------------------------------------------------------------------------------- /paper/2023-EVCS/figure/dynamics-smallstep.tex: -------------------------------------------------------------------------------- 1 | \begin{mathpar}%\mprset{sep=1em} 2 | % 3 | % Naturals 4 | % 5 | \and 6 | \infer*[left=Z-Val] 7 | {% 8 | \\ 9 | }{% 10 | \exprZero{}\StepTo\exprZero{} 11 | } 12 | \and 13 | \infer*[left=Inc] 14 | {% 15 | n\StepsTo{v} 16 | }{% 17 | \exprIncRule\StepsTo{\exprIncValue} 18 | } 19 | \and 20 | \infer*[left=Add-L] 21 | {% 22 | a\StepsTo{v} 23 | }{% 24 | \exprAddRule\StepsTo{\exprAddStepL} 25 | } 26 | \and 27 | \infer*[left=Add-LZ] 28 | {% 29 | b\StepsTo{v} 30 | }{% 31 | \exprAddValueLZ\StepsTo{v} 32 | } 33 | \and 34 | \infer*[left=Add-RV] 35 | {% 36 | b\StepsTo{v_b} 37 | }{% 38 | \exprAddValueRV\StepsTo{\exprAddStepValue} 39 | } 40 | % 41 | % Booleans 42 | % 43 | \and 44 | \infer*[left=T-Val] 45 | {% 46 | \\ 47 | }{% 48 | \exprTrue\StepTo\exprTrue 49 | } 50 | \and 51 | \infer*[left=F-Val] 52 | {% 53 | \\ 54 | }{% 55 | \exprFalse\StepTo\exprFalse 56 | } 57 | \and 58 | \infer*[left=And-L] 59 | {% 60 | a\StepsTo{v} 61 | }{% 62 | \exprAndRule\StepsTo{\exprAndStepL} 63 | } 64 | \and 65 | \infer*[left=And-TR] 66 | {% 67 | b\StepsTo{v} 68 | }{% 69 | \exprAndValueL\StepsTo{v} 70 | } 71 | \and 72 | \infer*[left=And-FW] 73 | {% 74 | \\ 75 | }{% 76 | \exprAndValueF\StepsTo{\exprFalse} 77 | } 78 | \and 79 | \infer*[left=App] 80 | {% 81 | f\StepsTo{\exprLamValue} 82 | }{% 83 | \exprAppRule\StepsTo\subst{b}{x}{a} 84 | } 85 | \end{mathpar} 86 | 87 | %%% Local Variables: 88 | %%% mode: latex 89 | %%% TeX-master: "../paper" 90 | %%% End: 91 | -------------------------------------------------------------------------------- /paper/2023-EVCS/figure/statics.tex: -------------------------------------------------------------------------------- 1 | \begin{mathpar}%\mprset{sep=1em} 2 | \infer*[left=Var] 3 | {% 4 | \ty{x}{t}\in\Gamma 5 | }{% 6 | \env{\ty{x}{t}} 7 | } 8 | % 9 | % Naturals 10 | % 11 | \and 12 | \infer*[left=Z-Intro] 13 | {% 14 | \\ 15 | }{% 16 | \env{\ty{\exprZero}{\TyNat}} 17 | } 18 | \and 19 | \infer*[left=Inc] 20 | {% 21 | \env{\ty{n}{\TyNat}} 22 | }{% 23 | \env{\ty{\exprIncRule}{\TyNat}} 24 | } 25 | \and 26 | \infer*[left=Add] 27 | {% 28 | \env{\ty{a}{\TyNat}} 29 | \\ 30 | \env{\ty{b}{\TyNat}} 31 | }{% 32 | \env{\ty{\exprAddRule}{\TyNat}} 33 | } 34 | % 35 | % Booleans 36 | % 37 | \and 38 | \infer*[left=T-Intro] 39 | {% 40 | \\ 41 | }{% 42 | \env{\ty{\exprTrue}{\TyBool}} 43 | } 44 | \and 45 | \infer*[left=F-Intro] 46 | {% 47 | \\ 48 | }{% 49 | \env{\ty{\exprFalse}{\TyBool}} 50 | } 51 | \and 52 | \infer*[left=And] 53 | {% 54 | \env{\ty{a}{\TyBool}} 55 | \\ 56 | \env{\ty{b}{\TyBool}} 57 | }{% 58 | \env{\ty{\exprAndRule}{\TyBool}} 59 | } 60 | % 61 | % Lam & Apps 62 | % 63 | \and 64 | \infer*[left=Lam] 65 | {% 66 | \env[\envAdd{\ty{x}{t_a}}]{\ty{b}{t_b}} 67 | }{% 68 | \env{\ty{\exprLamRule}{\typeFuncRule}} 69 | } 70 | \and 71 | \infer*[left=App] 72 | {% 73 | \env{\ty{f}{\typeFuncRule}} 74 | \\ 75 | \env{\ty{a}{t_a}} 76 | }{% 77 | \env{\ty{\exprAppRule}{t_b}} 78 | } 79 | % 80 | % Lets 81 | % 82 | \and 83 | \infer*[left=Let] 84 | {% 85 | \env{\ty{e}{t_a}} 86 | \\ 87 | \env[\envAdd{\ty{x}{t_a}}]{\ty{b}{t_b}} 88 | }{% 89 | \env{\ty{\exprLetRule}{t_b}} 90 | } 91 | \end{mathpar} 92 | 93 | %%% Local Variables: 94 | %%% mode: latex 95 | %%% TeX-master: "../paper" 96 | %%% End: 97 | -------------------------------------------------------------------------------- /paper/2023-EVCS/figure/syntax.tex: -------------------------------------------------------------------------------- 1 | \newcommand{\syntaxtypes}{ 2 | \[\begin{array}{lcl} 3 | \ty{t}{\Type} 4 | & \Coloneqq 5 | & \TyNat \\ 6 | & \fpAlt 7 | & \TyBool \\ 8 | & \fpAlt 9 | & \typeFuncIntro{} 10 | \end{array}\]} 11 | 12 | \newcommand{\syntaxcontexts}{ 13 | \[\begin{array}{lcl} 14 | \ty{\Gamma}{\Context} 15 | & \Coloneqq 16 | & \epsilon \\ 17 | & \fpAlt 18 | & \Gamma,\, \ty{x}{t} 19 | \end{array}\]} 20 | 21 | \newcommand{\varRule}{ 22 | $\Gamma \ni \ty{x}{a}$ 23 | } 24 | 25 | \newcommand{\varZero}{ 26 | \[ 27 | \infer{ }{\Gamma \,, \ty{x}{a} \ni \ty{x}{a}} 28 | \] 29 | } 30 | 31 | \newcommand{\varSuc}{ 32 | \[ 33 | \infer{\Gamma \ni \ty{x}{a}}{\Gamma \,, \ty{y}{b} \ni \ty{x}{a}} 34 | \] 35 | } 36 | 37 | \newcommand{\inferenceRule}{ 38 | $\Gamma \vdash \ty{t}{a}$ 39 | } 40 | 41 | \newcommand{\inferenceZero}{ 42 | \[ 43 | \infer{ }{\Gamma \vdash \ty{\exprZero}{\TyNat}} 44 | \] 45 | } 46 | 47 | \newcommand{\inferenceVar}{ 48 | \[ 49 | \infer{\Gamma \ni \ty{x}{a}}{\Gamma \vdash \ty{x}{a}} 50 | \] 51 | } 52 | 53 | \newcommand{\inferenceInc}{ 54 | \[ 55 | \infer{\Gamma \vdash \ty{n}{\TyNat} 56 | }{\Gamma \vdash \ty{\exprInc{n}}{\TyNat}} 57 | \] 58 | } 59 | 60 | \newcommand{\inferenceApp}{ 61 | \[ 62 | \infer{\Gamma \vdash \ty{f}{\TyFunc{a}{b}} 63 | \\ \Gamma \vdash \ty{t}{a} 64 | }{\Gamma \vdash \ty{\exprApp{f}{t}}{b}} 65 | \] 66 | } 67 | 68 | \newcommand{\inferenceFunc}{ 69 | \[ 70 | \infer{\Gamma,\, \ty{x}{a} \vdash \ty{t}{b} 71 | }{\Gamma \vdash \ty{\exprLam{t}}{\TyFunc{a}{b}}} 72 | \] 73 | } 74 | 75 | \newcommand{\syntaxlang}{ 76 | \begin{align*} 77 | \ty{e}{t} 78 | & 79 | \Coloneqq 80 | x 81 | \fpAlt 82 | \exprZero 83 | \fpAlt 84 | \exprIncIntro{} 85 | \fpAlt 86 | \exprAddIntro{} 87 | & 88 | \text{Expressions} 89 | \\ 90 | & 91 | \firstAlt 92 | \exprTrue{} 93 | \fpAlt 94 | \exprFalse{} 95 | \fpAlt 96 | \exprAndIntro{} 97 | & 98 | \\ 99 | & 100 | \firstAlt 101 | \exprLamIntro{} 102 | \fpAlt 103 | \exprLetIntro{} 104 | \fpAlt 105 | \exprAppIntro{} 106 | & 107 | \\ 108 | \ty{v}{t} 109 | & 110 | \Coloneqq 111 | \exprZero 112 | \fpAlt 113 | \exprIncValue{} 114 | \fpAlt 115 | \exprTrue{} 116 | \fpAlt 117 | \exprFalse{} 118 | \fpAlt 119 | \exprLamValue{} 120 | & 121 | \text{Values} 122 | \end{align*} 123 | } 124 | 125 | %%% Local Variables: 126 | %%% mode: latex 127 | %%% TeX-master: "../paper" 128 | %%% End: 129 | -------------------------------------------------------------------------------- /paper/2023-EVCS/idris2.sty: -------------------------------------------------------------------------------- 1 | \usepackage{inconsolata} 2 | \usepackage{fancyvrb} 3 | \usepackage[x11names]{xcolor} 4 | \newcommand{\Katla} [2][]{\VerbatimInput[commandchars=\\\{\}#1]{#2}} 5 | \newcommand{\KatlaNewline} {\\} 6 | \newcommand{\KatlaSpace} {\hphantom{ }} 7 | \newcommand{\KatlaUnderscore} {\string_} 8 | \newcommand{\KatlaDash} {\string-} 9 | \newcommand{\KatlaTilde} {\raisebox{-.35em}{\textasciitilde}} 10 | \newcommand{\IdrisHlightFont} {\ttfamily} 11 | \newcommand{\IdrisHlightStyleData} {} 12 | \newcommand{\IdrisHlightStyleType} {} 13 | \newcommand{\IdrisHlightStyleBound} {} 14 | \newcommand{\IdrisHlightStyleFunction}{} 15 | \newcommand{\IdrisHlightStyleKeyword} {\bfseries} 16 | \newcommand{\IdrisHlightStyleImplicit}{} 17 | \newcommand{\IdrisHlightStyleComment} {\itshape} 18 | \newcommand{\IdrisHlightStyleHole} {\bfseries} 19 | \newcommand{\IdrisHlightStyleNamespace}{\itshape} 20 | \newcommand{\IdrisHlightStylePostulate}{\bfseries} 21 | \newcommand{\IdrisHlightStyleModule} {\itshape} 22 | 23 | \newcommand{\IdrisHlightColourData} {IndianRed1} 24 | \newcommand{\IdrisHlightColourType} {DeepSkyBlue3} 25 | \newcommand{\IdrisHlightColourBound} {DarkOrchid3} 26 | \newcommand{\IdrisHlightColourFunction}{Chartreuse4} 27 | \newcommand{\IdrisHlightColourKeyword} {black} 28 | \newcommand{\IdrisHlightColourImplicit}{DarkOrchid3} 29 | \newcommand{\IdrisHlightColourComment} {gray} 30 | \newcommand{\IdrisHlightColourHole} {yellow} 31 | \newcommand{\IdrisHlightColourNamespace}{black} 32 | \newcommand{\IdrisHlightColourPostulate}{DarkOrchid3} 33 | \newcommand{\IdrisHlightColourModule} {black} 34 | 35 | \newcommand{\IdrisHole}[1]{{% 36 | \colorbox{\IdrisHlightColourHole}{% 37 | \IdrisHlightStyleHole\IdrisHlightFont% 38 | #1}}} 39 | 40 | \newcommand{\RawIdrisHighlight}[3]{{\textcolor{#1}{\IdrisHlightFont#2{#3}}}} 41 | 42 | \newcommand{\IdrisData}[1]{\RawIdrisHighlight{\IdrisHlightColourData}{\IdrisHlightStyleData}{#1}} 43 | \newcommand{\IdrisType}[1]{\RawIdrisHighlight{\IdrisHlightColourType}{\IdrisHlightStyleType}{#1}} 44 | \newcommand{\IdrisBound}[1]{\RawIdrisHighlight{\IdrisHlightColourBound}{\IdrisHlightStyleBound}{#1}} 45 | \newcommand{\IdrisFunction}[1]{\RawIdrisHighlight{\IdrisHlightColourFunction}{\IdrisHlightStyleFunction}{#1}} 46 | \newcommand{\IdrisKeyword}[1]{\RawIdrisHighlight{\IdrisHlightColourKeyword}{\IdrisHlightStyleKeyword}{#1}} 47 | \newcommand{\IdrisImplicit}[1]{\RawIdrisHighlight{\IdrisHlightColourImplicit}{\IdrisHlightStyleImplicit}{#1}} 48 | \newcommand{\IdrisComment}[1]{\RawIdrisHighlight{\IdrisHlightColourComment}{\IdrisHlightStyleComment}{#1}} 49 | \newcommand{\IdrisNamespace}[1]{\RawIdrisHighlight{\IdrisHlightColourNamespace}{\IdrisHlightStyleNamespace}{#1}} 50 | \newcommand{\IdrisPostulate}[1]{\RawIdrisHighlight{\IdrisHlightColourPostulate}{\IdrisHlightStylePostulate}{#1}} 51 | \newcommand{\IdrisModule}[1]{\RawIdrisHighlight{\IdrisHlightColourModule}{\IdrisHlightStyleModule}{#1}} 52 | 53 | \newenvironment{code} 54 | {\vspace{1em}\noindent\begin{minipage}{\linewidth}\obeyspaces\ttfamily} 55 | {\end{minipage}} 56 | 57 | % Bugfix in fancyvrb to allow inline saved listings 58 | \makeatletter 59 | \let\FV@ProcessLine\relax 60 | \makeatother 61 | -------------------------------------------------------------------------------- /paper/2023-EVCS/notations.tex: -------------------------------------------------------------------------------- 1 | %% Temporary shim before we bring in Katla's idris2.sty 2 | 3 | \newcommand{\IdrisData}[1]{\texttt{#1}} 4 | \newcommand{\IdrisType}[1]{\texttt{#1}} 5 | \newcommand{\IdrisFunction}[1]{\texttt{#1}} 6 | \newcommand{\IdrisImplicit}[1]{\texttt{#1}} 7 | \newcommand{\IdrisBound}[1]{\texttt{#1}} 8 | -------------------------------------------------------------------------------- /paper/2023-EVCS/oasics-logo-bw.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/paper/2023-EVCS/oasics-logo-bw.pdf -------------------------------------------------------------------------------- /paper/2023-EVCS/orcid.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/paper/2023-EVCS/orcid.pdf -------------------------------------------------------------------------------- /paper/2023-EVCS/robust-catch.tex: -------------------------------------------------------------------------------- 1 | \makeatletter 2 | 3 | \newrobustcmd*\OrigExecuteMetaData[2][\jobname]{% 4 | \CatchFileBetweenTags\CatchFBT@tok{#1}{#2}% 5 | \global\expandafter\CatchFBT@tok\expandafter{% 6 | \expandafter}\the\CatchFBT@tok 7 | }%\OrigExecuteMetaData 8 | 9 | \newrobustcmd*\ChkExecuteMetaData[2][\jobname]{% 10 | \CatchFileBetweenTags\CatchFBT@tok{#1}{#2}% 11 | \edef\mytokens{\detokenize\expandafter{\the\CatchFBT@tok}} 12 | \ifx\mytokens\empty\PackageError{catchfilebetweentags}{the tag #2 is not found\MessageBreak in file #1 \MessageBreak called from \jobname.tex}{use a different tag}\fi% 13 | }%\ChkExecuteMetaData 14 | 15 | \renewrobustcmd*\ExecuteMetaData[2][\jobname]{% 16 | \ChkExecuteMetaData[#1]{#2}% 17 | \OrigExecuteMetaData[#1]{#2}% 18 | } 19 | 20 | \makeatother 21 | -------------------------------------------------------------------------------- /paper/2023-EVCS/velo.sty: -------------------------------------------------------------------------------- 1 | \ProvidesPackage{velo} 2 | 3 | \RequirePackage{jfdm-plt} 4 | \RequirePackage{bbm} 5 | \RequirePackage{textcomp} 6 | \RequirePackage{newtxmath} 7 | 8 | % # [ Types ] 9 | 10 | % Definitions for \TyNat and \TyBool come from jfdm-plt.sty 11 | 12 | \newcommand{\typeFuncIntro}{\TyFunc{t}{t}} 13 | \newcommand{\typeFuncRule}{\TyFunc{t_a}{t_b}} 14 | 15 | % # [ Expressions ] 16 | 17 | % Definitions for \stmtLet, \exprLam, \exprApp, \exprZero, \exprInc, come from jfdm-plty.sty 18 | 19 | \newcommand{\exprIncIntro}{\exprInc{e}} 20 | \newcommand{\exprIncRule}{\exprInc{n}} 21 | \newcommand{\exprIncValue}{\exprInc{v}} 22 | 23 | \MkEnum{\EnumAnd}{and} 24 | \newcommand{\exprAnd}[2]{\newExpr{\EnumAnd}{#1\,#2}} 25 | 26 | \newcommand{\exprAndIntro}{\exprAnd{e}{e}} 27 | \newcommand{\exprAndRule}{\exprAnd{a}{b}} 28 | 29 | \newcommand{\exprAndStepL}{\exprAnd{v}{b}} 30 | \newcommand{\exprAndValueL}{\exprAnd{\exprTrue}{b}} 31 | \newcommand{\exprAndValueF}{\exprAnd{\exprFalse}{b}} 32 | \newcommand{\exprAndStepR}{\exprAnd{\exprTrue}{v_b}} 33 | 34 | 35 | \MkEnum{\EnumAdd}{add} 36 | \newcommand{\exprAdd}[2]{\newExpr{\EnumAdd}{#1\,#2}} 37 | 38 | \newcommand{\exprAddIntro}{\exprAdd{e}{e}} 39 | \newcommand{\exprAddRule}{\exprAdd{a}{b}} 40 | 41 | \newcommand{\exprAddStepL}{\exprAdd{v}{b}} 42 | \newcommand{\exprAddValueLZ}{\exprAdd{\exprZero}{b}} 43 | \newcommand{\exprAddValueRV}{\exprAdd{\exprInc{v_a}}{b}} 44 | \newcommand{\exprAddStepValue}{\exprInc{\exprAdd{v_a}{v_b}}} 45 | 46 | 47 | \newcommand{\exprLamIntro}{\exprLamTy{x}{t}{e}} 48 | \newcommand{\exprLamRule}{\exprLamTy{x}{t}{b}} 49 | \newcommand{\exprLamValue}{\exprLamRule{}} 50 | 51 | \newcommand{\exprAppIntro}{\exprApp{e}{e}} 52 | \newcommand{\exprAppRule}{\exprApp{f}{a}} 53 | 54 | \newcommand{\exprLamTyIntro}{\exprLamTy{x}{t}{e}} 55 | \newcommand{\exprLamTyRule}{\exprLamTy{x}{t}{b}} 56 | 57 | \newcommand{\exprLetIntro}{\exprLet{x}{e}{e}} 58 | \newcommand{\exprLetRule}{\exprLet{x}{e}{b}} 59 | 60 | 61 | \endinput 62 | -------------------------------------------------------------------------------- /presentation/.gitignore: -------------------------------------------------------------------------------- 1 | *.idr.tex 2 | cover-letter.pdf 3 | paper.*.synctex.gz 4 | presentation*.pdf 5 | *draft.pdf 6 | *blind.*.pdf 7 | *camera.pdf 8 | *preprint.pdf 9 | *submission.pdf 10 | *.fdb_latexmk 11 | *.fls 12 | *.acn 13 | *.ist 14 | *.upa 15 | *.upb 16 | auto/ 17 | sample-*.pdf 18 | *.log 19 | *.aux 20 | *.cfg 21 | *.glo 22 | *.idx 23 | *.nav 24 | *.snm 25 | *.vrb 26 | *.toc 27 | *.ilg 28 | *.ind 29 | *.out 30 | *.lof 31 | *.lot 32 | *.bbl 33 | *.blg 34 | *.gls 35 | *.cut 36 | *.hd 37 | *.dvi 38 | *.ps 39 | *.thm 40 | *.tgz 41 | *.zip 42 | *.rpi 43 | *.vtc 44 | *~ 45 | *.bcf 46 | *.run.xml 47 | *.loc 48 | *.soc 49 | -------------------------------------------------------------------------------- /presentation/Makefile: -------------------------------------------------------------------------------- 1 | slides: presentation.slides.pdf 2 | 3 | %.pdf: %.tex 4 | mkdir -p __build 5 | latexmk -pdf -bibtex-cond -outdir="__build" $*.tex 6 | ln -sf __build/$*.pdf $*.pdf 7 | 8 | clean: 9 | rm -rf __build/ 10 | rm presentation.slides.pdf 11 | -------------------------------------------------------------------------------- /presentation/biblio.bib: -------------------------------------------------------------------------------- 1 | @inproceedings{DBLP:conf/sle/ErdwegSVBBCGHKLKMPPSSSVVVWW13, 2 | author = {Sebastian Erdweg and 3 | Tijs van der Storm and 4 | Markus V{\"{o}}lter and 5 | Meinte Boersma and 6 | Remi Bosman and 7 | William R. Cook and 8 | Albert Gerritsen and 9 | Angelo Hulshout and 10 | Steven Kelly and 11 | Alex Loh and 12 | Gabri{\"{e}}l D. P. Konat and 13 | Pedro J. Molina and 14 | Martin Palatnik and 15 | Risto Pohjonen and 16 | Eugen Schindler and 17 | Klemens Schindler and 18 | Riccardo Solmi and 19 | Vlad A. Vergu and 20 | Eelco Visser and 21 | Kevin van der Vlist and 22 | Guido Wachsmuth and 23 | Jimi van der Woning}, 24 | editor = {Martin Erwig and 25 | Richard F. Paige and 26 | Eric Van Wyk}, 27 | title = {The State of the Art in Language Workbenches - Conclusions from the 28 | Language Workbench Challenge}, 29 | booktitle = {Software Language Engineering - 6th International Conference, {SLE} 30 | 2013, Indianapolis, IN, USA, October 26-28, 2013. Proceedings}, 31 | series = {Lecture Notes in Computer Science}, 32 | volume = {8225}, 33 | pages = {197--217}, 34 | publisher = {Springer}, 35 | year = {2013}, 36 | url = {https://doi.org/10.1007/978-3-319-02654-1\_11}, 37 | doi = {10.1007/978-3-319-02654-1\_11}, 38 | timestamp = {Sun, 02 Oct 2022 16:15:33 +0200}, 39 | biburl = {https://dblp.org/rec/conf/sle/ErdwegSVBBCGHKLKMPPSSSVVVWW13.bib}, 40 | bibsource = {dblp computer science bibliography, https://dblp.org} 41 | } 42 | -------------------------------------------------------------------------------- /presentation/figure/.gitkeep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/presentation/figure/.gitkeep -------------------------------------------------------------------------------- /presentation/figure/edwin.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/presentation/figure/edwin.jpg -------------------------------------------------------------------------------- /presentation/figure/idris.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/presentation/figure/idris.pdf -------------------------------------------------------------------------------- /presentation/figure/master.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/presentation/figure/master.jpg -------------------------------------------------------------------------------- /presentation/figure/novice.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/presentation/figure/novice.jpg -------------------------------------------------------------------------------- /presentation/figure/spoofax.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/presentation/figure/spoofax.png -------------------------------------------------------------------------------- /presentation/figure/visser.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/presentation/figure/visser.jpg -------------------------------------------------------------------------------- /presentation/gla-colours.sty: -------------------------------------------------------------------------------- 1 | % ---------------------------------------------------------- [ gla-colours.sty ] 2 | % Module : gla-colours.sty 3 | % Copyright : (c) Jan de Muijnck-Hughes 4 | % License : see LICENSE 5 | % Version : v2016.03.09 6 | % ---------------------------------------------------------------------- [ EOH ] 7 | \ProvidesPackage{gla-colours} 8 | 9 | \RequirePackage{xcolor} 10 | 11 | \definecolor{gla-blue}{RGB/cmyk}{0,56,101/1.0, 0.6, 0.1, 0.53} 12 | \definecolor{gla-heather}{RGB/cmyk}{91,83,125/0.56, 0.59, 0.04, 0.14} 13 | \definecolor{gla-aquamarine}{RGB/cmyk}{154,185,173/0.37, 0.04, 0.26, 0.10} 14 | \definecolor{gla-slate}{RGB/cmyk}{79,89,97/0.45, 0.25, 0.16, 0.59} 15 | \definecolor{gla-rose}{RGB/cmyk}{210,120,171/0.17, 0.68, 0.03, 0.12} 16 | \definecolor{gla-mocha}{RGB/cmyk}{181,144,121/0.14, 0.48, 0.53, 0.26} 17 | \definecolor{gla-lawn}{RGB/cmyk}{132,189,80/0.54, 0.0, 1.0, 0.0} 18 | \definecolor{gla-cobalt}{RGB/cmyk}{0,117,176/1.0, 0.22, 0.02, 0.16} 19 | \definecolor{gla-turquiose}{RGB/cmyk}{0,181,209/0.84, 0.0, 0.18, 0.0} 20 | \definecolor{gla-sunshine}{RGB/cmyk}{255,220,54/0.0, 0.11, 0.88, 0.0} 21 | \definecolor{gla-pumpkin}{RGB/cmyk}{255,185,72/0.0, 0.45, 0.94, 0.0} 22 | \definecolor{gla-thistle}{RGB/cmyk}{149,18,114/0.30, 1.0, 0.02, 0.02} 23 | \definecolor{gla-pillarbox}{RGB/cmyk}{213,0,50/0.0, 1.0, 0.72, 0.0} 24 | \definecolor{gla-lavender}{RGB/cmyk}{91,77,148/0.7, 0.76, 0.0, 0.0} 25 | \definecolor{gla-forest}{RGB/cmyk}{0,81,51/0.91, 0.14, 0.78, 0.60} 26 | \definecolor{gla-burgundy}{RGB/cmyk}{125,34,57/0.13, 0.96, 0.26, 0.52} 27 | \definecolor{gla-rust}{RGB/cmyk}{154,58,6/0.0, 0.74, 1.0, 0.8} 28 | \definecolor{gla-sandstone}{RGB/cmyk}{82,71,59/0.16, 0.29, 0.38, 0.53} 29 | % 30 | 31 | \newcommand{\glaBlue}[1]{\textcolor{gla-blue}{#1}} 32 | \newcommand{\glaHeather}[1]{\textcolor{gla-heather}{#1}} 33 | \newcommand{\glaAquamarine}[1]{\textcolor{gla-aquamarine}{#1}} 34 | \newcommand{\glaSlate}[1]{\textcolor{gla-slate}{#1}} 35 | \newcommand{\glaRose}[1]{\textcolor{gla-rose}{#1}} 36 | \newcommand{\glaMocha}[1]{\textcolor{gla-mocha}{#1}} 37 | \newcommand{\glaLawn}[1]{\textcolor{gla-lawn}{#1}} 38 | \newcommand{\glaCobalt}[1]{\textcolor{gla-cobalt}{#1}} 39 | \newcommand{\glaTurquiose}[1]{\textcolor{gla-turquiose}{#1}} 40 | \newcommand{\glaSunshine}[1]{\textcolor{gla-sunshine}{#1}} 41 | \newcommand{\glaPumpkin}[1]{\textcolor{gla-pumpkin}{#1}} 42 | \newcommand{\glaThistle}[1]{\textcolor{gla-thistle}{#1}} 43 | \newcommand{\glaPillarbox}[1]{\textcolor{gla-pillarbox}{#1}} 44 | \newcommand{\glaLavender}[1]{\textcolor{gla-lavender}{#1}} 45 | \newcommand{\glaForest}[1]{\textcolor{gla-forest}{#1}} 46 | \newcommand{\glaBurgundy}[1]{\textcolor{gla-burgundy}{#1}} 47 | \newcommand{\glaRust}[1]{\textcolor{gla-rust}{#1}} 48 | \newcommand{\glaSandstone}[1]{\textcolor{gla-sandstone}{#1}} 49 | 50 | % ---------------------------------------------------------------------- [ EOS ] 51 | \endinput 52 | % ---------------------------------------------------------------------- [ EOF ] 53 | -------------------------------------------------------------------------------- /presentation/image/gla.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/presentation/image/gla.pdf -------------------------------------------------------------------------------- /presentation/image/sta.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jfdm/velo-lang/b88d19d84fbbbe805bfc93d4b57eaea197b8b80b/presentation/image/sta.pdf -------------------------------------------------------------------------------- /src/Main.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Velo.Core 4 | import Velo.Options 5 | import Velo.Pipeline 6 | import Velo.REPL 7 | 8 | 9 | covering 10 | mainRug : Velo () 11 | mainRug 12 | = do opts <- getOpts 13 | 14 | when (repl opts) $ repl 15 | 16 | pipeline opts 17 | 18 | covering 19 | main : IO () 20 | main 21 | = do Velo.run mainRug 22 | 23 | 24 | -- [ EOF ] 25 | -------------------------------------------------------------------------------- /src/Toolkit/AST.idr: -------------------------------------------------------------------------------- 1 | module Toolkit.AST 2 | 3 | import public Data.Vect 4 | import public Toolkit.Data.Location 5 | import public Toolkit.Data.DVect 6 | 7 | public export 8 | data AST : (desc : (k : kind) 9 | -> (arity : Nat) 10 | -> (meta : Vect arity kind) 11 | -> Type) 12 | -> (k : kind) 13 | -> (annotation : Type) 14 | -> Type 15 | where 16 | 17 | Branch : {0 node : (k : kind) -> (n : Nat) -> Vect n kind -> Type} 18 | -> ( desc : node k n meta) 19 | -> ( annot : a) 20 | -> ( nodes : DVect kind (\k => AST node k a) n meta) 21 | -> AST node k a 22 | 23 | export 24 | getAnnotation : AST d k a -> a 25 | getAnnotation (Branch kind annot nodes) 26 | = annot 27 | 28 | export 29 | Functor (AST kinds k) where 30 | map f (Branch kind annot nodes) 31 | = Branch kind (f annot) (mapV f nodes) 32 | 33 | where mapV : (f : a -> b) -> DVect d (\k => AST node k a) n ks 34 | -> DVect d (\k => AST node k b) n ks 35 | mapV f [] = [] 36 | mapV f (x :: xs) = map f x :: mapV f xs 37 | 38 | 39 | 40 | namespace Generic 41 | export 42 | show : {0 node : (k : kind) -> (n : Nat) -> Vect n kind -> Type} 43 | -> (showDesc : forall k, arity, ms . (desc : node k arity ms) 44 | -> String) 45 | -> (showAnn : (annot : a) -> String) 46 | -> (ast : AST node k a) 47 | -> String 48 | 49 | 50 | show k a (Branch kind annot nodes) 51 | = "(Branch \{k kind} \{a annot} \{showDVect (show k a) nodes})" 52 | 53 | namespace Default 54 | export 55 | {0 node : (k : kind) -> (n : Nat) -> Vect n kind -> Type} 56 | -> (forall k,n,ms . Show (node k n ms)) 57 | => Show a 58 | => Show (AST node k a) where 59 | 60 | show = assert_total $ show show show 61 | 62 | 63 | public export 64 | data AsRef : String -> FileContext -> Ref -> Type where 65 | R : AsRef s fc (MkRef fc s) 66 | 67 | export 68 | asRef : (s : String) -> (fc : FileContext) -> AsRef s fc (MkRef fc s) 69 | asRef s fc = R 70 | 71 | namespace Singleton 72 | public export 73 | data Singleton : (Nat -> Type) -> Unit -> (n : Nat) -> Vect n Unit -> Type where 74 | Val : s n -> Singleton s () n (replicate n ()) 75 | 76 | -- [ EOF ] 77 | -------------------------------------------------------------------------------- /src/Toolkit/CoDeBruijn/Binding.idr: -------------------------------------------------------------------------------- 1 | module Toolkit.CoDeBruijn.Binding 2 | 3 | import Control.Function 4 | import Decidable.Equality 5 | 6 | %default total 7 | 8 | public export 9 | data Binding : (t : SnocList a -> Type) -> a -> SnocList a -> Type where 10 | ||| Constant 11 | K : t g -> Binding t s g 12 | ||| Relevant 13 | R : (0 s : a) -> t (g :< s) -> Binding t s g 14 | 15 | export Injective (K {t, s, g}) where injective Refl = Refl 16 | export Injective (R {t, g} s) where injective Refl = Refl 17 | 18 | export Uninhabited (K {t, s, g} l === R s r) where uninhabited Refl impossible 19 | export Uninhabited (R {t, g} s l === K r) where uninhabited Refl impossible 20 | 21 | public export 22 | ({0 xs : SnocList a} -> DecEq (t xs)) => DecEq (Binding t x xs) where 23 | decEq (K t) (K u) = decEqCong (decEq t u) 24 | decEq (K _) (R _ _) = No absurd 25 | decEq (R _ _) (K _) = No absurd 26 | decEq (R x t) (R x u) = decEqCong (decEq t u) 27 | 28 | public export 29 | (forall xs. Eq (t xs)) => Eq (Binding t x xs) where 30 | K t == K u = t == u 31 | R x t == R x u = t == u 32 | _ == _ = False 33 | 34 | public export 35 | (forall xs. Ord (t xs)) => Ord (Binding t x xs) where 36 | compare (K t) (K u) = compare t u 37 | compare (K _) _ = LT 38 | compare _ (K _) = GT 39 | compare (R x t) (R x u) = compare t u 40 | -------------------------------------------------------------------------------- /src/Toolkit/CoDeBruijn/Variable.idr: -------------------------------------------------------------------------------- 1 | module Toolkit.CoDeBruijn.Variable 2 | 3 | import Decidable.Equality 4 | 5 | %default total 6 | 7 | public export 8 | data IsVar : SnocList a -> a -> Type where 9 | Here : IsVar [ (y : b) -> Type where 11 | LT : Comparison x y 12 | EQ : Comparison x x -- note it's the same `x` in both indices here 13 | GT : Comparison x y 14 | 15 | public export 16 | interface Comparable a b where 17 | cmp : (x : a) -> (y : b) -> Comparison x y 18 | 19 | public export 20 | Comparable Nat Nat where 21 | cmp Z Z = EQ 22 | cmp Z (S _) = LT 23 | cmp (S _) Z = GT 24 | cmp (S m) (S n) with (cmp m n) 25 | _ | LT = LT 26 | cmp (S m) (S .(m)) | EQ = EQ 27 | _ | GT = GT 28 | -------------------------------------------------------------------------------- /src/Toolkit/Data/DList.idr: -------------------------------------------------------------------------------- 1 | ||| A `list` construct to create lists of dependent types. 2 | ||| 3 | ||| One of the problems with using dependent types is that types 4 | ||| depend on values. This affects the ability to construct lists of 5 | ||| values that have a dependent type. The existing `List` type cannot 6 | ||| be used as it requires all elements to have the same type. 7 | ||| 8 | ||| Copyright : see COPYRIGHT 9 | ||| License : see LICENSE 10 | ||| 11 | module Toolkit.Data.DList 12 | 13 | import Data.String 14 | import public Data.List 15 | import public Data.List.Elem 16 | 17 | ||| A list construct for dependent types. 18 | ||| 19 | ||| @aTy The type of the value contained within the list element type. 20 | ||| @elemTy The type of the elements within the list 21 | ||| @as The List used to contain the different values within the type. 22 | public export 23 | data DList : (aTy : Type) 24 | -> (elemTy : aTy -> Type) 25 | -> (as : List aTy) 26 | -> Type where 27 | ||| Create an empty List 28 | Nil : DList aTy elemTy Nil 29 | ||| Cons 30 | ||| 31 | ||| @elem The element to add 32 | ||| @rest The list for `elem` to be added to. 33 | (::) : {x : aTy} 34 | -> (elem : elemTy x) 35 | -> (rest : DList aTy elemTy xs) 36 | -> DList aTy elemTy (x::xs) 37 | 38 | 39 | public export 40 | mapToList : (forall x . e x -> b) 41 | -> DList a e xs 42 | -> List b 43 | mapToList _ Nil = Nil 44 | mapToList f (x::xs) = f x :: mapToList f xs 45 | 46 | public export 47 | lookup : (idx : Elem x xs) 48 | -> (ps : DList type pred xs) 49 | -> pred x 50 | lookup Here (elem :: rest) = elem 51 | lookup (There y) (elem :: rest) = lookup y rest 52 | 53 | public export 54 | replace : (idx : Elem x xs) 55 | -> (new : pred x) 56 | -> (ps : DList type pred xs) 57 | -> DList type pred xs 58 | replace Here new (elem :: rest) = new :: rest 59 | replace (There y) new (elem :: rest) = elem :: replace y new rest 60 | 61 | ||| Function to show a `DList`. 62 | ||| 63 | ||| Due to limitations in idris wrt to class instances on dependent 64 | ||| types a generic show instance cannot be defined for 65 | ||| sigmalist. This will cause minor annoyances in its use. 66 | ||| 67 | ||| @showFunc A function to show the elements 68 | ||| @l The list to be Shown. 69 | public export 70 | showDList : (showFunc : forall a . elemTy a -> String) 71 | -> (l : DList aTy elemTy as) 72 | -> String 73 | showDList f xs = "[" ++ unwords (intersperse "," (mapToList f xs)) ++ "]" 74 | 75 | 76 | namespace Alt 77 | public export 78 | index : (xs : DList iTy eTy is) 79 | -> (idx : Elem i is) 80 | -> eTy i 81 | index (ex :: rest) Here = ex 82 | index (ex :: rest) (There later) = index rest later 83 | 84 | public export 85 | update : (vs : DList iTy eTy is) 86 | -> (idx : Elem i is) 87 | -> (new : eTy i) 88 | -> DList iTy eTy is 89 | update (ex :: rest) Here new = new :: rest 90 | update (ex :: rest) (There later) new = ex :: update rest later new 91 | 92 | 93 | public export 94 | updateWith : DList iTy eTy is 95 | -> Elem i is 96 | -> (eTy i -> eTy i) 97 | -> DList iTy eTy is 98 | updateWith (ex :: rest) Here f = f ex :: rest 99 | updateWith (ex :: rest) (There later) f = ex :: updateWith rest later f 100 | 101 | -- --------------------------------------------------------------------- [ EOF ] 102 | -------------------------------------------------------------------------------- /src/Toolkit/Data/DList/Any.idr: -------------------------------------------------------------------------------- 1 | ||| The Any list quantifier for the DList quantifier. 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.Data.DList.Any 7 | 8 | import Toolkit.Decidable.Informative 9 | 10 | import Toolkit.Data.DList 11 | 12 | import public Toolkit.Decidable.Equality.Indexed 13 | 14 | %default total 15 | 16 | ||| Proof that some element satisfies the predicate 17 | ||| 18 | ||| @idx The type of the element's index. 19 | ||| @type The type of the list element. 20 | ||| @p A predicate 21 | ||| @xs The list itself. 22 | public export 23 | data Any : (idx : Type) 24 | -> (type : idx -> Type) 25 | -> (p : {i : idx} -> (x : type i) -> Type) 26 | -> {is : List idx} 27 | -> (xs : DList idx type is) 28 | -> Type 29 | where 30 | ||| Proof that the element is at the front of the list. 31 | H : {p : {i : idx} -> (x : type i) -> Type} 32 | -> {i : idx} 33 | -> {y : type i} 34 | -> (prf : p y) 35 | -> Any idx type p (y :: xs) 36 | 37 | ||| Proof that the element is found later in the list. 38 | T : {p : {i : idx} -> (x : type i) -> Type} 39 | -> (contra : p x' -> Void) 40 | -> (later : Any idx type p xs) 41 | -> Any idx type p (x' ::xs) 42 | 43 | empty : {p : {i : idx} -> (x : type i) -> Type} -> Any idx type p Nil -> Void 44 | empty (H prf) impossible 45 | empty (T contra later) impossible 46 | 47 | 48 | isNotThere : {p : {i : idx} -> (x : type i) -> Type} 49 | -> (Any idx type p rest -> Void) 50 | -> (p i -> Void) 51 | -> Any idx type p (i :: rest) -> Void 52 | isNotThere f g (H prf) = g prf 53 | isNotThere f g (T contra later) = f later 54 | 55 | export 56 | any : {p : {i : idx} -> (x : type i) -> Type} 57 | -> (f : {i : idx} -> (x : type i) -> DecInfo err (p x)) 58 | -> (xs : DList idx type is) 59 | -> Dec (Any idx type p xs) 60 | any f [] = No empty 61 | 62 | any f (elem :: rest) with (f elem) 63 | any f (elem :: rest) | (Yes prfWhy) 64 | = Yes (H prfWhy) 65 | 66 | any f (elem :: rest) | (No msgWhyNot prfWhyNot) with (any f rest) 67 | any f (elem :: rest) | (No msgWhyNot prfWhyNot) | (Yes prfWhy) 68 | = Yes (T prfWhyNot prfWhy) 69 | any f (elem :: rest) | (No msgWhyNot prfWhyNot) | (No g) 70 | = No (isNotThere g prfWhyNot) 71 | 72 | -- [ EOF ] 73 | -------------------------------------------------------------------------------- /src/Toolkit/Data/DList/AtIndex.idr: -------------------------------------------------------------------------------- 1 | ||| Reasoning about elements in a DList based on their index. 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.Data.DList.AtIndex 7 | 8 | import Decidable.Equality 9 | 10 | import Toolkit.Decidable.Informative 11 | 12 | import Toolkit.Data.List.AtIndex 13 | import Toolkit.Data.DList 14 | 15 | %default total 16 | 17 | 18 | ||| Proof that some element satisfies the predicate 19 | ||| 20 | ||| @idx The type of the element's index. 21 | ||| @type The type of the list element. 22 | ||| @p A predicate 23 | ||| @xs The list itself. 24 | public export 25 | data HoldsAtIndex : (type : Type) 26 | -> (item : type -> Type) 27 | -> (p : {i : type} -> (x : item i) -> Type) 28 | -> {is : List type} 29 | -> (xs : DList type item is) 30 | -> (idx : Nat) 31 | -> Type 32 | where 33 | ||| Proof that the element is at the front of the list. 34 | Here : {p : {i : type} -> (x : item i) -> Type} 35 | -> {i : type} 36 | -> {x : item i} 37 | -> (prf : p x) 38 | -> HoldsAtIndex type item p (x::xs) Z 39 | 40 | 41 | ||| Proof that the element is found later in the list. 42 | There : {p : {i : type} -> (x : item i) -> Type} 43 | -> (contra : p x' -> Void) 44 | -> (later : HoldsAtIndex type item p xs loc) 45 | -> HoldsAtIndex type item p (x'::xs) (S loc) 46 | 47 | namespace Find 48 | namespace HoldsAtIndex 49 | public export 50 | data Error type = IsEmpty 51 | | Later type (HoldsAtIndex.Error type) 52 | 53 | isEmpty : {p : {i : type} -> (x : item i) -> Type} 54 | -> DPair Nat (HoldsAtIndex type item p []) 55 | -> Void 56 | isEmpty (MkDPair loc prf) with (prf) 57 | isEmpty (MkDPair loc prf) | (MkDPair _ (Here _)) impossible 58 | isEmpty (MkDPair loc prf) | (MkDPair _ (There _)) impossible 59 | 60 | 61 | notLater : {p : {i : type} -> (x : item i) -> Type} 62 | -> (DPair Nat (HoldsAtIndex type item p rest) -> Void) 63 | -> (p i -> Void) 64 | -> DPair Nat (HoldsAtIndex type item p (i :: rest)) 65 | -> Void 66 | notLater f g (MkDPair _ (Here prf)) 67 | = g prf 68 | notLater f g (MkDPair _ (There contra later)) 69 | = f (MkDPair _ later) 70 | 71 | export 72 | holdsAtIndex : {p : {i : type} -> (x : item i) -> Type} 73 | -> (f : {i : type} -> (x : item i) -> DecInfo err (p x)) 74 | -> (xs : DList type item is) 75 | -> DecInfo (HoldsAtIndex.Error err) 76 | (DPair Nat (HoldsAtIndex type item p xs)) 77 | holdsAtIndex f Nil 78 | = No IsEmpty (isEmpty) 79 | 80 | holdsAtIndex f (x :: y) with (f x) 81 | holdsAtIndex f (x :: y) | (Yes prf) 82 | = Yes (MkDPair 0 (Here prf)) 83 | 84 | holdsAtIndex f (x :: y) | (No msg contra) with (holdsAtIndex f y) 85 | holdsAtIndex f (x :: y) | (No msg contra) | (Yes (MkDPair loc prf)) 86 | = Yes (MkDPair (S loc) (There contra prf)) 87 | 88 | holdsAtIndex f (x :: y) | (No msg contra) | (No msgR contraR) 89 | = No (Later msg msgR) 90 | (notLater contraR contra) 91 | 92 | 93 | -- [ EOF ] 94 | -------------------------------------------------------------------------------- /src/Toolkit/Data/DList/Elem.idr: -------------------------------------------------------------------------------- 1 | ||| The Elem list quantifier for the DList quantifier. 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.Data.DList.Elem 7 | 8 | import Toolkit.Data.DList 9 | 10 | import public Toolkit.Decidable.Equality.Indexed 11 | 12 | %default total 13 | 14 | ||| Proof that some element is found in a `DList`. 15 | ||| 16 | ||| @iTy The type of the element's index. 17 | ||| @elemTy The type of the list element. 18 | ||| @x An element in the list. 19 | ||| @xs The list itself. 20 | ||| @prf Proof that the element's index is in the list in the same position as the element itself. 21 | public export 22 | data Elem : (iTy : Type) 23 | -> (elemTy : iTy -> Type) 24 | -> forall i, is 25 | . (x : elemTy i) 26 | -> (xs : DList iTy elemTy is) 27 | -> Type 28 | where 29 | ||| Proof that the element is at the front of the list. 30 | H : (Equals ity elemTy x y) -> Elem ity elemTy x (y :: xs) 31 | 32 | ||| Proof that the element is found later in the list. 33 | T : (later : Elem iTy elemTy x xs) 34 | -> Elem iTy elemTy x (x' ::xs) 35 | 36 | 37 | listEmpty : Elem type e thing Nil -> Void 38 | listEmpty (H x) impossible 39 | listEmpty (T later) impossible 40 | 41 | notInLater : (contraE : Equals type e x y -> Void) 42 | -> (contraR : Elem type e x xs -> Void) 43 | -> (prf : Elem type e x (y::xs)) 44 | -> Void 45 | notInLater contraE contraR (H z) = contraE z 46 | notInLater contraE contraR (T later) = contraR later 47 | 48 | 49 | export 50 | isElem : {type : Type} 51 | -> {e : type -> Type} 52 | -> DecEq type 53 | => DecEqIdx type e 54 | => {a : type} 55 | -> {as : List type} 56 | -> (thing : e a) 57 | -> (things : DList type e as) 58 | -> Dec (Elem type e thing things) 59 | isElem thing [] = No listEmpty 60 | isElem thing (elem :: rest) with (Index.decEq thing elem) 61 | isElem thing (thing :: rest) | (Yes (Same Refl Refl)) = Yes (H (Same Refl Refl)) 62 | isElem thing (elem :: rest) | (No contra) with (isElem thing rest) 63 | isElem thing (elem :: rest) | (No contra) | (Yes prf) = Yes (T prf) 64 | isElem thing (elem :: rest) | (No contra) | (No f) = No (notInLater contra f) 65 | -- [ EOF ] 66 | -------------------------------------------------------------------------------- /src/Toolkit/Data/DList/Interleaving.idr: -------------------------------------------------------------------------------- 1 | ||| Everything has a place. 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.Data.DList.Interleaving 7 | 8 | import public Toolkit.Data.List.Interleaving 9 | 10 | import Toolkit.Data.DList 11 | 12 | %default total 13 | 14 | public export 15 | data Interleaving : (a : Type) 16 | -> (type : a -> Type) 17 | -> {ls, rs, os : List a} 18 | -> (lefts : DList a type ls) 19 | -> (rights : DList a type rs) 20 | -> (orig : DList a type os) 21 | -> (prf : Interleaving ls rs os) 22 | -> Type 23 | where 24 | Empty : Interleaving a type Nil Nil Nil Empty 25 | 26 | Left : {a : Type} 27 | -> {type : a -> Type} 28 | -> {x : a} 29 | -> {xs, ys, zs : List a} 30 | -> {ls : DList a type xs} 31 | -> {rs : DList a type ys} 32 | -> {os : DList a type zs} 33 | -> {prf : Interleaving xs ys zs} 34 | -> (head : type x) 35 | -> (tail : Interleaving a type ls rs os prf) 36 | -> Interleaving a type (head::ls) rs (head::os) (x <:: prf) 37 | 38 | Right : {a : Type} 39 | -> {type : a -> Type} 40 | -> {y : a} 41 | -> {xs, ys, zs : List a} 42 | -> {ls : DList a type xs} 43 | -> {rs : DList a type ys} 44 | -> {os : DList a type zs} 45 | -> {prf : Interleaving xs ys zs} 46 | -> (head : type y) 47 | -> (tail : Interleaving a type ls rs os prf) 48 | -> Interleaving a type ls (head::rs) (head::os) (y ::> prf) 49 | 50 | (<::) : {a : Type} 51 | -> {type : a -> Type} 52 | -> {x : a} 53 | -> {xs, ys, zs : List a} 54 | -> {ls : DList a type xs} 55 | -> {rs : DList a type ys} 56 | -> {os : DList a type zs} 57 | -> {prf : Interleaving xs ys zs} 58 | -> (head : type x) 59 | -> (tail : Interleaving a type ls rs os prf) 60 | -> Interleaving a type (head::ls) rs (head::os) (x <:: prf) 61 | (<::) = Left 62 | 63 | (::>) : {a : Type} 64 | -> {type : a -> Type} 65 | -> {xs, ys, zs : List a} 66 | -> {ls : DList a type xs} 67 | -> {rs : DList a type ys} 68 | -> {os : DList a type zs} 69 | -> {prf : Interleaving xs ys zs} 70 | -> {y : a} 71 | -> (head : type y) 72 | -> (tail : Interleaving a type ls rs os prf) 73 | -> Interleaving a type ls (head::rs) (head::os) (y ::> prf) 74 | (::>) = Right 75 | -------------------------------------------------------------------------------- /src/Toolkit/Data/DVect.idr: -------------------------------------------------------------------------------- 1 | ||| A `list` construct to create lists of dependent types. 2 | ||| 3 | ||| One of the problems with using dependent types is that types 4 | ||| depend on values. This affects the ability to construct lists of 5 | ||| values that have a dependent type. The existing `List` type cannot 6 | ||| be used as it requires all elements to have the same type. 7 | ||| 8 | ||| Copyright : see COPYRIGHT 9 | ||| License : see LICENSE 10 | ||| 11 | module Toolkit.Data.DVect 12 | 13 | import Data.Nat 14 | import Data.String 15 | 16 | import public Data.Vect 17 | import public Data.Vect.Elem 18 | 19 | import public Toolkit.Decidable.Equality.Indexed 20 | 21 | %default total 22 | 23 | 24 | ||| A list construct for dependent types. 25 | ||| 26 | ||| @aTy The type of the value contained within the list element type. 27 | ||| @len The length of the list. 28 | ||| @elemTy The type of the elements within the list 29 | ||| @as The List used to contain the different values within the type. 30 | public export 31 | data DVect : (aTy : Type) 32 | -> (elemTy : aTy -> Type) 33 | -> (len : Nat) 34 | -> (as : Vect len aTy) 35 | -> Type where 36 | ||| Create an empty List 37 | Nil : DVect aTy elemTy Z Nil 38 | ||| Cons 39 | ||| 40 | ||| @ex The element to add 41 | ||| @rest The list for `elem` to be added to. 42 | (::) : {x : aTy} 43 | -> (ex : elemTy x) 44 | -> (rest : DVect aTy elemTy n xs) 45 | -> DVect aTy elemTy (S n) (x::xs) 46 | 47 | public export 48 | size : DVect a e l as -> Nat 49 | size Nil = Z 50 | size (x::xs) = 1 + size xs 51 | 52 | public export 53 | mapToVect : (forall x . e x -> b) 54 | -> DVect a e n xs 55 | -> Vect n b 56 | mapToVect _ Nil = Nil 57 | mapToVect f (x::xs) = f x :: mapToVect f xs 58 | 59 | toList : Vect q a -> List a 60 | toList Nil = Nil 61 | toList (x::xs) = x :: DVect.toList xs 62 | 63 | ||| Function to show a `DList`. 64 | ||| 65 | ||| Due to limitations in idris wrt to class instances on dependent 66 | ||| types a generic show instance cannot be defined for 67 | ||| sigmalist. This will cause minor annoyances in its use. 68 | ||| 69 | ||| @showFunc A function to show the elements 70 | ||| @l The list to be Shown. 71 | public export 72 | showDVect : (showFunc : forall a . elemTy a -> String) 73 | -> (l : DVect aTy elemTy n as) 74 | -> String 75 | showDVect f xs = "[" ++ unwords asList ++ "]" 76 | where 77 | asList : List String 78 | asList = DVect.toList $ intersperse "," (mapToVect f xs) 79 | 80 | namespace Alternative 81 | public export 82 | index : DVect aTy elemTy n as 83 | -> Elem a as 84 | -> elemTy a 85 | index (x::xs) Here = x 86 | index (x::xs) (There later) = index xs later 87 | 88 | public export 89 | update : (vs : DVect iTy eTy l is) 90 | -> (idx : Elem i is) 91 | -> (new : eTy i) 92 | -> DVect iTy eTy l is 93 | update (ex :: rest) Here new = new :: rest 94 | update (ex :: rest) (There later) new = ex :: update rest later new 95 | 96 | -- --------------------------------------------------------------------- [ EOF ] 97 | -------------------------------------------------------------------------------- /src/Toolkit/Data/DVect/Elem.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.DVect.Elem 6 | 7 | import Data.Vect 8 | 9 | import Toolkit.Data.DVect 10 | 11 | import public Toolkit.Decidable.Equality.Indexed 12 | 13 | %default total 14 | 15 | 16 | public export 17 | data Elem : (iTy : Type) 18 | -> (elemTy : iTy -> Type) 19 | -> forall i, is 20 | . (e : elemTy i) 21 | -> (es : DVect iTy elemTy l is) 22 | -> Type 23 | where 24 | H : Elem iTy eTy x (y::xs) 25 | T : (later : Elem iTy eTy x xs) 26 | -> Elem iTy eTy x (x'::xs) 27 | 28 | -- [ EOF ] 29 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Fin.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.Fin 6 | 7 | import public Decidable.Equality 8 | import public Data.Fin 9 | 10 | 11 | %default total 12 | 13 | namespace Safe 14 | 15 | ||| Safe nat to fin conversion 16 | public export 17 | data NatToFin : (n,m : Nat) -> Fin m -> Type where 18 | Here : NatToFin Z (S _) FZ 19 | There : NatToFin k j f 20 | -> NatToFin (S k) (S j) (FS f) 21 | 22 | bothZero : (f : Fin 0 ** NatToFin 0 0 f) -> Void 23 | bothZero (FZ ** _) impossible 24 | 25 | upZero : (f : Fin 0 ** NatToFin (S k) 0 f) -> Void 26 | upZero (FZ ** _) impossible 27 | 28 | export 29 | natToFin : (n,m : Nat) -> Dec (f : Fin m ** NatToFin n m f) 30 | natToFin 0 0 31 | = No bothZero 32 | natToFin 0 (S k) 33 | = Yes (FZ ** Here) 34 | 35 | natToFin (S k) 0 36 | = No upZero 37 | natToFin (S k) (S j) with (Safe.natToFin k j) 38 | natToFin (S k) (S j) | (Yes ((fst ** snd))) 39 | = Yes (FS fst ** There snd) 40 | natToFin (S k) (S j) | (No contra) 41 | = No (\(FS f ** There rest) => contra (f ** rest)) 42 | 43 | -- [ EOF ] 44 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Graph/EdgeBounded/DegreeCommon.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.Graph.EdgeBounded.DegreeCommon 6 | 7 | import Decidable.Equality 8 | 9 | import Data.String 10 | import Data.List.Elem 11 | import Data.List.Quantifiers 12 | 13 | import Toolkit.Decidable.Do 14 | import Toolkit.Decidable.Informative 15 | 16 | import Toolkit.Data.Nat 17 | import Toolkit.Data.Pair 18 | import Toolkit.Data.List.Size 19 | import Toolkit.Data.List.Occurs.Does 20 | 21 | %default total 22 | 23 | namespace HasDegree 24 | 25 | public export 26 | data DegreeType = I | O 27 | 28 | public export 29 | record Error where 30 | constructor MkError 31 | vertexID : Nat 32 | degType : DegreeType 33 | values : Occurs.Error 34 | 35 | -- [ EOF ] 36 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Graph/EdgeBounded/HasExactDegree/All.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.Graph.EdgeBounded.HasExactDegree.All 6 | 7 | import Decidable.Equality 8 | 9 | import Data.String 10 | import Data.List.Elem 11 | import Data.List.Quantifiers 12 | 13 | import Toolkit.Decidable.Do 14 | import Toolkit.Decidable.Informative 15 | 16 | import Toolkit.Data.Nat 17 | import Toolkit.Data.Pair 18 | import Toolkit.Data.List.Size 19 | import Toolkit.Data.List.Occurs.Does 20 | 21 | import Toolkit.Data.Graph.EdgeBounded 22 | 23 | import public Toolkit.Data.Graph.EdgeBounded.DegreeCommon 24 | import public Toolkit.Data.Graph.EdgeBounded.HasExactDegree 25 | 26 | %default total 27 | 28 | public export 29 | HasExactDegrees : Vertices type -> Edges -> Type 30 | HasExactDegrees vs es = All (\v => HasExactDegree v es) vs 31 | 32 | errorHead : {x : type} 33 | -> {p : type -> Type} 34 | -> (p x -> Void) 35 | -> All p (x :: xs) -> Void 36 | errorHead contra (y :: z) = contra y 37 | 38 | errorTail : (All p xs -> Void) -> All p (x :: xs) -> Void 39 | errorTail f (y :: z) = f z 40 | 41 | all : {type : Type} 42 | -> {p : type -> Type} 43 | -> (f : (x : type) -> DecInfo e (p x)) 44 | -> (xs : List type) 45 | -> DecInfo e (All p xs) 46 | all f [] = Yes [] 47 | all f (x :: xs) with (f x) 48 | all f (x :: xs) | (Yes prfWhy) with (all f xs) 49 | all f (x :: xs) | (Yes prfWhy) | (Yes y) 50 | = Yes (prfWhy :: y) 51 | all f (x :: xs) | (Yes prfWhy) | (No msgWhyNot prfWhyNot) 52 | = No msgWhyNot (errorTail prfWhyNot) 53 | 54 | all f (x :: xs) | (No msgWhyNot prfWhyNot) = No msgWhyNot (errorHead prfWhyNot) 55 | 56 | export 57 | hasExactDegrees : {type : Type} 58 | -> (vs : Vertices type) 59 | -> (es : Edges) 60 | -> DecInfo (HasExactDegree.Error type) 61 | (HasExactDegrees vs es) 62 | hasExactDegrees vs es = all (\v => hasExactDegree v es) vs 63 | 64 | -- [ EOF ] 65 | -------------------------------------------------------------------------------- /src/Toolkit/Data/List/Filter.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.List.Filter 6 | 7 | import Toolkit.Data.DList 8 | import Toolkit.Data.List.Interleaving 9 | 10 | %default total 11 | 12 | public export 13 | data Filter : (holdsFor : type -> Type) 14 | -> (input : List type) 15 | -> Type 16 | where 17 | MkFilter : {thrown : List type} 18 | -> (kept : List type) 19 | -> (prfOrdering : Interleaving kept thrown input) 20 | -> (prfKept : DList type holdsFor kept) 21 | -> (prfThrown : DList type (Not . holdsFor) thrown) 22 | -> Filter holdsFor input 23 | 24 | export 25 | filter : (test : (value : type) -> Dec (holds value)) 26 | -> (input : List type) 27 | -> Filter holds input 28 | filter test [] = MkFilter [] Empty [] [] 29 | filter test (x :: xs) with (filter test xs) 30 | filter test (x :: xs) | (MkFilter kept prfOrdering prfKept prfThrown) with (test x) 31 | filter test (x :: xs) | (MkFilter kept prfOrdering prfKept prfThrown) | (Yes prf) 32 | = MkFilter (x::kept) (Left x prfOrdering) (prf :: prfKept) prfThrown 33 | filter test (x :: xs) | (MkFilter kept prfOrdering prfKept prfThrown) | (No contra) 34 | = MkFilter kept (Right x prfOrdering) prfKept (contra :: prfThrown) 35 | 36 | export 37 | extract : Filter p xs 38 | -> (ks ** DList type p ks) 39 | extract (MkFilter kept prfOrdering prfKept prfThrown) 40 | = (kept ** prfKept) 41 | 42 | 43 | -- [ EOF ] 44 | -------------------------------------------------------------------------------- /src/Toolkit/Data/List/Interleaving.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.List.Interleaving 6 | 7 | %default total 8 | 9 | infixr 6 <:: 10 | infixr 6 ::> 11 | 12 | public export 13 | data Interleaving : (xs, ys, zs : List type) -> Type where 14 | Empty : Interleaving Nil Nil Nil 15 | 16 | Left : {xs,ys,zs : List type} 17 | -> (x : type) 18 | -> (rest : Interleaving xs ys zs) 19 | -> Interleaving (x::xs) ys (x::zs) 20 | Right : {xs,ys,zs : List type} 21 | -> (y : type) 22 | -> (rest : Interleaving xs ys zs) 23 | -> Interleaving xs (y::ys) (y::zs) 24 | 25 | public export 26 | (<::) : {xs,ys,zs : List type} 27 | -> (x : type) 28 | -> (rest : Interleaving xs ys zs) 29 | -> Interleaving (x::xs) ys (x::zs) 30 | (<::) = Left 31 | 32 | public export 33 | (::>) : {xs,ys,zs : List type} 34 | -> (y : type) 35 | -> (rest : Interleaving xs ys zs) 36 | -> Interleaving xs (y::ys) (y::zs) 37 | (::>) = Right 38 | -------------------------------------------------------------------------------- /src/Toolkit/Data/List/Occurs.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.List.Occurs 6 | 7 | import Decidable.Equality 8 | 9 | import Toolkit.Decidable.Informative 10 | 11 | import Toolkit.Data.Nat 12 | import Toolkit.Data.DList 13 | import Toolkit.Data.List.Size 14 | import Toolkit.Data.List.Interleaving 15 | 16 | %default total 17 | 18 | 19 | public export 20 | data Occurs : (type : Type) 21 | -> (p : type -> Type) 22 | -> (xs : List type) 23 | -> (cy : Nat) 24 | -> (cn : Nat) 25 | -> Type 26 | where 27 | O : (thrown : List type) 28 | -> (sizeThrown : Size thrown t) 29 | 30 | -> (kept : List type) 31 | -> (sizeKept : Size kept k) 32 | 33 | -> (prfOrigin : Interleaving kept thrown input) 34 | 35 | -> (prfKept : DList type holdsFor kept) 36 | -> (prfThrown : DList type (Not . holdsFor) throw) 37 | 38 | -> Occurs type holdsFor input k t 39 | 40 | namespace Result 41 | 42 | public export 43 | data Occurs : (type : Type) 44 | -> (p : type -> Type) 45 | -> (xs : List type) 46 | -> Type 47 | where 48 | O : {type : Type} 49 | -> {p : type -> Type} 50 | -> (xs : List type) 51 | -> (cy,cn : Nat) 52 | -> (prf : Occurs type p xs cy cn) 53 | -> Occurs type p xs 54 | 55 | 56 | export 57 | occurs : {type : Type} 58 | -> {p : type -> Type} 59 | -> (f : (this : type) -> Dec (p this)) 60 | -> (xs : List type) 61 | -> Occurs type p xs 62 | occurs f [] 63 | = O [] 0 0 (O [] Zero [] Zero Empty [] []) 64 | 65 | occurs f (x :: xs) with (f x) 66 | occurs f (x :: xs) | (Yes prf) with (occurs f xs) 67 | 68 | occurs f (x :: xs) | (Yes prf) | (O xs cy cn (O thrown sizeThrown kept sizeKept prfOrigin prfKept prfThrown)) 69 | = O (x::xs) (S cy) cn (O thrown sizeThrown (x :: kept) (PlusOne sizeKept) (Left x prfOrigin) (prf :: prfKept) prfThrown) 70 | 71 | occurs f (x :: xs) | (No not) with (occurs f xs) 72 | occurs f (x :: xs) | (No not) | (O xs cy cn (O thrown sizeThrown kept sizeKept prfOrigin prfKept prfThrown)) 73 | = O (x::xs) cy (S cn) (O (x :: thrown) (PlusOne sizeThrown) kept sizeKept (Right x prfOrigin) prfKept (not :: prfThrown)) 74 | 75 | -- [ EOF ] 76 | -------------------------------------------------------------------------------- /src/Toolkit/Data/List/Occurs/Does/Not.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.List.Occurs.Does.Not 6 | 7 | import Decidable.Equality 8 | 9 | import Toolkit.Decidable.Informative 10 | 11 | import Toolkit.Data.List.Occurs.Error 12 | 13 | 14 | %default total 15 | 16 | public export 17 | data Occurs : (type : Type) 18 | -> (p : type -> Type) 19 | -> (xs : List type) 20 | -> (cy : Nat) 21 | -> Type 22 | where 23 | End : Occurs type p Nil Z 24 | 25 | Yes : (holds : p x) 26 | -> (rest : Occurs type p xs cn) 27 | -> Occurs type p (x::xs) cn 28 | 29 | No : (nope : Not (p x)) 30 | -> (rest : Occurs type p xs cn) 31 | -> Occurs type p (x::xs) (S cn) 32 | 33 | export 34 | Uninhabited (Occurs type p Nil (S x)) where 35 | uninhabited End impossible 36 | uninhabited (Yes holds rest) impossible 37 | uninhabited (No nope rest) impossible 38 | 39 | namespace Exactly 40 | 41 | shouldBeZero : (p x -> Void) 42 | -> Does.Not.Occurs type p (x :: xs) 0 -> Void 43 | shouldBeZero f (Yes holds rest) = f holds 44 | 45 | 46 | shouldNotOccurMore : (Does.Not.Occurs type p xs k -> Void) 47 | -> (p x -> Void) 48 | -> Does.Not.Occurs type p (x :: xs) (S k) -> Void 49 | shouldNotOccurMore f g (Yes holds rest) = g holds 50 | shouldNotOccurMore f g (No nope rest) = f rest 51 | 52 | wrongOccursNot : (Does.Not.Occurs type p xs cn -> Void) 53 | -> p x 54 | -> Does.Not.Occurs type p (x :: xs) cn -> Void 55 | wrongOccursNot f y (Yes holds rest) = f rest 56 | wrongOccursNot f y (No nope rest) = nope y 57 | 58 | export 59 | doesNotExactlyOccur : {type : Type} 60 | -> {p : type -> Type} 61 | -> (f : (this : type) -> Dec (p this)) 62 | -> (xs : List type) 63 | -> (cn : Nat) 64 | -> DecInfo Occurs.Error 65 | (Does.Not.Occurs type p xs cn) 66 | doesNotExactlyOccur f [] Z 67 | = Yes End 68 | 69 | doesNotExactlyOccur f [] (S k) 70 | = No (MkError Z (S k)) 71 | absurd 72 | 73 | doesNotExactlyOccur f (x :: xs) cn with (f x) 74 | doesNotExactlyOccur f (x :: xs) cn | (Yes prf) with (doesNotExactlyOccur f xs cn) 75 | doesNotExactlyOccur f (x :: xs) cn | (Yes prf) | (Yes y) 76 | = Yes (Yes prf y) 77 | 78 | doesNotExactlyOccur f (x :: xs) cn | (Yes prf) | (No msg contra) 79 | = No (MkError cn (found msg)) 80 | (wrongOccursNot contra prf) 81 | 82 | doesNotExactlyOccur f (x :: xs) cn | (No contra) with (cn) 83 | 84 | doesNotExactlyOccur f (x :: xs) cn | (No contra) | 0 85 | = No (MkError cn Z) 86 | (shouldBeZero contra) 87 | 88 | doesNotExactlyOccur f (x :: xs) cn | (No contra) | (S k) with (doesNotExactlyOccur f xs k) 89 | doesNotExactlyOccur f (x :: xs) cn | (No contra) | (S k) | (Yes prf) 90 | = Yes (No contra prf) 91 | 92 | doesNotExactlyOccur f (x :: xs) cn | (No contra) | (S k) | (No msg g) 93 | = No (MkError cn (S k)) 94 | (shouldNotOccurMore g contra) 95 | 96 | 97 | -- [ EOF ] 98 | -------------------------------------------------------------------------------- /src/Toolkit/Data/List/Occurs/Error.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.List.Occurs.Error 6 | 7 | %default total 8 | 9 | namespace Occurs 10 | public export 11 | record Error where 12 | constructor MkError 13 | expected : Nat 14 | found : Nat 15 | 16 | 17 | -- [ EOF ] 18 | -------------------------------------------------------------------------------- /src/Toolkit/Data/List/Pointwise.idr: -------------------------------------------------------------------------------- 1 | module Toolkit.Data.List.Pointwise 2 | 3 | %default total 4 | 5 | public export 6 | data Pointwise : (r : a -> b -> Type) -> List a -> List b -> Type where 7 | Nil : Pointwise r [] [] 8 | (::) : {0 r : a -> b -> Type} -> 9 | r x y -> 10 | Pointwise r xs ys -> 11 | Pointwise r (x :: xs) (y :: ys) 12 | -------------------------------------------------------------------------------- /src/Toolkit/Data/List/Quantifiers.idr: -------------------------------------------------------------------------------- 1 | ||| Error returning quantifiers for Lists 2 | ||| 3 | ||| Module : Quantifiers.idr 4 | ||| Copyright : (c) Jan de Muijnck-Hughes 5 | ||| License : see LICENSE 6 | ||| 7 | module Toolkit.Data.List.Quantifiers 8 | 9 | import public Toolkit.Decidable.Informative 10 | 11 | import public Data.List.Quantifiers 12 | 13 | %default total 14 | 15 | namespace Relevant 16 | 17 | export 18 | map : ({x : a} -> p x -> q x) -> 19 | {xs : List a} -> All p xs -> All q xs 20 | map f [] = [] 21 | map f (px :: pxs) = f px :: map f pxs 22 | 23 | namespace Informative 24 | 25 | namespace All 26 | namespace NotAll 27 | public export 28 | data NotAll : (p : (x : type) -> Type) 29 | -> (e : (x : type) -> Type) 30 | -> (xs : List type) 31 | -> Type 32 | where 33 | Here : {0 e : (a : type) -> Type} 34 | -> { x : type} 35 | -> (msg : e x) 36 | -> (prf : p x -> Void) 37 | -> NotAll p e (x::xs) 38 | 39 | There : {0 p : (a : type) -> Type} 40 | -> ( prf : p x) 41 | -> ( later : NotAll p e xs) 42 | -> NotAll p e (x::xs) 43 | 44 | export 45 | position : NotAll p e xs -> Nat 46 | position (Here _ _) 47 | = Z 48 | position (There _ later) 49 | = S (position later) 50 | 51 | export 52 | error : NotAll p e xs -> (x ** e x) 53 | error (Here m _) 54 | = (_ ** m) 55 | error (There _ later) 56 | = error later 57 | 58 | export 59 | errorAt : NotAll p e xs -> (Nat, (x ** e x)) 60 | errorAt (Here msg _) 61 | = (Z, (_ ** msg)) 62 | 63 | errorAt (There _ later) with (errorAt later) 64 | errorAt (There _ later) | (loc, m) = (S loc, m) 65 | 66 | export 67 | all : (f : (x : a) 68 | -> DecInfo (e x) (p x)) 69 | -> (xs : List a) 70 | -> DecInfo (NotAll p e xs) 71 | (All p xs) 72 | all f [] 73 | = Yes [] 74 | 75 | all f (x :: xs) with (f x) 76 | all f (x :: xs) | (Yes pH) with (all f xs) 77 | all f (x :: xs) | (Yes pH) | (Yes pT) 78 | = Yes (pH :: pT) 79 | 80 | all f (x :: xs) | (Yes pH) | (No m c) 81 | = No (There pH m) 82 | (\(y::ys) => c ys) 83 | 84 | all f (x :: xs) | (No m c) 85 | = No (Here m c) 86 | (\(y::ys) => c y) 87 | 88 | -- [ EOF ] 89 | -------------------------------------------------------------------------------- /src/Toolkit/Data/List/Size.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.List.Size 6 | 7 | public export 8 | data Size : List a -> Nat -> Type where 9 | Zero : Size Nil Z 10 | PlusOne : Size rest k 11 | -> Size (e :: rest) (S k) 12 | 13 | export 14 | size' : (xs : List a) -> DPair Nat (Size xs) 15 | size' [] = MkDPair Z Zero 16 | size' (x :: xs) with (size' xs) 17 | size' (x :: xs) | (MkDPair k rest) = MkDPair (S k) (PlusOne rest) 18 | 19 | export 20 | size : (xs : List a) -> Size xs (length xs) 21 | size [] = Zero 22 | size (x :: xs) = PlusOne (size xs) 23 | 24 | Uninhabited (Size Nil (S x)) where 25 | uninhabited Zero impossible 26 | uninhabited (PlusOne x) impossible 27 | 28 | Uninhabited (Size (x::xs) Z) where 29 | uninhabited Zero impossible 30 | uninhabited (PlusOne x) impossible 31 | 32 | export 33 | hasSize : (xs : List a) -> (d : Nat) -> Dec (Size xs d) 34 | hasSize xs d with (xs) 35 | hasSize xs 0 | [] = Yes Zero 36 | hasSize xs (S k) | [] = No absurd 37 | 38 | hasSize xs 0 | (x :: ys) = No absurd 39 | hasSize xs (S k) | (x :: ys) with (hasSize ys k) 40 | hasSize xs (S k) | (x :: ys) | (Yes prf) = Yes (PlusOne prf) 41 | hasSize xs (S k) | (x :: ys) | (No contra) = No (\(PlusOne y) => contra y) 42 | 43 | 44 | -- [ EOF ] 45 | -------------------------------------------------------------------------------- /src/Toolkit/Data/List/Thinning.idr: -------------------------------------------------------------------------------- 1 | module Toolkit.Data.List.Thinning 2 | 3 | import public Toolkit.Data.List.Subset 4 | 5 | public export 6 | Thinning : (xs, ys : List a) -> Type 7 | Thinning = Subset (===) 8 | 9 | export 10 | Identity : {xs : List a} -> Thinning xs xs 11 | Identity {xs = []} = Empty 12 | Identity {xs = x :: xs} = Keep Refl Identity 13 | 14 | infixr 8 <.> 15 | export 16 | (<.>) : Thinning xs ys -> Thinning ys zs -> Thinning xs zs 17 | (<.>) = trans (\ eq1, eq2 => trans eq1 eq2) 18 | 19 | namespace Cover 20 | 21 | public export 22 | data Cover : (th : Thinning {a} xs1 ys) -> (ph : Thinning xs2 ys) -> Type where 23 | Empty : Cover Empty Empty 24 | Keep : Cover th ph -> Cover (Keep Refl th) (Keep Refl ph) 25 | SkipL : Cover th ph -> Cover (Skip th) (Keep Refl ph) 26 | SkipR : Cover th ph -> Cover (Keep eq th) (Skip ph) 27 | 28 | export 29 | coverDec : (th : Thinning {a} xs1 ys) -> (ph : Thinning xs2 ys) -> Dec (Cover th ph) 30 | coverDec Empty Empty = Yes Empty 31 | coverDec (Keep Refl th) (Keep Refl ph) with (coverDec th ph) 32 | _ | Yes p = Yes (Keep p) 33 | _ | No np = No (\ (Keep p) => void (np p)) 34 | coverDec (Keep eq th) (Skip ph) with (coverDec th ph) 35 | _ | Yes p = Yes (SkipR p) 36 | _ | No np = No (\ (SkipR p) => void (np p)) 37 | coverDec (Skip th) (Keep Refl ph) with (coverDec th ph) 38 | _ | Yes p = Yes (SkipL p) 39 | _ | No np = No (\ (SkipL p) => void (np p)) 40 | coverDec (Skip th) (Skip ph) = No (\case p impossible) 41 | 42 | namespace Join 43 | 44 | public export 45 | record Join 46 | {a : Type} {xs1, xs2, ys : List a} 47 | (th : Thinning xs1 ys) 48 | (ph : Thinning xs2 ys) where 49 | constructor MkJoin 50 | {union : List a} 51 | {left : Thinning xs1 union} 52 | middle : Thinning union ys 53 | {right : Thinning xs2 union} 54 | cover : Cover left right 55 | 56 | export 57 | join : {ys : _} -> (th : Thinning xs1 ys) -> (ph : Thinning xs2 ys) -> Join th ph 58 | join Empty Empty = MkJoin Empty Empty 59 | join (Keep Refl th) (Keep Refl ph) = 60 | let (MkJoin middle cover) = join th ph in 61 | MkJoin (Keep Refl middle) (Keep cover) 62 | join (Keep Refl th) (Skip ph) = 63 | let (MkJoin middle cover) = join th ph in 64 | MkJoin (Keep Refl middle) (SkipR {eq = Refl} cover) 65 | join (Skip th) (Keep Refl ph) = 66 | let (MkJoin middle cover) = join th ph in 67 | MkJoin (Keep Refl middle) (SkipL cover) 68 | join (Skip th) (Skip ph) = 69 | let (MkJoin middle cover) = join th ph in 70 | MkJoin (Skip middle) cover 71 | 72 | export 73 | none : {xs : List a} -> Thinning [] xs 74 | none {xs = []} = Empty 75 | none {xs = x :: xs} = Skip none 76 | 77 | export 78 | ones : {xs : List a} -> Thinning xs xs 79 | ones {xs = []} = Empty 80 | ones {xs = x :: xs} = Keep Refl ones 81 | -------------------------------------------------------------------------------- /src/Toolkit/Data/List/View/PairWise.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.List.View.PairWise 6 | 7 | import Data.List 8 | 9 | %default total 10 | 11 | public export 12 | data PairWise : List a -> Type where 13 | Empty : PairWise Nil 14 | One : (x:a) -> PairWise [x] 15 | Two : (x,y : a) -> PairWise [x,y] 16 | N : (x,y : a) 17 | -> PairWise (y::xs) 18 | -> PairWise (x::y::xs) 19 | 20 | 21 | export 22 | pairwise : (xs : List a) -> PairWise xs 23 | pairwise [] = Empty 24 | pairwise (x :: []) = One x 25 | pairwise (x :: (y :: xs)) with (pairwise (y::xs)) 26 | pairwise (x :: (y :: [])) | (One y) = Two x y 27 | pairwise (x :: (y :: [w])) | (Two y w) = N x y (Two y w) 28 | pairwise (x :: (y :: (w :: xs))) | (N y w v) = N x y (N y w v) 29 | 30 | unSafeToList : {xs : List a} -> PairWise xs -> Maybe (List (a,a)) 31 | unSafeToList Empty = Just Nil 32 | unSafeToList (One x) = Nothing 33 | unSafeToList (Two x y) = Just [(x,y)] 34 | unSafeToList (N x y z) 35 | = do rest <- unSafeToList z 36 | pure (MkPair x y :: rest) 37 | 38 | ||| Returns a list of pairs if `xs` has even number of elements, Nothing if odd. 39 | export 40 | unSafePairUp : (xs : List a) -> Maybe (List (a,a)) 41 | unSafePairUp xs = (unSafeToList (pairwise xs)) 42 | 43 | 44 | -- [ EOF ] 45 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Location.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.Location 6 | 7 | import Toolkit.Data.Nat 8 | 9 | %default total 10 | 11 | public export 12 | record Location where 13 | constructor MkLoc 14 | source : Maybe String 15 | line : Nat 16 | col : Nat 17 | 18 | public export 19 | record FileContext where 20 | constructor MkFC 21 | source : Maybe String 22 | start : Location 23 | end : Location 24 | 25 | public export 26 | record Ref where 27 | constructor MkRef 28 | span : FileContext 29 | get : String 30 | 31 | 32 | public export 33 | FC : Type 34 | FC = FileContext 35 | 36 | export 37 | newFC : Maybe String -> Location -> Location -> FileContext 38 | newFC n s e = MkFC n ({source := n} s) ({source := n} e) 39 | 40 | namespace FromCoords 41 | export 42 | newLoc : Maybe String -> (Nat, Nat) -> Location 43 | newLoc n (l,c) = MkLoc n l c 44 | 45 | export 46 | newFC : Maybe String -> (Nat, Nat) -> (Nat, Nat) -> FileContext 47 | newFC n s e = newFC n (newLoc n s) (newLoc n e) 48 | 49 | namespace Int 50 | export 51 | newLoc : Maybe String -> (Int, Int) -> Location 52 | newLoc n (l,c) = newLoc n (toNat l, toNat c) 53 | 54 | export 55 | newFC : Maybe String -> (Int , Int) -> (Int, Int) -> FileContext 56 | newFC n s e = newFC n (newLoc n s) (newLoc n e) 57 | 58 | namespace Anon 59 | 60 | export 61 | newLoc : (Nat, Nat) -> Location 62 | newLoc (l,c) = MkLoc Nothing l c 63 | 64 | export 65 | newFC : Location -> Location -> FileContext 66 | newFC s e = newFC Nothing s e 67 | 68 | export 69 | emptyFC : FileContext 70 | emptyFC = newFC Nothing (Z,Z) (Z,Z) 71 | 72 | export 73 | setSource : String -> FileContext -> FileContext 74 | setSource str fc 75 | = { source := Just str 76 | , start.source := Just str 77 | , end.source := Just str 78 | } fc 79 | 80 | namespace Ref 81 | 82 | export 83 | setSource : String -> Ref -> Ref 84 | setSource new ref = { span $= setSource new } ref 85 | 86 | export 87 | Show Location where 88 | show (MkLoc Nothing l c) = with List concat [show l, ":", show c] 89 | show (MkLoc (Just n) l c) = with List concat [n, ":", show l, ":", show c] 90 | 91 | export 92 | Show FileContext where 93 | show (MkFC Nothing (MkLoc _ l scol) (MkLoc _ _ ecol)) = with List concat ["global:", show (S l), ":", show (S scol), "-", show (S ecol), ":"] 94 | show (MkFC (Just x) (MkLoc _ l scol) (MkLoc _ _ ecol)) = with List concat [x, ":", show (S l), ":", show (S scol), "-", show (S ecol), ":"] 95 | 96 | -- [ EOF ] 97 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Nat.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.Nat 6 | 7 | import Decidable.Equality 8 | 9 | %default total 10 | 11 | public export 12 | toNat : Int -> Nat 13 | toNat = (integerToNat . cast) 14 | 15 | 16 | public export 17 | data Plus : (x,y,z : Nat) -> Type where 18 | Zero : Plus Z y y 19 | One : Plus n x z 20 | -> Plus (S n) x (S z) 21 | 22 | export 23 | plus : (x,y : Nat) -> DPair Nat (Plus x y) 24 | plus Z y 25 | = MkDPair y Zero 26 | 27 | plus (S k) y with (Nat.plus k y) 28 | plus (S k) y | (MkDPair fst snd) 29 | = MkDPair (S fst) (One snd) 30 | 31 | 32 | resWhenZeroIsMore : (y = z -> Void) -> Plus 0 y z -> Void 33 | resWhenZeroIsMore f Zero = f Refl 34 | 35 | resWhenOneIsZero : Plus (S k) y 0 -> Void 36 | resWhenOneIsZero Zero impossible 37 | resWhenOneIsZero (One x) impossible 38 | 39 | export 40 | isPlus : (x,y,z : Nat) -> Dec (Plus x y z) 41 | isPlus Z y z with (decEq y z) 42 | isPlus Z y y | (Yes Refl) 43 | = Yes Zero 44 | 45 | isPlus Z y z | (No contra) 46 | = No (resWhenZeroIsMore contra) 47 | 48 | isPlus (S k) y 0 = No resWhenOneIsZero 49 | 50 | isPlus (S k) y (S j) with (isPlus k y j) 51 | isPlus (S k) y (S j) | (Yes prf) 52 | = Yes (One prf) 53 | 54 | isPlus (S k) y (S j) | (No contra) 55 | = No (\(One prf) => contra prf) 56 | 57 | -- [ EOF ] 58 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Pair.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.Pair 6 | 7 | import Decidable.Equality 8 | 9 | %default total 10 | 11 | public export 12 | data IsFirst : (this : a) -> (that : Pair a b) -> Type where 13 | IF : (prf : x = y) 14 | -> IsFirst x (y,b) 15 | 16 | export 17 | isFirst : DecEq type 18 | => (this : type) 19 | -> (that : Pair type b) 20 | -> Dec (IsFirst this that) 21 | isFirst this (x, y) with (decEq this x) 22 | isFirst this (this, y) | (Yes Refl) 23 | = Yes (IF Refl) 24 | isFirst this (x, y) | (No contra) 25 | = No (\(IF Refl) => contra Refl) 26 | 27 | public export 28 | data IsSecond : (this : b) -> (that : Pair a b) -> Type where 29 | IS : (prf : x = y) 30 | -> IsSecond x (a,y) 31 | 32 | export 33 | isSecond : DecEq type 34 | => (this : type) 35 | -> (that : Pair a type) 36 | -> Dec (IsSecond this that) 37 | isSecond this (x, y) with (decEq this y) 38 | isSecond this (x, this) | (Yes Refl) 39 | = Yes (IS Refl) 40 | isSecond this (x, y) | (No contra) 41 | = No (\(IS Refl) => contra Refl) 42 | 43 | -- [ EOF ] 44 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Relation.idr: -------------------------------------------------------------------------------- 1 | ||| Borrowed from Frex until Frex and Toolkit's Data are merged into 2 | ||| contrib or elsewhere in Idris2's libs/ dir. 3 | module Toolkit.Data.Relation 4 | 5 | %default total 6 | 7 | public export 8 | 0 9 | Pred : Type -> Type 10 | Pred a = a -> Type 11 | 12 | public export 13 | 0 14 | Rel : Type -> Type 15 | Rel a = a -> a -> Type 16 | 17 | infix 5 ~> 18 | public export 19 | 0 20 | (~>) : Rel a -> Rel a -> Type 21 | p ~> q = {x, y : a} -> p x y -> q x y 22 | 23 | -- [ EOF ] 24 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Relation/List.idr: -------------------------------------------------------------------------------- 1 | ||| Borrowed from Frex until Frex and Toolkit's Data are merged into 2 | ||| contrib or elsewhere in Idris2's libs/ dir. 3 | module Toolkit.Data.Relation.List 4 | 5 | 6 | import Decidable.Equality 7 | import Data.SnocList -- only for the (<>>) fixity declaration 8 | import Data.SortedMap.Dependent 9 | 10 | import Toolkit.Data.Relation 11 | 12 | %default total 13 | 14 | public export 15 | data RTList : Rel a -> Rel a where 16 | Nil : RTList r x x 17 | (::) : {0 r : Rel a} -> {y : a} 18 | -> r x y -> RTList r y z 19 | -> RTList r x z 20 | 21 | public export 22 | data SnocRTList : Rel a -> Rel a where 23 | Lin : SnocRTList r x x 24 | (:<) : {0 r : Rel a} -> {y : a} -> SnocRTList r x y -> r y z -> SnocRTList r x z 25 | 26 | export 27 | (<>>) : {y : a} -> SnocRTList r x y -> RTList r y z -> RTList r x z 28 | [<] <>> acc = acc 29 | (rs :< r) <>> acc = rs <>> r :: acc 30 | 31 | export 32 | reflexive : (===) ~> RTList r 33 | reflexive Refl = [] 34 | 35 | export 36 | (++) : RTList r x y -> RTList r y z -> RTList r x z 37 | [] ++ ys = ys 38 | (x :: xs) ++ ys = x :: xs ++ ys 39 | 40 | export 41 | concat : RTList (RTList r) ~> RTList r 42 | concat [] = [] 43 | concat (xs :: xss) = xs ++ concat xss 44 | 45 | export 46 | gmap : (f : a -> b) -> p ~> (q `on` f) -> RTList p ~> (RTList q `on` f) 47 | gmap _ f [] = [] 48 | gmap _ f (x :: xs) = f x :: gmap _ f xs 49 | 50 | export 51 | map : (p ~> q) -> RTList p ~> RTList q 52 | map = gmap id 53 | 54 | export 55 | reverseAcc : {y : a} -> (r ~> flip s) -> 56 | flip (RTList s) x y -> RTList r y z -> 57 | flip (RTList s) x z 58 | reverseAcc f acc [] = acc 59 | reverseAcc f acc (x :: xs) = reverseAcc f (f x :: acc) xs 60 | 61 | export 62 | reverse : (r ~> flip s) -> RTList r ~> flip (RTList s) 63 | reverse f = reverseAcc f [] 64 | 65 | ||| Deloop detects whenever a proof forms a loop, and removes it e.g. 66 | ||| 67 | ||| x7 <-r- x6 <-r- x5 68 | ||| | ^ 69 | ||| r r 70 | ||| v | 71 | ||| x1 -r-> x2 -r-> x3 -r-> x4 -r-> x8 72 | ||| 73 | ||| becomes 74 | ||| 75 | ||| x1 -r-> x2 -r-> x3 -r-> x4 -r-> x8 76 | 77 | export 78 | deloop : (Ord a, DecEq a) => RTList {a} r ~> RTList r 79 | deloop = go {begin = x} (singleton x (0, [<])) (0, [<]) where 80 | 81 | -- Invariant: the accumulator contains the shortest subproofs for all 82 | -- of the values encountered on the way to middle. 83 | -- The candidate witnesses the fact that we always have a proof for the 84 | -- path we've already trodden from begin to middle. It is the shortest 85 | -- currently known such proof. 86 | go : {begin, middle, end : a} -> 87 | SortedDMap a (\ end => (Nat, SnocRTList r begin end)) -> 88 | (Nat, SnocRTList r begin middle) -> 89 | RTList r middle end -> RTList r begin end 90 | go _ (_, prf) [] = prf <>> [] 91 | go acc (n, nprf) ((r :: rs) {y = nextMiddle}) = 92 | let snprf := (S n, nprf :< r) in 93 | case lookupPrecise nextMiddle acc of 94 | -- We have a hit: is it a smaller proof? 95 | -- We may have taken a different, shorter, path this time! 96 | Just (m, mprf) => 97 | ifThenElse (m <= n) 98 | (go acc (m, mprf) rs) 99 | (go (insert nextMiddle snprf acc) snprf rs) 100 | -- No hit: the current candidate is our best bet 101 | Nothing => go (insert nextMiddle snprf acc) snprf rs 102 | 103 | -- [ EOF ] 104 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Rig.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Data.Rig 6 | 7 | import public Decidable.Equality 8 | import public Data.Vect 9 | 10 | %default total 11 | 12 | public export 13 | data TyRig = None | One | Tonne 14 | 15 | public export 16 | noneNotOne : (None = One) -> Void 17 | noneNotOne Refl impossible 18 | 19 | public export 20 | noneNotTonne : (None = Tonne) -> Void 21 | noneNotTonne Refl impossible 22 | 23 | public export 24 | oneNotTonne : (One = Tonne) -> Void 25 | oneNotTonne Refl impossible 26 | 27 | public export 28 | DecEq TyRig where 29 | decEq None None = Yes Refl 30 | decEq None One = No noneNotOne 31 | decEq None Tonne = No noneNotTonne 32 | decEq One None = No (negEqSym noneNotOne) 33 | decEq One One = Yes Refl 34 | decEq One Tonne = No oneNotTonne 35 | decEq Tonne None = No (negEqSym noneNotTonne) 36 | decEq Tonne One = No (negEqSym oneNotTonne) 37 | decEq Tonne Tonne = Yes Refl 38 | 39 | 40 | public export 41 | plus : TyRig -> TyRig -> TyRig 42 | plus None None = None 43 | plus None One = One 44 | plus None Tonne = Tonne 45 | plus One None = One 46 | plus One One = Tonne 47 | plus One Tonne = Tonne 48 | plus Tonne None = Tonne 49 | plus Tonne One = Tonne 50 | plus Tonne Tonne = Tonne 51 | 52 | public export 53 | multiply : TyRig -> TyRig -> TyRig 54 | multiply None None = None 55 | multiply None One = None 56 | multiply None Tonne = None 57 | multiply One None = None 58 | multiply One One = One 59 | multiply One Tonne = Tonne 60 | multiply Tonne None = None 61 | multiply Tonne One = Tonne 62 | multiply Tonne Tonne = Tonne 63 | 64 | public export 65 | product : Vect n TyRig -> Vect n TyRig -> Vect n TyRig 66 | product [] [] = [] 67 | product (x :: xs) (y :: ys) = multiply x y :: product xs ys 68 | 69 | public export 70 | sum : Vect n TyRig -> Vect n TyRig -> Vect n TyRig 71 | sum [] [] = [] 72 | sum (x :: xs) (y :: ys) = plus x y :: sum xs ys 73 | -------------------------------------------------------------------------------- /src/Toolkit/Data/SnocList/Quantifiers.idr: -------------------------------------------------------------------------------- 1 | module Toolkit.Data.SnocList.Quantifiers 2 | 3 | import Data.List.Quantifiers 4 | import public Data.SnocList.Quantifiers 5 | 6 | %default total 7 | 8 | export 9 | (<>>) : All p sx -> All p xs -> All p (sx <>> xs) 10 | [<] <>> pxs = pxs 11 | (psx :< px) <>> pxs = psx <>> (px :: pxs) 12 | 13 | export 14 | (<><) : All p sx -> All p xs -> All p (sx <>< xs) 15 | psx <>< [] = psx 16 | psx <>< (px :: pxs) = (psx :< px) <>< pxs 17 | 18 | export 19 | unzipWith : (a -> (x : b ** p x)) -> 20 | List a -> 21 | (xs : SnocList b ** All p xs) 22 | unzipWith f = go ([<] ** [<]) where 23 | 24 | go : (xs : SnocList b ** All p xs) -> 25 | List a -> 26 | (xs : SnocList b ** All p xs) 27 | go acc [] = acc 28 | go (ys ** pys) (x :: xs) = 29 | let (y ** py) = f x in 30 | go (ys :< y ** pys :< py) xs 31 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Spaces.idr: -------------------------------------------------------------------------------- 1 | ||| Easing working with n-dimensional vectors. 2 | ||| 3 | ||| 4 | ||| Copyright : see COPYRIGHT 5 | ||| License : see LICENSE 6 | ||| 7 | module Toolkit.Data.Spaces 8 | 9 | import public Decidable.Equality 10 | import Data.Vect 11 | 12 | import public Data.Fin 13 | import public Toolkit.Data.DList 14 | 15 | import public Toolkit.Data.Vect.Extra 16 | 17 | public export 18 | Indices : List Nat -> Type 19 | Indices = DList Nat Fin 20 | 21 | -- [ EOF ] 22 | -------------------------------------------------------------------------------- /src/Toolkit/Data/Vect/Quantifiers.idr: -------------------------------------------------------------------------------- 1 | ||| Error returning quantifiers for Vectors 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.Data.Vect.Quantifiers 7 | 8 | import public Toolkit.Decidable.Informative 9 | import Data.Vect 10 | 11 | import Data.Vect.Quantifiers 12 | import Data.Vect.AtIndex 13 | 14 | %default total 15 | 16 | namespace Informative 17 | 18 | namespace All 19 | namespace NotAll 20 | public export 21 | data NotAll : (p : (x : type) -> Type) 22 | -> (e : (x : type) -> Type) 23 | -> (xs : Vect n type) 24 | -> Type 25 | where 26 | Here : {0 e : (a : type) -> Type} 27 | -> { x : type} 28 | -> (msg : e x) 29 | -> (prf : p x -> Void) 30 | -> NotAll p e (x::xs) 31 | 32 | There : {0 p : (a : type) -> Type} 33 | -> ( prf : p x) 34 | -> ( later : NotAll p e xs) 35 | -> NotAll p e (x::xs) 36 | 37 | export 38 | position : NotAll p e xs -> Nat 39 | position (Here _ _) 40 | = Z 41 | position (There _ later) 42 | = S (position later) 43 | 44 | export 45 | error : NotAll p e xs -> (x ** e x) 46 | error (Here m _) 47 | = (_ ** m) 48 | error (There _ later) 49 | = error later 50 | 51 | export 52 | errorAt : NotAll p e xs -> (Nat, (x ** e x)) 53 | errorAt (Here msg _) 54 | = (Z, (_ ** msg)) 55 | 56 | errorAt (There _ later) with (errorAt later) 57 | errorAt (There _ later) | (loc, m) = (S loc, m) 58 | 59 | export 60 | all : (f : (x : a) 61 | -> DecInfo (e x) (p x)) 62 | -> (xs : Vect n a) 63 | -> DecInfo (NotAll p e xs) 64 | (All p xs) 65 | all f [] 66 | = Yes [] 67 | 68 | all f (x :: xs) with (f x) 69 | all f (x :: xs) | (Yes pH) with (all f xs) 70 | all f (x :: xs) | (Yes pH) | (Yes pT) 71 | = Yes (pH :: pT) 72 | 73 | all f (x :: xs) | (Yes pH) | (No m c) 74 | = No (There pH m) 75 | (\(y::ys) => c ys) 76 | 77 | all f (x :: xs) | (No m c) 78 | = No (Here m c) 79 | (\(y::ys) => c y) 80 | 81 | -- [ EOF ] 82 | -------------------------------------------------------------------------------- /src/Toolkit/DeBruijn/Environment.idr: -------------------------------------------------------------------------------- 1 | ||| Environments. 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.DeBruijn.Environment 7 | 8 | import Decidable.Equality 9 | 10 | import Data.DPair 11 | 12 | import Toolkit.Decidable.Informative 13 | 14 | import Toolkit.Data.List.AtIndex 15 | import Toolkit.Data.DList 16 | import Toolkit.Data.DList.AtIndex 17 | 18 | import Toolkit.DeBruijn.Context.Item 19 | import Toolkit.DeBruijn.Context 20 | import Toolkit.DeBruijn.Renaming 21 | 22 | %default total 23 | 24 | ||| Sometimes it is bettern to think that we have this thing called an 25 | ||| environment and not a `DList`. 26 | ||| 27 | ||| @t The Type for Types in our environment. 28 | ||| @obj How we interpret the types in our DSL. Either this is a 29 | ||| dependent type or a function that computes a type. 30 | ||| @ctxt The typing context. 31 | public export 32 | Env : (t : Type) -> (obj : t -> Type) -> (ctxt : List t) -> Type 33 | Env = DList 34 | 35 | ||| Add an object to our execution environment. 36 | ||| @env The typing environment. 37 | export 38 | extend : {t : ty} 39 | -> (env : Env ty e ctxt) 40 | -> (obj : e t) 41 | -> Env ty e (t::ctxt) 42 | extend env obj = obj :: env 43 | 44 | namespace Elem 45 | ||| Read an object from our typing environment. 46 | ||| 47 | ||| @idx Which object. 48 | ||| @env The execution environment. 49 | export 50 | read : (idx : Elem t ctxt) 51 | -> (env : Env ty e ctxt) 52 | -> e t 53 | read Here (obj::store) = obj 54 | read (There x) (obj::store) = read x store 55 | 56 | ||| Add an object to our execution environment. 57 | ||| 58 | ||| @idx Where the object is. 59 | ||| @obj The new object. 60 | ||| @env The environment to which the object is added. 61 | export 62 | update : (idx : Elem t ctxt) 63 | -> (obj : e t) 64 | -> (env : Env ty e ctxt) 65 | -> Env ty e ctxt 66 | update Here obj (_ :: store) = obj :: store 67 | update (There x) obj (obj' :: store) = obj' :: update x obj store 68 | 69 | namespace IsVar 70 | ||| Read an object from our typing environment. 71 | ||| 72 | ||| @idx Which object. 73 | ||| @env The execution environment. 74 | export 75 | read : (idx : IsVar ctxt t) 76 | -> (env : Env ty e ctxt) 77 | -> e t 78 | read (V 0 Here) (elem :: rest) 79 | = elem 80 | read (V (S idx) (There later)) (elem :: rest) 81 | = read (V idx later) rest 82 | 83 | ||| Add an object to our execution environment. 84 | ||| 85 | ||| @idx Where the object is. 86 | ||| @obj The new object. 87 | ||| @env The environment to which the object is added. 88 | export 89 | update : (idx : IsVar ctxt t) 90 | -> (obj : e t) 91 | -> (env : Env ty e ctxt) 92 | -> Env ty e ctxt 93 | update (V 0 Here) obj (elem :: rest) 94 | = obj :: rest 95 | update (V (S k) (There later)) obj (elem :: rest) 96 | = elem :: update (V k later) obj rest 97 | 98 | -- [ EOF ] 99 | -------------------------------------------------------------------------------- /src/Toolkit/DeBruijn/Evaluation.idr: -------------------------------------------------------------------------------- 1 | ||| How to replace things. 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.DeBruijn.Evaluation 7 | 8 | import Data.Fuel 9 | 10 | import public Toolkit.Data.Relation 11 | import public Toolkit.Data.Relation.List 12 | import Toolkit.DeBruijn.Progress 13 | 14 | %default total 15 | 16 | public export 17 | 0 Reduces : (0 redux : Rel a) 18 | -> (this, that : a) 19 | -> Type 20 | Reduces redux = RTList redux 21 | 22 | public export 23 | data Evaluate : (0 value : Pred a) 24 | -> (0 redux : Rel a) 25 | -> (v : a) 26 | -> Type 27 | where -- 28 | RunEval : {tm, val : a} 29 | -> (steps : Reduces redux tm val) 30 | -> (result : Maybe (value val)) 31 | -> Evaluate value redux tm 32 | 33 | 34 | export 35 | evaluate : {0 a : Type} 36 | -> {0 value : Pred a} 37 | -> {0 redux : Rel a} 38 | -> Progressable a value redux 39 | => (fuel : Fuel) 40 | -> (tm : a) 41 | -> Evaluate value redux tm 42 | evaluate Dry term 43 | = RunEval Nil Nothing 44 | evaluate (More fuel) term with (progress term) 45 | evaluate (More fuel) term | (Done val) 46 | = RunEval Nil (Just val) 47 | evaluate (More fuel) term | (Step step {that}) with (evaluate fuel that) 48 | evaluate (More fuel) term | (Step step {that = that}) | (RunEval steps result) 49 | = RunEval (step :: steps) result 50 | 51 | public export 52 | data Result : (0 value : Pred a) 53 | -> (0 redux : Rel a) 54 | -> (this : a) 55 | -> Type 56 | where 57 | R : (that : a) 58 | -> (val : value that) 59 | -> (steps : Reduces redux this that) 60 | -> Result value redux this 61 | 62 | export covering 63 | eval : Progressable a value redux 64 | => (this : a) -> Maybe (Result value redux this) 65 | 66 | eval this with (evaluate forever this) 67 | eval this | (RunEval steps (Just val)) 68 | = Just (R _ -- reduce term is magiced in 69 | val -- prf it is a val 70 | steps) 71 | eval this | (RunEval steps Nothing) = Nothing 72 | 73 | -- [ EOF ] 74 | -------------------------------------------------------------------------------- /src/Toolkit/DeBruijn/Progress.idr: -------------------------------------------------------------------------------- 1 | ||| How to replace things. 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.DeBruijn.Progress 7 | 8 | import public Toolkit.Data.Relation 9 | 10 | %default total 11 | 12 | public export 13 | data Progress : (0 value : Pred a) 14 | -> (0 redux : Rel a) 15 | -> (tm : a) 16 | -> Type 17 | where 18 | Done : {0 tm : a} 19 | -> (val : value tm) 20 | -> Progress value redux tm 21 | 22 | Step : {this, that : a} 23 | -> (step : redux this that) 24 | -> Progress value redux this 25 | 26 | 27 | public export 28 | interface Progressable (0 a : Type) 29 | (0 value : Pred a) 30 | (0 redux : Rel a) 31 | | a 32 | where 33 | progress : (tm : a) 34 | -> Progress value redux tm 35 | 36 | -- [ EOF ] 37 | -------------------------------------------------------------------------------- /src/Toolkit/DeBruijn/Renaming.idr: -------------------------------------------------------------------------------- 1 | ||| How to rename things 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.DeBruijn.Renaming 7 | 8 | import Toolkit.Data.SnocList.AtIndex 9 | import public Toolkit.DeBruijn.Variable 10 | 11 | %default total 12 | 13 | 14 | public export 15 | interface Rename (0 type : Type) (0 term : SnocList type -> type -> Type) | term where 16 | rename : {0 old, new : SnocList type} 17 | -> (f : {0 ty : type} -> IsVar old ty 18 | -> IsVar new ty) 19 | -> ({0 ty : type} -> term old ty 20 | -> term new ty) 21 | 22 | %inline 23 | embed : {0 ty : type} 24 | -> {0 ctxt : SnocList type} 25 | -> IsVar ctxt ty 26 | -> term ctxt ty 27 | 28 | public export 29 | %inline 30 | weakens : {0 type : Type} 31 | -> {0 term : SnocList type -> type -> Type} 32 | -> Rename type term 33 | => {0 old, new : SnocList type} 34 | -> (f : {0 ty : type} 35 | -> IsVar old ty 36 | -> term new ty) 37 | -> ({0 ty,type' : type} 38 | -> IsVar (old :< type') ty 39 | -> term (new :< type') ty) 40 | 41 | weakens f v@_ with (view v) 42 | _ | Here 43 | = embed here 44 | _ | There w 45 | = rename shift (f w) 46 | 47 | -- [ EOF ] 48 | -------------------------------------------------------------------------------- /src/Toolkit/DeBruijn/Substitution.idr: -------------------------------------------------------------------------------- 1 | ||| How to replace things. 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.DeBruijn.Substitution 7 | 8 | import Decidable.Equality 9 | 10 | import Data.DPair 11 | 12 | import Toolkit.Decidable.Informative 13 | 14 | import Toolkit.DeBruijn.Variable 15 | import Toolkit.DeBruijn.Context 16 | import Toolkit.DeBruijn.Renaming 17 | import Toolkit.Item 18 | 19 | %default total 20 | 21 | namespace General 22 | public export 23 | interface Rename type term 24 | => Substitute (0 type : Type) 25 | (0 term : SnocList type -> type -> Type) 26 | | term 27 | where 28 | 29 | subst : {0 old, new : SnocList type} 30 | -> (f : {0 ty : type} 31 | -> IsVar old ty 32 | -> term new ty) 33 | -> ({0 ty : type} 34 | -> term old ty 35 | -> term new ty) 36 | 37 | namespace Single 38 | %inline 39 | apply : {0 type : Type} 40 | -> {0 term : SnocList type -> type -> Type} 41 | -> Rename type term 42 | => {0 ctxt : SnocList type} 43 | -> {0 typeA : type} 44 | -> {0 typeB : type} 45 | -> (this : term ctxt typeB) 46 | -> (idx : IsVar (ctxt :< typeB) typeA) 47 | -> term ctxt typeA 48 | apply this v@_ with (view v) 49 | _ | Here = this 50 | _ | There w = embed w 51 | 52 | export 53 | subst : {0 type : Type} 54 | -> {0 term : SnocList type -> type -> Type} 55 | -> Rename type term 56 | => Substitute type term 57 | => {0 ctxt : SnocList type} 58 | -> {0 typeA : type} 59 | -> {0 typeB : type} 60 | -> (this : term ctxt typeB) 61 | -> (inThis : term (ctxt :< typeB) typeA) 62 | -> term ctxt typeA 63 | subst {ctxt} {typeA} {typeB} this inThis 64 | = General.subst (apply this) inThis 65 | 66 | namespace Double 67 | 68 | %inline 69 | public export 70 | apply : {0 type : Type} 71 | -> {0 term : SnocList type -> type -> Type} 72 | -> Rename type term 73 | => {0 ctxt : SnocList type} 74 | -> {0 typeA, typeB, typeC : type} 75 | -> (this : term ctxt typeA) 76 | -> (andThis : term ctxt typeB) 77 | -> (idx : IsVar ((ctxt :< typeA) :< typeB) typeC) 78 | -> term ctxt typeC 79 | apply this andThis pos@_ with (view pos) 80 | _ | Here = andThis 81 | _ | There pos' with (view pos') 82 | apply this andThis pos@_ | There pos'@_ | Here = this 83 | apply this andThis pos@_ | There pos'@_ | There pos'' = embed pos'' 84 | 85 | public export 86 | subst : {0 type : Type} 87 | -> {0 term : SnocList type -> type -> Type} 88 | -> Rename type term 89 | => Substitute type term 90 | => {0 ctxt : SnocList type} 91 | -> {0 typeA, typeB, typeC : type} 92 | -> (this : term ctxt typeA) 93 | -> (andThis : term ctxt typeB) 94 | -> (inThis : term ((ctxt :< typeA) :< typeB) typeC) 95 | -> term ctxt typeC 96 | subst {ctxt} {typeA} {typeB} {typeC} this andThis inThis 97 | = General.subst (apply this andThis) inThis 98 | 99 | -- [ EOF ] 100 | -------------------------------------------------------------------------------- /src/Toolkit/DeBruijn/Variable.idr: -------------------------------------------------------------------------------- 1 | ||| Naming 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.DeBruijn.Variable 7 | 8 | import Decidable.Equality 9 | import Data.SnocList 10 | 11 | import Toolkit.Decidable.Informative 12 | import Toolkit.Data.Comparison.Informative 13 | 14 | import Toolkit.Data.SnocList.AtIndex 15 | import Toolkit.Data.SnocList.Thinning 16 | 17 | %default total 18 | 19 | public export 20 | data IsVar : (ctxt : SnocList kind) 21 | -> (type : kind) 22 | -> Type 23 | where 24 | V : ( pos : Nat) 25 | -> (0 prf : AtIndex type ctxt pos) 26 | -> IsVar ctxt type 27 | 28 | export 29 | Uninhabited (IsVar [<] x) where 30 | uninhabited (V n prf) = void (uninhabited prf) 31 | 32 | export 33 | DecEq (IsVar ctxt type) where 34 | decEq (V m p) (V n q) with (decEq m n) 35 | decEq (V .(m) p) (V m q) | Yes Refl 36 | = Yes (irrelevantEq $ cong (\ p => V m p) (irrelevantAtIndex p q)) 37 | _ | No neq = No (\case Refl => neq Refl) 38 | 39 | public export 40 | %inline 41 | here : IsVar (ctxt :< a) a 42 | here = V 0 Here 43 | 44 | public export 45 | %inline 46 | shift : IsVar ctxt type -> IsVar (ctxt :< a) type 47 | shift (V pos prf) = V (S pos) (There prf) 48 | 49 | export 50 | shifts : IsVar g s -> {g' : SnocList a} -> IsVar (g <+> g') s 51 | shifts v {g' = [<]} = v 52 | shifts v {g' = _ :< _} = shift (shifts v) 53 | 54 | public export 55 | data View : IsVar ctxt type -> Type where 56 | Here : View Variable.here 57 | There : (v : IsVar ctxt type) -> View (shift v) 58 | 59 | export 60 | view : (v : IsVar ctxt type) -> View v 61 | view (V 0 Here) = Here 62 | view (V (S n) (There prf)) = There (V n prf) 63 | 64 | public export 65 | Comparable (IsVar ctxt ty) (IsVar ctxt ty') where 66 | cmp v@_ w@_ with (view v) | (view w) 67 | _ | Here | Here = EQ 68 | _ | Here | There _ = LT 69 | _ | There _ | Here = GT 70 | _ | There v' | There w' with (cmp v' w') 71 | _ | LT = LT 72 | cmp v@_ w@_ | There v' | There .(v') | EQ = EQ 73 | _ | GT = GT 74 | 75 | public export 76 | %inline 77 | weaken : (func : IsVar old type 78 | -> IsVar new type) 79 | -> (IsVar (old :< type') type 80 | -> IsVar (new :< type') type) 81 | weaken f v@_ with (view v) 82 | _ | Here = here 83 | _ | There later = shift (f later) 84 | 85 | export 86 | thin : IsVar g s -> Thinning g g' -> IsVar g' s 87 | thin v Empty = absurd v 88 | thin v (Skip th) = shift (thin v th) 89 | thin v@_ (Keep Refl th) with (view v) 90 | _ | Here = here 91 | _ | There w = shift (thin w th) 92 | 93 | export 94 | Show (IsVar g s) where 95 | show (V n _) = show n 96 | 97 | -- [ EOF ] 98 | -------------------------------------------------------------------------------- /src/Toolkit/Decidable/Do.idr: -------------------------------------------------------------------------------- 1 | ||| An embedding of `Dec` instances into `Either` to gain access to Do notation. 2 | ||| 3 | ||| Thanks Matus for figuring it out. 4 | ||| 5 | ||| So let's have this: 6 | ||| 7 | ||| ``` 8 | ||| exampleDo : DecEq a => DecEq b => (ps, rs : Pair a b) -> Dec (ps = rs) 9 | ||| exampleDo (x, y) (a,b) 10 | ||| = decDo $ do Refl <- decEq x a `otherwise` (\Refl => Refl) 11 | ||| Refl <- decEq y b `otherwise` (\Refl => Refl) 12 | ||| Right Refl 13 | ||| ``` 14 | ||| 15 | ||| Rather than: 16 | ||| 17 | ||| ``` 18 | ||| example : DecEq a => DecEq b => (ps, rs : Pair a b) -> Dec (ps = rs) 19 | ||| example (x, y) (a, b) with (decEq x a) 20 | ||| example (x, y) (x, b) | (Yes Refl) with (decEq y b) 21 | ||| example (x, y) (x, y) | (Yes Refl) | (Yes Refl) = Yes Refl 22 | ||| example (x, y) (x, b) | (Yes Refl) | (No contra) = No (\Refl => contra Refl) 23 | ||| example (x, y) (a, b) | (No contra) = No (\Refl => contra Refl) 24 | ||| ``` 25 | ||| 26 | ||| 27 | ||| Copyright : see COPYRIGHT 28 | ||| License : see LICENSE 29 | ||| 30 | module Toolkit.Decidable.Do 31 | 32 | import Decidable.Equality 33 | 34 | import Toolkit.Decidable.Informative 35 | 36 | %default total 37 | 38 | export 39 | otherwise : Dec b -> (a -> b) -> Either (Not a) b 40 | otherwise (Yes pfB) f = Right pfB 41 | otherwise (No notB) f = Left (notB . f) 42 | 43 | export 44 | decDo : Either (Not a) a -> Dec a 45 | decDo (Left notA) = No notA 46 | decDo (Right pfA) = Yes pfA 47 | 48 | 49 | -- [ EOF ] 50 | -------------------------------------------------------------------------------- /src/Toolkit/Decidable/Equality/Indexed.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Decidable.Equality.Indexed 6 | 7 | import public Decidable.Equality 8 | 9 | %default total 10 | 11 | public export 12 | data Equals : (t : Type) 13 | -> (e : t -> Type) 14 | -> {i,j : t} 15 | -> (x : e i) 16 | -> (y : e j) 17 | -> Type 18 | where 19 | Same : { i,j : t} 20 | -> { x : e i} 21 | -> { y : e j} 22 | -> ( prfIdx : i = j) 23 | -> ( prfVal : x = y) 24 | -> Equals t e x y 25 | 26 | public export 27 | interface DecEq iTy 28 | => DecEqIdx (iTy : Type) 29 | (eTy : iTy -> Type) | eTy 30 | where 31 | decEq : {i,j : iTy} 32 | -> (x : eTy i) 33 | -> (y : eTy j) 34 | -> (prf : i = j) 35 | -> Dec (Equals iTy eTy x y) 36 | 37 | export 38 | sym : {i,j : iTy} 39 | -> {a : eTy i} 40 | -> {b : eTy j} 41 | -> (rule : Equals iTy eTy a b) -> Equals iTy eTy b a 42 | sym (Same Refl Refl) = Same Refl Refl 43 | 44 | export 45 | negEqSym : {i,j : iTy} 46 | -> {a : eTy i} 47 | -> {b : eTy j} 48 | -> (Equals iTy eTy a b -> Void) 49 | -> (Equals iTy eTy b a -> Void) 50 | negEqSym p h = p (sym h) 51 | 52 | export 53 | trans : {i,j,k : iTy} 54 | -> {a : eTy i} 55 | -> {b : eTy j} 56 | -> {c : eTy k} 57 | -> (ab : Equals iTy eTy a b) 58 | -> (bc : Equals iTy eTy b c) 59 | -> Equals iTy eTy a c 60 | trans {i = i} {j = i} {k = k} {a = a} {b = a} {c = c} (Same Refl Refl) bc with (bc) 61 | trans {i = i} {j = i} {k = i} {a = a} {b = a} {c = a} (Same Refl Refl) bc | (Same Refl Refl) = (Same Refl Refl) 62 | 63 | namespace Index 64 | public export 65 | indexAreSame : {i,j : iTy} 66 | -> (contra : i = j -> Void) 67 | -> {x : eTy i} 68 | -> {y : eTy j} 69 | -> (prf : Equals iTy eTy x y) 70 | -> Void 71 | indexAreSame contra (Same Refl prfVal) = contra Refl 72 | 73 | public export 74 | decEq : {iTy : Type} 75 | -> {eTy : iTy -> Type} 76 | -> DecEqIdx iTy eTy 77 | => {i : iTy} 78 | -> {j : iTy} 79 | -> (x : eTy i) 80 | -> (y : eTy j) 81 | -> Dec (Equals iTy eTy x y) 82 | decEq x y {i} {j} {eTy} with (decEq i j) 83 | decEq x y {i = i} {j = i} {eTy = eTy} | (Yes Refl) = Indexed.decEq x y Refl 84 | decEq x y {i = i} {j = j} {eTy = eTy} | (No contra) = No (indexAreSame contra) 85 | 86 | public export 87 | same : Equals kind type x y -> x = y 88 | same (Same Refl Refl) = Refl 89 | 90 | -- --------------------------------------------------------------------- [ EOF ] 91 | -------------------------------------------------------------------------------- /src/Toolkit/Decidable/Equality/Views.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Decidable.Equality.Views 6 | 7 | import Decidable.Equality 8 | 9 | import Toolkit.Decidable.Informative 10 | 11 | %default total 12 | 13 | public export 14 | data AllEqual : (a,b,c : ty) -> Type where 15 | AE : AllEqual a a a 16 | 17 | public export 18 | data Error = AB | AC 19 | 20 | abNotEq : (a = b -> Void) -> AllEqual a b c -> Void 21 | abNotEq f AE = f Refl 22 | 23 | acNotEq : (a = c -> Void) -> AllEqual a b c -> Void 24 | acNotEq f AE = f Refl 25 | 26 | export 27 | allEqual : DecEq type 28 | => (a,b,c : type) 29 | -> DecInfo (Error) (AllEqual a b c) 30 | allEqual a b c with (decEq a b) 31 | allEqual a a c | (Yes Refl) with (decEq a c) 32 | allEqual a a a | (Yes Refl) | (Yes Refl) = Yes AE 33 | allEqual a a c | (Yes Refl) | (No contra) 34 | = No (AC) (acNotEq contra) 35 | allEqual a b c | (No contra) 36 | = No (AB) (abNotEq contra) 37 | 38 | 39 | -- [ EOF ] 40 | -------------------------------------------------------------------------------- /src/Toolkit/Decidable/Informative.idr: -------------------------------------------------------------------------------- 1 | ||| A version of `Dec` that returns a meaningful error message as well 2 | ||| as proof of void. 3 | ||| 4 | ||| When dealing with decidable properties for type-level computations 5 | ||| the existing `Dec` data type is useful. However, when using 6 | ||| decidable properties interactively one cannot easily tell why a 7 | ||| property failed. One can always encode failing cases within the 8 | ||| property itself but that is not necessarily a advantageous. 9 | ||| 10 | ||| `DecInfo` provides a data structure to capture decidable 11 | ||| properties together with an informative error message for when the 12 | ||| property does not hold. 13 | ||| 14 | ||| Copyright : see COPYRIGHT 15 | ||| License : see LICENSE 16 | ||| 17 | module Toolkit.Decidable.Informative 18 | 19 | import Decidable.Equality 20 | %default total 21 | 22 | 23 | public export 24 | data DecInfo : (errType : Type) -> (prop : Type) -> Type where 25 | Yes : (prfWhy : prop) 26 | -> DecInfo errType prop 27 | No : (msgWhyNot : errType) 28 | -> (prfWhyNot : prop -> Void) 29 | -> DecInfo errType prop 30 | 31 | namespace Toolkit.Decidable 32 | export 33 | embed : (prf : Dec p) 34 | -> DecInfo () p 35 | embed (Yes prf) 36 | = Yes prf 37 | embed (No contra) 38 | = No () contra 39 | 40 | export 41 | embedUn : (prf : DecInfo e p) 42 | -> Dec p 43 | embedUn (Yes prfWhy) 44 | = Yes prfWhy 45 | embedUn (No _ no) 46 | = No no 47 | 48 | export 49 | embed : (f : a -> e) 50 | -> (res : DecInfo a p) 51 | -> DecInfo e p 52 | embed _ (Yes prfWhy) = Yes prfWhy 53 | embed f (No msgWhyNot prfWhyNot) = No (f msgWhyNot) prfWhyNot 54 | 55 | export 56 | otherwise : DecInfo e b -> (a -> b) -> Either (e, Not a) b 57 | otherwise (Yes prfWhy) f = Right prfWhy 58 | otherwise (No msgWhyNot prfWhyNot) f = Left (msgWhyNot, \x => prfWhyNot (f x)) 59 | 60 | export 61 | try : DecInfo e b -> (a -> b) -> Either (e, Not a) b 62 | try = otherwise 63 | 64 | export 65 | decInfoDo : Either (e, Not a) a -> DecInfo e a 66 | decInfoDo (Left (x, y)) = No x y 67 | decInfoDo (Right x) = Yes x 68 | 69 | namespace Lift 70 | 71 | export 72 | otherwise : DecInfo eB b -> (eB -> eA) -> (a -> b) -> Either (eA, Not a) b 73 | otherwise (Yes prfWhy) _ _ = Right prfWhy 74 | otherwise (No msgWhyNot prfWhyNot) g f = Left (g msgWhyNot, \x => prfWhyNot (f x)) 75 | 76 | export 77 | try : DecInfo eB b -> (eB -> eA) -> (a -> b) -> Either (eA, Not a) b 78 | try = otherwise 79 | 80 | namespace Either 81 | 82 | public export 83 | asEither : DecInfo e p -> Either e p 84 | asEither (Yes prfWhy) = Right prfWhy 85 | asEither (No msgWhyNot prfWhyNot) = Left msgWhyNot 86 | 87 | -- --------------------------------------------------------------------- [ EOF ] 88 | -------------------------------------------------------------------------------- /src/Toolkit/Item.idr: -------------------------------------------------------------------------------- 1 | ||| Context items 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.Item 7 | 8 | import Data.SnocList 9 | import Data.SnocList.Quantifiers 10 | import Decidable.Equality 11 | 12 | import Toolkit.Decidable.Informative 13 | 14 | %default total 15 | 16 | ||| An item in our context, paramterised by the type collected. 17 | ||| 18 | ||| @kind the type of the datatype describing types 19 | ||| @type the instance of the type being recorded. 20 | public export 21 | data Item : (type : kind) 22 | -> Type 23 | where 24 | I : (name : String) 25 | -> (type : kind) 26 | -> Item type 27 | 28 | ||| A generic container to capture properties over items in the 29 | ||| context. 30 | public export 31 | data Holds : (kind : Type) 32 | -> (pred : (type : kind) -> Type) 33 | -> (key : String) 34 | -> {type : kind} 35 | -> (item : Item type) 36 | -> Type 37 | where 38 | H : {pred : (type : kind) -> Type} 39 | -> {i : kind} 40 | -> (prfK : key = str) 41 | -> (prf : pred i) 42 | -> Holds kind pred key (I str i) 43 | 44 | namespace Holds 45 | public export 46 | data Error type = NotSatisfied type 47 | | WrongName String String 48 | export 49 | holds : {pred : (type : kind) -> Type} 50 | -> (func : (type : kind) -> DecInfo err (pred type)) 51 | -> (key : String) 52 | -> {type : kind} 53 | -> (item : Item type) 54 | -> DecInfo (Holds.Error err) 55 | (Holds kind pred key item) 56 | holds func key (I name type) with (decEq key name) 57 | holds func key (I key type) | (Yes Refl) with (func type) 58 | holds func key (I key type) | (Yes Refl) | (Yes prfWhy) 59 | = Yes (H Refl prfWhy) 60 | 61 | holds func key (I key type) | (Yes Refl) | (No msg contra) 62 | = No (NotSatisfied msg) 63 | (\(H Refl prf) => contra prf) 64 | 65 | holds func key (I name type) | (No contra) 66 | = No (WrongName key name) 67 | (\(H Refl prf) => contra Refl) 68 | 69 | 70 | export 71 | support : All Item ctxt -> (ctxt' : _ ** ctxt === ctxt') 72 | support [<] = (_ ** Refl) 73 | support (is :< I s x) 74 | = let (ctxt' ** eq) = support is in 75 | (ctxt' :< x ** cong (:< x) eq) 76 | 77 | -- [ EOF ] 78 | -------------------------------------------------------------------------------- /src/Toolkit/Logging/Simple.idr: -------------------------------------------------------------------------------- 1 | ||| The `LogLevel` type allows for simple logging in the style of the Log4j/Python family of 2 | ||| loggers. 3 | module Toolkit.Logging.Simple 4 | 5 | 6 | ||| Logging levels are essentially natural numbers wrapped in a data type for 7 | ||| convenience. 8 | ||| 9 | public export 10 | data LogLevel : Type where 11 | ||| Log No Events 12 | OFF : LogLevel 13 | 14 | ||| A fine-grained debug message, typically capturing the flow through 15 | ||| the application. 16 | TRACE : LogLevel 17 | 18 | ||| A general debugging event. 19 | DEBUG : LogLevel 20 | 21 | ||| An event for informational purposes. 22 | INFO : LogLevel 23 | 24 | ||| An event that might possible lead to an error. 25 | WARN : LogLevel 26 | 27 | ||| An error in the application, possibly recoverable. 28 | ERROR : LogLevel 29 | 30 | ||| A severe error that will prevent the application from continuing. 31 | FATAL : LogLevel 32 | 33 | ||| All events should be logged. 34 | ALL : LogLevel 35 | 36 | export 37 | Eq LogLevel where 38 | (==) OFF OFF = True 39 | (==) TRACE TRACE = True 40 | (==) DEBUG DEBUG = True 41 | (==) INFO INFO = True 42 | (==) WARN WARN = True 43 | (==) ERROR ERROR = True 44 | (==) FATAL FATAL = True 45 | (==) ALL ALL = True 46 | (==) _ _ = False 47 | 48 | Cast (LogLevel) Nat where 49 | cast OFF = 0 50 | cast TRACE = 1 51 | cast DEBUG = 2 52 | cast INFO = 3 53 | cast WARN = 4 54 | cast ERROR = 5 55 | cast FATAL = 6 56 | cast ALL = 7 57 | 58 | export 59 | Ord LogLevel where 60 | compare a b 61 | = compare (cast {to=Nat} a) 62 | (cast {to=Nat} b) 63 | 64 | namespace Default 65 | export 66 | toString : LogLevel -> String 67 | toString OFF = "[ OFF ]" 68 | toString TRACE = "[ TRACE ]" 69 | toString DEBUG = "[ DEBUG ]" 70 | toString INFO = "[ INFO ]" 71 | toString WARN = "[ WARN ]" 72 | toString ERROR = "[ ERROR ]" 73 | toString FATAL = "[ FATAL ]" 74 | toString ALL = "[ ALL ]" 75 | 76 | export 77 | Show LogLevel where 78 | show = toString 79 | 80 | -- [ EOF ] 81 | -------------------------------------------------------------------------------- /src/Toolkit/Options/ArgParse.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Options.ArgParse 6 | 7 | import Data.List 8 | import Data.String 9 | 10 | import Toolkit.Options.ArgParse.Lexer 11 | import Toolkit.Options.ArgParse.Parser 12 | 13 | import public Toolkit.Options.ArgParse.Model 14 | 15 | import Toolkit.Options.ArgParse.Parser 16 | import public Toolkit.Options.ArgParse.Error 17 | 18 | %default total 19 | -- ----------------------------------------------------------------- [ Records ] 20 | 21 | private 22 | convOpts : (Arg -> a -> Maybe a) 23 | -> a 24 | -> List Arg 25 | -> Either ArgParseError a 26 | convOpts _ o Nil = pure o 27 | convOpts conv o (x :: xs) = case conv x o of 28 | Nothing => Left (InvalidOption x) 29 | Just o' => do 30 | os <- convOpts conv o' xs 31 | pure os 32 | 33 | ||| Parse arguments using a record. 34 | ||| 35 | ||| @orig The starting value of the record representing the options. 36 | ||| @conv A user supplied conversion function used to update the record. 37 | ||| @args The *unmodified* result of calling `System.getArgs` or `Effects.System.geArgs`. 38 | export 39 | parseArgs : (orig : a) 40 | -> (conv : Arg -> a -> Maybe a) 41 | -> (args : List String) 42 | -> Either ArgParseError a 43 | parseArgs o _ Nil = pure o 44 | parseArgs o _ [a] = pure o 45 | parseArgs o func (a::as) = do 46 | case parseArgsStr (unwords as) of 47 | Left err => Left (MalformedOption err) 48 | Right res => do 49 | r <- convOpts func o res 50 | pure r 51 | 52 | -- --------------------------------------------------------------------- [ EOF ] 53 | -------------------------------------------------------------------------------- /src/Toolkit/Options/ArgParse/Error.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Options.ArgParse.Error 6 | 7 | import Data.String 8 | 9 | import System.File 10 | 11 | import Toolkit.Data.Location 12 | 13 | import Toolkit.Options.ArgParse.Model 14 | import Toolkit.Options.ArgParse.Lexer 15 | import Toolkit.Options.ArgParse.Parser 16 | 17 | %default total 18 | 19 | public export 20 | data ArgParseError : Type where 21 | InvalidOption : Arg -> ArgParseError 22 | MalformedOption : ParseError Token -> ArgParseError 23 | 24 | export 25 | (Show Arg) => Show ArgParseError where 26 | show (InvalidOption o) 27 | = "Invalid Option " ++ show o 28 | show (MalformedOption err) 29 | = "Malformed Option " ++ show err 30 | 31 | 32 | -- --------------------------------------------------------------------- [ EOF ] 33 | -------------------------------------------------------------------------------- /src/Toolkit/Options/ArgParse/Lexer.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Options.ArgParse.Lexer 6 | 7 | import Data.String 8 | import Text.Lexer 9 | 10 | 11 | import public Toolkit.Text.Lexer.Run 12 | 13 | %default total 14 | 15 | public export 16 | data Token = SFlag String 17 | | LFlag String 18 | | Equals String 19 | | Quoted String 20 | | WS String 21 | | Arg String 22 | | Unknown String 23 | | EndInput 24 | 25 | export 26 | Show Token where 27 | show (LFlag x) = unwords ["LFlag", show x] 28 | show (SFlag x) = unwords ["SFlag", show x] 29 | show (Equals x) = unwords ["Equals", show x] 30 | show (Quoted x) = unwords ["Quoted", show x] 31 | show (WS x) = unwords ["WS", show x] 32 | show (Arg x) = unwords ["Arg", show x] 33 | show (Unknown x) = unwords ["BAD TOKEN", show x] 34 | show EndInput = "ENDINPUT" 35 | 36 | ch : Lexer 37 | ch = pred (isAlphaNum) 38 | 39 | str : Lexer 40 | str = some (pred isAlphaNum) 41 | 42 | shortFlag : Lexer 43 | shortFlag = is '-' <+> ch 44 | 45 | longFlag : Lexer 46 | longFlag = is '-' <+> is '-' <+> str 47 | 48 | equals : Lexer 49 | equals = is '=' 50 | 51 | arg : Lexer 52 | arg = any <+> manyUntil space any 53 | 54 | rawTokens : TokenMap Token 55 | rawTokens = 56 | [ (space, WS) 57 | , (stringLit, Quoted) 58 | , (longFlag, LFlag) 59 | , (shortFlag, SFlag) 60 | , (equals, Equals) 61 | , (arg, Arg) 62 | , (symbol, Unknown) 63 | ] 64 | 65 | keep : WithBounds Token -> Bool 66 | keep (MkBounded t _ _) with (t) 67 | keep (MkBounded t _ _) | (WS x) = False 68 | keep (MkBounded t _ _) | _ = True 69 | 70 | export 71 | ArgParseLexer : Lexer Token 72 | ArgParseLexer = MkLexer rawTokens keep EndInput 73 | 74 | export 75 | lexArgParseStr : String -> Either LexError (List (WithBounds Token)) 76 | lexArgParseStr = lexString ArgParseLexer 77 | 78 | export 79 | lexArgParseFile : String -> IO $ Either LexFail (List (WithBounds Token)) 80 | lexArgParseFile = lexFile ArgParseLexer 81 | 82 | -- --------------------------------------------------------------------- [ EOF ] 83 | -------------------------------------------------------------------------------- /src/Toolkit/Options/ArgParse/Model.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Options.ArgParse.Model 6 | 7 | %default total 8 | 9 | public export 10 | data Arg : Type where 11 | Flag : String -> Arg 12 | KeyValue : String -> String -> Arg 13 | File : String -> Arg 14 | 15 | export 16 | Show Arg where 17 | show (Flag f) = "[Flag " ++ show f ++ "]" 18 | show (KeyValue k v) = "[KeyValue " ++ show k ++ " : " ++ show v ++ "]" 19 | show (File fs) = "[File " ++ show fs ++ "]" 20 | 21 | -- --------------------------------------------------------------------- [ EOF ] 22 | -------------------------------------------------------------------------------- /src/Toolkit/Options/ArgParse/Parser.idr: -------------------------------------------------------------------------------- 1 | ||| A simple parser for command options. 2 | ||| 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Toolkit.Options.ArgParse.Parser 7 | 8 | import Text.Lexer 9 | import Text.Parser 10 | 11 | import Toolkit.Text.Lexer.Run 12 | import public Toolkit.Text.Parser.Run 13 | 14 | import Toolkit.Options.ArgParse.Lexer 15 | import Toolkit.Options.ArgParse.Parser.API 16 | import Toolkit.Options.ArgParse.Model 17 | 18 | -- ----------------------------------------------------------------- [ Parsers ] 19 | 20 | flagLong : Rule Arg 21 | flagLong = do 22 | l <- longFlag 23 | pure $ Flag l 24 | 25 | flagShort : Rule Arg 26 | flagShort = do 27 | s <- shortFlag 28 | pure $ Flag s 29 | 30 | kvLong : Rule Arg 31 | kvLong = do 32 | key <- longFlag 33 | equals 34 | value <- (arg <|> quoted) 35 | pure $ KeyValue key value 36 | 37 | kvShort : Rule Arg 38 | kvShort = do 39 | k <- shortFlag 40 | v <- (arg <|> quoted) 41 | pure $ KeyValue k v 42 | 43 | options : Rule Arg 44 | options = kvShort <|> kvLong <|> flagShort <|> flagLong <|> (do fs <- arg; pure $ File fs) 45 | 46 | args : RuleEmpty (List Arg) 47 | args = do 48 | os <- many options 49 | pure $ os 50 | 51 | export 52 | parseArgsStr : (str : String) 53 | -> Either (Run.ParseError Token) (List Arg) 54 | parseArgsStr str = parseString ArgParseLexer args str 55 | 56 | export 57 | parseArgsFile :(fname : String) 58 | -> IO (Either (Run.ParseError Token) (List Arg)) 59 | parseArgsFile fn = parseFile ArgParseLexer args fn 60 | 61 | -- --------------------------------------------------------------------- [ EOF ] 62 | -------------------------------------------------------------------------------- /src/Toolkit/Options/ArgParse/Parser/API.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Options.ArgParse.Parser.API 6 | 7 | import Data.List 8 | import Data.String 9 | 10 | import Text.Token 11 | import Text.Lexer 12 | import Text.Parser 13 | 14 | import Toolkit.Options.ArgParse.Lexer 15 | import public Toolkit.Text.Parser.Support 16 | 17 | 18 | %default total 19 | 20 | namespace ArgParse 21 | public export 22 | Rule : Type -> Type 23 | Rule = Rule Unit Token 24 | 25 | public export 26 | RuleEmpty : Type -> Type 27 | RuleEmpty = RuleEmpty Unit Token 28 | 29 | -- Some basic parsers used by all the intermediate forms 30 | 31 | export 32 | shortFlag : Rule String 33 | shortFlag 34 | = terminal "Expected Short Flag" 35 | (\x => case x of 36 | SFlag f => Just (substr 1 (length f) f) 37 | _ => Nothing) 38 | 39 | export 40 | longFlag : Rule String 41 | longFlag 42 | = terminal "Expected long flag" 43 | (\x => case x of 44 | LFlag f => Just (substr 2 (length f) f) 45 | _ => Nothing) 46 | 47 | export 48 | arg : Rule String 49 | arg = terminal "Expected arg." 50 | (\x => case x of 51 | Arg s => Just (trim s) 52 | _ => Nothing) 53 | 54 | export 55 | equals : Rule () 56 | equals = terminal "Expected equals" 57 | (\x => case x of 58 | Equals _ => Just () 59 | _ => Nothing) 60 | 61 | export 62 | quoted : Rule String 63 | quoted = terminal "Expected quoted input" 64 | (\x => case x of 65 | Quoted s => Just $ rmQuotes s 66 | _ => Nothing) 67 | where 68 | rmQuotes : String -> String 69 | rmQuotes xs = pack $ filter (not . (==) '"') (unpack xs) 70 | 71 | -- --------------------------------------------------------------------- [ EOF ] 72 | -------------------------------------------------------------------------------- /src/Toolkit/Options/ArgParse/Test.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Options.ArgParse.Test 6 | 7 | import Data.String 8 | 9 | import Data.Either 10 | import Data.Maybe 11 | import Toolkit.Options.ArgParse 12 | import Toolkit.Options.ArgParse.Error 13 | 14 | 15 | ||| Program Options 16 | record Opts where 17 | constructor MkOpts 18 | from : Maybe String 19 | verbose : Bool 20 | help : Bool 21 | version : Bool 22 | args : List String 23 | 24 | Show Opts where 25 | show (MkOpts f v h ve as) = unwords ["MkOpts", show f, show v, show h, show ve, show as] 26 | 27 | Eq Opts where 28 | (==) (MkOpts a b c d e) (MkOpts a' b' c' d' e') = a == a' && b == b' && c == c' && d' == d' && e == e' 29 | 30 | ||| Convert Arguments into Options 31 | convOpts : Arg -> Opts -> Maybe Opts 32 | convOpts (File x) o = Just $ record {args = x :: args o} o 33 | convOpts (KeyValue k v) o = 34 | case k of 35 | "from" => Just $ record {from = Just v} o 36 | otherwise => Nothing 37 | convOpts (Flag x) o = 38 | case x of 39 | "help" => Just $ record {help = True} o 40 | "verbose" => Just $ record {verbose = True} o 41 | "version" => Just $ record {version = True} o 42 | otherwise => Nothing 43 | 44 | defOpts : Opts 45 | defOpts = MkOpts Nothing False False False Nil 46 | 47 | test1 : IO () 48 | test1 = 49 | case parseArgs defOpts convOpts ["--help", "--verbose"] of 50 | Left _ => do 51 | putStrLn "Err" 52 | pure () 53 | Right o => do 54 | printLn $ (True == verbose o) 55 | printLn $ (False == help o) 56 | printLn $ (isNothing $ from o) 57 | 58 | export 59 | runTests : IO () 60 | runTests = do 61 | putStrLn "Testing ArgParse" 62 | test1 63 | printLn (isRight $ parseArgs defOpts convOpts Nil) 64 | 65 | let res' = parseArgs defOpts convOpts ["exe", "--help", "--verbose", "--from=conv"] 66 | case res' of 67 | Left _ => putStrLn "Err" 68 | Right res => do 69 | printLn (from res == Just "conv") 70 | 71 | -- --------------------------------------------------------------------- [ EOF ] 72 | -------------------------------------------------------------------------------- /src/Toolkit/System.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.System 6 | 7 | import System 8 | 9 | %default total 10 | 11 | export 12 | tryOrDie : Show err 13 | => Either err type 14 | -> IO type 15 | tryOrDie (Left err) = 16 | do putStrLn "Error Happened" 17 | printLn err 18 | exitFailure 19 | tryOrDie (Right res) = pure res 20 | 21 | -- [ EOF ] 22 | -------------------------------------------------------------------------------- /src/Toolkit/Text/Lexer/Run.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Text.Lexer.Run 6 | 7 | import System.File 8 | 9 | import Data.List 10 | import Data.String 11 | 12 | import Text.Lexer 13 | 14 | import Toolkit.Data.Nat 15 | import Toolkit.Data.Location 16 | 17 | %default total 18 | 19 | 20 | 21 | public export 22 | record LexError where 23 | constructor MkLexFail 24 | location : Location 25 | input : String 26 | 27 | public export 28 | data LexFail = LError LexError | LIOErr FileError 29 | 30 | export 31 | Show LexFail where 32 | show (LError (MkLexFail loc i)) = 33 | unwords ["Lexing Error at ", show loc, ":\n", show i] 34 | show (LIOErr err) = 35 | unwords ["FileError", show err] 36 | 37 | public export 38 | record Lexer a where 39 | constructor MkLexer 40 | tokenMap : TokenMap a 41 | keep : WithBounds a -> Bool 42 | endInput : a 43 | 44 | export 45 | lexString : Lexer a 46 | -> String 47 | -> Either LexError (List (WithBounds a)) 48 | lexString lexer str = 49 | case Lexer.Core.lex (tokenMap lexer) str of 50 | (tok, (c,l, "")) => 51 | Right $ (filter (keep lexer) tok ++ [MkBounded (endInput lexer) False (MkBounds l c l c)]) 52 | 53 | (_, (c,l,i)) => Left (MkLexFail (MkLoc Nothing (toNat c) (toNat l)) i) 54 | 55 | export covering 56 | lexFile : Lexer a -> String -> IO $ Either LexFail (List (WithBounds a)) 57 | lexFile lexer fname = do 58 | Right str <- readFile fname | Left err => pure (Left (LIOErr err)) 59 | case lexString lexer str of 60 | Left err => pure $ Left (LError ({ location->source := Just fname } err)) 61 | Right toks => pure (Right toks) 62 | 63 | -- [ EOF ] 64 | -------------------------------------------------------------------------------- /src/Toolkit/Text/Parser/Location.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Text.Parser.Location 6 | 7 | import Text.Lexer 8 | import Text.Parser 9 | 10 | import Toolkit.Data.Nat 11 | import Toolkit.Data.Location 12 | import Toolkit.Text.Parser.Support 13 | 14 | %default total 15 | 16 | namespace Toolkit 17 | export 18 | location : RuleEmpty state tok Location 19 | location = do 20 | (x,y) <- Text.Parser.location 21 | pure (MkLoc Nothing (toNat x) (toNat y)) 22 | 23 | namespace WithFileName 24 | export 25 | location : String -> RuleEmpty state tok Location 26 | location fname = do 27 | l <- Toolkit.location 28 | pure ({ source := Just fname} l) 29 | 30 | -- [ EOF ] 31 | -------------------------------------------------------------------------------- /src/Toolkit/Text/Parser/Run.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Text.Parser.Run 6 | 7 | import System.File 8 | 9 | import Text.Parser 10 | import Text.Lexer 11 | 12 | import Data.List1 13 | import Data.String 14 | import Toolkit.Data.Nat 15 | import Toolkit.Data.Location 16 | import Toolkit.Text.Lexer.Run 17 | 18 | import Toolkit.Text.Parser.Support 19 | 20 | 21 | %default total 22 | 23 | public export 24 | record ParseFailure a where 25 | constructor MkParseFail 26 | error : String 27 | location : FileContext 28 | 29 | public export 30 | data ParseError a = PError (List1 (ParseFailure a)) 31 | | LError LexError 32 | | FError FileError 33 | 34 | 35 | export 36 | Show a => Show (ParseFailure a) where 37 | show err 38 | = trim $ unlines [show (location err), (error err)] 39 | 40 | export 41 | Show a => Show (Run.ParseError a) where 42 | show (FError err) 43 | = trim $ unlines ["File Error: " 44 | , show err] 45 | show (PError err) 46 | = trim $ unlines (forget (map show err)) 47 | 48 | show (LError (MkLexFail l i)) 49 | = trim $ unlines [show l, show i] 50 | 51 | 52 | convert : (src : Maybe String) 53 | -> (err : ParsingError a) 54 | -> ParseFailure a 55 | convert src (Error msg Nothing) 56 | = MkParseFail msg ({ source := src } emptyFC) 57 | 58 | convert src (Error msg (Just loc)) 59 | = let s = startBounds loc in 60 | let e = endBounds loc in 61 | let fc = if s == e 62 | then newFC src s (mapSnd (+1) e) 63 | else newFC src s e 64 | in MkParseFail msg fc 65 | 66 | runConvert : Maybe String 67 | -> List1 (ParsingError a) 68 | -> ParseError a 69 | runConvert src es = PError (map (convert src) es) 70 | 71 | export 72 | parseString : {e : _} 73 | -> (lexer : Lexer a) 74 | -> (rule : Grammar () (a) e ty) 75 | -> (str : String) 76 | -> (Either (ParseError a) ty) 77 | parseString lexer rule str = 78 | case lexString lexer str of 79 | Left err => Left (LError err) 80 | Right toks => 81 | case parse rule toks of 82 | Left err => Left (runConvert Nothing err) 83 | Right (val,_) => Right val 84 | 85 | export 86 | covering 87 | parseFile : {e : _} 88 | -> (lexer : Lexer a) 89 | -> (rule : Grammar () a e ty) 90 | -> (fname : String) 91 | -> IO $ Either (ParseError a) ty 92 | parseFile lexer grammar fname = 93 | case !(lexFile lexer fname) of 94 | Left (LError err) => pure (Left (LError err)) 95 | Left (LIOErr err) => pure (Left (FError err)) 96 | Right toks => 97 | case parse grammar toks of 98 | Left err => pure (Left (runConvert (Just fname) err)) 99 | Right (val,_) => pure (Right val) 100 | 101 | -- [ EOF ] 102 | -------------------------------------------------------------------------------- /src/Toolkit/Text/Parser/Support.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Toolkit.Text.Parser.Support 6 | 7 | import Text.Lexer 8 | import Text.Parser 9 | 10 | %default total 11 | 12 | public export 13 | Rule : Type -> Type -> Type -> Type 14 | Rule state tok ty = Grammar state tok True ty 15 | 16 | 17 | public export 18 | RuleEmpty : Type -> Type -> Type -> Type 19 | RuleEmpty state tok ty = Grammar state tok False ty 20 | 21 | export 22 | eoi : (f : a -> Bool) -> RuleEmpty state a () 23 | eoi f 24 | = ignore $ nextIs "Not End of Input" (f) 25 | 26 | 27 | -- [ EOF ] 28 | -------------------------------------------------------------------------------- /src/Toolkit/TheRug/Logging/Simple.idr: -------------------------------------------------------------------------------- 1 | module Toolkit.TheRug.Logging.Simple 2 | 3 | import Data.String 4 | import Toolkit.TheRug 5 | import public Toolkit.Logging.Simple 6 | 7 | %default total 8 | 9 | export 10 | %inline 11 | logWhen : (f : LogLevel -> String) 12 | -> (given, expected : LogLevel) 13 | -> (msg : String) 14 | -> TheRug e () 15 | logWhen f g e msg 16 | = if (g <= e || g == FATAL || g == ALL) 17 | then putStrLn (unwords [(f g), msg]) 18 | else pure () 19 | 20 | export 21 | %inline 22 | log : (f : LogLevel -> String) 23 | -> (level : LogLevel) 24 | -> (msg : String) 25 | -> TheRug e () 26 | log f l msg 27 | = putStrLn (unwords [(f l), msg]) 28 | 29 | namespace Default 30 | export 31 | log : (level : LogLevel) 32 | -> (msg : String) 33 | -> TheRug e () 34 | log = log (Default.toString) 35 | 36 | export 37 | logWhen : (given, expected : LogLevel) 38 | -> (msg : String) 39 | -> TheRug e () 40 | logWhen = logWhen (Default.toString) 41 | 42 | -- [ EOF ] 43 | -------------------------------------------------------------------------------- /src/Velo/Core.idr: -------------------------------------------------------------------------------- 1 | module Velo.Core 2 | 3 | import System 4 | 5 | import Data.String 6 | 7 | import public Toolkit.TheRug 8 | import public Toolkit.TheRug.Logging.Simple 9 | import Toolkit.System 10 | 11 | import public Velo.Error 12 | import Velo.Error.Pretty 13 | 14 | import public Toolkit.Data.Location 15 | 16 | %default total 17 | 18 | public export 19 | %inline 20 | Velo : Type -> Type 21 | Velo = TheRug Velo.Error 22 | 23 | export 24 | throwAt : FileContext -> Elaborating.Error -> Velo a 25 | throwAt l e = throw $ Elab (Err l e) 26 | 27 | export 28 | dec : FileContext 29 | -> Elaborating.Error 30 | -> Dec a 31 | -> Velo a 32 | dec _ _ (Yes prf) 33 | = pure prf 34 | dec fc err (No _) 35 | = throwAt fc err 36 | 37 | namespace Velo 38 | 39 | %inline 40 | whenErr : (msg : Velo.Error) 41 | -> IO () 42 | whenErr err 43 | = do printLn err 44 | exitFailure 45 | 46 | %inline 47 | whenOK : a -> IO () 48 | whenOK _ = pure () 49 | 50 | export 51 | run : (prog : Velo a) 52 | -> IO () 53 | run = run whenErr whenOK 54 | 55 | -- [ EOF ] 56 | -------------------------------------------------------------------------------- /src/Velo/Elaborator.idr: -------------------------------------------------------------------------------- 1 | module Velo.Elaborator 2 | 3 | import Data.List 4 | import Data.DPair 5 | import Data.SnocList.Quantifiers 6 | import Decidable.Equality 7 | 8 | import Toolkit.Data.List.Pointwise 9 | import Toolkit.Data.List.Quantifiers 10 | 11 | import Toolkit.Data.SnocList.Quantifiers 12 | import Toolkit.Data.List.Subset 13 | import Toolkit.DeBruijn.Context 14 | import Toolkit.DeBruijn.Variable 15 | 16 | import Velo.Core 17 | import Velo.Types 18 | import Velo.IR.Common 19 | import Velo.Elaborator.Common 20 | 21 | import Velo.IR.AST 22 | 23 | import Velo.IR.Holey 24 | import Velo.IR.Term 25 | 26 | import Velo.Elaborator.Holey 27 | import Velo.Elaborator.Term 28 | 29 | %default total 30 | 31 | public export 32 | data IsEmpty : (xs : List a) -> Type where 33 | ItIsEmpty : IsEmpty Nil 34 | 35 | 36 | Uninhabited (IsEmpty (x::xs)) where 37 | uninhabited ItIsEmpty impossible 38 | 39 | -- @TODO Merge into Toolkit or Idris2 40 | nonEmpty : (xs : List a) -> DecInfo (IsEmpty xs) (NonEmpty xs) 41 | nonEmpty [] 42 | = No ItIsEmpty absurd 43 | 44 | nonEmpty (x :: xs) 45 | = Yes IsNonEmpty 46 | 47 | public export 48 | record SynthResult (ctxt : SnocList Ty) where 49 | constructor MkSynthResult 50 | {ty : Ty} 51 | metas : List Meta 52 | term : Term metas ctxt ty 53 | 54 | namespace Synth 55 | 56 | export 57 | elab : All Item ctxt 58 | -> Raw 59 | -> Velo (SynthResult ctxt) 60 | elab gam ast 61 | = do (ty ** holes ** t) <- synth gam ast 62 | let (metas ** inv) = initInvariant gam holes 63 | let t = wscoped t inv 64 | pure (MkSynthResult metas t) 65 | 66 | public export 67 | record CheckResult (ctxt : SnocList Ty) (ty : Ty) where 68 | constructor MkCheckResult 69 | metas : List Meta 70 | term : Term metas ctxt ty 71 | 72 | namespace Check 73 | 74 | export 75 | elab : All Item ctxt 76 | -> (ty : Ty) 77 | -> Raw 78 | -> Velo (CheckResult ctxt ty) 79 | elab gam ty ast 80 | = do (holes ** t) <- check gam ty ast 81 | let (metas ** inv) = initInvariant gam holes 82 | let t = wscoped t inv 83 | pure (MkCheckResult metas t) 84 | 85 | -- [ EOF ] 86 | -------------------------------------------------------------------------------- /src/Velo/Elaborator/CoDeBruijn.idr: -------------------------------------------------------------------------------- 1 | module Velo.Elaborator.CoDeBruijn 2 | 3 | import Toolkit.CoDeBruijn 4 | import Toolkit.CoDeBruijn.Variable 5 | import Toolkit.DeBruijn.Variable 6 | 7 | import Toolkit.Data.SnocList.Thinning 8 | 9 | import Velo.Types 10 | import Velo.IR.Common 11 | import Velo.IR.Term 12 | import Velo.IR.CoTerm 13 | 14 | %default total 15 | 16 | namespace IsVar 17 | 18 | export 19 | coDeBruijn : {ctxt : _} -> 20 | DeBruijn.Variable.IsVar ctxt s -> 21 | Diamond (`CoDeBruijn.Variable.IsVar` s) ctxt 22 | coDeBruijn v@_ with (view v) 23 | coDeBruijn {ctxt = _ :< _} v@_ | Here = MkDiamond (Keep Refl none) Here 24 | coDeBruijn {ctxt = _ :< _} v@_ | There w = Skip (coDeBruijn w) 25 | 26 | export 27 | deBruijn : CoDeBruijn.Variable.IsVar g s -> 28 | DeBruijn.Variable.IsVar g s 29 | deBruijn Here = here 30 | 31 | 32 | namespace Term 33 | 34 | export 35 | coDeBruijns : {ctxt, metas, tys : _} -> 36 | All (Term metas ctxt) tys -> 37 | Diamond (\ ctxt => CoTerms metas ctxt tys) ctxt 38 | 39 | export 40 | coDeBruijnS : {ctxt, metas, tys : _} -> 41 | Subst metas ctxt tys -> 42 | Diamond (\ ctxt => CoSubst metas ctxt tys) ctxt 43 | 44 | export 45 | coDeBruijnM : {ctxt, metas : _} -> 46 | (0 m : Meta) -> 47 | IsMember metas m -> 48 | Subst metas ctxt m.metaScope -> 49 | Diamond (\ ctxt => CoTerm metas ctxt m.metaType) ctxt 50 | coDeBruijnM (MkMeta nm nms ty) mem sg with (lookup mem) 51 | _ | (_ ** Refl) with (support nms) 52 | _ | (_ ** Refl) 53 | = Met mem <$> coDeBruijnS sg 54 | 55 | export 56 | coDeBruijn : {ctxt, metas, s : _} -> 57 | Term metas ctxt s -> 58 | Diamond (\ ctxt => CoTerm metas ctxt s) ctxt 59 | coDeBruijn (Var v) = Var <$> coDeBruijn v 60 | coDeBruijn (Met m sg) = coDeBruijnM _ m sg 61 | coDeBruijn (Fun b) = Fun <$> bind (coDeBruijn b) 62 | coDeBruijn (Call op ts) = Call op <$> coDeBruijns ts 63 | 64 | coDeBruijns [] = MkDiamond none [] 65 | coDeBruijns (t :: ts) = Cons <$> relevant (coDeBruijn t) (coDeBruijns ts) 66 | 67 | coDeBruijnS [<] = MkDiamond none [<] 68 | coDeBruijnS (sg :< t) = Snoc <$> relevant (coDeBruijnS sg) (coDeBruijn t) 69 | 70 | export 71 | deBruijns : CoTerms metas ctxt tys -> 72 | Thinning ctxt ctxt' -> 73 | All (Term metas ctxt') tys 74 | 75 | export 76 | deBruijnS : CoSubst metas ctxt tys -> 77 | Thinning ctxt ctxt' -> 78 | Subst metas ctxt' tys 79 | 80 | export 81 | deBruijn : CoTerm metas ctxt s -> Thinning ctxt ctxt' -> Term metas ctxt' s 82 | deBruijn (Var v) th = Var (thin (deBruijn v) th) 83 | deBruijn (Met m sg) th = Met m (deBruijnS sg th) 84 | deBruijn (Fun (K b)) th = Fun (deBruijn b (Skip th)) 85 | deBruijn (Fun (R x b)) th = Fun (deBruijn b (Keep Refl th)) 86 | deBruijn (Call op ts) th = Call op (deBruijns ts th) 87 | 88 | deBruijns [] th = [] 89 | deBruijns (Cons (MkRelevant {th = left} {ph = right} t _ ts)) th 90 | = deBruijn t (left <.> th) :: deBruijns ts (right <.> th) 91 | 92 | deBruijnS [<] th = [<] 93 | deBruijnS (Snoc (MkRelevant {th = left} {ph = right} sg _ t)) th 94 | = deBruijnS sg (left <.> th) :< deBruijn t (right <.> th) 95 | -------------------------------------------------------------------------------- /src/Velo/Elaborator/Common.idr: -------------------------------------------------------------------------------- 1 | module Velo.Elaborator.Common 2 | 3 | import Decidable.Equality 4 | 5 | import Velo.Core 6 | import Velo.Error 7 | import Velo.Types 8 | 9 | import Toolkit.Decidable.Informative 10 | 11 | %default total 12 | 13 | export 14 | compare : (fc : FileContext) 15 | -> (a,b : Ty) 16 | -> Velo (a = b) 17 | compare fc a b 18 | = dec fc (Mismatch a b) 19 | (decEq a b) 20 | 21 | export 22 | isTyFunc : (fc : FileContext) -> (ty : Ty) -> Velo (IsTyFunc ty) 23 | isTyFunc fc ty = case isTyFunc ty of 24 | Just prf => pure prf 25 | Nothing => throwAt fc (FuncExpected ty) 26 | 27 | export 28 | dec : FileContext 29 | -> Elaborating.Error 30 | -> Dec a 31 | -> Velo a 32 | dec _ _ (Yes prf) 33 | = pure prf 34 | dec fc err (No _) 35 | = throwAt fc err 36 | 37 | export 38 | decInfo : FileContext 39 | -> Elaborating.Error 40 | -> DecInfo e a 41 | -> Velo a 42 | decInfo _ _ (Yes prf) 43 | = pure prf 44 | decInfo fc e (No msg prf) 45 | = throwAt fc e 46 | -------------------------------------------------------------------------------- /src/Velo/Elaborator/Instantiate.idr: -------------------------------------------------------------------------------- 1 | module Velo.Elaborator.Instantiate 2 | 3 | import Data.SnocList.Quantifiers 4 | import Data.List.Quantifiers 5 | import Toolkit.Data.List.Member 6 | 7 | import Velo.Types 8 | import Velo.IR.Common 9 | import Velo.IR.Term 10 | 11 | %default total 12 | 13 | export 14 | embed : Term [] ctxt ty -> Term metas ctxt ty 15 | -- Cannot be bothered to implement a complicated identity function 16 | embed = believe_me 17 | 18 | substV : 19 | IsVar old ty -> 20 | Subst metas new old -> 21 | Term metas new ty 22 | substV v [<] = absurd v 23 | substV v@_ (sg :< t) with (view v) 24 | _ | Here = t 25 | _ | There v' = substV v' sg 26 | 27 | export 28 | subst : 29 | Term metas old ty -> 30 | Subst metas new old -> 31 | Term metas new ty 32 | 33 | substS : 34 | Subst metas old ty -> 35 | Subst metas new old -> 36 | Subst metas new ty 37 | 38 | substs : 39 | {0 tys : List Ty} -> 40 | All (Term metas old) tys -> 41 | Subst metas new old -> 42 | All (Term metas new) tys 43 | 44 | subst (Var v) sg = substV v sg 45 | subst (Met m sg') sg = Met m (substS sg' sg) 46 | subst (Fun b) sg = Fun (subst b (mapProperty (rename shift) sg :< Var here)) 47 | subst (Call op ts) sg = Call op (substs ts sg) 48 | 49 | substS [<] sg = [<] 50 | substS (args :< arg) sg = substS args sg :< subst arg sg 51 | 52 | substs [] sg = [] 53 | substs (t :: ts) sg = subst t sg :: substs ts sg 54 | 55 | export 56 | instantiate : 57 | Term metas ctxt ty -> 58 | (p : IsMember metas m) -> 59 | Term (drop p) m.metaScope m.metaType -> 60 | Term (drop p) ctxt ty 61 | 62 | instantiates : 63 | {0 tys : List Ty} -> 64 | All (Term metas ctxt) tys -> 65 | (p : IsMember metas m) -> 66 | Term (drop p) m.metaScope m.metaType -> 67 | All (Term (drop p) ctxt) tys 68 | 69 | instantiateS : 70 | Subst metas ctxt tys -> 71 | (p : IsMember metas m) -> 72 | Term (drop p) m.metaScope m.metaType -> 73 | Subst (drop p) ctxt tys 74 | 75 | instantiate (Var v) p t = Var v 76 | instantiate (Met mem sg) prf t with (hetDecEq prf mem) 77 | instantiate (Met mem sg) .(mem) t 78 | | Yes (Refl, Refl) = subst t (instantiateS sg mem t) 79 | instantiate (Met mem sg) prf t 80 | | No neq = Met (dropNeq neq) (instantiateS sg prf t) 81 | instantiate (Fun b) p t = Fun (instantiate b p t) 82 | instantiate (Call op ts) p t = Call op (instantiates ts p t) 83 | 84 | instantiates [] p t = [] 85 | instantiates (arg :: args) p t = instantiate arg p t :: instantiates args p t 86 | 87 | instantiateS [<] p t = [<] 88 | instantiateS (args :< arg) p t = instantiateS args p t :< instantiate arg p t 89 | -------------------------------------------------------------------------------- /src/Velo/Error.idr: -------------------------------------------------------------------------------- 1 | ||| Stuff that goes wrong. 2 | ||| 3 | ||| 4 | ||| Copyright : see COPYRIGHT 5 | ||| License : see LICENSE 6 | ||| 7 | module Velo.Error 8 | 9 | import Data.String 10 | 11 | import System.File 12 | import Toolkit.Data.Location 13 | import Toolkit.System 14 | import Toolkit.Text.Lexer.Run 15 | import Toolkit.Text.Parser.Run 16 | 17 | import Toolkit.Options.ArgParse 18 | 19 | import Velo.Types 20 | 21 | import Velo.Lexer.Token 22 | 23 | 24 | %default total 25 | 26 | namespace Options 27 | public export 28 | data Error : Type where 29 | OError : ArgParseError -> Options.Error 30 | 31 | namespace Lexing 32 | public export 33 | data Error : Type where 34 | LError : String -> LexFail -> Lexing.Error 35 | 36 | namespace Parsing 37 | public export 38 | data Error : Type where 39 | PError : String -> ParseError (Token) -> Parsing.Error 40 | 41 | namespace Elaborating 42 | public export 43 | data Error = Mismatch Ty Ty 44 | | NotBound String 45 | | FuncExpected Ty 46 | | Hole String 47 | | Err FileContext Elaborating.Error 48 | 49 | namespace Evaluating 50 | public export 51 | data Error = OOF 52 | 53 | namespace Velo 54 | 55 | public export 56 | data Error : Type where 57 | Internal : String -> Velo.Error 58 | Generic : String -> Velo.Error 59 | Opts : Options.Error -> Velo.Error 60 | Lex : Lexing.Error -> Velo.Error 61 | Parse : Parsing.Error -> Velo.Error 62 | Elab : Elaborating.Error -> Velo.Error 63 | Eval : Evaluating.Error -> Velo.Error 64 | 65 | -- [ EOF ] 66 | -------------------------------------------------------------------------------- /src/Velo/Error/Pretty.idr: -------------------------------------------------------------------------------- 1 | module Velo.Error.Pretty 2 | 3 | import Data.String 4 | import Data.List1 5 | import System.File 6 | import Toolkit.Data.Location 7 | import Toolkit.System 8 | import Toolkit.Text.Lexer.Run 9 | import Toolkit.Text.Parser.Run 10 | import Toolkit.Options.ArgParse 11 | 12 | import Text.Lexer 13 | 14 | import Velo.Types 15 | import Velo.Error 16 | import Velo.Lexer.Token 17 | 18 | -- @TODO Make error messages prettier. 19 | 20 | %default total 21 | 22 | Show (Lexing.Error) where 23 | show (LError _ e) = show e 24 | 25 | Show (Options.Error) where 26 | show (OError err) 27 | = show err 28 | 29 | Show (Parsing.Error) where 30 | show (PError _ err) 31 | = show err 32 | 33 | Show (Evaluating.Error) where 34 | show OOF = "Out of Fuel" 35 | 36 | 37 | [veloFC] Show FileContext where 38 | show (MkFC fname (MkLoc _ l scol) (MkLoc _ _ ecol)) 39 | = concat [ maybe "global" id fname 40 | , ":" 41 | , show (S l) 42 | , ":" 43 | , show (S scol) 44 | , "-" 45 | , show (S ecol) 46 | , ":" 47 | ] 48 | 49 | 50 | Show (Elaborating.Error) where 51 | show (Hole msg) 52 | = "Hole error:\n\t\{show msg}" 53 | 54 | show (Err fc err) 55 | = unlines [show @{veloFC} fc 56 | , show err] 57 | 58 | show (FuncExpected ty) 59 | = "Function expected, was given:\n\t\{show ty}" 60 | 61 | show (NotBound ref) 62 | = "Not a bound identifier:\n\t\{show ref}" 63 | 64 | show (Mismatch given expected) 65 | = unlines ["Type Mismatch:" 66 | , " Given:" 67 | , " \{show given}" 68 | , " Expected:" 69 | , " \{show expected}" 70 | ] 71 | 72 | export 73 | Show (Velo.Error) where 74 | show (Internal err) 75 | = "Not supposed to happen:\n\t\{err}" 76 | show (Generic err) 77 | = show err 78 | 79 | show (Opts r) 80 | = show r 81 | 82 | show (Lex x) 83 | = show x 84 | 85 | show (Parse x) 86 | = show x 87 | 88 | show (Elab x) 89 | = show x 90 | show (Eval x) 91 | = show x 92 | 93 | -- [ EOF ] 94 | -------------------------------------------------------------------------------- /src/Velo/Eval.idr: -------------------------------------------------------------------------------- 1 | module Velo.Eval 2 | 3 | import public Toolkit.DeBruijn.Evaluation 4 | 5 | import Velo.Types 6 | import Velo.IR.Common 7 | import Velo.IR.Term 8 | import Velo.Values 9 | 10 | import public Velo.Semantics.Reductions 11 | import Velo.Semantics.Progress 12 | 13 | import Velo.Core 14 | 15 | export 16 | eval : {type : Ty} 17 | -> (this : Term metas [<] type) 18 | -> Velo (Result Value Redux this) 19 | eval this 20 | = maybe (throw (Eval OOF)) 21 | (pure) 22 | (eval this) 23 | 24 | 25 | -- [ EOF ] 26 | -------------------------------------------------------------------------------- /src/Velo/Lexer.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | ||| Copyright : see COPYRIGHT 3 | ||| License : see LICENSE 4 | ||| 5 | module Velo.Lexer 6 | 7 | import public Data.List.Elem 8 | 9 | import public Text.Lexer 10 | 11 | import public Toolkit.Text.Lexer.Run 12 | 13 | import public Velo.Lexer.Token 14 | 15 | import Velo.Core 16 | 17 | %default total 18 | 19 | namespace Velo 20 | public export 21 | Symbols : List String 22 | Symbols = [ -- special composite symbols 23 | "->", "=>" 24 | -- Deliminators 25 | , "(", ")" 26 | 27 | -- Plain-old Symbols 28 | , ":" 29 | , "=" 30 | , "?" 31 | ] 32 | 33 | 34 | public export 35 | Keywords : List String 36 | Keywords = [ "fun", "let", "in" 37 | 38 | -- CTors 39 | , "true", "false" 40 | , "zero", "inc" 41 | 42 | -- Operations 43 | , "and", "add" 44 | , "the" 45 | 46 | -- Types 47 | , "nat", "bool" 48 | ] 49 | 50 | 51 | identifier : Lexer 52 | identifier = pred startIdent <+> many (pred validIdent) 53 | where 54 | startIdent : Char -> Bool 55 | startIdent '_' = True 56 | startIdent x = isAlpha x 57 | 58 | validIdent : Char -> Bool 59 | validIdent '_' = True 60 | validIdent x = isAlphaNum x 61 | 62 | namespace Velo 63 | 64 | tokenMap : TokenMap Velo.Token 65 | tokenMap = with List 66 | [ 67 | (space, WS) 68 | , (lineComment (exact "--"), LineComment) 69 | , (blockComment (exact "{-") (exact "-}"), BlockComment) 70 | ] 71 | ++ 72 | map (\x => (exact x, Symbol)) Symbols 73 | ++ 74 | [ 75 | (identifier, (\x => if elem x Keywords then Keyword x else ID x)) 76 | , (any, NotRecognised) 77 | ] 78 | 79 | keep : WithBounds Velo.Token -> Bool 80 | keep (MkBounded t _ _) = case t of 81 | BlockComment _ => False 82 | LineComment _ => False 83 | WS _ => False 84 | _ => True 85 | 86 | 87 | 88 | 89 | public export 90 | IsKeyword : String -> Type 91 | IsKeyword s = Elem s Velo.Keywords 92 | 93 | public export 94 | IsSymbol : String -> Type 95 | IsSymbol s = Elem s Velo.Symbols 96 | 97 | export 98 | Lexer : Lexer Token 99 | Lexer = MkLexer (Lexer.Velo.tokenMap) keep EndInput 100 | 101 | export 102 | lexFile : String -> Velo (List (WithBounds Token)) 103 | lexFile fname 104 | = do toks <- lexFile (\e => Lex (LError fname e)) 105 | Velo.Lexer 106 | fname 107 | pure toks 108 | 109 | -- [ EOF ] 110 | -------------------------------------------------------------------------------- /src/Velo/Lexer/Token.idr: -------------------------------------------------------------------------------- 1 | ||| Copyright : see COPYRIGHT 2 | ||| License : see LICENSE 3 | ||| 4 | module Velo.Lexer.Token 5 | 6 | import Text.Bounded 7 | 8 | %default total 9 | 10 | public export 11 | data Identifier = MkIdentifier String 12 | 13 | export 14 | Eq Identifier where 15 | (==) (MkIdentifier x) (MkIdentifier y) = x == y 16 | 17 | namespace Velo 18 | public export 19 | data Token = ID String 20 | | Keyword String 21 | | LineComment String 22 | | BlockComment String 23 | 24 | | Symbol String 25 | | WS String 26 | | NotRecognised String 27 | | EndInput 28 | 29 | showToken : Show a => String -> a -> String 30 | showToken n a 31 | = "(\{n} \{show a})" 32 | 33 | export 34 | Show Token where 35 | show (ID id) = showToken "ID" id 36 | show (Keyword str) = showToken "Keyword" str 37 | show (LineComment str) = showToken "LineComment" str 38 | 39 | show (BlockComment str) = showToken "BlockComment" str 40 | 41 | show (Symbol s) = showToken "Symbol" s 42 | show (WS ws) = "WS" 43 | show (NotRecognised s) = showToken "Urgh" s 44 | show EndInput = "EndInput" 45 | 46 | export 47 | [veloWB] Show a => Show (WithBounds a) where 48 | show (MkBounded t _ _) = show t 49 | 50 | export 51 | [veloWBs] Show (List (WithBounds Token)) where 52 | show ts = show $ map (show @{veloWB} ) ts 53 | 54 | export 55 | Eq Token where 56 | (==) (ID x) (ID y) = x == y 57 | 58 | (==) (LineComment x) (LineComment y) = x == y 59 | (==) (Keyword x) (Keyword y) = x == y 60 | 61 | (==) (Symbol x) (Symbol y) = x == y 62 | 63 | (==) (WS x) (WS y) = x == y 64 | (==) (NotRecognised x) (NotRecognised y) = x == y 65 | (==) EndInput EndInput = True 66 | (==) _ _ = False 67 | 68 | 69 | -- [ EOF ] 70 | -------------------------------------------------------------------------------- /src/Velo/Options.idr: -------------------------------------------------------------------------------- 1 | module Velo.Options 2 | 3 | import Toolkit.Options.ArgParse 4 | import Toolkit.Logging.Simple 5 | 6 | import Velo.Core 7 | 8 | %default total 9 | 10 | public export 11 | record Opts where 12 | constructor O 13 | justLex : Bool 14 | justCheck : Bool 15 | repl : Bool 16 | logLevel : LogLevel 17 | file : Maybe String 18 | 19 | Show Opts where 20 | show (O l c r lvl f) 21 | = "O \{show l} \{show c} \{show r} \{show lvl} \{show f}" 22 | 23 | Eq Opts where 24 | (==) x y 25 | = justLex x == justLex y 26 | && justCheck x == justCheck y 27 | && repl x == repl y 28 | && logLevel x == logLevel y 29 | && file x == file y 30 | 31 | convOpts : Arg -> Opts -> Maybe Opts 32 | 33 | convOpts (File x) o 34 | = Just $ { file := Just x} o 35 | 36 | convOpts (KeyValue k v) o 37 | = Just o 38 | 39 | convOpts (Flag x) o 40 | = case x of 41 | "repl" 42 | => Just $ { repl := True} o 43 | "lexOnly" 44 | => Just $ { justLex := True} o 45 | "checkOnly" 46 | => Just $ { justCheck := True} o 47 | otherwise => Nothing 48 | 49 | defOpts : Opts 50 | defOpts = O False False False OFF Nothing 51 | 52 | export 53 | getOpts : Velo Opts 54 | getOpts 55 | = parseArgs 56 | (Opts . OError) 57 | defOpts 58 | convOpts 59 | 60 | -- [ EOF ] 61 | -------------------------------------------------------------------------------- /src/Velo/Parser/API.idr: -------------------------------------------------------------------------------- 1 | ||| 2 | 3 | ||| Copyright : see COPYRIGHT 4 | ||| License : see LICENSE 5 | ||| 6 | module Velo.Parser.API 7 | 8 | import public Text.Parser 9 | import public Data.List.Elem 10 | import public System.File.Mode 11 | 12 | import Data.Maybe 13 | 14 | import public Toolkit.Data.Location 15 | import public Toolkit.Text.Lexer.Run 16 | import public Toolkit.Text.Parser.Support 17 | import public Toolkit.Text.Parser.Location 18 | import public Toolkit.Text.Parser.Run 19 | 20 | 21 | import Velo.Core 22 | 23 | import public Velo.Lexer.Token 24 | import public Velo.Lexer 25 | 26 | 27 | %default total 28 | 29 | namespace Velo 30 | public export 31 | Rule : Type -> Type 32 | Rule = Rule Unit Token 33 | 34 | public export 35 | RuleEmpty : Type -> Type 36 | RuleEmpty = RuleEmpty Unit Token 37 | 38 | export 39 | fromString : (rule : Rule a) 40 | -> (fname : String) 41 | -> Velo a 42 | fromString rule str 43 | = parseString (\p => Parse (PError str p)) 44 | Velo.Lexer rule str 45 | 46 | export 47 | eoi : RuleEmpty Unit 48 | eoi = eoi isEOI 49 | where 50 | isEOI : Token -> Bool 51 | isEOI EndInput = True 52 | isEOI _ = False 53 | 54 | 55 | export 56 | symbol : (str : String) 57 | -> Rule Unit 58 | symbol str 59 | = terminal ("Expected Symbol '" ++ str ++ "'") 60 | (\x => case x of 61 | Symbol s => if s == str then Just MkUnit 62 | else Nothing 63 | _ => Nothing) 64 | 65 | export 66 | keyword : (str : String) 67 | -> Rule Builtin.Unit 68 | keyword str 69 | = terminal ("Expected Keyword '" ++ str ++ "'") 70 | (\x => case x of 71 | Keyword s => if s == str then Just Builtin.MkUnit 72 | else Nothing 73 | _ => Nothing) 74 | 75 | identifier : Rule String 76 | identifier 77 | = terminal "Expected Identifier" 78 | (\x => case x of 79 | ID str => Just str 80 | _ => Nothing) 81 | 82 | export 83 | name : Rule String 84 | name = identifier 85 | 86 | export 87 | ref : Rule Ref 88 | ref = 89 | do s <- Toolkit.location 90 | n <- identifier 91 | e <- Toolkit.location 92 | pure (MkRef (newFC s e) n) 93 | 94 | 95 | export 96 | keywordLoc : (s : String) -> Rule FileContext 97 | keywordLoc str 98 | = do s <- Toolkit.location 99 | keyword str 100 | e <- Toolkit.location 101 | pure (newFC s e) 102 | 103 | 104 | export 105 | withLoc : Rule a -> Rule (FileContext, a) 106 | withLoc r 107 | = do s <- Toolkit.location 108 | v <- r 109 | e <- Toolkit.location 110 | pure (newFC s e, v) 111 | 112 | export 113 | gives : (s : String) -> a -> Rule a 114 | gives str ctor 115 | = do keyword str 116 | pure ctor 117 | 118 | export 119 | givesWithLoc : (s : String) -> (FileContext -> a) -> Rule a 120 | givesWithLoc str ctor 121 | = do loc <- withLoc (keyword str) 122 | pure (ctor (fst loc)) 123 | 124 | -- [ EOF ] 125 | -------------------------------------------------------------------------------- /src/Velo/Pipeline.idr: -------------------------------------------------------------------------------- 1 | module Velo.Pipeline 2 | 3 | import Data.SnocList.Quantifiers 4 | import Data.List.Quantifiers 5 | import Data.String 6 | 7 | import Velo.Types 8 | import Velo.Values 9 | 10 | import Velo.Core 11 | import Velo.IR.Common 12 | import Velo.IR.AST 13 | import Velo.IR.Holey 14 | import Velo.IR.Term 15 | import Velo.Parser 16 | import Velo.Lexer 17 | import Velo.Elaborator.Holey 18 | import Velo.Elaborator.Term 19 | import Velo.Elaborator 20 | import Velo.Eval 21 | import Velo.Trace 22 | import Velo.Options 23 | import Velo.Commands 24 | 25 | %default total 26 | 27 | export 28 | pipeline : Opts -> Velo () 29 | pipeline opts 30 | = do fname <- embed 31 | (Generic "File expected.") 32 | (file opts) 33 | 34 | let level = if justCheck opts 35 | then OFF 36 | else ALL 37 | 38 | 39 | when (justLex opts) 40 | $ do toks <- lexFile fname 41 | putStrLn (show @{veloWBs} toks) 42 | exitSuccess 43 | 44 | ast <- fromFile fname 45 | logWhen INFO level "# Finished Parsing" 46 | 47 | res <- elab [<] ast 48 | 49 | logWhen INFO level "# Finished Type Checking" 50 | 51 | unless (null res.metas) $ 52 | prettyMetas res.metas 53 | 54 | when (justCheck opts) 55 | $ exitSuccess 56 | 57 | v <- eval res.term 58 | log INFO "# Finished Executing" 59 | 60 | prettyComputation v 61 | log INFO "# Finished" 62 | 63 | -- [ EOF ] 64 | -------------------------------------------------------------------------------- /src/Velo/Semantics/Progress.idr: -------------------------------------------------------------------------------- 1 | module Velo.Semantics.Progress 2 | 3 | import Decidable.Equality 4 | 5 | import public Toolkit.DeBruijn.Progress 6 | 7 | import Velo.Types 8 | import Velo.IR.Common 9 | import Velo.IR.Term 10 | import Velo.Values 11 | import Velo.Semantics.Reductions 12 | 13 | %default total 14 | 15 | public export 16 | data Progresss : {tys : List Ty} -> (args : All (Term metas [<]) tys) 17 | -> Type 18 | where 19 | Dones : (vals : Values args) 20 | -> Progresss args 21 | 22 | Steps : {0 tys : List Ty} 23 | -> {0 these : All (Term metas [<]) tys} 24 | -> {those : All (Term metas [<]) tys} 25 | -> (step : Reduxes these those) 26 | -> Progresss these 27 | 28 | export 29 | compute : {tys : List Ty} 30 | -> {0 op : Prim tys ty} 31 | -> ComputePrim op 32 | -> {args : All (Term metas [<]) tys} 33 | -> Values args 34 | -> Progress Value Redux (Call op args) 35 | compute Add [m, n] = case m of 36 | Call Zero [] => Step (ReduceAddZW n) 37 | Call Plus [m] => Step (RewriteEqNatPW (Call Plus [m]) n) 38 | Call True _ impossible 39 | Call False _ impossible 40 | 41 | compute And [b, c] = case b of 42 | Call False [] => Step ReduceAndFW 43 | Call True [] => case c of 44 | Call False [] => Step ReduceAndWF 45 | Call True [] => Step ReduceAndTT 46 | Call Zero _ impossible 47 | Call Plus _ impossible 48 | Call Zero _ impossible 49 | Call Plus _ impossible 50 | 51 | compute App [f, t] = case f of 52 | Fun => Step (ReduceFuncApp t) 53 | Call _ _ impossible 54 | 55 | export 56 | call : {tys : _} 57 | -> (p : Prim tys ty) 58 | -> {args : All (Term metas [<]) tys} 59 | -> Progresss args 60 | -> Progress Value Redux (Call p args) 61 | call p (Steps stes) = Step (SimplifyCall p stes) 62 | call p (Dones vals) = case isValuePrim p of 63 | Left pv => Done (Call pv vals) 64 | Right npv => compute npv vals 65 | 66 | namespace Velo 67 | export 68 | progresss : {tys : List Ty} 69 | -> (args : All (Term metas [<]) tys) 70 | -> Progresss args 71 | export 72 | progress : {0 ty : Ty} 73 | -> (term : Term metas [<] ty) 74 | -> Progress Value Redux term 75 | 76 | progresss [] = Dones [] 77 | progresss (arg :: args) with (progress arg) 78 | _ | Step step = Steps (step !: args) 79 | _ | Done val with (progresss args) 80 | _ | Dones vals = Dones (val :: vals) 81 | _ | Steps stes = Steps (val :: stes) 82 | 83 | progress (Var v) = absurd v 84 | 85 | progress (Met v th) 86 | = Done Met 87 | 88 | progress (Fun body) 89 | = Done Fun 90 | 91 | progress (Call p args) = call p (progresss args) 92 | 93 | public export 94 | Progressable (Term metas [<] s) Value Redux where 95 | progress = Velo.progress 96 | 97 | -- [ EOF ] 98 | -------------------------------------------------------------------------------- /src/Velo/Semantics/Reductions.idr: -------------------------------------------------------------------------------- 1 | module Velo.Semantics.Reductions 2 | 3 | import Decidable.Equality 4 | 5 | import Velo.Types 6 | import Velo.IR.Common 7 | import Velo.IR.Term 8 | import Velo.Values 9 | 10 | %default total 11 | 12 | data Reduxes : {tys : List Ty} -> (these, those : All (Term metas ctxt) tys) -> Type 13 | data Redux : (this,that : Term metas ctxt type) -> Type 14 | 15 | infixr 7 !: 16 | 17 | public export 18 | data Reduxes :{tys : List Ty} -> (these, those : All (Term metas ctxt) tys) 19 | -> Type 20 | where 21 | 22 | (!:) : {0 tys : List Ty} 23 | -> (hd : Redux this that) 24 | -> (rest : All (Term metas ctxt) tys) 25 | -> Reduxes (this :: rest) (that :: rest) 26 | 27 | (::) : (value : Value hd) 28 | -> (tl : Reduxes these those) 29 | -> Reduxes (hd :: these) (hd :: those) 30 | 31 | public export 32 | data Redux : (this,that : Term metas ctxt type) 33 | -> Type 34 | where 35 | 36 | -- [ Call ] 37 | SimplifyCall : (p : Prim tys ty) 38 | -> (step : Reduxes these those) 39 | -> Redux (Call p these) (Call p those) 40 | 41 | -- [ Nats ] 42 | ReduceAddZW : (value : Value right) 43 | -> Redux (Call Add [Call Zero [], right]) 44 | right 45 | 46 | RewriteEqNatPW : (valueL : Value (Call Plus [this])) 47 | -> (valueR : Value right) 48 | -> Redux (Call Add [Call Plus [this], right]) 49 | (Call Add [this, Call Plus [right]]) 50 | 51 | 52 | -- [ Bool ] 53 | 54 | ReduceAndTT : Redux (Call And [Call True [], Call True []]) 55 | (Call True []) 56 | 57 | ReduceAndWF : Redux (Call And [left, Call False []]) 58 | (Call False []) 59 | 60 | ReduceAndFW : Redux (Call And [Call False [], right]) 61 | (Call False []) 62 | 63 | 64 | ReduceFuncApp : {body : Term metas (ctxt :< type) return} 65 | -> {var : Term metas ctxt type} 66 | -> Value var 67 | -> Redux (Call App [Fun body, var]) 68 | (Single.subst var body) 69 | 70 | 71 | -- [ EOF ] 72 | -------------------------------------------------------------------------------- /src/Velo/Types.idr: -------------------------------------------------------------------------------- 1 | module Velo.Types 2 | 3 | import Control.Function 4 | import Decidable.Equality 5 | 6 | import Toolkit.Data.Comparison.Informative 7 | 8 | %default total 9 | 10 | public export 11 | data Ty = TyNat 12 | | TyBool 13 | | TyFunc Ty Ty 14 | 15 | export 16 | Show Ty where 17 | showPrec d TyNat = "Nat" 18 | showPrec d TyBool = "Bool" 19 | showPrec d (TyFunc a b) = 20 | showParens (d > Open) $ 21 | "\{showPrec App a} -> \{show b}" 22 | 23 | export 24 | Uninhabited (TyNat = TyBool) where 25 | uninhabited Refl impossible 26 | 27 | export 28 | Uninhabited (TyNat = TyFunc x y) where 29 | uninhabited Refl impossible 30 | 31 | export 32 | Uninhabited (TyBool = TyFunc x y) where 33 | uninhabited Refl impossible 34 | 35 | export 36 | Biinjective TyFunc where 37 | biinjective Refl = (Refl, Refl) 38 | 39 | namespace IsTyFunct 40 | 41 | public export 42 | data IsTyFunc : Ty -> Type where 43 | TyFunc : (a, b : Ty) -> IsTyFunc (TyFunc a b) 44 | 45 | export 46 | isTyFunc : (ty : Ty) -> Maybe (IsTyFunc ty) 47 | isTyFunc (TyFunc a b) = pure (TyFunc a b) 48 | isTyFunc _ = Nothing 49 | 50 | 51 | public export 52 | DecEq Ty where 53 | decEq TyNat TyNat 54 | = Yes Refl 55 | 56 | decEq TyNat TyBool 57 | = No absurd 58 | 59 | decEq TyNat (TyFunc x y) 60 | = No absurd 61 | 62 | 63 | decEq TyBool TyNat 64 | = No (negEqSym absurd) 65 | 66 | decEq TyBool TyBool 67 | = Yes Refl 68 | 69 | decEq TyBool (TyFunc x y) 70 | = No absurd 71 | 72 | decEq (TyFunc x z) TyNat 73 | = No (negEqSym absurd) 74 | 75 | decEq (TyFunc x z) TyBool 76 | = No (negEqSym absurd) 77 | 78 | decEq (TyFunc aA rA) (TyFunc aB rB) 79 | = decEqCong2 (decEq aA aB) (decEq rA rB) 80 | 81 | public export 82 | Comparable Ty Ty where 83 | cmp TyNat TyNat = EQ 84 | cmp TyNat t = LT 85 | cmp s TyNat = GT 86 | cmp TyBool TyBool = EQ 87 | cmp TyBool t = LT 88 | cmp s TyBool = GT 89 | cmp (TyFunc a b) (TyFunc s t) with (cmp a s) 90 | _ | LT = LT 91 | cmp (TyFunc a b) (TyFunc .(a) t) 92 | | EQ with (cmp b t) 93 | _ | LT = LT 94 | cmp (TyFunc a b) (TyFunc .(a) .(b)) 95 | | EQ | EQ = EQ 96 | _ | GT = GT 97 | _ | GT = GT 98 | 99 | -- [ EOF ] 100 | -------------------------------------------------------------------------------- /src/Velo/Unelaboration.idr: -------------------------------------------------------------------------------- 1 | module Velo.Unelaboration 2 | 3 | import Data.List1 4 | import Data.SnocList 5 | import Data.SnocList.Quantifiers 6 | 7 | import Velo.Types 8 | import Velo.IR.Common 9 | import Velo.IR.AST 10 | import Velo.IR.Term 11 | 12 | %default total 13 | 14 | fresh : {0 ctxt : SnocList Ty} -> All Item ctxt -> Ty -> String 15 | fresh nms ty 16 | = go (forget $ mapProperty (\ (I str _) => str) nms) 17 | ((,Nothing) <$> hints ty) where 18 | 19 | hints : Ty -> List1 String 20 | hints TyNat = "m" ::: ["n", "p", "q"] 21 | hints TyBool = "b" ::: ["x", "y"] 22 | hints (TyFunc x y) = "f" ::: ["g", "h"] 23 | 24 | toName : (String, Maybe Nat) -> String 25 | toName (str, mn) = maybe str ((str ++) . show) mn 26 | 27 | candidate : SnocList String -> List1 (String, Maybe Nat) -> Maybe String 28 | candidate used = choice . map (\ tn => delay $ do 29 | let nm = toName tn 30 | guard (not (nm `elem` used)) 31 | pure nm) 32 | 33 | go : SnocList String -> List1 (String, Maybe Nat) -> String 34 | go used cs = case candidate used cs of 35 | Just str => str 36 | Nothing => assert_total (go used (map (map (Just . maybe 0 S)) cs)) 37 | 38 | var : All Item ctxt -> IsVar ctxt t -> String 39 | var [<] v = absurd v 40 | var (nms :< I x _) v@_ with (view v) 41 | _ | Here = x 42 | _ | There v' = var nms v' 43 | 44 | meta : {0 m : Meta} -> {metas : _} -> 45 | All Item ctxt -> 46 | IsMember metas m -> 47 | Subst metas ctxt (metaScope m) -> 48 | RawEmpty 49 | 50 | checking : {metas, t : _} -> All Item ctxt -> 51 | Term metas ctxt t -> RawEmpty 52 | synthing : {metas, t : _} -> All Item ctxt -> 53 | Term metas ctxt t -> RawEmpty 54 | 55 | meta nms p sg with (lookup p) 56 | _ | (MkMeta nm supp _ ** Refl) = go 0 supp sg (Branch (Hole nm) () Nil) where 57 | 58 | go : Nat -> All Item tys -> Subst metas ctxt tys -> RawEmpty -> RawEmpty 59 | go n [<] _ t = t 60 | go n (xs :< I x _) (sg :< u@(Var (V m p))) t 61 | = ifThenElse (n == m) 62 | (go (S n) xs sg t) 63 | (go (S n) xs sg (Branch (Let x) () [(synthing nms u), t])) 64 | go n (xs :< I x _) (sg :< u) t 65 | = go (S n) xs sg (Branch (Let x) () [(synthing nms u), t]) 66 | 67 | calling : {metas, tys : _} -> All Item ctxt -> 68 | Prim tys ty -> All (Term metas ctxt) tys -> RawEmpty 69 | calling nms Zero ts 70 | = Branch Zero () Nil 71 | calling nms Plus [t] 72 | = Branch Plus () [(checking nms t)] 73 | calling nms Add [s,t] 74 | = Branch Add () [(checking nms s), (checking nms t)] 75 | calling nms True ts 76 | = Branch T () Nil 77 | calling nms False ts 78 | = Branch F () Nil 79 | calling nms And [s,t] 80 | = Branch And () [(checking nms s), (checking nms t)] 81 | 82 | calling nms App [f,t] 83 | = case f of 84 | Fun b => let x = fresh nms (typeOf t) in 85 | Branch (Let x) () [(synthing nms t), (synthing (nms :< I x _) b)] 86 | _ => Branch App () [(synthing nms f), (checking nms t)] 87 | 88 | checking nms (Met m sg) = meta nms m sg 89 | checking nms t = synthing nms t 90 | 91 | synthing nms (Var v) 92 | = Branch (Ref (var nms v)) () Nil 93 | synthing nms (Met m sg) 94 | = Branch (The t) () [meta nms m sg] 95 | synthing nms (Fun {a = dom} b) 96 | = let x = fresh nms dom in 97 | Branch (Fun x dom) () [synthing (nms :< I x _) b] 98 | synthing nms (Call op ts) 99 | = calling nms op ts 100 | 101 | export 102 | unelaborate : {metas, t : _} -> Term metas [<] t -> RawEmpty 103 | unelaborate = synthing [<] 104 | -------------------------------------------------------------------------------- /src/Velo/Values.idr: -------------------------------------------------------------------------------- 1 | module Velo.Values 2 | 3 | import Decidable.Equality 4 | 5 | import Velo.Types 6 | import Velo.IR.Common 7 | import Velo.IR.Term 8 | 9 | %default total 10 | 11 | public export 12 | data ValuePrim : (op : Prim tys ty) 13 | -> Type 14 | where 15 | Zero : ValuePrim Zero 16 | Plus : ValuePrim Plus 17 | True : ValuePrim True 18 | False : ValuePrim False 19 | 20 | public export 21 | data ComputePrim : (op : Prim tys ty) 22 | -> Type 23 | where 24 | Add : ComputePrim Add 25 | And : ComputePrim And 26 | App : ComputePrim App 27 | 28 | public export 29 | isValuePrim : (op : Prim tys ty) 30 | -> Either (ValuePrim op) (ComputePrim op) 31 | isValuePrim Zero = Left Zero 32 | isValuePrim Plus = Left Plus 33 | isValuePrim Add = Right Add 34 | isValuePrim True = Left True 35 | isValuePrim False = Left False 36 | isValuePrim And = Right And 37 | isValuePrim App = Right App 38 | 39 | data Values : {0 tys : List Ty} -> (args : All (Term metas ctxt) tys) -> Type 40 | data Value : (term : Term metas ctxt type) -> Type 41 | 42 | public export 43 | data Values : {0 tys : List Ty} -> (args : All (Term metas ctxt) tys) 44 | -> Type 45 | where 46 | 47 | Nil : Values [] 48 | (::) : (value : Value t) 49 | -> (values : Values ts) 50 | -> Values (t :: ts) 51 | 52 | public export 53 | data Value : (term : Term metas ctxt type) 54 | -> Type 55 | where 56 | Met : Value (Met m sg) 57 | 58 | Fun : Value (Fun body) 59 | 60 | Call : (prim : ValuePrim op) 61 | -> (values : Values ts) 62 | -> Value (Call op ts) 63 | 64 | 65 | -- [ EOF ] 66 | -------------------------------------------------------------------------------- /tests/.gitignore: -------------------------------------------------------------------------------- 1 | failures 2 | report.md 3 | report.csv 4 | report.json 5 | -------------------------------------------------------------------------------- /tests/Main.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Data.List 4 | 5 | import Test.Golden 6 | 7 | %default total 8 | 9 | working : IO TestPool 10 | working 11 | = testsInDir "working" 12 | (const True) 13 | "Passing Tests" 14 | [] 15 | Nothing 16 | 17 | covering 18 | main : IO () 19 | main 20 | = runner [ !working 21 | ] 22 | 23 | -- [ EOF ] 24 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | # -- [ Makefile ] 2 | # 3 | # Makefile for the project's test suite. 4 | # 5 | # Copyright : (c) Jan de Muijnck-Hughes 6 | # License : see ../LICENSE 7 | # 8 | # -- [ EOH ] 9 | 10 | PROJECT=testing 11 | IDRIS2=idris2 12 | HYPERFINE=hyperfine 13 | 14 | 15 | TARGETDIR = ./build/exec 16 | TARGET = ${TARGETDIR}/velo-tests 17 | 18 | UPDATE ?= --interactive 19 | THREADS ?= $(shell (nproc || sysctl -n hw.ncpu) 2>/dev/null || echo 1) 20 | 21 | # [ Testing Targets ] 22 | 23 | .PHONY: testbin test test-re 24 | 25 | # Build the test suite 26 | testbin: 27 | ${IDRIS2} --build ${PROJECT}.ipkg 28 | 29 | # Run the test suite storing failures in the failure file. 30 | test: 31 | ${TARGET} \ 32 | $(PROG_BIN) \ 33 | --timing \ 34 | $(UPDATE) \ 35 | --threads $(THREADS) \ 36 | --failure-file failures \ 37 | --only $(ONLY) 38 | 39 | # Only re-run the failed tests. 40 | test-re: 41 | ${TARGET} \ 42 | $(PROG_BIN) \ 43 | $(UDATE) \ 44 | --timing \ 45 | --failure-file failures \ 46 | --threads $(THREADS) \ 47 | --only-file failures \ 48 | --only $(ONLY) 49 | 50 | # [ Housekeeping ] 51 | 52 | .PHONY: clobber clean 53 | 54 | clean: 55 | $(IDRIS2) --clean ${PROJECT}.ipkg 56 | @find . -type f -name 'output' | xargs rm -f 57 | 58 | clobber: clean 59 | ${RM} -rf build/ 60 | ${RM} -rf failures 61 | 62 | # -- [ EOF ] 63 | -------------------------------------------------------------------------------- /tests/testing.ipkg: -------------------------------------------------------------------------------- 1 | -- [ Manifest ] 2 | -- 3 | -- Testing Manifest 4 | -- 5 | -- Copyright : (c) Jan de Muijnck-Hughes 6 | -- License : see ../LICENSE 7 | -- 8 | -- 9 | package testing 10 | 11 | depends = contrib, test 12 | 13 | executable = velo-tests 14 | 15 | main = Main 16 | 17 | -- [ EOF ] 18 | -------------------------------------------------------------------------------- /tests/working/000-bonjour/expected: -------------------------------------------------------------------------------- 1 | Running Test 2 | [ INFO ] # Finished Parsing 3 | [ INFO ] # Finished Type Checking 4 | [ INFO ] # Finished Executing 5 | ``` 6 | let m = zero 7 | in let n = (inc m) 8 | in let p = (add m n) 9 | in let b = true 10 | in let x = false 11 | in let y = (and b x) 12 | in let f = (fun q : Nat => q) 13 | in (f zero) 14 | ``` 15 | ### Reduce Application 16 | ``` 17 | let m = (inc zero) 18 | in let n = (add zero m) 19 | in let b = true 20 | in let x = false 21 | in let y = (and b x) 22 | in let f = (fun p : Nat => p) 23 | in (f zero) 24 | ``` 25 | ### Reduce Application 26 | ``` 27 | let m = (add zero (inc zero)) 28 | in let b = true 29 | in let x = false 30 | in let y = (and b x) 31 | in let f = (fun n : Nat => n) 32 | in (f zero) 33 | ``` 34 | ### Simplify Application Variable by Reduce Add Left is Zero 35 | ``` 36 | let m = (inc zero) 37 | in let b = true 38 | in let x = false 39 | in let y = (and b x) 40 | in let f = (fun n : Nat => n) 41 | in (f zero) 42 | ``` 43 | ### Reduce Application 44 | ``` 45 | let b = true 46 | in let x = false 47 | in let y = (and b x) 48 | in let f = (fun m : Nat => m) 49 | in (f zero) 50 | ``` 51 | ### Reduce Application 52 | ``` 53 | let b = false 54 | in let x = (and true b) 55 | in let f = (fun m : Nat => m) 56 | in (f zero) 57 | ``` 58 | ### Reduce Application 59 | ``` 60 | let b = (and true false) 61 | in let f = (fun m : Nat => m) 62 | in (f zero) 63 | ``` 64 | ### Simplify Application Variable by Reduce And Right is False 65 | ``` 66 | let b = false 67 | in let f = (fun m : Nat => m) 68 | in (f zero) 69 | ``` 70 | ### Reduce Application 71 | ``` 72 | let f = (fun m : Nat => m) 73 | in (f zero) 74 | ``` 75 | ### Reduce Application 76 | ``` 77 | let m = zero 78 | in m 79 | ``` 80 | ### Reduce Application 81 | ``` 82 | zero 83 | ``` 84 | [ INFO ] # Finished 85 | -------------------------------------------------------------------------------- /tests/working/000-bonjour/main.velo: -------------------------------------------------------------------------------- 1 | let a = zero 2 | in let b = (inc a) 3 | in let c = (add a b) 4 | 5 | in let d = true 6 | in let e = false 7 | in let f = (and d e) 8 | 9 | in let foo = (fun x : nat => x) 10 | in (foo zero) 11 | -------------------------------------------------------------------------------- /tests/working/000-bonjour/run: -------------------------------------------------------------------------------- 1 | echo "Running Test" 2 | 3 | $1 main.velo 4 | 5 | 6 | # Local Variables: 7 | # mode: sh 8 | # End: 9 | 10 | # -- [ EOF ] 11 | -------------------------------------------------------------------------------- /tests/working/001-cse/expected: -------------------------------------------------------------------------------- 1 | Running Test 2 | [ INFO ] # Finished Parsing 3 | [ INFO ] # Finished Type Checking 4 | [ INFO ] # Finished Executing 5 | ``` 6 | let m = (inc (inc zero)) 7 | in let n = (add m m) 8 | in let p = (add m m) 9 | in let q = (add n p) 10 | in q 11 | ``` 12 | ### Reduce Application 13 | ``` 14 | let m = (add (inc (inc zero)) (inc (inc zero))) 15 | in let n = (add (inc (inc zero)) (inc (inc zero))) 16 | in let p = (add m n) 17 | in p 18 | ``` 19 | ### Simplify Application Variable by Rewriting Add 20 | ``` 21 | let m = (add (inc zero) (inc (inc (inc zero)))) 22 | in let n = (add (inc (inc zero)) (inc (inc zero))) 23 | in let p = (add m n) 24 | in p 25 | ``` 26 | ### Simplify Application Variable by Rewriting Add 27 | ``` 28 | let m = (add zero (inc (inc (inc (inc zero))))) 29 | in let n = (add (inc (inc zero)) (inc (inc zero))) 30 | in let p = (add m n) 31 | in p 32 | ``` 33 | ### Simplify Application Variable by Reduce Add Left is Zero 34 | ``` 35 | let m = (inc (inc (inc (inc zero)))) 36 | in let n = (add (inc (inc zero)) (inc (inc zero))) 37 | in let p = (add m n) 38 | in p 39 | ``` 40 | ### Reduce Application 41 | ``` 42 | let m = (add (inc (inc zero)) (inc (inc zero))) 43 | in let n = (add (inc (inc (inc (inc zero)))) m) 44 | in n 45 | ``` 46 | ### Simplify Application Variable by Rewriting Add 47 | ``` 48 | let m = (add (inc zero) (inc (inc (inc zero)))) 49 | in let n = (add (inc (inc (inc (inc zero)))) m) 50 | in n 51 | ``` 52 | ### Simplify Application Variable by Rewriting Add 53 | ``` 54 | let m = (add zero (inc (inc (inc (inc zero))))) 55 | in let n = (add (inc (inc (inc (inc zero)))) m) 56 | in n 57 | ``` 58 | ### Simplify Application Variable by Reduce Add Left is Zero 59 | ``` 60 | let m = (inc (inc (inc (inc zero)))) 61 | in let n = (add (inc (inc (inc (inc zero)))) m) 62 | in n 63 | ``` 64 | ### Reduce Application 65 | ``` 66 | let m = (add (inc (inc (inc (inc zero)))) (inc (inc (inc (inc zero))))) 67 | in m 68 | ``` 69 | ### Simplify Application Variable by Rewriting Add 70 | ``` 71 | let m = (add (inc (inc (inc zero))) (inc (inc (inc (inc (inc zero)))))) 72 | in m 73 | ``` 74 | ### Simplify Application Variable by Rewriting Add 75 | ``` 76 | let m = (add (inc (inc zero)) (inc (inc (inc (inc (inc (inc zero))))))) 77 | in m 78 | ``` 79 | ### Simplify Application Variable by Rewriting Add 80 | ``` 81 | let m = (add (inc zero) (inc (inc (inc (inc (inc (inc (inc zero)))))))) 82 | in m 83 | ``` 84 | ### Simplify Application Variable by Rewriting Add 85 | ``` 86 | let m = (add zero (inc (inc (inc (inc (inc (inc (inc (inc zero))))))))) 87 | in m 88 | ``` 89 | ### Simplify Application Variable by Reduce Add Left is Zero 90 | ``` 91 | let m = (inc (inc (inc (inc (inc (inc (inc (inc zero)))))))) 92 | in m 93 | ``` 94 | ### Reduce Application 95 | ``` 96 | (inc (inc (inc (inc (inc (inc (inc (inc zero)))))))) 97 | ``` 98 | [ INFO ] # Finished 99 | -------------------------------------------------------------------------------- /tests/working/001-cse/main.velo: -------------------------------------------------------------------------------- 1 | let a = (inc (inc zero)) 2 | in let b = (add a a) 3 | in let c = (add a a) 4 | in let d = (add b c) 5 | 6 | in d 7 | -------------------------------------------------------------------------------- /tests/working/001-cse/run: -------------------------------------------------------------------------------- 1 | echo "Running Test" 2 | 3 | $1 main.velo 4 | 5 | 6 | # Local Variables: 7 | # mode: sh 8 | # End: 9 | 10 | # -- [ EOF ] 11 | -------------------------------------------------------------------------------- /tests/working/002-holes/expected: -------------------------------------------------------------------------------- 1 | Running Test 2 | [ INFO ] # Finished Parsing 3 | [ INFO ] # Finished Type Checking 4 | a : Nat 5 | ---------- 6 | ?a : Nat 7 | 8 | a : Nat 9 | b : Nat 10 | c : Nat 11 | ---------- 12 | ?c : Nat 13 | 14 | -------------------------------------------------------------------------------- /tests/working/002-holes/main.velo: -------------------------------------------------------------------------------- 1 | let a = (inc (inc zero)) 2 | in let b = (add a ?a) 3 | in let c = (add a ?a) 4 | in let d = (add b ?c) 5 | 6 | in d 7 | -------------------------------------------------------------------------------- /tests/working/002-holes/run: -------------------------------------------------------------------------------- 1 | echo "Running Test" 2 | 3 | $1 main.velo 4 | 5 | 6 | # Local Variables: 7 | # mode: sh 8 | # End: 9 | 10 | # -- [ EOF ] 11 | -------------------------------------------------------------------------------- /tests/working/003-shadowing/expected: -------------------------------------------------------------------------------- 1 | Running Test 2 | [ INFO ] # Finished Parsing 3 | [ INFO ] # Finished Type Checking 4 | a : Nat -> Nat 5 | ---------- 6 | ?hole : Nat 7 | 8 | [ INFO ] # Finished Executing 9 | ``` 10 | let m = (inc (inc zero)) 11 | in let b = true 12 | in let x = false 13 | in let n = (inc zero) 14 | in let f = (fun p : Nat => p) 15 | in (?hole : Nat) 16 | ``` 17 | ### Reduce Application 18 | ``` 19 | let b = true 20 | in let x = false 21 | in let m = (inc zero) 22 | in let f = (fun n : Nat => n) 23 | in (let a = (inc (inc zero)) in ?hole : Nat) 24 | ``` 25 | ### Reduce Application 26 | ``` 27 | let b = false 28 | in let m = (inc zero) 29 | in let f = (fun n : Nat => n) 30 | in (let a = (inc (inc zero)) in let a = true in ?hole : Nat) 31 | ``` 32 | ### Reduce Application 33 | ``` 34 | let m = (inc zero) 35 | in let f = (fun n : Nat => n) 36 | in (let a = (inc (inc zero)) in let a = true in let a = false in ?hole : Nat) 37 | ``` 38 | ### Reduce Application 39 | ``` 40 | let f = (fun m : Nat => m) 41 | in (let a = (inc (inc zero)) 42 | in let a = true 43 | in let a = false 44 | in let a = (inc zero) 45 | in ?hole : Nat) 46 | ``` 47 | ### Reduce Application 48 | ``` 49 | (let a = (inc (inc zero)) 50 | in let a = true 51 | in let a = false 52 | in let a = (inc zero) 53 | in let a = (fun m : Nat => m) 54 | in ?hole : Nat) 55 | ``` 56 | [ INFO ] # Finished 57 | -------------------------------------------------------------------------------- /tests/working/003-shadowing/main.velo: -------------------------------------------------------------------------------- 1 | let a = (inc (inc zero)) 2 | in let a = true 3 | in let a = false 4 | in let a = (inc zero) 5 | in let a = (fun x : nat => x) 6 | in (?hole : nat) -------------------------------------------------------------------------------- /tests/working/003-shadowing/run: -------------------------------------------------------------------------------- 1 | echo "Running Test" 2 | 3 | $1 main.velo 4 | 5 | 6 | # Local Variables: 7 | # mode: sh 8 | # End: 9 | 10 | # -- [ EOF ] 11 | -------------------------------------------------------------------------------- /tests/working/004-repl/expected: -------------------------------------------------------------------------------- 1 | Running Test 2 | Velo> Need to load a file. 3 | Velo> [:q,:quit,:exit] 4 | Exit the REPL. 5 | [:?,:h,:help] 6 | Show the list of available commands. 7 | [:holes] 8 | Show the current list of holes. 9 | [:hole_type,:t] [name] 10 | Show the specified hole. 11 | [:instantiate,:i] [name] {term} 12 | Instantiate the specified hole with the given term. 13 | [:eval] 14 | Eval the loaded program. 15 | [:cse] 16 | Perform common sub-expression elimination on the loaded program. 17 | [:simpl] 18 | Perform constant folding on the loaded program. 19 | [:show] 20 | Print the loaded program. 21 | [:load,:l] [file] 22 | Load a program. 23 | 24 | Velo> # Finished Parsing 25 | # Finished Type-Checking 26 | Velo> a : Nat 27 | b : Nat 28 | c : Nat 29 | ---------- 30 | ?c : Nat 31 | 32 | Velo> a : Nat 33 | ---------- 34 | ?a : Nat 35 | 36 | a : Nat 37 | b : Nat 38 | c : Nat 39 | ---------- 40 | ?c : Nat 41 | 42 | Velo> Quitting, Goodbye. 43 | -------------------------------------------------------------------------------- /tests/working/004-repl/input: -------------------------------------------------------------------------------- 1 | :holes 2 | :help 3 | :load main.velo 4 | :t c 5 | :holes 6 | :quit 7 | -------------------------------------------------------------------------------- /tests/working/004-repl/main.velo: -------------------------------------------------------------------------------- 1 | let a = (inc (inc zero)) 2 | in let b = (add a ?a) 3 | in let c = (add a ?a) 4 | in let d = (add b ?c) 5 | 6 | in d 7 | -------------------------------------------------------------------------------- /tests/working/004-repl/run: -------------------------------------------------------------------------------- 1 | echo "Running Test" 2 | 3 | $1 --repl < input 4 | 5 | 6 | # Local Variables: 7 | # mode: sh 8 | # End: 9 | 10 | # -- [ EOF ] 11 | -------------------------------------------------------------------------------- /tests/working/005-cse/expected: -------------------------------------------------------------------------------- 1 | Running Test 2 | Velo> # Finished Parsing 3 | # Finished Type-Checking 4 | Velo> let m = zero 5 | in let n = (inc zero) 6 | in (add (add (add m n) (add n m)) (add (add n m) (add m n))) 7 | Velo> let m = zero 8 | in let n = (inc zero) 9 | in let p = (add n m) 10 | in let q = (add m n) 11 | in (add (add q p) (add p q)) 12 | Velo> Quitting, Goodbye. 13 | -------------------------------------------------------------------------------- /tests/working/005-cse/input: -------------------------------------------------------------------------------- 1 | :load main.velo 2 | :show 3 | :cse 4 | :quit 5 | -------------------------------------------------------------------------------- /tests/working/005-cse/main.velo: -------------------------------------------------------------------------------- 1 | let m = zero in 2 | let n = (inc zero) in 3 | (add (add (add m n) (add n m)) 4 | (add (add n m) (add m n))) -------------------------------------------------------------------------------- /tests/working/005-cse/run: -------------------------------------------------------------------------------- 1 | echo "Running Test" 2 | 3 | $1 --repl < input 4 | 5 | 6 | # Local Variables: 7 | # mode: sh 8 | # End: 9 | 10 | # -- [ EOF ] 11 | -------------------------------------------------------------------------------- /tests/working/006-instantiate/expected: -------------------------------------------------------------------------------- 1 | Running Test 2 | Velo> # Finished Parsing 3 | # Finished Type-Checking 4 | Velo> (fun m : Nat 5 | => (add ?hole1 let n = (inc zero) 6 | in (add let x = m in ?hole1 (add ?hole2 ?hole3)))) 7 | Velo> x : Nat 8 | ---------- 9 | ?hole1 : Nat 10 | 11 | x : Nat 12 | b : Nat 13 | ---------- 14 | ?hole2 : Nat 15 | 16 | x : Nat 17 | b : Nat 18 | ---------- 19 | ?hole3 : Nat 20 | 21 | Velo> (fun m : Nat => (add m let n = (inc zero) in (add m (add ?hole2 ?hole3)))) 22 | Velo> x : Nat 23 | b : Nat 24 | ---------- 25 | ?hole2 : Nat 26 | 27 | x : Nat 28 | b : Nat 29 | ---------- 30 | ?hole3 : Nat 31 | 32 | Velo> (fun m : Nat => (add m let n = (inc zero) in (add m (add (add m n) ?hole3)))) 33 | Velo> x : Nat 34 | b : Nat 35 | ---------- 36 | ?hole3 : Nat 37 | 38 | Velo> (fun m : Nat => (add m let n = (inc zero) in (add m (add (add m n) zero)))) 39 | Velo> No Holes 40 | Velo> Quitting, Goodbye. 41 | -------------------------------------------------------------------------------- /tests/working/006-instantiate/input: -------------------------------------------------------------------------------- 1 | :load main.velo 2 | :show 3 | :holes 4 | :instantiate hole1 x 5 | :holes 6 | :instantiate hole2 (add x b) 7 | :holes 8 | :i hole3 (zero : nat) 9 | :holes 10 | :quit 11 | -------------------------------------------------------------------------------- /tests/working/006-instantiate/main.velo: -------------------------------------------------------------------------------- 1 | (fun x : nat => 2 | (add ?hole1 3 | let b = (inc zero) 4 | in (add ?hole1 (add ?hole2 ?hole3)))) -------------------------------------------------------------------------------- /tests/working/006-instantiate/run: -------------------------------------------------------------------------------- 1 | echo "Running Test" 2 | 3 | $1 --repl < input 4 | 5 | 6 | # Local Variables: 7 | # mode: sh 8 | # End: 9 | 10 | # -- [ EOF ] 11 | -------------------------------------------------------------------------------- /tests/working/007-paper-intro/expected: -------------------------------------------------------------------------------- 1 | Running Test 2 | Velo> # Finished Parsing 3 | # Finished Type-Checking 4 | Velo> b : Bool 5 | double : Nat -> Nat 6 | ---------- 7 | ?hole : Nat 8 | 9 | Velo> Quitting, Goodbye. 10 | -------------------------------------------------------------------------------- /tests/working/007-paper-intro/input: -------------------------------------------------------------------------------- 1 | :load main.velo 2 | :holes 3 | :quit 4 | -------------------------------------------------------------------------------- /tests/working/007-paper-intro/main.velo: -------------------------------------------------------------------------------- 1 | let b = false 2 | in let double = (fun x : nat => (add x x)) 3 | in let x = (double ?hole) 4 | in (double ?hole) 5 | -------------------------------------------------------------------------------- /tests/working/007-paper-intro/run: -------------------------------------------------------------------------------- 1 | echo "Running Test" 2 | 3 | $1 --repl < input 4 | 5 | 6 | # Local Variables: 7 | # mode: sh 8 | # End: 9 | 10 | # -- [ EOF ] 11 | -------------------------------------------------------------------------------- /velo.ipkg: -------------------------------------------------------------------------------- 1 | package velo 2 | 3 | depends = contrib 4 | 5 | main = Main 6 | 7 | sourcedir = "src" 8 | executable = velo 9 | 10 | modules = Velo.Types 11 | 12 | , Velo.Values 13 | 14 | , Velo.Semantics.Reductions 15 | , Velo.Semantics.Progress 16 | 17 | , Velo.Error 18 | , Velo.Error.Pretty 19 | , Velo.Core 20 | 21 | , Velo.IR.Common 22 | , Velo.IR.AST 23 | , Velo.IR.Holey 24 | , Velo.IR.Term 25 | , Velo.IR.CoTerm 26 | 27 | , Velo.Elaborator.Common 28 | , Velo.Elaborator.Holey 29 | , Velo.Elaborator.Term 30 | , Velo.Elaborator.CoDeBruijn 31 | , Velo.Elaborator.Instantiate 32 | 33 | , Velo.Lexer.Token 34 | , Velo.Lexer 35 | , Velo.Parser 36 | 37 | , Velo.Pass.Folding 38 | , Velo.Pass.CSE 39 | 40 | , Velo.Unelaboration 41 | 42 | , Velo.Trace 43 | 44 | , Velo.Options 45 | , Velo.Commands 46 | , Velo.REPL 47 | 48 | , Main 49 | --------------------------------------------------------------------------------