Add getChar, putChar and putCharLn to prelude

libs/prelude/PrimIO.idr

@@ -36,6 +36,8 @@ io_bind (MkIO fn)
 
 %extern prim__putStr : String -> (1 x : %World) -> IORes ()
 %extern prim__getStr : (1 x : %World) -> IORes String
+%extern prim__putChar : Char -> (1 x : %World) -> IORes ()
+%extern prim__getChar : (1 x : %World) -> IORes Char
 
 -- A pointer representing a given parameter type
 -- The parameter is a phantom type, to help differentiate between
@@ -76,25 +78,43 @@ export %inline
 cCall : (ret : Type) -> String -> FArgList -> IO ret
 cCall ret fn args = primIO (prim__cCall ret fn args)
 
+||| Output a string to stdout without a trailing newline
 export
 putStr : String -> IO ()
 putStr str = primIO (prim__putStr str)
 
+||| Output a string to stdout with a trailing newline
 export
 putStrLn : String -> IO ()
 putStrLn str = putStr (prim__strAppend str "\n")
 
+||| Read one line of input from stdin, without the trailing newline
 export
 getLine : IO String
 getLine = primIO prim__getStr
 
+||| Write a single character to stdout
+export
+putChar : Char -> IO ()
+putChar c = primIO (prim__putChar c)
+
+||| Write a single character to stdout, with a trailing newline
+export
+putCharLn : Char -> IO ()
+putCharLn c = putStrLn (prim__cast_CharString c)
+
+||| Read a single character from stdin
+export
+getChar : IO Char
+getChar = primIO prim__getChar
+
 export
 fork : (1 prog : IO ()) -> IO ThreadID
 fork (MkIO act) = schemeCall ThreadID "blodwen-thread" [act]
 
 export
 prim_fork : (1 prog : PrimIO ()) -> PrimIO ThreadID
-prim_fork act w = prim__schemeCall ThreadID "blodwen-thread" [act] w 
+prim_fork act w = prim__schemeCall ThreadID "blodwen-thread" [act] w
 
 unsafeCreateWorld : (1 f : (1 x : %World) -> a) -> a
 unsafeCreateWorld f = f %MkWorld

src/Compiler/Scheme/Common.idr

@@ -157,7 +157,8 @@ schOp BelieveMe [_,_,x] = x
 
 ||| Extended primitives for the scheme backend, outside the standard set of primFn
 public export
-data ExtPrim = CCall | SchemeCall | PutStr | GetStr
+data ExtPrim = CCall | SchemeCall
+             | PutStr | GetStr | PutChar | GetChar
              | FileOpen | FileClose | FileReadLine | FileWriteLine | FileEOF
              | NewIORef | ReadIORef | WriteIORef
              | NewArray | ArrayGet | ArraySet
@@ -173,6 +174,8 @@ Show ExtPrim where
   show SchemeCall = "SchemeCall"
   show PutStr = "PutStr"
   show GetStr = "GetStr"
+  show PutChar = "PutChar"
+  show GetChar = "GetChar"
   show FileOpen = "FileOpen"
   show FileClose = "FileClose"
   show FileReadLine = "FileReadLine"
@@ -201,6 +204,8 @@ toPrim pn@(NS _ n)
             (n == UN "prim__cCall", CCall),
             (n == UN "prim__putStr", PutStr),
             (n == UN "prim__getStr", GetStr),
+            (n == UN "prim__putChar", PutChar),
+            (n == UN "prim__getChar", GetChar),
             (n == UN "prim__open", FileOpen),
             (n == UN "prim__close", FileClose),
             (n == UN "prim__readLine", FileReadLine),
