89 lines
3.5 KiB
Scheme
89 lines
3.5 KiB
Scheme
; (define $IORes (lambda (nm-1 nm-2) (vector 0 #f nm-1 nm-2)))
|
|
(define $IORes (lambda (nm-1 nm-2) (cons nm-1 nm-2)))
|
|
(define ($Left x) (vector 0 x))
|
|
(define ($Right x) (vector 1 x))
|
|
(define $LT 0)
|
|
(define $EQ 1)
|
|
(define $GT 2)
|
|
(define (Prelude.addString a b) (string-append a b))
|
|
(define (Prelude.addInt a b) (+ a b))
|
|
(define (Prelude.ltInt a b) (< a b))
|
|
(define (Prelude.eqInt a b) (= a b))
|
|
(define (Prelude.ltChar a b) (char<? a b))
|
|
(define (Prelude.eqChar a b) (char=? a b))
|
|
(define (Prelude.ltString a b) (string<? a b))
|
|
(define (Prelude.eqString a b) (string=? a b))
|
|
(define Prelude.showInt number->string)
|
|
(define (Prelude.primPutStrLn msg)
|
|
(lambda (w)
|
|
(display msg)
|
|
(newline)
|
|
($IORes #f w)))
|
|
(define Prelude.chr integer->char)
|
|
(define Prelude.ord char->integer)
|
|
(define (Prelude.intToNat x) x)
|
|
(define (Prelude.natToInt x) x)
|
|
(define (Prelude.slen s) (string-length s))
|
|
(define (Prelude.debugStr _ x) (format #f "~s" x))
|
|
;; REVIEW if this works for all of the cases that it is used for
|
|
;; maybe they should all go away for specific instances
|
|
(define (Prelude.jsShow x) (format #f "~s" x))
|
|
(define (Node.putStr s) (lambda (w) (display s) ($IORes #f w)))
|
|
(define (Prelude.mod x y) (mod x y))
|
|
;; REVIEW returns #f for failure
|
|
(define Prelude.stringToInt string->number)
|
|
|
|
(define (Prelude.unpack str) (string->list str))
|
|
(define (Prelude.pack cs) (list->string cs))
|
|
(define (Prelude.fastConcat strings) (apply string-append strings))
|
|
|
|
(define (Prelude.isPrefixOf pfx str)
|
|
(string=? pfx (substring str 0 (string-length pfx))))
|
|
;; Only used by getArgs(define Prelude.arrayToList #f)
|
|
;; fastConcat uses it in js
|
|
(define Prelude.listToArray #f)
|
|
(define (Node.readFile fn)
|
|
(lambda (w)
|
|
(guard (x [else ($IORes ($Left (if (condition? x)
|
|
; (condition-message x)
|
|
(with-output-to-string (lambda() (display-condition x)))
|
|
"Error")) w)])
|
|
($IORes ($Right (call-with-input-file fn get-string-all)) w))))
|
|
(define (Node.writeFile fn content)
|
|
(lambda (w)
|
|
(guard (x [else ($IORes ($Left (if (condition? x)
|
|
; (condition-message x)
|
|
(with-output-to-string (lambda() (display-condition x)))
|
|
"Error")) w)])
|
|
(with-output-to-file fn
|
|
(lambda () (display content))
|
|
'replace)
|
|
($IORes ($Right #f) w))))
|
|
(define Prelude.strIndex string-ref)
|
|
(define (Data.IORef.primNewIORef _ a) (lambda (w) ($IORes (box a) w)))
|
|
(define (Data.IORef.primReadIORef _ ref) (lambda (w) ($IORes (unbox ref) w)))
|
|
;; Actually should return unit..
|
|
(define (Data.IORef.primWriteIORef _ ref a) (lambda (w) ($IORes (set-box! ref a) w)))
|
|
(define (Node.readLine w)
|
|
(case (get-line (current-input-port))
|
|
(#!eof ($IORes ($Left "EOF") w))
|
|
(else ($IORes ($Right (get-line (current-input-port))) w))))
|
|
(define (Prelude.subInt a b) (- a b))
|
|
(define (Prelude.jsEq _ a b) (= a b))
|
|
(define (Prelude.divInt a b) (fx/ a b))
|
|
;; In node this throws and the next one exits cleanly
|
|
(define (Prelude.fatalError _ msg) (raise (error #f msg)))
|
|
(define (Node.exitFailure _ msg)
|
|
(display msg)
|
|
(newline)
|
|
(exit 1))
|
|
(define (Prelude.isSuffixOf sfx s)
|
|
(let ((n (string-length sfx))
|
|
(m (string-length s)))
|
|
(if (<= n m)
|
|
(string=? sfx (substring s (- m n) m))
|
|
#f)))
|
|
(define (Node.getArgs w) ($IORes (command-line) w))
|
|
(define (Prelude.unsafePerformIO a f)
|
|
(car (f 'world)))
|