├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── bin ├── check.sh └── install.sh ├── examples ├── apply.shen ├── days.shen └── nat.shen ├── info.rkt ├── lang ├── bindings.rkt ├── configure-runtime.rkt ├── expander.rkt ├── failure.rkt ├── interposition-points.rkt ├── iso-prolog-bnf.rkt ├── lang-info.rkt ├── load.rkt ├── macros.rkt ├── namespace-requires.rkt ├── namespaces.rkt ├── packages.rkt ├── pairs.rkt ├── printer.rkt ├── prolog-debug-gui.rkt ├── prolog-syntax-expanders.rkt ├── prolog-syntax.rkt ├── prolog.rkt ├── racket-iso-prolog-term-interface.rkt ├── reader-tests.rkt ├── reader.rkt ├── scryer-prolog-interface.rkt ├── syntax-utils.rkt ├── system-function-exports.rkt ├── system-functions.rkt ├── systemf.rkt ├── type-syntax-expanders.rkt └── types-syntax.rkt ├── repl.rkt ├── screenshots ├── apply_failure_1.png └── debug_window.png ├── scryer-server ├── scryer-prolog-server.pl ├── scryer-shen-ipc.pl ├── scryer-shen-toplevel.pl └── type-checker │ ├── inference_rules.pl │ ├── rule_expanders.pl │ ├── term_variables.pl │ ├── type-checker.pl │ └── type_variables.pl ├── shen-tests.shen └── tools ├── colorer.rkt └── submit.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | # These are some examples of commonly ignored file patterns. 2 | # You should customize this list as applicable to your project. 3 | # Learn more about .gitignore: 4 | # https://www.atlassian.com/git/tutorials/saving-changes/gitignore 5 | 6 | # Node artifact files 7 | node_modules/ 8 | dist/ 9 | 10 | # Compiled Java class files 11 | *.class 12 | 13 | # Compiled Python bytecode 14 | *.py[cod] 15 | 16 | # Log files 17 | *.log 18 | 19 | # Package files 20 | *.jar 21 | 22 | # Maven 23 | target/ 24 | dist/ 25 | 26 | # JetBrains IDE 27 | .idea/ 28 | 29 | # Unit test reports 30 | TEST*.xml 31 | 32 | # Generated by MacOS 33 | .DS_Store 34 | 35 | # Generated by Windows 36 | Thumbs.db 37 | 38 | # Applications 39 | *.app 40 | *.exe 41 | *.war 42 | 43 | # Large media files 44 | *.mp4 45 | *.tiff 46 | *.avi 47 | *.flv 48 | *.mov 49 | *.wmv -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2024, Mark Thom 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SHELL := /bin/bash 2 | 3 | .PHONY: \ 4 | build-scryer-prolog \ 5 | check-requirements \ 6 | clone-scryer-prolog-repository \ 7 | clone-scryer-shen-repository \ 8 | ensure-scryer-prolog-availability \ 9 | ensure-scryer-shen-availability \ 10 | install \ 11 | install-rust-toolchain \ 12 | uninstall \ 13 | 14 | help: ### Show available commands short description 15 | @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' 16 | 17 | check-requirements: ### Check if requirements are satisfied 18 | @. ./bin/check.sh && \ 19 | check_requirements 20 | 21 | clone-scryer-prolog-repository: ### Clone scryer-prolog repository 22 | test -d scryer-prolog || ( cd dist && git clone https://github.com/mthom/scryer-prolog ) 23 | 24 | clone-scryer-shen-repository: ### Clone scryer-shen repository 25 | test -d scryer-shen || git clone https://github.com/mthom/scryer-shen 26 | 27 | install: check-requirements ### Install [scryer-shen with raco](https://github.com/mthom/scryer-shen/issues/2#issuecomment-2106059943) 28 | @. ./bin/install.sh && \ 29 | install 30 | 31 | install-rust-toolchain: check-requirements ### Install [default rust toolchain](https://rustup.rs/) 32 | @. ./bin/install.sh && \ 33 | install_rust_toolchain 34 | 35 | build-scryer-prolog: install-rust-toolchain clone-scryer-prolog-repository ### Build scryer-prolog executable 36 | ( cd dist/scryer-prolog && \ 37 | $$HOME/.cargo/bin/cargo build --release ) 38 | 39 | ensure-scryer-prolog-executable-availability: build-scryer-prolog ### Ensure Scryer prolog availability in ./dist/bin 40 | mkdir -p dist/bin && \ 41 | mv ./dist/scryer-prolog/target/release/scryer-prolog ./dist/bin 42 | 43 | ensure-scryer-shen-executable-availability: ensure-scryer-prolog-executable-availability ### Ensure Scryer shen availability in ./ 44 | make install 45 | 46 | uninstall: check-requirements ### Uninstall [scryer-shen with raco](https://github.com/mthom/scryer-shen/issues/2#issuecomment-2106059943) 47 | @. ./bin/install.sh && \ 48 | uninstall -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Scryer Shen 3 | 4 | An experimental, in-progress implementation of the [Shen programming 5 | language](https://www.shenlanguage.org) in Racket and [Scryer Prolog](https://github.com/mthom/scryer-prolog). 6 | 7 | Unlike most other implementations of Shen, scryer-shen implements Shen 8 | directly in its host languages without bootstrapping from a seed 9 | implementation of KLambda. 10 | 11 | The intention is to allow direct integration of Scryer Prolog inside a 12 | Shen implementation. Scryer Prolog is a performant ISO Prolog system 13 | with powerful metaprogramming capabilities and highly general and 14 | expressive constraint logic programming libraries over integers and 15 | booleans among many other features. 16 | 17 | The integration should naturally extend Shen's logic and type systems 18 | to allow styles of dependently typed programming and theorem proving akin to 19 | those found in programming languages like Agda and Lean. 20 | 21 | # Progress to a fully featured Shen implementation 22 | 23 | - [x] Add `define`, `defun` 24 | - [x] Add `defmacro` and `package` 25 | - [x] Add `defprolog` and `prolog?` 26 | - [x] Add `if` and `cond` forms 27 | - [x] Add `@v`, `@p` and `@s` constructors/patterns 28 | - [x] Add `freeze` and `thaw` 29 | - [x] Add `deftype` and support for type signatures in functions 30 | - [ ] Use `raco` and Racket's `compiler` API to automatically download, 31 | compile and package Scryer Prolog with Scryer Shen 32 | - [ ] Implement the rest of the Shen standard library 33 | - [ ] Implement Shen-YACC 34 | 35 | # Installation 36 | 37 | scryer-shen can be run in the Racket REPL (for 38 | `#lang shen` modules) or compiled to an executable using 39 | 40 | ```shell 41 | # Install [GNU Make](https://www.gnu.org/software/make/#download) 42 | # Install [racket](https://download.racket-lang.org/) 43 | # before 44 | # - logging into a shell terminal, and 45 | # - executing the following commands 46 | # from cloned `scryer-shen` project root directory 47 | # before passing `ensure-scryer-shen-executable-availability` target to make binary 48 | # so that making `shen` executable is made available 49 | make ensure-scryer-shen-executable-availability 50 | ``` 51 | 52 | The scryer-prolog executable must be copied to 53 | the install directory `dist/bin`. It can be downloaded from the above 54 | link and built by following the instructions there. Soon this requirement 55 | will be automated through raco. 56 | 57 | # Non-standard extensions of Shen Prolog 58 | 59 | Scryer Shen has full access to Scryer Prolog's library modules. They 60 | are loaded in `prolog?` forms using the non-standard syntax 61 | 62 | ``` 63 | (1-) (prolog? (use-module (library clpz))) 64 | ``` 65 | 66 | Also unlike standard Shen Prolog, Scryer Shen Prolog supports 67 | functor notation for the sake of partial evaluation in libraries 68 | like [`clpz`](https://github.com/triska/clpz): 69 | 70 | ``` 71 | (2-) (defprolog fac 72 | 0 1 <--; 73 | N R <-- (#> N 0) 74 | (#= N1 -(N 1)) 75 | (#= R *(N F1)) 76 | (fac N1 F1);) 77 | (3-) (prolog? (fac X 120) (return X)) 78 | 5 79 | ``` 80 | 81 | `-(N 1)` and `*(N F1)` annotate the ISO Prolog functors `-(N,1)` 82 | and `*(N,F1)` while s-expressions annotate either Shen function calls 83 | or Prolog predicate calls as in standard Shen Prolog. 84 | 85 | Scryer Shen Prolog predicates and queries are converted to ISO Prolog 86 | syntax and streamed to the Scryer Prolog subprocess. The interaction 87 | between Scryer Shen and Scryer Prolog is displayed in the Scryer 88 | Prolog Debug Window, which for the above interaction is 89 | 90 | ![Scryer Prolog Debug Window](screenshots/debug_window.png) 91 | 92 | These and other new features are described in [this wiki article.](https://github.com/mthom/scryer-shen/wiki/Some-novel-features-of-Scryer-Shen) 93 | 94 | # An example interaction 95 | 96 | The loaded files are found in [examples](https://github.com/mthom/scryer-shen/tree/master/examples). 97 | 98 | ```shen 99 | (0-) (tc +) 100 | true 101 | 102 | (1+) (load "examples/days.shen") 103 | days#type 104 | next-day : (day --> day) 105 | loaded : symbol 106 | 107 | (2+) (load "examples/apply.shen") 108 | h-list-to-function-sig 109 | heterogeneous-lists#type 110 | true 111 | heterogeneously-mappable-functions#type 112 | apply : ((h-mappable [A | B] C) --> ((h-list [A | B]) --> C)) 113 | loaded : symbol 114 | 115 | (3+) (apply + [1 2 3]) 116 | type error 117 | 118 | (4+) (apply + [1 2]) 119 | 3 : number 120 | 121 | (5+) [1 saturday] 122 | [1 saturday] : (h-list [number symbol]) 123 | 124 | (6+) (apply + [1]) 125 | curried:+ : (number --> number) 126 | 127 | (7+) (apply +) 128 | curried:apply : ((h-list [number]) --> (number --> number)) 129 | 130 | (8+) (fn apply) 131 | apply : ((h-mappable [A | B] C) --> ((h-list [A | B]) --> C)) 132 | ``` 133 | -------------------------------------------------------------------------------- /bin/check.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -Eeu 3 | 4 | # Test if requirements are satisfied 5 | function check_requirements { 6 | if ! command -v raco >>/dev/null 2>&1 || 7 | ! command -v ./dist/bin/scryer-prolog >>/dev/null 2>&1; then 8 | 9 | if ! command -v ./dist/bin/scryer-prolog >>/dev/null 2>&1; then 10 | printf '%s.%s' 'Please install [scryer-prolog](https://github.com/mthom/scryer-prolog/blob/42a0d686a5db241924490a5cca5c8b1d5bd0e5b0/README.md#installing-scryer-prolog) executable' $'\n' 11 | fi 12 | 13 | if ! command -v raco >>/dev/null 2>&1; then 14 | printf '%s.%s' 'Please install [raco](https://download.racket-lang.org/)' $'\n' 15 | fi 16 | 17 | return 1 18 | fi 19 | 20 | printf '%s.%s' 'Requirements (`scryer-prolog`, `raco`) appear to be satisfied' $'\n' 21 | } 22 | 23 | set +Eeu 24 | -------------------------------------------------------------------------------- /bin/install.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -Eeu 3 | 4 | # Install `scryer-shen` executable 5 | function install { 6 | if [ -e shen ]; 7 | then 8 | printf '%s.%s' 'shen executable exists already.' $'\n' 9 | 10 | return 0 11 | fi 12 | 13 | local raco_executable 14 | raco_executable=$(which raco) 15 | 16 | "${raco_executable}" setup --clean 17 | "${raco_executable}" setup 18 | 19 | ( cd ../ && \ 20 | "${raco_executable}" pkg install ./scryer-shen ) 21 | 22 | ( "${raco_executable}" exe --cs -o shen ++lib racket/lang/reader repl.rkt || \ 23 | "${raco_executable}" pkg show scryer-shen ) 24 | } 25 | 26 | # ⚠️ Requires [`curl`](https://curl.se/download.html) 27 | function install_rust_toolchain { 28 | curl \ 29 | --proto '=https' \ 30 | --tlsv1.2 \ 31 | -sSf https://sh.rustup.rs \ 32 | -o install-rust-toolchain.sh && \ 33 | sh -c '( chmod u+x ./install-rust-toolchain.sh && ./install-rust-toolchain.sh -y )' 34 | } 35 | 36 | # Uninstall `scryer-shen` executable 37 | function uninstall { 38 | ( cd ../ && \ 39 | raco pkg remove scryer-shen ) 40 | } 41 | 42 | set +Eeu 43 | -------------------------------------------------------------------------------- /examples/apply.shen: -------------------------------------------------------------------------------- 1 | (datatype heterogeneous-lists 2 | ____________________________ 3 | [] : (h-list Ts) >> Ts ~ []; 4 | 5 | _______________________________________________________________ 6 | [X|Xs] : (h-list Ts) >> X : T, Xs : (h-list Tss), Ts ~ [T|Tss]; 7 | 8 | _________________ 9 | [] : (h-list []); 10 | 11 | X : T; 12 | Xs : (h-list Ts); 13 | _________________________ 14 | [X|Xs] : (h-list [T|Ts]);) 15 | 16 | (defprolog h-list-to-function-sig 17 | [] R R <--; 18 | [T1 T2|Ts] -->(T1 Rs) R <-- (h-list-to-function-sig [T2|Ts] Rs R); 19 | [T] -->(T R) R <--;) 20 | 21 | (prolog? (use-module (library dif))) 22 | 23 | (datatype heterogeneously-mappable-functions 24 | F : (--> R); 25 | ====================== 26 | F : (h-mappable [] R); 27 | 28 | (dif R -->(_ _)); 29 | F : (T --> R); 30 | ======================= 31 | F : (h-mappable [T] R); 32 | 33 | (dif R -->(_ _)); 34 | F : (T1 --> (h-mappable [T2|Ts] R)); 35 | =================================== 36 | F : (h-mappable [T1 T2|Ts] R); 37 | 38 | F : (A --> B); 39 | (h-list-to-function-sig [T|Ts] (A --> B) R); 40 | ____________________________________________ 41 | F : (h-mappable [T|Ts] R);) 42 | 43 | (define apply 44 | { (h-mappable Ts R) --> (h-list Ts) --> R } 45 | F [] -> (F) 46 | F [X] -> (F X) 47 | F [X1 X2|Xs] -> (apply (F X1) [X2|Xs])) 48 | 49 | (define apply1 50 | { (h-mappable [T|Ts] R) --> (h-list [T|Ts]) --> R} 51 | F [X] -> (F X) 52 | F [X1 X2|Xs] -> (apply1 (F X1) [X2|Xs])) 53 | -------------------------------------------------------------------------------- /examples/days.shen: -------------------------------------------------------------------------------- 1 | (datatype days 2 | if (element? Day [monday tuesday wednesday thursday friday saturday sunday]) 3 | ____________________________________________________________________________ 4 | Day : day;) 5 | 6 | (define next-day 7 | { day --> day } 8 | monday -> tuesday 9 | tuesday -> wednesday 10 | wednesday -> thursday 11 | thursday -> friday 12 | friday -> saturday 13 | saturday -> sunday 14 | sunday -> monday) 15 | -------------------------------------------------------------------------------- /examples/nat.shen: -------------------------------------------------------------------------------- 1 | (prolog? (use-module (library clpz))) 2 | 3 | (datatype nat 4 | var(N); 5 | #>=(N 0); 6 | ========= 7 | N : nat; 8 | 9 | if (integer? N) 10 | if (>= N 0) 11 | _______________ 12 | N : nat; 13 | 14 | _______________________________________ 15 | (integer? N) : verified >> N : integer; 16 | 17 | __________________________ 18 | N : integer >> N : number; 19 | 20 | _______________________ 21 | N : nat >> N : integer; 22 | 23 | (nat? N) : verified; 24 | ____________________ 25 | N : nat;) 26 | 27 | (define nat? 28 | { A --> boolean } 29 | X -> (>= X 0) where (integer? X) 30 | _ -> false) 31 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "shen") 4 | 5 | (define deps '("base")) 6 | 7 | (define build-deps '("rackunit")) 8 | -------------------------------------------------------------------------------- /lang/bindings.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide shen-function-bindings 4 | shen-variable-bindings) 5 | 6 | (define shen-function-bindings (make-hasheq)) 7 | (define shen-variable-bindings (make-hasheq)) 8 | -------------------------------------------------------------------------------- /lang/configure-runtime.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide configure) 4 | 5 | (require (only-in "macros.rkt" expand-shen-form) 6 | (only-in "reader.rkt" shen-readtable) 7 | "printer.rkt") 8 | 9 | (define (configure data) 10 | (global-port-print-handler shen-printer) 11 | (current-read-interaction read-one-line)) 12 | 13 | (define (read-one-line origin port) 14 | (parameterize ([current-readtable shen-readtable]) 15 | (read-syntax origin port))) 16 | -------------------------------------------------------------------------------- /lang/expander.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "bindings.rkt" 4 | "macros.rkt" 5 | "namespaces.rkt" 6 | "packages.rkt" 7 | "pairs.rkt" 8 | "prolog.rkt" 9 | racket/stxparam 10 | syntax/parse/define 11 | "systemf.rkt" 12 | "type-syntax-expanders.rkt" 13 | (for-syntax "prolog-syntax-expanders.rkt" 14 | racket/base 15 | racket/function 16 | racket/match 17 | racket/port 18 | racket/provide-transform 19 | racket/stxparam 20 | racket/syntax 21 | (only-in "reader.rkt" 22 | shen-readtable) 23 | syntax/parse 24 | syntax/stx 25 | "syntax-utils.rkt" 26 | "types-syntax.rkt")) 27 | 28 | (define-for-syntax (variadic-op-macros name assoc) 29 | (syntax-parse assoc 30 | [(~datum #:right) 31 | #:with right-assoc-macro-id (format-id name "shen.~a-right-assoc-macro" name) 32 | (syntax-local-lift-module-end-declaration 33 | #`(shen-defmacro right-assoc-macro-id 34 | (cons #,name (cons Op1 (cons Op2 (cons Op3 Ops)))) 35 | -> 36 | (cons '#,name (cons Op1 (cons (cons '#,name (cons Op2 (cons Op3 Ops))) '())))))] 37 | [(~datum #:left) 38 | #:with left-assoc-macro-id (format-id name "shen.~a-left-assoc-macro" name) 39 | #`(shen-defmacro left-assoc-macro-id 40 | (cons #,name (cons Op1 (cons Op2 (cons Op3 Ops)))) 41 | -> 42 | (cons '#,name (cons (cons '#,name (cons Op1 (cons Op2 '()))) (cons Op3 Ops))))])) 43 | 44 | (define-syntax define-shen-function 45 | (syntax-parser 46 | [(_ fn:id racket-fn) 47 | #:with spaced-fn ((make-interned-syntax-introducer 'function) #'fn) 48 | #'(begin 49 | (define spaced-fn (procedure-rename racket-fn 'fn 'shen)) 50 | (hash-set! shen-function-bindings 'fn spaced-fn))])) 51 | 52 | (define-syntax shen-curry-out 53 | (make-provide-pre-transformer 54 | (lambda (export-list modes) 55 | (syntax-parse export-list 56 | [(_ . export-list) 57 | #:with (export ...) 58 | (stx-map (syntax-parser 59 | [f:shen-curry-out-export 60 | (when (syntax->datum #'f.assoc) 61 | (variadic-op-macros #'f.renamed-id #'f.assoc)) 62 | (syntax-local-lift-expression 63 | #'(systemf 'f.renamed-id)) 64 | (syntax-local-lift-module-end-declaration 65 | #'(define-shen-function f.renamed-id f.wrapper)) 66 | #'(for-space function f.renamed-id)]) 67 | (syntax->list #'export-list)) 68 | (pre-expand-export 69 | #'(combine-out export ...) 70 | modes)])))) 71 | 72 | (define-syntax shen-function-out 73 | (make-provide-pre-transformer 74 | (lambda (stx modes) 75 | (syntax-parse stx 76 | [(_ f:shen-function-out-export ...) 77 | #:do [(stx-map 78 | syntax-local-lift-module-end-declaration 79 | #'((define-shen-function f.renamed-id f.func-id) ...)) 80 | (stx-map 81 | syntax-local-lift-expression 82 | #'((systemf 'f.renamed-id) ...))] 83 | (pre-expand-export 84 | #'(for-space function f.renamed-id ...) 85 | modes)])))) 86 | 87 | (define-syntax shen-define 88 | (syntax-parser 89 | [(shen-define define-form:shen-define) 90 | #:when (attribute define-form.type-sig) 91 | #:cut 92 | (let-values ([(queries assert-strings retract-strings) 93 | (function-def->type-check-queries 94 | #'define-form.name 95 | #'define-form.type-sig 96 | #'(define-form.clause ...))]) 97 | #`(begin 98 | (define-shen-function define-form.name define-form.wrapper) 99 | (enqueue-function-type-data! '#,queries '#,assert-strings '#,retract-strings) 100 | define-form.name))] 101 | [(shen-define define-form:shen-define) 102 | #'(begin 103 | (define-shen-function define-form.name define-form.wrapper) 104 | define-form.name)] 105 | [shen-define:id #''define])) 106 | 107 | (define-syntax shen-defmacro 108 | (syntax-parser 109 | [(shen-defmacro defmacro:shen-defmacro) 110 | #'(add-shen-macro-expander! 'defmacro.name defmacro.expander)] 111 | [defmacro:id #''defmacro])) 112 | 113 | (define-syntax shen-package 114 | (syntax-parser 115 | [(shen-package package:shen-package) 116 | #:when (and (eq? (syntax->datum #'package.name) 'null) 117 | (eq? (syntax->datum #'package.export-list) '())) 118 | #'(begin package.top-level-decls ...)] 119 | [(shen-package package:shen-internal-package) 120 | (syntax-local-lift-expression 121 | #'(add-external-symbols-to-package! 122 | 'package.name 123 | 'package.external-symbols)) 124 | (syntax-local-lift-expression 125 | #'(add-internal-symbols-to-package! 126 | 'package.name 127 | 'package.internal-symbols)) 128 | #'(begin 129 | package.top-level-decls ...)])) 130 | 131 | (define-syntax shen-defprolog 132 | (syntax-parser 133 | [(shen-defprolog rule-name:id rule:shen-prolog-rule ...+) 134 | #:with iso-prolog-code (datum->syntax #'rule-name 135 | (expand-shen-defprolog #'rule-name #'(rule ...)) 136 | #'rule-name) 137 | #'(add-prolog-predicate! iso-prolog-code)])) 138 | 139 | (define-syntax shen-prolog? 140 | (syntax-parser 141 | [(shen-prolog? goal:prolog-body-pattern ...+) 142 | #:with iso-prolog-query (expand-shen-prolog-query #'(goal ...)) 143 | #'(run-prolog-query! iso-prolog-query)])) 144 | 145 | (define-syntax kl-defun 146 | (syntax-parser 147 | [(kl-defun defun:kl-defun) 148 | #'(define-shen-function defun.name defun.wrapper)] 149 | [defun:id #''defun])) 150 | 151 | (define-match-expander @p 152 | (syntax-parser 153 | [((~literal @p) arg1 arg2 ... args) 154 | #'(shen-tuple (vector arg1 arg2 ... args))]) 155 | (syntax-parser 156 | [((~literal @p) arg1 arg2 ... args) 157 | #'(shen-tuple (vector arg1 arg2 ... args))])) 158 | 159 | (define (@s-pattern num-chars) 160 | (lambda (str) 161 | (for/list ([ch (in-string str)] 162 | [n (in-range 0 (add1 num-chars))]) 163 | (if (= n num-chars) 164 | (substring str num-chars) 165 | (string ch))))) 166 | 167 | (define-match-expander @s 168 | (syntax-parser 169 | [((~literal @s) (~or arg:shen-var-id arg:unit-string) ...+ 170 | (~or last-arg:shen-var-id last-arg:string)) 171 | #:with num-chars (length (syntax->list #'(arg ...))) 172 | #'(? string? 173 | ;; quote is needed here to compensate for lack of #%datum in 174 | ;; the transformer phase 175 | (app (@s-pattern (quote num-chars)) 176 | (list arg ... last-arg)))]) 177 | (syntax-parser 178 | [((~literal @s) arg1 args ...+) 179 | #'(string-append arg1 args ...)])) 180 | 181 | (define (@v-pattern num-elts) 182 | (lambda (vec) 183 | (vector-append (vector-take vec num-elts) 184 | (vector (vector-drop vec num-elts))))) 185 | 186 | (define-match-expander @v 187 | (syntax-parser 188 | [((~literal @v) arg ...+ (~literal <>)) 189 | #:with num-elts (length (syntax->list #'(arg ...))) 190 | #'(vector arg ...)] 191 | [((~literal @v) arg ...+ last-arg) 192 | #:with num-elts (length (syntax->list #'(arg ...))) 193 | #'(? vector? 194 | (app (@v-pattern (quote num-elts)) 195 | (vector arg ... last-arg)))]) 196 | (syntax-parser 197 | [((~literal @v) arg ...+ last-arg) 198 | #'(vector-append (vector arg ...) last-arg)])) 199 | 200 | (define-syntax shen-lambda 201 | (syntax-parser 202 | [(shen-lambda lambda-form:shen-lambda-form) 203 | #'(procedure-rename (curry 204 | (lambda (lambda-form.var ...) 205 | lambda-form.body-expr)) 206 | 'anonymous-fn 207 | 'shen)])) 208 | 209 | (define-syntax shen-let 210 | (syntax-parser 211 | [(shen-let let-form:shen-let-form) 212 | #'(let* ([let-form.binding-id let-form.binding-expr] 213 | ...) 214 | let-form.body-expr)])) 215 | 216 | (define-syntax shen-cond 217 | (syntax-parser 218 | [(shen-cond cond-form:shen-cond-form) 219 | #'(cond [cond-form.condition cond-form.true-form] 220 | ... 221 | [else #f])])) 222 | 223 | (define-syntax shen-datatype 224 | (syntax-parser 225 | [(shen-datatype type-module-name:id sequent:shen-type-sequent ...+) 226 | #:with iso-prolog-type-definitions (datatype->type-definition 227 | #'type-module-name 228 | #'(sequent ...)) 229 | #'(enqueue-datatype-definition! (quote iso-prolog-type-definitions))])) 230 | 231 | (define-syntax shen-if 232 | (syntax-parser 233 | [(shen-if if-form:shen-if-form) 234 | #'(if if-form.condition if-form.true-form if-form.false-form)])) 235 | 236 | (define-syntax (shen-true stx) 237 | (syntax-case stx () 238 | [_:id #'#t])) 239 | 240 | (define-syntax (shen-false stx) 241 | (syntax-case stx () 242 | [_:id #'#f])) 243 | 244 | (define-syntax <> 245 | (syntax-parser 246 | [_:id #'#()])) 247 | 248 | (provide (protect-out <> 249 | @p 250 | @s 251 | @v 252 | kl-defun 253 | shen-curry-out 254 | shen-function-out) 255 | (rename-out [shen-true true] 256 | [shen-false false] 257 | [shen-datatype datatype] 258 | [shen-define define] 259 | [shen-cond cond] 260 | [shen-if if] 261 | [shen-let let] 262 | [shen-lambda /.] 263 | [shen-defmacro defmacro] 264 | [shen-defprolog defprolog] 265 | [shen-package package] 266 | [shen-prolog? prolog?])) 267 | -------------------------------------------------------------------------------- /lang/failure.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/stxparam) 4 | 5 | (provide (protect-out fail fail-if)) 6 | 7 | (define-values (struct:failure make-failure-object failure? failure-ref set-failure!) 8 | (make-struct-type 'failure #f 0 0)) 9 | 10 | (define failure-object (make-failure-object)) 11 | 12 | (define fail-if-fn 13 | (curry 14 | (lambda (fail-fn x) 15 | (if (fail-fn x) 16 | failure-object 17 | x)))) 18 | 19 | (define-syntax-parameter fail 20 | (syntax-id-rules (fail) 21 | [(fail) failure-object] 22 | [fail (lambda () failure-object)])) 23 | 24 | (define-syntax-parameter fail-if 25 | (syntax-id-rules (fail) 26 | [(fail-if fail-fn x) (fail-if-fn fail-fn x)] 27 | [fail-if fail-if-fn])) 28 | -------------------------------------------------------------------------------- /lang/interposition-points.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (only-in "system-functions.rkt" 4 | [eval shen:eval] 5 | function) 6 | "load.rkt" 7 | "macros.rkt" 8 | "namespaces.rkt" 9 | "printer.rkt" 10 | "prolog.rkt" 11 | (only-in "reader.rkt" detect-prolog-syntax) 12 | (for-syntax syntax/parse 13 | "syntax-utils.rkt") 14 | syntax/parse 15 | "syntax-utils.rkt" 16 | "type-syntax-expanders.rkt") 17 | 18 | (provide app 19 | top) 20 | 21 | (define-syntax (app stx) 22 | (syntax-parse stx 23 | [(app) 24 | (syntax/loc stx empty)] 25 | [(app . (proc-var:shen-var-id . args)) 26 | (syntax/loc stx (#%app . ((app function proc-var) . args)))] 27 | [(app . (proc:id . args)) 28 | #:with fs-proc ((make-interned-syntax-introducer 'function) #'proc) 29 | (syntax/loc stx (#%app fs-proc . args))] 30 | [(app . form) 31 | (syntax/loc stx (#%app . form))])) 32 | 33 | (define-syntax (top stx) 34 | (syntax-parse stx 35 | [(top . id:shen-var-id) 36 | (if (syntax-property #'id 'bound) 37 | (syntax/loc stx (#%top . id)) 38 | (syntax/loc stx (quote id)))] 39 | [(top . id:id) 40 | (syntax/loc stx (quote id))])) 41 | -------------------------------------------------------------------------------- /lang/iso-prolog-bnf.rkt: -------------------------------------------------------------------------------- 1 | #lang brag 2 | 3 | term : clause | variable | atom | number | list | string 4 | 5 | clause : atom /"(" term (/"," term)* /")" 6 | 7 | list : /"[" term (/"," term)* /"]" | /"[" term (/"," term)* BAR term /"]" | "'.'" /"(" term /"," term /")" 8 | 9 | atom : ATOM 10 | 11 | string : STRING 12 | 13 | number : NUMBER 14 | 15 | variable : VARIABLE 16 | -------------------------------------------------------------------------------- /lang/lang-info.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define (get-info data) 4 | (λ (key default) 5 | (case key 6 | [(configure-runtime) 7 | '(#(shen/lang/configure-runtime configure #f))] 8 | [(color-lexer) 9 | (dynamic-require 'shen/tools/colorer 'shen-colorer)] 10 | [else 11 | default]))) 12 | 13 | (provide get-info) -------------------------------------------------------------------------------- /lang/load.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (only-in "expander.rkt" 4 | shen-function-out) 5 | "macros.rkt" 6 | "namespaces.rkt" 7 | "printer.rkt" 8 | "prolog.rkt" 9 | "prolog-syntax-expanders.rkt" 10 | (only-in "reader.rkt" 11 | detect-prolog-syntax 12 | shen-readtable) 13 | racket/syntax 14 | syntax/parse 15 | "syntax-utils.rkt" 16 | (only-in "system-functions.rkt" 17 | [eval shen:eval]) 18 | "type-syntax-expanders.rkt") 19 | 20 | (provide (protect-out (struct-out shen-type-check-exn)) 21 | (shen-function-out load) 22 | expression-type-check 23 | load-shen-form 24 | post-load-type-check!) 25 | 26 | (struct shen-type-check-exn exn:fail () 27 | #:transparent) 28 | 29 | ;; return #t iff it was passed an expression 30 | (define (post-load-type-check!) 31 | (define-values (datatype-definitions assert-declares retract-declares clause-queries) 32 | (type-check-definitions-and-queries)) 33 | 34 | (clear-type-check-queues!) 35 | 36 | (unless (and (empty? datatype-definitions) 37 | (empty? assert-declares) 38 | (empty? retract-declares) 39 | (empty? clause-queries)) 40 | (with-handlers ([exn:fail? (lambda (e) 41 | (for ([retract-declare (in-list retract-declares)]) 42 | (run-prolog-query! retract-declare)) 43 | (raise e))]) 44 | (for ([datatype-definition (in-list datatype-definitions)]) 45 | (add-prolog-predicate! datatype-definition)) 46 | 47 | (for ([assert-declare (in-list assert-declares)]) 48 | (run-prolog-query! assert-declare)) 49 | 50 | (for ([clause-query (in-list clause-queries)]) 51 | (unless (run-prolog-query! clause-query) 52 | (raise (shen-type-check-exn "failed" (current-continuation-marks)))))))) 53 | 54 | (define (expression-type-check pre-eval-syntax) 55 | (define type-query 56 | (with-syntax* ([(str-stx ...) (shen-strings pre-eval-syntax)] 57 | [string-hyps (shen-cons-syntax #'((#%prolog-functor type_check str-stx string) ...))]) 58 | #`((#%prolog-functor : type_checker 59 | (#%prolog-functor start_proof string-hyps 60 | (#%prolog-functor type_check 61 | #,pre-eval-syntax 62 | ResultType) 63 | _)) 64 | (type-check-return ResultType)))) 65 | 66 | (define query-string (eval-syntax (expand-shen-prolog-query type-query))) 67 | (define query-result (run-prolog-query! query-string)) 68 | 69 | (or query-result 70 | (raise (shen-type-check-exn "failed" (current-continuation-marks))))) 71 | 72 | (define (load-shen-form pre-eval-stx) 73 | (syntax-parse pre-eval-stx 74 | [((~literal define) name:id . _) 75 | (let ([result (shen:eval (syntax->datum pre-eval-stx))]) 76 | (if (type-check?) 77 | (begin 78 | (post-load-type-check!) 79 | (shen-printer result (current-output-port)) 80 | (write-string " : " (current-output-port)) 81 | (type-printer (expression-type-check #'(#%prolog-functor fn name)) 82 | (current-output-port))) 83 | (shen-printer result (current-output-port))))] 84 | [((~literal datatype) name:id . _) 85 | (shen:eval (syntax->datum pre-eval-stx)) 86 | (post-load-type-check!) 87 | (fprintf (current-output-port) "~a#type" (syntax->datum #'name))] 88 | [((~literal prolog?) . _) 89 | (shen-printer (shen:eval (syntax->datum pre-eval-stx)) (current-output-port))] 90 | [(~or ((~literal defmacro) name . _) 91 | ((~literal defprolog) name . _) 92 | ((~literal package) name . _)) 93 | (let ([result (shen:eval (syntax->datum pre-eval-stx))]) 94 | (post-load-type-check!) 95 | (shen-printer (syntax->datum #'name) (current-output-port)))] 96 | [_ 97 | #:when (type-check?) 98 | (let ([type-expr (expression-type-check 99 | (syntax->shen-prolog-term 100 | pre-eval-stx))] 101 | [result (shen:eval (syntax->datum pre-eval-stx))]) 102 | (shen-printer result (current-output-port)) 103 | (write-string " : " (current-output-port)) 104 | (type-printer type-expr (current-output-port)))] 105 | [_ 106 | (shen-printer (shen:eval (syntax->datum pre-eval-stx)) (current-output-port))])) 107 | 108 | (define (load filename) 109 | (define in (open-input-file filename)) 110 | (dynamic-wind 111 | (thunk (void)) 112 | (thunk 113 | (parameterize ([current-readtable shen-readtable]) 114 | (for ([stx (in-port (curry read-syntax (object-name in)) in)]) 115 | (load-shen-form (detect-prolog-syntax (expand-shen-form stx))) 116 | (printf "\n")))) 117 | (thunk 118 | (close-input-port in))) 119 | 'loaded) 120 | -------------------------------------------------------------------------------- /lang/macros.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (only-in racket/function 4 | curry) 5 | syntax/parse 6 | syntax/stx 7 | "namespaces.rkt" 8 | "packages.rkt" 9 | "syntax-utils.rkt" 10 | "type-syntax-expanders.rkt") 11 | 12 | (provide add-shen-macro-expander! 13 | remove-shen-macro-expander! 14 | expand-shen-form) 15 | 16 | (struct original [form]) 17 | 18 | (struct macro-list-node [expander [prev #:mutable] [next #:mutable]] 19 | #:property prop:procedure (lambda (self form) 20 | (((macro-list-node-expander self) 21 | (if (procedure? (macro-list-node-next self)) 22 | (macro-list-node-next self) 23 | original)) 24 | form))) 25 | 26 | (struct macro-list [head tail] #:mutable) 27 | 28 | (define macro-table (make-hash)) 29 | 30 | (define macro-expander-list (macro-list (void) (void))) 31 | 32 | (define (push-macro-list! new-node) 33 | (unless (macro-list-node? (macro-list-head macro-expander-list)) 34 | (set-macro-list-head! macro-expander-list new-node)) 35 | 36 | (if (macro-list-node? (macro-list-tail macro-expander-list)) 37 | (begin 38 | (set-macro-list-node-prev! new-node (macro-list-tail macro-expander-list)) 39 | (set-macro-list-node-next! (macro-list-tail macro-expander-list) new-node) 40 | (set-macro-list-tail! macro-expander-list new-node)) 41 | (set-macro-list-tail! macro-expander-list new-node))) 42 | 43 | (push-macro-list! (macro-list-node (lambda (k) (lambda (form) (k form))) 44 | (void) 45 | (void))) 46 | 47 | (define (add-shen-macro-expander! name new-macro-expander) 48 | (define new-node (macro-list-node new-macro-expander (void) (void))) 49 | 50 | ;; if a macro is already defined under 'name', remove it from the 51 | ;; macro-list. 52 | (when (hash-ref macro-table name (thunk #f)) 53 | (remove-shen-macro-expander! name)) 54 | 55 | (push-macro-list! new-node) 56 | (hash-set! macro-table name new-node)) 57 | 58 | (define (remove-shen-macro-expander! name) 59 | (let ([removed-node (hash-ref! macro-table name (thunk #f))]) 60 | (when (macro-list-node? removed-node) 61 | (hash-remove! macro-table name) 62 | 63 | (if (macro-list-node? (macro-list-node-prev removed-node)) 64 | (set-macro-list-node-next! (macro-list-node-prev removed-node) 65 | (macro-list-node-next removed-node)) 66 | (set-macro-list-head! macro-expander-list 67 | (macro-list-node-next removed-node))) 68 | 69 | (if (macro-list-node? (macro-list-node-next removed-node)) 70 | (set-macro-list-node-prev! (macro-list-node-next removed-node) 71 | (macro-list-node-prev removed-node)) 72 | (set-macro-list-tail! macro-expander-list 73 | (macro-list-node-prev removed-node)))))) 74 | 75 | (define (shen-form-expansion-loop form) 76 | (if (original? form) 77 | (original-form form) 78 | (shen-form-expansion-loop ((macro-list-head macro-expander-list) form)))) 79 | 80 | (define (expand-shen-form stx) 81 | (syntax-parse (inner-expand-shen-form stx) 82 | [((~datum define) define-form:shen-define) 83 | #:cut 84 | #:fail-when (and (type-check?) (not (attribute define-form.type-sig))) 85 | "function needs a type signature with type checking enabled" 86 | this-syntax] 87 | [_ this-syntax])) 88 | 89 | (define (inner-expand-shen-form stx) 90 | (define (expand-shen-form- stx) 91 | (let ([ht (make-hash)]) 92 | (define expansion-result 93 | (dm-subst ht (shen-form-expansion-loop (dm-syntax->datum stx ht)))) 94 | (if (syntax? expansion-result) 95 | expansion-result 96 | (datum->syntax stx expansion-result stx)))) 97 | 98 | (define (expand-shen-function-clause stx) 99 | (syntax-parse stx 100 | [(clause:function-clause-definition) 101 | #:with expanded-body (expand-shen-form #'clause.body) 102 | #:with expanded-guard (if (attribute clause.guard) 103 | (quasisyntax/loc #'clause.guard 104 | (where #,(expand-shen-form #'clause.guard))) 105 | #'()) 106 | (syntax/loc stx 107 | (clause.pats ... clause.arrow expanded-body (~@ . expanded-guard)))])) 108 | 109 | (syntax-parse stx 110 | [((~datum define) define-form:shen-define) 111 | #:with (expanded-clauses ...) (stx-map expand-shen-function-clause #'(define-form.clause ...)) 112 | (expand-shen-form- 113 | (syntax/loc stx 114 | (define define-form.name 115 | (~? (~@ |{| (~@ . define-form.type-sig) |}|)) 116 | (~@ . expanded-clauses) ...)))] 117 | [((~datum defun) defun-form:kl-defun) 118 | #:with (expanded-body-expr ...) (stx-map inner-expand-shen-form #'(defun-form.body-expr ...)) 119 | (expand-shen-form- (syntax/loc stx (defun defun-form.name expanded-body-expr ...)))] 120 | [((~datum defmacro) defmacro-form:shen-defmacro) 121 | #:with (expanded-clause-expr ...) (stx-map inner-expand-shen-form #'(defmacro-form.clause-expr ...)) 122 | (expand-shen-form- 123 | (syntax/loc stx 124 | (defmacro defmacro-form.name 125 | (~@ defmacro-form.pat -> expanded-clause-expr) ...)))] 126 | [((~datum defprolog) :id :shen-prolog-rule ...+) 127 | (expand-shen-form- stx)] 128 | [((~literal cons) hd tl) 129 | (quasisyntax/loc stx 130 | (cons #,(inner-expand-shen-form #'hd) 131 | #,(inner-expand-shen-form #'tl)))] 132 | [((~datum let) let-form:shen-let-form) 133 | #:with (expanded-b-expr ...) (stx-map inner-expand-shen-form #'(let-form.binding-expr ...)) 134 | #:with expanded-body-expr (inner-expand-shen-form #'let-form.body-expr) 135 | (expand-shen-form- 136 | (syntax/loc stx 137 | (let (~@ . [let-form.binding-id expanded-b-expr]) 138 | ... 139 | expanded-body-expr)))] 140 | [((~datum /.) lambda-form:shen-lambda-form) 141 | #:with expanded-body-expr (inner-expand-shen-form #'lambda-form.body-expr) 142 | (expand-shen-form- 143 | (syntax/loc stx 144 | (/. lambda-form.var ... expanded-body-expr)))] 145 | [((~datum package) package-form:shen-package) 146 | #:when (and (eq? (syntax->datum #'package-form.name) 'null) 147 | (eq? (syntax->datum #'package-form.export-list) '())) 148 | #:with (expanded-form ...) (stx-map inner-expand-shen-form #'(package-form.top-level-decls ...)) 149 | (syntax/loc stx 150 | (package null () expanded-form ...))] 151 | [((~datum package) package-form:shen-package) 152 | (let*-values ([(export-list) 153 | (eval-export-list (inner-expand-shen-form #'package-form.export-list))] 154 | [(top-level-forms external-symbols internal-symbols) 155 | (unpackage-shen-package 156 | #'package-form.name 157 | export-list 158 | #'(package-form.top-level-decls ...))]) 159 | (with-syntax ([(expanded-form ...) (stx-map inner-expand-shen-form top-level-forms)] 160 | [external-symbols (hash-keys external-symbols)] 161 | [internal-symbols (hash-keys internal-symbols)] 162 | [export-list (datum->syntax #'package-form.export-list export-list)]) 163 | (syntax/loc stx 164 | (package package-form.name 165 | export-list 166 | external-symbols 167 | internal-symbols 168 | expanded-form ...))))] 169 | [((~datum prolog?) :prolog-body-pattern ...+) 170 | (expand-shen-form- stx)] 171 | [body:expr 172 | #:when (stx-pair? #'body) 173 | (syntax-parse (expand-shen-form- #'body) 174 | [(hd . tl) 175 | #:with expanded-car (inner-expand-shen-form #'hd) 176 | #:with expanded-cdr (stx-map inner-expand-shen-form #'tl) 177 | (if (syntax? stx) 178 | (syntax/loc stx (expanded-car . expanded-cdr)) 179 | #'(expanded-car . expanded-cdr))] 180 | [body (inner-expand-shen-form #'body)])] 181 | [body:expr 182 | (expand-shen-form- #'body)])) 183 | 184 | ;; from compatibility-lib/define-macro, used to deconstruct 185 | ;; and reconstruct syntax objects. 186 | 187 | (define (dm-syntax->datum stx ht) 188 | ;; Easiest to handle cycles by letting `syntax-object->datum' 189 | ;; do all the work. 190 | (let ([v (syntax->datum stx)]) 191 | (let loop ([stx stx][v v]) 192 | (let ([already (hash-ref ht v (lambda () #f))]) 193 | (if already 194 | (hash-set! ht v #t) ;; not stx => don't subst later 195 | (hash-set! ht v stx)) 196 | (cond 197 | [(stx-pair? stx) 198 | (loop (stx-car stx) (car v)) 199 | (loop (stx-cdr stx) (cdr v))] 200 | [(stx-null? stx) null] 201 | [(vector? (syntax-e stx)) 202 | (for-each 203 | loop 204 | (vector->list 205 | (syntax-e stx)) 206 | (vector->list v))] 207 | [(box? (syntax-e stx)) 208 | (loop (unbox (syntax-e stx)) 209 | (unbox v))] 210 | [else (void)]))) 211 | v)) 212 | 213 | (define (dm-subst ht v) 214 | (define cycle-ht (make-hash)) 215 | (let loop ([v v]) 216 | (if (hash-ref cycle-ht v (lambda () #f)) 217 | v 218 | (begin 219 | (hash-set! cycle-ht v #t) 220 | (let ([m (hash-ref ht v (lambda () #f))]) 221 | (cond 222 | [(syntax? m) m] ;; subst back! 223 | [(pair? v) (cons (loop (car v)) 224 | (loop (cdr v)))] 225 | [(vector? v) (list->vector 226 | (map 227 | loop 228 | (vector->list v)))] 229 | [(box? v) (box (loop (unbox v)))] 230 | [else v])))))) 231 | -------------------------------------------------------------------------------- /lang/namespace-requires.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "namespaces.rkt" 4 | racket/runtime-path) 5 | 6 | (define-runtime-module-path module-path-to-interposition-points "interposition-points.rkt") 7 | (define-runtime-module-path module-path-to-system-function-exports "system-function-exports.rkt") 8 | (define-runtime-module-path module-path-to-expander "expander.rkt") 9 | (define-runtime-module-path module-path-to-load "load.rkt") 10 | 11 | (namespace-require `(rename ,module-path-to-interposition-points #%app app) kl-namespace) 12 | (namespace-require `(rename ,module-path-to-interposition-points #%top top) kl-namespace) 13 | (namespace-require '(only racket/base #%datum) kl-namespace) 14 | (namespace-require module-path-to-system-function-exports kl-namespace) 15 | (namespace-require `(for-space function ,module-path-to-system-function-exports) kl-namespace) 16 | (namespace-require `(only ,module-path-to-load load) 17 | kl-namespace) 18 | (namespace-require `(rename ,module-path-to-expander defun kl-defun) kl-namespace) 19 | (namespace-require `(only ,module-path-to-expander /. cond false if let true) kl-namespace) 20 | 21 | (namespace-require `(rename ,module-path-to-interposition-points #%app app) shen-namespace) 22 | (namespace-require `(rename ,module-path-to-interposition-points #%top top) shen-namespace) 23 | (namespace-require '(only racket/base #%datum) shen-namespace) 24 | (namespace-require module-path-to-system-function-exports shen-namespace) 25 | (namespace-require `(for-space function ,module-path-to-system-function-exports) shen-namespace) 26 | (namespace-require `(only ,module-path-to-load load) 27 | shen-namespace) 28 | (namespace-require `(rename ,module-path-to-expander defun kl-defun) shen-namespace) 29 | (namespace-require `(only ,module-path-to-expander <> @p @s @v /. cond datatype define defmacro 30 | defprolog false if let package prolog? true) 31 | shen-namespace) 32 | -------------------------------------------------------------------------------- /lang/namespaces.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide kl-namespace 4 | shen-namespace) 5 | 6 | (define-namespace-anchor kl-namespace-anchor) 7 | 8 | (define kl-namespace (namespace-anchor->empty-namespace kl-namespace-anchor)) 9 | (define shen-namespace (namespace-anchor->empty-namespace kl-namespace-anchor)) 10 | -------------------------------------------------------------------------------- /lang/packages.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "namespaces.rkt" 4 | racket/syntax 5 | "syntax-utils.rkt" 6 | syntax/parse 7 | syntax/stx 8 | "systemf.rkt") 9 | 10 | (provide add-internal-symbols-to-package! 11 | add-external-symbols-to-package! 12 | eval-export-list 13 | package-list 14 | unpackage-shen-package) 15 | 16 | (define shen-packages (make-hasheq)) 17 | 18 | (define (package-list pkg-name [type 'external]) 19 | (let ([package-ht (hash-ref! shen-packages pkg-name (thunk (make-hasheq)))]) 20 | (for/list ([(symbol symbol-type) (in-hash package-ht)] 21 | #:when (eq? symbol-type type)) 22 | symbol))) 23 | 24 | (define (add-internal-symbols-to-package! pkg-name internal-symbols-list) 25 | (let ([package-ht (hash-ref! shen-packages pkg-name (thunk (make-hasheq)))]) 26 | (map (lambda (symbol) 27 | (hash-set! package-ht symbol 'internal)) 28 | internal-symbols-list))) 29 | 30 | (define (add-external-symbols-to-package! pkg-name external-symbols-list) 31 | (let ([package-ht (hash-ref! shen-packages pkg-name (thunk (make-hasheq)))]) 32 | (map (lambda (symbol) 33 | (hash-set! package-ht symbol 'external)) 34 | external-symbols-list))) 35 | 36 | (define (eval-export-list export-list) 37 | (parameterize ([current-namespace shen-namespace]) 38 | (define quoted-export-list (expand (quote-pattern export-list))) 39 | (if (stx-null? quoted-export-list) 40 | '() 41 | (eval-syntax quoted-export-list)))) 42 | 43 | (define (unpackage-shen-package pkg-name export-list top-level-decls) 44 | (let ([external-symbols (make-hasheq)] 45 | [internal-symbols (make-hasheq)]) 46 | (values (map (curry fqn pkg-name export-list external-symbols internal-symbols) 47 | (syntax->list top-level-decls)) 48 | external-symbols 49 | internal-symbols))) 50 | 51 | (define (fqn pkg-name export-list external-symbols internal-symbols top-level-decl) 52 | (let fqn ([top-level-decl top-level-decl]) 53 | (syntax-parse top-level-decl 54 | [decl:shen-var-id 55 | #'decl] 56 | [decl:id 57 | (cond [(member (syntax->datum #'decl) (reserved-shen-symbols)) 58 | #'decl] 59 | [(member (syntax->datum #'decl) export-list) 60 | (hash-set! external-symbols #'decl (void)) 61 | #'decl] 62 | [(let ([pkg-name-str (symbol->string (syntax->datum pkg-name))] 63 | [decl-str (symbol->string (syntax->datum #'decl))]) 64 | (or (string-prefix? decl-str "shen.") 65 | (string-prefix? decl-str (string-append pkg-name-str ".")))) 66 | (hash-set! internal-symbols #'decl (void)) 67 | #'decl] 68 | [else 69 | (let ([dotted-id (format-id top-level-decl "~a.~a" pkg-name #'decl)]) 70 | (hash-set! internal-symbols dotted-id (void)) 71 | dotted-id)])] 72 | [decl:expr 73 | #:when (stx-pair? #'decl) 74 | (quasisyntax/loc top-level-decl 75 | (#,(fqn (stx-car #'decl)) 76 | . 77 | #,(stx-map fqn (stx-cdr #'decl))))] 78 | [decl:expr 79 | #'decl]))) 80 | -------------------------------------------------------------------------------- /lang/pairs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (struct-out shen-tuple)) 4 | 5 | (struct shen-tuple [args] #:prefab) 6 | -------------------------------------------------------------------------------- /lang/printer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "pairs.rkt" 4 | racket/base 5 | racket/generator 6 | racket/match) 7 | 8 | (provide shen-printer 9 | type-printer) 10 | 11 | (define (print-cons-contents args port printer) 12 | (for ([arg (in-generator 13 | (let loop ([pair args]) 14 | (cond [(cons? pair) 15 | (yield (car pair)) 16 | (loop (cdr pair))] 17 | [else 18 | (unless (empty? pair) 19 | (write-string " |" port) 20 | (yield pair))])))] 21 | [space (sequence-append (in-value "") (in-cycle '(#\space)))]) 22 | (fprintf port "~a" space) 23 | (printer arg port))) 24 | 25 | (define (cons-contents args) 26 | (foldr (lambda (item acc) (if (void? acc) item (cons item acc))) 27 | (void) 28 | (for/list ([arg (in-generator 29 | (let loop ([args args]) 30 | (match args 31 | [(list 'cons a d) 32 | (yield a) 33 | (if (empty? d) 34 | (yield d) 35 | (loop d))] 36 | [_ 37 | (yield args)])))]) 38 | arg))) 39 | 40 | (define/contract (type-printer datum port) 41 | (any/c output-port? . -> . any) 42 | (match datum 43 | [(list 'cons a d) 44 | (write-char #\[ port) 45 | (print-cons-contents (cons-contents datum) port type-printer) 46 | (write-char #\] port)] 47 | [(list '--> a d) 48 | (write-string "(" port) 49 | (type-printer a port) 50 | (write-string " --> " port) 51 | (type-printer d port) 52 | (write-string ")" port)] 53 | [(list terms ...) 54 | (write-char #\( port) 55 | (print-cons-contents terms port type-printer) 56 | (write-char #\) port)] 57 | [(? empty?) 58 | (write-string "[]" port)] 59 | [(? shen-tuple?) 60 | (write-string "(@p" port) 61 | (for ([elt (in-vector (shen-tuple-args datum))]) 62 | (write-string " " port) 63 | (type-printer elt port)) 64 | (write-string ")" port)] 65 | [(? vector?) 66 | (write-string "<" port) 67 | (unless (vector-empty? datum) 68 | (type-printer (vector-ref datum 0) port) 69 | (for ([elt (in-vector datum 1)]) 70 | (write-string " " port) 71 | (type-printer elt port))) 72 | (write-string ">" port)] 73 | [_ (shen-printer datum port)])) 74 | 75 | (define/contract (shen-printer datum port) 76 | (any/c output-port? . -> . any) 77 | (match datum 78 | [(? empty?) 79 | (write-string "[]" port)] 80 | [(? cons?) 81 | (write-char #\[ port) 82 | (print-cons-contents datum port shen-printer) 83 | (write-char #\] port)] 84 | [(? symbol?) 85 | (write-string (symbol->string datum) port)] 86 | [(? string?) 87 | (write-char #\" port) 88 | (write-string datum port) 89 | (write-char #\" port)] 90 | [(? boolean?) 91 | (write-string (if datum "true" "false") port)] 92 | [(? void?) 93 | (write-string "[]" port)] 94 | [(? shen-tuple?) 95 | (write-string "(@p" port) 96 | (for ([elt (in-vector (shen-tuple-args datum))]) 97 | (write-string " " port) 98 | (shen-printer elt port)) 99 | (write-string ")" port)] 100 | [(? procedure?) 101 | (write (object-name datum) port)] 102 | [(? vector?) 103 | (write-string "<" port) 104 | (unless (vector-empty? datum) 105 | (shen-printer (vector-ref datum 0) port) 106 | (for ([elt (in-vector datum 1)]) 107 | (write-string " " port) 108 | (shen-printer elt port))) 109 | (write-string ">" port)] 110 | [#\| 111 | (write-string "bar!" port)] 112 | [_ 113 | (write datum port)])) 114 | -------------------------------------------------------------------------------- /lang/prolog-debug-gui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | 3 | (require "scryer-prolog-interface.rkt") 4 | 5 | (provide open-prolog-debug-gui 6 | (rename-out [sp-connector-out scryer-prolog-log-out])) 7 | 8 | (define-values (sp-connector-in sp-connector-out) 9 | (make-pipe)) 10 | 11 | (define (open-prolog-debug-gui) 12 | (add-multiplexed-input-port-pipe! scryer-prolog-in sp-connector-out) 13 | (add-multiplexed-input-port-pipe! scryer-prolog-err sp-connector-out) 14 | (add-multiplexed-output-port-pipe! scryer-prolog-out sp-connector-out) 15 | 16 | (let ([prolog-debug-es (make-eventspace)]) 17 | (parameterize ([current-eventspace prolog-debug-es]) 18 | (define frame (new frame% 19 | [label "Scryer Prolog Debug Window"] 20 | [width 800] 21 | [height 600])) 22 | 23 | (define scryer-prolog-text 24 | (new text% 25 | [auto-wrap #t])) 26 | 27 | (define scryer-prolog-canvas 28 | (new editor-canvas% 29 | [parent frame] 30 | [editor scryer-prolog-text] 31 | [style '(auto-hscroll auto-vscroll resize-corner)])) 32 | 33 | (send scryer-prolog-canvas set-canvas-background 34 | (make-object color% "black")) 35 | 36 | (send scryer-prolog-text change-style 37 | (let ([color-delta (make-object style-delta% 'change-normal-color)]) 38 | (send color-delta set-delta-foreground "green") 39 | color-delta)) 40 | 41 | (send scryer-prolog-text change-style 42 | (let ([font-delta (make-object style-delta% 'change-family 'modern)]) 43 | (send font-delta set-delta 'change-size 16) 44 | font-delta)) 45 | 46 | (send frame show #t) 47 | 48 | (add-text-keymap-functions (send scryer-prolog-text get-keymap)) 49 | 50 | (send (send scryer-prolog-text get-keymap) 51 | map-function 52 | "c:c" 53 | "copy-clipboard") 54 | 55 | (define debug-output-port 56 | (open-output-text-editor scryer-prolog-text #:eventspace prolog-debug-es)) 57 | 58 | (thread (lambda () 59 | (let loop () 60 | (define line (read-line sp-connector-in)) 61 | (unless (eof-object? line) 62 | (write-string line debug-output-port) 63 | (write-string "\n" debug-output-port)) 64 | (loop))))))) 65 | 66 | -------------------------------------------------------------------------------- /lang/prolog-syntax-expanders.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require data/gvector 4 | "prolog-syntax.rkt" 5 | (for-template (only-in "prolog-syntax.rkt" 6 | write-as-prolog-datum) 7 | racket) 8 | syntax/parse 9 | syntax/stx 10 | "syntax-utils.rkt") 11 | 12 | (provide expand-shen-defprolog 13 | expand-shen-prolog-query) 14 | 15 | (define (expand-shen-defprolog name rules) 16 | (define-values (string-port write-prolog-goals received-vars-vec) 17 | (prolog-syntax-writers #f)) 18 | 19 | (let ([name (shen-atom->prolog-atom (syntax->datum name))]) 20 | (for-each (lambda (rule-stx) 21 | (write-string name string-port) 22 | (syntax-parse rule-stx 23 | [(rule:shen-prolog-rule) 24 | (unless (stx-null? #'(rule.head-form ...)) 25 | (write-string "(" string-port) 26 | (write-prolog-goals #'(rule.head-form ...) #f) 27 | (write-string ")" string-port)) 28 | 29 | (unless (stx-null? #'(rule.body-form ...)) 30 | (write-string " :- " string-port) 31 | (write-prolog-goals #'(rule.body-form ...) #t)) 32 | 33 | (write-string ".\n" string-port)])) 34 | (syntax->list rules))) 35 | 36 | (get-output-string string-port)) 37 | 38 | (define (expand-shen-prolog-query query) 39 | (define-values (string-port write-prolog-goals received-vars-vec) 40 | (prolog-syntax-writers #t)) 41 | 42 | (write-prolog-goals query #t) 43 | 44 | (quasisyntax/loc query 45 | (apply format 46 | #,(get-output-string string-port) 47 | (map 48 | (lambda (shen-value) 49 | (let ([port (open-output-string)]) 50 | (write-as-prolog-datum shen-value port) 51 | (get-output-string port))) 52 | (list #,@(gvector->list received-vars-vec)))))) 53 | -------------------------------------------------------------------------------- /lang/prolog-syntax.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require data/gvector 4 | "pairs.rkt" 5 | syntax/parse 6 | syntax/stx 7 | "syntax-utils.rkt") 8 | 9 | (provide prolog-syntax-writers 10 | shen-atom->prolog-atom 11 | write-as-prolog-datum) 12 | 13 | (define (shen-atom->prolog-atom atom) 14 | (let* ([underlying-str (symbol->string atom)]) 15 | (if (or (equal? underlying-str "_") 16 | (char-upper-case? (string-ref underlying-str 0))) 17 | underlying-str 18 | (string-append "'" underlying-str "'")))) 19 | 20 | (define (write-as-prolog-datum datum port) 21 | (let loop ([datum datum]) 22 | (match datum 23 | [(cons hd tl) 24 | (write-string "[" port) 25 | (loop hd) 26 | (write-string "|" port) 27 | (loop tl) 28 | (write-string "]" port)] 29 | [(or '() (? void?)) 30 | (write-string "[]" port)] 31 | [(? symbol?) 32 | (write-string (shen-atom->prolog-atom datum) port)] 33 | [(? string?) 34 | (fprintf port "~s" datum)] 35 | [(== #t eq?) 36 | (fprintf port "true")] 37 | [(== #f eq?) 38 | (fprintf port "false")] 39 | [_ 40 | (write datum port)]))) 41 | 42 | (define (prolog-syntax-writers query? [embedded? #t]) 43 | (define string-port (open-output-string)) 44 | (letrec ([received-vars-vec (make-gvector)] 45 | [shift-args (lambda (stx [top-level-arg? #t]) 46 | (syntax-parse stx 47 | [((~datum receive) id:shen-var-id) 48 | #:when (and query? embedded?) 49 | (gvector-add! received-vars-vec #'id) 50 | (datum->syntax stx '~a stx)] 51 | [(~or ((~datum cons) _ _) 52 | ((~datum #%prolog-functor) . _) 53 | ((~datum #%free-variable) _)) 54 | stx] 55 | [(hd . tl) 56 | #:when top-level-arg? 57 | (let ([hd (shift-args #'hd #f)] 58 | [tl (stx-map (lambda (stx) (shift-args stx #f)) #'tl)] 59 | [result-binding (gensym "G")]) 60 | (write-string "ipc:bind(" string-port) 61 | (write-prolog-datum hd) 62 | (write-string "(" string-port) 63 | (write-prolog-goals tl #f) 64 | (write-string "), " string-port) 65 | (write result-binding string-port) 66 | (write-string "), " string-port) 67 | 68 | (datum->syntax stx result-binding stx))] 69 | [form #'form]))] 70 | [write-prolog-datum (lambda (rule [top-level? #f]) 71 | (syntax-parse rule 72 | [((~datum cons) hd tl) 73 | (let ([hd (shift-args #'hd)] 74 | [tl (shift-args #'tl)]) 75 | (write-string "[" string-port) 76 | (write-prolog-datum hd) 77 | (write-string " | " string-port) 78 | (write-prolog-datum tl) 79 | (write-string "]" string-port))] 80 | [((~datum use-module) ((~datum library) lib-id:id)) 81 | #:when (and top-level? query?) 82 | (write-string "use_module(library(" string-port) 83 | (write-string (shen-atom->prolog-atom (syntax->datum #'lib-id)) string-port) 84 | (write-string "))" string-port)] 85 | [((~datum use-module) file-name:id) 86 | #:when (and top-level? query?) 87 | (write-string "use_module('" string-port) 88 | (write (syntax->datum #'file-name) string-port) 89 | (write-string "')" string-port)] 90 | [((~datum #%free-variable) var) 91 | (define datum (syntax->datum #'var)) 92 | (write-string (string-append "'" (symbol->string datum) "'") string-port)] 93 | [((~and slash-op (~or (~literal |\+|) (~literal |\=|) (~literal |\==|))) 94 | term) 95 | #:when top-level? 96 | ;; support ISO Prolog functors for 97 | ;; negation as failure, not 98 | ;; unifiable, not equal 99 | (write-string (symbol->string (syntax-e #'slash-op)) string-port) 100 | (write-string "(" string-port) 101 | (write-prolog-datum (shift-args #'term)) 102 | (write-string ")" string-port)] 103 | [((~datum is!) x t) 104 | #:when top-level? 105 | (let ([x (shift-args #'x)] 106 | [t (shift-args #'t)]) 107 | (write-string "unify_with_occurs_check(" string-port) 108 | (write-prolog-datum x) 109 | (write-string ", " string-port) 110 | (write-prolog-datum t) 111 | (write-string ")" string-port))] 112 | [((~datum findall) pat predicate solutions) 113 | #:when top-level? 114 | (write-string "findall(" string-port) 115 | (write-prolog-datum #'pat) 116 | (write-string ", " string-port) 117 | (write-prolog-datum #'predicate #t) 118 | (write-string ", " string-port) 119 | (write-prolog-datum #'solutions) 120 | (write-string ")" string-port)] 121 | [((~or (~datum is) (~datum bind)) x t) 122 | #:when top-level? 123 | (let ([x (shift-args #'x)] 124 | [t (shift-args #'t)]) 125 | (write-string "=(" string-port) 126 | (write-prolog-datum x) 127 | (write-string ", " string-port) 128 | (write-prolog-datum t) 129 | (write-string ")" string-port))] 130 | [((~datum ~) t) 131 | #:when top-level? 132 | (let ([t (shift-args #'t)]) 133 | (write-string "\\+(" string-port) 134 | (write-prolog-datum t #t) 135 | (write-string ")" string-port))] 136 | [((~datum return) t) 137 | #:when top-level? 138 | (let ([t (shift-args #'t)]) 139 | (write-string "ipc:return_to_shen(" string-port) 140 | (write-prolog-datum t) 141 | (write-string ")" string-port))] 142 | [((~datum type-check-return) t) 143 | #:when top-level? 144 | (let ([t (shift-args #'t)]) 145 | (write-string "ipc:type_check_return_to_shen(" string-port) 146 | (write-prolog-datum t) 147 | (write-string ")" string-port))] 148 | [((~datum var?) t) 149 | #:when top-level? 150 | (let ([t (shift-args #'t)]) 151 | (write-string "var(" string-port) 152 | (write-prolog-datum t)) 153 | (write-string ")" string-port)] 154 | [((~datum fork) arg . args) 155 | #:when top-level? 156 | (write-string "(" string-port) 157 | (write-prolog-datum #'arg #t) 158 | (stx-map (lambda (stx) 159 | (write-string "; " string-port) 160 | (write-prolog-datum stx #t)) 161 | #'args) 162 | (write-string ")" string-port)] 163 | [((~or (~datum +) (~datum -)) form) 164 | (write-prolog-datum #'form top-level?)] 165 | [((~datum when) t) 166 | #:when top-level? 167 | (let ([t (shift-args #'t)]) 168 | (write-prolog-datum t) 169 | (write-string " = true" string-port))] 170 | [((~datum #%prolog-functor) id:id . args) 171 | (let ([args (stx-map shift-args #'args)]) 172 | (write-string (shen-atom->prolog-atom (syntax->datum #'id)) string-port) 173 | (unless (stx-null? #'args) 174 | (write-string "(" string-port) 175 | (write-prolog-goals args #f) 176 | (write-string ")" string-port)))] 177 | [(hd . tl) 178 | (let ([tl (if top-level? (stx-map shift-args #'tl) #'tl)]) 179 | (write-prolog-datum #'hd) 180 | (unless (stx-null? tl) 181 | (write-string "(" string-port) 182 | (write-prolog-goals tl #f) 183 | (write-string ")" string-port)))] 184 | [(~datum !) 185 | #:when top-level? 186 | (write-string "!" string-port)] 187 | [(~and atom:id (~not atom:shen-var-id)) 188 | #:when (not top-level?) 189 | (write-string (shen-atom->prolog-atom (syntax->datum #'atom)) string-port)] 190 | [atom 191 | (if top-level? 192 | (raise-syntax-error #f "goals must be represented as s-expressions or functors " 193 | rule) 194 | (write-as-prolog-datum (syntax->datum #'atom) string-port))]))] 195 | [write-prolog-goals (lambda (arg-stx top-level?) 196 | (if (stx-pair? arg-stx) 197 | (begin 198 | (write-prolog-datum (stx-car arg-stx) top-level?) 199 | (unless (stx-null? (stx-cdr arg-stx)) 200 | (write-string ", " string-port) 201 | (write-prolog-goals (stx-cdr arg-stx) top-level?))) 202 | (write-prolog-datum arg-stx top-level?)))]) 203 | (values string-port 204 | write-prolog-goals 205 | received-vars-vec))) 206 | -------------------------------------------------------------------------------- /lang/prolog.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "namespaces.rkt" 4 | "prolog-debug-gui.rkt" 5 | (only-in "prolog-syntax.rkt" 6 | write-as-prolog-datum) 7 | (only-in racket/exn 8 | exn->string) 9 | "racket-iso-prolog-term-interface.rkt" 10 | "scryer-prolog-interface.rkt") 11 | 12 | (provide add-prolog-predicate! 13 | run-prolog-query!) 14 | 15 | (define (peek-for-prolog-warning) 16 | (when (eq? (peek-char scryer-prolog-in) #\%) 17 | (read-line scryer-prolog-in) 18 | (peek-for-prolog-warning))) 19 | 20 | (define (add-prolog-predicate! iso-prolog-code) 21 | (fprintf scryer-prolog-log-out "?- ") 22 | (fprintf scryer-prolog-out "[user].~n~a~nend_of_file.~n" iso-prolog-code)) 23 | 24 | (define (run-prolog-query! iso-prolog-query) 25 | (fprintf scryer-prolog-log-out "?- ") 26 | (fprintf scryer-prolog-out "shen_prolog_eval((~a)).~n" iso-prolog-query) 27 | 28 | (with-handlers ([exn:fail? (lambda (e) 29 | (printf "prolog error on query ~a: ~a~n" 30 | iso-prolog-query (exn->string e)) 31 | (read-char scryer-prolog-in) ;; read trailing newline 32 | #f)]) 33 | (let loop () 34 | (define (continue result) 35 | (write-as-prolog-datum result scryer-prolog-out) 36 | (fprintf scryer-prolog-out ".~n") 37 | (loop)) 38 | 39 | (define (bind fn-call continue?) 40 | (define result (eval fn-call shen-namespace)) 41 | (if (eq? continue? 'true) 42 | (continue result) 43 | result)) 44 | 45 | (peek-for-prolog-warning) 46 | 47 | (match (read-iso-prolog-term scryer-prolog-in) 48 | [(list (list 'type-functor type)) 49 | type] 50 | [(list 'type-check-error _) 51 | #f] 52 | [(list 'if-bind fn-call continue?) 53 | (with-handlers ([exn:fail? (lambda (_) 54 | (if (eq? continue? 'true) 55 | (continue 'false) 56 | #f))]) 57 | (bind fn-call continue?))] 58 | [(or (list fn-call continue?) 59 | (list 'cons fn-call (list 'cons continue? '()))) 60 | (bind fn-call continue?)] 61 | [_ #f])))) 62 | -------------------------------------------------------------------------------- /lang/racket-iso-prolog-term-interface.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require brag/support 4 | "iso-prolog-bnf.rkt" 5 | racket/generator 6 | (only-in "reader.rkt" shen-readtable)) 7 | 8 | (provide read-iso-prolog-term) 9 | 10 | (define-lex-abbrev graphic-char 11 | (union "#" "$" "&" "*" "+" "-" "." "/" ":" "<" "=" ">" "?" "@" "^" "~")) 12 | 13 | (define-lex-abbrev single-quoted-char 14 | (union "" "\"" "`" " " graphic-char alphabetic numeric solo-char)) 15 | 16 | (define-lex-abbrev single-quoted 17 | (concatenation "'" single-quoted-char "'")) 18 | 19 | (define-lex-abbrev solo-char 20 | (union "!" "(" ")" " " ";" "[" "]" "{" "}" "|" "%")) 21 | 22 | (define-lex-abbrev atom 23 | (union (concatenation lower-case (repetition 0 +inf.0 (union alphabetic numeric "_"))) 24 | (concatenation "'" (repetition 0 +inf.0 single-quoted-char) "'") 25 | ";" 26 | "!" 27 | "[]" 28 | "{}" 29 | (repetition 1 +inf.0 graphic-char) 30 | single-quoted)) 31 | 32 | (define-lex-abbrev number 33 | (concatenation (union "-" "") 34 | (repetition 1 +inf.0 numeric) 35 | (union "" (concatenation "." (repetition 1 +inf.0 numeric))))) 36 | 37 | (define-lex-abbrev variable 38 | (concatenation (union upper-case "_") 39 | (repetition 0 +inf.0 (union alphabetic numeric)))) 40 | 41 | (define-lex-abbrev quoted-string 42 | (concatenation "\"" any-string "\"")) 43 | 44 | (define (make-tokenizer port) 45 | (define (next-token) 46 | (define iso-prolog-lexer 47 | (lexer 48 | ["|" (token 'BAR lexeme)] 49 | [atom (token 'ATOM (string->symbol lexeme))] 50 | [variable (token 'VARIABLE (string->symbol lexeme))] 51 | [number (token 'NUMBER (string->number lexeme))] 52 | [quoted-string (token 'STRING lexeme)] 53 | [whitespace (token 'WHITESPACE lexeme #:skip? #t)] 54 | [(char-set "()[],| ") lexeme] 55 | [(eof) (void)])) 56 | (iso-prolog-lexer port)) 57 | next-token) 58 | 59 | (define (read-iso-prolog-term port) 60 | (define line (read-line port)) 61 | (iso-prolog-term->shen-expr (parse-to-datum (apply-tokenizer-maker make-tokenizer line)))) 62 | 63 | (define (un-bar-bracket atom) 64 | (define (unquote-string string) 65 | (substring string 1 (sub1 (string-length string)))) 66 | 67 | (match (symbol->string atom) 68 | [(and (var string) (or "-" "->" "-->")) string] 69 | [(and (var string) (regexp #rx"^'.*'$")) 70 | (unquote-string string)] 71 | [string (string-replace string "_" "-")])) 72 | 73 | (define (iso-prolog-term->shen-expr term-tree) 74 | (define output-port (open-output-string)) 75 | 76 | (define (subterms term) 77 | (for/list ([term (in-generator 78 | (let loop ([term term]) 79 | (match term 80 | [(list 'term term) 81 | (loop term)] 82 | [(list 'atom '|[]|) 83 | (void)] 84 | [(list 'clause 85 | (list 'atom '|'.'|) 86 | a d) 87 | (yield a) 88 | (loop d)] 89 | [term (yield term)])))]) 90 | term)) 91 | 92 | (define (cons-contents char-list) 93 | (match char-list 94 | [(list 'cons a d) (cons a (cons-contents d))] 95 | [_ empty])) 96 | 97 | (let write-shen-term ([term-tree term-tree]) 98 | (match term-tree 99 | [(list 'term inner-term) 100 | (write-shen-term inner-term)] 101 | [(list 'atom atom) 102 | (write-string (un-bar-bracket atom) output-port)] 103 | [(list 'variable var) 104 | (let ([var-string (symbol->string var)]) 105 | (if (equal? (string-ref var-string 0) #\_) 106 | (write-string var-string output-port) 107 | (write-string (un-bar-bracket var) output-port)))] 108 | [(list (or 'number 'string) datum) 109 | (write datum output-port)] 110 | [(list 'clause (list 'atom '|'.'|) 111 | (list 'term (list 'atom '|'.'|)) 112 | a d) 113 | (write-string "[" output-port) 114 | (write-shen-term a) 115 | (write-string " | " output-port) 116 | (write-shen-term d) 117 | (write-string "]" output-port)] 118 | [(list 'clause (list 'atom '|'.'|) 119 | (list 'term (list 'atom '|'#%apply'|)) 120 | clause) 121 | (write-string "[" output-port) 122 | (for ([subterm (in-list (subterms clause))] 123 | [space (sequence-append (in-value "") (in-cycle '(#\space)))]) 124 | (fprintf output-port "~a" space) 125 | (write-shen-term subterm)) 126 | (write-string "]" output-port)] 127 | [(and (var term) 128 | (list 'clause (list 'atom '|'.'|) 129 | _ _)) 130 | (let ([subterms (subterms term)]) 131 | (write-string "(" output-port) 132 | (write-shen-term (car subterms)) 133 | (for ([subterm (in-list (cdr subterms))]) 134 | (write-string " " output-port) 135 | (write-shen-term subterm)) 136 | (write-string ")" output-port))] 137 | [(list 'clause term terms ...) 138 | (write-string "(" output-port) 139 | (write-shen-term term) 140 | (for ([term (in-list terms)]) 141 | (write-string " " output-port) 142 | (write-shen-term term)) 143 | (write-string ")" output-port)] 144 | [(list 'list term terms ... "|" tail) 145 | (write-string "[" output-port) 146 | (write-shen-term term) 147 | (for ([term (in-list terms)]) 148 | (write-string " " output-port) 149 | (write-shen-term term)) 150 | (write-string " | " output-port) 151 | (write-shen-term tail) 152 | (write-string "]" output-port)] 153 | [(list 'list term terms ...) 154 | (write-string "[" output-port) 155 | (write-shen-term term) 156 | (for ([term (in-list terms)]) 157 | (write-string " " output-port) 158 | (write-shen-term term)) 159 | (write-string "]" output-port)])) 160 | 161 | (parameterize ([current-readtable shen-readtable]) 162 | (read (open-input-string (get-output-string output-port))))) 163 | 164 | ;; (parse-to-datum (apply-tokenizer-maker make-tokenizer "type_check_error(inference_limit_exceeded)")) 165 | ;; (parse-to-datum (apply-tokenizer-maker make-tokenizer "'.'(number,'.'(false,[]))")) 166 | ;; (parse-to-datum (apply-tokenizer-maker make-tokenizer "term")) 167 | ;; (parse-to-datum (apply-tokenizer-maker make-tokenizer "term(b,c,[])")) 168 | ;; (parse-to-datum (apply-tokenizer-maker make-tokenizer "'.'('.'(type_functor,'.'('.'('h-list','.'('.'('.',number,'.'('.',symbol,[])),[])),[])),[])")) 169 | ;; (parse-to-datum (apply-tokenizer-maker make-tokenizer "'.'('.'('element?','.'('.'('#%symbol','.'(tuesday,[])),'.'('.'('.',monday,'.'('.',tuesday,'.'('.',wednesday,'.'('.',thursday,'.'('.',friday,'.'('.',saturday,'.'('.',sunday,[]))))))),[]))),'.'(true,[]))")) 170 | ;; "'.'('.'('element?','.'('.'('@s','.'('.'('#%symbol','.'(_141760,[])),'.'('.'('#%string','.'('.'('.',a,'.'('.',s,[])),[])),[]))),'.'('.'('.',monday,'.'('.',tuesday,'.'('.',wednesday,'.'('.',thursday,'.'('.',friday,'.'('.',saturday,'.'('.',sunday,[]))))))),[]))),'.'(true,[]))" 171 | -------------------------------------------------------------------------------- /lang/reader-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit "reader.rkt") 4 | 5 | (check-equal? (read (open-input-string "[1 2 3 | 4]")) '(1 2 3 . 4)) 6 | (check-equal? (read (open-input-string "[[1]]")) '((1))) 7 | (check-equal? (read (open-input-string "[2 [1]]")) '(2 (1))) 8 | (check-equal? (read (open-input-string "[[1 2] | 3]")) '((1 2) . 3)) 9 | (check-equal? (read (open-input-string "[[1 2] | [3 4]]")) '((1 2) 3 4)) 10 | (check-equal? (read (open-input-string "[1 2 | [3 4]]")) '(1 2 3 4)) 11 | (check-equal? (read (open-input-string "[]")) '()) 12 | (check-equal? (read (open-input-string "[[]]")) '(())) 13 | (check-exn exn:fail:read? (thunk (read (open-input-string "[1 2 3 | 4 5]")))) 14 | (check-exn exn:fail:read? (thunk (read (open-input-string "[1 2 3 |]")))) -------------------------------------------------------------------------------- /lang/reader.rkt: -------------------------------------------------------------------------------- 1 | (module reader syntax/module-reader 2 | #:language 'shen 3 | #:language-info '#(shen/lang/lang-info get-info #f) 4 | #:wrapper1 wrapper1 5 | #:info (lambda (key defval default) 6 | (case key 7 | [(drracket:default-filters) '(["Shen Sources" "*.shen"])] 8 | [(drracket:default-extension) "Shen"] 9 | [(drracket:submit-predicate) 10 | (dynamic-require 'shen/tools/submit 'repl-submit?)] 11 | [(color-lexer) 12 | (dynamic-require 'shen/tools/colorer 'shen-colorer)] 13 | [else (default key defval)])) 14 | 15 | (require "macros.rkt" 16 | racket 17 | racket/generator 18 | syntax/parse 19 | syntax/readerr 20 | syntax/strip-context 21 | syntax/stx) 22 | 23 | (provide detect-prolog-syntax 24 | shen-readtable) 25 | 26 | (define (wrapper1 t is-syntax?) 27 | (parameterize ([current-readtable shen-readtable]) 28 | (if is-syntax? 29 | (strip-context (detect-prolog-syntax (expand-shen-form (t)))) 30 | (syntax->datum (detect-prolog-syntax (expand-shen-form (datum->syntax #f (t)))))))) 31 | 32 | (define (detect-prolog-syntax stx) 33 | (syntax-parse stx 34 | [((~and id (~or (~datum defprolog) (~datum prolog?) (~datum datatype))) . body) 35 | (quasisyntax/loc stx 36 | (id . #,(tag-prolog-functors #'body)))] 37 | [(a . d) 38 | (quasisyntax/loc stx 39 | (#,(detect-prolog-syntax #'a) 40 | . 41 | #,(detect-prolog-syntax #'d)))] 42 | [_ stx])) 43 | 44 | (define (tag-prolog-functors stx) 45 | (syntax-parse stx 46 | [(id:id (~and (arg:expr ...+) brackets) . more) 47 | ;; 'paren-shape property being null affirms that round brackets were used 48 | (cond [(and (not (syntax-property #'brackets 'paren-shape)) 49 | (= (+ (syntax-position #'id) (syntax-span #'id)) 50 | (syntax-position #'brackets))) 51 | (let ([adjusted-more (tag-prolog-functors #'more)] 52 | [arguments (tag-prolog-functors #'(arg ...))]) 53 | (datum->syntax 54 | #f 55 | `((#%prolog-functor ,#'id ,@arguments) . ,adjusted-more) 56 | stx))] 57 | [else 58 | (with-syntax ([(_ . rest) stx]) 59 | (let ([adjusted-rest (tag-prolog-functors #'rest)]) 60 | (datum->syntax #f 61 | `(,#'id . ,adjusted-rest) 62 | stx)))])] 63 | [(a . d) 64 | (quasisyntax/loc stx 65 | (#,(tag-prolog-functors #'a) 66 | . 67 | #,(tag-prolog-functors #'d)))] 68 | [_ stx])) 69 | 70 | (define (shen-cons-fold list-items) 71 | (foldr (lambda (item acc) (if (void? acc) item #`(cons #,item #,acc))) 72 | (void) 73 | (syntax->list list-items))) 74 | 75 | (define read-list 76 | (case-lambda 77 | [(ch in) 78 | (syntax->datum 79 | (shen-cons-fold (read-list-items in (object-name in))))] 80 | [(ch in src line col pos) 81 | (shen-cons-fold (read-list-items in src))])) 82 | 83 | (define read-shen-backslash-symbols 84 | (case-lambda 85 | [(ch in) 86 | (read-shen-backslash-symbols- in)] 87 | [(ch in src line col pos) 88 | (read-shen-backslash-symbols- in src)])) 89 | 90 | ;; TODO: generalize this function to other graphic chars 91 | (define (read-shen-backslash-symbols- in [src #f]) 92 | (case (peek-char in) 93 | [(#\*) 94 | (read-char in) ;; read the #\* 95 | 96 | (define comment-chars 97 | (for/list ([ch (in-input-port-chars in)] 98 | #:break (and (eq? ch #\*) 99 | (eq? (peek-char in) #\\))) 100 | ch)) 101 | 102 | (read-char in) ;; read the final #\\ 103 | (make-special-comment (list->string comment-chars))] 104 | [(#\+) 105 | (read-char in) 106 | '|\+|] 107 | [(#\=) 108 | (read-char in) 109 | (if (eq? (peek-char in) #\=) 110 | (begin 111 | (read-char in) 112 | '|\==|) 113 | '|\=|)])) 114 | 115 | (define shen-readtable 116 | (make-readtable #f 117 | #\[ 'terminating-macro read-list 118 | #\| 'terminating-macro (const #\|) 119 | #\; 'terminating-macro (const '|;|) 120 | #\, 'terminating-macro (const '|,|) 121 | #\: 'terminating-macro (const '|:|) 122 | #\\ 'terminating-macro read-shen-backslash-symbols 123 | #\{ 'terminating-macro (const '|{|) 124 | #\} 'terminating-macro (const '|}|) 125 | ;; parse # like any other symbol char 126 | #\# #\a (current-readtable))) 127 | 128 | (define (consume-spaces in) 129 | (define ch (peek-char in)) 130 | (when (and (char? ch) (char-whitespace? ch)) 131 | (read-char in) 132 | (consume-spaces in))) 133 | 134 | (define (read-list-items in [src #f]) 135 | (define list-contents 136 | (for/list ([term (in-generator 137 | (let loop () 138 | (consume-spaces in) 139 | (case (peek-char in) 140 | ([#\]] (read-char in) 141 | (yield (datum->syntax #f '())) 142 | (yield (void))) 143 | ([#\|] (read-char in) 144 | (consume-spaces in) 145 | (let ([term (read-syntax/recursive src in)]) 146 | (consume-spaces in) 147 | (if (equal? (peek-char in) #\]) 148 | (yield term) 149 | (let-values ([(line col pos) (port-next-location in)]) 150 | (raise-read-error "expected a closing ']'" src line col pos 1)))) 151 | (read-char in) 152 | (yield (void))) 153 | (else (yield (read-syntax/recursive src in)))) 154 | (loop)))] 155 | #:break (void? term)) 156 | term)) 157 | (datum->syntax #f list-contents))) 158 | -------------------------------------------------------------------------------- /lang/scryer-prolog-interface.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require data/gvector 4 | racket/runtime-path 5 | racket/system) 6 | 7 | (provide add-multiplexed-input-port-pipe! 8 | add-multiplexed-output-port-pipe! 9 | scryer-prolog-err 10 | scryer-prolog-in 11 | scryer-prolog-out) 12 | 13 | (define-runtime-path scryer-prolog-path "../dist/bin/scryer-prolog") 14 | (define-runtime-path scryer-shen-toplevel "../scryer-server/scryer-shen-toplevel.pl") 15 | 16 | (define-values (scryer-prolog-process in out err) 17 | (subprocess #f #f #f 'new scryer-prolog-path "-f" scryer-shen-toplevel)) 18 | 19 | (struct multiplexed-input-port [name wrapped-in child-outs] 20 | #:property prop:input-port (struct-field-index wrapped-in)) 21 | 22 | (define (make-multiplexed-input-port name in) 23 | (define child-outs (make-gvector)) 24 | (define wrapped-in (make-input-port 25 | name 26 | (lambda (bstr) 27 | (unless (eq? (subprocess-status scryer-prolog-process) 'running) 28 | (error "Scryer Prolog is no longer running!")) 29 | (handle-evt (read-bytes!-evt bstr in) 30 | (lambda (bytes-read-or-eof) 31 | (unless (eof-object? bytes-read-or-eof) 32 | (for ([pipe (in-gvector child-outs)]) 33 | (write-bytes bstr pipe))) 34 | bytes-read-or-eof))) 35 | (lambda (bstr skip progress-evt) 36 | (peek-bytes!-evt bstr skip progress-evt in)) 37 | (thunk (close-input-port in)))) 38 | (multiplexed-input-port name wrapped-in child-outs)) 39 | 40 | (struct multiplexed-output-port [name wrapped-out child-outs] 41 | #:property prop:output-port (struct-field-index wrapped-out)) 42 | 43 | (define (make-multiplexed-output-port name out) 44 | (define child-outs (make-gvector)) 45 | (define wrapped-out (make-output-port 46 | name 47 | always-evt 48 | (lambda (bstr start-pos end-pos can-block? blocks?) 49 | (unless (eq? (subprocess-status scryer-prolog-process) 'running) 50 | (error "Scryer Prolog is no longer running!")) 51 | (define result (write-bytes 52 | bstr 53 | out 54 | start-pos 55 | end-pos)) 56 | (flush-output out) 57 | (for ([pipe (in-gvector child-outs)]) 58 | (write-bytes bstr pipe start-pos end-pos)) 59 | result) 60 | (thunk (close-output-port out)))) 61 | (multiplexed-output-port name wrapped-out child-outs)) 62 | 63 | (define (add-multiplexed-input-port-pipe! in pipe) 64 | (gvector-add! (multiplexed-input-port-child-outs in) pipe)) 65 | 66 | (define (add-multiplexed-output-port-pipe! out pipe) 67 | (gvector-add! (multiplexed-output-port-child-outs out) pipe)) 68 | 69 | (define scryer-prolog-in (make-multiplexed-input-port 'scryer-prolog-out in)) 70 | (define scryer-prolog-err (make-multiplexed-input-port 'scryer-prolog-err err)) 71 | (define scryer-prolog-out (make-multiplexed-output-port 'scryer-prolog-in out)) 72 | 73 | (fprintf scryer-prolog-out "'$scryer-shen-toplevel':repl.~n") 74 | 75 | (define sp-executor (make-will-executor)) 76 | 77 | (will-register sp-executor scryer-prolog-process (lambda (_) (fprintf scryer-prolog-out "end_of_file.~n"))) 78 | 79 | (will-register sp-executor scryer-prolog-in close-input-port) 80 | (will-register sp-executor scryer-prolog-out close-output-port) 81 | (will-register sp-executor scryer-prolog-err close-input-port) 82 | -------------------------------------------------------------------------------- /lang/syntax-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require data/gvector 4 | (for-template 5 | racket/base 6 | racket/match 7 | racket/stxparam 8 | "failure.rkt" 9 | (only-in racket/function 10 | curry)) 11 | "pairs.rkt" 12 | racket 13 | racket/generator 14 | racket/match 15 | racket/syntax 16 | syntax/parse 17 | syntax/parse/define 18 | syntax/stx) 19 | 20 | (provide function-clause-definition 21 | kl-defun 22 | macro-clause-definition 23 | prolog-body-pattern 24 | quote-pattern 25 | shen-binding 26 | shen-cons-syntax 27 | shen-curry-out-export 28 | shen-define 29 | shen-defmacro 30 | shen-internal-package 31 | shen-function-out-export 32 | shen-function-type-sig 33 | shen-package 34 | shen-cond-form 35 | shen-if-form 36 | shen-lambda-form 37 | shen-let-form 38 | shen-prolog-rule 39 | ;; shen-prolog-term 40 | shen-strings 41 | shen-special-form? 42 | shen-var-id 43 | syntax->shen-prolog-term 44 | unit-string) 45 | 46 | (define (capitalized-symbol? symbol) 47 | (and (symbol? symbol) 48 | (let ([string (symbol->string symbol)]) 49 | (char-upper-case? (string-ref string 0))))) 50 | 51 | (define (quote-pattern pattern) 52 | (syntax-parse pattern 53 | [((~datum cons) hd tl) 54 | (quasisyntax/loc pattern 55 | (cons #,(quote-pattern #'hd) 56 | #,(quote-pattern #'tl)))] 57 | [() #''()] 58 | [(~datum _) pattern] 59 | [(~and id:id (~not :shen-var-id)) 60 | #''id] 61 | [_ pattern])) 62 | 63 | (define (pattern-variables pattern) 64 | (for/list ([var (in-generator 65 | (let loop ([pattern pattern]) 66 | (syntax-parse pattern 67 | [(a . d) 68 | (loop #'a) 69 | (loop #'d)] 70 | [:shen-var-id 71 | (yield pattern)] 72 | [_ (void)])))]) 73 | var)) 74 | 75 | (define (shen-strings form) 76 | (for/list ([string (in-generator 77 | (let loop ([form form]) 78 | (syntax-parse form 79 | [(a . d) 80 | (loop #'a) 81 | (loop #'d)] 82 | [:string 83 | (yield form)] 84 | [_ (void)])))]) 85 | string)) 86 | 87 | (define-literal-set shen-special-forms 88 | #:datum-literals (true false let cons if /. cond fn @p @s @v) 89 | ()) 90 | 91 | (define shen-special-form? 92 | (literal-set->predicate shen-special-forms)) 93 | 94 | (define-syntax-class unit-string 95 | (pattern str:string 96 | #:fail-unless (= (string-length (syntax-e #'str)) 1) 97 | "string literal patterns must consist of a single character")) 98 | 99 | (define (syntax->shen-prolog-term stx [type-datum? #t] [untagged-vars? #f]) 100 | (syntax-parse stx 101 | [(~literal <>) 102 | #'<>] 103 | [str:string #'str] 104 | [num:number #'num] 105 | [sym:shen-var-id 106 | (if type-datum? 107 | (wrap-tagged-shen-prolog-term #'sym untagged-vars?) 108 | #'sym)] 109 | [(~and sym:id 110 | (~not (~literal #%prolog-functor)) 111 | (~not (~literal #%apply))) 112 | #:when (not (shen-special-form? #'sym)) 113 | #'sym] 114 | [((~datum fn) arg:id) 115 | #'(#%prolog-functor fn arg)] 116 | [((~and id:id (~or (~datum @p) 117 | (~datum @s) 118 | (~datum @v))) 119 | first-arg 120 | second-arg) 121 | #`(#%prolog-functor id 122 | #,(syntax->shen-prolog-term #'first-arg type-datum? untagged-vars?) 123 | #,(syntax->shen-prolog-term #'second-arg type-datum? untagged-vars?))] 124 | [((~and id:id (~or (~datum @p) 125 | (~datum @s) 126 | (~datum @v))) 127 | first-arg 128 | second-arg 129 | args 130 | ...+) 131 | #:with first-arg-stx (syntax->shen-prolog-term #'first-arg 132 | type-datum? 133 | untagged-vars?) 134 | #:with second-arg-stx (syntax->shen-prolog-term #'(id second-arg args ...) 135 | type-datum? 136 | untagged-vars?) 137 | #`(#%prolog-functor id first-arg-stx second-arg-stx)] 138 | [((~and id:id (~or (~datum freeze) 139 | (~datum thaw))) 140 | e:expr) 141 | #`(#%prolog-functor id 142 | #,(syntax->shen-prolog-term 143 | #'e 144 | type-datum? 145 | untagged-vars?))] 146 | [((~datum if) cond:expr then:expr else:expr) 147 | #:with cond-term (syntax->shen-prolog-term 148 | #'cond 149 | type-datum? 150 | untagged-vars?) 151 | #:with then-term (syntax->shen-prolog-term 152 | #'then 153 | type-datum? 154 | untagged-vars?) 155 | #:with else-term (syntax->shen-prolog-term 156 | #'else 157 | type-datum? 158 | untagged-vars?) 159 | #'(#%prolog-functor if 160 | cond-term 161 | then-term 162 | else-term)] 163 | [((~datum let) first-b:shen-binding remaining-b ... body-expr:expr) 164 | #:with id-shen-prolog-term (if (and type-datum? (not untagged-vars?)) 165 | #'first-b.id 166 | (syntax->shen-prolog-term #'first-b.id 167 | type-datum? 168 | untagged-vars?)) 169 | #:with expr-shen-prolog-term (syntax->shen-prolog-term #'first-b.expr 170 | type-datum? 171 | untagged-vars?) 172 | (parameterize ([local-pattern-variables (list* (syntax->datum #'first-b.id) 173 | (local-pattern-variables))]) 174 | #`(#%prolog-functor let id-shen-prolog-term expr-shen-prolog-term 175 | #,(syntax->shen-prolog-term 176 | (if (stx-pair? #'(remaining-b ...)) 177 | #'(let remaining-b ... body-expr) 178 | #'body-expr) 179 | type-datum? 180 | untagged-vars?)))] 181 | [((~datum /.) var:shen-var-id remaining-var:shen-var-id ... body-expr:expr) 182 | #:with id-shen-prolog-term 183 | (if (and type-datum? (not untagged-vars?)) 184 | #'var 185 | (syntax->shen-prolog-term #'var type-datum? untagged-vars?)) 186 | #:with expr-shen-prolog-term 187 | (parameterize ([local-pattern-variables (list* (syntax->datum #'var) 188 | (local-pattern-variables))]) 189 | (syntax->shen-prolog-term 190 | (if (stx-pair? #'(remaining-var ...)) 191 | #'(/. remaining-var ... body-expr) 192 | #'body-expr) 193 | type-datum? 194 | untagged-vars?)) 195 | #'(#%prolog-functor /. id-shen-prolog-term expr-shen-prolog-term)] 196 | [((~literal quote) x) 197 | (syntax->shen-prolog-term #'x type-datum? untagged-vars?)] 198 | [((~datum cons) a d) 199 | #`(cons #,(syntax->shen-prolog-term #'a type-datum? untagged-vars?) 200 | #,(syntax->shen-prolog-term #'d type-datum? untagged-vars?))] 201 | [(type-sig) 202 | #:declare type-sig (shen-function-type-sig #:type-datum type-datum? 203 | #:untagged-vars untagged-vars?) 204 | #'(#%prolog-functor --> type-sig.type ...)] 205 | [((~datum #%prolog-functor) id:id . args) 206 | #:with (arg-term ...) (stx-map (lambda (stx) 207 | (syntax->shen-prolog-term 208 | stx 209 | type-datum? 210 | untagged-vars?)) 211 | #'args) 212 | #'(#%prolog-functor id arg-term ...)] 213 | [(f) 214 | #:with fn (syntax->shen-prolog-term #'f type-datum? untagged-vars?) 215 | #'(#%prolog-functor #%apply fn)] 216 | [(f first-arg arg ...) 217 | #:when type-datum? 218 | #:with fn-term (syntax-parse #'f 219 | [(~and id:id (~not :shen-var-id)) 220 | #'(#%prolog-functor fn id)] 221 | [term (syntax->shen-prolog-term #'term type-datum? untagged-vars?)]) 222 | #:with inner-apply #`(#%prolog-functor #%apply 223 | fn-term 224 | #,(syntax->shen-prolog-term #'first-arg 225 | type-datum? 226 | untagged-vars?)) 227 | #:with (arg-term ...) (stx-map (lambda (stx) 228 | (syntax->shen-prolog-term 229 | stx 230 | type-datum? 231 | untagged-vars?)) 232 | #'(arg ...)) 233 | (foldl (lambda (arg-term acc) 234 | #`(#%prolog-functor #%apply #,acc #,arg-term)) 235 | #'inner-apply 236 | (syntax->list #'(arg-term ...)))] 237 | [((~and a:id (~not :shen-var-id)) d ...+) 238 | #:with a-arg (syntax->shen-prolog-term 239 | #'a 240 | type-datum? 241 | untagged-vars?) 242 | #:with (d-arg ...) (stx-map (lambda (stx) 243 | (syntax->shen-prolog-term 244 | stx 245 | type-datum? 246 | untagged-vars?)) 247 | #'(d ...)) 248 | #'(#%prolog-functor a-arg d-arg ...)] 249 | [datum #'datum])) 250 | 251 | (define shen-cons-syntax 252 | (syntax-parser 253 | [(a . d) 254 | #`(cons a #,(shen-cons-syntax #'d))] 255 | [stx 256 | #'stx])) 257 | 258 | (define-splicing-syntax-class (shen-function-type-sig #:type-datum [type-datum? #f] 259 | #:untagged-vars [untagged-vars? #t]) 260 | #:attributes ((type 1)) 261 | #:datum-literals (-->) 262 | (pattern (~seq --> t) 263 | #:with (type ...) #`(#,(syntax->shen-prolog-term #'t type-datum? untagged-vars?))) 264 | (pattern (~seq (~and t1 (~not -->)) (~seq --> t2) ...+) 265 | #:with (type ...) (stx-map (lambda (stx) 266 | (syntax->shen-prolog-term 267 | stx 268 | type-datum? 269 | untagged-vars?)) 270 | #'(t1 t2 ...)))) 271 | 272 | (define local-pattern-variables (make-parameter empty)) 273 | 274 | (define (wrap-tagged-shen-prolog-term datum-term untagged-vars?) 275 | (define datum (syntax->datum datum-term)) 276 | (if (not untagged-vars?) 277 | (if (memf (lambda (var) (equal? datum var)) 278 | (local-pattern-variables)) 279 | datum-term 280 | #`(#%free-variable #,datum-term)) 281 | datum-term)) 282 | 283 | (define-splicing-syntax-class shen-cond-form 284 | #:attributes ((condition 1) 285 | (true-form 1)) 286 | (pattern (~seq (condition:expr true-form:expr) ...+))) 287 | 288 | (define-splicing-syntax-class shen-if-form 289 | (pattern (~seq condition:expr true-form:expr false-form:expr))) 290 | 291 | (define-splicing-syntax-class shen-lambda-form 292 | (pattern (~seq var:shen-var-id ... body-expr:expr) 293 | #:do [(stx-map (lambda (stx) (syntax-property stx 'bound #t)) 294 | #'(var ...))])) 295 | 296 | (define-splicing-syntax-class shen-let-form 297 | #:attributes ((binding-id 1) 298 | (binding-expr 1) 299 | body-expr) 300 | (pattern (~seq binding:shen-binding ...+ body-expr:expr) 301 | #:with (binding-id ...) #'(binding.id ...) 302 | #:with (binding-expr ...) #'(binding.expr ...))) 303 | 304 | (define-syntax-class shen-var-id 305 | (pattern (~and id:id (~fail #:unless (capitalized-symbol? (syntax->datum #'id)))))) 306 | 307 | (define-syntax-class function-clause-pattern 308 | #:attributes (pat (vars 1)) 309 | #:datum-literals (-> <-) 310 | (pattern (~and (~not ->) (~not <-)) 311 | #:with pat (quote-pattern this-syntax) 312 | #:with (vars ...) (pattern-variables this-syntax)) 313 | (pattern (~or (->) (<-)) 314 | #:with pat this-syntax 315 | #:with (vars ...) (pattern-variables this-syntax))) 316 | 317 | (define-syntax-class macro-clause-pattern 318 | #:attributes (pat) 319 | #:datum-literals (->) 320 | (pattern (~not ->) 321 | #:with pat (quote-pattern this-syntax))) 322 | 323 | (define-splicing-syntax-class shen-prolog-rule 324 | #:attributes ((head-form 1) 325 | (body-form 1)) 326 | #:datum-literals (<--) 327 | (pattern (~seq head-form:prolog-head-pattern ... 328 | <-- 329 | body-form:prolog-body-pattern ... 330 | (~literal |;|)))) 331 | 332 | (define-syntax-class prolog-head-pattern 333 | #:datum-literals (<--) 334 | (pattern (~not (~or <-- (~literal |;|))))) 335 | 336 | (define-syntax-class prolog-body-pattern 337 | (pattern (~not (~literal |;|)))) 338 | 339 | (define-syntax-class shen-op-assoc 340 | (pattern (~or #:right #:left))) 341 | 342 | (define-splicing-syntax-class macro-clause-definition 343 | #:attributes (body match-clause pat) 344 | #:datum-literals (->) 345 | (pattern (~seq pat:macro-clause-pattern -> body:expr) 346 | #:with match-clause #'[pat.pat body])) 347 | 348 | (define-splicing-syntax-class shen-binding 349 | #:attributes (id expr) 350 | (pattern (~seq id:shen-var-id expr:expr) 351 | #:do [(syntax-property #'id 'bound #t)] 352 | #:with id-shen-prolog-term (syntax->shen-prolog-term #'id) 353 | #:with expr-shen-prolog-term (syntax->shen-prolog-term #'expr))) 354 | 355 | (define-splicing-syntax-class function-clause-definition 356 | #:attributes ((pats 1) 357 | arrow 358 | body 359 | guard 360 | match-clause 361 | shen-prolog-body 362 | shen-prolog-guard 363 | (shen-prolog-pat 1) 364 | (shen-string 1)) 365 | #:datum-literals (-> <- where) 366 | (pattern (~seq pats:function-clause-pattern ... -> body:expr 367 | (~optional (~seq where guard:expr))) 368 | #:with arrow #'-> 369 | #:with pat-vars #'(pats.vars ... ...) 370 | #:with match-clause #'[(pats.pat ...) (~? (~@ . (#:when guard))) body] 371 | #:with shen-prolog-body (parameterize ([local-pattern-variables (syntax->datum #'pat-vars)]) 372 | (syntax->shen-prolog-term #'body)) 373 | #:with shen-prolog-guard (parameterize ([local-pattern-variables (syntax->datum #'pat-vars)]) 374 | (if (attribute guard) 375 | (syntax->shen-prolog-term #'guard) 376 | #'#t)) 377 | #:with (shen-prolog-pat ...) (parameterize ([local-pattern-variables (syntax->datum #'pat-vars)]) 378 | (stx-map syntax->shen-prolog-term #'(pats.pat ...))) 379 | #:with (shen-string ...) (shen-strings this-syntax)) 380 | (pattern (~seq pats:function-clause-pattern ... <- body:expr 381 | (~optional (~seq where guard:expr))) 382 | #:with arrow #'<- 383 | #:with pat-vars #'(pats.vars ... ...) 384 | #:with match-clause #'[(pats.pat ...) 385 | (=> backtrack-fn) 386 | (~? (unless guard (backtrack-fn))) 387 | (syntax-parameterize ([fail (syntax-id-rules (backtrack-fn) 388 | [(fail) (backtrack-fn)] 389 | [fail fail])] 390 | [fail-if (syntax-id-rules (backtrack-fn) 391 | [(fail-if fail-fn r) 392 | (let ([result r]) 393 | (if (fail-fn result) 394 | (backtrack-fn) 395 | result))] 396 | [fail-if 397 | (lambda (e r) 398 | (let ([result r]) 399 | (if (fail-fn result) 400 | (backtrack-fn) 401 | result)))])]) 402 | body)] 403 | #:with shen-prolog-body (parameterize ([local-pattern-variables (syntax->datum #'pat-vars)]) 404 | (syntax->shen-prolog-term #'body)) 405 | #:with shen-prolog-guard (parameterize ([local-pattern-variables (syntax->datum #'pat-vars)]) 406 | (if (attribute guard) 407 | (syntax->shen-prolog-term #'guard) 408 | #'#t)) 409 | #:with (shen-prolog-pat ...) (parameterize ([local-pattern-variables (syntax->datum #'pat-vars)]) 410 | (stx-map syntax->shen-prolog-term #'(pats.pat ...))) 411 | #:with (shen-string ...) (shen-strings this-syntax))) 412 | 413 | ;; the cut in shen-define ensures a syntax error is raised if the 414 | ;; second #:fail-unless condition isn't met. 415 | (define-splicing-syntax-class shen-define 416 | #:attributes (name (clause 1) (type 1) type-sig wrapper) 417 | #:datum-literals (|{| |}|) 418 | (pattern (~seq 419 | name:id (~optional (~seq |{| type-sig:shen-function-type-sig |}| ~!)) 420 | clause:function-clause-definition ...+) 421 | #:fail-unless (apply = (map length (attribute clause.pats))) 422 | "each clause must contain the same number of patterns" 423 | #:fail-unless (if (attribute type-sig.type) 424 | (= (length (first (attribute clause.pats))) 425 | (sub1 (length (attribute type-sig.type)))) 426 | #t) 427 | "the number of argument types must match the number of clause arguments" 428 | #:with (type ...) #'((~? (~@ type-sig.type ...) ())) 429 | #:with (arg-id ...) (stx-map 430 | (lambda (stx) (syntax-property stx 'bound #t)) 431 | (generate-temporaries (car (attribute clause.pats)))) 432 | #:with wrapper #'(curry 433 | (letrec ([name (lambda (arg-id ...) 434 | (match* (arg-id ...) 435 | clause.match-clause ...))]) 436 | name)))) 437 | 438 | (define-splicing-syntax-class kl-defun 439 | #:attributes (name wrapper (body-expr 1)) 440 | (pattern (~seq name:id (args:shen-var-id ...) body-expr:expr ...+) 441 | #:do [(stx-map 442 | (lambda (stx) (syntax-property stx 'bound #t)) 443 | #'(args ...))] 444 | #:with wrapper #'(curry 445 | (letrec ([name (lambda (args ...) 446 | body-expr ...)]) 447 | name)))) 448 | 449 | (define-splicing-syntax-class shen-defmacro 450 | #:attributes (name (pat 1) (clause-expr 1) expander) 451 | (pattern (~seq name:id clause:macro-clause-definition ...+) 452 | #:with (pat ...) #'(clause.pat ...) 453 | #:with (clause-expr ...) #'(clause.body ...) 454 | #:with expander #'(lambda (k) 455 | (lambda (arg-id) 456 | (match arg-id 457 | clause.match-clause 458 | ... 459 | [_ (k arg-id)]))))) 460 | 461 | (define-syntax-class shen-top-level-decl 462 | #:datum-literals (define defun defmacro) 463 | #:attributes (name expansion) 464 | (pattern (define define-form:shen-define) 465 | #:with expansion #'(define . define-form) 466 | #:with name (attribute define-form.name)) 467 | (pattern (defun defun-form:kl-defun) 468 | #:with expansion #'(defun . defun-form) 469 | #:with name (attribute defun-form.name)) 470 | (pattern (defmacro defmacro-form:shen-defmacro) 471 | #:with expansion #'(defmacro . defmacro-form) 472 | #:with name (attribute defmacro-form.name))) 473 | 474 | (define-splicing-syntax-class shen-package 475 | #:attributes (export-list 476 | name 477 | (top-level-decls 1)) 478 | (pattern (~seq name:id 479 | export-list:expr 480 | top-level-decls:shen-top-level-decl ...))) 481 | 482 | (define-splicing-syntax-class shen-internal-package 483 | #:attributes (export-list 484 | external-symbols 485 | internal-symbols 486 | name 487 | (top-level-decls 1)) 488 | (pattern (~seq name:id 489 | export-list:expr 490 | external-symbols:expr 491 | internal-symbols:expr 492 | top-level-decls:shen-top-level-decl ...))) 493 | 494 | (define-syntax-class shen-curry-out-export 495 | #:attributes (func-id renamed-id wrapper assoc) 496 | (pattern [func-id:id (~optional renamed-id:id #:defaults ([renamed-id #'func-id])) 497 | #:arity wrapped-arity:nat 498 | (~optional (~seq #:polyadic assoc:shen-op-assoc) #:defaults ([assoc #'#f]))] 499 | #:cut 500 | #:fail-when (and (syntax->datum (attribute assoc)) 501 | (not (= (syntax->datum (attribute wrapped-arity)) 2))) 502 | "polyadic functions must have arity 2" 503 | #:with wrapper #'(curry (procedure-reduce-arity func-id wrapped-arity))) 504 | (pattern [func-id:id renamed-id:id] 505 | #:with wrapper #'(curry func-id) 506 | #:with assoc #'#f) 507 | (pattern func-id:id 508 | #:with renamed-id #'func-id 509 | #:with wrapper #'(curry func-id) 510 | #:with assoc #'#f)) 511 | 512 | (define-syntax-class shen-function-out-export 513 | #:attributes (func-id renamed-id) 514 | (pattern [(~seq func-id:id renamed-id:id)]) 515 | (pattern func-id:id 516 | #:with renamed-id #'func-id)) 517 | -------------------------------------------------------------------------------- /lang/system-function-exports.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (except-in racket 4 | load 5 | foldr 6 | map 7 | eval 8 | set 9 | vector) 10 | (only-in "expander.rkt" 11 | shen-curry-out 12 | shen-function-out) 13 | "failure.rkt" 14 | (only-in "load.rkt" 15 | load) 16 | "system-functions.rkt" 17 | "systemf.rkt") 18 | 19 | ;; system functions manifest 20 | (provide (shen-curry-out [+ #:arity 2 #:polyadic #:right] 21 | [* #:arity 2 #:polyadic #:right] 22 | [- #:arity 2] 23 | [/ #:arity 2] 24 | [> #:arity 2] 25 | [< #:arity 2] 26 | [equal? == #:arity 2] 27 | [>= #:arity 2] 28 | [<= #:arity 2] 29 | [<-vector #:arity 2] 30 | [vector-> #:arity 3] 31 | [cons adjoin #:arity 2] 32 | [append #:arity 2 #:polyadic #:right] 33 | [map #:arity 2] 34 | [cn #:arity 2] 35 | [concat #:arity 2] 36 | [difference #:arity 2] 37 | [element? #:arity 2]) 38 | (rename-out [begin do]) 39 | (shen-function-out [shen-= =] 40 | atom? 41 | [car head] 42 | cd 43 | [cdr tail] 44 | [vector? absvector?] 45 | arity 46 | bound? 47 | cons 48 | cons? 49 | empty? 50 | error-to-string 51 | external 52 | eval 53 | eval-kl 54 | explode 55 | fix 56 | fst 57 | function 58 | gensym 59 | hdstr 60 | integer? 61 | intern 62 | internal 63 | limit 64 | load 65 | [shen-not not] 66 | output 67 | snd 68 | symbol? 69 | systemf 70 | thaw 71 | undefmacro 72 | value 73 | vector) 74 | (all-from-out "failure.rkt") 75 | destroy 76 | error 77 | fn 78 | freeze 79 | set 80 | tc) 81 | -------------------------------------------------------------------------------- /lang/system-functions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "bindings.rkt" 4 | (only-in "expander.rkt" 5 | defmacro) 6 | (only-in racket 7 | [foldr r:foldr] 8 | [map r:map] 9 | [eval r:eval] 10 | [vector r:vector]) 11 | (only-in racket/exn 12 | exn->string) 13 | (only-in "failure.rkt" 14 | fail 15 | fail-if) 16 | "macros.rkt" 17 | "namespaces.rkt" 18 | "pairs.rkt" 19 | (only-in "packages.rkt" 20 | package-list) 21 | (for-syntax syntax/parse) 22 | syntax/parse/define 23 | "type-syntax-expanders.rkt") 24 | 25 | (provide (all-defined-out)) 26 | 27 | (define-syntax tc 28 | (syntax-parser 29 | [(_ (~datum +)) 30 | #'(begin (type-check? #t) #t)] 31 | [(_ (~datum -)) 32 | #'(begin (type-check? #f) #f)] 33 | [_ (raise-syntax-error 'tc "expects + or -")])) 34 | 35 | (define-syntax fn 36 | (syntax-parser 37 | [(_ id:id) 38 | #:with fs-proc ((make-interned-syntax-introducer 'function) #'id) 39 | #'fs-proc])) 40 | 41 | (define-syntax destroy 42 | (syntax-parser 43 | [(_ id:id) 44 | #`(begin 45 | (set! #,((make-interned-syntax-introducer 'function) #'id) (void)) 46 | (hash-remove! shen-function-bindings id))] 47 | [(_ value) #'value] 48 | [id:id #''id])) 49 | 50 | (defmacro shen.and-right-assoc-macro 51 | (cons and (cons Op1 (cons Op2 (cons Op3 Ops)))) 52 | -> 53 | (cons 'if (cons Op1 (cons (cons 'and (cons Op2 (cons Op3 Ops))) '(false)))) 54 | (cons and (cons Op1 (cons Ops '()))) 55 | -> 56 | (cons 'if (cons Op1 (cons (cons 'if (cons Ops '(true false))) '(false))))) 57 | 58 | (defmacro shen.or-right-assoc-macro 59 | (cons or (cons Op1 (cons Op2 (cons Op3 Ops)))) 60 | -> 61 | (cons 'if (cons Op1 (cons 'true (cons (cons 'or (cons Op2 (cons Op3 Ops))) '())))) 62 | (cons or (cons Op1 (cons Ops '()))) 63 | -> 64 | (cons 'if (cons Op1 (cons 'true (cons Ops '()))))) 65 | 66 | (define-syntax set 67 | (syntax-parser 68 | [(_ id:id value:expr) 69 | #'(hash-set! shen-variable-bindings id value)] 70 | [id:id #''id])) 71 | 72 | (define (arity proc) 73 | (let ([arity (procedure-arity (function proc))]) 74 | (if (cons? arity) 75 | (last arity) 76 | arity))) 77 | 78 | (define (bound? var) 79 | (with-handlers ([exn:fail:contract? (lambda (_) #f)]) 80 | (begin 81 | (hash-ref shen-variable-bindings var) 82 | #t))) 83 | 84 | (define (value key) 85 | (if (symbol? key) 86 | (hash-ref shen-variable-bindings key) 87 | (error "value: first parameter must be a symbol."))) 88 | 89 | (define (function var) 90 | (cond [(symbol? var) 91 | (hash-ref shen-function-bindings var)] 92 | [(procedure? var) 93 | var] 94 | [else 95 | (error "function: first parameter must be bound to a function.")])) 96 | 97 | (define (map fn list) 98 | (r:map (function fn) list)) 99 | 100 | (define (cd string) 101 | (current-directory string)) 102 | 103 | (define cn string-append) 104 | 105 | (define (difference list-1 list-2) 106 | (filter (lambda (e) (not (member e list-2 equal?))) list-1)) 107 | 108 | (define (element? e list) 109 | (if (member e list equal?) #t #f)) 110 | 111 | (define (eval-kl expr) 112 | (r:eval expr 113 | (if (and (cons? expr) (eq? 'defun (first expr))) 114 | shen-namespace 115 | kl-namespace))) 116 | 117 | (define (eval expr) 118 | (r:eval expr shen-namespace)) 119 | 120 | (define error-to-string exn->string) 121 | 122 | (define (concat x y) 123 | (if (and (symbol? x) (symbol? y)) 124 | (string->symbol (string-append (symbol->string x) (symbol->string y))) 125 | (and x y))) 126 | 127 | (define (undefmacro name) 128 | (if (symbol? name) 129 | (remove-shen-macro-expander! name) 130 | (error "undefmacro: argument must be a symbol naming a macro."))) 131 | 132 | (define (external pkg-name) 133 | (package-list pkg-name 'external)) 134 | 135 | (define (internal pkg-name) 136 | (package-list pkg-name 'internal)) 137 | 138 | (define (output fmt-string . args) 139 | (apply printf fmt-string args)) 140 | 141 | (define (vector size) 142 | (build-vector size (const '...))) 143 | 144 | (define-syntax-parse-rule (freeze stx:expr) 145 | (procedure-rename (thunk stx) ')) 146 | 147 | (define (thaw f) (f)) 148 | 149 | ;; Shen vectors are 1-indexed while Racket's are 0-indexed so sub1 to 150 | ;; compensate 151 | 152 | (define (<-vector vec idx) 153 | (vector-ref vec (sub1 idx))) 154 | 155 | (define (vector-> vec idx value) 156 | (vector-set! vec (sub1 idx) value) 157 | vec) 158 | 159 | (define limit vector-length) 160 | 161 | (define (explode data) 162 | (match data 163 | [(? string?) 164 | (map string (string->list data))] 165 | [(? vector?) 166 | (append '("<") 167 | (apply append (add-between (vector->list (vector-map explode data)) '(" "))) 168 | '(">"))] 169 | [(? symbol?) 170 | (explode (symbol->string data))] 171 | [(? number?) 172 | (explode (number->string data))] 173 | [(list args ...) 174 | (append '("[") 175 | (apply append (add-between (map explode args) '(" "))) 176 | '("]"))] 177 | [(list-rest args ... tail) 178 | (append '("[") 179 | (apply append (add-between (map explode args) '(" "))) 180 | '(" | ") 181 | (explode tail) 182 | '("]"))])) 183 | 184 | (define (atom? value) 185 | (or (boolean? value) 186 | (number? value) 187 | (string? value) 188 | (symbol? value))) 189 | 190 | (define (fix f) 191 | (procedure-rename (letrec ([fix-help (lambda (x) 192 | (let ([result (f x)]) 193 | (if (equal? result x) 194 | x 195 | (fix-help result))))]) 196 | fix-help) 197 | ')) 198 | 199 | (define (fst tuple) 200 | (vector-ref (shen-tuple-args tuple) 0)) 201 | 202 | (define (snd tuple) 203 | (vector-ref (shen-tuple-args tuple) 1)) 204 | 205 | (define (hdstr str) 206 | (string (string-ref str 0))) 207 | 208 | (define intern string->symbol) 209 | 210 | (define (shen-not val) 211 | (if (boolean? val) 212 | (not val) 213 | (error 'not "~a is not a boolean" val))) 214 | 215 | (define (shen-= x y) 216 | (if (and (number? x) (number? y)) 217 | (= x y) 218 | (equal? x y))) 219 | -------------------------------------------------------------------------------- /lang/systemf.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide reserved-shen-symbols 4 | reserved-shen-symbol? 5 | systemf) 6 | 7 | (define system-symbols (make-hasheq '((! . 'external) 8 | (|}| . 'external) 9 | (|{| . 'external) 10 | (--> . 'external) 11 | (<-- . 'external) 12 | (&& . 'external) 13 | (: . 'internal) 14 | (|;| . 'internal) 15 | (:= . 'internal) 16 | (|,| . 'internal) 17 | (|_| . 'external) 18 | (*language* . 'external) 19 | (*implementation* . 'external) 20 | (*stinput* . 'external) 21 | (*sterror* . 'external) 22 | (*stoutput* . 'external) 23 | (*home-directory* . 'external) 24 | (*version* . 'external) 25 | (*maximum-print-sequence-size* . 'external) 26 | (*macros* . 'external) 27 | (*os* . 'external) 28 | (*release* . 'external) 29 | (*property-vector* . 'external) 30 | (/. . 'external) 31 | (@v . 'external) 32 | (@p . 'external) 33 | (@s . 'external) 34 | (*port* . 'external) 35 | (*porters* . 'external) 36 | (*hush* . 'external) 37 | (<- . 'external) 38 | (-> . 'external) 39 | ( . 'external) 40 | (== . 'external) 41 | (= . 'external) 42 | (>= . 'external) 43 | (> . 'external) 44 | (==> . 'external) 45 | ( . 'external) 46 | ( . 'external) 47 | ($ . 'external) 48 | (- . 'external) 49 | (/ . 'external) 50 | (* . 'external) 51 | (+ . 'external) 52 | (<= . 'external) 53 | (< . 'external) 54 | (>> . 'external) 55 | (<> . 'external) 56 | (y-or-n? . 'external) 57 | (write-to-file . 'external) 58 | (write-byte . 'external) 59 | (where . 'external) 60 | (when . 'external) 61 | (warn . 'external) 62 | (version . 'external) 63 | (verified . 'external) 64 | (variable? . 'external) 65 | (var? . 'external) 66 | (value . 'external) 67 | (vector-> . 'external) 68 | (<-vector . 'external) 69 | (vector . 'external) 70 | (vector? . 'external) 71 | (u! . 'external) 72 | (update-lambda-table . 'external) 73 | (unspecialise . 'external) 74 | (untrack . 'external) 75 | (unit . 'external) 76 | (unix . 'external) 77 | (union . 'external) 78 | (unput . 'external) 79 | (unprofile . 'external) 80 | (undefmacro . 'external) 81 | (return . 'external) 82 | (type . 'external) 83 | (tuple? . 'external) 84 | (true . 'external) 85 | (trap-error . 'external) 86 | (track . 'external) 87 | (time . 'external) 88 | (thaw . 'external) 89 | (tc? . 'external) 90 | (tc . 'external) 91 | (tl . 'external) 92 | (tlstr . 'external) 93 | (tlv . 'external) 94 | (tail . 'external) 95 | (systemf . 'external) 96 | (synonyms . 'external) 97 | (symbol . 'external) 98 | (symbol? . 'external) 99 | (string->symbol . 'external) 100 | (sum . 'external) 101 | (subst . 'external) 102 | (string? . 'external) 103 | (string->n . 'external) 104 | (stream . 'external) 105 | (string . 'external) 106 | (stinput . 'external) 107 | (sterror . 'external) 108 | (stoutput . 'external) 109 | (step . 'external) 110 | (spy . 'external) 111 | (specialise . 'external) 112 | (snd . 'external) 113 | (simple-error . 'external) 114 | (set . 'external) 115 | (save . 'external) 116 | (str . 'external) 117 | (run . 'external) 118 | (reverse . 'external) 119 | (retract . 'external) 120 | (remove . 'external) 121 | (release . 'external) 122 | (read . 'external) 123 | (receive . 'external) 124 | (read-file . 'external) 125 | (read-file-as-bytelist . 'external) 126 | (read-file-as-string . 'external) 127 | (read-byte . 'external) 128 | (read-from-string . 'external) 129 | (read-from-string-unprocessed . 'external) 130 | (package? . 'external) 131 | (put . 'external) 132 | (preclude . 'external) 133 | (preclude-all-but . 'external) 134 | (ps . 'external) 135 | (prolog? . 'external) 136 | (protect . 'external) 137 | (profile-results . 'external) 138 | (profile . 'external) 139 | (prolog-memory . 'external) 140 | (print . 'external) 141 | (pprint . 'external) 142 | (pr . 'external) 143 | (pos . 'external) 144 | (porters . 'external) 145 | (port . 'external) 146 | (package . 'external) 147 | (output . 'external) 148 | (out . 'external) 149 | (os . 'external) 150 | (or . 'external) 151 | (optimise . 'external) 152 | (open . 'external) 153 | (occurrences . 'external) 154 | (occurs-check . 'external) 155 | (n->string . 'external) 156 | (number? . 'external) 157 | (number . 'external) 158 | (null . 'external) 159 | (nth . 'external) 160 | (not . 'external) 161 | (nl . 'external) 162 | (mode . 'external) 163 | (macroexpand . 'external) 164 | (maxinferences . 'external) 165 | (mapcan . 'external) 166 | (map . 'external) 167 | (make-string . 'external) 168 | (load . 'external) 169 | (loaded . 'external) 170 | (list . 'external) 171 | (lineread . 'external) 172 | (limit . 'external) 173 | (length . 'external) 174 | (let . 'external) 175 | (lazy . 'external) 176 | (lambda . 'external) 177 | (language . 'external) 178 | (is . 'external) 179 | (intersection . 'external) 180 | (inferences . 'external) 181 | (intern . 'external) 182 | (integer? . 'external) 183 | (input . 'external) 184 | (input . 'external) 185 | (inline . 'external) 186 | (include . 'external) 187 | (include-all-but . 'external) 188 | (it . 'external) 189 | (is . 'external) 190 | (is! . 'external) 191 | (in . 'external) 192 | (in-package . 'external) 193 | (internal . 'external) 194 | (implementation . 'external) 195 | (if . 'external) 196 | (head . 'external) 197 | (hd . 'external) 198 | (hdv . 'external) 199 | (hdstr . 'external) 200 | (hash . 'external) 201 | (get . 'external) 202 | (get-time . 'external) 203 | (gensym . 'external) 204 | (fn . 'external) 205 | (function . 'external) 206 | (fst . 'external) 207 | (freeze . 'external) 208 | (fresh . 'external) 209 | (fork . 'external) 210 | (foreign . 'external) 211 | (fix . 'external) 212 | (file . 'external) 213 | (fail . 'external) 214 | (fail-if . 'external) 215 | (factorise . 'external) 216 | (findall . 'external) 217 | (false . 'external) 218 | (enable-type-theory . 'external) 219 | (explode . 'external) 220 | (external . 'external) 221 | (exception . 'external) 222 | (eval-kl . 'external) 223 | (eval . 'external) 224 | (error-to-string . 'external) 225 | (error . 'external) 226 | (empty? . 'external) 227 | (element? . 'external) 228 | (do . 'external) 229 | (difference . 'external) 230 | (destroy . 'external) 231 | (defun . 'external) 232 | (define . 'external) 233 | (defmacro . 'external) 234 | (defcc . 'external) 235 | (defprolog . 'external) 236 | (declare . 'external) 237 | (datatype . 'external) 238 | (cn . 'external) 239 | (cons? . 'external) 240 | (cons . 'external) 241 | (cond . 'external) 242 | (concat . 'external) 243 | (compile . 'external) 244 | (cd . 'external) 245 | (cases . 'external) 246 | (call . 'external) 247 | (close . 'external) 248 | (bind . 'external) 249 | (bound? . 'external) 250 | (boolean? . 'external) 251 | (boolean . 'external) 252 | (bootstrap . 'external) 253 | (|.| . 'internal) 254 | (intern . 'external) 255 | (bar! . 'external) 256 | (atom? . 'external) 257 | (asserta . 'external) 258 | (assertz . 'external) 259 | (assoc . 'external) 260 | (arity . 'external) 261 | (append . 'external) 262 | (and . 'external) 263 | (adjoin . 'external) 264 | (<-address . 'external) 265 | (address-> . 'external) 266 | (absvector? . 'external) 267 | (absvector . 'external) 268 | (abort . 'external)))) 269 | 270 | (define (reserved-shen-symbol? name) 271 | (if (symbol? name) 272 | (eq? (cdr (hash-ref system-symbols name (thunk #f))) 'external) 273 | (error "reserved-shen-symbol?: first parameter must be a symbol."))) 274 | 275 | (define (reserved-shen-symbols) 276 | (map car (hash->list system-symbols))) 277 | 278 | (define (systemf name) 279 | (if (symbol? name) 280 | (begin 281 | (hash-set! system-symbols name 'external) 282 | (filter-map (lambda (pair) 283 | (and (eq? (cdr pair) 'external) 284 | (car pair))) 285 | (hash->list system-symbols))) 286 | (error "systemf: first parameter must be a symbol."))) 287 | -------------------------------------------------------------------------------- /lang/type-syntax-expanders.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require data/queue 4 | (for-syntax "prolog-syntax.rkt" 5 | "prolog-syntax-expanders.rkt" 6 | racket 7 | racket/syntax 8 | syntax/parse 9 | syntax/stx 10 | "syntax-utils.rkt" 11 | "types-syntax.rkt")) 12 | 13 | (provide (for-syntax function-def->type-check-queries 14 | datatype->type-definition) 15 | clear-type-check-queues! 16 | enqueue-datatype-definition! 17 | enqueue-function-type-data! 18 | type-check? 19 | type-check-definitions-and-queries) 20 | 21 | (define type-check? (make-parameter #f (lambda (val) 22 | (unless (boolean? val) 23 | (raise-type-error 'tc "boolean" val)) 24 | val))) 25 | 26 | (define function-assert-declare-queue (make-queue)) 27 | (define function-retract-declare-queue (make-queue)) 28 | (define function-type-check-queue (make-queue)) 29 | (define datatype-definition-queue (make-queue)) 30 | 31 | (define (clear-type-check-queues!) 32 | (set! datatype-definition-queue (make-queue)) 33 | (set! function-assert-declare-queue (make-queue)) 34 | (set! function-retract-declare-queue (make-queue)) 35 | (set! function-type-check-queue (make-queue))) 36 | 37 | (define (type-check-definitions-and-queries) 38 | (values (queue->list datatype-definition-queue) 39 | (queue->list function-assert-declare-queue) 40 | (queue->list function-retract-declare-queue) 41 | (queue->list function-type-check-queue))) 42 | 43 | (define (enqueue-datatype-definition! type-definition) 44 | (enqueue! datatype-definition-queue type-definition)) 45 | 46 | (define (enqueue-function-type-data! query-strings assert-string retract-string) 47 | (for ([query-string (in-list query-strings)]) 48 | (enqueue! function-type-check-queue query-string)) 49 | 50 | (enqueue! function-assert-declare-queue assert-string) 51 | (enqueue! function-retract-declare-queue retract-string)) 52 | 53 | (begin-for-syntax 54 | (define (datatype->type-definition type-module-name sequents) 55 | (syntax-parse sequents 56 | [((sequent:shen-type-sequent) ...+) 57 | (apply string-append 58 | (format ":- module('~a#type', []).\n\n" 59 | (syntax->datum type-module-name)) 60 | (stx-map (lambda (stx) 61 | (syntax-parse stx 62 | [((~datum defprolog) rule-name:id rule:shen-prolog-rule ...+) 63 | (expand-shen-defprolog #'rule-name #'(rule ...))])) 64 | #'(sequent.prolog-form ... ...)))])) 65 | 66 | (define (function-def->type-check-queries fn-name type-sig clauses) 67 | (define (pattern-hyps pat-types clause-strings pats clause-guard) 68 | (with-syntax ([(pat ...) pats] 69 | [(pat-type ...) pat-types] 70 | [(clause-string ...) clause-strings]) 71 | (shen-cons-syntax #`((#%prolog-functor type_check pat pat-type) 72 | ... 73 | (#%prolog-functor type_check clause-string string) 74 | ... 75 | #,@(if (eq? (syntax->datum clause-guard) #t) 76 | #'() 77 | #`((#%prolog-functor type_check 78 | #,clause-guard 79 | verified))))))) 80 | 81 | (define-values (assert-declare-string retract-declare-string) 82 | (syntax-parse type-sig 83 | [(type-sig:shen-function-type-sig) 84 | (define declare-functor 85 | (with-syntax ([(type-sig-type ... result-type) #'(type-sig.type ...)]) 86 | #`(#%prolog-functor declare #,fn-name 87 | #,(if (stx-null? #'(type-sig-type ...)) 88 | #'(#%prolog-functor --> result-type) 89 | (foldr (lambda (type acc) 90 | #`(#%prolog-functor --> #,type #,acc)) 91 | #'result-type 92 | (syntax->list #'(type-sig-type ...))))))) 93 | 94 | (values 95 | (let-values ([(string-port write-prolog-goals received-vars-vec) (prolog-syntax-writers #t #f)]) 96 | ;; assert the function declares 97 | (write-prolog-goals #`((retractall (#%prolog-functor : inference_rules #,declare-functor)) 98 | (assertz (#%prolog-functor : inference_rules #,declare-functor))) 99 | #t) 100 | (get-output-string string-port)) 101 | 102 | (let-values ([(string-port write-prolog-goals received-vars-vec) (prolog-syntax-writers #t #f)]) 103 | ;; retract the function declares if type checking fails 104 | (define-values (string-port write-prolog-goals received-vars-vec) 105 | (prolog-syntax-writers #t #f)) 106 | 107 | (write-prolog-goals #`((retractall (#%prolog-functor : inference_rules #,declare-functor))) #t) 108 | (get-output-string string-port)))])) 109 | 110 | (define shen-prolog-queries 111 | (syntax-parse type-sig 112 | [(type-sig:shen-function-type-sig) 113 | (with-syntax* ([(pat-type ... clause-type) #'(type-sig.type ...)] 114 | [(((pat-form ...) ...) 115 | (clause-body ...) 116 | (clause-guard ...) 117 | ((clause-string ...) ...)) 118 | (syntax-parse clauses 119 | [((clause:function-clause-definition) ...+) 120 | #'(((clause.shen-prolog-pat ...) ...) 121 | (clause.shen-prolog-body ...) 122 | (clause.shen-prolog-guard ...) 123 | ((clause.shen-string ...) ...))])] 124 | [(pattern-hyp ...) (stx-map 125 | (curry pattern-hyps #'(pat-type ...)) 126 | #'((clause-string ...) ...) 127 | #'((pat-form ...) ...) 128 | #'(clause-guard ...))]) 129 | #'(((: type_checker (#%prolog-functor start_proof 130 | pattern-hyp 131 | (#%prolog-functor type_check clause-body clause-type) 132 | _))) 133 | ...))])) 134 | 135 | (values (for/list ([query-syntax (in-syntax shen-prolog-queries)]) 136 | (define-values (string-port write-prolog-goals received-vars-vec) 137 | (prolog-syntax-writers #t #f)) 138 | (write-prolog-goals query-syntax #t) 139 | (get-output-string string-port)) 140 | assert-declare-string 141 | retract-declare-string))) 142 | -------------------------------------------------------------------------------- /lang/types-syntax.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require syntax/parse 4 | syntax/stx 5 | "syntax-utils.rkt") 6 | 7 | (provide shen-type-sequent) 8 | 9 | (define-syntax-class shen-single-line-bar 10 | (pattern :id 11 | #:fail-unless (regexp-match #rx"^_+$" 12 | (symbol->string (syntax-e this-syntax))) 13 | #f)) 14 | 15 | (define-syntax-class shen-multi-line-bar 16 | (pattern :id 17 | #:fail-unless (regexp-match #rx"^=+$" 18 | (symbol->string (syntax-e this-syntax))) 19 | #f)) 20 | 21 | (define-splicing-syntax-class shen-type-declaration 22 | #:attributes (term type) 23 | (pattern (~seq num (~literal :) (~literal number)) 24 | #:with term (syntax->shen-prolog-term #'num #t #t) 25 | #:with type #'number) 26 | (pattern (~seq str (~literal :) (~literal string)) 27 | #:with term (syntax->shen-prolog-term #'str #t #t) 28 | #:with type #'string) 29 | (pattern (~seq sym (~literal :) (~literal symbol)) 30 | #:with term (syntax->shen-prolog-term #'sym #t #t) 31 | #:with type #'symbol) 32 | (pattern (~seq datum-term (~literal :) type-term) 33 | #:with term (syntax->shen-prolog-term #'datum-term #t #t) 34 | #:with type (syntax->shen-prolog-term #'type-term #f))) 35 | 36 | (define-splicing-syntax-class shen-type-equation 37 | #:attributes (first-arg second-arg) 38 | (pattern (~seq first-arg-term (~literal ~) second-arg-term) 39 | #:with first-arg (syntax->shen-prolog-term #'first-arg-term #f #t) 40 | #:with second-arg (syntax->shen-prolog-term #'second-arg-term #f #t))) 41 | 42 | (define-splicing-syntax-class shen-sequent-assertion 43 | #:attributes (assumption head-args shen-prolog-term) 44 | (pattern (~seq type-decl:shen-type-declaration) 45 | #:with assumption #'(#%prolog-functor type_check type-decl.term type-decl.type) 46 | #:with head-args #'(type-decl.term type-decl.type) 47 | #:with shen-prolog-term #'(#%prolog-functor type_check type-decl.term type-decl.type)) 48 | (pattern (~seq type-equation:shen-type-equation) 49 | #:with assumption #'(#%prolog-functor type_eq type-equation.first-arg type-equation.second-arg) 50 | #:with head-args #'(type-equation.first-arg type-equation.second-arg) 51 | #:with shen-prolog-term #'(#%prolog-functor g (#%prolog-functor type_eq 52 | type-equation.first-arg 53 | type-equation.second-arg))) 54 | (pattern goal 55 | #:with goal-term (syntax->shen-prolog-term #'goal #f #t) 56 | #:with assumption #'(#%prolog-functor : user goal-term) 57 | #:with head-args #'goal-term 58 | #:with shen-prolog-term #'(#%prolog-functor g (#%prolog-functor : user goal-term)))) 59 | 60 | (define-splicing-syntax-class shen-sequent-assertion-list 61 | #:attributes ((assumption 1) (shen-prolog-term 1)) 62 | (pattern (~seq first:shen-sequent-assertion 63 | (~seq (~literal |,|) rest:shen-sequent-assertion) 64 | ...) 65 | #:with (assumption ...) #'(first.assumption rest.assumption ...) 66 | #:with (shen-prolog-term ...) #'(first.shen-prolog-term rest.shen-prolog-term ...))) 67 | 68 | (define-splicing-syntax-class shen-sequent-condition 69 | #:attributes (implicative shen-prolog-terms) 70 | (pattern (~seq (~datum if) condition-term) 71 | #:cut 72 | #:with condition (syntax->shen-prolog-term #'condition-term #f #t) 73 | #:with implicative #'() 74 | #:with shen-prolog-terms #'((#%prolog-functor g (#%prolog-functor shen_if_condition 75 | condition)))) 76 | (pattern (~seq (~datum let) id:shen-var-id datum:expr) 77 | #:cut 78 | #:with implicative #'() 79 | #:with shen-prolog-terms #'((is! id datum))) 80 | (pattern (~seq assertions:shen-sequent-assertion-list (~literal |;|)) 81 | #:with implicative #'(assertions.assumption ...) 82 | #:with shen-prolog-terms #'(assertions.shen-prolog-term ...)) 83 | (pattern (~seq implies:shen-sequent-implicative (~literal |;|)) 84 | #:with implicative #'(implies.head-arg ...) 85 | #:with shen-prolog-terms #'(implies.shen-prolog-term))) 86 | 87 | (define-splicing-syntax-class shen-sequent-implicative 88 | #:attributes (conq (head-arg 1) shen-prolog-term) 89 | (pattern (~seq assertions:shen-sequent-assertion-list (~literal >>) ps:shen-sequent-assertion-list) 90 | #:with conq (if (stx-null? (stx-cdr #'(ps.assumption ...))) 91 | (stx-car #'(ps.assumption ...)) 92 | (shen-cons-syntax #'(ps.assumption ...))) 93 | #:with (head-arg ...) #'(assertions.assumption ...) 94 | #:with shen-prolog-term #`(>> #,(shen-cons-syntax #'(assertions.assumption ...)) 95 | conq))) 96 | 97 | ;; The consequent is the head of a type sequent being generated. 98 | (define-splicing-syntax-class shen-sequent-consequent 99 | #:attributes (assumptions predicate-name shen-prolog-term) 100 | (pattern (~seq assertion:shen-sequent-assertion) 101 | #:with assumptions #'assertion.head-args 102 | #:with predicate-name #'type_check 103 | #:with shen-prolog-term #'assertion.shen-prolog-term) 104 | (pattern (~seq implies:shen-sequent-implicative) 105 | #:with assumptions #`(#,(shen-cons-syntax #'(implies.head-arg ...)) implies.conq) 106 | #:with predicate-name #'>> 107 | #:with shen-prolog-term #'implies.shen-prolog-term)) 108 | 109 | (define-splicing-syntax-class shen-type-sequent 110 | #:attributes ((prolog-form 1)) 111 | (pattern (~seq cond:shen-sequent-condition ... 112 | :shen-single-line-bar 113 | conq:shen-sequent-consequent 114 | (~literal |;|)) 115 | #:with (prolog-form ...) #'((defprolog conq.predicate-name 116 | (~@ . conq.assumptions) <-- 117 | (~@ . cond.shen-prolog-terms) ... |;|))) 118 | (pattern (~seq cond:shen-sequent-condition ... 119 | :shen-multi-line-bar 120 | conq:shen-sequent-assertion 121 | (~literal |;|)) 122 | #:with conq-list (shen-cons-syntax #'(conq.assumption)) 123 | #:with impl-list (shen-cons-syntax #'((~@ . cond.implicative) ...)) 124 | #:with (prolog-form ...) #'((defprolog type_check 125 | (~@ . conq.head-args) <-- (~@ . cond.shen-prolog-terms) ... |;|) 126 | (defprolog >> 127 | conq-list P <-- (>> impl-list P) |;|)))) 128 | -------------------------------------------------------------------------------- /repl.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (compile-allow-set!-undefined #t) 4 | (compile-enforce-module-constants #f) 5 | 6 | (require racket/runtime-path) 7 | 8 | (require (only-in racket/exn 9 | exn->string) 10 | shen/lang/interposition-points 11 | shen/lang/load 12 | shen/lang/macros 13 | shen/lang/namespaces 14 | shen/lang/namespace-requires 15 | shen/lang/printer 16 | shen/lang/prolog-debug-gui 17 | (only-in shen/lang/reader 18 | detect-prolog-syntax 19 | shen-readtable) 20 | (only-in shen/lang/syntax-utils 21 | syntax->shen-prolog-term) 22 | (only-in shen/lang/system-functions 23 | [eval shen:eval]) 24 | shen/lang/type-syntax-expanders 25 | syntax/parse 26 | syntax/stx) 27 | 28 | (define (shen-repl) 29 | (define prompt-num 0) 30 | (open-prolog-debug-gui) 31 | 32 | (parameterize ([current-readtable shen-readtable]) 33 | (let loop () 34 | (with-handlers ([shen-type-check-exn? (lambda (_) (printf "type error"))] 35 | [exn:break? (lambda (e) 36 | (write-char #\newline) 37 | (exit))] 38 | [exn? (lambda (e) 39 | (printf "error: ~a~n" (exn->string e)))]) 40 | (printf "(~a~a) " prompt-num (if (type-check?) '+ '-)) 41 | (set! prompt-num (add1 prompt-num)) 42 | (load-shen-form (detect-prolog-syntax 43 | (expand-shen-form 44 | (read-syntax))))) 45 | (printf "~n~n") 46 | (loop)))) 47 | 48 | (shen-repl) 49 | -------------------------------------------------------------------------------- /screenshots/apply_failure_1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mthom/scryer-shen/ab98bc1b8dcfa49137d39df8be48c9a9b95f3a14/screenshots/apply_failure_1.png -------------------------------------------------------------------------------- /screenshots/debug_window.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mthom/scryer-shen/ab98bc1b8dcfa49137d39df8be48c9a9b95f3a14/screenshots/debug_window.png -------------------------------------------------------------------------------- /scryer-server/scryer-prolog-server.pl: -------------------------------------------------------------------------------- 1 | :- module('$scryer-prolog-server', [shen_prolog_eval/2]). 2 | 3 | :- use_module('scryer-shen-ipc'). 4 | 5 | :- meta_predicate shen_prolog_eval(0, ?). 6 | 7 | shen_prolog_eval(Query, VNs) :- 8 | catch(continue(Query, VNs), 9 | E, 10 | ( write_error(E), 11 | false 12 | )). 13 | -------------------------------------------------------------------------------- /scryer-server/scryer-shen-ipc.pl: -------------------------------------------------------------------------------- 1 | :- module(ipc, [bind/2, 2 | continue/2, 3 | if_bind/2, 4 | return_to_shen/1, 5 | type_check_return_to_shen/1, 6 | write_error/1]). 7 | 8 | :- use_module(library(between)). 9 | :- use_module(library(charsio)). 10 | :- use_module(library(iso_ext)). 11 | :- use_module(library(lambda)). 12 | :- use_module(library(lists)). 13 | 14 | :- meta_predicate continue(0, ?). 15 | 16 | continue(Query, VNs) :- 17 | bb_put('#%variable_names', VNs), 18 | ( catch(Query, '#%return_success'(P), return_handler(P)) -> 19 | ( var(P) -> 20 | write([true, false]), 21 | nl 22 | ; true 23 | ) 24 | ; write([false, false]), 25 | nl 26 | ). 27 | 28 | return_handler(Printer) :- 29 | callable(Printer), 30 | call(Printer). 31 | 32 | bind(F, X) :- 33 | bb_get('#%variable_names', VNs), 34 | executable_functor_shen_expr(F, SF), 35 | write_canonical_term_wq([SF, true], VNs), % write to scryer-shen 36 | % which is listening to 37 | % stdout ... 38 | nl, 39 | read(X). % .. and block until the result is read back from 40 | % scryer-shen. 41 | 42 | if_bind(F, X) :- 43 | bb_get('#%variable_names', VNs), 44 | executable_functor_shen_expr(F, SF), 45 | write_canonical_term_wq([if_bind, SF, true], VNs), 46 | nl, 47 | read(X). 48 | 49 | return_to_shen(T) :- 50 | bb_get('#%variable_names', VNs0), 51 | variable_labels(T, VNs0, VNs), 52 | data_functor_shen_expr(T, TF), 53 | throw('#%return_success'((ipc:write_canonical_term_wq([TF, false], VNs), nl))). 54 | 55 | type_check_return_to_shen(T) :- 56 | bb_get('#%variable_names', VNs0), 57 | variable_labels(T, VNs0, VNs), 58 | executable_functor_shen_expr(T, TF), 59 | throw('#%return_success'((ipc:write_canonical_term_wq([[type_functor, TF]], VNs), nl))). 60 | 61 | write_canonical_term_wq(Term, VNs) :- 62 | write_term(Term, [ignore_ops(true), variable_names(VNs), 63 | quoted(true), double_quotes(true)]). 64 | 65 | write_error(Error) :- 66 | write_canonical_term_wq(Error, []), 67 | nl. 68 | 69 | eq_list_match(L, [L=V1|_], V1). 70 | eq_list_match(L, [_|VNs], V) :- 71 | eq_list_match(L, VNs, V). 72 | 73 | label_matches(_, [], [], _). 74 | label_matches(VNs0, [L=V1|VNs1], Matches, N) :- 75 | N1 is N+1, 76 | ( eq_list_match(L, VNs0, V0), 77 | V0 \== V1 -> 78 | Matches = [N|Matches0], 79 | label_matches(VNs0, VNs1, Matches0, N1) 80 | ; label_matches(VNs0, VNs1, Matches, N1) 81 | ). 82 | 83 | provisional_variable_labels([], _, _, []). 84 | provisional_variable_labels([V|Vs], NumVars0, Min, VNs) :- 85 | NumVars is NumVars0 + Min - 1, 86 | numlist(Min, NumVars, VarLabels), 87 | maplist(\V^N^VarForm^( 88 | write_term_to_chars('$VAR'(N), [numbervars(true)], VCs), 89 | atom_chars(VA, VCs), 90 | VarForm = (VA = V) 91 | ), 92 | [V|Vs], 93 | VarLabels, 94 | VNs 95 | ). 96 | 97 | matching_variable_labels_loop(TermVars, NumVars0, Min, VNs0, VNs) :- 98 | provisional_variable_labels(TermVars, NumVars0, Min, VNs1), 99 | label_matches(VNs0, VNs1, Matches, Min), 100 | ( Matches == [] -> 101 | append(VNs0, VNs1, VNs) 102 | ; list_max(Matches, Max), 103 | % Max1 is Max + 1, 104 | matching_variable_labels_loop(TermVars, NumVars0, Max, VNs0, VNs) 105 | ). 106 | 107 | variable_labels(Term, VNs0, VNs) :- 108 | term_variables(Term, TermVars), 109 | length(TermVars, NumVars0), 110 | matching_variable_labels_loop(TermVars, NumVars0, 0, VNs0, VNs). 111 | 112 | data_functor_shen_expr(T, T) :- 113 | ( atomic(T) 114 | ; var(T) 115 | ), 116 | !. 117 | data_functor_shen_expr([T|Ts], '.'('.', U, Us)) :- 118 | data_functor_shen_expr(T, U), 119 | data_functor_shen_expr(Ts, Us), 120 | !. 121 | data_functor_shen_expr(T, '.'('.', F, Vs)) :- 122 | T =.. [F | Ts], 123 | data_functor_shen_expr(Ts, Vs). 124 | 125 | list_dot_functor([], []). 126 | list_dot_functor([T|Ts], '.'(T, Us)) :- 127 | list_dot_functor(Ts, Us). 128 | 129 | executable_functor_shen_expr(T, T) :- 130 | ( atomic(T) 131 | ; var(T) 132 | ), 133 | !. 134 | executable_functor_shen_expr([T|Ts], '.'('.', U, Us)) :- 135 | executable_functor_shen_expr(T, U), 136 | executable_functor_shen_expr(Ts, Us), 137 | !. 138 | executable_functor_shen_expr(T, '.'(F, Vs)) :- 139 | T =.. [F | Ts], 140 | maplist(executable_functor_shen_expr, Ts, Us), 141 | list_dot_functor(Us, Vs). 142 | -------------------------------------------------------------------------------- /scryer-server/scryer-shen-toplevel.pl: -------------------------------------------------------------------------------- 1 | :- module('$scryer-shen-toplevel', []). 2 | 3 | :- use_module(library(charsio)). 4 | :- use_module(library(cont)). 5 | :- use_module(library(error)). 6 | :- use_module(library(iso_ext)). 7 | :- use_module(library(lists)). 8 | 9 | :- use_module('scryer-prolog-server'). 10 | :- use_module('type-checker/type-checker'). 11 | 12 | repl :- 13 | catch(read_and_match, E, print_exception(E)), 14 | false. 15 | repl :- 16 | repl. 17 | 18 | read_and_match :- 19 | '$read_query_term'(_, Term, _, _, VarList), 20 | instruction_match(Term, VarList). 21 | 22 | instruction_match(Term, VarList) :- 23 | ( var(Term) -> 24 | throw(error(instantiation_error, repl/0)) 25 | ; Term = [Item] -> 26 | ( atom(Item) -> 27 | ( Item == user -> 28 | catch(load(user_input), E, print_exception_with_check(E)) 29 | ; 30 | consult(Item) 31 | ) 32 | ; catch(type_error(atom, Item, repl/0), 33 | E, 34 | print_exception_with_check(E)) 35 | ) 36 | ; Term = end_of_file -> 37 | halt 38 | ; Term = shen_prolog_eval(Query) -> 39 | expand_goal(Query, user, Query0), 40 | shen_prolog_eval(user:Query0, VarList) 41 | ). 42 | 43 | print_exception(E) :- 44 | ( E == error('$interrupt_thrown', repl) -> nl 45 | ; true 46 | ), 47 | loader:write_error(E), 48 | nl. 49 | 50 | print_exception_with_check(E) :- 51 | ( E = error(_, _:_) -> true 52 | ; print_exception(E) 53 | ). 54 | -------------------------------------------------------------------------------- /scryer-server/type-checker/inference_rules.pl: -------------------------------------------------------------------------------- 1 | :- module(inference_rules, [type_check//2, 2 | provable//1, 3 | declare/2]). 4 | 5 | :- use_module(term_variables). 6 | 7 | :- discontiguous(type_check/4). 8 | :- multifile(type_check/4). 9 | 10 | type_check(X, T) --> 11 | { of_type(X, T) }. 12 | type_check([X|Xs], list(A)) --> 13 | [g(type_check(X, A)), 14 | g(type_check(Xs, list(A)))]. 15 | type_check([], list(_A)) --> 16 | []. 17 | type_check(true, boolean) --> 18 | []. 19 | type_check(false, boolean) --> 20 | []. 21 | type_check('@p'(X,Y), A * B) --> 22 | [g(type_check(X, A)), 23 | g(type_check(Y, B))]. 24 | type_check('@s'(X,Y), string) --> 25 | [g(type_check(X, string)), 26 | g(type_check(Y, string))]. 27 | type_check('@v'(X, Y), vector(A)) --> 28 | [g(type_check(X, A)), 29 | g(type_check(Y, vector(A)))]. 30 | type_check(<>, vector(_A)) --> 31 | []. 32 | type_check(/.(Var, Body), (A --> B)) --> 33 | [h(exists(A)), 34 | h(type_check(Var, A)), 35 | g(type_check(Body, B))]. 36 | type_check(let(Var, Binding, Body), A) --> 37 | [g(type_check(Binding, B)), 38 | h(type_check(Var, B)), 39 | g(type_check(Body, A))]. 40 | type_check(if(Condition, TrueBranch, FalseBranch), A) --> 41 | [g(type_check(Condition, boolean)), 42 | g(type_check(TrueBranch, A)), 43 | g(type_check(FalseBranch, A))]. 44 | type_check('#%apply'(F, X), B) --> 45 | [g(type_check(F, (A --> B))), 46 | g(type_check(X, A))]. 47 | type_check('#%apply'(F), R) --> 48 | [g(type_check(F, -->(R)))]. 49 | type_check(fn(F), A) --> 50 | [g(declare(F, A))]. 51 | type_check(freeze(E), lazy(A)) --> 52 | [g(type_check(E, A))]. 53 | type_check(thaw(E), A) --> 54 | [g(type_check(E, lazy(A)))]. 55 | type_check(X, number) --> 56 | { value_type(X, number) }. 57 | type_check(X, symbol) --> 58 | { value_type(X, symbol) }. 59 | type_check(F, FnT) --> 60 | { nonvar(F), 61 | value_type(F, symbol) }, 62 | [g(declare(F, FnT))]. 63 | 64 | :- discontiguous(provable/3). 65 | :- multifile(provable/3). 66 | 67 | provable(type_check([X|Xs], list(A))) --> 68 | [h(type_check(X, A)), 69 | h(type_check(Xs, list(A)))]. 70 | provable(type_check('@p'(X, Y), A * B)) --> 71 | [h(type_check(X, A)), 72 | h(type_check(Y, B))]. 73 | provable(type_check('@s'(X, Y), string)) --> 74 | [h(type_check(X, string)), 75 | h(type_check(Y, string))]. 76 | provable(type_check('@v'(X, Y), vector(A))) --> 77 | [h(type_check(X, A)), 78 | h(type_check(Y, vector(A)))]. 79 | 80 | 81 | :- dynamic(declare/2). 82 | 83 | declare(load, (string --> symbol)). 84 | declare(tc, (symbol --> boolean)). 85 | declare(+, (number --> (number --> number))). 86 | declare(-, (number --> (number --> number))). 87 | declare(*, (number --> (number --> number))). 88 | declare(/, (number --> (number --> number))). 89 | declare(=, (A --> (A --> boolean))). 90 | declare(==, (A --> (A --> boolean))). 91 | declare(>, (number --> (number --> boolean))). 92 | declare(<, (number --> (number --> boolean))). 93 | declare(>=, (number --> (number --> boolean))). 94 | declare(<=, (number --> (number --> boolean))). 95 | declare(head, (list(A) --> A)). 96 | declare(tail, (list(A) --> list(A))). 97 | declare(explode, (_A --> list(string))). 98 | declare(cd, (string --> string)). 99 | declare(arity, (_A --> number)). 100 | declare('absvector?', (_A --> boolean)). 101 | declare('bound?', (symbol --> boolean)). 102 | declare(cons, (A --> (list(A) --> list(A)))). 103 | declare(adjoin, (A --> (list(A) --> list(A)))). 104 | declare(append, (list(A) --> (list(A) --> list(A)))). 105 | declare(difference, (list(A) --> (list(A) --> list(A)))). 106 | declare('element?', (A --> (list(A) --> boolean))). 107 | declare(map, ((A --> B) --> (list(A) --> list(B)))). 108 | declare(cn, (string --> (string --> string))). 109 | declare('cons?', (_A --> boolean)). 110 | declare('empty?', (_A --> boolean)). 111 | declare('error-to-string', (exception --> string)). 112 | declare(external, (symbol --> list(symbol))). 113 | declare(internal, (symbol --> list(symbol))). 114 | declare(limit, (vector(_A) --> number)). 115 | declare('symbol?', (_A --> boolean)). 116 | declare('atom?', (_A --> boolean)). 117 | declare('integer?', (_A --> boolean)). 118 | declare(systemf, (symbol --> symbol)). 119 | declare(freeze, (A --> lazy(A))). 120 | declare(thaw, (lazy(A) --> A)). 121 | declare(undefmacro, (symbol --> symbol)). 122 | declare(vector, (number --> vector(_A))). 123 | declare('<-vector', (vector(A) --> (number --> A))). 124 | declare('vector->', (vector(A) --> (number --> (A --> vector(A))))). 125 | declare(and, (boolean --> (boolean --> boolean))). 126 | declare(or, (boolean --> (boolean --> boolean))). 127 | declare(fail, -->(symbol)). 128 | declare(fix, ((A --> A) --> (A --> A))). 129 | declare(fst, ((A * _B) --> A)). 130 | declare(snd, ((_A * B) --> B)). 131 | declare(gensym, (symbol --> symbol)). 132 | declare(hdstr, (string --> string)). 133 | declare(intern, (string --> symbol)). 134 | declare(not, (boolean --> boolean)). 135 | -------------------------------------------------------------------------------- /scryer-server/type-checker/rule_expanders.pl: -------------------------------------------------------------------------------- 1 | :- module(rule_expanders, []). 2 | 3 | :- use_module(library(dcgs)). 4 | :- use_module(library(lists)). 5 | 6 | :- use_module(type_variables). 7 | 8 | list_comma_goals([], EndTerm, EndTerm). 9 | list_comma_goals([G|Gs], EndTerm, (G, EGs)) :- 10 | list_comma_goals(Gs, EndTerm, EGs). 11 | 12 | type_check_goals(type_check(X, T)) --> 13 | [[g(type_check(X, T))]]. 14 | 15 | provability_goals(type_check(X, T)) --> 16 | [[h(type_check(X, T))]]. 17 | provability_goals(G) --> 18 | [[g(G)]]. 19 | 20 | :- meta_predicate expand_shen_goals(?, 3, ?, ?). 21 | 22 | expand_shen_goals((G1, G2), GoalRenderer) --> 23 | expand_shen_goals(G1, GoalRenderer), 24 | expand_shen_goals(G2, GoalRenderer). 25 | expand_shen_goals(type_check(X, A), GoalRenderer) --> 26 | phrase(GoalRenderer, type_check(X, A)). 27 | expand_shen_goals(>>(Gs, P), _GoalRenderer) --> 28 | foldl(provability_goals, Gs), 29 | premises_proof_end_terms([], P). 30 | expand_shen_goals(g(G), _GoalRenderer) --> 31 | [[g(G)]]. 32 | 33 | premises_proof_end_terms([P|Ps], Conclusion) --> 34 | [g(provable([P|Ps]))], 35 | premises_proof_end_terms([], Conclusion). 36 | premises_proof_end_terms([], Conclusion) --> 37 | ( { var(Conclusion) } -> 38 | [] 39 | ; [[h(provable(Conclusion))]] 40 | ). 41 | 42 | user:term_expansion((>>([type_check(X, A)|Ps], P) :- Goals), (inference_rules:provable(type_check(X, A)) --> ExpandedGoals)) :- 43 | type(A), 44 | phrase(expand_shen_goals(Goals, provability_goals), ListOfExpandedGoals), 45 | phrase(premises_proof_end_terms(Ps, P), EndTerms), 46 | list_comma_goals(ListOfExpandedGoals, EndTerms, ExpandedGoals). 47 | user:term_expansion(>>([type_check(X, A)|Ps], P), (inference_rules:provable(type_check(X, A)) --> ExpandedGoals)) :- 48 | type(A), 49 | phrase(premises_proof_end_terms(Ps, P), ListOfExpandedGoals), 50 | list_comma_goals(ListOfExpandedGoals, [], ExpandedGoals). 51 | user:term_expansion((type_check(X, A) :- Goals), (inference_rules:type_check(X, A) --> ExpandedGoals)) :- 52 | type(A), 53 | phrase(expand_shen_goals(Goals, type_check_goals), ListOfExpandedGoals), 54 | list_comma_goals(ListOfExpandedGoals, [], ExpandedGoals). 55 | user:term_expansion(type_check(X, T), (inference_rules:type_check(X, T) --> [])). 56 | -------------------------------------------------------------------------------- /scryer-server/type-checker/term_variables.pl: -------------------------------------------------------------------------------- 1 | :- module(term_variables, [of_type/2, 2 | op(1200, fx, -->), 3 | term/1, 4 | value_type/2]). 5 | 6 | :- use_module(library(atts)). 7 | :- use_module(library(dcgs)). 8 | :- use_module(library(iso_ext)). 9 | :- use_module(library(lambda)). 10 | :- use_module(library(lists)). 11 | 12 | :- attribute term_var/0, of_types/1. 13 | 14 | verify_attributes(Var, Other, []) :- 15 | ( var(Other) -> 16 | ( get_atts(Other, term_var) -> 17 | ( get_atts(Var, term_var) -> 18 | Var == Other 19 | ; true 20 | ) 21 | ; true 22 | ) 23 | ; false 24 | ). 25 | 26 | of_type(X, T) :- 27 | var(X), 28 | get_atts(X, of_types(Types)), 29 | member(T, Types). 30 | 31 | value_type(X, T) :- 32 | ( var(X) -> 33 | ( get_atts(X, of_types(Types)) -> 34 | ( member(T, Types) -> 35 | true 36 | ; put_atts(X, of_types([T|Types])) 37 | ) 38 | ; put_atts(X, of_types([T])) 39 | ) 40 | ; T = symbol, 41 | atom(X) -> 42 | true 43 | ; T = number, 44 | number(X) -> 45 | true 46 | ; T = string, 47 | partial_string(X), 48 | partial_string_tail(X, []) -> 49 | true 50 | ). 51 | 52 | term(Term) :- 53 | term_variables(Term, TVs), 54 | maplist(\X^put_atts(X, term_var), TVs). 55 | -------------------------------------------------------------------------------- /scryer-server/type-checker/type-checker.pl: -------------------------------------------------------------------------------- 1 | :- module(type_checker, [op(599, fx, ?), 2 | set_maximum_allowed_inferences/2, 3 | start_proof/3]). 4 | 5 | :- use_module(library(dcgs)). 6 | :- use_module(library(dif)). 7 | :- use_module(library(iso_ext), [call_with_inference_limit/3]). 8 | :- use_module(library(lambda)). 9 | :- use_module(library(lists)). 10 | 11 | :- use_module('../scryer-shen-ipc'). 12 | 13 | :- use_module(inference_rules). 14 | :- use_module(rule_expanders). 15 | :- use_module(term_variables). 16 | :- use_module(type_variables). 17 | 18 | :- set_prolog_flag(occurs_check, true). 19 | 20 | :- dynamic(inf_limit_exceeded/0). 21 | 22 | :- dynamic(maximum_allowed_inferences/1). 23 | 24 | :- meta_predicate depth_iterated_proof(2, ?, ?, ?). 25 | 26 | assert_inf_limit_exceeded :- 27 | ( inf_limit_exceeded -> 28 | true 29 | ; assertz(inf_limit_exceeded) 30 | ). 31 | 32 | set_maximum_allowed_inferences(OldInf, NewInf) :- 33 | integer(NewInf), 34 | NewInf > 0, 35 | retract(maximum_allowed_inferences(OldInf)), 36 | assertz(maximum_allowed_inferences(NewInf)). 37 | 38 | maximum_allowed_inferences(65536). % default maximum inferences is 2^16 39 | 40 | attribute_hyp(type_check(X, T)) :- 41 | term(X), 42 | type(T). 43 | attribute_hyp(dif(T, U)) :- 44 | dif(T, U). 45 | 46 | start_proof(Hyps, type_check(X, T), ProofTree) :- 47 | retractall(inf_limit_exceeded), 48 | maplist(attribute_hyp, Hyps), 49 | term(X), 50 | Goal = (Hyps, X, T)+\Infs^ProofTree^prove(Infs, Hyps, g(type_check(X, T)), ProofTree), 51 | call_with_inference_limit( 52 | depth_iterated_proof(Goal, ProofTree, Status, 32), 53 | 50_000, 54 | R 55 | ), 56 | ( R == inference_limit_exceeded -> 57 | throw(type_check_error(inference_limit_exceeded)) 58 | ; Status = false, 59 | !, 60 | false 61 | ; Status = true -> 62 | true 63 | ; throw(type_check_error(Status)) 64 | ). 65 | 66 | depth_iterated_proof(Goal, ProofTree, Status, Inferences) :- 67 | length(InfList, Inferences), 68 | ( call(Goal, InfList, ProofTree), 69 | Status = true 70 | ; retract(inf_limit_exceeded), 71 | NextInferences is 2 * Inferences, 72 | ( maximum_allowed_inferences(MaxInferences), 73 | NextInferences >= MaxInferences, 74 | Status = depth_inference_limit_exceeded 75 | ; depth_iterated_proof(Goal, ProofTree, Status, NextInferences) 76 | ) 77 | ; Status = false % if the proof failed within the inference 78 | % limit, we cannot prove the Goal so it's no 79 | % help increasing the inference limit: fail 80 | % immediately 81 | ). 82 | 83 | 84 | shen_if_condition(G) :- 85 | if_bind(G, F), 86 | F \== false. 87 | 88 | precedent_check(Hyps, Goal, assumed(g(Goal))) :- 89 | member(Goal, Hyps). 90 | 91 | prove_type_check(g(type_check(X, T)), Hyps, Hyps, X, T) --> 92 | { term(X) }, 93 | inference_rules:type_check(X, T). 94 | prove_type_check(discharged(Hyp), PrevHyps, SuccHyps, X, T) --> 95 | { select(Hyp, PrevHyps, SuccHyps) }, 96 | inference_rules:provable(Hyp), 97 | [g(type_check(X, T))]. 98 | 99 | affirm_hypothesis(type_check(X, T)) :- 100 | attribute_hyp(type_check(X, T)), 101 | ( var(X) -> 102 | value_type(X, T) 103 | ; true 104 | ). 105 | affirm_hypothesis(provable([G|Gs])) :- 106 | maplist(affirm_hypothesis, [G|Gs]). 107 | affirm_hypothesis(provable(G)) :- 108 | callable(G), 109 | G \= [_|_], 110 | affirm_hypothesis(G). 111 | affirm_hypothesis(type_eq(T, U)) :- 112 | type_eq(T, U). 113 | affirm_hypothesis(exists(T)) :- 114 | exists(T). 115 | 116 | succ_hyps(Hyps, h(provable([H|Hs])), SuccHyps) :- 117 | append([H|Hs], Hyps, SuccHyps). 118 | succ_hyps(Hyps, h(provable(H)), [H|Hyps]). 119 | succ_hyps(Hyps, h(Goal), [Goal|Hyps]). 120 | succ_hyps(Hyps, g(_), Hyps). 121 | 122 | chain_proof([], _Hs, _Cs, _SubTs) :- 123 | assert_inf_limit_exceeded, 124 | false. 125 | chain_proof([t|_Is], _Hs, [], []). 126 | chain_proof([t|Is], Hs, [C|Cs], [SubT | RSubTs]) :- 127 | prove([t|Is], Hs, C, SubT), 128 | succ_hyps(Hs, C, NewHs), 129 | chain_proof(Is, NewHs, Cs, RSubTs). 130 | 131 | chained_proof_tree(discharged(Hyp), Goal, Subtrees, t(discharged(Hyp), Subtree)) :- 132 | Subtree =.. [t, Goal | Subtrees]. 133 | chained_proof_tree(_TreeHead, Goal, Subtrees, Tree) :- 134 | Tree =.. [t, Goal | Subtrees]. 135 | 136 | prove([], _Hyps, _Goal, _Tree) :- 137 | assert_inf_limit_exceeded, 138 | false. 139 | prove([t|Infs], Hyps, g(type_check(X, T)), Tree) :- 140 | ( precedent_check(Hyps, type_check(X, T), Tree) 141 | ; phrase(prove_type_check(TreeHead, Hyps, SuccHyps, X, T), Conditions), 142 | chain_proof(Infs, SuccHyps, Conditions, Subtrees), 143 | chained_proof_tree(TreeHead, g(type_check(X, T)), Subtrees, Tree) 144 | ). 145 | prove([t|Infs], Hyps, g(provable([Goal|Goals])), Tree) :- 146 | maplist((Infs, Hyps)+\G^ST^prove(Infs, Hyps, g(provable(G)), ST), 147 | [Goal|Goals], 148 | Subtrees), 149 | Tree =.. [t, g(provable([Goal|Goals])) | Subtrees]. 150 | prove([t|Infs], Hyps, g(provable(Goal)), Tree) :- 151 | callable(Goal), 152 | ( precedent_check(Hyps, provable(Goal), Tree) 153 | ; affirm_hypothesis(Goal), 154 | phrase(provable(Goal), Conditions), 155 | chain_proof(Infs, [Goal|Hyps], Conditions, Subtrees), 156 | chained_proof_tree(g(provable(Goal)), g(provable(Goal)), Subtrees, Tree) 157 | ). 158 | prove([t|_Infs], _Hyps, g(Goal), t(g(Goal))) :- 159 | callable(Goal), 160 | \+ functor(Goal, type_check, 2), 161 | \+ functor(Goal, provable, 1), 162 | call(Goal). 163 | prove([t|_Infs], _Hyps, h(Goal), assumed(g(Goal))) :- 164 | affirm_hypothesis(Goal). 165 | -------------------------------------------------------------------------------- /scryer-server/type-checker/type_variables.pl: -------------------------------------------------------------------------------- 1 | :- module(type_variables, [exists/1, type/1, type_eq/2]). 2 | 3 | :- use_module(library(atts)). 4 | :- use_module(library(lambda)). 5 | :- use_module(library(lists)). 6 | 7 | :- attribute type_equated/0, type_var/0. 8 | 9 | verify_attributes(Var, Other, []) :- 10 | ( get_atts(Var, type_equated) -> 11 | true 12 | ; var(Other), 13 | ( get_atts(Other, type_equated) -> 14 | true 15 | ; get_atts(Other, type_var) -> 16 | ( get_atts(Var, type_var), 17 | Var == Other 18 | ) 19 | ; true 20 | ) 21 | ). 22 | 23 | type(T) :- 24 | term_variables(T, TVs), 25 | maplist(\TV^put_atts(TV, type_var), TVs). 26 | 27 | type_eq(T, U) :- 28 | term_variables([T, U], TVs), 29 | maplist(\TV^put_atts(TV, [type_var, type_equated]), TVs), 30 | T = U, 31 | maplist(\TV^( var(TV) -> 32 | put_atts(TV, -type_equated) 33 | ; true 34 | ), 35 | TVs). 36 | 37 | exists(T) :- 38 | ( var(T) -> 39 | ( get_atts(T, type_var) -> 40 | true 41 | ; put_atts(T, type_equated) 42 | ) 43 | ; true 44 | ). 45 | -------------------------------------------------------------------------------- /shen-tests.shen: -------------------------------------------------------------------------------- 1 | #lang shen 2 | 3 | (define max 4 | X Y -> X where (> X Y) 5 | _ Y -> Y) 6 | 7 | (define test-2 8 | 4 4 5 <- (fail-if (= 2) 2) 9 | 4 4 X -> [success: X]) 10 | 11 | (define test-3 12 | X -> (let Y (+ 1 (log 2)) 13 | (+ Y X))) 14 | 15 | (define test-4 16 | 4 4 X <- (fail-if (= 2) X) 17 | 1 4 5 -> fail 18 | 4 4 X -> (* X X)) 19 | 20 | (define test-5 21 | X Y -> (X Y)) 22 | 23 | (define test-6 24 | X -> Y) 25 | 26 | (define second 27 | [_ Y | _] -> Y) 28 | 29 | (define identity 30 | X -> X) 31 | 32 | (defmacro max-macro 33 | [max X Y Z | W] -> [max X [max Y Z | W]]) 34 | 35 | (defmacro add1-macro 36 | [add1-ct X] -> (let Y [+ X 1] 37 | [identity Y])) 38 | 39 | (define my-head 40 | [X | Y] -> X 41 | [] -> (error "head: empty list")) 42 | 43 | (defmacro log-macro 44 | [log N] -> [+ N 1]) 45 | 46 | (package math [abs] 47 | (define abs 48 | X -> (- X) where (< X 0) 49 | X -> X)) 50 | 51 | (define foo 52 | X -> (prolog? (return (+ (receive X) (receive X))))) 53 | 54 | (define foo-2 55 | X -> (prolog? (f (receive X) (h (g (receive X) X) (g Y))))) 56 | 57 | -------------------------------------------------------------------------------- /tools/colorer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/match 4 | syntax-color/racket-lexer) 5 | 6 | (provide shen-colorer) 7 | 8 | (define (shen-colorer port) 9 | (match (peek-char port) 10 | [#\| 11 | (define-values (_line _col pos) (port-next-location port)) 12 | (read-char port) 13 | (values "|" 'symbol #f pos (add1 pos))] 14 | [_ 15 | (define-values (matching-text type paren-type start-loc end-loc) 16 | (racket-lexer port)) 17 | (match matching-text 18 | [(? eof-object?) (values matching-text 'eof #f #f #f)] 19 | [else 20 | (match-define (list cat paren) 21 | (match type 22 | ['error '(error #f)] 23 | ['comment '(comment #f)] 24 | ['sexp-comment '(comment #f)] 25 | ['white-space '(no-color #f)] 26 | ['constant '(constant #f)] 27 | ['string '(string #f)] 28 | ['no-color '(no-color #f)] 29 | ['parenthesis (list 'parenthesis paren-type)] 30 | ['hash-colon-keyword '(symbol #f)] 31 | ['symbol '(symbol #f)] 32 | ['eof '(eof #f)] 33 | ['other '(other #f)])) 34 | (values matching-text cat paren start-loc end-loc)])])) 35 | -------------------------------------------------------------------------------- /tools/submit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide repl-submit?) 4 | 5 | (require syntax/readerr) 6 | 7 | (define (repl-submit? ip has-white-space?) 8 | (define paren-stack-depth 0) 9 | (let loop ([in-comment? #f]) 10 | (define c (read-char ip)) 11 | (cond 12 | [(eof-object? c) (zero? paren-stack-depth)] 13 | [(eqv? c #\*) (if (and in-comment? (eqv? (peek-char ip) #\\)) 14 | (loop #f) 15 | (loop in-comment?))] 16 | [in-comment? (loop #t)] 17 | [(or (eqv? c #\() (eqv? c #\[)) 18 | (if in-comment? 19 | (loop #t) 20 | (begin 21 | (set! paren-stack-depth (add1 paren-stack-depth)) 22 | (loop #f)))] 23 | [(or (eqv? c #\)) (eqv? c #\])) 24 | (if in-comment? 25 | (loop #t) 26 | (begin 27 | (set! paren-stack-depth (sub1 paren-stack-depth)) 28 | (if (< paren-stack-depth 0) 29 | (let-values ([(line col pos) (port-next-location ip)]) 30 | (raise-read-error "expected an opening '('" #f line col pos 1)) 31 | (loop #f))))] 32 | [(eqv? c #\|) (loop #f)] 33 | [(eqv? c #\newline) (if (= paren-stack-depth 0) 34 | (loop #f) 35 | (loop #f))] 36 | [(char-whitespace? c) (loop #f)] 37 | [else (loop #f)]))) 38 | 39 | (module+ test 40 | (require rackunit) 41 | 42 | (define (test s) 43 | (repl-submit? (open-input-string s) #f)) 44 | ;; evaluate to true to force evaluation in the REPL. 45 | (check-true (test "symbol\n")) 46 | (check-true (test "symbol")) 47 | (check-false (test "[1 "))) 48 | --------------------------------------------------------------------------------