├── .vscode └── database.json ├── lang └── reader.rkt ├── lib ├── require-stuff.rkt ├── identity.rkt ├── infix-math.rkt ├── pipes.rkt ├── theory.rkt ├── math.rkt ├── monadology.rkt ├── hole.rkt ├── maybe.rkt ├── string.rkt ├── list.rkt └── things.rkt ├── .gitignore ├── examples ├── id-do.rkt ├── celebrate.rkt ├── hole-test.rkt ├── pipeland.rkt ├── fizzbuzz.rkt ├── list-do.rkt ├── 99bottles.rkt ├── fact.rkt ├── option-type.rkt ├── collatz.rkt ├── cards.rkt ├── do-action.rkt ├── cons-things.rkt └── brainfuck.rkt ├── tests ├── app.rkt ├── infix-math.rkt ├── Y.rkt └── things.rkt ├── info.rkt ├── private ├── io.rkt ├── random.rkt └── base.rkt ├── main.rkt ├── README.md ├── .travis.yml ├── LICENSE └── docs └── heresy.scrbl /.vscode/database.json: -------------------------------------------------------------------------------- 1 | {} -------------------------------------------------------------------------------- /lang/reader.rkt: -------------------------------------------------------------------------------- 1 | (module reader syntax/module-reader heresy) 2 | -------------------------------------------------------------------------------- /lib/require-stuff.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide only-in for-syntax) 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.bak 2 | compiled/ 3 | doc/ 4 | private/hello.txt 5 | *.lyx# 6 | *~ 7 | 8 | docs/*.html 9 | docs/*.js 10 | docs/*.css -------------------------------------------------------------------------------- /examples/id-do.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (id-do 4 | (x = 5) 5 | (y = 4) 6 | (z = (+ x y)) 7 | (print (format$ "#_ + #_ = #_" x y z))) -------------------------------------------------------------------------------- /examples/celebrate.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (def fn celebrate () 4 | (for (x in (range 0 to 9) with "!") 5 | (do 6 | (print (& "Heresy is 1 year old" cry)) 7 | (carry (& "!" cry))))) 8 | 9 | (celebrate) -------------------------------------------------------------------------------- /examples/hole-test.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (def foo (hole 1)) 4 | (hole? foo) 5 | (reset foo 2) 6 | (deref foo) 7 | (update foo + 5) 8 | (deref foo) 9 | (reset foo (thing (foo 1))) 10 | ((deref foo)) 11 | (reset-thing foo (foo 2)) 12 | ((deref foo)) -------------------------------------------------------------------------------- /examples/pipeland.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (:> '(1 2 3 4) 4 | (l> map (fn (x) (* x x))) 5 | (f> left 2) 6 | (l> append '(a b)) 7 | (f> append '(a b))) 8 | 9 | (-> '(1 2 3 4) 10 | (left 2) 11 | (append '(a b))) 12 | 13 | (->> '(1 2 3 4) 14 | (map (fn (x) (* x x))) 15 | (append '(a b))) 16 | -------------------------------------------------------------------------------- /examples/fizzbuzz.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (def fn fizzbuzz (n) 4 | (for (x in (range 1 to n)) 5 | (select 6 | ((zero? x) x) 7 | ((zero? (+ (mod x 5) 8 | (mod x 3))) (print "FizzBuzz")) 9 | ((zero? (mod x 5)) (print "Buzz")) 10 | ((zero? (mod x 3)) (print "Fizz")) 11 | (else (print x))))) 12 | -------------------------------------------------------------------------------- /tests/app.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (require rackunit) 4 | 5 | (test-case "#%app for procedure applications" 6 | (def fn f (x) (list x 5)) 7 | (check-equal? (f 8) '(8 5))) 8 | 9 | (test-case "#%app for index*" 10 | (def dave '(1 (2 3 (4 5)) 6)) 11 | (check-equal? (dave 2 3 1) 4) 12 | (def lst2 '(1 1 2 4 5 8 13 21 34 55 89 144)) 13 | (check-equal? (map lst2 '(7 8 9)) '(13 21 34))) 14 | 15 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define name "Heresy") 3 | (define collection "heresy") 4 | (define version "0.4") 5 | (define blurb 6 | "A BASIC-Flavored Lisp dialect") 7 | (define scribblings '(["docs/heresy.scrbl" (multi-page) (language)])) 8 | 9 | (define deps '("base" "unstable-lib" "rackjure")) 10 | (define build-deps '("racket-doc" 11 | "rackunit-lib" "sandbox-lib" "scribble-lib")) 12 | (define test-omit-paths '("examples")) 13 | -------------------------------------------------------------------------------- /examples/list-do.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (list-do 4 | (x <- (range 1 to 5)) 5 | (y <- (range 1 to 5)) 6 | (z = (* x y)) 7 | (if (even? z)) 8 | (yield z)) 9 | 10 | (list-do 11 | (rank <- (append (range 2 to 10) '(J Q K A))) 12 | (suit <- '(♠ ♣ ♥ ♦)) 13 | (if (equal? suit '♦)) 14 | (card = (format$ "#_#_" rank suit)) 15 | (yield card)) 16 | 17 | (list-do 18 | (x <- (range 1 to 5)) 19 | (y <- (range 1 to 5)) 20 | (z = (+ x y)) 21 | (yield (* z z))) -------------------------------------------------------------------------------- /examples/99bottles.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (def bot 99) 4 | 5 | (def fn bottles (n) 6 | (for (x in (range n to 1 step -1)) 7 | (? (format$ "#_ bottles of beer on the wall, #_ bottles of beer," x x)) 8 | (? "Take one down pass it around,") 9 | (if (zero? (dec x)) then 10 | (? "No more bottles of beer on the wall.") 11 | else 12 | (do 13 | (print & (dec x)) 14 | (? " bottles of beer on the wall."))))) 15 | 16 | (bottles bot) -------------------------------------------------------------------------------- /examples/fact.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | ; Classical recursive 4 | (def fn fact (n) 5 | (select 6 | ((zero? n) 1) 7 | (else (* n (fact (- n 1)))))) 8 | 9 | ; W/ Heresy's for w/carry 10 | (def fn fact-2 (n) 11 | (for (x in (range n to 1 step -1) with 1) 12 | (carry (* cry x)))) 13 | 14 | ; Folding over a range 15 | (def fn fact-3 (n) 16 | (foldl * 1 (range 1 to n))) 17 | 18 | ; Using the m-block 19 | (def fn fact-4 (n) 20 | (if (zero? n) then 1 else 21 | (m let next = n - 1 22 | let x = (fact-4 next) 23 | in x * n))) -------------------------------------------------------------------------------- /examples/option-type.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (def >>= maybe-bind) 4 | 5 | (def fn // (x y) 6 | (>>= x 7 | (fn (a) 8 | (>>= y 9 | (fn (b) 10 | (if (= b 0) then None else (some (/ a b)))))))) 11 | 12 | (def fn //- (x y) 13 | (maybe-do 14 | (a <- x) 15 | (b <- y) 16 | (yield (if (zero? b) then None else (/ a b))))) 17 | 18 | 19 | (-> (//- (some 4) (some 2)) 20 | (get-some)) 21 | 22 | (maybe-do 23 | (a <- (some 4)) 24 | (c = (* a 4)) 25 | (yield c)) 26 | 27 | (maybe-do 28 | (a <- (some 5)) 29 | (b <- (some 4)) 30 | (c = (+ a b)) 31 | (* a c)) -------------------------------------------------------------------------------- /examples/collatz.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (def fn collatz (n) 4 | (select 5 | ((one? n) '(1)) 6 | ((even? n) (join n (collatz (/ n 2)))) 7 | ((odd? n) (join n (collatz (+ (* 3 n) 1)))))) 8 | 9 | (def fn coll-count (n) 10 | (let recur ([x n] 11 | [c 0]) 12 | (select 13 | ((one? x) `(,n ,c)) 14 | ((even? x) 15 | (recur (/ x 2) (inc c))) 16 | (else (recur (+ (* 3 x) 1) (inc c)))))) 17 | 18 | (for (x in (range 2 to 999999) with '(1 1)) 19 | (let ([y (coll-count x)]) 20 | (if (> (head (tail y)) 21 | (head (tail cry))) 22 | then 23 | (carry y) 24 | else 25 | (carry cry)))) 26 | -------------------------------------------------------------------------------- /examples/cards.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (def cards 4 | (for (suit in '(♠ ♣ ♥ ♦)) 5 | (carry (append (for (x in (append (range 2 to 10) '(J Q K A))) 6 | (carry (join `(,x ,suit) cry))) 7 | cry)))) 8 | 9 | (def fn rand-card (cards) 10 | (let ((n (int (inc (* (len cards) (rnd)))))) 11 | (index n cards))) 12 | 13 | (def shuffled 14 | (for (x in (range 1 to (len cards)) with (thing (new '()) 15 | (old cards))) 16 | (def pick (rand-card (cry 'old))) 17 | (def old (filter (fn (x) (not (equal? x pick))) (cry 'old))) 18 | (def new (join pick (cry 'new))) 19 | (carry (cry `(,new ,old))))) 20 | 21 | (print (left (shuffled 'new) 5)) -------------------------------------------------------------------------------- /lib/identity.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | (import "things.rkt") 4 | (import "monadology.rkt") 5 | (provide (all-defined-out)) 6 | 7 | ; A container thing 8 | (describe Identity (state Null)) 9 | 10 | ; The type constructor for the Identity monad 11 | (def fn id (v) 12 | (Identity (list v))) 13 | 14 | ; The bind (>>=) operator for the Identity monad 15 | (def fn id-bind (act fn) 16 | (fn (act 'state))) 17 | 18 | ; The guard function for identity. Essentially meaningless, but necessary for the definition 19 | (def fn id-guard (test) 20 | (if test then (id Null) else Null)) 21 | 22 | ; An instance of monad-do for Identity 23 | (def macroset id-do 24 | ((id-do e ...) 25 | (monad-do (id-bind id id-guard) e ...))) -------------------------------------------------------------------------------- /examples/do-action.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (describe Identity (state Null)) 4 | 5 | (def fn id (v) 6 | (Identity (list v))) 7 | 8 | (def fn >>= (act fn) 9 | (fn (act 'state))) 10 | 11 | (def macroset do> (return :=) 12 | ((_ (return exp)) 13 | (id exp)) 14 | ((_ (exp ...)) (exp ...)) 15 | ((_ (name := val) exp ...) 16 | (>>= (id val) (fn (name) (do> exp ...)))) 17 | ((_ (exp0 ...) exp1 ...) 18 | (>>= (id (exp0 ...)) (fn (_) (do> exp1 ...))))) 19 | 20 | (rem (do> 21 | (a := (input stx)) 22 | (b := (input stx)) 23 | (print (format$ "#_ * #_ = " a b)) 24 | (c := (* a b)) 25 | (a := 100) 26 | (print c))) 27 | 28 | (do> 29 | (x := 5) 30 | (print (format$ "Value was #_" x)) 31 | (x := (+ x 5)) 32 | (print (format$ "But now it's #_" x)) 33 | (x := "Behold, a monad ... -ish.") 34 | (return x)) -------------------------------------------------------------------------------- /private/io.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/stxparam) 4 | (provide (all-defined-out) 5 | ) 6 | 7 | ; (using (file "name" as *'input|'output*) ...) 8 | ; parameterizes the current I/O port as indicated, redirecting print & input 9 | (define-syntax using 10 | (syntax-rules (as file) 11 | [(_ (file name as type) body ...) 12 | (cond 13 | [(eq? type 'output) (with-output-to-file name 14 | (lambda () body ...))] 15 | [(eq? type 'rewrite) (with-output-to-file name 16 | #:exists 'truncate 17 | (lambda () body ...))] 18 | [(eq? type 'input) (with-input-from-file name 19 | (lambda () body ...))])])) 20 | 21 | (define-syntax-parameter as 22 | (lambda (stx) 23 | (raise-syntax-error (syntax-e stx) "as must be used with using"))) 24 | (define-syntax-parameter file 25 | (lambda (stx) 26 | (raise-syntax-error (syntax-e stx) "file must be used with using"))) -------------------------------------------------------------------------------- /examples/cons-things.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (import rkt racket/base) 4 | 5 | (describe List) 6 | (describe Nil extends List) 7 | (describe Cons extends List 8 | (car (any?) Nil) 9 | (cdr (is-a? List) Nil)) 10 | 11 | (def fn cons (a b) 12 | (Cons (list a b))) 13 | 14 | (def fn car (l) 15 | (l 'car)) 16 | 17 | (def fn cdr (l) 18 | (l 'cdr)) 19 | 20 | (def fn cons? (v) 21 | (is-a? Cons v)) 22 | 23 | (def fn nil? (l) 24 | (is-a? Nil l)) 25 | 26 | (def fn print-cons (l) 27 | (select 28 | ((nil? l) "Nil") 29 | ((cons? (car l)) (format$ "Cons(#_, #_)" (print-cons (car l)) (print-cons (cdr l)))) 30 | (else (format$ "Cons(#_, #_)" (car l) (print-cons (cdr l)))))) 31 | 32 | (def fn cons->list (l) 33 | (select 34 | ((nil? l) Null) 35 | ((cons? (car l)) (join (cons->list (car l)) 36 | (cons->list (cdr l)))) 37 | (else (join (car l) 38 | (cons->list (cdr l)))))) 39 | 40 | (def l (cons 1 (cons (cons 2 (cons 4 Nil)) (cons 3 Nil)))) 41 | 42 | (print-cons l) 43 | (cons->list l) 44 | (cons? l) -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Heresy - a BASIC-flavored Lisp dialect 4 | ; Copyright (C) 2014 Annaia Danvers 5 | ; Licensed with the LGPL v.3.0 6 | 7 | ;; Requires 8 | (require "./private/base.rkt" 9 | "./lib/list.rkt" 10 | "./lib/string.rkt" 11 | "./lib/math.rkt" 12 | "./lib/theory.rkt" 13 | "./lib/things.rkt" 14 | "./lib/infix-math.rkt" 15 | "./lib/pipes.rkt" 16 | "./lib/monadology.rkt" 17 | "./lib/identity.rkt" 18 | "./lib/hole.rkt" 19 | "./lib/maybe.rkt") 20 | 21 | ;; Provides 22 | (provide (all-from-out "./private/base.rkt" 23 | "./lib/list.rkt" 24 | "./lib/string.rkt" 25 | "./lib/math.rkt" 26 | "./lib/theory.rkt" 27 | "./lib/things.rkt" 28 | "./lib/infix-math.rkt" 29 | "./lib/pipes.rkt" 30 | "./lib/monadology.rkt" 31 | "./lib/identity.rkt" 32 | "./lib/hole.rkt" 33 | "./lib/maybe.rkt")) 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Heresy 2 | ====== 3 | [![Build Status](https://travis-ci.com/jarcane/heresy.svg?branch=master)](https://app.travis-ci.com/jarcane/heresy) 4 | 5 | Heresy is a BASIC-inspired functional dialect of Lisp, currently implemented as a Racket language. 6 | 7 | Heresy aims to provide a simple, semi-pure functional Lisp language that is nevertheless familiar to programmers of BASIC, by providing a combination of familiar control structures and features with purely functional execution. 8 | 9 | The official documentation and reference can be found here: http://pkg-build.racket-lang.org/doc/heresy/index.html 10 | 11 | Heresy is chiefly written by myself, with considerable contributions from Alex Knauth, and several others in the Racket community. The code Copyright 2014 by Annaia Danvers, and is licensed via the LGPL v3. 12 | 13 | Installation 14 | ------------ 15 | 16 | To install: 17 | 18 | ``raco pkg install heresy`` 19 | 20 | To use, append this to the start of your file in DrRacket or your favorite text-editor: 21 | 22 | ``#lang heresy`` 23 | 24 | Contributing 25 | ------------ 26 | 27 | Pull requests should be made against the `develop` branch. `master` is reserved for the current release, as it is the source for the raco package for Heresy. 28 | -------------------------------------------------------------------------------- /lib/infix-math.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | ;; based on maya.clj: 4 | ;; https://gist.github.com/divs1210/b4fcbd48d7697dfd8850 5 | ;; http://pizzaforthought.blogspot.in/2015/01/maya-dsl-for-math-and-numerical-work.html 6 | 7 | (provide m) 8 | 9 | (require "require-stuff.rkt" 10 | racket/stxparam 11 | syntax/parse/define 12 | (only-in racket/base define-syntax begin-for-syntax) 13 | (for-syntax racket/base 14 | syntax/parse 15 | )) 16 | 17 | (define-simple-macro (define-syntax-parser macro:id opt-or-clause ...) 18 | (define-syntax macro (syntax-parser opt-or-clause ...))) 19 | 20 | (begin-for-syntax 21 | (define-syntax-class !lit #:literals (let = in with as) 22 | [pattern (~not (~or let = in with as))])) 23 | 24 | (define-syntax-parser m #:literals (let = in with as) 25 | [(m a) #'a] 26 | [(m let ~! a-id:id = a:!lit ... 27 | (~or (~seq in b ...) 28 | (~and (~seq (~or let with) _ ...) (~seq b ...)))) 29 | #'(let ([a-id (m a ...)]) 30 | (m b ...))] 31 | [(m with ~! a:!lit ... as a-id:id (~optional in) b ...) 32 | #'(let ([a-id (m a ...)]) 33 | (m b ...))] 34 | [(m a op b . rst) 35 | #'(m (op a b) . rst)]) 36 | 37 | -------------------------------------------------------------------------------- /lib/pipes.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | (provide (all-defined-out)) 4 | 5 | ; (:> *initial-value* *fn1* ...) 6 | ; The forward pipe operator. Given an initial value and a list of one-argument functions 7 | ; applys functions in order from left to right and returns the result 8 | (def fn :> (initial-value . fns) 9 | (for (f in fns with initial-value) 10 | (carry (f cry)))) 11 | 12 | ; (f> *fn* *args* ...) 13 | ; For currying fns for :>. Returns a function that takes initial-value and applies it as the first argument of fn 14 | (def macro f> (f args ...) 15 | (fn (x) 16 | (f x args ...))) 17 | 18 | ; (l> *fn* *args* ...) 19 | ; The inverse of f>, returns a function that takes a value and applies it as the last argument of fn 20 | (def macro l> (f args ...) 21 | (fn (x) 22 | (f args ... x))) 23 | 24 | ; (-> *value* *fns* ...) 25 | ; The first-argument threading macro. Takes value, and threads it in turn as the first argument of the following functions 26 | (def macro -> (iv (f args ...) ...) 27 | (:> iv 28 | (f> f args ...) 29 | ...)) 30 | 31 | ; (->> *value* *fns* ...) 32 | ; The last-argument version of ->. Takes a value, and threads it in turn as the last argument of successive functions 33 | (def macro ->> (iv (f args ...) ...) 34 | (:> iv 35 | (l> f args ...) 36 | ...)) -------------------------------------------------------------------------------- /lib/theory.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | (require "list.rkt") 4 | (provide (all-defined-out)) 5 | 6 | ; Y 7 | ; The Y-combinator 8 | (def Y 9 | (fn (b) 10 | ((fn (f) (b (fn (x) ((f f) x)))) 11 | (fn (f) (b (fn (x) ((f f) x))))))) 12 | 13 | ;; Y* 14 | ;; the Y-combinator, generalized for multiple argument functions 15 | (def Y* 16 | (fn (b) 17 | ((fn (f) (b (fn args (apply (f f) args)))) 18 | (fn (f) (b (fn args (apply (f f) args))))))) 19 | 20 | ; (partial *fun* *init-args* ...) 21 | ; Returns a new function with with init-args partially applied to fun 22 | (def fn partial (fun . rest) 23 | (fn (x . args) (apply fun (append rest (append (list x) args))))) 24 | 25 | ; (compose *fun* *fun2*) 26 | ; Returns a new function which is the composition of the two, 27 | ; returning the result of fun on the evaluation of fun2 and it's args. 28 | (def fn compose (fun fun2) 29 | (fn (x . args) (fun (apply fun2 (join x args))))) 30 | 31 | ; (fnlet *name* args body ...) 32 | ; A syntax sugaring for less verbose use of Y 33 | ; Allows lambda functions that can still self-refer 34 | ; uses the generalized Y-combinator 35 | (def macro fnlet (name args body ...) 36 | (Y* 37 | (fn (name) 38 | (fn args 39 | body ...)))) 40 | 41 | ; (identity v) 42 | ; Any -> Any 43 | ; The identity function. Given a value, returns that value. 44 | (def fn identity (v) v) 45 | -------------------------------------------------------------------------------- /private/random.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/unsafe/ops 4 | racket/generator) 5 | 6 | (provide timer 7 | randomize 8 | rnd) 9 | 10 | (define fxxor unsafe-fxxor) 11 | (define fxrshift unsafe-fxrshift) 12 | (define fxlshift unsafe-fxlshift) 13 | (define fx* unsafe-fx*) 14 | 15 | ; timer 16 | ; a special internal variable that returns the current time in ms 17 | (define-syntax timer 18 | (syntax-id-rules (timer) (timer (current-milliseconds)))) 19 | 20 | ; (randomize [seed]) 21 | ; returns a new pseudorandom number generator function 22 | ; Numbers are between 0 and 1 exclusive 23 | ; method is the xorshift* algorithm 24 | ; if seed is not provided, defaults to the current time in ms 25 | (define-syntax randomize 26 | (syntax-rules () 27 | [(_ seed) 28 | (generator 29 | () 30 | (let loop ([x (equal-hash-code seed)] 31 | [f (λ (x dir y) 32 | (fxxor x (if (eq? dir 'l) 33 | (fxlshift x y) 34 | (fxrshift x y))))]) 35 | (begin 36 | (let ([new-x (f (f (f x 'r 12) 'l 25) 'r 27)]) 37 | (yield (/ (modulo (unsafe-fxabs (fx* 2685821657736338717 new-x)) 38 | (expt 2 62)) 39 | (expt 2.0 62))) 40 | (loop new-x f)))))] 41 | [(_) (randomize timer)])) 42 | 43 | ; (rnd) 44 | ; returns a random number between 0 and 1 exclusive 45 | (define rnd (randomize)) 46 | -------------------------------------------------------------------------------- /lib/math.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | (import rkt racket) 4 | (require racket/flonum) 5 | (provide (all-defined-out)) 6 | 7 | (def pi 3.141592653589793) 8 | (def e 2.718281828459045) 9 | 10 | ; (abs n) 11 | ; returns the absolute value of n 12 | (def fn abs (n) 13 | (if (< n 0) then (* n -1) else n)) 14 | 15 | ; (even? n) 16 | ; returns True if n is even 17 | (def fn even? (n) 18 | (select 19 | ((not (rkt:integer? n)) (error 'even? "expected integer")) 20 | ((zero? n) True) 21 | (else (= (mod n 2) 0)))) 22 | 23 | ; (odd? n) 24 | ; return True if n is odd 25 | (def fn odd? (n) 26 | (select 27 | ((not (rkt:integer? n)) 28 | (error 'odd? "expected integer")) 29 | (else (not (even? n))))) 30 | 31 | ; (sgn n) 32 | ; Returns the "sign" of n, -1 if neg, 0 if zero?, or 1 if positive 33 | (def fn sgn (n) 34 | (select 35 | ((< n 0) -1) 36 | ((> n 0) 1) 37 | (else 0))) 38 | 39 | ; (inc n) 40 | ; increments n by 1 41 | (def fn inc (n) 42 | (+ 1 n)) 43 | 44 | ; (dec n) 45 | ; decrements n by 1 46 | (def fn dec (n) 47 | (- n 1)) 48 | 49 | ; (exp n) 50 | ; Returns the value of e^n 51 | (def fn exp (n) 52 | (^ e n)) 53 | 54 | ; (sin x) 55 | ; Sine of x 56 | (def fn sin (x) 57 | (rkt:real-part 58 | (/ (- (^ e (* 0+1i x)) (^ e (* 0-1i x))) 59 | 0+2i))) 60 | 61 | ; (cos x) 62 | ; Cosine of x 63 | (def fn cos (x) 64 | (rkt:real-part 65 | (/ (+ (^ e (* 0+1i x)) (^ e (* 0-1i x))) 66 | 2))) 67 | 68 | ; (tan x) 69 | ; Tangent of x 70 | (def fn tan (x) 71 | (/ (sin x) 72 | (cos x))) -------------------------------------------------------------------------------- /tests/infix-math.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | ;; based on maya.clj: 4 | ;; https://gist.github.com/divs1210/b4fcbd48d7697dfd8850 5 | ;; http://pizzaforthought.blogspot.in/2015/01/maya-dsl-for-math-and-numerical-work.html 6 | 7 | (require "../lib/infix-math.rkt" 8 | "../lib/require-stuff.rkt" 9 | rackunit 10 | (only-in racket/base sqrt)) 11 | 12 | (def macro ~> (a b) (b a)) 13 | 14 | (test-case "quadratic1" 15 | (def fn quadratic (a b c) 16 | (m let d = 4 * a * c 17 | let D = b * b - d ~> sqrt 18 | let t = 2 * a let -b = (- b) 19 | let x1 = -b + D / t 20 | let x2 = -b - D / t in 21 | (list x1 x2))) 22 | (check-equal? (quadratic 1 0 0) '(0 0)) 23 | (check-equal? (quadratic 1 0 -1) '(1 -1)) 24 | (check-equal? (quadratic 1 0 -4) '(2 -2)) 25 | (check-equal? (quadratic 1 0 1) '(+i -i)) 26 | (check-equal? (quadratic 1 0 4) '(+2i -2i)) 27 | (check-equal? (quadratic 1 -2 0) '(2 0)) 28 | (check-equal? (quadratic 1 2 0) '(0 -2)) 29 | (check-equal? (quadratic 1 -2 1) '(1 1)) 30 | (check-equal? (quadratic 1/2 -2 2) '(2 2)) 31 | (check-equal? (quadratic 1/2 -2 0) '(4 0))) 32 | 33 | (test-case "quadratic2" 34 | (def fn quadratic (a b c) 35 | (m with (- b) as -b 36 | with b ^ 2 - (m 4 * a * c) ~> sqrt as D 37 | let x1 = -b + D / (m 2 * a) 38 | let x2 = -b - D / (m 2 * a) in 39 | (list x1 x2))) 40 | (check-equal? (quadratic 1 0 0) '(0 0)) 41 | (check-equal? (quadratic 1 0 -1) '(1 -1)) 42 | (check-equal? (quadratic 1 0 -4) '(2 -2)) 43 | (check-equal? (quadratic 1 0 1) '(+i -i)) 44 | (check-equal? (quadratic 1 0 4) '(+2i -2i)) 45 | (check-equal? (quadratic 1 -2 0) '(2 0)) 46 | (check-equal? (quadratic 1 2 0) '(0 -2)) 47 | (check-equal? (quadratic 1 -2 1) '(1 1)) 48 | (check-equal? (quadratic 1/2 -2 2) '(2 2)) 49 | (check-equal? (quadratic 1/2 -2 0) '(4 0))) 50 | 51 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | # To use Travis CI's newer container infrastructure, use the following 4 | # line. (Also be sure RACKET_DIR is set to somewhere like ~/racket 5 | # that doesn't require sudo.) 6 | sudo: false 7 | 8 | env: 9 | global: 10 | # Supply a global RACKET_DIR environment variable. This is where 11 | # Racket will be installed. A good idea is to use ~/racket because 12 | # that doesn't require sudo to install and is therefore compatible 13 | # with Travis CI's newer container infrastructure. 14 | - RACKET_DIR=~/racket 15 | matrix: 16 | # Supply at least one RACKET_VERSION environment variable. This is 17 | # used by the install-racket.sh script (run at before_install, 18 | # below) to select the version of Racket to download and install. 19 | # 20 | # Supply more than one RACKET_VERSION (as in the example below) to 21 | # create a Travis-CI build matrix to test against multiple Racket 22 | # versions. 23 | # 24 | # The RELEASE snapshot is only available during the release process. 25 | - RACKET_VERSION=HEAD 26 | - RACKET_VERSION=RELEASE 27 | 28 | # You may want to test against certain versions of Racket, without 29 | # having them count against the overall success/failure. 30 | matrix: 31 | allow_failures: 32 | - env: RACKET_VERSION=HEAD 33 | # - env: RACKET_VERSION=RELEASE 34 | # Fast finish: Overall build result is determined as soon as any of 35 | # its rows have failed, or, all of its rows that aren't allowed to 36 | # fail have succeeded. 37 | fast_finish: true 38 | 39 | 40 | before_install: 41 | - git clone https://github.com/greghendershott/travis-racket.git 42 | - cat travis-racket/install-racket.sh | bash # pipe to bash not sh! 43 | - export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us 44 | 45 | install: 46 | 47 | before_script: 48 | 49 | script: 50 | - raco pkg install --deps search-auto 51 | - raco setup -D --check-pkg-deps heresy 52 | - raco test -x -p heresy 53 | 54 | after_script: 55 | -------------------------------------------------------------------------------- /lib/monadology.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | (provide (all-defined-out)) 4 | 5 | ; monad-do 6 | ; The base implementation for Heresy do notation DSL 7 | ; Inspired by Remko Trançon's post on Scheme monads: https://el-tramo.be/blog/scheme-monads/ 8 | ; This constructor form can be used directly, by providing the bind (>>=), return, and guard 9 | ; functions for a data type, or more commonly, wrapped in a macro that provides these 10 | ; Comments below describe individual forms/operators within the DSL 11 | (def macroset monad-do (<- = yield if) 12 | 13 | ; (yield exp ...) 14 | ; When used as the final line of a do form, returns the result of the expression(s) wrapped 15 | ; in the monad's constructor 16 | ((_ (bind return guard) 17 | (yield exp ...)) 18 | (return exp ...)) 19 | 20 | ; If instead the final line of the do form is a bare expression, its result will be returned 21 | ((_ (bind return guard) 22 | (exp ...)) 23 | (exp ...)) 24 | 25 | ; (name = val) 26 | ; Wraps the expression val in the monad type, and binds it to name 27 | ((_ (bind return guard) 28 | (name = val) 29 | exps ...) 30 | (bind (return val) 31 | (fn (name) (monad-do (bind return guard) exps ...)))) 32 | 33 | ; (name <- val) 34 | ; Binds the given monadic value to name. Will fail if not the correct type 35 | ((_ (bind return guard) 36 | (name <- val) 37 | exps ...) 38 | (bind val 39 | (fn (name) (monad-do (bind return guard) exps ...)))) 40 | 41 | ; (if test) 42 | ; The guard pattern. If test is true, will bind to an instance of the type, else to Null 43 | ((_ (bind return guard) 44 | (if test) 45 | exps ...) 46 | (bind (guard test) 47 | (fn (_) (monad-do (bind return guard) exps ...)))) 48 | 49 | ; Bare expressions within the do-form are evaluated but their results ignored 50 | ((_ (bind return guard) 51 | (exp0 ...) 52 | exps ...) 53 | (bind (return (exp0 ...)) 54 | (fn (_) (monad-do (bind return guard) exps ...))))) -------------------------------------------------------------------------------- /lib/hole.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | (import "things.rkt") 4 | (import "monadology.rkt") 5 | (import rkt racket) 6 | (import rkt racket/async-channel) 7 | (import rkt rackjure/utils) 8 | (provide (all-defined-out)) 9 | 10 | ; Hole 11 | ; Core data type for holes. Not especially useful on its own, except as a reference for is-a?. 12 | (describe Hole 13 | (box Null)) 14 | 15 | ; (hole *val*) 16 | ; Any -> Hole 17 | ; Returns a hole containing val. Holes carry a single value, with a limited set of atomic 18 | ; operations. 19 | (def fn hole (val) 20 | (Hole (list (rkt:box val)))) 21 | 22 | ; (hole? *v*) 23 | ; Any -> Boolean 24 | ; Returns #t if v is a hole. 25 | (def fn hole? (v) 26 | (and (is-a? Hole v) 27 | (rkt:box? (v 'box)))) 28 | 29 | ; (deref *hol*) 30 | ; Hole -> Any 31 | ; Returns the current value store in hol. 32 | (def fn deref (hol) 33 | (rkt:unbox (hol 'box))) 34 | 35 | ; (reset *hol* *new-val*) 36 | ; Hole Any -> Hole 37 | ; Resets the current value of hol to new-val 38 | (def fn reset (hol new-val) 39 | (rkt:set-box! (hol 'box) new-val) 40 | hol) 41 | 42 | ; (update *hol* *fn* . *args* ...) 43 | ; Hole Fn . Args -> Hole 44 | ; Updates the current value of hol by applying fn with the current value as first arg, and args 45 | ; as the remaining arguments 46 | (def fn update (hol fn . args) 47 | (apply rkt:box-swap! (hol 'box) fn args) 48 | hol) 49 | 50 | ; (reset-thing *hol* *sym* *val* ...) 51 | ; Hole Field Any ... -> Hole 52 | ; Expects a Thing stored in hol, and resets the value in the thing field defined by sym to val 53 | (def macro reset-thing (hol (field val) ...) 54 | (update hol (fn (t) 55 | (t `((field ,val) ...))))) 56 | 57 | ; (hole-bind *hol* *fn*) 58 | ; Hole Fn -> Hole 59 | ; Applies fn over the current value of hol. The bind (>>=) operator for holes. 60 | (def fn hole-bind (hol fn) 61 | (fn (deref hol))) 62 | 63 | ; (hole-guard *test*) 64 | ; The guard operator for holes 65 | (def fn hole-guard (test) 66 | (if test then (hole Null) else Null)) 67 | 68 | ; (hole-do ...) 69 | ; monad-do as defined for holes 70 | (def macroset hole-do 71 | ((_ e ...) 72 | (monad-do (hole-bind hole hole-guard) e ...))) -------------------------------------------------------------------------------- /tests/Y.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (import rkt racket/base) 4 | (require rackunit syntax/parse/define (rkt:for-syntax racket/base)) 5 | 6 | (rkt:begin-for-syntax 7 | (define-syntax-class chk-clause 8 | [pattern (~and stx [actual:expr expected:expr]) 9 | #:with chk (syntax/loc #'stx (check-equal? actual expected))])) 10 | (define-simple-macro (chk clause:chk-clause ...) 11 | (rkt:begin clause.chk ...)) 12 | 13 | (test-case "Y" 14 | (def fact 15 | (Y (fn (f) 16 | (fn (n) 17 | (select 18 | [(zero? n) 1] 19 | [else (* n (f (dec n)))]))))) 20 | (chk [(fact 0) 1] 21 | [(fact 1) 1] 22 | [(fact 2) 2] 23 | [(fact 3) 6] 24 | [(fact 4) 24] 25 | [(fact 5) 120] 26 | [(fact 6) 720])) 27 | 28 | (test-case "Y*" 29 | (def fib 30 | (Y* (fn (f) 31 | (fn (f0 f1 n) 32 | (select 33 | [(zero? n) f0] 34 | [(one? n) f1] 35 | [else (+ (f f0 f1 (- n 2)) (f f0 f1 (- n 1)))]))))) 36 | (chk [(fib 0 1 0) 0] ; Fibonacci Numbers 37 | [(fib 0 1 1) 1] 38 | [(fib 0 1 2) 1] 39 | [(fib 0 1 3) 2] 40 | [(fib 0 1 4) 3] 41 | [(fib 0 1 5) 5] 42 | [(fib 0 1 6) 8] 43 | [(fib 0 1 7) 13] 44 | [(fib 0 1 8) 21] 45 | [(fib 0 1 9) 34] 46 | [(fib 0 1 10) 55] 47 | [(fib 0 1 11) 89] 48 | [(fib 0 1 12) 144] 49 | [(fib 0 1 13) 233] 50 | [(fib 0 1 14) 377] 51 | [(fib 0 1 15) 610] 52 | [(fib 0 1 16) 987] 53 | [(fib 2 1 0) 2] ; Lucas Numbers 54 | [(fib 2 1 1) 1] 55 | [(fib 2 1 2) 3] 56 | [(fib 2 1 3) 4] 57 | [(fib 2 1 4) 7] 58 | [(fib 2 1 5) 11] 59 | [(fib 2 1 6) 18] 60 | [(fib 2 1 7) 29] 61 | [(fib 2 1 8) 47] 62 | [(fib 2 1 9) 76] 63 | [(fib 2 1 10) 123] 64 | [(fib 2 1 11) 199] 65 | [(fib 2 1 12) 322])) 66 | 67 | (test-case "fnlet" 68 | (def fib 69 | (fnlet f (f0 f1 n) 70 | (select 71 | [(zero? n) f0] 72 | [(one? n) f1] 73 | [else (+ (f f0 f1 (- n 2)) (f f0 f1 (- n 1)))]))) 74 | (chk [(fib 0 1 0) 0] ; Fibonacci Numbers 75 | [(fib 0 1 16) 987] 76 | [(fib 2 1 0) 2] ; Lucas Numbers 77 | [(fib 2 1 12) 322])) 78 | 79 | -------------------------------------------------------------------------------- /lib/maybe.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | (import "things.rkt") 4 | (import "theory.rkt") 5 | (import "monadology.rkt") 6 | (provide (all-defined-out)) 7 | 8 | ;; The Maybe type family 9 | (describe Maybe) 10 | 11 | ; None 12 | ; Represents no result 13 | (describe None extends Maybe) 14 | 15 | ; Some 16 | ; Contains a value 17 | (describe Some extends Maybe (contains Null)) 18 | 19 | ; (some v) 20 | ; Any -> Some 21 | ; Constructor for Some. Returns a Some containing v. 22 | (def fn some (v) 23 | (Some (list v))) 24 | 25 | ; (is-some? opt) 26 | ; Maybe -> Boolean 27 | ; Returns true if opt is a Some 28 | (def fn is-some? (opt) 29 | (is-a? Some opt)) 30 | 31 | ; (is-none? opt) 32 | ; Maybe -> Boolean 33 | ; Returns true if opt is None. 34 | (def fn is-none? (opt) 35 | (is-a? None opt)) 36 | 37 | ; (maybe? v) 38 | ; Any -> Boolean 39 | ; Returns true if v is a Maybe. 40 | (def fn maybe? (opt) 41 | (is-a? Maybe opt)) 42 | 43 | ; (maybe-bind opt fn) 44 | ; Maybe Fn(Any -> Maybe) -> Maybe 45 | ; The bind (>>=) operator for Some/None. 46 | ; Returns None if opt is None, or fn applied to the contents of Some. 47 | (def fn maybe-bind (opt fn) 48 | (select 49 | ((is-none? opt) None) 50 | (else (fn (opt 'contains))))) 51 | 52 | ; (get-some opt) 53 | ; Maybe -> Any 54 | ; If opt is Some(v), returns v, else if None, returns None. 55 | (def fn get-some (opt) 56 | (maybe-bind opt identity)) 57 | 58 | ; (maybe-map fn opt) 59 | ; Fn(Any -> Any) Maybe -> Maybe 60 | ; If opt is Some(v), returns Some(fn v), else if None, Returns None 61 | (def fn maybe-map (fn opt) 62 | (select 63 | ((is-none? opt) opt) 64 | (else (some (fn (opt 'contains)))))) 65 | 66 | ; (maybe-filter pred? opt) 67 | ; Fn(Any -> Boolean) Maybe -> Maybe 68 | ; If opt is None, returns None. If opt is Some(v), returns Some(v) if (pred? v) is true, 69 | ; or None if it is false 70 | (def fn maybe-filter (pred? opt) 71 | (select 72 | ((and (is-some? opt) 73 | (pred? (opt 'contains))) opt) 74 | (else None))) 75 | 76 | ; (maybe-guard test) 77 | ; Bool -> Maybe 78 | (def fn maybe-guard (test) 79 | (if test then (some Null) else None)) 80 | 81 | ; (maybe-do ...) 82 | ; Do notation micro-DSL for Maybe. 83 | ; For each line but the last, the following two forms are allowed: 84 | ; (name <- val) - binds Maybe val to name. 85 | ; (name = val) - binds Some(val) to name 86 | ; Subsequent val expressions have the previous named vals in scope. 87 | ; The last line must be a normal expression, most useful if it is a calculation of previous 88 | ; bound values. A bare expression will return its result, use (yield ...) to return a Some. 89 | (def macroset maybe-do 90 | ((_ e ...) 91 | (monad-do (maybe-bind some maybe-guard) e ...))) -------------------------------------------------------------------------------- /tests/things.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (require rackunit 4 | "../lib/things.rkt") 5 | (import rkt racket/base) 6 | 7 | (test-case "cthulhu" 8 | (describe cthulhu 9 | (size 'massive) 10 | (type 'squamous) 11 | (status 'sleeping)) 12 | 13 | (def great-baalthogua (cthulhu '(* * awake))) 14 | 15 | (check-equal? (cthulhu) 16 | '((size massive) (type squamous) (status sleeping))) 17 | (check-equal? (great-baalthogua) 18 | '((size massive) (type squamous) (status awake))) 19 | (check-equal? (cthulhu 'size) 'massive) 20 | (check-equal? ((cthulhu '(* * awake)) 'status) 'awake) 21 | (def dreamer cthulhu) 22 | (check-equal? (dreamer 'type) 'squamous) 23 | (def star-spawn (cthulhu '(medium * awake))) 24 | (check-equal? (star-spawn) '((size medium) (type squamous) (status awake))) 25 | (check-equal? (star-spawn 'size) 'medium) 26 | ) 27 | 28 | (test-case "using methods" 29 | (def (make-fish sz) 30 | (thing [size sz] 31 | [get-size (fn () size)] 32 | [grow (fn (amt) 33 | (Self `(,(+ amt size))))] 34 | [eat (fn (other-fish) 35 | (grow (send other-fish 'get-size)))])) 36 | (def charlie (make-fish 10)) 37 | (check-equal? (charlie 'size) 10) 38 | (def charlie2 (send charlie 'grow 6)) 39 | (check-equal? (charlie2 'size) 16) 40 | (check-equal? (send charlie2 'get-size) 16) 41 | (check-equal? (send charlie 'get-size) 10) 42 | (def (make-hungry-fish sz) 43 | (thing extends (make-fish sz) 44 | [eat-more (fn (fish1 fish2) 45 | (send+ Self (eat fish1) (eat fish2)))])) 46 | (def hungry-fish (make-hungry-fish 32)) 47 | (check-equal? (hungry-fish 'size) 32) 48 | (check-equal? ((send hungry-fish 'eat-more charlie charlie2) 'size) 58) 49 | ) 50 | 51 | (test-case "make sure the field exprs aren't re-evaluated" 52 | (def x (rkt:box 1)) 53 | (def (get-x) (rkt:unbox x)) 54 | (def (inc-x!) (rkt:set-box! x (inc (get-x)))) 55 | (describe foo [a (inc-x!)]) 56 | (check-equal? (get-x) 2) 57 | (foo 'a) 58 | (check-equal? (get-x) 2) 59 | (foo 'a) 60 | (check-equal? (get-x) 2) 61 | ) 62 | 63 | (test-case "make sure that (thing extends ...) doesn't change order of fields" 64 | (describe foo [a 'a] [b 'b] [c 'c]) 65 | (describe bar extends foo [b 'new-b] [d 'd] [e 'e]) 66 | (check-equal? (bar) '([a a] [b new-b] [c c] [d d] [e e]))) 67 | 68 | (test-case "test super" 69 | (describe Sup 70 | [m1 (fn (x) (error 'nevergetshere))] 71 | [m2 (fn (y) (m1 y))]) 72 | (describe Sub extends Sup super ([super-m2 m2]) 73 | [m1 (fn (x) (inc x))] 74 | [m2 (fn (y) (error 'nevergetshere))] 75 | [m3 (fn (y) (super-m2 y))]) 76 | (check-equal? (send Sub 'm3 1) 2)) 77 | -------------------------------------------------------------------------------- /lib/string.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | (require "list.rkt") 4 | (provide (all-defined-out)) 5 | 6 | ; (empty$? str) 7 | ; Returns true if string is empty) 8 | (def fn empty$? (str) 9 | (=$ str "")) 10 | 11 | ; (len$ *str*) 12 | ; Returns the length of the given str 13 | (def fn len$ (str) 14 | (len (list$ str))) 15 | 16 | ; (list& *lst*) 17 | ; Takes a list of strings and returns a single string concatenated together 18 | (def fn list& (lst) 19 | (apply & lst)) 20 | 21 | ; (head$ *str*) 22 | ; Returns the first character of the string 23 | (def fn head$ (str) 24 | (head (list$ str))) 25 | 26 | ; (tail$ *str*) 27 | ; Returns the remainder of the string 28 | (def fn tail$ (str) 29 | (let ([tl (list$ str)]) 30 | (if (null? tl) then 31 | "" 32 | else (list& (tail tl))))) 33 | 34 | ; (left$ *str* *n* ) 35 | ; Returns the leftmost n characters of the string 36 | (def fn left$ (str n) 37 | (list& (left (list$ str) n))) 38 | 39 | ; (right$ *str* *n*) 40 | ; Returns the rightmost n characters of the string 41 | (def fn right$ (str n) 42 | (list& (right (list$ str) n))) 43 | 44 | ; (mid$ *str* *idx* *length*) 45 | ; Returns a slice of str, length long, starting at idx 46 | (def fn mid$ (str idx length) 47 | (list& (mid (list$ str) idx length))) 48 | 49 | ; (slice$ *str* *start* *finish*) 50 | ; Returns a slice of the string from start to finish, inclusive 51 | (def fn slice$ (str (start 0) (finish (len$ str))) 52 | (list& (slice (list$ str) start finish))) 53 | 54 | ; (instr *str* *search*) 55 | ; Returns the index of the first instance given search string within str, or #f 56 | (def fn instr (str search (idx 1)) 57 | (select 58 | ((empty$? str) False) 59 | ((> (len$ search) (len$ str)) False) 60 | ((=$ search (left$ str (len$ search))) idx) 61 | (else (instr (tail$ str) search (+ 1 idx))))) 62 | 63 | ; (split *str* [*delimiters*]) 64 | ; Returns a list of strings split from str at the given list of delimiters 65 | ; default delimiter is " " 66 | (def fn split (str (delims '(" "))) 67 | (let ([s (sort < (for (x in delims) 68 | (let ([sx (instr str x)]) 69 | (if (not sx) then (carry cry) else (carry (join sx cry))))))]) 70 | (select 71 | ((empty$? str) '()) 72 | ((null? s) (join str Null)) 73 | (else (let ([s2 (head s)]) 74 | (join (left$ str (- s2 1)) 75 | (join (mid$ str s2 1) 76 | (split (slice$ str (+ 1 s2)) delims)))))))) 77 | 78 | ; (format *str-template* v1 ...) 79 | ; Returns a new string, based on template, with indicated reserved places replaced by vals 80 | ; Reserved spaces are indicated by #_, and consume one of the following variables 81 | (def fn format$ (t . rest) 82 | (select 83 | ((empty$? t) t) 84 | ((and (=$ (head$ t) "#") 85 | (=$ (head$ (tail$ t)) "_")) (& (str$ (head rest)) 86 | (apply format$ (tail$ (tail$ t)) (tail rest)))) 87 | (else (& (head$ t) 88 | (apply format$ (tail$ t) rest))))) -------------------------------------------------------------------------------- /examples/brainfuck.rkt: -------------------------------------------------------------------------------- 1 | #lang heresy 2 | 3 | (import rkt racket) 4 | 5 | ;; Machine state object 6 | (describe Machine 7 | (data-ptr 0) 8 | (instr-ptr 0) 9 | (cells (for (x in (range 1 to 30000)) 10 | (carry (join 0 cry))))) 11 | 12 | ;; helper functions 13 | (def fn constantly (val) 14 | (fn args* val)) 15 | 16 | (def fn update (nth fun lst) 17 | (select 18 | ((> nth (len lst)) (error 'update "out of index")) 19 | ((zero? nth) (join (fun (head lst)) 20 | (tail lst))) 21 | (else (join (head lst) 22 | (update (dec nth) 23 | fun 24 | (tail lst)))))) 25 | 26 | (def fn assoc-v (tgt lst) 27 | (:> (assoc tgt lst) tail)) 28 | 29 | (def fn update-alst (tgt fun lst) 30 | (let ([orig (assoc-v tgt lst)]) 31 | (subst tgt (fun orig) lst))) 32 | 33 | ;; Instruction implementations 34 | 35 | ; > 36 | (def fn inc-dptr (Machine) 37 | (let ([old (Machine 'data-ptr)]) 38 | (Machine `(,(inc old) * *)))) 39 | 40 | ; < 41 | (def fn dec-dptr (Machine) 42 | (let ([old (Machine 'data-ptr)]) 43 | (Machine `(,(dec old) * *)))) 44 | 45 | ; + 46 | (def fn inc-byte (Machine) 47 | (let ([old (Machine 'cells)] 48 | [ptr (Machine 'data-ptr)]) 49 | (Machine `(* * ,(update ptr inc old))))) 50 | 51 | ; - 52 | (def fn dec-byte (Machine) 53 | (let ([old (Machine 'cells)] 54 | [ptr (Machine 'data-ptr)]) 55 | (Machine `(* * ,(update ptr dec old))))) 56 | 57 | ; . 58 | (def fn out-byte (Machine) 59 | (let ([byte (index (inc (Machine 'data-ptr)) (Machine 'cells))]) 60 | (rkt:write-byte byte (rkt:current-output-port)) 61 | Machine)) 62 | 63 | ; , 64 | (def fn in-byte (Machine) 65 | (let ([byte (rkt:read-byte (rkt:current-input-port))] 66 | [old (Machine 'cells)] 67 | [ptr (Machine 'data-ptr)]) 68 | (Machine `(* * ,(update ptr (constantly byte) old))))) 69 | 70 | ; [ 71 | (def fn jmp-r (Machine prg) 72 | (let ([init-ptr (Machine 'instr-ptr)]) 73 | (for (x in (list$ (slice$ prg (+ 2 init-ptr))) with `((lefts . 0) 74 | (count . ,(inc init-ptr)))) 75 | (select case x 76 | (("]") (if (zero? (assoc-v 'lefts cry)) then 77 | (break (Machine `(* ,(inc (assoc-v 'count cry)) *))) else 78 | (carry (update-alst 'lefts dec (update-alst 'count inc cry))))) 79 | (("[") (carry (update-alst 'lefts inc (update-alst 'count inc cry)))) 80 | (else (carry (update-alst 'count inc cry))))))) 81 | 82 | ; ] 83 | (def fn jmp-l (Machine prg) 84 | (let ([init-ptr (Machine 'instr-ptr)]) 85 | (for (x in (reverse (list$ (slice$ prg 1 init-ptr))) with `((rights . 0) 86 | (count . ,init-ptr))) 87 | (select case x 88 | (("[") (if (zero? (assoc-v 'rights cry)) then 89 | (break (Machine `(* ,(assoc-v 'count cry) *))) else 90 | (carry (update-alst 'rights dec (update-alst 'count dec cry))))) 91 | (("]") (carry (update-alst 'rights inc (update-alst 'count dec cry)))) 92 | (else (carry (update-alst 'count dec cry))))))) 93 | 94 | ;; Runtime 95 | (def fn inc-iptr (Machine) 96 | (let ([old (Machine 'instr-ptr)]) 97 | (Machine `(* ,(inc old) *)))) 98 | 99 | (def fn eval-instr (Machine instr) 100 | (select case instr 101 | ((">") (inc-iptr (inc-dptr Machine))) 102 | (("<") (inc-iptr (dec-dptr Machine))) 103 | (("+") (inc-iptr (inc-byte Machine))) 104 | (("-") (inc-iptr (dec-byte Machine))) 105 | ((".") (inc-iptr (out-byte Machine))) 106 | ((",") (inc-iptr (in-byte Machine))) 107 | (("[") (if (zero? ((Machine 'cells) (Machine 'data-ptr))) then 108 | (jmp-r Machine) else 109 | (inc-iptr Machine))) 110 | (("]") (if (not (zero? ((Machine 'cells) (Machine 'data-ptr)))) then 111 | (jmp-l Machine) else 112 | (inc-iptr Machine))) 113 | (else (inc-iptr Machine)))) 114 | 115 | (def fn start (prg) 116 | (do loop with Machine 117 | (if (> (cry 'instr-ptr) (dec (len$ prg))) then 118 | (break cry) else 119 | (carry (eval-instr cry (index (inc (Machine 'instr-ptr)) (list$ prg))))))) 120 | -------------------------------------------------------------------------------- /lib/list.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | (require "math.rkt") 4 | (require "monadology.rkt") 5 | (provide (all-defined-out)) 6 | 7 | ; (map *fun* *lst*) 8 | ; Takes a single-argument function and list, 9 | ; returning a new list with the function applied to each entry. 10 | (def fn map (fun lst) 11 | (select 12 | ((null? lst) lst) 13 | (else (join (fun (head lst)) 14 | (map fun (tail lst)))))) 15 | 16 | ; (filter *pred* *lst*) 17 | ; Returns a new list, containing only those items which are True according to pred 18 | (def fn filter (pred lst) 19 | (select 20 | ((null? lst) lst) 21 | ((pred (head lst)) 22 | (join (head lst) 23 | (filter pred (tail lst)))) 24 | (else (filter pred (tail lst))))) 25 | 26 | ; (foldr *fun* *base* *lst*) 27 | ; Folds a list from the right, combining pairs with fun, and returns the result 28 | (def fn foldr (fun base lst) 29 | (select 30 | ((null? lst) base) 31 | (else (fun (head lst) (foldr fun base (tail lst)))))) 32 | 33 | ; (foldl *fun* *base* *lst*) 34 | ; Folds a list from the left 35 | (def fn foldl (fun base lst) 36 | (select 37 | ((null? lst) base) 38 | (else (foldl fun (fun (head lst) base) (tail lst))))) 39 | 40 | ; (reverse *lst*) 41 | ; Returns list with items in reverse order 42 | (def fn reverse (lst) 43 | (foldl join Null lst)) 44 | 45 | ; (inlst *item* *lst*) 46 | ; Searches lst for item, returns index of item if found, False if not 47 | (def fn inlst (item lst (idx 1)) 48 | (select 49 | ((null? lst) False) 50 | ((equal? (head lst) item) idx) 51 | (else (inlst item (tail lst) (+ 1 idx))))) 52 | 53 | ; (left *lst* *n*) 54 | ; Returns the first n elements of the list. 55 | (def fn left (lst n) 56 | (select 57 | ((zero? n) Null) 58 | (else (join (head lst) (left (tail lst) (- n 1)))))) 59 | 60 | ; (right *lst* *n*) 61 | ; Returns last n entries from the list 62 | (def fn right (lst n) 63 | (reverse (left (reverse lst) n))) 64 | 65 | ; (mid *lst* *pos* *n*) 66 | ; Returns n entries from lst starting at pos 67 | (def fn mid (lst pos n) 68 | (select 69 | ((one? pos) (left lst n)) 70 | (else (mid (tail lst) (- pos 1) n)))) 71 | 72 | ; (slice *lst* *first* *last*) 73 | ; Returns a slice of the list from first and last positions, inclusive. 74 | (def fn slice (lst (first 0) (last (len lst))) 75 | (mid lst first (- last first -1))) 76 | 77 | ; (append1 *lst* *lst2*) 78 | ; Returns a list with the contents of lst2 appended to the end of lst1 79 | (def fn append1 (lst lst2) 80 | (select 81 | ((null? lst) lst2) 82 | (else (join (head lst) (append (tail lst) lst2))))) 83 | 84 | ; (append *lst1* ...) 85 | ; Returns a list with the given lists appended one after the other 86 | (def fn append *args 87 | (foldr append1 '() *args)) 88 | 89 | ; (assoc *target* *lst*) 90 | ; Searches the heads of a list of lists/pairs, and returns the first matching list or #f 91 | (def fn assoc (tgt lst) 92 | (select 93 | ((null? lst) False) 94 | ((eq? tgt (head (head lst))) (head lst)) 95 | (else (assoc tgt (tail lst))))) 96 | 97 | ; (subst *tgt* *new* *lst*) 98 | ; returns a new list of lists with assoc of tgt's tail replaced with new 99 | (def fn subst (tgt new lst) 100 | (select 101 | ((null? lst) False) 102 | ((eq? tgt (head (head lst))) (join (join tgt (join new Null)) (tail lst))) 103 | (else (join (head lst) (subst tgt new (tail lst)))))) 104 | 105 | ; (subst* *tgt* *new* *lst*) 106 | ; like subst, but doesn't coerce new to a list 107 | (def fn subst* (tgt new lst) 108 | (select 109 | ((null? lst) False) 110 | ((eq? tgt (head (head lst))) (join (join tgt new) (tail lst))) 111 | (else (join (head lst) (subst* tgt new (tail lst)))))) 112 | 113 | ; (heads *lst*) 114 | ; Returns the heads of a list of lists 115 | (def fn heads (lst) 116 | (select 117 | ((null? lst) Null) 118 | ((atom? (head lst)) (error 'heads "expected list")) 119 | (else (join (head (head lst)) 120 | (heads (tail lst)))))) 121 | 122 | ; (sort *fun* *lst*) 123 | ; Sorts list according to comparator fun 124 | (def fn sort (fun lst) 125 | (select 126 | ((null? lst) lst) 127 | (else (append (sort fun (filter (fn (x) (not (fun (head lst) x))) (tail lst))) 128 | (list (head lst)) 129 | (sort fun (filter (fn (x) (fun (head lst) x)) (tail lst))))))) 130 | 131 | ; (zip *lst1* *lst2*) 132 | ; Combines two lists into a single list of lists. Excess length is lost. 133 | (def fn zip (lst1 lst2) 134 | (select 135 | ((or (null? lst1) 136 | (null? lst2)) Null) 137 | (else (join (list (head lst1) 138 | (head lst2)) 139 | (zip (tail lst1) 140 | (tail lst2)))))) 141 | 142 | ; (zipwith *fun* *lst1* *lst*) 143 | ; Returns a new list containing the result of applying fun to matching entries in lsts 144 | (def fn zipwith (fun lst1 lst2) 145 | (select 146 | ((or (null? lst1) 147 | (null? lst2)) Null) 148 | (else (join (fun (head lst1) 149 | (head lst2)) 150 | (zipwith fun 151 | (tail lst1) 152 | (tail lst2)))))) 153 | 154 | ; (flatten *lst*) 155 | ; Given a list of lists, flattens all nested lists into a single list 156 | (def fn flatten (lst) 157 | (select 158 | ((null? lst) Null) 159 | ((list? lst) 160 | (append (flatten (head lst)) (flatten (tail lst)))) 161 | (else (list lst)))) 162 | 163 | ; (list-bind lst fn) 164 | ; The monadic (>>=) bind operator for lists 165 | (def fn list-bind (lst fn) 166 | (flatten (map fn lst))) 167 | 168 | ; (list-guard test) 169 | ; The guard function for lists. Used by list-do 170 | (def fn list-guard (test) 171 | (if test then (list Null) else Null)) 172 | 173 | ; (list-do ...) 174 | ; The do notation DSL for lists. 175 | (def macroset list-do 176 | ((_ e ...) 177 | (monad-do (list-bind list list-guard) e ...))) -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | 167 | -------------------------------------------------------------------------------- /private/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Heresy - a BASIC-flavored Lisp dialect 4 | ; Copyright (C) 2014 Annaia Danvers 5 | ; Licensed with the LGPL v.3.0 6 | 7 | ;; Requires 8 | (require racket/stxparam 9 | (only-in racket/base 10 | [case rkt:case] 11 | [cons join] 12 | [car head] 13 | [cdr tail] 14 | [procedure? fn?] 15 | [eval run] 16 | [eof-object? eof?]) 17 | "io.rkt" 18 | "random.rkt" 19 | (for-syntax racket/base 20 | syntax/parse)) 21 | 22 | ;; Provides 23 | (provide (all-defined-out) 24 | (all-from-out "io.rkt" 25 | "random.rkt") 26 | ; required 27 | #%module-begin 28 | #%top-interaction 29 | #%datum #%top 30 | 31 | ; From Racket 32 | + - / * = < > 33 | list? null? zero? eq? 34 | symbol? equal? 35 | number? string? fn? 36 | eof eof? 37 | and or not else 38 | quote quasiquote 39 | unquote unquote-splicing 40 | let list apply 41 | require provide all-defined-out 42 | error 43 | join head tail 44 | run 45 | one? 46 | (for-syntax ... _) 47 | (rename-out [app #%app])) 48 | 49 | ;; Declarations 50 | 51 | ; (IMPORT name) 52 | ; (IMPORT RKT name) 53 | ; requires the given file, importing it's names 54 | (define-syntax import 55 | (syntax-rules (rkt) 56 | [(_ rkt name) (require (prefix-in rkt: name))] 57 | [(_ name) (require name)])) 58 | (define-syntax-parameter rkt (λ (stx) (error "rkt is an import keyword only"))) 59 | 60 | ; (LET ((name value) ...) ...) 61 | ; Defines a variable in the local context. 62 | ; provided by Racket 63 | 64 | ; (DEF name contents) 65 | ; (DEF FN name (args) body) 66 | ; (DEF MACRO name (pattern-vars) pattern) 67 | ; Defines new variables and functions (with help from FN) 68 | (define-syntax def 69 | (syntax-rules (macro macroset fn) 70 | [(_ macro name (args ... . rest) body0 bodyn ...) 71 | (define-syntax-rule (name args ... . rest) body0 bodyn ...)] 72 | [(_ macroset name [(pname ptr0 ptrn ...) (body0 bodyn ...)] ...) 73 | (define-syntax name 74 | (syntax-rules () 75 | [(pname ptr0 ptrn ...) (body0 bodyn ...)] ...))] 76 | [(_ macroset name (lits ...) [(pname ptr0 ptrn ...) (body0 bodyn ...)] ...) 77 | (define-syntax name 78 | (syntax-rules (lits ...) 79 | [(pname ptr0 ptrn ...) (body0 bodyn ...)] ...))] 80 | [(_ fn name (args ... . rest) body0 bodyn ...) 81 | (define (name args ... . rest) body0 bodyn ...)] 82 | [(_ name contents) (define name contents)])) 83 | 84 | ; DEF literals 85 | (define-syntax-parameter macro 86 | (lambda (stx) 87 | (raise-syntax-error (syntax-e stx) "macro must be used with def"))) 88 | (define-syntax-parameter macroset 89 | (lambda (stx) 90 | (raise-syntax-error (syntax-e stx) "syntax must be used with def"))) 91 | ;(define-syntax-parameter fn 92 | ; (lambda (stx) 93 | ; (raise-syntax-error (syntax-e stx) 94 | ; "fn must be used with def; use lambda for anonymous functions"))) 95 | 96 | ; (FN (args) body ...) 97 | ; The anonymous function 98 | (define-syntax fn 99 | (syntax-rules () 100 | [(_ (args ... . rest) body ...) (lambda (args ... . rest) body ...)] 101 | [(_) (error 'fn "Missing syntax")])) 102 | 103 | ;; Flow Control 104 | 105 | ; (IF test THEN do1 ELSE do2) 106 | ; (IF test THEN do) 107 | ; Basic conditional execution block 108 | (define-syntax if 109 | (syntax-rules (then else) 110 | [(_ test then do1 else do2) (cond [test do1] [else do2])] 111 | [(_ test then do) (when test do)])) 112 | 113 | (define-syntax-parameter then 114 | (lambda (stx) 115 | (raise-syntax-error (syntax-e stx) "then can only be used inside if"))) 116 | 117 | ; (FOR (var OVER list) body... [CARRY value] [BREAK [value]] 118 | ; Iterates over list in val, CARRYing value assigned from accumulator to next loop 119 | ; CRY contains the accumulator, initialized to '() 120 | ; thanks to chandler in #racket for the assistance 121 | (define-syntax-parameter carry 122 | (lambda (stx) 123 | (raise-syntax-error (syntax-e stx) "carry can only be used inside loops"))) 124 | (define-syntax-parameter cry 125 | (lambda (stx) 126 | (raise-syntax-error (syntax-e stx) "cry can only be used inside loops"))) 127 | (define-syntax-parameter in 128 | (lambda (stx) 129 | (raise-syntax-error (syntax-e stx) "in can only be used inside for"))) 130 | (define-syntax-parameter with 131 | (lambda (stx) 132 | (raise-syntax-error (syntax-e stx) "with can only be used inside for"))) 133 | 134 | (define-syntax for 135 | (syntax-rules (in with) 136 | [(_ (var in lst with x) body ...) 137 | (for-loop var lst x body ...)] 138 | [(_ (var in lst) body ...) 139 | (for-loop var lst '() body ...)])) 140 | 141 | (define-syntax-rule (for-loop var lst x body ...) 142 | (let/ec break-k 143 | (syntax-parameterize 144 | ((break (syntax-rules () 145 | [(_ ret) (break-k ret)] 146 | [(_) (break-k)]))) 147 | (let loop ((cry-v x) 148 | (l lst)) 149 | (syntax-parameterize 150 | ([cry (make-rename-transformer #'cry-v)]) 151 | (cond [(null? l) cry-v] 152 | [else (let ([var (car l)]) 153 | (loop 154 | (call/ec 155 | (lambda (k) 156 | (syntax-parameterize 157 | ([carry (make-rename-transformer #'k)]) 158 | body ...) 159 | cry-v)) 160 | (cdr l)))])))))) 161 | 162 | ; (DO body ...) 163 | ; (DO LOOP body ... [BREAK]) 164 | ; executes a block of code, looping with LOOP until it encounters a BREAK 165 | (define-syntax-parameter break 166 | (lambda (stx) 167 | (raise-syntax-error (syntax-e stx) "break can only be used inside loops"))) 168 | 169 | (define-syntax do 170 | (syntax-rules (loop with) 171 | [(_ loop with x body ...) 172 | (do-loop x body ...)] 173 | [(_ loop body ...) 174 | (do-loop '() body ...)] 175 | [(_ body ...) (begin body ...)])) 176 | 177 | (define-syntax-rule (do-loop x body ...) 178 | (let/ec break-k 179 | (syntax-parameterize 180 | ((break (syntax-rules () 181 | [(_ ret) (break-k ret)] 182 | [(_) (break-k)]))) 183 | (let loop ([cry-v x]) 184 | (syntax-parameterize 185 | ((cry (make-rename-transformer #'cry-v))) 186 | (loop 187 | (call/ec 188 | (lambda (k) 189 | (syntax-parameterize 190 | ((carry (make-rename-transformer #'k))) 191 | body ...) 192 | cry-v)))))))) 193 | 194 | ; (SELECT [test op1] ... [ELSE opn]) 195 | ; (SELECT CASE test [test-result op1] ... [else opn]) 196 | ; Multiple conditional block: COND-style, or CASE style with CASE. 197 | (define-syntax select 198 | (syntax-rules (case) 199 | [(select case expr ((result1 ...) op1) ... (else opn)) 200 | (rkt:case expr [(result1 ...) op1] ... (else opn))] 201 | [(select (test op1) ... (else opn)) 202 | (cond [test op1] ... (else opn))])) 203 | 204 | (define-syntax-parameter case 205 | (lambda (stx) 206 | (raise-syntax-error (syntax-e stx) "case can only be used with select"))) 207 | 208 | ;; I/O 209 | 210 | ; PRINT LIT -> print 211 | ; PRINT & -> display 212 | ; PRINT -> displayln 213 | (define-syntax print 214 | (syntax-rules (lit &) 215 | [(_ lit datum) (write datum)] 216 | [(_ & datum) (display datum)] 217 | [(_ datum) (displayln datum)] 218 | [(_) (newline)])) 219 | 220 | (define-syntax-parameter lit 221 | (lambda (stx) 222 | (raise-syntax-error (syntax-e stx) "lit can only be used with print"))) 223 | 224 | ; ? (shortcut for print) 225 | (define-syntax ? 226 | (syntax-rules () 227 | [(_ a ...) (print a ...)])) 228 | 229 | ; INPUT -> read-line (current-input-port) 230 | ; INPUT STX -> read 231 | (define-syntax input 232 | (syntax-rules (stx) 233 | [(_ stx str) (begin (display str) (read))] 234 | [(_ stx) (read)] 235 | [(_ str) (begin (display str) (read-line))] 236 | [(_) (read-line)])) 237 | 238 | (define-syntax-parameter stx 239 | (lambda (stx) 240 | (raise-syntax-error (syntax-e stx) "stx can only be used with input"))) 241 | 242 | ;; Strings 243 | 244 | ; (=$ str ...) 245 | ; Compares strings for equality 246 | (define-syntax =$ 247 | (syntax-id-rules () 248 | [(_ a b ...) (string=? a b ...)] 249 | [=$ string=?])) 250 | 251 | ; & str ... (string concat) 252 | ; Concats strings 253 | (define-syntax & 254 | (syntax-id-rules () 255 | [(& a b ...) (string-append a b ...)] 256 | [& string-append])) 257 | 258 | ; LIST$ list 259 | ; Converts a string into a list of single character strings 260 | (define (list$ l) 261 | (map string (string->list l))) 262 | 263 | ; (str$ *num*) 264 | ; Converts a printable value into a string 265 | (define (str$ n) 266 | (with-output-to-string 267 | (thunk (display n)))) 268 | 269 | ; (chr$ *num*) 270 | ; Converts an integer into a single-character string 271 | (define (chr$ n) 272 | (str$ (integer->char (int n)))) 273 | 274 | ;; Math 275 | 276 | ; ^ 277 | (def ^ expt) 278 | 279 | ; (mod x y) 280 | ; returns the modulo of x over y 281 | (def mod modulo) 282 | 283 | ; ! (infix operator) 284 | (define-syntax ! 285 | (syntax-rules () 286 | [(! a fun b) (fun a b)])) 287 | 288 | ; (int x) 289 | ; rounds x down 290 | (def int exact-truncate) 291 | 292 | ;; Lists 293 | 294 | ; JOIN a b 295 | ; Provided by Racket cons 296 | 297 | ; HEAD list 298 | ; Provided by Racket car 299 | 300 | ; TAIL list 301 | ; Provided by Racket cdr 302 | 303 | ;; Predicates 304 | ; Provided by racket 305 | ; LIST? l 306 | ; NULL? l 307 | ; ZERO? n 308 | ; EQ? a b ... 309 | ; = a b ... 310 | 311 | ; ATOM? a 312 | ; Tests a given item to see if it is an atom (ie. not a list) 313 | (define (atom? a) 314 | (and (not (pair? a)) (not (null? a)))) 315 | 316 | (define (lat? l) 317 | (cond 318 | [(null? l) #t] 319 | [(atom? (car l)) (lat? (cdr l))] 320 | [else #f])) 321 | 322 | ; (range x to y [step s]) 323 | ; Generates a list of numbers from x to y by step 324 | (define (gen-range x y (step 1) (lst '())) 325 | (cond 326 | [(= step 0) (error 'range "infinite loop detected")] 327 | [(or (and (> x y) (= 1 (sgn step))) 328 | (and (< x y) (= -1 (sgn step)))) (error 'range "Step does not iterate towards target")] 329 | [(= x y) (cons x lst)] 330 | [else (cons x (gen-range (+ x step) y step lst))])) 331 | 332 | (define-syntax range 333 | (syntax-rules (to step) 334 | [(_ x to y step s) (gen-range x y s)] 335 | [(_ x to y) (gen-range x y)] 336 | [(_) (error 'range "malformed range")])) 337 | 338 | (define-syntax-parameter to 339 | (lambda (stx) 340 | (raise-syntax-error (syntax-e stx) "to can only be used in range"))) 341 | (define-syntax-parameter step 342 | (lambda (stx) 343 | (raise-syntax-error (syntax-e stx) "step can only be used in range"))) 344 | 345 | ;; Meta Functions 346 | 347 | ; RUN 348 | ; Provided by Racket eval 349 | 350 | ; QUOTE 351 | ; Provided by Racket quote 352 | 353 | ; REM 354 | (define-syntax rem 355 | (syntax-rules () 356 | [(rem a ...) (void)])) 357 | 358 | ;; Boolean 359 | 360 | ; True 361 | (define-syntax True (syntax-id-rules (True) (True #t))) 362 | 363 | ; False 364 | (define-syntax False (syntax-id-rules (False) (False #f))) 365 | 366 | ; Null 367 | (define-syntax Null (syntax-id-rules (Null) (Null '()))) 368 | 369 | ; (one? n) 370 | ; Returns True if number is 1. 371 | (def fn one? (n) 372 | (= n 1)) 373 | 374 | ;; len, index, index*, and a new #%app (here called app) 375 | 376 | ; (len *lst*) 377 | ; Returns the number of items in the list 378 | (def fn len (lst) 379 | (select 380 | ((null? lst) 0) 381 | (else (+ 1 (len (tail lst)))))) 382 | 383 | ; (index *nth* *lst*) 384 | ; Returns the nth entry in lst. 1-indexed. 385 | (def fn index (nth lst) 386 | (select 387 | ((> nth (len lst)) (error 'index "out of index")) 388 | ((one? nth) (head lst)) 389 | (else (index (- nth 1) (tail lst))))) 390 | 391 | ; (index* *lst* . *dims*) 392 | ; Walks through nested lists according to dimensions and returns the indexed result 393 | (def fn index* (lst . dims) 394 | (select 395 | ((null? dims) lst) 396 | (else (apply index* (index (head dims) lst) (tail dims))))) 397 | 398 | (define-syntax app 399 | (syntax-parser 400 | [(app f-expr:expr arg:expr ...+) 401 | #'(let ([f f-expr]) 402 | (cond [(procedure? f) (f arg ...)] 403 | [(list? f) (index* f arg ...)] 404 | [else (f arg ...)]))] 405 | [(app f:expr arg/kw ...) 406 | #'(f arg/kw ...)])) 407 | 408 | 409 | 410 | 411 | -------------------------------------------------------------------------------- /lib/things.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../private/base.rkt" 2 | 3 | (require racket/stxparam 4 | "list.rkt" 5 | "require-stuff.rkt" 6 | "theory.rkt" 7 | "string.rkt" 8 | (only-in racket/base 9 | define-syntax 10 | gensym 11 | begin 12 | let* 13 | for/and 14 | case-lambda 15 | with-handlers 16 | struct 17 | exn:fail 18 | exn:fail? 19 | gen:custom-write 20 | write-string 21 | prop:procedure 22 | struct-field-index 23 | raise 24 | current-continuation-marks 25 | equal-hash-code) 26 | syntax/parse/define 27 | (for-syntax racket/base syntax/parse unstable/syntax)) 28 | 29 | (provide (all-defined-out)) 30 | 31 | (define-simple-macro (define-thing-literal-ids id:id ...) 32 | (begin (define-syntax-parameter id 33 | (lambda (stx) 34 | (raise-syntax-error #f "cannot be used outside a thing definition" stx))) 35 | ...)) 36 | 37 | (define-thing-literal-ids Self extends inherit super) 38 | 39 | (def (alist-ref alist fld) 40 | (head (tail (assoc fld alist)))) 41 | 42 | (define-simple-macro (def-field-id id:id ths:id) 43 | (define-syntax id 44 | (make-variable-like-transformer #'(ths 'id)))) 45 | 46 | (define-simple-macro (define-syntax-parser name:id opt-or-clause ...) 47 | (define-syntax name (syntax-parser opt-or-clause ...))) 48 | 49 | (define-simple-macro (build-type-list (field (type arg0 ...)) ...) 50 | (list 51 | `(field (,(partial type arg0 ...) (type arg0 ...))) ...)) 52 | 53 | (def fn empty-type-list (fields) 54 | (for (x in fields with Null) 55 | (carry (join `(,x (,any? (any?))) 56 | cry)))) 57 | 58 | (def fn get-type-pred (name types) 59 | (head (alist-ref types name))) 60 | 61 | (def fn get-type-name (name types) 62 | (head (tail (alist-ref types name)))) 63 | 64 | ; (describe *thing* (*field* *value*) ...) 65 | ; Declare a new kind of Thing, with the given fields and default values. 66 | (define-syntax-parser describe #:literals (extends inherit super) 67 | [(describe name:id extends super-thing:expr 68 | (~or (~optional (~seq inherit (inherit-id:id ...)) #:defaults ([(inherit-id 1) '()])) 69 | (~optional (~seq super ([super-id1:id super-id2:id] ...)) 70 | #:defaults ([(super-id1 1) '()] [(super-id2 1) '()]))) 71 | ... 72 | (field:id (type?:id arg0:expr ...) value:expr) ...) 73 | #'(def name (thing name extends super-thing inherit (inherit-id ...) super ([super-id1 super-id2] ...) 74 | (field (type? arg0 ...) value) ...))] 75 | [(describe name:id extends super-thing:expr 76 | (~or (~optional (~seq inherit (inherit-id:id ...)) #:defaults ([(inherit-id 1) '()])) 77 | (~optional (~seq super ([super-id1:id super-id2:id] ...)) 78 | #:defaults ([(super-id1 1) '()] [(super-id2 1) '()]))) 79 | ... 80 | (field:id value:expr) ...) 81 | #'(def name (thing name extends super-thing inherit (inherit-id ...) super ([super-id1 super-id2] ...) 82 | (field value) ...))] 83 | [(describe name:id (field:id (type?:id arg0:expr ...) value:expr) ...) 84 | #'(def name (thing name (field (type? arg0 ...) value) ...))] 85 | [(describe name:id (field:id value:expr) ...) 86 | #'(def name (thing name (field value) ...))]) 87 | 88 | (define-syntax-parser thing #:literals (extends inherit super) 89 | [(thing (~optional name:id #:defaults ([name #'thing])) (field:id (type?:id arg0:expr ...) value:expr) ...) 90 | #'(let ([types (build-type-list (field (type? arg0 ...)) ...)]) 91 | (make-thing `([field 92 | ,(let ([field 93 | (fn (ths) 94 | (syntax-parameterize ([Self (make-rename-transformer #'ths)]) 95 | (def-field-id field ths) ... 96 | value))]) 97 | field)] 98 | ...) 99 | 'name 100 | types))] 101 | [(thing (~optional name:id #:defaults ([name #'thing])) (field:id value:expr) ...) 102 | #'(make-thing `([field 103 | ,(let ([field 104 | (fn (ths) 105 | (syntax-parameterize ([Self (make-rename-transformer #'ths)]) 106 | (def-field-id field ths) ... 107 | value))]) 108 | field)] 109 | ...) 110 | 'name)] 111 | [(thing (~optional name:id #:defaults ([name #'thing])) extends super-thing:expr 112 | (~or (~optional (~seq inherit (inherit-id:id ...)) #:defaults ([(inherit-id 1) '()])) 113 | (~optional (~seq super ([super-id1:id super-id2:id] ...)) 114 | #:defaults ([(super-id1 1) '()] [(super-id2 1) '()]))) 115 | ... 116 | (field:id (type?:id arg0:expr ...) value:expr) ...) 117 | #'(let* ([super super-thing] 118 | [super-λlst (super λlst-sym)] 119 | [super-parents (super '__parents)] 120 | [super-ident (super '__ident)] 121 | [super-types (super '__types)] 122 | [types (alist-merge super-types (build-type-list (field (type? arg0 ...)) ...))]) 123 | (make-thing (alist-merge 124 | super-λlst 125 | `([field 126 | ,(let ([field 127 | (fn (ths) 128 | (syntax-parameterize ([Self (make-rename-transformer #'ths)]) 129 | (def-field-id field ths) ... 130 | (def-field-id inherit-id ths) ... 131 | (def super-id1 ((alist-ref super-λlst 'super-id2) ths)) ... 132 | value))]) 133 | field)] 134 | ...)) 135 | 'name 136 | types 137 | (join super-ident super-parents)))] 138 | [(thing (~optional name:id #:defaults ([name #'thing])) extends super-thing:expr 139 | (~or (~optional (~seq inherit (inherit-id:id ...)) #:defaults ([(inherit-id 1) '()])) 140 | (~optional (~seq super ([super-id1:id super-id2:id] ...)) 141 | #:defaults ([(super-id1 1) '()] [(super-id2 1) '()]))) 142 | ... 143 | (field:id value:expr) ...) 144 | #'(let* ([super super-thing] 145 | [super-λlst (super λlst-sym)] 146 | [super-parents (super '__parents)] 147 | [super-ident (super '__ident)] 148 | [super-fields (super 'fields)] 149 | [super-types (super '__types)] 150 | [types (alist-merge super-types 151 | (build-type-list (field (any?)) ...))]) 152 | (make-thing (alist-merge 153 | super-λlst 154 | `([field 155 | ,(let ([field 156 | (fn (ths) 157 | (syntax-parameterize ([Self (make-rename-transformer #'ths)]) 158 | (def-field-id field ths) ... 159 | (def-field-id inherit-id ths) ... 160 | (def super-id1 ((alist-ref super-λlst 'super-id2) ths)) ... 161 | value))]) 162 | field)] 163 | ...)) 164 | 'name 165 | types 166 | (join super-ident super-parents)))]) 167 | 168 | (def λlst-sym (gensym 'λlst)) 169 | (struct exn:bad-thing-ref exn:fail ()) 170 | (struct exn:thing-type-err exn:fail ()) 171 | 172 | ;; Wrapper struct for things. Provides custom printing while still behaving as procedure. 173 | (def fn thing-print (obj port mode) 174 | (let* ([thng (thing-s-proc obj)] 175 | [as-str (str$ (join (thing-s-name obj) (thng)))]) 176 | (write-string as-str port))) 177 | 178 | (struct thing-s (name proc) 179 | #:methods gen:custom-write 180 | [(def write-proc 181 | thing-print)] 182 | #:property prop:procedure 183 | (struct-field-index proc)) 184 | 185 | (def fn make-thing (λlst name [types Null] [parents Null] [ident (gensym 'thing)]) 186 | (let () 187 | (def this 188 | (fn args* 189 | (let* ([alst lst] 190 | [hash (equal-hash-code lst)] 191 | [fields (heads lst)] 192 | [type-list (if (null? types) then (empty-type-list fields) else types)]) 193 | (select 194 | [(null? args*) alst] 195 | [(eq? 'fields (head args*)) fields] 196 | [(eq? '__hash (head args*)) hash] 197 | [(eq? '__ident (head args*)) ident] 198 | [(eq? '__parents (head args*)) parents] 199 | [(eq? '__types (head args*)) type-list] 200 | [(eq? λlst-sym (head args*)) λlst] 201 | [(and (symbol? (head args*)) 202 | (assoc (head args*) alst)) (alist-ref alst (head args*))] 203 | [(list-of? list? (head args*)) 204 | (let ([new-lst (for (x in (head args*) with λlst) 205 | (let ([pred? (get-type-pred (head x) type-list)] 206 | [type (get-type-name (head x) type-list)]) 207 | (if (pred? (head (tail x))) 208 | then 209 | (carry (subst (head x) (fn (_) (head (tail x))) cry)) 210 | else 211 | (raise (exn:thing-type-err 212 | (format$ "Thing encountered type error in assignment: #_ must be #_" (head x) type) 213 | (current-continuation-marks))))))]) 214 | (make-thing new-lst name types parents ident))] 215 | [(list? (head args*)) 216 | (let recur ([λl λlst] 217 | [pat (head args*)] 218 | [c 1]) 219 | (select 220 | [(null? pat) (make-thing λl name types parents ident)] 221 | [(eq? (head pat) '*) (recur λl (tail pat) (+ 1 c))] 222 | [else 223 | (let* ([hd (head pat)] 224 | [pair (index c type-list)] 225 | [field (head pair)] 226 | [type (get-type-name field type-list)] 227 | [pred? (get-type-pred field type-list)]) 228 | (if (pred? hd) 229 | then 230 | (recur (subst (head (index c λl)) 231 | (fn (_) hd) 232 | λl) 233 | (tail pat) 234 | (+ 1 c)) 235 | else 236 | (raise (exn:thing-type-err 237 | (format$ "Thing encountered type error in assignment: #_ must be #_" field type) 238 | (current-continuation-marks)))))]))] 239 | [else (raise (exn:bad-thing-ref 240 | "Thing expected a valid symbol or a pattern" 241 | (current-continuation-marks)))])))) 242 | (def lst 243 | (map (fn (p) 244 | (list (index 1 p) ((index 2 p) this))) 245 | λlst)) 246 | (if (null? types) then (thing-s name this) else 247 | (do 248 | (for (x in lst) 249 | (let* ([val (head (tail x))] 250 | [field (head x)] 251 | [type (get-type-name field types)] 252 | [pred? (get-type-pred field types)]) 253 | (if (pred? val) 254 | then val 255 | else (raise (exn:thing-type-err 256 | (format$ "Thing encountered type error in declaration: #_ must be #_" field type) 257 | (current-continuation-marks)))))) 258 | (thing-s name this))))) 259 | 260 | (def (send thing method . args) 261 | (apply (thing method) args)) 262 | 263 | (define-simple-macro (send* obj-expr:expr (method:id arg ...) ...+) 264 | (let ([obj obj-expr]) 265 | (send obj 'method arg ...) 266 | ...)) 267 | 268 | (define-simple-macro (send+ obj-expr:expr msg:expr ...) 269 | (let* ([obj obj-expr] 270 | [obj (send* obj msg)] ...) 271 | obj)) 272 | 273 | ; (thing? v) 274 | ; Any -> Bool 275 | ; Returns True if value is a Thing 276 | (def fn thing? (v) 277 | (and (fn? v) 278 | (with-handlers ((exn:bad-thing-ref? (fn (e) False))) 279 | (and (list? (v)) 280 | (list? (v 'fields)) 281 | (v '__hash) 282 | (fn? (v '())))))) 283 | 284 | ; (is-a? Type Thing) 285 | ; Thing Thing -> Bool 286 | ; Returns True if Thing is the same type as Type 287 | (def fn is-a? (Type Thing) 288 | (and (thing? Type) 289 | (thing? Thing) 290 | (or (equal? (Type '__ident) 291 | (Thing '__ident)) 292 | (number? (inlst (Type '__ident) 293 | (Thing '__parents)))))) 294 | 295 | ; (thing=? thing1 thing2) 296 | ; Thing Thing -> Bool 297 | ; Returns True if both Things are the same type and their hash values are equal? 298 | (def fn thing=? (thing1 thing2) 299 | (and (is-a? thing1 thing2) 300 | (equal? (thing1 '__hash) 301 | (thing2 '__hash)))) 302 | 303 | ; (any? v) 304 | ; Any -> True 305 | ; Always returns True regardless of value 306 | (def fn any? (v) True) 307 | 308 | ; (list-of? pred? xs) 309 | ; Fn(Any -> Bool) List(Any) -> Bool 310 | ; Returns True of all elements in the list match pred? 311 | (def fn list-of? (pred? xs) 312 | (select 313 | ((null? xs) True) 314 | ((not (pred? (head xs))) False) 315 | (else (list-of? pred? (tail xs))))) 316 | 317 | ;; Placeholder values 318 | ;; These are simple values predefined for common primitive types, to provide more self-documenting default values for newly described things 319 | ;; Note that no error checking is actually performed, these are merely for documentation purposes 320 | ;; Placeholders that take an argument allow you to also specify what type is within the container, ie. (List Number) 321 | (def Any Null) 322 | (def String "") 323 | (def Number 0) 324 | (def Boolean False) 325 | (def Symbol 'default) 326 | (def Fn (fn (v) v)) 327 | (def Thing (thing)) 328 | (def fn List (type) (list type)) 329 | 330 | ;; alist-merge 331 | (def alist-merge 332 | (case-lambda 333 | [() '()] 334 | [(a) a] 335 | [(a b) 336 | (select 337 | [(null? b) a] 338 | [(null? a) b] 339 | [else (let* ([b.fst (head b)] 340 | [b.rst (tail b)] 341 | [a.hds (map head a)] 342 | 343 | [b.fst.fst (head b.fst)] 344 | [b.fst.rst (tail b.fst)]) 345 | (select 346 | [(inlst b.fst.fst a.hds) (alist-merge (subst* b.fst.fst b.fst.rst a) b.rst)] 347 | [else (alist-merge (append a (list b.fst)) b.rst)]))])] 348 | [(a b . rst) (apply alist-merge (alist-merge a b) rst)])) 349 | 350 | -------------------------------------------------------------------------------- /docs/heresy.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval 4 | racket/sandbox 5 | (for-label heresy 6 | (only-in racket/base require))) 7 | @(define (make-heresy-eval) 8 | (parameterize ([sandbox-output 'string] 9 | [sandbox-error-output 'string]) 10 | (make-evaluator 'heresy))) 11 | @(define-syntax-rule @myexamples[stuff ...] 12 | @examples[#:eval (make-heresy-eval) stuff ...]) 13 | @(define-syntax-rule @mytabular[[cell ...] ...] 14 | @tabular[#:sep @hspace[1] (list (list cell ...) ...)]) 15 | 16 | @title[#:style '(toc)]{The Heresy Programming Language} 17 | 18 | @author{Annaia Danvers} 19 | 20 | source code: @url["https://github.com/jarcane/heresy"] 21 | 22 | @defmodule[heresy #:lang] 23 | 24 | The Heresy language is a functional Lisp/Scheme dialect implemented in Racket, 25 | with syntax inspired by the BASIC family of programming languages. Its principle 26 | goals are to provide a simple core language for BASIC and other programmers to 27 | experiment with and learn how to program functionally. This document will detail 28 | the general philosophy of the Heresy language, such as exists, as well as the 29 | language syntax and functions. 30 | 31 | The Heresy language was created by Annaia Danvers with additional contributions 32 | from many others in the Racket community. 33 | 34 | Heresy and this documentation are Copyright (c) 2014 Annaia Danvers and 35 | released under the terms of the GNU LGPL. 36 | 37 | @table-of-contents[] 38 | 39 | @section[#:tag "rules"]{The Heresy Rules} 40 | 41 | The Heresy language is developed according to a few basic "ground rules," which 42 | the author and contributors attempt to follow in developing new features and 43 | functions for the language. These are as follows: 44 | 45 | @itemlist[ 46 | #:style 'ordered 47 | @item{@bold{Heresy is BASIC} - Heresy is inspired by BASIC, and aims to be at 48 | least somewhat easy for BASIC programmers to learn. Mostly this means we 49 | prefer BASIC names for functions over the Lisp name, and naming 50 | conventions like the $ for string functions.} 51 | @item{@bold{Heresy is a Lisp} - Heresy is still a Lisp, and loves simple syntax 52 | and s-expressions. While it makes use of some sugaring like literal 53 | keywords for certain common primitives, these are best used sparingly. 54 | Heresy is the Diet Coke of Evil, just one calorie, not quite evil enough.} 55 | @item{@bold{Heresy is functional} - Functional, but not Haskell. It is not 56 | intended solely as a vehicle for absolute functional purity. I love 57 | Haskell. You love Haskell. We don’t need to write another Haskell. Think 58 | more in terms of a lower-calorie, more intelligible Clojure.} 59 | @item{@bold{Heresy is for learning} - Heresy started as a learning project, a 60 | chance to learn how Lisp and functional programming really work on a 61 | practical level. I hope that, in time, it can be that for others as well, 62 | especially those who grew up with BASIC like myself and still sometimes 63 | struggle to get their head around the functional style. In particular, 64 | this means the Heresy-written portions of the source are generally 65 | written in as clear a manner as possible, as they are intended to be 66 | self-teaching.} 67 | @item{@bold{Heresy is an experiment} - Heresy is an experimental language. 68 | It’s very DNA is as a mad idea that came to life, and it’s development 69 | should be ready and willing to embrace new mad ideas and run with them. 70 | This is where carry came from, and I hope to have more mad ideas in the 71 | future.} 72 | @item{@bold{Heresy is for everyone} - As a statement of culture, the Heresy 73 | community welcomes the contribution of all people, who taste equally 74 | delicious to the jaws of mighty Cthulhu. No discrimination, harassment, 75 | or any other mistreatment of contributors on the basis of age, race, 76 | sexuality, or gender will @bold{ever} be tolerated by myself or anyone 77 | else who wishes to be part of this project.} 78 | ] 79 | 80 | @section[#:tag "syntax"]{Heresy Syntax and Conventions} 81 | 82 | Generally speaking, Heresy follows standard s-expression syntax as expected from 83 | any Lisp, being composed of parenthesized sequences of terms in Polish notation. 84 | Each sequence thus begins with an operator or function, and any number of 85 | arguments or additional s-expressions as needed. 86 | 87 | There are however a few exceptions to usual expectations in the case of certain 88 | special forms like @racket[for], @racket[def], and @racket[if]. These make use 89 | of additional literal terms as part of their syntax, to provide more clarity and 90 | similarity to BASIC-style syntax. 91 | 92 | In accordance with that goal, Heresy also follows certain naming conventions as 93 | a matter of style. Functions which produce a string value are appended with $, 94 | and in general where a naming conflict between two similar functions in 95 | Racket/Scheme and BASIC exists, prefer BASIC. 96 | 97 | When borrowing BASIC syntax and naming for use in Heresy, the author has 98 | generally relied chiefly on QBASIC and ECMA BASIC for reference. 99 | 100 | @section[#:tag "reference" #:style '(toc)]{Heresy Reference} 101 | 102 | The following sections describe the forms and functions of the Heresy programming language 103 | in more detail, subdivided by category for easier navigation. 104 | 105 | @local-table-of-contents[] 106 | 107 | @subsection[#:tag "declarations"]{Declarations} 108 | 109 | @defform[(def name value)]{ 110 | Defines a new variable of @racket[name] with the given @racket[value]. 111 | } 112 | 113 | @defform[#:link-target? #f #:literals (fn) 114 | (def fn name args body ...+) 115 | #:grammar ([args (arg ...) (arg ... . rest-id) args-id] 116 | [arg arg-id [arg-id default-expr]])]{ 117 | Defines a function of @racket[name], which when called evaluates its body 118 | expressions with the given list of arguments bound to local variables for use in 119 | the body of the function’s definition. Note that there are a number of 120 | additional options here for defining arguments. Default values can be ascribed 121 | to an argument by enclosing it in additional parentheses: 122 | @myexamples[ 123 | (def fn foo (x (y 1)) (+ x y)) 124 | (foo 3 4) 125 | (foo 5) 126 | ] 127 | Two patterns as well exist for taking an arbitrary number of values. The 128 | argument names list can be forgone entirely and substituted with a single name 129 | (generally args* by convention), which will then contain a list of any and all 130 | values passed to the function. The second method is the use of the dot (.) in 131 | the body of the arguments list followed by a single variable (usually called rest). 132 | @myexamples[ 133 | (def fn foo args* args*) 134 | (foo) 135 | (foo 3 4 5) 136 | (def fn bar (x y . rest) (join (+ x y) rest)) 137 | (bar 3 4) 138 | (bar 3 4 5 6 7 8) 139 | ]} 140 | 141 | @defform[#:link-target? #f #:literals (macro) 142 | (def macro name (pattern ...) template)]{ 143 | Defines a new macro with @racket[name]. A macro can best be thought of as a 144 | function which is not evaluated, but rather returns syntax to be evaluated in 145 | the form of a template. Each name described in the @racket[pattern] defines a 146 | "pattern variable" which can then be used in the body of the @racket[template] 147 | and will pass any syntax contained in that portion of the @racket[pattern] in 148 | the appropriate location matched in the @racket[template]. The elipsis 149 | @racket[...] can be used in a pattern to indicate repeatable values. 150 | } 151 | 152 | @defform*[#:link-target? #f #:literals (macroset) 153 | ((def macroset name [(name pattern ...) template] ...) 154 | (def macroset name (literal ...) [(name pattern ...) template] ...))]{ 155 | Similar to @racket[def macro], except that multiple matching patterns can be defined 156 | allowing for macros with variable syntax. Like @racket[def macro], the @racket[...] 157 | symbol can be used to indicate repeating values. 158 | } 159 | 160 | @defform[(let ((name value) ...) body ...+)]{ 161 | Binds the given name-value pairs for use in the local context created by the 162 | body of the expression. This is used to define local variables, such as are 163 | needed within a function. Note that local functions can potentially be assigned 164 | this way by storing anonymous functions, but there is a built-in syntax for 165 | defining a single such function, like so: 166 | @defform[#:link-target? #f (let proc-id ((name value) ...) body ...)]{ 167 | When let is called this way, it defines a local function proc (conventionally 168 | called recur), which can then be called from within the body of the let in order 169 | to perform local recursion; the name-value pairs thus act as arguments to the 170 | function proc. 171 | }} 172 | 173 | @defform[(fn (arg ...) body ...)]{ 174 | Creates an anonymous function with the given arguments, that evaluates its body 175 | when called. This is the lambda expression from other Lisps and functional 176 | languages, and a given fn can be passed as a value (as can named functions, for 177 | that matter) wherever called for. An anonymous function can also be evaluated 178 | directly in place by using it as the operator in an expression, like so: 179 | @myexamples[ 180 | ((fn (x y) (* x y)) 4 5) 181 | ]} 182 | 183 | @subsection[#:tag "conditionals"]{Conditionals and Loops} 184 | 185 | @defform[#:literals (then else) 186 | (if test then texpr else fexpr)]{ 187 | Evalutes @racket[test] and, if @racket[test] is @racket[True], evaluates 188 | @racket[texpr], otherwise it evaluates @racket[fexpr]. Note that only a single 189 | expression can be placed in each "slot" in the syntax; if you need to do 190 | multiple things, use a @racket[do] block. 191 | } 192 | 193 | @defform*[#:literals (else) 194 | [(select (test1 expr1) ...) 195 | (select (test1 expr1) ... (else fexpr))]]{ 196 | Given a list of test-expression pairs, evaluates the tests in order until it 197 | finds one which is @racket[True], and evaluates the matching expression. The 198 | @racket[else] expression is always true: if an else is found at the end of the 199 | select statement, its matching @racket[fexpr] will be evaluated. If no test in 200 | select is true, returns @|void-const|. 201 | } 202 | 203 | @defform*[#:link-target? #f #:literals (case else) 204 | [(select case texpr ((val ...) rexpr) ...) 205 | (select case texpr ((val ...) rexpr) ... (else fexpr))]]{ 206 | Evaluates @racket[texpr] and compares it to each @racket[val] in turn until it 207 | finds a value that is @racket[eq?] to the result of @racket[texpr]. If one is 208 | found, it evaluates the matching @racket[rexpr]. Like with @racket[select], 209 | @racket[else] is always considered True, and will therefore always evaluate its 210 | @racket[fexpr]. If no matching @racket[val] is found, @racket[select case] 211 | evaluates to @|void-const|. Note also that the @racket[(val ...)] is a list, and 212 | can contain as many values as is needed, such as in the following example: 213 | @myexamples[ 214 | (select case (* 2 3) 215 | ((2 3 4) (print "Nope.")) 216 | ((5 6 7) (print "Yup.")) 217 | (else (print "something is horribly wrong."))) 218 | ]} 219 | 220 | @defform*[#:literals (in with) 221 | [(for (var in list) body ...) 222 | (for (var in list with cry) body ...)]]{ 223 | Iterates over list evaluating its body with the head of list assigned to var, 224 | then recurs with the tail of list until it returns @racket[Null]. @racket[for] 225 | loops declare an implicit variable @racket[cry] which can be passed a value with 226 | @racket[carry]. They may also be interrupted with @racket[break]. See below for 227 | more details. 228 | } 229 | 230 | @defform[(do body ...)]{ 231 | Evaluates its @racket[body]s in order, returning the result of the final body 232 | expression. 233 | } 234 | 235 | @defform*[#:link-target? #f #:literals (loop with) 236 | [(do loop body ...) 237 | (do loop with cry body ...)]]{ 238 | Evaluates body repeatedly until a @racket[break] statement is encountered. 239 | Declares the implicit variable @racket[cry], which can be reassigned with the 240 | @racket[carry] operator. 241 | } 242 | 243 | @defform*[[(break) 244 | (break value)]]{ 245 | Breaks the continuation of a @racket[for] or @racket[do] loop evaluation. If 246 | provided a value, returns that value as the result of the loop. 247 | } 248 | 249 | @defform[(carry value)]{ 250 | When called in the body of a @racket[for] or @racket[do] loop expression, 251 | immediately begins the next iteration of the loop, and passes the given value to 252 | the implicit variable @racket[cry]. 253 | } 254 | 255 | @defidform[cry]{ 256 | Loops declare an internal variable called @racket[cry], which defaults to 257 | @racket[Null], and which is passed automatically to the next iteration of the 258 | loop, and is returned when the loop concludes. The value of @racket[cry] can be 259 | specified at the beginning of the loop with the optional @racket[with] 260 | parameter, and @racket[carry] can be used to pass a new value of @racket[cry] to 261 | the next iteration. 262 | } 263 | 264 | @subsection[#:tag "logic"]{Predicates and Logic} 265 | 266 | @defproc[(list? [v any]) boolean?]{ 267 | Returns True if @racket[v] is a list. 268 | } 269 | 270 | @defproc[(list-of? [pred? fn?] [xs list?]) boolean?]{ 271 | Returns True if @racket[pred?] is true for all elements in @racket[xs]. 272 | } 273 | 274 | @defproc[(null? [v any]) boolean?]{ 275 | Returns True if @racket[v] is @racket[Null], where Null is defined as the empty list 276 | @racket['()]. 277 | } 278 | 279 | @defproc[(number? [v any]) boolean?]{ 280 | Returns True if @racket[v] is a number. 281 | } 282 | 283 | @defproc[(zero? [v any]) boolean?]{ 284 | Returns True if @racket[v] = 0. 285 | } 286 | 287 | @defproc[(one? [v any]) boolean?]{ 288 | Returns True if @racket[v] = 1. 289 | } 290 | 291 | @defproc[(eq? [x any] [y any]) boolean?]{ 292 | Returns True if x and y are the same object. 293 | } 294 | 295 | @defproc[(equal? [x any] [y any]) boolean?]{ 296 | Returns True if x and y are equal. 297 | } 298 | 299 | @defproc[(symbol? [v any]) boolean?]{ 300 | Returns True if @racket[v] is a symbol: ie. a quoted name such as @racket['foo]. 301 | See @racket[quote] in @secref["syntax-and-evaluation"]. 302 | } 303 | 304 | @defproc[(string? [v any]) boolean?]{ 305 | Returns True if @racket[v] is a string. 306 | } 307 | 308 | @defproc[(fn? [v any]) boolean?]{ 309 | Returns True if @racket[v] is a function. 310 | } 311 | 312 | @defproc[(atom? [v any]) boolean?]{ 313 | Returns True if @racket[v] is an atom: ie. a number, symbol, or function, 314 | rather than a list or Null. 315 | } 316 | 317 | @defproc[(lat? [l any]) boolean?]{ 318 | Returns True if @racket[l] is a list composed solely of atoms. 319 | } 320 | 321 | @defproc[(any? [v any]) boolean?]{ 322 | Always returns True regardless of value of @racket[v]. 323 | } 324 | 325 | @defform[(and expr ...)]{ 326 | Returns True only if all given expressions are True. 327 | } 328 | 329 | @defform[(or expr ...)]{ 330 | Returns True if any given expression is True. 331 | } 332 | 333 | @defproc[(not [v any]) boolean?]{ 334 | Returns True if v is False, else returns False. 335 | } 336 | 337 | @defidform[else]{ 338 | A special keyword for True, used as a literal in conditional statements. 339 | } 340 | 341 | @defthing[True boolean?]{ 342 | The boolean truth value. Actually an alias for @racket[#t] in the Racket 343 | implementation. Note that, in Heresy, as in Racket, anything not explicitly 344 | False is considered True. 345 | } 346 | 347 | @defthing[False boolean?]{ 348 | The boolean false value. Actually an alias for @racket[#f] in the Racket 349 | implementation. 350 | } 351 | 352 | @defthing[Null null?]{ 353 | An alias for the empty list @racket['()]. 354 | } 355 | 356 | @subsection[#:tag "syntax-and-evaluation"]{Syntax and Evaluation} 357 | 358 | @defform*[[(quote v) 359 | @#,code{'v}]]{ 360 | "Quotes" the given @racket[v], without evaluating its contents. A quoted list is 361 | passed merely as data, a quoted atom is a "symbol" as per @racket[symbol?]. Can 362 | be shortened to @litchar{'}. 363 | } 364 | 365 | @defform*[[(quasiquote v) 366 | @#,code{`v}]]{ 367 | Same as @racket[quote], but can be "escaped" with the @racket[unquote] and 368 | @racket[unquote-splicing] syntax. Can be shortened to @litchar{`}. 369 | } 370 | 371 | @defform*[[(unquote v) 372 | @#,code{,v}]]{ 373 | When encountered within a a @racket[quasiquote]d block, evaluates @racket[v] and 374 | quotes its value instead. Can be shortened to @litchar{,}. 375 | } 376 | 377 | @defform*[[(unquote-splicing v) 378 | @#,code|{,@v}|]]{ 379 | Similar to @racket[unquote], but splices the result of evaluating @racket[v] in 380 | place. Can be shortened to @litchar|{,@}|. 381 | } 382 | 383 | @defproc*[([(error [message string?]) nothing] 384 | [(error [symbol symbol?] [message string?]) nothing])]{ 385 | Halts the program, returning an error of @italic{@tt{symbol: message}} where 386 | @racket[symbol] is a quoted value (customarily the name of the current function) 387 | and @racket[message] is a string. 388 | } 389 | 390 | @defproc[(run [form any]) any]{ 391 | Evaluates the given form. Usage is not recommended. 392 | } 393 | 394 | @defform[(rem any ...)]{ 395 | Ignores its arguments and returns void. Useful for block comments. 396 | } 397 | 398 | @defproc[(apply [fun fn?] [v any] ... [lst list?]) any]{ 399 | Applies @racket[fun] to the given arguments, as if it had been called with 400 | @racket[(fun v ... x ...)] where the @racket[x]s are the elements in @racket[lst]. 401 | } 402 | 403 | @subsection[#:tag "io"]{Input and Output} 404 | 405 | @defform*[#:literals (& lit) 406 | [(print v) 407 | (print & v) 408 | (print lit v) 409 | (print)]]{ 410 | Prints the given @racket[v] to the current output, or stdout if not otherwise 411 | specified, followed by a newline. @racket[(print & v)] outputs without a 412 | newline, while @racket[(print lit v)] outputs as a literal form that can be 413 | directly read back by @racket[(input stx ....)] as code. A bare @racket[(print)] 414 | merely prints a newline to the current output. 415 | } 416 | 417 | @defform[(? ....)]{ 418 | A shortened macro for print. 419 | } 420 | 421 | @defform*[#:literals (stx) 422 | [(input) 423 | (input stx) 424 | (input string) 425 | (input stx string)]]{ 426 | Reads a line of input from the current input, or stdin if not otherwise 427 | specified, and returns the value read as a string. @racket[(input stx ....)] 428 | instead reads a value using the standard reader, thus providing syntax which can 429 | be evaluated with @racket[run]. If additionally provided with a string, this 430 | will be output as a prompt to the current output. 431 | } 432 | 433 | @defform[(using io-port body ...)]{ 434 | Evaluates the body, with input/ouptut redirected to the given io-port. Only the 435 | @racket[file] port is supported at this time. 436 | } 437 | 438 | @defform[#:literals (as) 439 | (file name as mode)]{ 440 | Opens the file @racket[name] as the new target for input or output, depending on 441 | the @racket[mode] provided. @racket[mode] is a symbol, of one of the following: 442 | @mytabular[ 443 | [@racket['output] @elem{Opens file as the current output port. Will fail if 444 | file already exists.}] 445 | [@racket['rewrite] @elem{Opens file as the current output port, rewriting its 446 | contents if the file exists.}] 447 | [@racket['input] @elem{Opens file as the current input port.}]] 448 | } 449 | 450 | @defthing[eof eof-object?]{ 451 | A value (distinct from all other values) that represents an end-of-file. 452 | } 453 | 454 | @defproc[(eof? [v any?]) boolean?]{ 455 | Returns @racket[True] if @racket[v] is an @racket[eof] object. 456 | } 457 | 458 | @subsection[#:tag "lists"]{Lists} 459 | 460 | @defproc[(list [v any] ...) list?]{ 461 | Returns a list containing the given values. 462 | } 463 | 464 | @defproc[(join [a any] [b any]) pair?]{ 465 | Joins @racket[a] and @racket[b] into a pair. If @racket[b] is @racket[Null], a 466 | list is created containing @racket[a]. If @racket[b] is a list, @racket[a] is 467 | joined to the head of the list. 468 | } 469 | 470 | @defproc[(head [l list?]) any]{ 471 | Returns the head (first element) of the list @racket[l]. 472 | } 473 | 474 | @defproc[(tail [l list?]) any]{ 475 | Returns the remainder of list @racket[l] after the head. If the list has only 476 | one element, returns @racket[Null]. 477 | } 478 | 479 | @defform*[#:literals (to step) 480 | [(range start to finish) 481 | (range start to finish step n)]]{ 482 | Generates a list of numbers, incrementing from @racket[start] to @racket[finish] 483 | by @racket[n]. If no @racket[n] is provided, defaults to 1. Note that, unlike 484 | BASIC’s @tt{for x = y to z}, descending sequences where @racket[start] is 485 | greater than @racket[finish] can only be declared by including a negative n. 486 | Otherwise only @racket[Null] will be returned. 487 | } 488 | 489 | @defproc[(map [fun fn?] [l list?]) list?]{ 490 | Given a single-argument function @racket[fun], returns a list with @racket[fun] 491 | applied to each item in @racket[l]. 492 | } 493 | 494 | @defproc[(filter [fun fn?] [l list?]) list?]{ 495 | Given a predicate @racket[fun], returns a new list containing only those 496 | elements of @racket[l] for which @racket[fun] returns True. 497 | } 498 | 499 | @defproc[(len [l list?]) number?]{ 500 | Returns the number of items in @racket[l]. 501 | } 502 | 503 | @defproc[(foldr [fun fn?] [base any] [l list?]) any]{ 504 | Given a function @racket[fun] with two arguments, returns the cumulative result 505 | of @racket[fun] being applied to consecutive pairs, starting from @racket[base] 506 | and the rightmost element of @racket[l]. 507 | } 508 | 509 | @defproc[(foldl [fun fn?] [base any] [l list?]) any]{ 510 | Similar to @racket[foldr], except that it combines pairs from the left, starting 511 | with the head of @racket[l] and @racket[base]. 512 | } 513 | 514 | @defproc[(reverse [l list?]) list?]{ 515 | Returns a list with the order of @racket[l] reversed. 516 | } 517 | 518 | @defproc[(index [n number?] [l list?]) any]{ 519 | Returns the @racket[n]th entry of @racket[l], indexed from 1. 520 | } 521 | 522 | @defproc[(index* [l list?] [dims number?] ...) any]{ 523 | Walks through nested lists according to the given @racket[dims], essentially 524 | finding index recursively for an arbitrary number of dimensions. For example, 525 | given a nested list three lists deep, @racket[(index* l 2 3 1)] would return the 526 | 1st element of the third element of the 2nd lst, like so: 527 | @myexamples[ 528 | (def dave '(1 (2 3 (4 5)) 6)) 529 | (index* dave 2 3 1) 530 | ] 531 | Also, @racket[(l dims ...)] can be used as a shorthand for @racket[index*]: 532 | @myexamples[ 533 | (def dave '(1 (2 3 (4 5)) 6)) 534 | (dave 2 3 1) 535 | ]} 536 | 537 | @defproc[(inlst [item any] [l list?]) any]{ 538 | Searches @racket[l] for @racket[item], returning the index of @racket[item] if 539 | found, or @racket[False] if not. 540 | } 541 | 542 | @defproc[(left [l list?] [n number?]) list?]{ 543 | Returns a list of the leftmost @racket[n] elements of @racket[l]. 544 | } 545 | 546 | @defproc[(right [l list?] [n number?]) list?]{ 547 | Returns a list of the rightmost @racket[n] elements of @racket[l]. 548 | } 549 | 550 | @defproc[(mid [l list?] [idx number?] [n number?]) list?]{ 551 | Returns @racket[n] entries of @racket[l] starting from index @racket[idx]. 552 | } 553 | 554 | @defproc[(slice [l list?] [first number?] [last number? (len l)]) list?]{ 555 | Returns a slice of @racket[l], starting at @racket[first] and ending at 556 | @racket[last]. If @racket[last] is not provided, it defaults to the end of the 557 | list. 558 | } 559 | 560 | @defproc[(append1 [l1 list?] [l2 list?]) list?]{ 561 | Returns a list with @racket[l2] appended to the end of @racket[l1]. 562 | } 563 | 564 | @defproc[(append [l list?] ...) list?]{ 565 | Returns a list of the given @racket[l]s appended together in order. 566 | } 567 | 568 | @defproc[(assoc [tgt any] [l list?]) list-or-false?]{ 569 | Searches the heads of a list of lists @racket[l] and returns the first matching 570 | list or @racket[False]. 571 | } 572 | 573 | @defproc[(subst [tgt any] [new any] [l list?]) list-or-false?]{ 574 | Searches the heads of a list of lists @racket[l], and if it finds @racket[tgt], 575 | returns a new list with the tail of tgt substituted for a new list containing @racket[new]. Otherwise, 576 | returns @racket[False]. 577 | } 578 | 579 | @defproc[(subst* [tgt any] [new any] [l list?]) list-or-false?]{ 580 | Searches the heads of a list of lists @racket[l], and if it finds @racket[tgt], 581 | returns a new list with the tail of tgt substituted for @racket[new]. Otherwise, 582 | returns @racket[False]. For clarity's sake, the following examples may be more illustrative of the 583 | difference between @racket[subst] and @racket[subst*]. 584 | 585 | @myexamples[ 586 | (def alst '((foo 1) (bar 2))) 587 | (subst 'foo 3 alst) 588 | (subst 'foo '(3) alst) 589 | (subst* 'foo 3 alst) 590 | (subst* 'foo '(3) alst) 591 | ] 592 | } 593 | 594 | @defproc[(heads [l list?]) list?]{ 595 | Returns a list of the heads of a list of lists. 596 | } 597 | 598 | @defproc[(sort [fun fn?] [l list?]) list?]{ 599 | Sorts list @racket[l] according to the comparison function @racket[fun]. 600 | } 601 | 602 | @defproc[(zip [l1 list?] [l2 list?]) list?]{ 603 | Returns a new list of lists combining @racket[l1] and @racket[l2]. Excess length 604 | of either list is dropped. 605 | } 606 | 607 | @defproc[(zipwith [fun fn?] [l1 list?] [l2 list?]) list?]{ 608 | Returns a new list, combining the matching pairs of each list with @racket[fun]. 609 | Excess length of either list is dropped. 610 | } 611 | 612 | @defproc[(flatten [lst list?]) list?]{ 613 | Traverses a list, and flattens any nested lists into a single one-dimensional list. 614 | } 615 | 616 | @subsection[#:tag "strings"]{Strings} 617 | 618 | @defproc[(=$ [x string?] [y string?]) boolean?]{ 619 | Returns True if the two strings are equal. 620 | } 621 | 622 | @defproc[(& [str string?] ...) string?]{ 623 | Concatenates its arguments into a single string. 624 | } 625 | 626 | @defproc[(list$ [str string?]) string?]{ 627 | Returns a list of one-character strings from the given string. 628 | } 629 | 630 | @defproc[(str$ [n any?]) string?]{ 631 | Converts a value @racket[n] to a string. 632 | } 633 | 634 | @defproc[(chr$ [n number?]) string?]{ 635 | Converts a given number @racket[n] to single-character string. If the number is not an 636 | integer it will first be coerced to one with @racket[int]. 637 | } 638 | 639 | @defproc[(empty$? [str string?]) boolean?]{ 640 | Returns True if the string is empty (@racket[""]). 641 | } 642 | 643 | @defproc[(len$ [str string?]) number?]{ 644 | Returns the length of the string, indexed from 1. 645 | } 646 | 647 | @defproc[(list& [l list?]) string?]{ 648 | Given a list of strings, returns a single concatenated string. 649 | } 650 | 651 | @defproc[(head$ [str string?]) string?]{ 652 | Returns the head (first character) of the string. 653 | } 654 | 655 | @defproc[(tail$ [str string?]) string?]{ 656 | Returns the tail (remaining characters) of the string, unless @racket[str] is 657 | empty, in which case it returns the empty string. 658 | } 659 | 660 | @defproc[(left$ [str string?] [n number?]) string?]{ 661 | Returns a string of the leftmost @racket[n] characters of @racket[str]. 662 | } 663 | 664 | @defproc[(right$ [str string?] [n number?]) string?]{ 665 | Returns a string of the rightmost @racket[n] characters of @racket[str]. 666 | } 667 | 668 | @defproc[(mid$ [str string?] [idx number?] [len number?]) string?]{ 669 | Returns a section of @racket[str], @racket[len] characters long, beginning at 670 | @racket[idx]. 671 | } 672 | 673 | @defproc[(slice$ [str string?] [start number?] [finish number? (len$ str)]) string?]{ 674 | Returns a slice of @racket[str] beginning at @racket[start] and ending at 675 | @racket[finish]. If not specified, @racket[finish] defaults to the length of the 676 | string. 677 | } 678 | 679 | @defproc[(instr [str string?] [search string?]) number-or-false?]{ 680 | Returns the index of the first instance of @racket[search] in @racket[str], or 681 | False if not found. 682 | } 683 | 684 | @defproc[(split [str string?] [delimiters list? '(" ")]) list?]{ 685 | Returns a list of string sections split at the given delimiters. If 686 | @racket[delimiters] is not specified, defaults to space (@racket[" "]). 687 | } 688 | 689 | @defproc[(format$ [template string?] [value any?] ...) string?]{ 690 | Given a string template, returns a new string with instances of glyph @racket["#_"] replaced 691 | in order, starting with the first value given following the string. 692 | } 693 | 694 | @subsection[#:tag "math"]{Math} 695 | 696 | @defproc[(+ [x number?] ...) number?]{ 697 | Adds the given numbers left to right and returns the result. If only one argument is given, 698 | returns the argument. If no arguments are provided, returns 0. 699 | } 700 | 701 | @defproc*[([(- [x number?] [y nuber?] ...+) number?] 702 | [(- [x number?]) number?])]{ 703 | Subtracts the given numbers left to right and returns the result. If only one 704 | argument is given, returns @racket[(- 0 x)]. 705 | } 706 | 707 | @defproc*[([(/ [x number?] [y number?] ...+) number?] 708 | [(/ [x number?]) number?])]{ 709 | Divides the numbers from left to right and returns the result. If only one 710 | argument is given, returns @racket[(/ 1 x)]. 711 | } 712 | 713 | @defproc[(* [x number?] ...) number?]{ 714 | Multiplies the numbers given from left to right and returns the result. If no 715 | argument is given, returns one. If one argument is given, returns the argument. 716 | } 717 | 718 | @defproc[(= [x number?] [y number?] ...) boolean?]{ 719 | Returns True if all the numbers are numerically equal. 720 | } 721 | 722 | @defproc[(< [x number?] [y number?] ...) boolean?]{ 723 | Returns True if all arguments are greater than the one previous going right 724 | (ie, x < y < z, etc.) 725 | } 726 | 727 | @defproc[(> [x number?] [y number?] ...) boolean?]{ 728 | Returns True if all arguments are less than the one previous going right 729 | (ie, x > y > z, etc.) 730 | } 731 | 732 | @defthing[pi number?]{ 733 | A bound variable containing the 64-bit floating point value of pi. 734 | } 735 | 736 | @defthing[e number?]{ 737 | A bound variable containing the 64-bit floating point value of Euler’s number. 738 | } 739 | 740 | @defproc[(mod [x number?] [y number?]) number?]{ 741 | Returns the modulus of @racket[x] divided by @racket[y]. 742 | } 743 | 744 | @defproc[(abs [n number?]) number?]{ 745 | Returns the absolute value of @racket[n]. 746 | } 747 | 748 | @defproc[(even? [n number?]) boolean?]{ 749 | Returns True if @racket[n] is even. 750 | } 751 | 752 | @defproc[(odd? [n number?]) boolean?]{ 753 | Returns True if n is odd. 754 | } 755 | 756 | @defproc[(sgn [n number?]) number?]{ 757 | Returns @racket[-1] if @racket[n] is negative, @racket[0] if @racket[n] is zero, 758 | and @racket[1] if @racket[n] is positive. 759 | } 760 | 761 | @defproc[(inc [n number?]) number?]{ 762 | Returns the value of @racket[(+ n 1)]. 763 | } 764 | 765 | @defproc[(dec [n number?]) number?]{ 766 | Returns the value of @racket[(- n 1)]. 767 | } 768 | 769 | @defproc[(exp [x number?]) number?]{ 770 | Returns the value of @elem{@racket[e]@superscript{@racket[x]}}. 771 | } 772 | 773 | @defproc[(sin [x number?]) number?]{ 774 | Returns the sine of @racket[x] as a floating point value. 775 | } 776 | 777 | @defproc[(cos [x number?]) number?]{ 778 | Returns the cosine of @racket[x] as a floating point value. 779 | } 780 | 781 | @defproc[(tan [x number?]) number?]{ 782 | Returns the tangent of @racket[x] as a floating point value. 783 | } 784 | 785 | @defproc[(int [x number?]) number?]{ 786 | Returns the value of @racket[x], rounded to a whole number, rounded down. 787 | } 788 | 789 | @subsection[#:tag "random"]{Random Numbers} 790 | 791 | Heresy’s random number generator operates slightly differently to traditional 792 | BASIC's, in order to offer a more functional approach. Rather than defining a 793 | single global seed which the RND function then refers to, Heresy's 794 | @racket[randomize] returns a "generator" function with a given seed, allowing 795 | one to name and seed as many generators as one needs, though for practical 796 | purposes a default RND is still provided which is automatically created and 797 | seeded with a derivation of the current time in milliseconds. 798 | Heresy's RNG employs a fairly strong 64ish-bit Xorshift* algorithm, though no 799 | guarantees are offered as to its cryptographic security. 800 | 801 | @defproc[(randomize [seed any/c timer]) fn?]{ 802 | Returns a new generator function initialized with @racket[seed], which is first 803 | passed through @racket[equal-hash-code]. If no @racket[seed] is provided, defaults 804 | to @racket[timer]. 805 | } 806 | 807 | @defproc[(rnd) number?]{ 808 | A pre-defined generator which returns a random number between @racket[0] and 809 | @racket[1], exclusive, seeded by @racket[timer]. 810 | } 811 | 812 | @defthing[timer number?]{ 813 | A special internal variable which contains the current time in milliseconds. 814 | } 815 | 816 | @subsection[#:tag "things"]{Things} 817 | 818 | Things are Heresy's definable data structures. Unlike the objects of most 819 | object-oriented languages, which often exist to hold and carry mutable state and 820 | actions with which to change that state, Things are immutable. A Thing, once 821 | sprung to life, cannot itself be altered, but can be called with the correct 822 | syntax to return a new Thing with different internal values for its internal 823 | data fields. 824 | 825 | Things are essentially functions, lambdas specifically, with predefined syntax 826 | arguments. They are first class values, and can be passed freely just as any 827 | other data, but can also be passed arguments to either return the values of 828 | their fields, return a new Thing, or to employ any functions contained within 829 | the thing. 830 | 831 | Things can also optionally be given 832 | @italic{@hyperlink["http://wiki.c2.com/?PredicateTypes"]{predicate types}}. Predicate typing is 833 | a form of typing in which types are defined by a predicate function, in other words 834 | a function which given a value, will return either true or false. In this way, 835 | any kind of type validation can be specified so long as it can be programmed as a 836 | function which returns a Boolean value. Things check their values against these types 837 | at both declaration, when the object is first described or instantiated, and at 838 | assignment of new values, ie. when the copy syntax is used to generate a new thing 839 | from the old one. If you attempt to describe or copy a thing whose values do not match 840 | its predicate types, the program will throw an error and indicate what field did not 841 | match its type. 842 | 843 | @defform*[#:literals (extends inherit) 844 | [(describe Name) 845 | (describe Name (field [(type? args ...)] value) ...) 846 | (describe Name 847 | extends super-thing 848 | (field [(type? args ...)] value) ...) 849 | (describe Name 850 | extends super-thing 851 | inherit (id ...) 852 | (field [(type? args ...)] value) ...)]]{ 853 | Defines a new type of Thing, given @racket[Name]. By convention, Things are 854 | generally named in uppercase, though this is not required by the syntax. Each 855 | field is an internal name and external symbol, which is mapped to the given 856 | value. Anonymous functions (@racket[fn]) can be assigned as values to Thing 857 | fields, and those functions can access the fields of the Thing by name. 858 | 859 | Optionally, after the field name, a type predicate can be provided. Type 860 | predicates are automatically "curried", ie. treated as a partial function 861 | with the initial arguments following the given @racket[type?], and expecting 862 | the result to be a single argument function that returns @racket[True] or 863 | @racket[False]. Things which are not given a type are automatically given 864 | the type @racket[any?], which returns @racket[True] for any value. 865 | 866 | If the @racket[extends] option is provided, the new Thing extends 867 | @racket[super-thing], inheriting it's fields and methods (unless they are 868 | overridden). If the @racket[inherit] option is provided with it, then the 869 | @racket[id]s are available as bindings within the method expressions. Typed 870 | things can be extended from untyped things and vice versa; the fields from 871 | the parent will inherit their types from the parent, unless overridden by 872 | creating a new field with the same name and a new type signature (or no 873 | signature, as the case may be). Note that parent things are @italic{never} 874 | modified by their children. 875 | 876 | @myexamples[ 877 | (describe Project 878 | (name "Destroy the world") 879 | (id 90) 880 | (budget 432000000)) 881 | (Project 'budget) 882 | (describe Employee 883 | (name (string?) "Dave") 884 | (id (number?) 42) 885 | (dept (symbol?) 'it) 886 | (projects (list-of? number?) '(23 90 45))) 887 | (Employee 'name) 888 | (Employee '(* * "sales" *)) 889 | (def fn age-req? (age) (and (< 17 age) (> 45 age))) 890 | (describe Henchman extends Employee 891 | (weapon (symbol?) 'AK-47) 892 | (age (age-req?) 64)) 893 | ] 894 | } 895 | 896 | @defform*[#:literals (extends inherit) 897 | [(thing) 898 | (thing (field [(type? args ...)] value) ...) 899 | (thing extends super-thing 900 | (field [(type? args ...)] value) ...) 901 | (thing extends super-thing 902 | inherit (id ...) 903 | (field [(type? args ...)] value) ...)]]{ 904 | Just like @racket[fn] produces an anonymous function, @racket[thing] produces an 905 | anonymous Thing. 906 | } 907 | 908 | If there is a Thing defined as @defidentifier[#'Name]: 909 | @defform*[#:kind "" #:link-target? #f 910 | [(Name) 911 | (Name symbol) 912 | (Name @#,racket['fields]) 913 | (Name alist) 914 | (Name pattern)]]{ 915 | Once a Thing has been described or bound to a name by other means, that Name is 916 | bound locally as a function, and can thus be called with special syntax to 917 | return its contents or to return a new copied Thing. In more detail, these 918 | syntaxes are as follows: 919 | 920 | @defform[#:kind "" #:link-target? #f (Name)]{ 921 | Returns an association list containing the contents of the Thing, ie. a list in 922 | the form of: @racket['((field value) ...)] 923 | } 924 | 925 | @defform[#:kind "" #:link-target? #f (Name @#,racket['fields])]{ 926 | Returns a list of symbols for the fields contained within the Thing. Note that 927 | the symbol @racket['fields] takes precedent over the field names within, in 928 | order to prevent overwriting this syntax. 929 | } 930 | 931 | @defform[#:kind "" #:link-target? #f (Name symbol)]{ 932 | Returns the value of the field associated with @racket[symbol], the quoted 933 | form of the field name described when the Thing type was first declared. Will 934 | return an error if no such named field is found. If the value associated with 935 | symbol is a function, this expression can be used as the operating function of 936 | a further expression like so: 937 | @myexamples[ 938 | (describe Lord-Cthulhu (eat (fn (x) (print (& "Devours " x))))) 939 | ((Lord-Cthulhu 'eat) "Dave") 940 | ]} 941 | 942 | @defform[#:kind "" #:link-target? #f (Name alist) 943 | #:grammar ([alist @#,racket[`(@#,racketvarfont{pair} ...)]] 944 | [pair @#,racket[`(@#,racketvarfont{field} @#,racketvarfont{value})]])]{ 945 | Returns a copy of the Thing, with new values assigned to the fields as indicated by 946 | the provided associative list. All values not listed will copy over their values intact. 947 | The copy will type-check the values of each field assigned. 948 | 949 | @myexamples[ 950 | (describe Beeb (model (symbol?) 'B) (ram (number?) 32) (cpu (string?) "m6502")) 951 | (def BeebPlus (Beeb '((model B+) (ram 64)))) 952 | (BeebPlus) 953 | ] 954 | } 955 | 956 | @defform[#:kind "" #:link-target? #f (Name pattern) 957 | #:grammar ([pattern @#,racket[`(@#,racketvarfont{sub-pat} ...)]] 958 | [sub-pat * value])]{ 959 | Returns a copy of the Thing, with new values according to the pattern passed to 960 | the original Thing. @racket[pattern] must be a quoted list of either 961 | @racket['*]s or values, in order according to the fields of the Thing as 962 | originally defined (so the first @racket[sub-pat] matches the first 963 | field, the second to the second field, and so on). A @racket['*] in a field 964 | indicates that the value is copied in-tact, while a value becomes the new value 965 | of the field in that position. For example: 966 | @myexamples[ 967 | (describe Santa 968 | (size 'fat) 969 | (sleigh 'ready) 970 | (sack 'full)) 971 | (def Santa-after-Christmas (Santa `(* * empty))) 972 | (Santa-after-Christmas) 973 | ]}} 974 | 975 | @defproc[(send [Thing thing?] [symbol symbol?] [arg any] ...) any]{ 976 | An alternate syntax for accessing functions within Things, send calls the 977 | function named by @racket[(Thing symbol)] with the given arguments and returns 978 | the result. 979 | } 980 | 981 | @defproc[(thing? [v any?]) boolean?]{ 982 | Returns @racket[True] if @racket[v] "looks like" a Thing, or @racket[False] if it doesn't. 983 | @racket[thing?] employs a duck-typing method, checking the object for the expected 984 | properties of a Thing, so it is possible, albeit unlikely, to fool it. Specifically 985 | it checks first if @racket[v] is a @racket[fn?], then checks the returns for the default 986 | internal methods of all Things, and its internal hash value. 987 | } 988 | 989 | @defproc[(is-a? [Type thing?] [Thing thing?]) boolean?]{ 990 | Returns @racket[True] if @racket[Thing] is an instance of @racket[Type]. This 991 | will return @racket[True] if @racket[Thing] is the same kind as @racket[Type], or 992 | if @racket[Thing] is derived from @racket[Type], as by @racket[extends]. This is done by 993 | comparing the internal @racket['__ident] field of @racket[Type] to both the @racket['__ident] 994 | and @racket['__parents] fields of @racket[Thing]. 995 | } 996 | 997 | @defproc[(thing=? [thing1 thing?] [thing2 thing?]) boolean]{ 998 | Returns @racket[True] if @racket[thing1] and @racket[thing2]'s fields are @racket[equal?] 999 | to each other, according to the internal hash values generated from their fields, after first 1000 | checking that both things are the same type according to @racket[is-a?]. 1001 | } 1002 | 1003 | @defform[(Self ....)]{ 1004 | @racket[Self] is the self-referring identifier for a Thing, allowing for 1005 | functions within Things to call the Thing itself. Note that if it is only the 1006 | values of the other fields, this is not necessary, as fields are defined as 1007 | local names within the context of the Thing, and thus can be referred to simply 1008 | by name. 1009 | } 1010 | 1011 | @defidform[extends]{can only be used within a @racket[describe] or @racket[thing] form.} 1012 | @defidform[inherit]{can only be used within a @racket[describe] or @racket[thing] form.} 1013 | 1014 | @subsection[#:tag "theory"]{Theory} 1015 | 1016 | @defproc[(Y [fn fn?]) fn?]{ 1017 | The strict Y fixed-point combinator. Allows for recursion of anonymous 1018 | functions. Given a @racket[fn1] which contains a single named argument, and 1019 | within which is an additional single-argument @racket[fn2], the innermost 1020 | @racket[fn2] can call the named argument of @racket[fn1] as if it were a 1021 | function name in order to recur on itself. For example, the factorial function 1022 | can be defined thusly, using the Y-combinator: 1023 | @myexamples[ 1024 | (def Fact 1025 | (Y 1026 | (fn (fact) 1027 | (fn (n) 1028 | (if (zero? n) 1029 | then 1 1030 | else (* n (fact (- n 1)))))))) 1031 | ] 1032 | Note however that usage of the Y-combinator for recursion is not especially 1033 | efficient, and the more traditional recursive approach is generally recommended 1034 | whenever possible (which is most of the time). 1035 | } 1036 | 1037 | @defproc[(Y* [fn fn?]) fn?]{ 1038 | A generalization of the Y-combinator that allows the function to take any number 1039 | of arguments. 1040 | } 1041 | 1042 | @defform[(fnlet name args body ...+)]{ 1043 | Equivalent to @racket[(Y* (fn (name) (fn args body ...)))]. 1044 | For example, to map the Fibonacci sequence without 1045 | defining a named function to do it: 1046 | @myexamples[ 1047 | (map (fnlet fib (n) 1048 | (select 1049 | ((zero? n) 0) 1050 | ((one? n) 1) 1051 | (else (+ (fib (- n 2)) (fib (- n 1)))))) 1052 | (range 0 to 20)) 1053 | ]} 1054 | 1055 | @defproc[(partial [fun fn?] [arg any] ...) fn?]{ 1056 | Returns a function with the @racket[arg]s partially applied to @racket[fun], 1057 | which can then be passed the remaining arguments, as many as needed to complete 1058 | the calculation. For example: 1059 | @myexamples[ 1060 | (map (partial + 2) (range 1 to 4)) 1061 | ]} 1062 | 1063 | @defproc[(compose [fn1 fn?] [fn2 fn?]) fn?]{ 1064 | Returns a new function which is a composition of @racket[fn1] and @racket[fn2]. 1065 | This function evaluates @racket[fn2] with its arguments, and then applies 1066 | @racket[fn1] to the result of @racket[fn2]. 1067 | @myexamples[ 1068 | (def abs-sub (compose abs -)) 1069 | (abs-sub 4 5) 1070 | ]} 1071 | 1072 | @defproc[(identity [v any?]) any?]{ 1073 | Returns @racket[v]. 1074 | } 1075 | 1076 | @subsection[#:tag "pipes"]{Pipe/Threading Operators} 1077 | 1078 | @defproc[(:> [initial-value any] [fns fn?] ...) any]{ 1079 | The forward pipe operator. Given a value and a series of single-argument functions, 1080 | applies them in order from left to right and returns the resulting value. 1081 | @myexamples[ 1082 | (:> 5 inc dec sgn) 1083 | ] 1084 | } 1085 | 1086 | @defform[(f> fun args* ...)]{ 1087 | A currying macro. Expands into an anonymous function that takes a single argument, 1088 | and inserts it as the first argument of @racket[fun], followed by the remaining 1089 | @racket[args*]. 1090 | @myexamples[ 1091 | (:> '(1 2) (f> append '(3 4))) 1092 | ] 1093 | } 1094 | 1095 | @defform[(l> fun args* ...)]{ 1096 | The inverse of @racket[f>]. Returns a function whose argument is placed as the last 1097 | argument to the given @racket[fun]. 1098 | @myexamples[ 1099 | (:> '(1 2) (l> append '(3 4))) 1100 | ] 1101 | } 1102 | 1103 | @defform[(-> initial-value (fun args* ...) ...)]{ 1104 | The first-argument threading macro. Works similarly to @racket[:>], except that it 1105 | automatically applies @racket[f>] to each listed form following the initial value. 1106 | @myexamples[ 1107 | (-> '(1 2 3 4) 1108 | (left 2) 1109 | (append '(a b)))] 1110 | } 1111 | 1112 | @defform[(->> initial-value (fun args* ...) ...)]{ 1113 | The last-argument (as in @racket[l>]) version of @racket[->]. 1114 | @myexamples[ 1115 | (->> '(1 2 3 4) 1116 | (map (fn (x) (* x x))) 1117 | (append '(a b))) 1118 | ] 1119 | } 1120 | 1121 | @subsection[#:tag "holes"]{Holes} 1122 | 1123 | Holes are a simple mutable data structure based on Racket boxes, with an API inspired by 1124 | Clojure's atoms. Their purpose is to provide an in-memory data store that is treated as a 1125 | first-class value, which thus can be bound to a value or passed to functions. They can also 1126 | be useful for providing a source of shared program state. 1127 | 1128 | @defproc[(hole [v any?]) hole?]{ 1129 | Creates a hole containing @racket[v]. 1130 | } 1131 | 1132 | @defproc[(hole? [v any?]) boolean?]{ 1133 | Returns @racket[True] if @racket[v] is a hole. 1134 | } 1135 | 1136 | @defproc[(deref [hol hole?]) any?]{ 1137 | Returns the current value contained within @racket[hol]. 1138 | } 1139 | 1140 | @defproc[(reset [hol hole?] [new-val any?]) hole?]{ 1141 | Resets the current value of @racket[hol] to @racket[new-val], returning the hole. 1142 | } 1143 | 1144 | @defproc[(update [hol hole?] [fn fn?] [args any?] ...) hole?]{ 1145 | Resets the current value of @racket[hol] to the result if applying @racket[fn] to the current 1146 | value of @racket[hol], followed by @racket[args], ie. @racket[(apply f curr-val args)]. 1147 | } 1148 | 1149 | @defform[(reset-thing [hol hole?] (field value) ...)]{ 1150 | Resets the fields of a Thing contained in @racket[hol] to the values provided, and returns 1151 | the hole. 1152 | } 1153 | 1154 | @defproc[(hole-bind [hol hole?] [fn fn?]) any?]{ 1155 | Applies @racket[fn] to the value contained by @racket[hol]. The monadic bind (>>=) operator for holes. 1156 | } 1157 | 1158 | @defproc[(hole-guard [test boolean?]) any?]{ 1159 | The monadic guard operator for holes. Primarily of use for the @racket[hole-do] DSL. 1160 | } 1161 | 1162 | @subsection[#:tag "maybe"]{Maybe} 1163 | 1164 | Maybe is an "option type", similar to that found in languages like Scala, Haskell, and Rust. It 1165 | allows for safe return from a function that might not return a result, without relying on @racket[Null]. 1166 | A Maybe can be either a Some containing a value, or the empty thing None. Maybe is implemented 1167 | as a heirarchy of things, and the usual thing functions and behaviors apply to them, but a number 1168 | of helper functions have also been provided for easier use with them. 1169 | 1170 | @defthing[Maybe thing? #:value (thing)]{ 1171 | The parent object of the Maybe family. 1172 | } 1173 | 1174 | @defthing[Some maybe? #:value (thing extends Maybe (contains Null))]{ 1175 | The thing for a Maybe containing a value. Child of @racket[Maybe]. 1176 | } 1177 | 1178 | @defthing[None maybe? #:value (thing extends Maybe)]{ 1179 | The empty value, for a Maybe that contains no value. 1180 | } 1181 | 1182 | @defproc[(some [v any?]) is-some?]{ 1183 | Returns @racket[v] wrapped in @racket[Some]. 1184 | } 1185 | 1186 | @defproc[(is-some? [opt any?]) boolean?]{ 1187 | Returns @racket[True] if @racket[opt] is @racket[Some]. 1188 | } 1189 | 1190 | @defproc[(is-none? [opt any?]) boolean?]{ 1191 | Returns @racket[True] if @racket[opt] is @racket[None]. 1192 | } 1193 | 1194 | @defproc[(maybe? [opt any?]) boolean?]{ 1195 | Returns @racket[True] if @racket[opt] is a @racket[Maybe]. 1196 | } 1197 | 1198 | @defproc[(maybe-bind [opt maybe?] [fn fn?]) (or is-none? any?)]{ 1199 | The bind operator for @racket[Maybe]. Returns @racket[None] if @racket[opt] is @racket[None], 1200 | or if it is @racket[Some], returns the result of @racket[fn] applied to the value field of 1201 | @racket[Some]. 1202 | } 1203 | 1204 | @defproc[(get-some [opt maybe?]) (or is-none? any?)]{ 1205 | If @racket[opt] is @racket[Some], returns the value it contains, or else @racket[None]. 1206 | } 1207 | 1208 | @defproc[(maybe-map [fn fn?] [opt maybe?]) maybe?]{ 1209 | Returns the result of @racket[fn] applied to the value contained in @racket[opt]. 1210 | } 1211 | 1212 | @defproc[(maybe-filter [pred? fn?] [opt maybe?]) maybe?]{ 1213 | If @racket[pred?] is true for the value contained in @racket[opt], returns @racket[opt], 1214 | else returns @racket[None]. 1215 | } 1216 | 1217 | @defproc[(maybe-guard [test boolean?]) maybe?]{ 1218 | The monad guard operator for maybe. If @racket[test] is true, returns @racket[(some Null)], 1219 | else returns @racket[None]. 1220 | } 1221 | 1222 | @subsection[#:tag "monad-do"]{Monads and Do Notation} 1223 | 1224 | @racket[monad-do] provides a generic, specializable DSL for handling monadic values, inspired by 1225 | Haskell's do notation and Scala's for comprehensions. @racket[monad-do] itself is generic, 1226 | expecting the provision of functions for the bind (@racket[>>=]), return, and guard operators, but 1227 | individual types can easily layer over this with a simple macro to provide a specialized version 1228 | of the DSL for a particular data type. 1229 | 1230 | @defform/subs[#:literals (<- = if yield) 1231 | (monad-do (bind return guard) exprs ... final-expr) 1232 | [(exprs (name <- val) 1233 | (name = val) 1234 | (if test) 1235 | (expr ...)) 1236 | (final-expr (yield val ...) 1237 | (return-expr ...))]]{ 1238 | The main implementation for do notation. The opening clause is a list of the three necessary 1239 | operators for a given type to implement monadic operations, which should be implemented 1240 | as follows: 1241 | 1242 | @itemlist[@item{@racket[bind]: A function which takes two arguments: an instance of the type, 1243 | and a function. @racket[bind] returns the result of applying the function 1244 | to the value of the instance.} 1245 | @item{@racket[return]: A function which takes a value, and wraps it in an instance of 1246 | the type.} 1247 | @item{@racket[guard]: A function which takes a boolean, and on true returns an 1248 | instance of the type, and on false returns the empty instance or Null.}] 1249 | 1250 | The rest of the body of the form is composed of various operations, which bind, guard, or return 1251 | values, described as follows. The last line of the do notation is special, in a sense, as it must 1252 | consist of either @racket[yield] or a bare expression. 1253 | 1254 | @specsubform[(name <- val)]{ 1255 | Binds @racket[val] to @racket[name]. @racket[val] must be an instance of the type over which 1256 | the do form operates. 1257 | } 1258 | 1259 | @specsubform[(name = val)]{ 1260 | Wraps @racket[val] in the current type, and binds it to @racket[name]. 1261 | } 1262 | 1263 | @specsubform[(if test)]{ 1264 | Filters the ongoing expression according to test. 1265 | } 1266 | 1267 | @specsubform[(yield val ...)]{ 1268 | When used as the last line of a do form, returns the given @racket[val](s) wrapped in the type 1269 | of the ongoing do form. 1270 | } 1271 | 1272 | @specsubform[(expr ...)]{ 1273 | When used in the body of a do form, the @racket[expr] is evaluated but its return value ignored. 1274 | If the last line of the do form is a bare expression, then the form will return the result of the 1275 | expression. 1276 | } 1277 | } 1278 | 1279 | @defform[(maybe-do expr ...)]{ 1280 | A specialization of @racket[monad-do] for @racket[Maybe]. This is useful for chaining operations 1281 | that return @racket[Maybe], as the monad for @racket[Maybe] short-circuits. If one operation 1282 | in the chain is a @racket[None], then the result of a @racket[yield] will be none. 1283 | 1284 | @myexamples[ 1285 | (is-none? (maybe-do 1286 | (a <- (some 5)) 1287 | (b <- None) 1288 | (c = (+ a b)) 1289 | (yield c))) 1290 | ] 1291 | } 1292 | 1293 | @defform[(list-do expr ...)]{ 1294 | A specialization of @racket[monad-do] for lists. @racket[list-do] flatmaps over its operations 1295 | forming a single-dimensional list from its calculations. This essentially enables list 1296 | comprehensions. 1297 | 1298 | @myexamples[ 1299 | (list-do 1300 | (rank <- (append (range 2 to 10) '(J Q K A))) 1301 | (suit <- '(♠ ♣ ♥ ♦)) 1302 | (if (equal? suit '♦)) 1303 | (card = (format$ "#_#_" rank suit)) 1304 | (yield card)) 1305 | ] 1306 | } 1307 | 1308 | @defform[(id-do expr ...)]{ 1309 | The Identity monad as a specialization of @racket[monad-do]. This essentially replaces the 1310 | functionality of the old "monadish" DSL from Heresy 0.1.0 and earlier. Mostly this is useful 1311 | as an example, but can be used for chaining together operations and mock-mutable behavior. 1312 | 1313 | @myexamples[ 1314 | (id-do 1315 | (x = 5) 1316 | (y = 4) 1317 | (z = (+ x y)) 1318 | (print (format$ "#_ + #_ = #_" x y z))) 1319 | ] 1320 | } 1321 | 1322 | @defform[(hole-do expr ...)]{ 1323 | A specialization of @racket[monad-do] for holes. Allows you to operate over and combine values 1324 | from multiple holes easily, while returning a new hole for future use. 1325 | 1326 | @myexamples[ 1327 | (deref 1328 | (hole-do 1329 | (x <- (hole 5)) 1330 | (y <- (hole 6)) 1331 | (z = (+ x y)) 1332 | (yield z))) 1333 | ] 1334 | } 1335 | 1336 | @subsubsection[#:tag "implementing-monad"]{Implementing a monad} 1337 | 1338 | A "monad" is a data type which can contain a value, and a set of operator functions which 1339 | operate on that type while obeying certain rules. You can think of them as a kind of container, 1340 | and the components of an assembly line that processes the container and its contents. 1341 | 1342 | Let's say that we have a Thing called @racket[Box], defined thusly: 1343 | @myexamples[ 1344 | (describe Box (val Null)) 1345 | ] 1346 | We then define a set of three functions, that work with @racket[Box]. The first, is 1347 | @italic{return}, which is a constructor function that wraps a value in our type: 1348 | @myexamples[ 1349 | (def fn box-return (val) 1350 | (Box (list val))) 1351 | ] 1352 | The next function is @italic{bind}, known in some languages as the operator @racket[>>=]. This 1353 | takes an instance of our type, and a function, and applies the function to the value inside 1354 | our type. The definition of @italic{bind} for @racket[Box] looks like this: 1355 | @myexamples[ 1356 | (def fn box-bind (box fn) 1357 | (fn (box 'val))) 1358 | ] 1359 | The final function is @italic{guard}, which is not especially useful on its own, but enables us 1360 | to implement a filter effect inside @racket[monad-do]. This function takes a boolean value, 1361 | the result of some test, and returns either an instance of our type with empty contents, or 1362 | nothing. For @racket[Box], it looks like this. 1363 | @myexamples[ 1364 | (def fn box-guard (test) 1365 | (if test then (box-return Null) else Null)) 1366 | ] 1367 | Now, we can provide those functions to @racket[monad-do] ourselves, or for convenience, we can 1368 | define a macro that wraps @racket[monad-do] without new operators pre-defined. It is necessary 1369 | to use @racket[def macroset] here, due to the peculiarities of the underlying Racket macro 1370 | system. 1371 | @myexamples[ 1372 | (def macroset box-do 1373 | [(_ e ...) 1374 | (monad-do (box-bind box-return box-guard) e ...)]) 1375 | ] 1376 | 1377 | Together, these three functions actually form an implementation of the Identity monad, and 1378 | by combining these and providing them to @racket[monad-do], we can 1379 | already perform imperative-like operations in our otherwise functional language of Heresy, 1380 | and all without any mutability involved! Behold: 1381 | @myexamples[ 1382 | (do 1383 | (describe Box (val Null)) 1384 | (def fn box-return (val) 1385 | (Box (list val))) 1386 | (def fn box-bind (box fn) 1387 | (fn (box 'val))) 1388 | (def fn box-guard (test) 1389 | (if test then (box-return Null) else Null)) 1390 | (def macroset box-do 1391 | [(_ e ...) 1392 | (monad-do (box-bind box-return box-guard) e ...)])) 1393 | (box-do 1394 | (a <- (box-return 5)) 1395 | (print a) 1396 | (a <- (box-return 10)) 1397 | (b = (* a 5)) 1398 | (print b)) 1399 | ] 1400 | --------------------------------------------------------------------------------