├── .gitignore ├── LICENSE ├── Setup.hs ├── examples ├── conditions.hms ├── fib.hms ├── generators.hms └── objects.hms ├── hummus.cabal ├── kernel ├── boot.hms ├── class.hms ├── condition.hms ├── generator.hms ├── object.hms └── record.hms └── src ├── Control └── Monad │ ├── CC.hs │ ├── CC │ ├── Cursor.hs │ ├── Dynvar.hs │ ├── Prompt.hs │ └── Seq.hs │ └── LICENSE ├── Hummus ├── Parser.hs ├── Prelude.hs ├── Runtime.hs └── Types.hs └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.ayc 2 | *.rbc 3 | *.hi 4 | *.o 5 | dist/ 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2010, Alex Suraci 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alex Suraci nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/conditions.hms: -------------------------------------------------------------------------------- 1 | (bind ((boolean? (e) (print (cons "boolean!" e))) 2 | (number? () (print "number!"))) 3 | (print "pre-signal") 4 | (signal #t) 5 | (signal "foo") 6 | (signal 123) 7 | (print "post-signal")) 8 | 9 | (print 10 | (bind ((boolean? (e) 11 | (print (cons "caught" e)) 12 | (restart use-value 43))) 13 | (with-restarts ((foo () 42) 14 | (use-value (v) v)) 15 | (print "pre-signal") 16 | (signal #t) 17 | (print "post-signal") 18 | 100))) 19 | -------------------------------------------------------------------------------- /examples/fib.hms: -------------------------------------------------------------------------------- 1 | (defn (fib n) 2 | (if (.") 95 | ; 30 96 | ; delegating x to y 97 | ; getting foo of x and y 98 | ; 2 99 | ; 30 100 | -------------------------------------------------------------------------------- /hummus.cabal: -------------------------------------------------------------------------------- 1 | name: hummus 2 | version: 0.1 3 | synopsis: A dialect of the Kernel programming language. 4 | -- description: 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Alex Suraci 8 | maintainer: i.am@toogeneric.com 9 | -- copyright: 10 | category: Language 11 | build-type: Simple 12 | cabal-version: >=1.8 13 | 14 | data-files: kernel/*.hms 15 | 16 | executable hummus 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | 20 | ghc-prof-options: -prof -auto-all -caf-all 21 | ghc-options: -Wall -threaded -fno-warn-unused-do-bind -rtsopts 22 | 23 | other-modules: 24 | Control.Monad.CC, 25 | Control.Monad.CC.Cursor, 26 | Control.Monad.CC.Dynvar, 27 | Control.Monad.CC.Prompt, 28 | Control.Monad.CC.Seq, 29 | Hummus.Types, 30 | Hummus.Parser, 31 | Hummus.Runtime, 32 | Hummus.Prelude 33 | 34 | build-depends: 35 | attoparsec, 36 | base, 37 | bytestring, 38 | filepath, 39 | haskeline, 40 | hashtables, 41 | mtl, 42 | time 43 | -------------------------------------------------------------------------------- /kernel/boot.hms: -------------------------------------------------------------------------------- 1 | (define sequence 2 | ((wrap 3 | (vau (seq2) #ignore 4 | (seq2 5 | (define aux 6 | (vau (head . tail) env 7 | (if (null? tail) 8 | (eval head env) 9 | (seq2 10 | (eval head env) 11 | (eval (cons aux tail) env))))) 12 | (vau body env 13 | (if (null? body) 14 | #inert 15 | (eval (cons aux body) env)))))) 16 | (vau (first second) env 17 | ((wrap (vau #ignore #ignore (eval second env))) 18 | (eval first env))))) 19 | 20 | (define list (wrap (vau x #ignore x))) 21 | 22 | (define list* 23 | (wrap 24 | (vau args #ignore 25 | (sequence 26 | (define aux 27 | (wrap 28 | (vau ((head . tail)) #ignore 29 | (if (null? tail) 30 | head 31 | (cons head (aux tail)))))) 32 | (aux args))))) 33 | 34 | (define car (wrap (vau ((x . #ignore)) #ignore x))) 35 | (define cdr (wrap (vau ((#ignore . x)) #ignore x))) 36 | 37 | (define length 38 | (wrap 39 | (vau (x) #ignore 40 | (if (null? x) 41 | 0 42 | (+ 1 (length (cdr x))))))) 43 | 44 | (define vau 45 | ((wrap 46 | (vau (vau) #ignore 47 | (vau (formals eformal . body) env 48 | (eval (list vau formals eformal 49 | (if (>? (length body) 1) 50 | (cons sequence body) 51 | (car body))) env)))) 52 | vau)) 53 | 54 | (define lambda 55 | (vau (formals . body) env 56 | (wrap (eval (list* vau formals #ignore body) env)))) 57 | 58 | (define caar (lambda (((x . #ignore) . #ignore)) x)) 59 | (define cdar (lambda (((#ignore . x) . #ignore)) x)) 60 | (define cadr (lambda ((#ignore . (x . #ignore))) x)) 61 | (define cddr (lambda ((#ignore . (#ignore . x))) x)) 62 | 63 | (define caaar (lambda ((((x . #ignore) . #ignore) . #ignore)) x)) 64 | (define cdaar (lambda ((((#ignore . x) . #ignore) . #ignore)) x)) 65 | (define cadar (lambda (((#ignore . (x . #ignore)) . #ignore)) x)) 66 | (define cddar (lambda (((#ignore . (#ignore . x)) . #ignore)) x)) 67 | (define caadr (lambda ((#ignore . ((x . #ignore) . #ignore))) x)) 68 | (define cdadr (lambda ((#ignore . ((#ignore . x) . #ignore))) x)) 69 | (define caddr (lambda ((#ignore . (#ignore . (x . #ignore)))) x)) 70 | (define cdddr (lambda ((#ignore . (#ignore . (#ignore . x)))) x)) 71 | 72 | (define caaaar (lambda (((((x . #ignore) . #ignore) . #ignore). #ignore))x)) 73 | (define cdaaar (lambda (((((#ignore . x) . #ignore) . #ignore). #ignore))x)) 74 | (define cadaar (lambda ((((#ignore . (x . #ignore)) . #ignore). #ignore))x)) 75 | (define cddaar (lambda ((((#ignore . (#ignore . x)) . #ignore). #ignore))x)) 76 | (define caadar (lambda (((#ignore . ((x . #ignore) . #ignore)). #ignore))x)) 77 | (define cdadar (lambda (((#ignore . ((#ignore . x) . #ignore)). #ignore))x)) 78 | (define caddar (lambda (((#ignore . (#ignore . (x . #ignore))). #ignore))x)) 79 | (define cdddar (lambda (((#ignore . (#ignore . (#ignore . x))). #ignore))x)) 80 | (define caaadr (lambda ((#ignore .(((x . #ignore) . #ignore) . #ignore)))x)) 81 | (define cdaadr (lambda ((#ignore .(((#ignore . x) . #ignore) . #ignore)))x)) 82 | (define cadadr (lambda ((#ignore .((#ignore . (x . #ignore)) . #ignore)))x)) 83 | (define cddadr (lambda ((#ignore .((#ignore . (#ignore . x)) . #ignore)))x)) 84 | (define caaddr (lambda ((#ignore .(#ignore . ((x . #ignore) . #ignore))))x)) 85 | (define cdaddr (lambda ((#ignore .(#ignore . ((#ignore . x) . #ignore))))x)) 86 | (define cadddr (lambda ((#ignore .(#ignore . (#ignore . (x . #ignore)))))x)) 87 | (define cddddr (lambda ((#ignore .(#ignore . (#ignore . (#ignore . x)))))x)) 88 | 89 | (define apply 90 | (lambda (appv arg . opt) 91 | (eval (cons (unwrap appv) arg) 92 | (if (null? opt) 93 | (make-environment) 94 | (car opt))))) 95 | 96 | (define cond 97 | (vau clauses env 98 | (define aux 99 | (lambda ((test . body) . clauses) 100 | (if (eval test env) 101 | (apply (wrap sequence) body env) 102 | (apply (wrap cond) clauses env)))) 103 | (if (null? clauses) 104 | #inert 105 | (apply aux clauses)))) 106 | 107 | (define drop 108 | (lambda (ls k) 109 | (if (>? k 0) 110 | (drop (cdr ls) (- k 1)) 111 | ls))) 112 | 113 | (define map 114 | (lambda (f xs) 115 | (if (null? xs) 116 | () 117 | (cons (f (car xs)) (map f (cdr xs)))))) 118 | 119 | (define any? 120 | (lambda (f xs) 121 | (cond 122 | ((null? xs) #f) 123 | ((f (car xs)) #t) 124 | (#t (any? f (cdr xs)))))) 125 | 126 | (define let 127 | (vau (bindings . body) env 128 | (eval (cons (list* lambda (map car bindings) body) 129 | (map cadr bindings)) 130 | env))) 131 | 132 | (define zip 133 | (lambda (f . xss) 134 | (let ((rest (map cdr xss))) 135 | (cons (apply f (map car xss)) 136 | (if (any? null? rest) 137 | () 138 | (apply zip (cons f rest))))))) 139 | 140 | (define not? (lambda (x) (if x #f #t))) 141 | 142 | (define and? 143 | (vau xs e 144 | (cond 145 | ((null? xs) #t) 146 | ((eval (car xs) e) (apply (wrap and?) (cdr xs) e)) 147 | (#t #f)))) 148 | 149 | (define or? 150 | (vau xs e 151 | (cond 152 | ((null? xs) #f) 153 | ((eval (car xs) e) #t) 154 | (#t (apply (wrap or?) (cdr xs) e))))) 155 | 156 | (define combiner? 157 | (lambda xs 158 | (apply (wrap and?) (map (lambda (x) (or? (operative? x) (applicative? x))) xs)))) 159 | 160 | (define at 161 | (lambda (n xs) 162 | (car (drop n xs)))) 163 | 164 | (define reduce 165 | (lambda (f xs a) 166 | (if (null? xs) 167 | a 168 | (reduce f (cdr xs) (f a (car xs)))))) 169 | 170 | (define append 171 | (lambda xss 172 | (define append2 173 | (lambda (xs ys) 174 | (if (null? xs) 175 | ys 176 | (cons (car xs) (append2 (cdr xs) ys))))) 177 | 178 | (reduce append2 xss ()))) 179 | 180 | (define list-neighbors 181 | (lambda (xs) 182 | (if (>? (length xs) 1) 183 | (cons (list (car xs) (cadr xs)) (list-neighbors (cdr xs))) 184 | ()))) 185 | 186 | (define filter 187 | (lambda (accept? xs) 188 | (if (null? xs) 189 | () 190 | (let (((a . bs) xs)) 191 | (if (apply accept? (list a)) 192 | (cons a (filter accept? bs)) 193 | (filter accept? bs)))))) 194 | 195 | (define lookup 196 | (lambda (n ps) 197 | (if (null? ps) 198 | (cons #f ()) 199 | (let ((((k v) . rest) ps)) 200 | (if (equal? n k) 201 | (cons #t v) 202 | (lookup n rest)))))) 203 | 204 | (define member? 205 | (lambda (x xs) 206 | (cond 207 | ((null? xs) #f) 208 | ((equal? x (car xs)) #t) 209 | (#t (member? x (cdr xs)))))) 210 | 211 | (define get-current-environment (wrap (vau () e e))) 212 | 213 | (define make-hummus-static-environment 214 | (lambda () (get-current-environment))) 215 | 216 | (define let* 217 | (vau (bindings . body) env 218 | (eval (if (null? bindings) 219 | (list* let bindings body) 220 | (list let (list (car bindings)) 221 | (list* let* (cdr bindings) body))) 222 | env))) 223 | 224 | (define letrec 225 | (vau (bindings . body) env 226 | (eval (list* let () 227 | (list define 228 | (map car bindings) 229 | (cons list (map cadr bindings))) 230 | body) 231 | env))) 232 | 233 | (define letrec* 234 | (vau (bindings . body) env 235 | (eval (if (null? bindings) 236 | (list* letrec bindings body) 237 | (list letrec (list (car bindings)) 238 | (list* letrec* (cdr bindings) body))) 239 | env))) 240 | 241 | (define let-redirect 242 | (vau (exp bindings . body) env 243 | (eval (cons (eval (list* lambda (map car bindings) body) (eval exp env)) 244 | (map cadr bindings)) env))) 245 | 246 | (define let-safe 247 | (vau (bindings . body) env 248 | (eval (list* let-redirect 249 | (make-hummus-static-environment) 250 | bindings 251 | body) 252 | env))) 253 | 254 | (define remote-eval 255 | (vau (o e) d 256 | (eval o (eval e d)))) 257 | 258 | (define bindings->environment 259 | (vau bindings env 260 | (eval (list let-redirect 261 | (make-environment) 262 | bindings 263 | (list get-current-environment)) 264 | env))) 265 | 266 | (define set! 267 | (vau (target formals values) env 268 | (eval (list define formals (list (unwrap eval) values env)) 269 | (eval target env)))) 270 | 271 | (define provide! 272 | (vau (symbols . body) env 273 | (eval (list define symbols 274 | (list let () 275 | (cons sequence body) 276 | (cons list symbols))) 277 | env))) 278 | 279 | (define import! 280 | (vau (exp . symbols) env 281 | (eval (list set! env symbols (cons list symbols)) 282 | (eval exp env)))) 283 | 284 | (define for-each 285 | (wrap (vau (x f) env (apply map (list f x) env) #inert))) 286 | 287 | (define defn 288 | (vau (name . body) e 289 | (if (pair? name) 290 | (let (((n . as) name)) 291 | (eval (list define n 292 | (cons lambda (cons as body))) 293 | e)) 294 | (eval (cons define (cons name body)) e)))) 295 | 296 | (defn (exit) 297 | (abort root-prompt ())) 298 | 299 | (load (get-hummus-data-file "kernel/record.hms")) 300 | (load (get-hummus-data-file "kernel/object.hms")) 301 | (load (get-hummus-data-file "kernel/class.hms")) 302 | (load (get-hummus-data-file "kernel/condition.hms")) 303 | (load (get-hummus-data-file "kernel/generator.hms")) 304 | -------------------------------------------------------------------------------- /kernel/class.hms: -------------------------------------------------------------------------------- 1 | (provide! (class new) 2 | (define quote (vau (e) #ignore e)) 3 | 4 | (define class 5 | (vau (name . body) e 6 | (let ((pred-name (string->symbol (join (symbol->string name) "?"))) 7 | (cls (eval (list* make-object 8 | (list (quote public) (list (quote name)) 9 | (symbol->string name)) 10 | 11 | (list (quote public) (list (quote initialize)) 12 | #inert) 13 | 14 | body) 15 | e))) 16 | (defn (pred? o) 17 | (and? (object? o) 18 | (or? (eq? (send o parent) cls) 19 | (pred? (send o parent))))) 20 | 21 | (apply (wrap set!) (list e pred-name pred?)) 22 | (apply (wrap set!) (list e name cls)) 23 | 24 | cls))) 25 | 26 | (define new 27 | (vau (cls . args) e 28 | (let ((obj (clone (eval cls e)))) 29 | (eval (list* send obj (quote initialize) args) e) 30 | obj)))) 31 | -------------------------------------------------------------------------------- /kernel/condition.hms: -------------------------------------------------------------------------------- 1 | (provide! (with-restarts bind restart signal fail warn 2 | condition condition? error error? simple-error simple-error?) 3 | ; [message -> #inert] 4 | (define handlers (make-dynvar ())) 5 | 6 | ; [(name . (args -> any))] 7 | (define restarts (make-dynvar ())) 8 | 9 | (define with-restarts 10 | (vau (bindings . body) e 11 | (reset 12 | (lambda (p) 13 | (with ((restarts (append (map (make-restart e p) bindings) 14 | (restarts)))) 15 | (eval (cons sequence body) e)))))) 16 | 17 | (define restart 18 | (vau (name . args) e 19 | (let (((found . res) (lookup name (restarts)))) 20 | (if found 21 | (eval (cons res args) e) 22 | (fail (new unknown-restart name)))))) 23 | 24 | (define bind 25 | (vau (bindings . body) e 26 | (with ((handlers (append (map (make-handler e) bindings) 27 | (handlers)))) 28 | (eval (cons sequence body) e)))) 29 | 30 | (defn (signal msg) 31 | (for-each (handlers) 32 | (lambda ((p? . b)) 33 | (if (p? msg) 34 | (b msg) 35 | #inert)))) 36 | 37 | (defn (fail msg) 38 | (let ((err (if (error? msg) msg (new simple-error msg)))) 39 | (signal err) 40 | 41 | (display (join (send err name) ": ")) 42 | (print (send err message)) 43 | (exit))) 44 | 45 | (defn (warn msg) 46 | (signal msg) 47 | (display (join (send err name) ": ")) 48 | (print (send wrn message))) 49 | 50 | (defn (make-restart env prompt) 51 | (lambda ((name args . body)) 52 | (list name 53 | (eval (list lambda args (list abort prompt (cons sequence body))) 54 | env)))) 55 | 56 | (defn (make-handler env) 57 | (lambda ((pred? vars . body)) 58 | (eval 59 | (list cons pred? 60 | (list* lambda (if (null? vars) (list #ignore) vars) body)) 61 | env))) 62 | 63 | (class condition) 64 | 65 | (class error (delegates-to condition)) 66 | 67 | (class warning (delegates-to condition)) 68 | 69 | (class simple-error 70 | (delegates-to error) 71 | 72 | (public (initialize msg) 73 | (set msg msg)) 74 | 75 | (public (message) msg)) 76 | 77 | (class simple-warning 78 | (delegates-to warning) 79 | 80 | (public (initialize msg) 81 | (set msg msg)) 82 | 83 | (public (message) msg))) 84 | 85 | (class message-not-understood 86 | (delegates-to error) 87 | 88 | (public (initialize obj msg) 89 | (set obj obj) 90 | (set msg msg)) 91 | 92 | (public (message) 93 | (join "The message `" (symbol->string msg) 94 | "' is not understood by " (send obj inspect) "."))) 95 | 96 | (class unknown-restart 97 | (delegates-to error) 98 | 99 | (public (initialize name) 100 | (set name name)) 101 | 102 | (public (message) 103 | (join "Restart `" (symbol->string name) "' is unbound."))) 104 | 105 | (class cannot-send 106 | (delegates-to error) 107 | 108 | (public (initialize msg val) 109 | (set msg msg) 110 | (set val val)) 111 | 112 | (public (message) 113 | (join "Value `" (show val) "' does not know how to " 114 | "receive message `" (symbol->string msg) "'."))) 115 | -------------------------------------------------------------------------------- /kernel/generator.hms: -------------------------------------------------------------------------------- 1 | (provide! (generator) 2 | (defn (aux f) 3 | (define here (get-current-environment)) 4 | 5 | (defn (start #ignore) 6 | (reset 7 | (lambda (p) 8 | (f (lambda (v) 9 | (shift p 10 | (lambda (k) 11 | (set! here start k) 12 | v))))))) 13 | 14 | (lambda () (start #inert))) 15 | 16 | (define quote (vau (e) #ignore e)) 17 | 18 | (define generator 19 | (vau body e 20 | (eval (list aux (list* lambda (quote (yield)) body)) e)))) 21 | -------------------------------------------------------------------------------- /kernel/object.hms: -------------------------------------------------------------------------------- 1 | (provide! (make-object object? send clone something) 2 | (define-record object (parent slots public private)) 3 | (define-record method (args body context)) 4 | 5 | (define make-object 6 | (vau body e 7 | (let ((obj (new-object e))) 8 | (eval (cons list body) (object-private obj)) 9 | obj))) 10 | 11 | (defn (clone o) 12 | (make-object (delegates-to o))) 13 | 14 | (define send 15 | (vau (target msg . args) e 16 | (define val (eval target e)) 17 | 18 | (define (where obj) 19 | (cond 20 | ((object? val) (list val val)) 21 | 22 | ; combiners 23 | ((applicative? val) 24 | (list (make-primitive val applicative) applicative)) 25 | 26 | ((dynvar? val) 27 | (list (make-primitive val dynvar) dynvar)) 28 | 29 | ((operative? val) 30 | (list (make-primitive val operative) operative)) 31 | 32 | ((combiner? val) 33 | (list (make-primitive val combiner) combiner)) 34 | 35 | ; other primitives 36 | ((boolean? val) 37 | (list (make-primitive val boolean) boolean)) 38 | 39 | ((environment? val) 40 | (list (make-primitive val environment) environment)) 41 | 42 | ((ignore? val) 43 | (list (make-primitive val ignore) ignore)) 44 | 45 | ((inert? val) 46 | (list (make-primitive val inert) inert)) 47 | 48 | ((null? val) 49 | (list (make-primitive val null) null)) 50 | 51 | ((number? val) 52 | (list (make-primitive val number) number)) 53 | 54 | ((pair? val) 55 | (list (make-primitive val pair) pair)) 56 | 57 | ((prompt? val) 58 | (list (make-primitive val prompt) prompt)) 59 | 60 | ((string? val) 61 | (list (make-primitive val string) string)) 62 | 63 | ((subcontinuation? val) 64 | (list (make-primitive val subcontinuation) subcontinuation)) 65 | 66 | ((symbol? val) 67 | (list (make-primitive val symbol) symbol)) 68 | 69 | ; encapsulation 70 | ((record? val) 71 | (list (make-primitive val record) record)) 72 | 73 | (#t (fail (new cannot-send msg val))))) 74 | 75 | (send-from e where obj msg args))) 76 | 77 | (defn (make-primitive val obj) 78 | (let ((inst (clone obj))) 79 | (set! (object-private inst) this val) 80 | inst)) 81 | 82 | (defn (send-from e where obj msg args) 83 | (define public (object-public obj)) 84 | 85 | (cond 86 | ((apply (wrap binds?) (list public msg)) 87 | (define meth (eval msg public)) 88 | 89 | (eval 90 | (list* 91 | let-redirect 92 | (make-environment 93 | (object-slots where) 94 | (object-public where) 95 | (object-private where) 96 | (object-slots obj) 97 | (object-public obj) 98 | (method-context meth)) 99 | (list (list (method-args meth) (cons list args))) 100 | (method-body meth)) 101 | e)) 102 | 103 | ((null? (object-parent obj)) 104 | (fail (new message-not-understood where msg))) 105 | 106 | (#t (send-from e where (object-parent obj) msg args)))) 107 | 108 | (defn (new-object e) 109 | (let* ((slots (make-environment)) 110 | (public (make-environment)) 111 | (private (make-environment e)) 112 | (obj (object something slots public private))) 113 | (set! private this obj) 114 | 115 | (set! private *parent* (lambda () (object-parent obj))) 116 | 117 | (set! private property 118 | (vau (x y) env 119 | (apply (wrap set!) (list slots x (eval y env))) 120 | (apply (wrap set!) (list public x (eval (list lambda () x) slots))))) 121 | 122 | (set! private accessor 123 | (vau (what) #ignore 124 | (apply (wrap set!) 125 | (list public what (eval (list lambda () what) slots))))) 126 | 127 | (set! private delegates-to 128 | (lambda (to) 129 | (set-object-parent! obj to))) 130 | 131 | (set! private set 132 | (vau (where what) e 133 | (eval (list set! slots where what) e))) 134 | 135 | (set! public responds-to? 136 | (vau (what) #ignore 137 | (or? (apply (wrap binds?) (list public what)) 138 | (send (object-parent obj) responds-to? what)))) 139 | 140 | (set! private public 141 | (vau ((name . args) . body) e 142 | (apply (wrap set!) (list slots name (vau args e (eval (list* send (string->symbol "this") name args) e)))) 143 | (apply (wrap set!) (list public name (method args body e))))) 144 | 145 | (remote-eval (public (parent) (*parent*)) private) 146 | 147 | (remote-eval (public (delegate-to x) (delegates-to x)) private) 148 | 149 | obj)) 150 | 151 | (define something ()) 152 | 153 | (define something 154 | (make-object 155 | (public (->string) 156 | (inspect)) 157 | 158 | (public (inspect) 159 | (show this))))) 160 | 161 | (define combiner (make-object)) 162 | (define applicative (make-object (delegates-to combiner))) 163 | (define dynvar (make-object (delegates-to combiner))) 164 | (define operative (make-object (delegates-to combiner))) 165 | 166 | (define boolean (make-object)) 167 | (define environment (make-object)) 168 | (define ignore (make-object)) 169 | (define inert (make-object)) 170 | (define null (make-object)) 171 | (define number (make-object)) 172 | (define pair (make-object)) 173 | (define prompt (make-object)) 174 | (define string 175 | (make-object 176 | (public (->string) this))) 177 | (define subcontinuation (make-object)) 178 | (define symbol (make-object)) 179 | 180 | (define record 181 | (make-object 182 | (public (inspect) ""))) 183 | -------------------------------------------------------------------------------- /kernel/record.hms: -------------------------------------------------------------------------------- 1 | (provide! (define-record record?) 2 | (define (record record? derecord) (make-encapsulation-type)) 3 | 4 | (define define-record 5 | (vau (name slots) e 6 | (let (((c p? as ss) (make-record slots)) 7 | (pred-name (string->symbol (join (symbol->string name) "?")))) 8 | (apply (wrap set!) (list e name c)) 9 | (apply (wrap set!) (list e pred-name p?)) 10 | 11 | (zip (lambda (slot a) 12 | (define an 13 | (string->symbol (join (symbol->string name) "-" 14 | (symbol->string slot)))) 15 | (apply (wrap set!) (list e an a))) 16 | slots as) 17 | 18 | (zip (lambda (slot s) 19 | (define sn 20 | (string->symbol (join "set-" (symbol->string name) "-" 21 | (symbol->string slot) "!"))) 22 | (apply (wrap set!) (list e sn s))) 23 | slots ss) 24 | 25 | #inert))) 26 | 27 | (defn (make-record slots) 28 | (define (c p? d) (make-encapsulation-type)) 29 | 30 | (define constructor 31 | (apply (wrap lambda) 32 | (list slots 33 | (list record 34 | (list c (list* bindings->environment 35 | (zip list slots slots))))))) 36 | 37 | (define predicate 38 | (lambda (r) (and? (record? r) (p? (derecord r))))) 39 | 40 | (define accessors 41 | (map (lambda (s) (lambda (r) (eval s (d (derecord r))))) slots)) 42 | 43 | (define setters 44 | (map (lambda (s) (lambda (r v) (apply (wrap set!) (list (d (derecord r)) s v)))) slots)) 45 | 46 | (list constructor predicate accessors setters))) 47 | -------------------------------------------------------------------------------- /src/Control/Monad/CC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types, GeneralizedNewtypeDeriving, MultiParamTypeClasses, 2 | UndecidableInstances, FunctionalDependencies, FlexibleInstances, GADTs #-} 3 | 4 | -------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Control.Monad.CC 7 | -- Copyright : (c) R. Kent Dybvig, Simon L. Peyton Jones and Amr Sabry 8 | -- License : MIT 9 | -- 10 | -- Maintainer : Dan Doel 11 | -- Stability : Experimental 12 | -- Portability : Non-portable (rank-2 types, multi-parameter type classes, 13 | -- functional dependencies) 14 | -- 15 | -- A monadic treatment of delimited continuations. 16 | -- 17 | -- Adapted from the paper 18 | -- /A Monadic Framework for Delimited Continuations/, 19 | -- by R. Kent Dybvig, Simon Peyton Jones and Amr Sabry 20 | -- () 21 | -- 22 | -- This module implements the delimited continuation monad and transformer, 23 | -- using the sequence-of-frames implementation from the original paper. 24 | module Control.Monad.CC ( 25 | -- * The CC monad 26 | CC(..), 27 | runCC, 28 | -- * The CCT monad transformer 29 | CCT(..), 30 | runCCT, 31 | SubCont(), 32 | Prompt, 33 | MonadDelimitedCont(..), 34 | -- * Assorted useful control operators 35 | reset, 36 | shift, 37 | control, 38 | shift0, 39 | control0, 40 | abort, 41 | appk 42 | -- * Examples 43 | -- $Examples 44 | ) where 45 | 46 | import Control.Applicative 47 | 48 | import Control.Monad.Identity 49 | import Control.Monad.State 50 | import Control.Monad.Reader 51 | 52 | import Prelude hiding (catch) 53 | 54 | import Control.Monad.CC.Seq 55 | import Control.Monad.CC.Prompt 56 | 57 | -- newtype Frame m ans a b = Frame (a -> CCT ans m b) 58 | data Frame m ans a b = FFrame (a -> b) 59 | | MFrame (a -> CCT ans m b) 60 | 61 | type Cont ans m a = Seq (Frame m) ans a 62 | newtype SubCont ans m a b = SC (SubSeq (Frame m) ans a b) 63 | 64 | -- | The CCT monad transformer allows you to layer delimited control 65 | -- effects over an arbitrary monad. 66 | -- 67 | -- The CCT transformer is parameterized by the following types 68 | -- 69 | -- * ans : A region parameter, so that prompts and subcontinuations 70 | -- may only be used in the same region they are created. 71 | -- 72 | -- * m : the underlying monad 73 | -- 74 | -- * a : The contained value. A value of type CCT ans m a can be though 75 | -- of as a computation that calls its continuation with a value of 76 | -- type 'a' 77 | newtype CCT ans m a = CCT { unCCT :: Cont ans m a -> P ans m ans } 78 | 79 | instance (Monad m) => Functor (CCT ans m) where 80 | fmap f (CCT e) = CCT $ \k -> e (PushSeg (FFrame f) k) 81 | 82 | instance (Monad m) => Applicative (CCT ans m) where 83 | pure = return 84 | (<*>) = ap 85 | 86 | instance (Monad m) => Monad (CCT ans m) where 87 | return v = CCT $ \k -> appk k v 88 | (CCT e1) >>= e2 = CCT $ \k -> e1 (PushSeg (MFrame e2) k) 89 | 90 | instance MonadTrans (CCT ans) where 91 | lift m = CCT $ \k -> lift m >>= appk k 92 | 93 | instance (MonadReader r m) => MonadReader r (CCT ans m) where 94 | ask = lift ask 95 | local f m = CCT $ \k -> local f (unCCT m k) 96 | 97 | instance (MonadState s m) => MonadState s (CCT ans m) where 98 | get = lift get 99 | put = lift . put 100 | 101 | instance (MonadIO m) => MonadIO (CCT ans m) where 102 | liftIO = lift . liftIO 103 | 104 | 105 | -- Applies a continuation to a value. 106 | appk :: Monad m => Cont ans m a -> a -> P ans m ans 107 | appk EmptyS a = return a 108 | appk (PushP _ k) a = appk k a 109 | appk (PushSeg f k) a = appFrame f a k 110 | where 111 | appFrame (MFrame g) b l = unCCT (g b) l 112 | appFrame (FFrame g) b l = appk l (g b) 113 | 114 | -- | Executes a CCT computation, yielding a value in the underlying monad 115 | runCCT :: (Monad m) => (forall ans. CCT ans m a) -> m a 116 | runCCT c = runP (unCCT c EmptyS) 117 | 118 | -- | The CC monad may be used to execute computations with delimited control. 119 | newtype CC ans a = CC { unCC :: CCT ans Identity a } 120 | deriving (Functor, Monad, Applicative, 121 | MonadDelimitedCont (Prompt ans) (SubCont ans Identity)) 122 | 123 | -- | Executes a CC computation, yielding a resulting value. 124 | runCC :: (forall ans. CC ans a) -> a 125 | runCC c = runIdentity (runCCT (unCC c)) 126 | 127 | -- | A typeclass for monads that support delimited control operators. 128 | -- The type varibles represent the following: 129 | -- 130 | -- m : The monad itself 131 | -- 132 | -- p : The associated type of prompts that may delimit computations in the monad 133 | -- 134 | -- s : The associated type of sub-continuations that may be captured 135 | class (Monad m) => MonadDelimitedCont p s m | m -> p s where 136 | -- | Creates a new, unique prompt. 137 | newPrompt :: m (p a) 138 | -- | Delimits a computation with a given prompt. 139 | pushPrompt :: p a -> m a -> m a 140 | -- | Abortively capture the sub-continuation delimited by the given 141 | -- prompt, and call the given function with it. The prompt does not appear 142 | -- delimiting the sub-continuation, nor the resulting computation. 143 | withSubCont :: p b -> (s a b -> m b) -> m a 144 | -- | Pushes a sub-continuation, reinstating it as part of the continuation. 145 | pushSubCont :: s a b -> m a -> m b 146 | -- | Checks if the given prompt is valid. 147 | isValidPrompt :: p b -> m Bool 148 | 149 | instance (Monad m) => MonadDelimitedCont (Prompt ans) (SubCont ans m) (CCT ans m) where 150 | newPrompt = CCT $ \k -> newPromptName >>= appk k 151 | pushPrompt p (CCT e) = CCT $ \k -> e (PushP p k) 152 | withSubCont p f = CCT $ \k -> let (subk, k') = splitSeq p k 153 | in unCCT (f (SC subk)) k' 154 | pushSubCont (SC subk) (CCT e) = CCT $ \k -> e (pushSeq subk k) 155 | isValidPrompt p = CCT $ \k -> appk k (inSeq p k) 156 | 157 | -- | An approximation of the traditional /reset/ operator. Creates a new prompt, 158 | -- calls the given function with it, and delimits the resulting computation 159 | -- with said prompt. 160 | reset :: (MonadDelimitedCont p s m) => (p a -> m a) -> m a 161 | reset e = newPrompt >>= \p -> pushPrompt p (e p) 162 | 163 | -- ----- 164 | -- These originally had types like: 165 | -- 166 | -- ((a -> m b) -> m b) -> m a 167 | -- 168 | -- but I came to the conclusion that it would be convenient to be able to pass 169 | -- in monadically typed values. 170 | -- As a specific example, this makes the difference between 171 | -- 172 | -- > shift q (\f -> f (dref p)) 173 | -- 174 | -- and 175 | -- 176 | -- > join $ shift q (\f -> f (dref p)) 177 | -- 178 | -- In other words, one can expressed in terms of the other (I think), but 179 | -- the fact that one has to insert a 'join' /outside/ the shift, and not 180 | -- anywhere near where the sub-continuation is actually used is rather 181 | -- odd, and difficult to remember compared to the difference between: 182 | -- 183 | -- > shift q (\f -> f (return pureValue)) 184 | -- 185 | -- and 186 | -- 187 | -- > shift q (\f -> f pureValue) 188 | -- ----- 189 | 190 | -- | The traditional /shift/ counterpart to the above 'reset'. Reifies the 191 | -- subcontinuation into a function, keeping both the subcontinuation, and 192 | -- the resulting computation delimited by the given prompt. 193 | shift :: (MonadDelimitedCont p s m) => p b -> ((m a -> m b) -> m b) -> m a 194 | shift p f = withSubCont p $ \sk -> pushPrompt p $ 195 | f (\a -> pushPrompt p $ pushSubCont sk a) 196 | 197 | -- | The /control/ operator, traditionally the counterpart of /prompt/. It does 198 | -- not delimit the reified subcontinuation, so control effects therein can 199 | -- escape. The corresponding prompt is performed equally well by 'reset' above. 200 | control :: (MonadDelimitedCont p s m) => p b -> ((m a -> m b) -> m b) -> m a 201 | control p f = withSubCont p $ \sk -> pushPrompt p $ 202 | f (\a -> pushSubCont sk a) 203 | 204 | -- | Abortively captures the current subcontinuation, delimiting it in a reified 205 | -- function. The resulting computation, however, is undelimited. 206 | shift0 :: (MonadDelimitedCont p s m) => p b -> ((m a -> m b) -> m b) -> m a 207 | shift0 p f = withSubCont p $ \sk -> f (\a -> pushPrompt p $ pushSubCont sk a) 208 | 209 | -- | Abortively captures the current subcontinuation, delimiting neither it nor 210 | -- the resulting computation. 211 | control0 :: (MonadDelimitedCont p s m) => p b -> ((m a -> m b) -> m b) -> m a 212 | control0 p f = withSubCont p $ \sk -> f (\a -> pushSubCont sk a) 213 | 214 | -- | Aborts the current continuation up to the given prompt. 215 | abort :: (MonadDelimitedCont p s m) => p b -> m b -> m a 216 | abort p e = withSubCont p (\_ -> e) 217 | 218 | ------------------------------------------------------------------------------- 219 | -- $Examples 220 | -- 221 | -- This module provides many different control operators, so hopefully the 222 | -- examples herein can help in selecting the right ones. The most raw are the 223 | -- four contained in the 'MonadDelimitedCont' type class. The first, of course, 224 | -- is 'newPrompt', which should be straight forward enough. Next comes 225 | -- 'pushPromp't, which is the basic operation that delimits a computation. 226 | -- In the absense of other control operators, it's simply a no-op, so 227 | -- 228 | -- > pushPrompt p (return v) == return v 229 | -- 230 | -- 'withSubCont' is the primitive that allows the capture of sub-continuations. 231 | -- Unlike callCC, 'withSubCont' aborts the delimited continuation it captures, 232 | -- so: 233 | -- 234 | -- > pushPrompt p ((1:) `liftM` (2:) `liftM` withSubCont p (\k -> return [])) 235 | -- 236 | -- will yield a value of [] on running, not [1, 2]. 237 | -- 238 | -- The final primitive control operator is 'pushSubCont', which allows the use 239 | -- of the sub-continuations captured using 'withSubCont'. So: 240 | -- 241 | -- > pushPrompt p ((1:) `liftM1 (2:) `liftM` 242 | -- > withSubCont p (\k -> pushSubCont k (return []))) 243 | -- 244 | -- will yield the answer [1, 2]. /However/, Capturing a sub-continuation and 245 | -- immediately pusshing it /is not/ a no-op, because the sub-continuation 246 | -- does not contain the delimiting prompt (and, of course, pushSubCont does 247 | -- not re-instate it, as it doesn't know what prompt was originally used). 248 | -- Thus, capturing and pushing a sub-continuation results in the net loss of 249 | -- one delimiter, and said delimiter will need to be re-pushed to negate that 250 | -- effect, if desired. 251 | -- 252 | -- Out of these four primitive operators have been built various functional 253 | -- abstractions that incorporate one or more operations. On the delimiting 254 | -- side is 'reset', which combines both prompt creation and delimiting. In 255 | -- some papers on the subject (such as /Shift to Control/), each capture 256 | -- operator would be paired with a corresponding delimiter operator (and 257 | -- indeed, a separate CPS transform). However, since prompts are explicitly 258 | -- passed in this implementation, a single delimiter suffices for supporting 259 | -- all capture operators (although 'pushPrompt' will need to be used if one 260 | -- wishes to explicitly push a prompt more than once). 261 | -- 262 | -- The simplest control flow operator is 'abort', which, as its name suggests, 263 | -- simply aborts a given sub-continuation. For instance, the second example 264 | -- above can be written: 265 | -- 266 | -- > pushPrompt p ((1:) `liftM` (2:) `liftM` abort p (return [])) 267 | -- 268 | -- The rest of the functions reify the sub-continuation into a function, 269 | -- so that it can be used. The shift/control operators all have similar 270 | -- effects in this regard, but differ as to where they delimit various 271 | -- parts of the resulting computation. Some names may help a bit for the 272 | -- following explanation, so consider: 273 | -- 274 | -- > shift p (\f -> e) 275 | -- 276 | -- /p/ is, obviously, the prompt; /f/ is the reified continuation, and /e/ 277 | -- is the computation that will be run in the aborted context. With these 278 | -- names in mind, the control operators work as follows: 279 | -- 280 | -- * 'shift' delimits both /e/ and every invocation of /f/. So, effectively, 281 | -- when using 'shift', control effects can never escape a delimiter, and 282 | -- computations of the form: 283 | -- 284 | -- > reset (\p -> ) 285 | -- 286 | -- /look/ pure from the outside. 287 | -- 288 | -- * 'control' delimits /e/, but not the sub-continuation in /f/. Thus, if 289 | -- the sub-continuation contains other 'control' invocations, the effects 290 | -- may escape an enclosing delimiter. So, for example: 291 | -- 292 | -- > reset (\p -> shift p (\f -> (1:) `liftM` f (return [])) 293 | -- >>= \y -> shift p (\_ -> return y)) 294 | -- 295 | -- yields a value of [1], while replacing the 'shift's with 'control' 296 | -- yields a value of []. 297 | -- 298 | -- * 'shift0' delimits /f/, but not /e/. So: 299 | -- 300 | -- > reset (\p -> (1:) `liftM` pushPrompt p 301 | -- > (shift0 p (\_ -> shift0 p (\_ -> return [])))) 302 | -- 303 | -- yields [], whereas using 'shift' would yield [1]. 304 | -- 305 | -- * 'control0' delimits neither /e/ nor /f/, and is, in effect, the reified 306 | -- analogue to using withSubCont and pushSubCont directly. 307 | -- 308 | -- For a more complete and in-depth discussion of these four control operators, 309 | -- see /Shift to Control/, by Chung-chieh Shan. 310 | -- 311 | -- A small example program follows. It uses delimited continuations to reify a 312 | -- monadic loop into an iterator object. Saving references to old iterators 313 | -- allows one to effecively store references to various points in the traversal. 314 | -- Effectively, this is a simple, restricted case of a generalized zipper. 315 | -- 316 | -- > data Iterator r a = I a (CC r (Iterator r a)) | Done 317 | -- > 318 | -- > current :: Iterator r a -> Maybe a 319 | -- > current (I a _) = Just a 320 | -- > current Done = Nothing 321 | -- > 322 | -- > next :: Iterator r a -> CC r (Iterator r a) 323 | -- > next (I _ m) = m 324 | -- > next Done = return Done 325 | -- > 326 | -- > iterator :: ((a -> CC r ()) -> CC r ()) -> CC r (Iterator r a) 327 | -- > iterator loop = reset $ \p -> 328 | -- > loop (\a -> 329 | -- > shift p $ \k -> 330 | -- > return $ I a (k $ return ())) >> return Done 331 | -- > 332 | -- > test = do i <- iterator $ forM_ [1..5] 333 | -- > go [] i 334 | -- > where 335 | -- > go l Done = return l 336 | -- > go l i = do let (Just a) = current i 337 | -- > l' = replicate a a ++ l 338 | -- > i' <- next i 339 | -- > go l' i' 340 | -- 341 | -- The results are what one might expect from such an iterator object: 342 | -- 343 | -- > *Test> runCC test 344 | -- > [5,5,5,5,5,4,4,4,4,3,3,3,2,2,1] 345 | -------------------------------------------------------------------------------- /src/Control/Monad/CC/Cursor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies #-} 2 | 3 | ------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Control.Monad.CC.Cursor 6 | -- Copyright : (c) Dan Doel 7 | -- License : MIT 8 | -- 9 | -- Maintainer : Dan Doel 10 | -- Stability : Experimental 11 | -- Portability : Non-portable (Generalized algebraic data types, 12 | -- Functional Dependencies) 13 | -- 14 | -- Implements various cursor datatypes for iterating over collections 15 | module Control.Monad.CC.Cursor ( 16 | Cursor(..), 17 | Iterator, 18 | generator, 19 | iterator, 20 | current, 21 | next, 22 | open, 23 | update, 24 | -- Walkable(..), 25 | -- Zipper, 26 | -- zipper, 27 | -- previousDir, 28 | -- currentTerm, 29 | -- move 30 | ) where 31 | 32 | import Prelude hiding (zip, mapM, mapM_) 33 | import Control.Monad hiding (mapM, mapM_) 34 | import Control.Monad.CC 35 | 36 | import Data.Maybe 37 | import Data.Foldable 38 | import Data.Traversable hiding (traverse) 39 | 40 | -- | A generalized type that represents a reified data structure traversal. 41 | -- The other traversal data types in this module are special cases of this 42 | -- general type. Cursor is parameterized by four types: 43 | -- 44 | -- m : The monad in which the Cursor object is usable. 45 | -- 46 | -- r : The result type, which will be stored in the cursor once the traversal 47 | -- has been completed. 48 | -- 49 | -- b : The type that the cursor expects to receive before moving on to the 50 | -- next element in the traversal. 51 | -- 52 | -- a : The element type to which the Cursor provides access at each step in 53 | -- the traversal. 54 | data Cursor m r b a where 55 | Current :: Monad m => a -> (b -> m (Cursor m r b a)) -> Cursor m r b a 56 | Done :: Monad m => r -> Cursor m r b a 57 | 58 | -- | A simple iterator, which provides a way to view each of the elements of 59 | -- a data structure in order. 60 | type Iterator m a = Cursor m () () a 61 | 62 | -- | A function for making a cursor out of a free form generator, similar to 63 | -- using 'yield' in Ruby or Python. For example: 64 | -- 65 | -- > generator $ \yield -> do a <- yield 1 ; yield 2 ; b <- yield 3 ; return [a,b] 66 | generator :: MonadDelimitedCont p s m => ((a -> m b) -> m r) -> m (Cursor m r b a) 67 | generator f = reset (\p -> Done `liftM` f (yield p)) 68 | where yield p a = shift p (\k -> return $ Current a (k . return)) 69 | 70 | -- A general cursor builder; takes the traversal function, a data structure, and 71 | -- returns a corresponding cursor. Currently not exported, just used internally. 72 | makeCursor :: (MonadDelimitedCont p s m) => 73 | ((a -> m b) -> t -> m r) -> t -> m (Cursor m r b a) 74 | makeCursor iter t = generator $ flip iter t 75 | 76 | -- | Creates an Iterator that will yield each of the elements of a Foldable in 77 | -- order. 78 | iterator :: (Foldable t, MonadDelimitedCont p s m) => t a -> m (Iterator m a) 79 | iterator = makeCursor mapM_ 80 | 81 | -- | Advances an Iterator to the next element (has no effect on a finished Iterator). 82 | next :: Iterator m a -> m (Iterator m a) 83 | next = update () 84 | 85 | -- | Extracts the current element from a cursor, if applicable. 86 | current :: Cursor m r b a -> Maybe a 87 | current (Done _) = Nothing 88 | current (Current a _) = Just a 89 | 90 | -- | Begins an updating traversal over a Traversable structure. At each step, 91 | -- the cursor will hold an element of type a, and providing an element of type 92 | -- b will move on to the next step. When done, a new Traversable object holding 93 | -- elements of type b will be available. 94 | open :: (Traversable t, MonadDelimitedCont p s m) => t a -> m (Cursor m (t b) b a) 95 | open = makeCursor mapM 96 | 97 | -- | Provides an item to a Cursor, moving on to the next step in the traversal. 98 | -- (has no effect on a finished Cursor). 99 | update :: b -> Cursor m r b a -> m (Cursor m r b a) 100 | update _ c@(Done _) = return c 101 | update b (Current _ k) = k b 102 | 103 | -- Removing for now. This isn't remotely done, and I need to reread ccshan's 104 | -- stuff on zippers and such before I can begin to get it right. 105 | {- 106 | class Direction d where 107 | nextD :: d -> d 108 | 109 | class Direction d => Walkable t d | t -> d where 110 | walk :: Monad m => (d -> t -> m (Maybe t, d)) -> t -> m t 111 | 112 | data ListDir = LLeft | LRight 113 | 114 | instance Direction ListDir where 115 | nextD = id 116 | 117 | instance Walkable [a] ListDir where 118 | walk tr ll = fromMaybe ll `liftM` traverse LRight ll 119 | where 120 | traverse d l = do (ml, d') <- tr d l 121 | let l' = fromMaybe l ml 122 | maybe ml Just `liftM` select l' d' 123 | select _ LLeft = return Nothing 124 | select l@(x:xs) LRight = do l' <- liftM (x:) `liftM` traverse LRight xs 125 | maybe l' Just `liftM` traverse LLeft (fromMaybe l l') 126 | select [] LRight = maybe Nothing Just `liftM` traverse LLeft [] 127 | 128 | type Zipper m t d = Cursor m t (Maybe t, d) (d,t) 129 | 130 | zipper :: (MonadDelimitedCont p s m, Walkable t d) => t -> m (Zipper m t d) 131 | zipper = makeCursor $ walk . curry 132 | 133 | previousDir :: Zipper m t d -> Maybe d 134 | previousDir (Done _) = Nothing 135 | previousDir (Current (d,_) _) = Just d 136 | 137 | currentTerm :: Zipper m t d -> t 138 | currentTerm (Done t) = t 139 | currentTerm (Current (_,t) _) = t 140 | 141 | move :: d -> Zipper m t d -> m (Zipper m t d) 142 | move _ z@(Done _) = return z 143 | move d (Current _ k) = k (Nothing, d) 144 | -} 145 | -------------------------------------------------------------------------------- /src/Control/Monad/CC/Dynvar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | ------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Control.Monad.CC.Dynvar 6 | -- Copyright : (c) Amr Sabry, Chung-chieh Shan and Oleg Kiselyov 7 | -- License : MIT 8 | -- 9 | -- Maintainer : Dan Doel 10 | -- Stability : Experimental 11 | -- Portability : Non-portable (generalized algebraic datatypes) 12 | -- 13 | -- An implementation of dynamically scoped variables using multi-prompt 14 | -- delimited control operators. This implementation follows that of the 15 | -- paper /Delimited Dynamic Binding/, by Oleg Kiselyov, Chung-chieh Shan and 16 | -- Amr Sabry (), adapting the 17 | -- Haskell implementation (available at 18 | -- ) to any delimited control 19 | -- monad (in practice, this is likely just CC and CCT m). 20 | -- 21 | -- See below for usage examples. 22 | module Control.Monad.CC.Dynvar ( 23 | -- * The Dynvar type 24 | Dynvar(), 25 | dnew, 26 | dref, 27 | dset, 28 | dmod, 29 | dupp, 30 | dlet, 31 | mdref, 32 | module Control.Monad.CC 33 | -- * examples 34 | -- $examples 35 | ) where 36 | 37 | import Control.Monad 38 | 39 | import Control.Monad.CC 40 | 41 | -- | The type of dynamically scoped variables in a given monad 42 | data Dynvar m a where 43 | Dynvar :: MonadDelimitedCont p s m => p (a -> m a) -> Dynvar m a 44 | 45 | -- | Creates a new dynamically scoped variable 46 | dnew :: MonadDelimitedCont p s m => m (Dynvar m a) 47 | dnew = Dynvar `liftM` newPrompt 48 | 49 | -- | Reads the value of a dynamically scoped variable 50 | dref :: Dynvar m a -> m a 51 | dref (Dynvar p) = shift p (\f -> return $ \v -> f (return v) >>= ($ v)) 52 | 53 | -- | Reads the value of a dynamically scoped variable 54 | mdref :: Dynvar m a -> m (Maybe a) 55 | mdref d@(Dynvar p) = do 56 | t <- isValidPrompt p 57 | if t 58 | then Just `liftM` dref d 59 | else return Nothing 60 | 61 | -- | Assigns a value to a dynamically scoped variable 62 | dset :: Dynvar m a -> a -> m a 63 | dset (Dynvar p) newv = shift p (\f -> return $ \v -> f (return v) >>= ($ newv)) 64 | 65 | -- | Modifies the value of a dynamically scoped variable 66 | dmod :: Dynvar m a -> (a -> a) -> m a 67 | dmod p@(Dynvar _) f = dref p >>= dset p . f 68 | 69 | -- | Calls the function, g, with the value of the given Dynvar 70 | dupp :: Dynvar m a -> (a -> m b) -> m b 71 | dupp p@(Dynvar _) g = dref p >>= g 72 | 73 | -- | Introduces a new value to the dynamic variable over a block 74 | dlet :: Dynvar m a -> a -> m b -> m b 75 | dlet (Dynvar p) v body = reset (\q -> 76 | pushPrompt p (body >>= (\z -> abort q (return z))) 77 | >>= ($ v) >>= undefined) 78 | 79 | ------------------------------------------------------------------------------- 80 | -- $examples 81 | -- The referenced paper provides a full treatment of the behavior of 82 | -- dynamically scoped variables and their interaction with delimited control. 83 | -- However, some examples might provide some intuition. First, a dynamic 84 | -- scoping example: 85 | -- 86 | -- > dscope = do p <- dnew 87 | -- > x <- dlet p 1 $ f p 88 | -- > y <- dlet p 2 $ f p 89 | -- > z <- dlet p 3 $ do z1 <- (dlet p 4 $ f p) 90 | -- > z2 <- f p 91 | -- > return $ z1 + z2 92 | -- > return $ x + y + z 93 | -- > where 94 | -- > f p = dref p 95 | -- 96 | -- > *Test> runCC dscope 97 | -- > 10 98 | -- 99 | -- In this example, x = 1, y = 2, z1 = 4 and z2 = 3, even though 100 | -- all come are from reading the same dynamically scoped variable. dlet 101 | -- introduces a scope in which references of the given variable take on a 102 | -- given value. As can be seen, shadowing works properly when writing code 103 | -- in this fashion. In many ways, this is like using the reader monad, with 104 | -- 'dref p' == 'ask', and 'dlet p v' == 'local (const v)'. The immediate 105 | -- difference, of course, is that you can have multiple dynamic variables 106 | -- instead of the single threaded environment of the reader monad. 107 | -- 108 | -- Of course, one can also use Dynvars mutably, as in the state monad: 109 | -- 110 | -- > settest = do p <- dnew 111 | -- > x <- dlet p 1 $ do x1 <- f p 112 | -- > dset p 2 113 | -- > x2 <- f p 114 | -- > return $ [x1, x2] 115 | -- > y <- dlet p 0 $ do y1 <- f p 116 | -- > y2 <- dlet p 1 $ do dset p 3 117 | -- > f p 118 | -- > y3 <- f p 119 | -- > return [y1, y2, y3] 120 | -- > return $ x ++ y 121 | -- > where 122 | -- > f p = dupp p return 123 | -- > 124 | -- > *Test> runCC settest 125 | -- > [1,2,0,3,0] 126 | -- 127 | -- So, with analogy to the state monad, 'dref p' == get, and 128 | -- 'dset p v' == 'put v'. Also, as one might expect, such mutations have 129 | -- effects only within the enclosing 'dlet' (and, in fact, an error will 130 | -- result from trying to 'dset' in a scope in which the dynamic var is not 131 | -- bound with 'dlet'). This example also demonstrates the use of the 'dupp' 132 | -- function, to implement the same 'f' function as the first example. 133 | -- Essentially 'dupp p f' = 'dref p >>= f'. 134 | -- 135 | -- Now, a bit on the interaction between delimited control and dynamic 136 | -- variables. Consider: 137 | -- 138 | -- > test = do p <- dnew 139 | -- > dlet p 5 (reset (\q -> dlet p 6 (shift q (\f -> dref p)))) 140 | -- > 141 | -- > *Test> runCC test 142 | -- > 5 143 | -- 144 | -- In this example, '... reset (\q ...' introduces a new delimited context, 145 | -- and '... shift q (\f ...' captures that context abortively. This results 146 | -- in the value of 'dref p' being 5, as the 'dlet p 6' resides in the aborted 147 | -- context. Now, consider a slightly more complex example: 148 | -- 149 | -- > test1 = do p <- dnew 150 | -- > dlet p 5 (reset (\q -> 151 | -- > dlet p 6 (shift q (\f -> 152 | -- > liftM2 (+) (dref p) (f (dref p)))))) 153 | -- > 154 | -- > *Test> runCC test1 155 | -- > 11 156 | -- 157 | -- Here we use 'dref p' twice. Once as before, after we have abortively captured 158 | -- the context, and thus, the outer binding of p is showing. However, the term 159 | -- 'f (dref p)' reinstitutes the captured context for its arguments, and thus, 160 | -- there, 'dref p' takes on a value of 6. 161 | -- 162 | -- Thus, to sum up, capturing a delimited context captures the dynamic variable 163 | -- bindings *within* that context, but leaves the dynamic bindings *outside* 164 | -- untouched. Similarly, if a context is put back pushed somewhere (for instance, 165 | -- by invoking the function returned by 'shift', it will put the captured 166 | -- dynamic bindings back in place, but will not restore those dynamic bindings 167 | -- outside of the delimited context (it will, instead, use those visible where 168 | -- the context is invoked. 169 | 170 | -------------------------------------------------------------------------------- /src/Control/Monad/CC/Prompt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-} 2 | 3 | ------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Control.Monad.CC.Prompt 6 | -- Copyright : (c) R. Kent Dybvig, Simon L. Peyton Jones and Amr Sabry 7 | -- License : MIT 8 | -- 9 | -- Maintainer : Dan Doel 10 | -- Stability : Experimental 11 | -- Portability : Non-portable (rank-2 types, generalized algebraic datatypes) 12 | -- 13 | -- A monadic treatment of delimited continuations. 14 | -- 15 | -- Adapted from the paper 16 | -- /A Monadic Framework for Delimited Continuations/, 17 | -- by R. Kent Dybvig, Simon Peyton Jones and Amr Sabry 18 | -- () 19 | -- 20 | -- This module implements the generation of unique prompt names to be used 21 | -- as delimiters. 22 | module Control.Monad.CC.Prompt ( 23 | -- * P, The prompt generation monad 24 | P, 25 | -- * The Prompt type 26 | Prompt, 27 | runP, 28 | newPromptName, 29 | eqPrompt, 30 | -- * A type equality datatype 31 | Equal(..) 32 | ) where 33 | 34 | import Control.Monad.State 35 | import Control.Monad.Reader 36 | 37 | import Unsafe.Coerce 38 | 39 | -- | The prompt type, parameterized by two types: 40 | -- * ans : The region identifier, used to ensure that prompts are only used 41 | -- within the same context in which they are created. 42 | -- 43 | -- * a : The type of values that may be returned 'through' a given prompt. 44 | -- For instance, only prompts of type 'Prompt r a' may be pushed onto a 45 | -- computation of type 'CC r a'. 46 | newtype Prompt ans a = Prompt Int 47 | 48 | -- | The prompt generation monad. Represents the type of computations that 49 | -- make use of a supply of unique prompts. 50 | newtype P ans m a = P { unP :: StateT Int m a } 51 | deriving (Functor, Monad, MonadTrans, MonadState Int, MonadReader r) 52 | 53 | -- | Runs a computation that makes use of prompts, yielding a result in the 54 | -- underlying monad. 55 | runP :: (Monad m) => P ans m ans -> m ans 56 | runP p = evalStateT (unP p) 0 57 | 58 | -- | Generates a new, unique prompt 59 | newPromptName :: (Monad m) => P ans m (Prompt ans a) 60 | newPromptName = do i <- get ; put (succ i) ; return (Prompt i) 61 | 62 | -- | A datatype representing type equality. The EQU constructor can 63 | -- be used to provide evidence that two types are equivalent. 64 | data Equal a b where 65 | EQU :: Equal a a 66 | NEQ :: Equal a b 67 | 68 | -- Unfortunately, the type system cannot check that the value of two prompts being 69 | -- equal ensures the equality of their types, so unsafeCoerce must be used. 70 | 71 | -- | Tests to determine if two prompts are equal. If so, it provides 72 | -- evidence of that fact, in the form of an /Equal/. 73 | eqPrompt :: Prompt ans a -> Prompt ans b -> Equal a b 74 | eqPrompt (Prompt p1) (Prompt p2) 75 | | p1 == p2 = unsafeCoerce EQU 76 | | otherwise = NEQ 77 | 78 | -------------------------------------------------------------------------------- /src/Control/Monad/CC/Seq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | ------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Control.Monad.CC.Seq 6 | -- Copyright : (c) R. Kent Dybvig, Simon L. Peyton Jones and Amr Sabry 7 | -- License : MIT 8 | -- 9 | -- Maintainer : Dan Doel 10 | -- Stability : Experimental 11 | -- Portability : Non-portable (generalized algebraic datatypes) 12 | -- 13 | -- A monadic treatment of delimited continuations. 14 | -- 15 | -- Adapted from the paper 16 | -- /A Monadic Framework for Delimited Continuations/, 17 | -- by R. Kent Dybvig, Simon Peyton Jones and Amr Sabry 18 | -- () 19 | -- 20 | -- This module implements the generalized sequence type used as a stack of 21 | -- frames representation of the delimited continuations. 22 | module Control.Monad.CC.Seq ( 23 | -- * Sequence datatype 24 | Seq(..), 25 | -- * Sub-sequences 26 | SubSeq, 27 | appendSubSeq, 28 | pushSeq, 29 | splitSeq, 30 | inSeq, 31 | ) where 32 | 33 | import Control.Monad.CC.Prompt 34 | 35 | -- | This is a generalized sequence datatype, parameterized by three types: 36 | -- seg : A constructor for segments of the sequence. 37 | -- 38 | -- ans : the type resulting from applying all the segments of the sequence. 39 | -- Also used as a region parameter. 40 | -- 41 | -- a : The type expected as input to the sequence of segments. 42 | data Seq seg ans a where 43 | EmptyS :: Seq seg ans ans 44 | PushP :: Prompt ans a -> Seq seg ans a -> Seq seg ans a 45 | PushSeg :: seg ans a b -> Seq seg ans b -> Seq seg ans a 46 | 47 | -- | A type representing a sub-sequence, which may be appended to a sequence 48 | -- of appropriate type. It represents a sequence that takes values of type 49 | -- a to values of type b, and may be pushed onto a sequence that takes values 50 | -- of type b to values of type ans. 51 | type SubSeq seg ans a b = Seq seg ans b -> Seq seg ans a 52 | 53 | -- | The null sub-sequence 54 | emptySubSeq :: SubSeq seg ans a a 55 | emptySubSeq = id 56 | 57 | -- | Concatenate two subsequences 58 | appendSubSeq :: SubSeq seg ans a b -> SubSeq seg ans b c -> SubSeq seg ans a c 59 | appendSubSeq = (.) 60 | 61 | -- | Push a sub-sequence onto the front of a sequence 62 | pushSeq :: SubSeq seg ans a b -> Seq seg ans b -> Seq seg ans a 63 | pushSeq = ($) 64 | 65 | -- | Splits a sequence at the given prompt into a sub-sequence, and 66 | -- the rest of the sequence 67 | splitSeq :: Prompt ans b -> Seq seg ans a -> (SubSeq seg ans a b, Seq seg ans b) 68 | splitSeq _ EmptyS = error "Prompt was not found on the stack." 69 | splitSeq p (PushP p' sk) = 70 | case eqPrompt p' p of 71 | EQU -> (emptySubSeq, sk) 72 | NEQ -> case splitSeq p sk of 73 | (subk, sk') -> (appendSubSeq (PushP p') subk, sk') 74 | splitSeq p (PushSeg seg sk) = 75 | case splitSeq p sk of 76 | (subk, sk') -> (appendSubSeq (PushSeg seg) subk, sk') 77 | 78 | 79 | inSeq :: Prompt ans b -> Seq seg ans a -> Bool 80 | inSeq _ EmptyS = False 81 | inSeq p (PushP p' sk) = 82 | case eqPrompt p' p of 83 | EQU -> True 84 | NEQ -> inSeq p sk 85 | inSeq p (PushSeg _ sk) = inSeq p sk 86 | -------------------------------------------------------------------------------- /src/Control/Monad/LICENSE: -------------------------------------------------------------------------------- 1 | The code in this library is derived from several sources: 2 | 3 | * Code for the implementation of delimited continuations (Control.Monad.CC, 4 | Control.Monad.CC.Prompt, Control.Monad.CC.Seq) is derived from work 5 | (c) R. Kent Dybvig, Simon L. Peyton Jones and Amr Sabry. 6 | 7 | * Code for dynamically scoped variables (Control.Monad.CC.Dynvar) is derived 8 | from work (c) Amr Sabry, Chung-chieh Shan and Oleg Kiselyov. 9 | 10 | * Additional modifications and improvements (c) Dan Doel and Oleg Kiselyov 11 | 12 | All code is available under the MIT license. The text of the licenses from the 13 | original sources is reproduced below. 14 | 15 | ------------------------------------------------------------------------------- 16 | 17 | Code derived from "A Monadic Framework for Delimited Continuations" is 18 | distributed under the following license: 19 | 20 | Copyright (c) 2005, R. Kent Dybvig, Simon L. Peyton Jones, and Amr Sabry 21 | 22 | Permission is hereby granted, free of charge, to any person obtaining 23 | a copy of this software and associated documentation files (the 24 | "Software"), to deal in the Software without restriction, including 25 | without limitation the rights to use, copy, modify, merge, publish, 26 | distribute, sublicense, and/or sell copies of the Software, and to 27 | permit persons to whom the Software is furnished to do so, subject to 28 | the following conditions: 29 | 30 | The above copyright notice and this permission notice shall be 31 | included in all copies or substantial portions of the Software. 32 | 33 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 34 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 35 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 36 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 37 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 38 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 39 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 40 | 41 | ------------------------------------------------------------------------------- 42 | 43 | Code derived from "Delimited Dynamic Binding" and its implementation is 44 | distributed under the following license: 45 | 46 | Copyright (c) 2006, Amr Sabry, Chung-chieh Shan, and Oleg Kiselyov 47 | 48 | Permission is hereby granted, free of charge, to any person obtaining 49 | a copy of this software and associated documentation files (the 50 | "Software"), to deal in the Software without restriction, including 51 | without limitation the rights to use, copy, modify, merge, publish, 52 | distribute, sublicense, and/or sell copies of the Software, and to 53 | permit persons to whom the Software is furnished to do so, subject to 54 | the following conditions: 55 | 56 | The above copyright notice and this permission notice shall be 57 | included in all copies or substantial portions of the Software. 58 | 59 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 60 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 61 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 62 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 63 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 64 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 65 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 66 | 67 | ------------------------------------------------------------------------------- 68 | -------------------------------------------------------------------------------- /src/Hummus/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Hummus.Parser where 3 | 4 | import Control.Applicative hiding (many) 5 | import Data.Attoparsec as A 6 | import Data.Attoparsec.Char8 (isSpace_w8, isDigit_w8) 7 | import qualified Data.ByteString as BS 8 | 9 | import Hummus.Types 10 | 11 | 12 | whitespace :: Parser () 13 | whitespace = skipMany $ choice 14 | [ takeWhile1 isSpace_w8 >> return () 15 | , skipMany1 comment 16 | ] 17 | 18 | comment :: Parser () 19 | comment = do 20 | string ";" 21 | manyTill anyWord8 (endOfLine <|> endOfInput) 22 | return () 23 | where 24 | endOfLine = string "\n" >> return () 25 | 26 | sexps :: Parser [Value ans] 27 | sexps = manyTill (whitespace *> sexp <* whitespace) endOfInput "sexps" 28 | 29 | sexp :: Parser (Value ans) 30 | sexp = choice [hNumber, hString, hConstant, hSymbol, hList] "sexp" 31 | 32 | toString :: BS.ByteString -> String 33 | toString = map (toEnum . fromEnum) . BS.unpack 34 | 35 | hNumber :: Parser (Value ans) 36 | hNumber = (do 37 | d <- satisfy isDigit_w8 38 | n <- loop (fromIntegral (fromEnum d - fromEnum '0')) 39 | return (Number (fromIntegral n))) "number" 40 | where 41 | loop :: Integer -> Parser Integer 42 | loop n = choice 43 | [ do 44 | d <- satisfy isDigit_w8 45 | loop (n * 10 + (fromIntegral $ fromEnum d - fromEnum '0')) 46 | , return n 47 | ] 48 | 49 | hString :: Parser (Value ans) 50 | hString = (string "\"" *> fmap (String . toString) inString) "string" 51 | where 52 | inString = do 53 | cs <- A.takeWhile (not . inClass "\\\"") 54 | choice 55 | [ do 56 | string "\"" 57 | return cs 58 | , do 59 | string "\\\"" 60 | rest <- inString 61 | return (BS.concat [cs, "\"", rest]) 62 | , fail "unknown escape" 63 | ] 64 | 65 | hConstant :: Parser (Value ans) 66 | hConstant = string "#" *> 67 | choice 68 | [ string "t" >> return (Boolean True) 69 | , string "f" >> return (Boolean False) 70 | , string "ignore" >> return Ignore 71 | , string "inert" >> return Inert 72 | ] "constant" 73 | 74 | hSymbol :: Parser (Value ans) 75 | hSymbol = (fmap (Symbol . toString) $ takeWhile1 validChar) "symbol" 76 | where 77 | validChar = inClass "a-zA-Z0-9-<>/?\\|~!@#$%^&*=+_-" 78 | 79 | hList :: Parser (Value ans) 80 | hList = (string "(" *> pairs <* string ")") "list" 81 | where 82 | pairs = whitespace *> choice 83 | [ do 84 | a <- sexp 85 | whitespace 86 | string "." 87 | whitespace 88 | b <- sexp 89 | return (Pair a b) 90 | , do 91 | a <- sexp 92 | ps <- pairs 93 | return (Pair a ps) 94 | , do 95 | x <- sexp 96 | return (Pair x Null) 97 | , return Null 98 | ] <* whitespace 99 | -------------------------------------------------------------------------------- /src/Hummus/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Hummus.Prelude where 3 | 4 | import Control.Monad 5 | import Control.Monad.CC 6 | import Control.Monad.CC.Dynvar 7 | import Control.Monad.Trans 8 | import Data.Attoparsec 9 | import Data.IORef 10 | import Data.Time 11 | import qualified Data.ByteString as BS 12 | 13 | import Hummus.Types 14 | import Hummus.Parser 15 | import Hummus.Runtime 16 | 17 | import Paths_hummus 18 | 19 | 20 | new :: VM ans (Value ans) 21 | new = do 22 | env <- newEnvironment [] 23 | 24 | defn env "make-encapsulation-type" $ \Null _ -> do 25 | i <- liftIO (newIORef ()) 26 | 27 | let cons = 28 | Applicative . CoreOperative $ \(Pair a Null) _ -> do 29 | vr <- liftIO (newIORef a) 30 | return Encapsulation { eID = i, eValue = vr } 31 | 32 | test = 33 | Applicative . CoreOperative $ \(Pair a Null) _ -> 34 | case a of 35 | Encapsulation { eID = eid } -> return (Boolean (eid == i)) 36 | _ -> return (Boolean False) 37 | 38 | decons = 39 | Applicative . CoreOperative $ \(Pair a Null) _ -> 40 | case a of 41 | Encapsulation { eID = eid, eValue = vr } | eid == i -> 42 | liftIO (readIORef vr) 43 | 44 | _ -> error "encapsulation type mismatch" 45 | 46 | return (Pair cons (Pair test (Pair decons Null))) 47 | 48 | defn env "reset" $ \(Pair b _) e -> 49 | reset $ \p -> 50 | apply e b (Pair (Prompt p) Null) 51 | 52 | defn env "make-dynvar" $ \(Pair a _) _ -> 53 | liftM (flip Dynvar a) dnew 54 | 55 | defn env "put!" $ \(Pair (Dynvar d _) (Pair b Null)) _ -> 56 | dset d b 57 | 58 | def env "with" $ \(Pair as bs) e -> do 59 | letDyn e (map toList (toList as)) (toList bs) 60 | 61 | defn env "shift" $ \(Pair a (Pair b _)) e -> do 62 | Prompt p <- evaluate e a 63 | shift p $ \f -> 64 | let app = Applicative . CoreOperative $ \(Pair x _) _ -> f (return x) 65 | in apply e b (Pair app Null) 66 | 67 | defn env "control" $ \(Pair a (Pair b _)) e -> do 68 | Prompt p <- evaluate e a 69 | control p $ \f -> 70 | let app = Applicative . CoreOperative $ \(Pair x _) _ -> f (return x) 71 | in apply e b (Pair app Null) 72 | 73 | defn env "shift0" $ \(Pair a (Pair b _)) e -> do 74 | Prompt p <- evaluate e a 75 | shift0 p $ \f -> 76 | let app = Applicative . CoreOperative $ \(Pair x _) _ -> f (return x) 77 | in apply e b (Pair app Null) 78 | 79 | defn env "control0" $ \(Pair a (Pair b _)) e -> do 80 | Prompt p <- evaluate e a 81 | control0 p $ \f -> 82 | let app = Applicative . CoreOperative $ \(Pair x _) _ -> f (return x) 83 | in apply e b (Pair app Null) 84 | 85 | def env "abort" $ \(Pair a (Pair b _)) e -> do 86 | Prompt p <- evaluate e a 87 | abort p (evaluate e b) 88 | 89 | defn env "boolean?" $ \(Pair a _) _ -> 90 | return (Boolean (isBoolean a)) 91 | 92 | defn env "eq?" $ \(Pair a (Pair b _)) _ -> 93 | return (Boolean (a == b)) 94 | 95 | evaluate env (Symbol "eq?") >>= define env (Symbol "equal?") 96 | 97 | defn env "symbol?" $ \(Pair a _) _ -> 98 | return (Boolean (isSymbol a)) 99 | 100 | defn env "string?" $ \(Pair a _) _ -> 101 | return (Boolean (isString a)) 102 | 103 | defn env "subcontinuation?" $ \(Pair a _) _ -> 104 | return (Boolean (isSubContinuation a)) 105 | 106 | defn env "prompt?" $ \(Pair a _) _ -> 107 | return (Boolean (isPrompt a)) 108 | 109 | defn env "inert?" $ \(Pair a _) _ -> 110 | return (Boolean (isInert a)) 111 | 112 | defn env "pair?" $ \(Pair a _) _ -> 113 | return (Boolean (isPair a)) 114 | 115 | defn env "null?" $ \(Pair a _) _ -> 116 | return (Boolean (isNull a)) 117 | 118 | defn env "cons" $ \(Pair a (Pair b _)) _ -> 119 | return (Pair a b) 120 | 121 | def env "if" $ \(Pair a (Pair b (Pair c _))) e -> do 122 | t <- evaluate e a 123 | 124 | case t of 125 | Boolean True -> 126 | evaluate e b 127 | 128 | Boolean False -> 129 | evaluate e c 130 | 131 | _ -> error ("not a boolean: " ++ show t) 132 | 133 | defn env "environment?" $ \(Pair a _) _ -> 134 | return (Boolean (isEnvironment a)) 135 | 136 | defn env "ignore?" $ \(Pair a _) _ -> 137 | return (Boolean (isIgnore a)) 138 | 139 | defn env "number?" $ \(Pair a _) _ -> 140 | return (Boolean (isNumber a)) 141 | 142 | defn env "eval" $ \(Pair a (Pair b _)) _ -> 143 | evaluate b a 144 | 145 | defn env "make-environment" $ \parents _ -> 146 | newEnvironment (toList parents) 147 | 148 | def env "binds?" $ \(Pair a bs) e -> do 149 | e' <- evaluate e a 150 | ss <- mapM (\(Symbol s) -> binds e' s) (toList bs) 151 | return (Boolean (and ss)) 152 | 153 | def env "define" $ \(Pair a (Pair b _)) e -> do 154 | v <- evaluate e b 155 | define e a v 156 | return Inert 157 | 158 | defn env "operative?" $ \(Pair a _) _ -> 159 | return (Boolean (isOperative a)) 160 | 161 | defn env "applicative?" $ \(Pair a _) _ -> 162 | return (Boolean (isApplicative a)) 163 | 164 | defn env "dynvar?" $ \(Pair a _) _ -> 165 | return (Boolean (isDynvar a)) 166 | 167 | defn env "combiner?" $ \as _ -> 168 | return (Boolean (and (map isCombiner (toList as)))) 169 | 170 | def env "vau" $ \(Pair a (Pair b (Pair c _))) e -> 171 | return (Operative a b c (Just e)) 172 | 173 | defn env "wrap" $ \(Pair a _) _ -> 174 | return (Applicative a) 175 | 176 | defn env "unwrap" $ \(Pair a _) _ -> 177 | case a of 178 | Applicative c -> return c 179 | _ -> error ("not an applicative: " ++ show a) 180 | 181 | defn env "make-prompt" $ \Null _ -> do 182 | x <- newPrompt 183 | return (Prompt x) 184 | 185 | def env "push-prompt" $ \(Pair a bs) e -> do 186 | Prompt p <- evaluate e a 187 | pushPrompt p (evaluateSequence e (toList bs)) 188 | 189 | defn env "with-sub-cont" $ \(Pair (Prompt p) (Pair x Null)) e -> do 190 | withSubCont p $ \s -> 191 | apply e x (Pair (SubContinuation s) Null) 192 | 193 | defn env "push-sub-cont" $ \(Pair a bs) e -> do 194 | SubContinuation s <- evaluate e a 195 | pushSubCont s (evaluateSequence e (toList bs)) 196 | 197 | defn env "=?" $ \as _ -> 198 | let allEq (a:b:cs) = a == b && allEq (b:cs) 199 | allEq _ = True 200 | in return (Boolean (allEq (toList as))) 201 | 202 | defn env "max" $ \as _ -> 203 | let nums = map (\(Number n) -> n) (toList as) 204 | in return (Number (maximum nums)) 205 | 206 | defn env " 207 | return (Boolean (a < b)) 208 | 209 | defn env ">?" $ \(Pair (Number a) (Pair (Number b) _)) _ -> 210 | return (Boolean (a > b)) 211 | 212 | defn env "<=?" $ \(Pair (Number a) (Pair (Number b) _)) _ -> 213 | return (Boolean (a <= b)) 214 | 215 | defn env ">=?" $ \(Pair (Number a) (Pair (Number b) _)) _ -> 216 | return (Boolean (a >= b)) 217 | 218 | defn env "+" $ \as _ -> 219 | let nums = map (\(Number n) -> n) (toList as) 220 | in return (Number (sum nums)) 221 | 222 | defn env "*" $ \as _ -> 223 | let nums = map (\(Number n) -> n) (toList as) 224 | in return (Number (product nums)) 225 | 226 | defn env "-" $ \(Pair (Number a) (Pair (Number b) _)) _ -> 227 | return (Number (a - b)) 228 | 229 | defn env "print" $ \(Pair a _) _ -> do 230 | case a of 231 | String s -> liftIO (putStrLn s) 232 | _ -> liftIO (print a) 233 | 234 | return Inert 235 | 236 | defn env "display" $ \(Pair a _) _ -> do 237 | case a of 238 | String s -> liftIO (putStr s) 239 | _ -> liftIO (putStr (show a)) 240 | 241 | return Inert 242 | 243 | defn env "write" $ \(Pair a _) _ -> do 244 | liftIO (print a) 245 | return Inert 246 | 247 | defn env "show" $ \(Pair a _) _ -> 248 | return (String (show a)) 249 | 250 | def env "time" $ \(Pair a _) e -> do 251 | before <- liftIO getCurrentTime 252 | x <- evaluate e a 253 | after <- liftIO getCurrentTime 254 | liftIO (print x) 255 | liftIO (print (diffUTCTime after before)) 256 | return Inert 257 | 258 | def env "loop" $ \as e -> 259 | forever $ evaluateSequence e (toList as) 260 | 261 | defn env "get-hummus-data-file" $ \(Pair (String fn) _) _ -> do 262 | liftM String (liftIO (getDataFileName fn)) 263 | 264 | defn env "load" $ \(Pair (String fn) _) e -> do 265 | source <- liftIO (BS.readFile fn) 266 | case parseOnly sexps source of 267 | Right ss -> 268 | evaluateSequence e ss 269 | 270 | Left msg -> 271 | error msg 272 | 273 | defn env "string->symbol" $ \(Pair (String s) _) _ -> 274 | return (Symbol s) 275 | 276 | defn env "symbol->string" $ \(Pair (Symbol s) _) _ -> 277 | return (String s) 278 | 279 | defn env "join" $ \as _ -> 280 | return (String (concatMap (\(String s) -> s) (toList as))) 281 | 282 | bootFile <- liftIO (getDataFileName "kernel/boot.hms") 283 | boot <- liftIO (BS.readFile bootFile) 284 | case parseOnly sexps boot of 285 | Right ss -> 286 | mapM_ (evaluate env) ss 287 | 288 | Left e -> 289 | error e 290 | 291 | return env 292 | where 293 | def :: Value ans -> String -> (Value ans -> Value ans -> VM ans (Value ans)) -> VM ans () 294 | def e n f = define e (Symbol n) (CoreOperative f) 295 | 296 | defn :: Value ans -> String -> (Value ans -> Value ans -> VM ans (Value ans)) -> VM ans () 297 | defn e n f = define e (Symbol n) (Applicative $ CoreOperative f) 298 | 299 | letDyn :: Value ans -> [[Value ans]] -> [Value ans] -> VM ans (Value ans) 300 | letDyn e [] bs = evaluateSequence e bs 301 | letDyn e ([a, b]:as) bs = do 302 | Dynvar d _ <- evaluate e a 303 | v <- evaluate e b 304 | dlet d v (letDyn e as bs) 305 | letDyn _ (p:_) _ = error $ "unknown pair: " ++ show p 306 | 307 | fromGround :: (Value ans -> VM ans (Value ans)) -> VM ans (Value ans) 308 | fromGround x = do 309 | e <- new 310 | 311 | reset $ \root -> do 312 | define e (Symbol "root-prompt") (Prompt root) 313 | x e 314 | -------------------------------------------------------------------------------- /src/Hummus/Runtime.hs: -------------------------------------------------------------------------------- 1 | module Hummus.Runtime where 2 | 3 | import Control.Monad 4 | import Control.Monad.CC.Dynvar 5 | import Control.Monad.Trans 6 | import Data.Maybe (catMaybes, isJust) 7 | import qualified Data.HashTable.IO as H 8 | 9 | import Hummus.Types 10 | 11 | 12 | evaluate :: Value ans -> Value ans -> VM ans (Value ans) 13 | evaluate env (Pair a b) = do 14 | x <- evaluate env a 15 | if isCombiner x 16 | then apply env x b 17 | else error ("not a combiner: " ++ show x) 18 | evaluate env (Symbol s) = do 19 | mv <- fetch env s 20 | case mv of 21 | Just v -> return v 22 | Nothing -> error ("undefined: " ++ s) 23 | evaluate env o@(Operative { oStaticEnvironment = Nothing }) = 24 | return o { oStaticEnvironment = Just env } 25 | evaluate _ x = return x 26 | 27 | evaluateSequence :: Value ans -> [Value ans] -> VM ans (Value ans) 28 | evaluateSequence _ [] = return Inert 29 | evaluateSequence e [s] = evaluate e s 30 | evaluateSequence e (s:ss) = evaluate e s >> evaluateSequence e ss 31 | 32 | evaluateAll :: Value ans -> Value ans -> VM ans (Value ans) 33 | evaluateAll env (Pair a b) = do 34 | ea <- evaluate env a 35 | eb <- evaluateAll env b 36 | return (Pair ea eb) 37 | evaluateAll _ x = return x 38 | 39 | apply :: Value ans -> Value ans -> Value ans -> VM ans (Value ans) 40 | apply env (CoreOperative f) as = f as env 41 | apply env (Operative fs ef b se) as = do 42 | newEnv <- newEnvironment (catMaybes [se]) 43 | 44 | define newEnv fs as 45 | define newEnv ef env 46 | 47 | evaluate newEnv b 48 | apply env (Applicative x) vs = do 49 | as <- evaluateAll env vs 50 | apply env x as 51 | apply _ (Dynvar d x) _ = liftM (maybe x id) (mdref d) 52 | apply _ v _ = error ("cannot apply: " ++ show v) 53 | 54 | define :: Value ans -> Value ans -> Value ans -> VM ans () 55 | define env@(Environment ht _) p v = 56 | case p of 57 | Ignore -> return () 58 | 59 | Symbol n -> liftIO (H.insert ht n v) 60 | 61 | Null -> 62 | case v of 63 | Null -> return () 64 | _ -> error ("mismatch: " ++ show (p, v)) 65 | 66 | Pair pa pb -> 67 | case v of 68 | Pair va vb -> do 69 | define env pa va 70 | define env pb vb 71 | 72 | _ -> error ("mismatch: " ++ show (p, v)) 73 | 74 | _ -> error ("unknown pattern: " ++ show p) 75 | define _ _ _ = error "invalid definition target" 76 | 77 | binds :: Value ans -> String -> VM ans Bool 78 | binds e n = liftM isJust (fetch e n) 79 | 80 | fetch :: Value ans -> String -> VM ans (Maybe (Value ans)) 81 | fetch (Environment ht ps) n = do 82 | l <- liftIO (H.lookup ht n) 83 | case l of 84 | Just v -> return (Just v) 85 | Nothing -> do 86 | up <- mapM (flip fetch n) ps 87 | case catMaybes up of 88 | (x:_) -> return (Just x) 89 | [] -> return Nothing 90 | fetch v n = error ("cannot fetch " ++ show n ++ " from " ++ show v) 91 | -------------------------------------------------------------------------------- /src/Hummus/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, 2 | UndecidableInstances #-} 3 | module Hummus.Types where 4 | 5 | import Control.Monad.CC 6 | import Control.Monad.CC.Dynvar 7 | import Control.Monad.CC.Prompt 8 | import Control.Monad.Trans 9 | import Data.IORef 10 | import qualified Data.HashTable.IO as H 11 | 12 | 13 | newtype VM ans a = VM { unVM :: CCT ans IO a } 14 | 15 | runVM :: (forall ans. VM ans a) -> IO a 16 | runVM v = runCCT (unVM v) 17 | 18 | instance Monad (VM ans) where 19 | return = VM . return 20 | x >>= y = VM (unVM x >>= unVM . y) 21 | 22 | instance MonadIO (VM ans) where 23 | liftIO x = VM (liftIO x) 24 | 25 | instance MonadDelimitedCont (Prompt ans) (SubCont ans IO) (VM ans) where 26 | newPrompt = VM newPrompt 27 | pushPrompt p x = VM (pushPrompt p (unVM x)) 28 | withSubCont p f = VM (withSubCont p (unVM . f)) 29 | pushSubCont s x = VM (pushSubCont s (unVM x)) 30 | isValidPrompt p = VM (isValidPrompt p) 31 | 32 | data Value ans 33 | = Applicative (Value ans) 34 | | Boolean Bool 35 | | CoreOperative (Value ans -> Value ans -> VM ans (Value ans)) 36 | | Dynvar (Dynvar (VM ans) (Value ans)) (Value ans) 37 | | Encapsulation 38 | { eID :: IORef () 39 | , eValue :: IORef (Value ans) -- for shallow equality check 40 | } 41 | | Environment (H.LinearHashTable String (Value ans)) [Value ans] 42 | | Ignore 43 | | Inert 44 | | Null 45 | | Number Integer 46 | | Operative 47 | { oFormals :: Value ans 48 | , oEnvironmentFormal :: Value ans 49 | , oBody :: Value ans 50 | , oStaticEnvironment :: Maybe (Value ans) 51 | } 52 | | Pair (Value ans) (Value ans) 53 | | Prompt (Prompt ans (Value ans)) 54 | | String String 55 | | SubContinuation (SubCont ans IO (Value ans) (Value ans)) 56 | | Symbol String 57 | 58 | 59 | instance forall ans. Show (Value ans) where 60 | show (Applicative v) = "" 61 | show (Boolean True) = "#t" 62 | show (Boolean False) = "#f" 63 | show (CoreOperative _) = "" 64 | show (Dynvar _ _) = "" 65 | show (Encapsulation {}) = "" 66 | show (Environment _ _) = "" 67 | show Ignore = "#ignore" 68 | show Inert = "#inert" 69 | show Null = "()" 70 | show (Number n) = show n 71 | show (Operative { oFormals = fs, oEnvironmentFormal = ef, oBody = b }) = 72 | "" 73 | show p@(Pair _ _) = "(" ++ showPair p ++ ")" 74 | where 75 | showPair (Pair a b) 76 | | isPair b = show a ++ " " ++ showPair b 77 | | isNull b = show a 78 | | otherwise = show a ++ " . " ++ show b 79 | showPair x = show x 80 | show (Prompt _) = "" 81 | show (String s) = show s 82 | show (SubContinuation _) = "" 83 | show (Symbol s) = s 84 | 85 | 86 | instance forall ans. Eq (Value ans) where 87 | Applicative a == Applicative b = a == b 88 | Boolean a == Boolean b = a == b 89 | Encapsulation aid av == Encapsulation bid bv = 90 | aid == bid && av == bv 91 | Ignore == Ignore = True 92 | Inert == Inert = True 93 | Null == Null = True 94 | Number a == Number b = a == b 95 | Operative afs aef ab ase == Operative bfs bef bb bse = 96 | afs == bfs && aef == bef && ab == bb && ase == bse 97 | Pair ah at == Pair bh bt = ah == bh && at == bt 98 | Prompt a == Prompt b = 99 | case eqPrompt a b of 100 | EQU -> True 101 | NEQ -> False 102 | String a == String b = a == b 103 | Symbol a == Symbol b = a == b 104 | _ == _ = False 105 | 106 | 107 | newEnvironment :: [Value ans] -> VM ans (Value ans) 108 | newEnvironment ps = do 109 | ht <- liftIO H.new 110 | return (Environment ht ps) 111 | 112 | 113 | toList :: Value ans -> [Value ans] 114 | toList (Pair a b) = a : toList b 115 | toList Null = [] 116 | toList x = error ("cannot toList: " ++ show x) 117 | 118 | 119 | isTrue :: Value ans -> Bool 120 | isTrue (Boolean True) = True 121 | isTrue _ = False 122 | 123 | isFalse :: Value ans -> Bool 124 | isFalse (Boolean False) = True 125 | isFalse _ = False 126 | 127 | isBoolean :: Value ans -> Bool 128 | isBoolean (Boolean _) = True 129 | isBoolean _ = False 130 | 131 | isApplicative :: Value ans -> Bool 132 | isApplicative (Applicative _) = True 133 | isApplicative _ = False 134 | 135 | isString :: Value ans -> Bool 136 | isString (String _) = True 137 | isString _ = False 138 | 139 | isSymbol :: Value ans -> Bool 140 | isSymbol (Symbol _) = True 141 | isSymbol _ = False 142 | 143 | isIgnore :: Value ans -> Bool 144 | isIgnore Ignore = True 145 | isIgnore _ = False 146 | 147 | isNull :: Value ans -> Bool 148 | isNull Null = True 149 | isNull _ = False 150 | 151 | isNumber :: Value ans -> Bool 152 | isNumber (Number _) = True 153 | isNumber _ = False 154 | 155 | isPair :: Value ans -> Bool 156 | isPair (Pair _ _) = True 157 | isPair _ = False 158 | 159 | isEnvironment :: Value ans -> Bool 160 | isEnvironment (Environment _ _) = True 161 | isEnvironment _ = False 162 | 163 | isInert :: Value ans -> Bool 164 | isInert Inert = True 165 | isInert _ = False 166 | 167 | isOperative :: Value ans -> Bool 168 | isOperative (CoreOperative _) = True 169 | isOperative (Operative {}) = True 170 | isOperative _ = False 171 | 172 | isPrompt :: Value ans -> Bool 173 | isPrompt (Prompt _) = True 174 | isPrompt _ = False 175 | 176 | isSubContinuation :: Value ans -> Bool 177 | isSubContinuation (SubContinuation _) = True 178 | isSubContinuation _ = False 179 | 180 | isDynvar :: Value ans -> Bool 181 | isDynvar (Dynvar _ _) = True 182 | isDynvar _ = False 183 | 184 | isCombiner :: Value ans -> Bool 185 | isCombiner x = isApplicative x || isOperative x || isDynvar x 186 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RankNTypes #-} 2 | module Main where 3 | 4 | import Control.Monad.Trans 5 | import Data.Attoparsec 6 | import Prelude hiding (catch) 7 | import System.Console.Haskeline 8 | import System.Environment (getArgs, getEnv) 9 | import System.FilePath (()) 10 | import qualified Data.ByteString as BS 11 | 12 | import Hummus.Types 13 | import Hummus.Parser 14 | import Hummus.Runtime 15 | import qualified Hummus.Prelude as Prelude 16 | 17 | 18 | main :: IO () 19 | main = do 20 | as <- getArgs 21 | 22 | runVM $ do 23 | Prelude.fromGround $ \e -> do 24 | case as of 25 | [] -> do 26 | home <- liftIO (getEnv "HOME") 27 | runInputT 28 | (defaultSettings { historyFile = Just (home ".hummus_history") }) 29 | (repl "" e) 30 | 31 | [f] -> do 32 | s <- liftIO (BS.readFile f) 33 | case parseOnly sexps s of 34 | Right ss -> mapM_ (evaluate e) ss 35 | Left m -> error m 36 | 37 | _ -> error "unknown argument form" 38 | 39 | return Inert 40 | 41 | return () 42 | 43 | -- TODO: super hacky 44 | instance MonadException (VM ans) where 45 | catch x _ = x -- TODO 46 | block x = x -- TODO 47 | unblock x = x -- TODO 48 | 49 | repl :: String -> Value ans -> InputT (VM ans) () 50 | repl p e = do 51 | mi <- getInputLine (if null p then "Hummus> " else "....... ") 52 | 53 | case mi of 54 | Just i -> 55 | case parse sexps (BS.pack . map (toEnum . fromEnum) $ p ++ i) of 56 | Done _ ss -> finish ss 57 | 58 | Fail rest context message -> do 59 | outputStrLn "Parse error!" 60 | outputStrLn ("at: " ++ show rest) 61 | 62 | if not (null context) 63 | then outputStrLn "Context:" 64 | else return () 65 | 66 | mapM_ (outputStrLn . (" " ++)) context 67 | outputStrLn message 68 | repl "" e 69 | 70 | Partial f -> 71 | case f "" of 72 | Done _ ss -> finish ss 73 | _ -> repl (p ++ i ++ "\n") e 74 | 75 | Nothing -> return () 76 | where 77 | finish ss = do 78 | v <- lift (evaluateSequence e ss) 79 | String s <- lift (evaluate e (Pair (Symbol "send") (Pair v (Pair (Symbol "->string") Null)))) 80 | outputStrLn s 81 | repl "" e 82 | --------------------------------------------------------------------------------