[18] | 1 | (use srfi-1) |
---|
| 2 | |
---|
| 3 | (define *undefined* (if #f #f)) |
---|
| 4 | |
---|
| 5 | (define (tagged? tag obj) (and (pair? obj) (eq? (car obj) tag))) |
---|
| 6 | (define (tagged?$ tag) (lambda (obj) (and (pair? obj) (eq? (car obj) tag)))) |
---|
| 7 | (define (tag t obj) (cons t obj)) |
---|
| 8 | (define (tag$ t) (lambda (obj) (cons t obj))) |
---|
| 9 | (define (untag obj) (cdr obj)) |
---|
| 10 | |
---|
| 11 | (use peg) |
---|
| 12 | |
---|
| 13 | (define (nil-if-true l) (if (eq? #t l) '() l)) |
---|
| 14 | (define ($my-sep-by parse sep . args) |
---|
| 15 | ($do (them ($sep-by parse sep)) |
---|
| 16 | ($return (nil-if-true them)))) |
---|
| 17 | |
---|
| 18 | (define %ws ($many ($one-of #[ \t\r\n]))) |
---|
| 19 | |
---|
| 20 | (define %string ; scheme-string で代用 |
---|
| 21 | (let* ([%dquote ($char #\")] |
---|
| 22 | [%unescaped ($none-of #[\"])] |
---|
| 23 | [%body-char ($or %unescaped)] |
---|
| 24 | [%string-body ($do (chars ($many %body-char)) |
---|
| 25 | ($return (tag :string (list->string chars))))] |
---|
| 26 | ) |
---|
| 27 | ($between %dquote %string-body %dquote))) |
---|
| 28 | |
---|
| 29 | (define %ident ;; scheme-symbolで代用 |
---|
| 30 | (let* ([%ident-head-char ($one-of #[a-z_])] |
---|
| 31 | [%ident-rest-char ($one-of #[0-9A-Za-z_'])]) |
---|
| 32 | ($do (head %ident-head-char) |
---|
| 33 | (rest ($many %ident-rest-char)) |
---|
| 34 | ($return (string->symbol (list->string (cons head rest))))))) |
---|
| 35 | |
---|
| 36 | (define %digits |
---|
| 37 | ($do (d ($many digit 1)) |
---|
| 38 | ($return (tag :number (string->number (list->string d)))))) |
---|
| 39 | |
---|
| 40 | (define %list |
---|
| 41 | (let* ([%begin-list ($seq %ws ($char #\[) %ws)] |
---|
| 42 | [%end-list ($seq %ws ($char #\]) %ws)] |
---|
| 43 | [%item ($or %digits %string %ident)] |
---|
| 44 | [%item-separator ($seq %ws ($char #\,) %ws)] |
---|
| 45 | ) |
---|
| 46 | ($do %begin-list |
---|
| 47 | (items ($my-sep-by %item %item-separator)) |
---|
| 48 | %end-list |
---|
| 49 | ($return (tag :list items))) |
---|
| 50 | )) |
---|
| 51 | |
---|
| 52 | (define %tuple |
---|
| 53 | (let* ([%begin-list ($seq %ws ($char #\() %ws)] |
---|
| 54 | [%end-list ($seq %ws ($char #\)) %ws)] |
---|
| 55 | [%item ($or %digits %string %ident)] |
---|
| 56 | [%item-separator ($seq %ws ($char #\,) %ws)] |
---|
| 57 | ) |
---|
| 58 | ($do %begin-list |
---|
| 59 | (items ($my-sep-by %item %item-separator)) |
---|
| 60 | %end-list |
---|
| 61 | ($return (tag :tuple @items))) |
---|
| 62 | )) |
---|
| 63 | |
---|
| 64 | (define %expr |
---|
| 65 | ($or %string %digits %ident %list %tuple)) |
---|
| 66 | |
---|
| 67 | (define %application |
---|
| 68 | (let1 %an-application |
---|
| 69 | ($do (fn %ident) |
---|
| 70 | %ws |
---|
| 71 | (args ($my-sep-by %expr %ws)) |
---|
| 72 | ($return `(:apply ,fn ,@args))) |
---|
| 73 | ($do (app1 %an-application) |
---|
| 74 | (apps ($many ($do %ws |
---|
| 75 | (($char #\$)) |
---|
| 76 | %ws |
---|
| 77 | (app %an-application) |
---|
| 78 | ($return app)))) |
---|
| 79 | ($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps)))))) |
---|
| 80 | |
---|
| 81 | (define %haskell |
---|
| 82 | (let* ([%unknown ($my-sep-by %expr %ws)] |
---|
| 83 | |
---|
| 84 | [%assignment ($do (id %ident) |
---|
| 85 | %ws |
---|
| 86 | (($string "<-")) |
---|
| 87 | %ws |
---|
| 88 | (value %application) |
---|
| 89 | ($return `(:assign ,id ,value)) |
---|
| 90 | )] |
---|
| 91 | [%do-line-separator ($seq %ws ($or ($seq newline ($string " ")) ($char #\;)) %ws)] |
---|
| 92 | [%do ($do (($string "do")) |
---|
| 93 | %ws |
---|
| 94 | (exprs ($or ($between ($seq ($char #\{) %ws) |
---|
| 95 | ($my-sep-by ($or %assignment %application) |
---|
| 96 | ($seq %ws ($char #\;) ($optional ($seq newline ($string " "))) %ws)) |
---|
| 97 | ($seq %ws ($char #\}))) |
---|
| 98 | ($my-sep-by ($or %assignment %application) |
---|
| 99 | ($seq newline ($string " ") %ws)) )) |
---|
| 100 | ($return `(:do ,@exprs)))] |
---|
| 101 | |
---|
| 102 | [%defun ($do (id %ident) |
---|
| 103 | %ws |
---|
| 104 | (args ($my-sep-by %ident %ws)) |
---|
| 105 | %ws |
---|
| 106 | (($char #\=)) |
---|
| 107 | %ws |
---|
| 108 | (rightside ($or %do %application)) |
---|
| 109 | ($return `(:defun (,id ,@args) ,rightside)) |
---|
| 110 | )] |
---|
| 111 | [%pattern ($do (id %ident) |
---|
| 112 | %ws |
---|
| 113 | (args ($my-sep-by ($or %ident %digits) %ws)) |
---|
| 114 | %ws |
---|
| 115 | (($char #\=)) |
---|
| 116 | %ws |
---|
| 117 | (rightside ($or %do %application)) |
---|
| 118 | ($return `(:pattern (,id ,@args) ,rightside)) |
---|
| 119 | )] |
---|
| 120 | |
---|
| 121 | ) |
---|
| 122 | ($or %defun %pattern %assignment %application %expr |
---|
| 123 | %unknown) |
---|
| 124 | )) |
---|
| 125 | |
---|
| 126 | (define (parse-haskell str) |
---|
| 127 | (parse-string %haskell str)) |
---|
| 128 | |
---|
| 129 | (define putStrLn print) |
---|
| 130 | |
---|
| 131 | (define ident? symbol?) |
---|
| 132 | (define ident-body identity) |
---|
| 133 | ;(define ident? (tagged?$ :ident)) |
---|
| 134 | ;(define ident-body untag) |
---|
| 135 | |
---|
| 136 | (define (indent w lines) |
---|
| 137 | (string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line))) |
---|
| 138 | lines) |
---|
| 139 | "\n")) |
---|
| 140 | |
---|
| 141 | (define *namespace* (make-hash-table)) |
---|
| 142 | (define (assign id val) |
---|
| 143 | (hash-table-put! *namespace* id val) |
---|
| 144 | id) |
---|
| 145 | (define (lookup id) |
---|
| 146 | (let1 val (hash-table-get *namespace* id) |
---|
| 147 | ; |
---|
| 148 | val)) |
---|
| 149 | |
---|
| 150 | ;; |
---|
| 151 | (define (make-procedure params body env) |
---|
| 152 | (list :procedure params body env)) |
---|
| 153 | |
---|
| 154 | (use util.match) |
---|
| 155 | (define (heval-map exps env) (map (cut heval <> env) exps)) |
---|
| 156 | (define (heval exp env) |
---|
| 157 | (if (or (null? exp) (not (pair? exp))) *undefined* |
---|
| 158 | (match exp |
---|
| 159 | [(':$ . _) |
---|
| 160 | ; (delay-it |
---|
| 161 | (let loop ([rest (cdr exp)]) |
---|
| 162 | (if (null? (cdr rest)) |
---|
| 163 | (heval (car rest) env) |
---|
| 164 | (heval (append (car rest) (list (loop (cdr rest)))) env) |
---|
| 165 | )) |
---|
| 166 | ; env) |
---|
| 167 | ] |
---|
| 168 | [(':apply f . _) |
---|
| 169 | (if (null? (cddr exp)) |
---|
| 170 | ; (delay-it (list (ident-body f)) env) |
---|
| 171 | (list (ident-body f)) |
---|
| 172 | `(,(ident-body f) ,@(cddr exp)); ,@(map (cut heval <> env) (cdr exp))) |
---|
| 173 | ; (delay-it `(,(ident-body f) |
---|
| 174 | ; ,@(map (cut heval <> env) (cdr exp))) |
---|
| 175 | ; env) |
---|
| 176 | )] |
---|
| 177 | [(':assign x y) ; id <- action |
---|
| 178 | (assign (ident-body x) (heval y env))] |
---|
| 179 | [(':do . _) ; do { ... ; ... ; ... } |
---|
| 180 | `(seq ,@(heval-map (cdr exp) env))] |
---|
| 181 | [(':defun id definition) ; id x y z = app x $ app y $ app z |
---|
| 182 | (let ([ident (car id)] |
---|
| 183 | [args (cdr id)]) |
---|
| 184 | (assign (ident-body ident) |
---|
| 185 | (make-procedure (map ident-body args) ;lambda-parameters |
---|
| 186 | (if (eq? 'seq (car definition)) ; lambda-body |
---|
| 187 | (heval definition env) |
---|
| 188 | (list (heval definition env)) ) |
---|
| 189 | env)))] |
---|
| 190 | [(':pattern id definition) ; id x y z = app x $ app y $ app z |
---|
| 191 | (let ([ident (car id)] |
---|
| 192 | [args (cdr id)]) |
---|
| 193 | (assign (ident-body ident) |
---|
| 194 | (make-procedure (map ident-body args) ;lambda-parameters |
---|
| 195 | (if (eq? 'seq (car definition)) ; lambda-body |
---|
| 196 | (heval definition env) |
---|
| 197 | (list (heval definition env)) ) |
---|
| 198 | env)))] |
---|
| 199 | |
---|
| 200 | [(':string . str) str] |
---|
| 201 | [(':list . l) l] |
---|
| 202 | [(':tuple . t) t] |
---|
| 203 | [(':ident . id) id] |
---|
| 204 | |
---|
| 205 | [_ (if (pair? exp) (happly (car exp) (cdr exp)) |
---|
| 206 | (format "unknown: ~a" exp))] ))) |
---|
| 207 | |
---|
| 208 | (define (primitive-procedure? proc) |
---|
| 209 | (memq proc '(putStr |
---|
| 210 | putStrLn |
---|
| 211 | lines length print |
---|
| 212 | tail))) |
---|
| 213 | |
---|
| 214 | (define (prim-print exp) |
---|
| 215 | (define (haskell-description-of-list l) |
---|
| 216 | (string-append "[" (string-join (map haskell-description l) ",") "]")) |
---|
| 217 | |
---|
| 218 | (define (haskell-description obj) |
---|
| 219 | (cond [(not (pair? obj)) (x->string obj)] |
---|
| 220 | [(tagged? :number obj) (number->string (untag obj))] |
---|
| 221 | [(tagged? :string obj) (untag obj)] |
---|
| 222 | [(tagged? :list obj) ; (untag obj)] |
---|
| 223 | (list->haskell-string (untag obj))] |
---|
| 224 | [(pair? obj) (haskell-description-of-list obj)] |
---|
| 225 | [else (x->string obj)])) |
---|
| 226 | |
---|
| 227 | (print (haskell-description exp))) |
---|
| 228 | |
---|
| 229 | (define (prim-tail exp) |
---|
| 230 | (cond [(tagged? :string exp) (substring (cdr exp) 1 (string-length (cdr exp)))] |
---|
| 231 | [(tagged? :list exp) (cddr exp)] |
---|
| 232 | [(pair? exp) (cdr exp)] |
---|
| 233 | [else *undefined*])) |
---|
| 234 | |
---|
| 235 | (define (apply-primitive-procedure proc args) |
---|
| 236 | (let1 args* (heval-map args '()) |
---|
| 237 | (case proc |
---|
| 238 | ((putStr) (display (x->string (car args*)))) |
---|
| 239 | ((putStrLn) (apply prim-print args*)) |
---|
| 240 | ((print) (apply prim-print args*)) |
---|
| 241 | ((lines) (length args*)) |
---|
| 242 | ((length) (if (tagged? :string (car args*)) |
---|
| 243 | (string-length (car args*)) |
---|
| 244 | (length (car args*)))) |
---|
| 245 | ((tail) (prim-tail (car args*))) |
---|
| 246 | ))) |
---|
| 247 | |
---|
| 248 | (define (compound-procedure? proc) (tagged? :procedure proc)) |
---|
| 249 | |
---|
| 250 | (define (procedure-parameters proc) (second proc)) |
---|
| 251 | (define (procedure-body proc) (third proc)) |
---|
| 252 | (define (procedure-environment proc) (fourth proc)) |
---|
| 253 | |
---|
| 254 | (define (make-frame vars vals) (cons vars vals)) |
---|
| 255 | |
---|
| 256 | (define (extend-environment vars vals base-env) |
---|
| 257 | ;; assert-equal (length vars) (length vals) |
---|
| 258 | (cons (make-frame vars vals) base-env)) |
---|
| 259 | |
---|
| 260 | (define (happly proc args) |
---|
| 261 | (cond [(primitive-procedure? proc) |
---|
| 262 | (apply-primitive-procedure proc args)] |
---|
| 263 | [(compound-procedure? proc) |
---|
| 264 | (let1 env (extend-environment (procedure-parameters proc) |
---|
| 265 | args |
---|
| 266 | (procedure-environment proc)) |
---|
| 267 | (heval-map (procedure-body proc) env))] |
---|
| 268 | [else |
---|
| 269 | ; |
---|
| 270 | ])) |
---|
| 271 | |
---|
| 272 | ;; REPL |
---|
| 273 | (let repl () |
---|
| 274 | (let1 input (read-line) |
---|
| 275 | (if (eof-object? input) 'eof |
---|
| 276 | (let1 parsed (parse-haskell input); (haskell->scheme input) |
---|
| 277 | (let1 evaled (heval parsed '()) |
---|
| 278 | (print "> " input) |
---|
| 279 | (print "=> " parsed) |
---|
| 280 | (print "" evaled)) |
---|
| 281 | (repl))))) |
---|
| 282 | |
---|
| 283 | (define (actual-value exp); env) |
---|
| 284 | (force-it (heval exp '()))) |
---|
| 285 | |
---|
| 286 | (let1 main (lookup 'main) |
---|
| 287 | (print "----") |
---|
| 288 | (happly main '()) |
---|
| 289 | ) |
---|