├── .gitignore ├── README.md ├── tulip-lib ├── base.rkt ├── info.rkt ├── lang │ ├── configure-runtime.rkt │ ├── emitter.rkt │ ├── lexer.rkt │ ├── parser.rkt │ └── reader.rkt ├── list.rkt ├── main.rkt ├── math.rkt ├── private │ ├── configured-runtime-lang.rkt │ └── util │ │ ├── curry.rkt │ │ ├── srcloc.rkt │ │ └── syntax-loc-props.rkt └── racket │ └── ffi.rkt ├── tulip-test ├── info.rkt └── tests │ └── tulip │ ├── assert.rkt │ ├── chain.rkt │ ├── corecur.rkt │ ├── id-namespace.rkt │ ├── import.rkt │ └── list.rkt └── tulip └── info.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 🌷 Tulip as a Racket `#lang` 2 | 3 | This is a Racket implementation of the [Tulip][tulip] programming language. It implements Tulip as a Racket `#lang`. This is an extreme work-in-progress, so the language support is currently somewhat poor (and Tulip itself is still a work in progress, itself). 4 | 5 | To install, just run `raco pkg install tulip`. You should then be able to write Tulip programs simply by writing `#lang tulip` at the top of your modules. 6 | 7 | ```tulip 8 | #lang tulip 9 | 10 | @import tulip/math 11 | 12 | test = { 13 | is-even = [ 0 => .t; x => decr x > is-odd ] 14 | is-odd = [ 0 => .f; x => decr x > is-even ] 15 | [ .even x => is-even x; .odd x => is-odd x ] 16 | } 17 | 18 | test (.even 3) 19 | test (.odd 3) 20 | ``` 21 | 22 | [tulip]: https://github.com/tulip-lang/tulip 23 | -------------------------------------------------------------------------------- /tulip-lib/base.rkt: -------------------------------------------------------------------------------- 1 | #lang tulip/private/configured-runtime-lang 2 | 3 | (require (for-syntax racket/base 4 | racket/function 5 | syntax/parse 6 | "private/util/syntax-loc-props.rkt") 7 | racket/format 8 | racket/function 9 | racket/match 10 | racket/string 11 | (prefix-in base: racket/base)) 12 | 13 | (provide #%app #%datum #%top #%top-interaction #%require #%provide 14 | @%define-multiple-binders @%lambda @%namespaced @%tag @%block @%chain @%chain-slot 15 | (rename-out [@%module-begin #%module-begin] 16 | [begin @%begin] 17 | [define @%define])) 18 | 19 | (define-syntax-rule (@%module-begin form ...) 20 | (base:#%module-begin 21 | (module configure-runtime racket/base 22 | (require tulip/lang/configure-runtime) 23 | (configure-runtime!)) 24 | form ...)) 25 | 26 | (define-syntax @%define-multiple-binders 27 | (syntax-parser 28 | [(_ id:id [id*:id ...] expr:expr) 29 | (syntax-property #'(define id expr) 30 | 'disappeared-binding 31 | (map syntax-local-introduce (attribute id*)))])) 32 | 33 | (define-syntax @%lambda 34 | (syntax-parser 35 | [(_ [(formal ...) expr] ...+) 36 | ; Cheat a little with curry. It might be a better idea to turn [ a b => ... ] into 37 | ; (λ (x) (λ (y) (match* (x y) [(a b) ...]))) for purity and performance, but a naïve 38 | ; desugaring implemented by generating nested match-lambda** forms won’t work because 39 | ; pattern-matching needs to be able to backtrack to previous arguments. Nested match-lambda** 40 | ; forms will create undesirable committing once a single match succeeds. 41 | #`(curry #,(syntax/loc this-syntax 42 | (match-lambda** [(formal ...) expr] ...)))])) 43 | 44 | (define-syntax @%namespaced 45 | (syntax-parser 46 | [(_ namespace:id id:id) 47 | ; This soup is effectively equivalent to (syntax-local-lift-require #'namespace #'id), which is 48 | ; what this is doing. As suggested by the documentation, however, we need to apply 49 | ; syntax-local-introduce to everything to prevent macro-introduction scopes from getting in the 50 | ; way. Additionally, we need to add the 'original-for-check-syntax property to both syntax 51 | ; objects, since original-ness does not seem to be preserved through the process. 52 | (syntax-local-introduce 53 | (syntax-local-lift-require 54 | (syntax-local-introduce (syntax-property #'namespace 'original-for-check-syntax #t)) 55 | (syntax-local-introduce (syntax-property #'id 'original-for-check-syntax #t))))])) 56 | 57 | (struct tag (name fields) 58 | #:transparent 59 | #:property prop:procedure 60 | (λ (t new-field) 61 | (tag (tag-name t) (append (tag-fields t) (list new-field)))) 62 | #:methods gen:custom-write 63 | [(define (write-proc t out mode) 64 | (if (null? (tag-fields t)) 65 | (fprintf out ".~a" (tag-name t)) 66 | (fprintf out "(.~a ~a)" (tag-name t) (string-join (map ~a (tag-fields t))))))]) 67 | 68 | (define-match-expander @%tag 69 | (syntax-parser 70 | [(_ name field ...) 71 | (syntax/loc this-syntax 72 | (tag 'name (list field ...)))]) 73 | (syntax-parser 74 | [(_ name) 75 | (syntax/loc this-syntax 76 | (tag 'name '()))])) 77 | 78 | (define-syntax-rule (@%block expr ...) 79 | (let () expr ...)) 80 | 81 | (define-syntax (@%chain-slot stx) 82 | (raise-syntax-error '- "cannot be used except within a chain" stx)) 83 | 84 | (begin-for-syntax 85 | (define-syntax-class application-with-chain-slot 86 | #:description #f 87 | #:literals [@%chain-slot] 88 | [pattern @%chain-slot 89 | #:attr replace-slot identity] 90 | [pattern (f:expr @%chain-slot) 91 | #:attr replace-slot 92 | (λ (replacement) 93 | (quasisyntax/loc/props this-syntax 94 | (f #,replacement)))] 95 | [pattern (f:application-with-chain-slot arg:expr) 96 | #:attr replace-slot 97 | (λ (replacement) 98 | (quasisyntax/loc/props this-syntax 99 | (#,((attribute f.replace-slot) replacement) arg)))])) 100 | 101 | (define-syntax @%chain 102 | (syntax-parser 103 | #:literals [@%chain-slot] 104 | [(_ a:expr b:application-with-chain-slot) 105 | ((attribute b.replace-slot) #'a)] 106 | [(_ a:expr b:expr) 107 | #'(b a)])) 108 | -------------------------------------------------------------------------------- /tulip-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "tulip") 4 | 5 | (define deps 6 | '("base" 7 | "functional-lib" 8 | "megaparsack-lib" 9 | "megaparsack-parser-tools" 10 | "parser-tools-lib")) 11 | (define build-deps 12 | '("curly-fn")) 13 | -------------------------------------------------------------------------------- /tulip-lib/lang/configure-runtime.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require megaparsack 4 | tulip/lang/parser 5 | tulip/lang/emitter) 6 | 7 | (provide configure-runtime!) 8 | 9 | (define (configure-runtime!) 10 | (current-read-interaction 11 | (λ (src in) 12 | ; The REPL works pretty differently when used at the terminal and when used from within DrRacket. 13 | ; Therefore, it’s necessary to branch on the result of terminal-port? so we can check what 14 | ; behavior to expect. 15 | ; 16 | ; Additionally, when readline is loaded, it installs itself in place of the terminal port with 17 | ; the name 'readline-input. Therefore, we should handle that case the same way. 18 | (if (or (terminal-port? in) 19 | (eq? (object-name in) 'readline-input)) 20 | ; At the terminal, input is delimited by newlines. Therefore, we should read a line at a time 21 | ; before handing things off to the lexer and parser. If we ever get #, we should pass it 22 | ; through. That way, the user can exit the REPL by sending ^D. 23 | (let ([line (read-line in)]) 24 | (if (eof-object? line) 25 | eof 26 | (emit-interaction (parse-result! (parse-tulip (open-input-string line) src))))) 27 | ; In DrRacket, multi-line input is completely possible, so #s are inserted between each 28 | ; interaction within the port. Therefore, we should just lex/parse the whole thing. We need 29 | ; to actually return # in order for the REPL to advance to the next prompt, though (for 30 | ; whatever reason), so we’ll also pass lone #s through here. 31 | (if (and (char-ready? in) 32 | (not (eof-object? (peek-char in)))) 33 | (emit-interaction (parse-result! (parse-tulip in src))) 34 | eof))))) 35 | -------------------------------------------------------------------------------- /tulip-lib/lang/emitter.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/list 4 | racket/match 5 | racket/syntax 6 | syntax/parse 7 | syntax/strip-context 8 | tulip/private/util/srcloc) 9 | 10 | (provide emit-module emit-interaction) 11 | 12 | (define (emit-module stx) 13 | (syntax-parse stx 14 | #:context '|error while parsing module| 15 | [((~var expr-or-def (tulip-top-level-form #f)) ...) 16 | (strip-context #'(#%module-begin expr-or-def.emitted ...))])) 17 | 18 | (define (emit-interaction stx) 19 | (syntax-parse stx 20 | #:context '|error while parsing interaction| 21 | [((~var expr-or-def (tulip-top-level-form #t)) ...) 22 | (strip-context #'(@%begin expr-or-def.emitted ...))])) 23 | 24 | (define-splicing-syntax-class (tulip-top-level-form interaction?) 25 | #:attributes [emitted] 26 | #:description "top level form" 27 | [pattern #s(import module-name:tulip-require-spec) 28 | #:attr emitted #'(#%require module-name.emitted)] 29 | [pattern expr-or-defn:tulip-expr-or-defn 30 | #:attr emitted (if (and (not interaction?) (attribute expr-or-defn.defined-id)) 31 | #'(@%begin (#%provide expr-or-defn.defined-id) 32 | expr-or-defn.emitted) 33 | #'expr-or-defn.emitted)]) 34 | 35 | (define-splicing-syntax-class tulip-expr-or-defn 36 | #:attributes [emitted defined-id] 37 | #:description #f 38 | ; Function definitions next to one another with the same name should be parsed as a single function 39 | ; definition with multiple pattern clauses. For example, this: 40 | ; is-zero 0 = .t 41 | ; is-zero _ = .f 42 | ; Should be parsed like this: 43 | ; is-zero = [ 0 => .t; _ => .f ] 44 | [pattern (~seq {~and def #s(function-definition id:tulip-unnamespaced-id pats expr)} 45 | {~and def* #s(function-definition 46 | id*:tulip-unnamespaced-id 47 | ; require each id* to be the same as id (otherwise, backtrack) 48 | (~fail #:unless (free-identifier=? #'id.emitted 49 | #'id*.emitted)) 50 | pats* expr*)} 51 | ...) 52 | #:do [(define this-srcloc 53 | (let ([matched-syntax #'(def def* ...)]) 54 | (join-srclocs (first (syntax->list matched-syntax)) 55 | (last (syntax->list matched-syntax)))))] 56 | #:with [clause ...] #'[#s(lambda-clause pats expr) 57 | #s(lambda-clause pats* expr*) 58 | ...] 59 | #:with lambda:tulip-expr (datum->syntax #f (syntax-e #'#s(lambda-full [clause ...])) 60 | this-srcloc) 61 | #:attr emitted #'(@%define-multiple-binders id.emitted [id*.emitted ...] lambda.emitted) 62 | #:attr defined-id #'id.emitted] 63 | [pattern #s(definition id:tulip-unnamespaced-id expr:tulip-expr) 64 | #:attr emitted #'(@%define id.emitted expr.emitted) 65 | #:attr defined-id #'id.emitted] 66 | [pattern expr:tulip-expr 67 | #:attr emitted #'expr.emitted 68 | #:attr defined-id #f]) 69 | 70 | (define-syntax-class tulip-id 71 | #:attributes [namespace name] 72 | [pattern #s(identifier (~or namespace-stx:id (~and #f namespace-stx)) name:id) 73 | #:attr namespace (and (syntax->datum #'namespace-stx) #'namespace-stx)]) 74 | 75 | (define-syntax-class tulip-unnamespaced-id 76 | #:attributes [emitted] 77 | #:description "identifier" 78 | [pattern id:tulip-id 79 | #:fail-when (attribute id.namespace) 80 | "expected an unnamespaced identifier, but a namespace was provided" 81 | #:attr emitted #'id.name]) 82 | 83 | (define-syntax-class tulip-expr 84 | #:attributes [emitted] 85 | [pattern id:tulip-id 86 | #:attr emitted (if (attribute id.namespace) 87 | (syntax/loc this-syntax 88 | (@%namespaced id.namespace id.name)) 89 | #'id.name)] 90 | [pattern #s(chain-slot) 91 | #:attr emitted (syntax/loc this-syntax @%chain-slot)] 92 | [pattern #s(tag-word name:id) 93 | #:attr emitted (syntax/loc this-syntax 94 | (@%tag name))] 95 | [pattern #s(flag-word name:id) 96 | #:attr emitted (syntax/loc this-syntax 97 | (@%flag name))] 98 | [pattern #s(flag-pair word:tulip-expr value:tulip-expr) 99 | #:attr emitted (syntax/loc this-syntax 100 | (@%flag-pair word.emitted value.emitted))] 101 | [pattern #s(number value) 102 | #:attr emitted #'value] 103 | [pattern #s(string value) 104 | #:attr emitted #'value] 105 | [pattern #s(application fn:tulip-expr arg:tulip-expr) 106 | #:attr emitted (datum->syntax #f (list #'fn.emitted #'arg.emitted) 107 | this-syntax #'fn.emitted)] 108 | [pattern #s(application! fn:tulip-expr) 109 | #:attr emitted (datum->syntax #f (list #'fn.emitted) this-syntax #'fn.emitted)] 110 | [pattern #s(block [expr:tulip-expr-or-defn ...]) 111 | #:attr emitted (syntax/loc this-syntax 112 | (@%block expr.emitted ...))] 113 | [pattern #s(chain left:tulip-expr right:tulip-expr) 114 | #:attr emitted (syntax/loc this-syntax 115 | (@%chain left.emitted right.emitted))] 116 | [pattern #s(lambda-full [clause:tulip-lambda-clause ...]) 117 | #:attr emitted (syntax/loc this-syntax 118 | (@%lambda clause.emitted ...))]) 119 | 120 | (define-syntax-class tulip-require-spec 121 | #:attributes [emitted] 122 | [pattern #s(string value) 123 | #:attr emitted #'value] 124 | [pattern id:tulip-id 125 | #:attr emitted (if (attribute id.namespace) 126 | (format-id #f "~a/~a" #'id.namespace #'id.name 127 | #:source (join-srclocs #'id.namespace #'id.name) 128 | #:props #'id.name) 129 | #'id.name)]) 130 | 131 | (define-syntax-class tulip-lambda-clause 132 | #:attributes [emitted] 133 | [pattern #s(lambda-clause (pat:tulip-pattern ...) expr:tulip-expr) 134 | #:attr emitted #'[(pat.emitted ...) expr.emitted]]) 135 | 136 | (define-syntax-class tulip-pattern 137 | #:attributes [emitted] 138 | [pattern #s(hole) 139 | #:attr emitted #'_] 140 | [pattern #s(tag-pattern #s(tag-word name:id) [value-pat:tulip-pattern ...]) 141 | #:attr emitted #'(@%tag name value-pat.emitted ...)] 142 | [pattern other-expr:tulip-expr 143 | #:attr emitted #'other-expr.emitted]) 144 | -------------------------------------------------------------------------------- /tulip-lib/lang/lexer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require parser-tools/lex 4 | (prefix-in : parser-tools/lex-sre) 5 | racket/list 6 | racket/match 7 | racket/port 8 | racket/string 9 | syntax/readerr) 10 | 11 | (provide tulip tulip* lex lex-for-colorizer) 12 | 13 | (define-tokens tulip 14 | [IDENTIFIER KEYWORD TAG-WORD FLAG-WORD NUMBER STRING 15 | INVALID-IDENTIFIER]) 16 | (define-empty-tokens tulip* 17 | [EOF AUTOVAR EMPTY-ARGS OP-SEQUENCE 18 | OP-CHAIN OP-CHAIN-SLOT OP-DEFINE OP-CLAUSE OP-HOLE 19 | GROUP-OPEN GROUP-CLOSE 20 | LAMBDA-OPEN LAMBDA-CLOSE 21 | BLOCK-OPEN BLOCK-CLOSE 22 | WHITESPACE COMMENT]) 23 | 24 | (define-lex-abbrevs 25 | [space (:& (:~ #\newline) (:or whitespace blank iso-control))] 26 | 27 | [identifier (:: letter (:* (:or letter digit #\-)))] 28 | [namespaced-identifier (:: (:? #\/) (:+ (:: identifier (:* #\/))))] 29 | [keyword (:: #\@ identifier)] 30 | [tag-word (:: #\. identifier)] 31 | [flag-word (:: #\- identifier)] 32 | [number (:or (:: (:* digit) #\. (:+ digit)) 33 | (:: (:+ digit) (:? #\.)))] 34 | [single-quote-string (:: #\' identifier)] 35 | [double-quote-string (:: #\" (:* (:~ #\")) #\")] 36 | [letter (:or (:/ #\a #\z) (:/ #\A #\Z))] 37 | [digit (:/ #\0 #\9)] 38 | [sequence-delimiter (:or #\; #\newline)] 39 | 40 | [comment (:: #\# (:* (:~ #\newline)))]) 41 | 42 | (define tulip-lexer 43 | (lexer-src-pos 44 | [#\( (token-GROUP-OPEN)] 45 | [#\) (token-GROUP-CLOSE)] 46 | [#\[ (token-LAMBDA-OPEN)] 47 | [#\] (token-LAMBDA-CLOSE)] 48 | [#\{ (token-BLOCK-OPEN)] 49 | [#\} (token-BLOCK-CLOSE)] 50 | [#\$ (token-AUTOVAR)] 51 | [#\! (token-EMPTY-ARGS)] 52 | [#\> (token-OP-CHAIN)] 53 | [#\= (token-OP-DEFINE)] 54 | ["=>" (token-OP-CLAUSE)] 55 | [#\_ (token-OP-HOLE)] 56 | [#\- (token-OP-CHAIN-SLOT)] 57 | 58 | [namespaced-identifier 59 | (if (regexp-match-exact? #px"([a-zA-Z][a-zA-Z0-9-]*/)*[a-zA-Z][a-zA-Z0-9-]*" lexeme) 60 | (token-IDENTIFIER (map string->symbol (string-split lexeme "/"))) 61 | (token-INVALID-IDENTIFIER lexeme))] 62 | [keyword (token-KEYWORD (string->symbol (substring lexeme 1)))] 63 | [tag-word (token-TAG-WORD (string->symbol (substring lexeme 1)))] 64 | [flag-word (token-FLAG-WORD (string->symbol (substring lexeme 1)))] 65 | 66 | [number (token-NUMBER (string->number lexeme))] 67 | 68 | [single-quote-string (token-STRING (substring lexeme 1))] 69 | [double-quote-string (token-STRING (substring lexeme 1 (sub1 (string-length lexeme))))] 70 | 71 | [sequence-delimiter (token-OP-SEQUENCE)] 72 | 73 | [comment (token-COMMENT)] 74 | [(:+ space) (token-WHITESPACE)] 75 | [(eof) (token-EOF)])) 76 | 77 | (define (lex in) 78 | (port-count-lines! in) 79 | (reverse 80 | (let loop ([acc '()]) 81 | (let ([v (tulip-lexer in)]) 82 | (cond 83 | ; do some post-processing for special tokens that lex can’t quite handle on its own 84 | [(or ; ignore whitespace tokens 85 | (eq? 'WHITESPACE (position-token-token v)) 86 | ; ignore comment tokens 87 | (eq? 'COMMENT (position-token-token v)) 88 | ; ignore consecutive OP-SEQUENCE tokens 89 | (and (not (empty? acc)) 90 | (eq? 'OP-SEQUENCE (position-token-token (first acc))) 91 | (eq? 'OP-SEQUENCE (position-token-token v)))) 92 | (loop acc)] 93 | ; once we hit the EOF token, stop lexing 94 | [(eq? 'EOF (token-name (position-token-token v))) 95 | (cons v acc)] 96 | ; raise an error for invalid identifiers 97 | [(eq? 'INVALID-IDENTIFIER (token-name (position-token-token v))) 98 | (match-let ([(position-token (app token-value invalid-id) 99 | (position start line col) (position end _ _)) v]) 100 | (raise-read-error (format "invalid identifier: ~a" invalid-id) 101 | (object-name in) line col start (- end start)))] 102 | ; otherwise, use the token and keep lexing 103 | [else 104 | (loop (cons v acc))]))))) 105 | 106 | (define (lex-for-colorizer in) 107 | (with-handlers (; if the lexer fails, just mark that character as an error and hobble along 108 | [exn:fail:read? 109 | (λ (exn) 110 | (values (read-string 1 in) 'error #f 111 | (file-position in) (add1 (file-position in))))]) 112 | (match-let* ([peek-in (peeking-input-port in #:init-position (add1 (file-position in)))] 113 | [(position-token tok (position start _ _) (position end _ _)) (tulip-lexer peek-in)] 114 | [read-str (read-string (- end start) in)]) 115 | (define-values (token-type paren-type) 116 | (match tok 117 | [(app token-name 'NUMBER) 118 | (values 'constant #f)] 119 | [(app token-name 'STRING) 120 | (values 'string #f)] 121 | [(app token-name 'IDENTIFIER) 122 | (values 'symbol #f)] 123 | [(app token-name 'KEYWORD) 124 | (values 'hash-colon-keyword #f)] 125 | [(app token-name (or 'TAG-WORD 'FLAG-WORD)) 126 | (values 'keyword #f)] 127 | 128 | ['GROUP-OPEN 129 | (values 'parenthesis '|(|)] 130 | ['GROUP-CLOSE 131 | (values 'parenthesis '|)|)] 132 | ['LAMBDA-OPEN 133 | (values 'parenthesis '|[|)] 134 | ['LAMBDA-CLOSE 135 | (values 'parenthesis '|]|)] 136 | ['BLOCK-OPEN 137 | (values 'parenthesis '|{|)] 138 | ['BLOCK-CLOSE 139 | (values 'parenthesis '|}|)] 140 | 141 | [(or 'EMPTY-ARGS 'OP-SEQUENCE 'OP-DEFINE 'OP-CHAIN 'OP-CHAIN-SLOT 'OP-CLAUSE 'OP-HOLE) 142 | (values 'other #f)] 143 | 144 | ['COMMENT 145 | (values 'comment #f)] 146 | ['WHITESPACE 147 | (values 'white-space #f)] 148 | ['EOF 149 | (values 'eof #f)] 150 | 151 | [(app token-name 'INVALID-IDENTIFIER) 152 | (values 'error #f)])) 153 | (values read-str token-type paren-type start end)))) 154 | -------------------------------------------------------------------------------- /tulip-lib/lang/parser.rkt: -------------------------------------------------------------------------------- 1 | #lang curly-fn racket 2 | 3 | (require data/applicative 4 | data/monad 5 | data/maybe 6 | (prefix-in monad: data/monad) 7 | tulip/private/util/srcloc 8 | megaparsack 9 | megaparsack/parser-tools/lex 10 | (prefix-in lex: parser-tools/lex) 11 | "lexer.rkt") 12 | 13 | (provide parse-tulip) 14 | 15 | (define (chain-left+/p p op) 16 | (define (rest x) 17 | (or/p (try/p (do [f <- op] 18 | [y <- p] 19 | (rest (f x y)))) 20 | (pure x))) 21 | (monad:chain rest p)) 22 | 23 | ;; --------------------------------------------------------------------------------------------------- 24 | 25 | ; The many/trailing-sep/end/p and some/trailing-sep/end/p combinators are like many/sep*/p and 26 | ; many/sep+/p, but they handle trailing separators, like in the following expression: 27 | ; 28 | ; [ 0 => 1; 1 => 2; ] 29 | ; 30 | ; Due to how the parser model works, that last semicolon needs to be handled with care to preserve 31 | ; good error messages without completely breaking the parser. These wordy combinators handle that by 32 | ; providing information about how the expression terminates, so they can explicitly check for the 33 | ; trailing separator. 34 | 35 | (define (many/trailing-sep/end/p p sep end) 36 | (or/p (some/trailing-sep/end/p p sep end) 37 | (do end (pure '())))) 38 | 39 | (define (some/trailing-sep/end/p p sep end) 40 | (do [x <- p] 41 | [xs <- (or/p (try/p (do sep end (pure '()))) 42 | (do sep (some/trailing-sep/end/p p sep end)) 43 | (do end (pure '())))] 44 | (pure (cons x xs)))) 45 | 46 | ;; --------------------------------------------------------------------------------------------------- 47 | 48 | (struct import (module-name) #:prefab) 49 | 50 | (struct identifier (namespace name) #:prefab) 51 | (struct tag-word (name) #:prefab) 52 | (struct flag-word (name) #:prefab) 53 | (struct flag-pair (word value) #:prefab) 54 | 55 | (struct number (value) #:prefab) 56 | (struct string (value) #:prefab) 57 | 58 | (struct application (fn arg) #:prefab) 59 | (struct application! (fn) #:prefab) 60 | (struct block (body) #:prefab) 61 | (struct chain (left right) #:prefab) 62 | 63 | (define chain-slot #s(chain-slot)) 64 | (define hole #s(hole)) 65 | 66 | (struct tag-pattern (tag value-patterns) #:prefab) 67 | 68 | (struct lambda-clause (formals expression) #:prefab) 69 | (struct lambda-full (clauses) #:prefab) 70 | 71 | (struct definition (identifier expression) #:prefab) 72 | (struct function-definition (identifier formals expression) #:prefab) 73 | 74 | ;; --------------------------------------------------------------------------------------------------- 75 | 76 | ;; 1. Datums and Operators 77 | 78 | (define (wrap-token/p label constructor token) 79 | (label/p label ((pure constructor) (syntax/p (token/p token))))) 80 | 81 | (define tag-word/p (wrap-token/p "tag-word" tag-word 'TAG-WORD)) 82 | (define flag-word/p (wrap-token/p "flag-word" flag-word 'FLAG-WORD)) 83 | (define number/p (wrap-token/p "number" number 'NUMBER)) 84 | (define string/p (wrap-token/p "string" string 'STRING)) 85 | 86 | (define chain-slot/p 87 | (label/p "hole" (syntax/p (do (token/p 'OP-CHAIN-SLOT) 88 | (pure chain-slot))))) 89 | 90 | (define identifier/p 91 | (label/p 92 | "identifier" 93 | (do [stx <- (syntax/p (token/p 'IDENTIFIER))] 94 | (match (syntax->datum stx) 95 | [(list name) 96 | (pure (identifier #f (datum->syntax #f name stx stx)))] 97 | [(list namespaces ... name) 98 | (let*-values ([(namespace) (string-join (map symbol->string namespaces) "/")] 99 | [(namespace-srcloc name-srcloc) (split-srcloc stx (string-length namespace) 1)]) 100 | (pure (identifier (and (not (empty? namespaces)) 101 | (datum->syntax #f (string->symbol namespace) namespace-srcloc stx)) 102 | (datum->syntax #f name name-srcloc stx))))])))) 103 | 104 | (define sequence-delimiter/p (token/p 'OP-SEQUENCE)) 105 | (define sequence-delimiter?/p (or/p (hidden/p sequence-delimiter/p) void/p)) 106 | 107 | (define (keyword/p keyword-name) 108 | (label/p (format "@~a" keyword-name) 109 | (satisfy/p (λ (tok) (and (lex:token? tok) 110 | (eq? (lex:token-name tok) 'KEYWORD) 111 | (equal? (lex:token-value tok) keyword-name)))))) 112 | 113 | ;; 2. Expressions 114 | 115 | (define group/p 116 | (do (token/p 'GROUP-OPEN) 117 | [expr <- expression/p] 118 | (token/p 'GROUP-CLOSE) 119 | (pure expr))) 120 | 121 | (define expression-term/p 122 | (or/p group/p 123 | (lazy/p lambda/p) 124 | (lazy/p block/p) 125 | tag-word/p 126 | number/p 127 | string/p 128 | identifier/p 129 | chain-slot/p)) 130 | 131 | (define application/p 132 | (syntax/p 133 | (or/p (try/p (do [expr <- expression-term/p] 134 | (token/p 'EMPTY-ARGS) 135 | (pure (application! expr)))) 136 | (chain-left+/p expression-term/p (pure application))))) 137 | 138 | (define chain/p 139 | (chain-left+/p application/p (do (token/p 'OP-CHAIN) (pure chain)))) 140 | 141 | (define block/p 142 | (do (token/p 'BLOCK-OPEN) 143 | sequence-delimiter?/p 144 | [exprs <- (some/trailing-sep/end/p (or/p definition/p chain/p) 145 | sequence-delimiter/p 146 | (token/p 'BLOCK-CLOSE))] 147 | (pure (block exprs)))) 148 | 149 | (define expression/p 150 | (label/p 151 | "expression" 152 | (or/p (try/p chain/p) 153 | expression-term/p))) 154 | 155 | ;; 2.1 Lambdas 156 | 157 | (define hole/p 158 | (label/p "hole" 159 | (syntax/p (do (token/p 'OP-HOLE) 160 | (pure hole))))) 161 | 162 | (define pattern/p 163 | (label/p 164 | "pattern" 165 | (or/p (lazy/p tag-pattern/p) 166 | (lazy/p grouped-pattern/p) 167 | hole/p 168 | identifier/p 169 | number/p))) 170 | 171 | (define grouped-pattern/p 172 | (do (token/p 'GROUP-OPEN) 173 | [pat <- pattern/p] 174 | (token/p 'GROUP-CLOSE) 175 | (pure pat))) 176 | 177 | (define tag-pattern/p 178 | ((pure tag-pattern) tag-word/p (many*/p pattern/p))) 179 | 180 | (define lambda-formals/p 181 | (or/p (do (token/p 'EMPTY-ARGS) (pure '())) 182 | (many+/p pattern/p))) 183 | 184 | (define lambda-clause/p 185 | (do [formals <- lambda-formals/p] 186 | (token/p 'OP-CLAUSE) 187 | 188 | ; the => token eats semicolons/newlines 189 | sequence-delimiter?/p 190 | 191 | [expr <- expression/p] 192 | (pure (lambda-clause formals expr)))) 193 | 194 | (define lambda/p 195 | (do (token/p 'LAMBDA-OPEN) 196 | sequence-delimiter?/p 197 | [clauses <- (some/trailing-sep/end/p lambda-clause/p 198 | sequence-delimiter/p 199 | (token/p 'LAMBDA-CLOSE))] 200 | (pure (lambda-full clauses)))) 201 | 202 | ;; 3. Definitions 203 | 204 | (define declaration/p 205 | (do [id <- identifier/p] 206 | [maybe-formals 207 | <- (or/p (do (token/p 'OP-DEFINE) 208 | (pure nothing)) 209 | (do [formals <- lambda-formals/p] 210 | (token/p 'OP-DEFINE) 211 | (pure (just formals))))] 212 | (pure (list id maybe-formals)))) 213 | 214 | (define definition/p 215 | (label/p 216 | "definition" 217 | (syntax/p (do [decl <- (try/p declaration/p)] 218 | ; the = token eats semicolons/newlines 219 | sequence-delimiter?/p 220 | [expr <- expression/p] 221 | (match decl 222 | [(list id (just formals)) (pure (function-definition id formals expr))] 223 | [(list id (nothing)) (pure (definition id expr))]))))) 224 | 225 | ;; 4. Whole Programs 226 | 227 | (define directive/p 228 | (do (keyword/p 'import) 229 | [module-name <- (or/p string/p identifier/p)] 230 | (pure (import module-name)))) 231 | 232 | (define top-level-form/p 233 | (or/p directive/p 234 | definition/p 235 | expression/p)) 236 | 237 | (define eof/p (label/p "end of file" (token/p 'EOF))) 238 | 239 | (define program/p 240 | (syntax/p 241 | (do sequence-delimiter?/p 242 | (many/trailing-sep/end/p top-level-form/p 243 | sequence-delimiter/p 244 | eof/p)))) 245 | 246 | ;; --------------------------------------------------------------------------------------------------- 247 | 248 | (define (parse-tulip in [source-name (object-name in)]) 249 | (parse-tokens program/p (lex in) source-name)) 250 | -------------------------------------------------------------------------------- /tulip-lib/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader tulip 2 | 3 | #:whole-body-readers? #t 4 | 5 | #:read tulip:read 6 | #:read-syntax tulip:read-syntax 7 | #:info get-info 8 | 9 | (require megaparsack 10 | "lexer.rkt" 11 | "parser.rkt" 12 | "emitter.rkt") 13 | 14 | (define (tulip:read-syntax module-name in) 15 | (let* ([ast (parse-result! (parse-tulip in module-name))] 16 | [mod (emit-module ast)]) 17 | (list mod))) 18 | 19 | (define (tulip:read in) 20 | (syntax->datum (tulip:read-syntax in))) 21 | 22 | (define (get-info key default lookup-default) 23 | (case key 24 | [(color-lexer) lex-for-colorizer] 25 | [else (lookup-default key default)])) 26 | -------------------------------------------------------------------------------- /tulip-lib/list.rkt: -------------------------------------------------------------------------------- 1 | #lang tulip 2 | 3 | map f .nil = .nil 4 | map f (.cons x xs) = .cons (f x) (map f xs) 5 | 6 | foldl f acc .nil = acc 7 | foldl f acc (.cons x xs) = foldl f (f acc x) xs 8 | 9 | foldr f acc .nil = acc 10 | foldr f acc (.cons x xs) = f (foldr f acc xs) x 11 | 12 | reverse lst = { 13 | go acc .nil = acc 14 | go acc (.cons x xs) = go (.cons x acc) xs 15 | go .nil lst 16 | } 17 | -------------------------------------------------------------------------------- /tulip-lib/main.rkt: -------------------------------------------------------------------------------- 1 | #lang tulip/private/configured-runtime-lang 2 | 3 | (require tulip/base) 4 | (provide (all-from-out tulip/base)) 5 | -------------------------------------------------------------------------------- /tulip-lib/math.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/math 4 | tulip/base 5 | tulip/private/util/curry) 6 | 7 | (provide 8 | abs 9 | round 10 | floor 11 | sqrt 12 | exp 13 | log 14 | random 15 | 16 | pi 17 | sqr 18 | sgn 19 | 20 | sin asin sinh 21 | cos acos cosh 22 | tan atan tanh 23 | 24 | eq gt lt gte lte 25 | 26 | (rename-out 27 | [add1 incr] 28 | [sub1 decr] 29 | [ceiling ceil]) 30 | 31 | (curry-out 32 | [(+ add) 2] 33 | [(- sub) 2] 34 | [(* mul) 2] 35 | [(/ div) 2] 36 | 37 | [(modulo mod) 2] 38 | 39 | [max 2] 40 | [min 2] 41 | 42 | [expt 2] 43 | 44 | [(atan atan2) 2])) 45 | 46 | (define ((eq a) b) (if (= a b) (@%tag t) (@%tag f))) 47 | (define ((gt a) b) (if (> a b) (@%tag t) (@%tag f))) 48 | (define ((lt a) b) (if (< a b) (@%tag t) (@%tag f))) 49 | (define ((gte a) b) (if (>= a b) (@%tag t) (@%tag f))) 50 | (define ((lte a) b) (if (<= a b) (@%tag t) (@%tag f))) 51 | -------------------------------------------------------------------------------- /tulip-lib/private/configured-runtime-lang.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (except-out (all-from-out racket/base) #%module-begin) 4 | (rename-out [@%module-begin #%module-begin])) 5 | 6 | (module reader syntax/module-reader 7 | tulip/private/configured-runtime-lang) 8 | 9 | (define-syntax-rule (@%module-begin form ...) 10 | (#%module-begin 11 | (module configure-runtime racket/base 12 | (require tulip/lang/configure-runtime) 13 | (configure-runtime!)) 14 | form ...)) 15 | -------------------------------------------------------------------------------- /tulip-lib/private/util/curry.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; This module implements static currying, which is useful for providing Racket functions to Tulip 4 | ; code. It is simpler than tulip/racket/ffi because it does not need to cooperate with Tulip’s 5 | ; always-curried function application syntax. 6 | 7 | (require (for-syntax racket/base 8 | racket/provide-transform 9 | syntax/parse)) 10 | 11 | (provide curry-n curry-out) 12 | 13 | (define-syntax-rule (curry-n n proc) 14 | (do-curry-n n proc)) 15 | 16 | (define-syntax do-curry-n 17 | (syntax-parser 18 | [(_ 0 proc arg ...) #'(proc arg ...)] 19 | [(_ n:nat proc arg ...) #`(λ (x) (do-curry-n #,(sub1 (syntax-e #'n)) proc arg ... x))])) 20 | 21 | (begin-for-syntax 22 | (define-syntax-class curry-out-clause 23 | #:attributes [provide-spec] 24 | [pattern [name:id arity:nat] 25 | #:with desugared:curry-out-clause #'[(name name) arity] 26 | #:attr provide-spec #'desugared.provide-spec] 27 | [pattern [(internal-name:id external-name:id) arity:nat] 28 | #:with curried (syntax-local-lift-expression #'(curry-n arity internal-name)) 29 | #:attr provide-spec #'(rename-out [curried external-name])])) 30 | 31 | (define-syntax curry-out 32 | (make-provide-pre-transformer 33 | (λ (stx modes) 34 | (syntax-parse stx 35 | [(_ clause:curry-out-clause ...) 36 | (pre-expand-export #'(combine-out clause.provide-spec ...) modes)])))) 37 | -------------------------------------------------------------------------------- /tulip-lib/private/util/srcloc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide split-srcloc 4 | join-srclocs) 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | ;; srcloc management 8 | 9 | ; The split-srcloc and join-srclocs functions are used to break apart and join source location 10 | ; information from identifiers. This is useful in Tulip because we have things like namespaced 11 | ; identifiers, of the form `racket/base/cons`, which should be broken up into two separate pieces 12 | ; of source location information along these lines: 13 | ; 14 | ; racket/base/cons 15 | ; ^^^^^^^^^^^ ^^^^ 16 | ; | | 17 | ; namespace identifier 18 | ; 19 | ; Additionally, the forward slash between each segment needs to be omitted from both srclocs, so 20 | ; the `skip` argument of split-srcloc is used for that purpose. 21 | 22 | (define (split-srcloc stx index [skip 0]) 23 | (values (list (syntax-source stx) (syntax-line stx) (syntax-column stx) 24 | (syntax-position stx) index) 25 | (list (syntax-source stx) (syntax-line stx) (syntax-column stx) 26 | (+ index skip (syntax-position stx)) (- (syntax-span stx) index skip)))) 27 | 28 | (define (join-srclocs a b) 29 | (list (syntax-source a) (syntax-line a) (syntax-column a) 30 | (syntax-position a) (+ (syntax-span a) (syntax-span b) 31 | (- (syntax-position b) (+ (syntax-position a) (syntax-span a)))))) 32 | -------------------------------------------------------------------------------- /tulip-lib/private/util/syntax-loc-props.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | syntax/parse)) 5 | 6 | (provide syntax/loc/props quasisyntax/loc/props) 7 | 8 | ;; --------------------------------------------------------------------------------------------------- 9 | ;; [quasi]syntax/loc/props 10 | 11 | ; The syntax/loc and quasisyntax/loc forms from racket/syntax are useful, but they don’t copy over 12 | ; syntax properties, even when they probably should. This module provides two forms that act just 13 | ; like syntax/loc and quasisyntax/loc, except that they also copy properties. 14 | 15 | (define-for-syntax (*/loc/props *) 16 | (syntax-parser 17 | [(_ src-expr template) 18 | #`(let ([src src-expr]) 19 | (datum->syntax (quote-syntax #,this-syntax) 20 | (syntax-e (#,* template)) 21 | src src))])) 22 | 23 | (define-syntaxes [syntax/loc/props quasisyntax/loc/props] 24 | (values (*/loc/props #'syntax) 25 | (*/loc/props #'quasisyntax))) 26 | -------------------------------------------------------------------------------- /tulip-lib/racket/ffi.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | syntax/parse)) 5 | 6 | (provide curry-n) 7 | 8 | (define-syntax-rule (curry-n n) 9 | (λ (proc) (do-curry-n n proc ()))) 10 | 11 | (define-syntax do-curry-n 12 | (syntax-parser 13 | [(_ 0 proc (arg ...)) #'(proc arg ...)] 14 | [(_ n:nat proc (arg ...)) #`(λ (x) (do-curry-n #,(sub1 (syntax-e #'n)) proc (arg ... x)))])) 15 | -------------------------------------------------------------------------------- /tulip-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps 6 | '()) 7 | (define build-deps 8 | '("base" 9 | "rackunit-lib" 10 | "tulip-lib")) 11 | -------------------------------------------------------------------------------- /tulip-test/tests/tulip/assert.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit) 4 | 5 | (provide (rename-out [check-true assert-true]) 6 | assert-equal) 7 | 8 | (define ((assert-equal a) b) 9 | (check-equal? a b)) 10 | -------------------------------------------------------------------------------- /tulip-test/tests/tulip/chain.rkt: -------------------------------------------------------------------------------- 1 | #lang tulip 2 | 3 | @import tulip/math 4 | @import "assert.rkt" 5 | 6 | 5 > sub - 3 > assert-equal 2 7 | add > - 1 2 > assert-equal 3 8 | 9 | 5 > sub - (3 > add - 1) > assert-equal 1 10 | -------------------------------------------------------------------------------- /tulip-test/tests/tulip/corecur.rkt: -------------------------------------------------------------------------------- 1 | #lang tulip 2 | 3 | @import tulip/math 4 | @import "assert.rkt" 5 | 6 | test v = { 7 | is-even = [ 0 => .t; x => decr x > is-odd ] 8 | is-odd = [ 0 => .f; x => decr x > is-even ] 9 | v > [ .even x => is-even x; .odd x => is-odd x ] 10 | } 11 | 12 | test (.even 3) > assert-equal .f 13 | test (.odd 3) > assert-equal .t 14 | -------------------------------------------------------------------------------- /tulip-test/tests/tulip/id-namespace.rkt: -------------------------------------------------------------------------------- 1 | #lang tulip 2 | 3 | @import "assert.rkt" 4 | 5 | kons = racket/function/curry racket/base/cons 6 | 7 | kons 1 racket/base/null > assert-equal (racket/base/list 1) 8 | -------------------------------------------------------------------------------- /tulip-test/tests/tulip/import.rkt: -------------------------------------------------------------------------------- 1 | #lang tulip 2 | 3 | @import racket/base 4 | @import racket/function 5 | 6 | @import "assert.rkt" 7 | 8 | kons = curry cons 9 | 10 | kons 1 null > assert-equal (list 1) 11 | -------------------------------------------------------------------------------- /tulip-test/tests/tulip/list.rkt: -------------------------------------------------------------------------------- 1 | #lang tulip 2 | 3 | @import tulip/list 4 | @import tulip/math 5 | 6 | @import "assert.rkt" 7 | 8 | list-123 = .cons 1 (.cons 2 (.cons 3 .nil)) 9 | 10 | list-123 > map incr > assert-equal (.cons 2 (.cons 3 (.cons 4 .nil))) 11 | list-123 > foldl add 0 > assert-equal 6 12 | list-123 > reverse > assert-equal (.cons 3 (.cons 2 (.cons 1 .nil))) 13 | -------------------------------------------------------------------------------- /tulip/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define version "0.0.1") 4 | 5 | (define implies 6 | '("tulip-lib")) 7 | 8 | (define deps (cons "base" implies)) 9 | --------------------------------------------------------------------------------