;;;; unicode-utils.scm  -*- Hen -*-
;;;; Kon Lovett, Aug '10

;; Issues
;;
;; - Implies Unicode support that is not present.

(module unicode-utils

(;export
  ascii-codepoint?
  unicode-char->string
  unicode-string
  unicode-make-string *unicode-make-string
  unicode-surrogate?
  unicode-surrogates->codepoint)

(import scheme chicken)

(import
  (only srfi-1 make-list)
  (only srfi-13 string-concatenate )
  (only type-checks check-natural-fixnum check-char))
(require-library srfi-1 srfi-13 type-checks)

(declare
  (bound-to-procedure
    ##sys#string-append
    ##sys#char->utf8-string
    ##sys#unicode-surrogate?
    ##sys#surrogates->codepoint))

;; Simple UTF 8

(define (ascii-codepoint? ch)
  (let ((x (char->integer (check-char 'ascii-codepoint? ch))))
    (and (fx<= 0 x) (fx<= x #x7f)) ) )

(define (unicode-char->string ch)
  (##sys#char->utf8-string (check-char 'unicode-char->string ch)) )

;inefficient
(define (unicode-string . chs)
  (cond
    ((null? chs)
      "" )
    ((null? (cdr chs))
      (unicode-char->string (car chs)) )
    (else
      (string-concatenate (map unicode-char->string chs)) ) ) )

(define (unicode-make-string len #!optional (fill #\space))
  (*unicode-make-string
    (check-natural-fixnum 'unicode-make-string len)
    (check-char 'unicode-make-string fill)) )

(define (unicode-surrogate? n)
  (##sys#unicode-surrogate? (check-natural-fixnum 'unicode-surrogate? n)) )

(define (unicode-surrogates->codepoint hi lo)
  (##sys#surrogates->codepoint
    (check-natural-fixnum 'unicode-surrogates->codepoint hi "high")
    (check-natural-fixnum 'unicode-surrogates->codepoint lo "low")) )

;inefficient
(define (*unicode-make-string len fill)
  (cond
    ((fx= 0 len)
      "" )
    ((ascii-codepoint? fill)
      (##sys#make-string len fill) )
    (else
      (string-concatenate (make-list len (##sys#char->utf8-string fill))) ) ) )


) ;module unicode-utils