@@ -341,6 +346,10 @@ parameters (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CEx
       = pure $ "(display " ++ !(schExp i vs arg) ++ ") " ++ mkWorld (schConstructor 0 []) -- code for MkUnit
   schExtCommon i vs GetStr [world]
       = pure $ mkWorld "(blodwen-get-line (current-input-port))"
+  schExtCommon i vs PutChar [arg, world]
+      = pure $ "(display " ++ !(schExp i vs arg) ++ ") " ++ mkWorld (schConstructor 0 []) -- code for MkUnit
+  schExtCommon i vs GetChar [world]
+      = pure $ mkWorld "(blodwen-get-char (current-input-port))"
   schExtCommon i vs FileOpen [file, mode, bin, world]
       = pure $ mkWorld $ fileOp $ "(blodwen-open "
                                       ++ !(schExp i vs file) ++ " "

support/chez/support.ss

@@ -14,8 +14,8 @@
 (define blodwen-or (lambda (x y) (logor x y)))
 (define blodwen-xor (lambda (x y) (logxor x y)))
 
-(define cast-num 
+(define cast-num
-  (lambda (x) 
+  (lambda (x)
     (if (number? x) x 0)))
 (define destroy-prefix
   (lambda (x)
@@ -30,14 +30,14 @@
 (define get-tag (lambda (x) (vector-ref x 0)))
 (define string-reverse (lambda (x)
   (list->string (reverse (string->list x)))))
-(define (string-substr off len s) 
+(define (string-substr off len s)
     (let* ((l (string-length s))
           (b (max 0 off))
           (x (max 0 len))
           (end (min l (+ b x))))
           (substring s b end)))
 
-(define either-left 
+(define either-left
   (lambda (x)
     (vector 0 #f #f x)))
 
@@ -109,10 +109,10 @@
 ;; Files: Much of the following adapted from idris-chez, thanks to Niklas
 ;; Larsson
 
-;; All the file operations are implemented as primitives which return 
+;; All the file operations are implemented as primitives which return
 ;; Either Int x, where the Int is an error code:
 (define (blodwen-error-code x)
-    (cond 
+    (cond
         ((i/o-read-error? x) 1)
         ((i/o-write-error? x) 2)
         ((i/o-file-does-not-exist-error? x) 3)
@@ -136,7 +136,7 @@
 (define (blodwen-open file mode bin)
     (define tc (if (= bin 1) #f (make-transcoder (utf-8-codec))))
     (define bm (buffer-mode line))
-    (case mode 
+    (case mode
         (("r") (open-file-input-port file (file-options) bm tc))
         (("w") (open-file-output-port file (file-options no-fail) bm tc))
         (("wx") (open-file-output-port file (file-options) bm tc))
@@ -151,11 +151,16 @@
     (when (port? p) (close-port p)))
 
 (define (blodwen-get-line p)
-    (if (and (port? p) (not (port-eof? p))) 
+    (if (and (port? p) (not (port-eof? p)))
         (let ((str (get-line p)))
             (string-append str "\n"))
         ""))
 
+(define (blodwen-get-char p)
+    (if (and (port? p) (not (port-eof? p)))
+        (get-char p)
+        #\nul))
+
 (define (blodwen-file-size p)
     (port-length p))
 
@@ -216,7 +221,7 @@
 (define (blodwen-condition-broadcast c) (condition-broadcast c))
 
 (define (blodwen-sleep s) (sleep (make-time 'time-duration 0 s)))
-(define (blodwen-usleep s) 
+(define (blodwen-usleep s)
   (let ((sec (div s 1000000))
         (micro (mod s 1000000)))
        (sleep (make-time 'time-duration (* 1000 micro) sec))))

support/chicken/support.scm

@@ -14,8 +14,8 @@
 (define blodwen-or (lambda (x y) (bitwise-or x y)))
 (define blodwen-xor (lambda (x y) (bitwise-xor x y)))
 
-(define cast-num 
+(define cast-num
-  (lambda (x) 
+  (lambda (x)
     (if (number? x) x 0)))
 (define destroy-prefix
   (lambda (x)
@@ -30,14 +30,14 @@
 (define get-tag (lambda (x) (vector-ref x 0)))
 (define string-reverse (lambda (x)
   (list->string (reverse (string->list x)))))
-(define (string-substr off len s) 
+(define (string-substr off len s)
     (let* ((l (string-length s))
           (b (max 0 off))
           (x (max 0 len))
           (end (min l (+ b x))))
           (substring s b end)))
 
-(define either-left 
+(define either-left
   (lambda (x)
     (vector 0 #f #f x)))
 
@@ -54,7 +54,7 @@
 ;; Files: Much of the following adapted from idris-chez, thanks to Niklas
 ;; Larsson
 
-;; All the file operations are implemented as primitives which return 
+;; All the file operations are implemented as primitives which return
 ;; Either Int x, where the Int is an error code
 
 ;; If the file operation raises an error, catch it and return an appropriate
@@ -72,13 +72,13 @@
     0)
 
 (define (blodwen-open file mode bin)
-    (cond 
+    (cond
         ((string=? mode "r") (open-input-file file))
         ((string=? mode "w") (open-output-file file))
         (else (abort "I haven't worked that one out yet, sorry..."))))
 
 (define (blodwen-close-port p)
-    (cond 
+    (cond
       ((input-port? p) (close-input-port p))
       ((output-port? p) (close-output-port p))))
 
@@ -90,6 +90,14 @@
                 (string-append str "\n")))
         void))
 
+(define (blodwen-get-char p)
+    (if (port? p)
+        (let ((char (read-char p)))
+            (if (eof-object? char)
+                #\nul
+                char))
+        void))
+
 (define (blodwen-eof p)
   (if (eof-object? (peek-char p))
       1
@@ -112,7 +120,7 @@
 (define (blodwen-thisthread) (current-thread))
 
 (define (blodwen-condition) (make-condition-variable))
-(define (blodwen-condition-wait c m) 
+(define (blodwen-condition-wait c m)
   (mutex-unlock! m c)
   (mutex-lock! m)) ;; lock again, for consistency with other CGs
 (define (blodwen-condition-wait-timeout c m t) (mutex-unlock! m c t))

support/racket/support.rkt

@@ -14,8 +14,8 @@
 (define blodwen-or (lambda (x y) (bitwise-ior x y)))
 (define blodwen-xor (lambda (x y) (bitwise-xor x y)))
 
-(define cast-num 
+(define cast-num
-  (lambda (x) 
+  (lambda (x)
     (if (number? x) x 0)))
 (define destroy-prefix
   (lambda (x)
@@ -30,14 +30,14 @@
 (define get-tag (lambda (x) (vector-ref x 0)))
 (define string-reverse (lambda (x)
   (list->string (reverse (string->list x)))))
-(define (string-substr off len s) 
+(define (string-substr off len s)
     (let* ((l (string-length s))
           (b (max 0 off))
           (x (max 0 len))
           (end (min l (+ b x))))
           (substring s b end)))
 
-(define either-left 
+(define either-left
   (lambda (x)
     (vector 0 #f #f x)))
 
@@ -111,10 +111,10 @@
 ;; Files : Much of the following adapted from idris-chez, thanks to Niklas
 ;; Larsson
 
-;; All the file operations are implemented as primitives which return 
+;; All the file operations are implemented as primitives which return
 ;; Either Int x, where the Int is an error code
 (define (blodwen-error-code x)
-    (cond 
+    (cond
         ((eq? x (lookup-errno 'ENOENT)) 3)
         ((eq? x (lookup-errno 'EACCES)) 4)
         ((eq? x (lookup-errno 'EEXIST)) 5)
@@ -123,11 +123,11 @@
 ;; If the file operation raises an error, catch it and return an appropriate
 ;; error code
 (define (blodwen-file-op op)
-  (with-handlers 
+  (with-handlers
        ([exn:fail:filesystem:errno?
           (lambda (exn) (either-left (blodwen-error-code
                                 (car (exn:fail:filesystem:errno-errno exn)))))]
-        [exn:fail:filesystem? 
+        [exn:fail:filesystem?
           (lambda (exn) (either-left 255))]
         )
       (either-right (op))))
@@ -139,7 +139,7 @@
 (define (blodwen-open file mode bin)
     (define tc (if (= bin 1) #f (make-transcoder (utf-8-codec))))
     (define bm (buffer-mode line))
-    (case mode 
+    (case mode
         (("r") (open-file-input-port file (file-options) bm tc))
         (("w") (open-file-output-port file (file-options no-fail) bm tc))
         (("wx") (open-file-output-port file (file-options) bm tc))
@@ -152,7 +152,7 @@
 
 
 (define (blodwen-close-port p)
-    (cond 
+    (cond
       ((input-port? p) (close-input-port p))
       ((output-port? p) (close-output-port p))))
 
@@ -164,6 +164,14 @@
                 (string-append str "\n")))
         void))
 
+(define (blodwen-get-char p)
+    (if (port? p)
+        (let ((char (read-char p)))
+            (if (eof-object? char)
+                #\nul
+                char))
+        void))
+
 (define (blodwen-eof p)
   (if (eof-object? (peek-char p))
       1
@@ -235,6 +243,6 @@
     (if (null? args)
         (vector 0 '())
         (vector 1 '() (car args) (blodwen-build-args (cdr args)))))
-    (blodwen-build-args 
+    (blodwen-build-args
       (cons (path->string (find-system-path 'run-file))
             (vector->list (current-command-line-arguments)))))

tests/idris2/basic017/expected

@@ -1,6 +1,6 @@
 1/1: Building CaseInf (CaseInf.idr)
 CaseInf.idr:7:24--9:1:While processing right hand side of Main.test3bad at CaseInf.idr:6:1--9:1:
-While processing right hand side of Main.case block in 1148(179) at CaseInf.idr:7:14--9:1:
+While processing right hand side of Main.case block in 1153(179) at CaseInf.idr:7:14--9:1:
 When unifying Integer and Nat
 Mismatch between:
 	Integer