├── .gitignore ├── .travis.yml ├── LICENSE.txt ├── README.md ├── ast.rkt ├── eval.rkt ├── examples ├── higher-order.rkt ├── scope.rkt ├── shuffles.rkt ├── simple.rkt └── sum.rkt ├── expander.rkt ├── infer.rkt ├── info.rkt ├── lexer.rkt ├── main.rkt ├── parser.rkt ├── scribblings └── wort.scrbl └── tokenizer.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | # Everything below makes sense on any package repository, so it's 3 | # stuff that should be put into each such repository. The same holds 4 | # for ".mailmap" (which some people can decide if they want to thin it 5 | # out or not include it) and for ".gitattributes" (which is probably 6 | # irrelevant except maybe for the core repo). 7 | 8 | compiled/ 9 | doc/ 10 | 11 | # common backups, autosaves, lock files, OS meta-files 12 | *~ 13 | \#* 14 | .#* 15 | .DS_Store 16 | *.bak 17 | TAGS 18 | 19 | # generated by patch 20 | *.orig 21 | *.rej 22 | 23 | # coredumps 24 | *.core -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | # Based from: https://github.com/greghendershott/travis-racket 4 | 5 | # Optional: Remove to use Travis CI's older infrastructure. 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 | - RACKET_VERSION=6.0 24 | - RACKET_VERSION=6.1 25 | - RACKET_VERSION=6.1.1 26 | - RACKET_VERSION=6.2 27 | - RACKET_VERSION=6.3 28 | - RACKET_VERSION=6.4 29 | - RACKET_VERSION=6.5 30 | - RACKET_VERSION=6.6 31 | - RACKET_VERSION=6.7 32 | - RACKET_VERSION=HEAD 33 | 34 | matrix: 35 | allow_failures: 36 | # - env: RACKET_VERSION=HEAD 37 | fast_finish: true 38 | 39 | before_install: 40 | - git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket 41 | - cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh! 42 | - export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us 43 | 44 | install: 45 | - raco pkg install --deps search-auto 46 | 47 | before_script: 48 | 49 | # Here supply steps such as raco make, raco test, etc. You can run 50 | # `raco pkg install --deps search-auto` to install any required 51 | # packages without it getting stuck on a confirmation prompt. 52 | script: 53 | - raco test -x -p wort 54 | 55 | after_success: 56 | - raco setup --check-pkg-deps --pkgs wort 57 | - raco pkg install --deps search-auto cover cover-coveralls 58 | - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . 59 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | wort 2 | Copyright (c) 2017 gamec 3 | 4 | This package is distributed under the GNU Lesser General Public 5 | License (LGPL). This means that you can link wort into proprietary 6 | applications, provided you follow the rules stated in the LGPL. You 7 | can also modify this package; if you distribute a modified version, 8 | you must distribute it under the terms of the LGPL, which in 9 | particular means that you must release the source code for the 10 | modified software. See http://www.gnu.org/copyleft/lesser.html 11 | for more information. 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | wort 2 | ==== 3 | 4 | **wort** is a core concatenative programming language with 'full' type inference, in the sense of Algorithm W (principal types at the expression level). It is not intended for general purpose use, but is surprisingly expressive for as minimal as it is. This particular variant of wort is implemented in Racket's `#lang` facility, so you'll need to have Racket installed first. At the top of your wort file, type `#lang wort` to make sure racket knows what you want (after you've installed the package). The syntax for wort is pretty simple: 5 | 6 | ``` 7 | <> := <>* 8 | <> := 0 | 1 | 2 ... 9 | | true | false 10 | | <

> 11 | | <> 12 | | { <> } 13 | | bind <> ( <> ) 14 | | let <> = <> ( <> ) 15 | <

