98 lines
3.8 KiB
Scheme
98 lines
3.8 KiB
Scheme
;; REVIEW all of this - some of it is IO and needs the IO dance
|
|
;; maybe we make a helper? A macro?
|
|
|
|
(define $Nil (lambda (nm-0) (vector 0 nm-0)))
|
|
(define $Cons (lambda (nm-0 nm-1 nm-2) (vector 1 nm-0 nm-1 nm-2)))
|
|
(define $IORes (lambda (nm-1 nm-2) (vector 0 #f nm-1 nm-2)))
|
|
(define ($Left x) (vector 0 #f #f x))
|
|
(define ($Right x) (vector 1 #f #f 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 (Node.exitFailure _ msg) (raise msg))
|
|
(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)
|
|
|
|
;; coerce scheme list to newt
|
|
(define (list->List xs)
|
|
(define (go acc xs)
|
|
(if (null? xs) acc
|
|
(go ($Cons #f (car xs) acc) (cdr xs))))
|
|
(go ($Nil #f) (reverse xs)))
|
|
|
|
(define (List->list xs)
|
|
(define (go acc xs)
|
|
(if (= 0 (vector-ref xs 0)) (reverse acc)
|
|
(go (cons (vector-ref xs 2) acc) (vector-ref xs 3))))
|
|
(go '() xs))
|
|
|
|
(define (Prelude.unpack str) (list->List (string->list str)))
|
|
(define (Prelude.pack cs) (list->string (List->list cs)))
|
|
(define (Prelude.fastConcat strings) (apply string-append (List->list 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)
|
|
($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))
|
|
(define (Prelude.fatalError _ msg) (raise msg))
|
|
(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 (list->List (command-line)) w))
|