;;;; unicode-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Aug '10

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

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

(module unicode-utils

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

(import scheme)
(import (chicken base))
(import (chicken type))
(import (only srfi-1 every make-list))
(import (only srfi-13 string-concatenate))
(import (only type-checks check-list check-natural-fixnum check-char))

;;

(: ascii-codepoint? (* --> boolean))
(: unicode-surrogate? (* --> boolean))
(: char->unicode-string (char -> string))
(: unicode-char->string (deprecated char->unicode-string))
(: *unicode-string ((list-of char) -> string))
(: unicode-string (#!rest -> string))
(: *unicode-make-string (fixnum char -> string))
(: unicode-make-string (fixnum #!optional char -> string))
(: unicode-surrogates->codepoint (fixnum fixnum -> (or boolean fixnum)))

;; Simple UTF 8

;nul is not accepted!
(define (ascii-codepoint? ch)
  (and
    (char? ch)
    (<= 0 (char->integer ch) #x7f) ) )

(define (unicode-surrogate? n)
  (and
    (fixnum? n)
    (##sys#unicode-surrogate? n) ) )

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

(define unicode-char->string char->unicode-string)

(define (*unicode-string chs)
  (cond
    ((null? chs)
      "" )
    ((null? (cdr chs))
      (##sys#char->utf8-string (car chs)) )
    (else
      (let* (
        (sts (map ##sys#char->utf8-string chs))
        (cnt (foldl (lambda (l s) (+ l (the fixnum (##sys#size s)))) 0 sts)) )
        (##sys#fragments->string cnt sts) ) ) ) )

;inefficient
(define (unicode-string . chs)
  (if (null? chs)
    ""
    (begin
      (if (null? (cdr chs)) (check-char 'unicode-string (car chs))
        #;(every (cut check-char 'unicode-string <>) chs)
        (check-list 'unicode-string chs))
      (*unicode-string chs) ) ) )

(define (*unicode-make-string len fill)
  (cond
    ((= 0 len)
      "" )
    ;ascii-codepoint < char
    ((not (ascii-codepoint? fill))
      (*unicode-string (the (list-of char) (make-list len fill))) )
    (else
      (##sys#make-string len fill) ) ) )

(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 generic-make-string unicode-make-string)

(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")) )

) ;module unicode-utils