> := add | call | fix | if | eq | less 16 | <> := variables beginning with letter, followed by zero or more letters or numbers 17 | ``` 18 | 19 | Error reporting for type inference is currently very minimal, to keep the implementation small and focused. -------------------------------------------------------------------------------- /ast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide ast-prim ast-block ast-bind ast-let) 4 | (provide ast-prim? ast-block? ast-bind? ast-let?) 5 | (provide ast-prim-name ast-block-body ast-bind-name 6 | ast-bind-body ast-let-name ast-let-arg ast-let-body) 7 | (provide subst) 8 | 9 | #| 10 | 11 | type Expr = Word* 12 | 13 | type Word 14 | = Prim String 15 | | Int 16 | | Var 17 | | Block Expr 18 | | Bind Var Expr 19 | | Let Var Expr Expr 20 | 21 | Int = racket int 22 | Var = racket string 23 | Prim = struct ast-prim 24 | Block = struct ast-block 25 | Bind = struct ast-bind 26 | Let = struct ast-let 27 | 28 | |# 29 | 30 | (struct ast-prim (name) #:transparent) 31 | (struct ast-block (body) #:transparent) 32 | (struct ast-bind (name body) #:transparent) 33 | (struct ast-let (name arg body) #:transparent) 34 | 35 | ;; subst :: Var, Expr, Expr -> Expr 36 | ;; Substitutes the expression 'rep' for every free 37 | ;; occurrence of the variable 'name' in the target 38 | ;; expression 'target'. 39 | ;; We cannot simply replace 'name' with the substituted 40 | ;; expression; rather we must concatenate it with the expressions 41 | ;; on either side (since our expressions are lists, not trees). 42 | ;; That's why we have 'flatten'. 43 | (define (subst name rep target) 44 | (define (flatten ls) 45 | (match ls 46 | [(list) 47 | (list)] 48 | [(list (list se ...) e ...) 49 | (append se (flatten e))] 50 | [(list x e ...) 51 | (cons x (flatten e))])) 52 | (define (subst-rec t) 53 | (cond 54 | [(list? t) 55 | (flatten (map (lambda (x) (subst-rec x)) t))] 56 | [(string? t) 57 | (if (equal? name t) rep t)] 58 | [(ast-block? t) 59 | (ast-block (subst-rec (ast-block-body t)))] 60 | [(ast-bind? t) 61 | (ast-bind (ast-bind-name t) 62 | (if (equal? name (ast-bind-name t)) 63 | (ast-bind-body t) 64 | (subst-rec (ast-bind-body t))))] 65 | [(ast-let? t) 66 | (ast-let (ast-let-name t) 67 | (subst-rec (ast-let-arg t)) 68 | (if (equal? name (ast-let-name t)) 69 | (ast-let-body t) 70 | (subst-rec (ast-let-body t))))] 71 | [#t t])) 72 | (subst-rec target)) -------------------------------------------------------------------------------- /eval.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "ast.rkt") 4 | 5 | ;; =================================================== 6 | ;; =================================================== 7 | ;; STACK MACHINE EVALUATION 8 | ;; =================================================== 9 | ;; =================================================== 10 | 11 | ;; type Expression = Word* 12 | ;; An expression is a list of operators, commonly called 13 | ;; 'words' in Forth and related languages. 14 | 15 | ;; type MachineState = (Stack Value, Expression) 16 | ;; A machine consists of: 17 | ;; 1. a stack of values, which will end up as the result 18 | ;; of evaluation 19 | ;; 2. an expression to evaluate 20 | (struct machine (stack expr) #:transparent) 21 | 22 | ;; eval-barley :: Expression -> Stack | Error 23 | ;; Runs the expression e on an initial (empty) 24 | ;; stack. The machine terminates when the 25 | ;; expression is 'empty' (expressions are just 26 | ;; a list of operators). If no transition rule 27 | ;; can be applied and the expression part is not 28 | ;; empty, then the machine is 'stuck'. 29 | (define (eval-wort e) 30 | ;; step-eval :: MachineState -> Stack | Error 31 | (define (step-eval state) 32 | (if (empty? (machine-expr state)) 33 | (machine-stack state) 34 | (step-eval (step state)))) 35 | ;; step :: MachineState -> MachineState | Error 36 | (define (step state) 37 | (match state 38 | ;; Pushing values 39 | [(machine s (list c e ...)) 40 | #:when (or (number? c) 41 | (boolean? c) 42 | (ast-block? c)) 43 | (machine (cons c s) e)] 44 | 45 | ;; Value binding 46 | [(machine (list v s ...) (list (ast-bind name body) e ...)) 47 | (machine s (append (subst name (list v) body) e))] 48 | 49 | ;; Let binding 50 | [(machine s (list (ast-let name arg body) e ...)) 51 | (machine s (append (subst name arg body) e))] 52 | 53 | ;; Primitives 54 | [(machine (list n1 n2 s ...) (list (ast-prim "add") e ...)) 55 | (machine (list* (+ n1 n2) s) e)] 56 | 57 | [(machine (list (ast-block exp) s ...) (list (ast-prim "call") e ...)) 58 | (machine s (append exp e))] 59 | 60 | [(machine (list (ast-block exp) s ...) (list (ast-prim "fix") e ...)) 61 | (machine (list* (ast-block (list (ast-block exp) (ast-prim "fix"))) s) 62 | (append exp e))] 63 | 64 | [(machine (list #t v1 v2 s ...) (list (ast-prim "if") e ...)) 65 | (machine (list* v1 s) e)] 66 | 67 | [(machine (list #f v1 v2 s ...) (list (ast-prim "if") e ...)) 68 | (machine (list* v2 s) e)] 69 | 70 | [(machine (list n1 n2 s ...) (list (ast-prim "eq") e ...)) 71 | #:when (and (number? n1) (number? n2)) 72 | (machine (list* (eq? n1 n2) s) e)] 73 | 74 | [(machine (list n1 n2 s ...) (list (ast-prim "less") e ...)) 75 | #:when (and (number? n1) (number? n2)) 76 | (machine (list* (< n2 n1) s) e)] 77 | 78 | ;; Stuck (should never occur if inference passes!) 79 | [_ 80 | (error "looks like we're stuck!")])) 81 | 82 | 83 | (step-eval (machine (list) e))) 84 | (provide eval-wort) -------------------------------------------------------------------------------- /examples/higher-order.rkt: -------------------------------------------------------------------------------- 1 | #lang wort 2 | 3 | let compose = bind f (bind g ({g call f call})) ( 4 | let partial = bind f (bind x ({x f call})) ( 5 | let add1 = 1 add ( 6 | let add1p = 1 { add } partial call ( 7 | 8 | { 1 2 3 } { add add add1 } compose call 9 | bind x ( 10 | x add1 11 | x add1p 12 | eq 13 | ) 14 | 15 | )))) -------------------------------------------------------------------------------- /examples/scope.rkt: -------------------------------------------------------------------------------- 1 | #lang wort 2 | 3 | 1 2 bind x (bind x (x)) -------------------------------------------------------------------------------- /examples/shuffles.rkt: -------------------------------------------------------------------------------- 1 | #lang wort 2 | 3 | let swap = bind x (bind y (x y)) ( 4 | let dup = bind x (x x) ( 5 | let zap = bind x () ( 6 | let bury = bind x (bind y (bind z (x z y))) ( 7 | 8 | 1 2 3 bury swap zap dup add 9 | 10 | )))) -------------------------------------------------------------------------------- /examples/simple.rkt: -------------------------------------------------------------------------------- 1 | #lang wort 2 | 3 | { 1 2 bind x (x) add } call 4 | -------------------------------------------------------------------------------- /examples/sum.rkt: -------------------------------------------------------------------------------- 1 | #lang wort 2 | 3 | let add1 = 1 add ( 4 | let sumaux = bind f (bind i (bind s (bind n ( 5 | 6 | { n 7 | s i add 8 | i add1 9 | f call } 10 | { s } 11 | i n add1 eq 12 | if 13 | call 14 | 15 | ))))( 16 | 17 | let sum = 0 0 {sumaux} fix ( 18 | 19 | 3 sum 20 | 21 | ))) -------------------------------------------------------------------------------- /expander.rkt: -------------------------------------------------------------------------------- 1 | #lang br/quicklang 2 | 3 | (require "ast.rkt") 4 | (require "eval.rkt") 5 | (require "infer.rkt") 6 | 7 | (define-macro (wort-module-begin PARSE-TREE) 8 | #'(#%module-begin PARSE-TREE)) 9 | (provide (rename-out [wort-module-begin #%module-begin])) 10 | 11 | ;; we reverse the returned evaluation stack to make it 12 | ;; easier to read. if you want to use the result stack 13 | ;; as a stack in racket, you probably don't want to reverse 14 | ;; it first; as the value on top of the stack will be 15 | ;; the first element in the list. 16 | (define-macro (wrt-program EXPR) 17 | #'(reverse (eval-wort (check-type EXPR)))) 18 | (provide wrt-program) 19 | 20 | (define-macro (wrt-expr WORDS ...) 21 | #'(list WORDS ...)) 22 | (provide wrt-expr) 23 | 24 | (define-macro (wrt-word WORD) 25 | #'WORD) 26 | (provide wrt-word) 27 | 28 | (define-macro (wrt-prim PRIM) 29 | #'(cond 30 | [(eq? PRIM "true") #t] 31 | [(eq? PRIM "false") #f] 32 | [#t (ast-prim PRIM)])) 33 | (provide wrt-prim) 34 | 35 | (define-macro (wrt-block "{" WORDS "}") 36 | #'(ast-block WORDS)) 37 | (provide wrt-block) 38 | 39 | (define-macro (wrt-bind "bind" VAR "(" WORDS ")") 40 | #'(ast-bind VAR WORDS)) 41 | (provide wrt-bind) 42 | 43 | (define-macro (wrt-let "let" VAR "=" ARGS "(" BODY ")") 44 | #'(ast-let VAR ARGS BODY)) 45 | (provide wrt-let) -------------------------------------------------------------------------------- /infer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "ast.rkt") 4 | 5 | (define (check-type expr) 6 | (reset-var) 7 | (let ([t (second (infer (gamma empty) expr))]) 8 | (displayln (string-append "inferred type: " (pretty-type t))) 9 | (unify-ind t (fun-type (list) (list (fresh-seq)))) 10 | expr)) 11 | (provide check-type) 12 | 13 | (module+ test 14 | (require rackunit)) 15 | 16 | ;; type Expr = Word* 17 | 18 | #| 19 | type Type 20 | = Int 21 | | Bool 22 | | IVar String 23 | | SVar String 24 | | Fun [Type] [Type] 25 | 26 | type Scheme = Scheme [SVar | IVar] Type 27 | 28 | One of the invariants we maintain throughout the 29 | type system is that sequence variables can only 30 | occur as the last element in a list of types. 31 | |# 32 | (struct ivar (n) #:transparent) 33 | (struct svar (n) #:transparent) 34 | (struct fun-type (in out) #:transparent) 35 | (struct prim-type (name) #:transparent) 36 | 37 | (struct scheme (vars mono) #:transparent) 38 | 39 | (define (pretty-type t) 40 | (match t 41 | [(ivar n) n] 42 | [(svar n) (string-append n "...")] 43 | [(fun-type is os) (string-append "(" (pretty-type is) " -> " (pretty-type os) ")")] 44 | [(list ts ...) 45 | (string-join (map pretty-type ts) " ")] 46 | [(prim-type p) (string-titlecase p)] 47 | [(scheme vs t) (string-append "forall " 48 | (string-join (map pretty-type vs) ",") 49 | "." 50 | (pretty-type t))])) 51 | 52 | ;; get-name : SVar | IVar -> String 53 | (define (get-name v) 54 | (match v 55 | [(ivar n) n] 56 | [(svar n) n])) 57 | 58 | ;; get-scheme-vnames : Scheme -> [String] 59 | (define (get-scheme-vnames s) 60 | (map get-name (scheme-vars s))) 61 | 62 | ;; type TypeEnvironment = [(Var,Scheme)] 63 | ;; Another invariant we maintain is that all variables 64 | ;; have a function type in the environment. 65 | (struct gamma (vs) #:transparent) 66 | (define (extend-env n t env) 67 | (gamma (list* (list n t) (gamma-vs env)))) 68 | 69 | ;; ftv :: Type | Scheme | Gamma -> [String] 70 | (define (ftv t) 71 | (match t 72 | [(list ts ...) (append* (map ftv ts))] 73 | [(ivar n) (list (ivar n))] 74 | [(svar n) (list (svar n))] 75 | [(fun-type in out) (append (ftv in) (ftv out))] 76 | [(scheme vs mono) (filter (lambda (v) (not (member v vs))) (ftv mono))] 77 | [(gamma vs) (append* (map (lambda (s) (ftv (second s))) vs))] 78 | [_ empty])) 79 | 80 | (module+ test 81 | (check-equal? (list) (ftv (list (prim-type "int")))) 82 | (check-equal? (list (ivar "n") (svar "a")) 83 | (ftv (list (ivar "n") (svar "a")))) 84 | (check-equal? (list (ivar "n") (svar "a")) 85 | (ftv (fun-type (list (ivar "n")) (list (svar "a"))))) 86 | (check-equal? (list (svar "a")) 87 | (ftv (scheme (list (ivar "n")) 88 | (fun-type (list (ivar "n")) 89 | (list (svar "a")))))) 90 | (check-equal? (list (svar "a")) 91 | (ftv (gamma (list (list "x" 92 | (scheme (list (ivar "n")) 93 | (fun-type (list (ivar "n")) 94 | (list (svar "a")))))))))) 95 | 96 | ;; =================================================== 97 | ;; =================================================== 98 | ;; SUBSTITUTIONS 99 | ;; =================================================== 100 | ;; =================================================== 101 | 102 | ;; type Subst = [(String,Seq)] 103 | 104 | ;; subst : Subst, (Type | Seq | Gamma | Scheme) -> (Type | Seq | Gamma | Scheme) 105 | (define (subst s t) 106 | (define (flatten ls) 107 | (match ls 108 | [(list) (list)] 109 | [(list (list e1 ...) e2 ...) (append e1 (flatten e2))] 110 | [(list t e2 ...) (list* t (flatten e2))])) 111 | 112 | ;; in-scheme : [String] -> (String, Seq) -> Bool 113 | (define (not-in-scheme vs) 114 | (lambda (vp) 115 | (not (member (car vp) vs)))) 116 | 117 | (cond 118 | [(list? t) 119 | (flatten (map (lambda (x) (subst s x)) t))] 120 | 121 | [(fun-type? t) 122 | (fun-type (subst s (fun-type-in t)) 123 | (subst s (fun-type-out t)))] 124 | 125 | [(ivar? t) 126 | (match (assoc (ivar-n t) s) 127 | [#f t] 128 | [other (second other)])] 129 | 130 | [(svar? t) 131 | (match (assoc (svar-n t) s) 132 | [#f t] 133 | [other (second other)])] 134 | 135 | [(scheme? t) 136 | (scheme 137 | (scheme-vars t) 138 | (subst (filter (not-in-scheme (get-scheme-vnames t)) s) (scheme-mono t)))] 139 | 140 | [(gamma? t) 141 | (gamma (map (lambda (x) 142 | (list (first x) (subst s (second x)))) 143 | (gamma-vs t)))] 144 | 145 | [#t t])) 146 | 147 | (module+ test 148 | (check-equal? 149 | (subst (list (list "a" (list (svar "b")))) (list (svar "a"))) 150 | (list (svar "b")))) 151 | 152 | ;; compose-subst : Subst, Subst -> Subst 153 | (define (compose-subst s1 s2) 154 | (define (combine-subs s1 s2) 155 | (match s2 156 | [(list) s1] 157 | [(list (list v t) s2s ...) 158 | (if (assoc v s1) 159 | (combine-subs s1 s2s) 160 | (list* (list v t) (combine-subs s1 s2s)))])) 161 | (define (sub-in-type s) 162 | (lambda (pair) 163 | (list (first pair) (subst s (second pair))))) 164 | (combine-subs (map (sub-in-type s1) s2) s1)) 165 | 166 | 167 | ;; =================================================== 168 | ;; =================================================== 169 | ;; TYPE INFERENCE 170 | ;; =================================================== 171 | ;; =================================================== 172 | 173 | (define ind 0) 174 | (define (reset-var) (set! ind 0)) 175 | ;; fresh-var : -> String 176 | (define (fresh-var) 177 | (let ([x (string-append "a" (number->string ind))]) 178 | (set! ind (add1 ind)) 179 | x)) 180 | (define (fresh-ind) (ivar (fresh-var))) 181 | (define (fresh-seq) (svar (fresh-var))) 182 | 183 | ;; infer : TypeEnvironment, Expr -> (Subst, Type) 184 | (define (infer env expr) 185 | (match expr 186 | [(list) 187 | (let ([a (fresh-seq)]) 188 | (list empty (fun-type (list a) (list a))))] 189 | [(list e ... w) 190 | (let* ([r1 (infer env e)] 191 | [s1 (first r1)] 192 | [t1 (second r1)] 193 | [r2 (infer-word (subst s1 env) w)] 194 | [s2 (first r2)] 195 | [t2 (second r2)] 196 | [phi (unify (fun-type-out t1) (fun-type-in t2))]) 197 | (list (compose-subst (compose-subst phi s2) s1) 198 | (subst phi (fun-type (fun-type-in t1) (fun-type-out t2)))))])) 199 | 200 | (module+ test 201 | (check-equal? 202 | (second (infer (gamma (list)) (list (ast-prim "call")))) 203 | (fun-type (list (svar "a1") (fun-type (list (svar "a1")) (list (svar "a2")))) 204 | (list (svar "a2")))) 205 | (reset-var) 206 | (check-equal? 207 | (second (infer (gamma (list)) (list (ast-bind "x" (list "x"))))) 208 | (fun-type (list (svar "a4") (ivar "a2")) 209 | (list (svar "a4") (ivar "a2")))) 210 | (reset-var) 211 | (check-equal? 212 | (second (infer (gamma (list)) (list (ast-let "x" (list (ast-prim "add")) (list "x"))))) 213 | (fun-type (list (svar "a4") (prim-type "int") (prim-type "int")) 214 | (list (svar "a4") (prim-type "int"))))) 215 | 216 | ;; infer-word : TypeEnvironment, Word -> (Subst, Type) 217 | (define (infer-word env word) 218 | (match word 219 | ;; numeric constant 220 | [c #:when (number? c) 221 | (let ([a (fresh-seq)]) 222 | (list empty (fun-type (list a) (list a (prim-type "int")))))] 223 | 224 | ;; boolean constant 225 | [c #:when (boolean? c) 226 | (let ([a (fresh-seq)]) 227 | (list empty (fun-type (list a) (list a (prim-type "bool")))))] 228 | 229 | ;; block constant 230 | [(ast-block e) 231 | (let* ([r1 (infer env e)] 232 | [s1 (first r1)] 233 | [t1 (second r1)] 234 | [a (fresh-seq)]) 235 | (list s1 (fun-type (list a) (list a t1))))] 236 | 237 | ;; primitive word 238 | [(ast-prim n) 239 | (list empty (infer-prim n))] 240 | 241 | ;; variable reference 242 | [c #:when (string? c) 243 | (list empty (inst (second (assoc c (gamma-vs env)))))] 244 | 245 | ;; value binding 246 | [(ast-bind n e) 247 | (let* ([a (fresh-seq)] 248 | [b (fresh-ind)] 249 | [r1 (infer (extend-env n 250 | (scheme (list a) (fun-type (list a) (list a b))) 251 | env) 252 | e)] 253 | [s1 (first r1)] 254 | [t1 (second r1)]) 255 | (list s1 (fun-type (append (fun-type-in t1) (flatten (list (subst s1 b)))) 256 | (fun-type-out t1))))] 257 | 258 | ;; expression binding 259 | [(ast-let n e1 e2) 260 | (let* ([r1 (infer env e1)] 261 | [s1 (first r1)] 262 | [t1 (second r1)] 263 | [envp (subst s1 env)] 264 | [r2 (infer (extend-env n (gen envp t1) envp) e2)] 265 | [s2 (first r2)] 266 | [t2 (second r2)]) 267 | (list (compose-subst s2 s1) t2))])) 268 | 269 | ;; infer-prim : String -> Type 270 | (define (infer-prim name) 271 | (match name 272 | ["add" 273 | (let ([a (fresh-seq)]) 274 | (fun-type (list a (prim-type "int") (prim-type "int")) 275 | (list a (prim-type "int"))))] 276 | ["call" 277 | (let ([a (fresh-seq)] 278 | [b (fresh-seq)]) 279 | (fun-type (list a (fun-type (list a) (list b))) (list b)))] 280 | ["fix" 281 | (let ([a (fresh-seq)] 282 | [b (fresh-seq)]) 283 | (fun-type (list a (fun-type (list a (fun-type (list a) (list b))) (list b))) 284 | (list b)))] 285 | ["if" 286 | (let ([a (fresh-seq)] 287 | [b (fresh-ind)]) 288 | (fun-type (list a b b (prim-type "bool")) (list a b)))] 289 | ["eq" 290 | (let ([a (fresh-seq)]) 291 | (fun-type (list a (prim-type "int") (prim-type "int")) 292 | (list a (prim-type "bool"))))] 293 | ["less" 294 | (let ([a (fresh-seq)]) 295 | (fun-type (list a (prim-type "int") (prim-type "int")) 296 | (list a (prim-type "bool"))))])) 297 | 298 | ;; inst : Scheme | Type -> Type 299 | (define (inst sch) 300 | (define (freshen v) 301 | (match v 302 | [(svar s) (list s (list (fresh-seq)))] 303 | [(ivar s) (list s (list (fresh-ind)))])) 304 | (match sch 305 | [(scheme vs t) 306 | (let ([fresh (map (lambda (v) (freshen v)) vs)]) 307 | (subst fresh t))] 308 | [t t])) 309 | 310 | (module+ test 311 | (reset-var) 312 | (check-equal? (inst (scheme (list (ivar "a")) (list (ivar "a")))) 313 | (list (ivar "a0"))) 314 | (reset-var) 315 | (check-equal? (inst (scheme (list) (list (ivar "a")))) 316 | (list (ivar "a")))) 317 | 318 | ;; gen : TypeEnvironment, Type -> Scheme 319 | (define (gen env ty) 320 | (let ([env-ftv (ftv env)]) 321 | (scheme (filter (lambda (x) (not (member x env-ftv))) (ftv ty)) ty))) 322 | 323 | (module+ test 324 | (check-equal? (gen (gamma (list)) (list (ivar "a"))) 325 | (scheme (list (ivar "a")) (list (ivar "a")))) 326 | (check-equal? (gen (gamma (list (list "x" (fun-type (list) (list (ivar "a")))))) 327 | (list (ivar "a"))) 328 | (scheme (list) (list (ivar "a"))))) 329 | 330 | ;; =================================================== 331 | ;; =================================================== 332 | ;; UNIFICATION 333 | ;; =================================================== 334 | ;; =================================================== 335 | 336 | ;; unify : Seq, Seq -> Subst | Error 337 | (define (unify s1 s2) 338 | (match* (s1 s2) 339 | ;; both sequences empty 340 | [((list) (list)) 341 | (list)] 342 | 343 | ;; if two individual types are equal, their unifier 344 | ;; is empty, so just unify the rest of the sequences 345 | [((list t1s ... t1) (list t2s ... t2)) 346 | #:when (equal? t1 t2) 347 | (unify t1s t2s)] 348 | 349 | ;; sequence variable unifies with any sequence that 350 | ;; doesn't contain that variable 351 | [((list (svar v1)) t2s) 352 | #:when (not (member (svar v1) (ftv t2s))) 353 | (list (list v1 t2s))] 354 | 355 | ;; same as above, but sequence variable is on the other side 356 | [(t1s (list (svar v2))) 357 | #:when (not (member (svar v2) (ftv t1s))) 358 | (list (list v2 t1s))] 359 | 360 | ;; two individual types aren't unifiable, so unify them 361 | [((list t1s ... t1) (list t2s ... t2)) 362 | #:when (and (not (svar? t1)) (not (svar? t2))) 363 | (let* ([phi (unify-ind t1 t2)] 364 | [phi2 (unify (subst phi t1s) (subst phi t2s))]) 365 | (compose-subst phi2 phi))] 366 | 367 | [(l r) (displayln "inference failed: sequence unification error") 368 | (displayln (string-append "left seq: " (pretty-type l))) 369 | (displayln (string-append "right seq: " (pretty-type r))) 370 | (error "will not run due to inference failure")])) 371 | 372 | ;; unify-ind : Type, Type -> Subst | Error 373 | (define (unify-ind t1 t2) 374 | (if (equal? t1 t2) 375 | (list) 376 | (match* (t1 t2) 377 | [((ivar v1) t2p) 378 | #:when (not (member (ivar v1) (ftv t2p))) 379 | (list (list v1 (list t2p)))] 380 | 381 | [(t1p (ivar v2)) 382 | #:when (not (member (ivar v2) (ftv t1p))) 383 | (list (list v2 (list t1p)))] 384 | 385 | [((fun-type i1 o1) (fun-type i2 o2)) 386 | (let* ([phi (unify i1 i2)] 387 | [phi2 (unify (subst phi o1) (subst phi o2))]) 388 | (compose-subst phi2 phi))] 389 | 390 | [(l r) (displayln "inference failed: individual unification error") 391 | (displayln (string-append "left: " (pretty-type l))) 392 | (displayln l) 393 | (displayln (string-append "right: " (pretty-type r))) 394 | (displayln r) 395 | (error "type checking failure")]))) 396 | 397 | (module+ test 398 | (check-equal? (unify-ind (fun-type (list) (list)) (fun-type (list) (list))) 399 | (list))) 400 | 401 | (module+ test 402 | (reset-var) 403 | (check-equal? 404 | (second (infer (gamma (list)) (list (ast-bind "x" (list (ast-bind "x" (list "x"))))))) 405 | (fun-type (list (svar "a7") (ivar "a5") (ivar "a2")) (list (svar "a7") (ivar "a5"))))) -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "wort") 3 | (define deps '("base" 4 | "rackunit-lib" 5 | "brag" 6 | "beautiful-racket" 7 | "beautiful-racket-lib" 8 | "br-parser-tools-lib")) 9 | (define build-deps '("scribble-lib" "racket-doc")) 10 | (define scribblings '(("scribblings/wort.scrbl" ()))) 11 | (define pkg-desc "A core concatenative language with type inference") 12 | -------------------------------------------------------------------------------- /lexer.rkt: -------------------------------------------------------------------------------- 1 | #lang br 2 | (require brag/support) 3 | 4 | (define wort-lexer 5 | (lexer-srcloc 6 | [(eof) (return-without-srcloc eof)] 7 | [(from/to "--" "\n") 8 | (token 'COMMENT lexeme #:skip? #t)] 9 | [whitespace 10 | (token 'WHITESPACE lexeme #:skip? #t)] 11 | [(:or "add" "eq" "less" "call" "fix" "if" 12 | "{" "}" "=" "(" ")" 13 | "bind" "let" 14 | "true" "false") 15 | (token lexeme lexeme)] 16 | [(:seq alphabetic (:* (:or alphabetic numeric))) 17 | (token 'VAR lexeme)] 18 | [(:+ (char-set "0123456789")) 19 | (token 'INT (string->number lexeme))])) 20 | 21 | (provide wort-lexer) -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang br/quicklang 2 | (require "parser.rkt" "tokenizer.rkt") 3 | 4 | (define (read-syntax path port) 5 | (define parse-tree (parse path (make-tokenizer port path))) 6 | (strip-bindings 7 | #`(module wort-module wort/expander 8 | #,parse-tree))) 9 | 10 | (module+ reader 11 | (provide read-syntax)) 12 | -------------------------------------------------------------------------------- /parser.rkt: -------------------------------------------------------------------------------- 1 | #lang brag 2 | 3 | wrt-program : wrt-expr 4 | 5 | wrt-expr : wrt-word* 6 | wrt-word : INT 7 | | wrt-prim 8 | | VAR 9 | | wrt-block 10 | | wrt-bind 11 | | wrt-let 12 | 13 | wrt-prim : "add" | "call" | "fix" | "if" 14 | | "true" | "false" | "eq" | "less" 15 | wrt-block : "{" wrt-expr "}" 16 | wrt-bind : "bind" VAR "(" wrt-expr ")" 17 | wrt-let : "let" VAR "=" wrt-expr "(" wrt-expr ")" -------------------------------------------------------------------------------- /scribblings/wort.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[@for-label[wort 3 | racket/base]] 4 | 5 | @title{wort} 6 | @author{gamec} 7 | 8 | @defmodule[wort] 9 | 10 | Package Description Here 11 | -------------------------------------------------------------------------------- /tokenizer.rkt: -------------------------------------------------------------------------------- 1 | #lang br 2 | (require "lexer.rkt") 3 | 4 | (define (make-tokenizer ip [path #f]) 5 | (port-count-lines! ip) 6 | (define (next-token) (wort-lexer ip)) 7 | next-token) 8 | 9 | (provide make-tokenizer) --------------------------------------------------------------------------------