#lang scheme/base

(require (planet chongkai/sml/ml-package)
         scheme/match
         (rename-in (only-in (planet chongkai/sml/ml-primitives)
                             chr ord
                             SOME? SOME SOME-content
                             NONE? NONE
                             Chr? Chr
                             LESS? LESS
                             EQUAL? EQUAL
                             GREATER? GREATER
                             < <= > >=)
                    (< ml-<)
                    (<= ml-<=)
                    (> ml->)
                    (>= ml->=))
         (planet chongkai/sml/lib/Strbase-struct))

(provide Char-struct)

(define-package Char-struct
  (minChar maxChar maxOrd ord chr succ pred
           < <= > >=
           compare contains notContains toLower toUpper
           isAlpha isAlphaNum isAscii isCntrl isDigit isGraph isHexDigit isLower isPrint isSpace
           isPunct isUpper fromString toString fromCString toCString)
  
  
  (define minChar #\nul)
  (define maxChar #\ÿ)
  (define maxOrd 255)
  
  (define* ord ord)
  (define* chr chr)
  
  (define (succ c)
    (if (eqv? c maxChar)
        (raise (Chr (current-continuation-marks)))
        (chr (add1 (ord c)))))
  (define (pred c)
    (if (eqv? c minChar)
        (raise (Chr (current-continuation-marks)))
        (chr (sub1 (ord c)))))
  
  (define compare
    (match-lambda
      ((vector c d)
       (cond ((char<? c d)
              LESS)
             ((char=? c d)
              EQUAL)
             (else
              GREATER)))))
  
  (define ((contains s) c)
    (memv c (string->list s)))
  
  (define ((notContains s) c)
    (not (memv c (string->list s))))
  
  (define toLower char-downcase)
  (define toUpper char-upcase)
  
  (define isAlpha char-alphabetic?)
  
  (define (isAlphaNum c)
    (or (char-alphabetic? c)
        (char-numeric? c)))
  
  (define (isAscii c)
    (<= (char->integer c) 127))
  
  (define isCntrl char-iso-control?)
  
  (define isDigit char-numeric?)
  
  (define isGraph char-graphic?)
  
  (define (isHexDigit c)
    (or (char-numeric? c)
        (char<=? #\a (char-downcase c)#\f)))
  
  (define isLower char-lower-case?)
  
  (define (isPrint c)
    (not (char-iso-control? c)))
  
  (define isSpace char-whitespace?)
  
  (define (isPunct c)
    (and (char-graphic? c)
         (not (isAlphaNum c))))
  
  (define isUpper char-upper-case?)
  
  (define-values (toString fromString fromCString toCString)
    (let ()
      (open-package Strbase-struct)
      (values toMLescape
              (lambda (s)
                (let ((getc (lambda (i)
                              (if (< i (string-length s))
                                  (SOME (vector (string-ref s i)
                                                (add1 i)))
                                  NONE))))
                  (match (getc 0)
                    ((? NONE?)
                     NONE)
                    ((? SOME? (app SOME-content (vector #\\ rest)))
                     (match ((fromMLescape getc) rest)
                       ((? NONE?)
                        NONE)
                       ((? SOME? (app SOME-content (vector c _)))
                        (SOME c))))
                    ((? SOME? (app SOME-content (vector c _)))
                     (SOME c)))))
              (lambda (s)
                (let ((getc (lambda (i)
                              (if (< i (string-length s))
                                  (SOME (vector (string-ref s i)
                                                (add1 i)))
                                  NONE))))
                  (match (getc 0)
                    ((? NONE?)
                     NONE)
                    ((? SOME? (app SOME-content (vector #\\ rest)))
                     (match ((fromCescape getc) rest)
                       ((? NONE?)
                        NONE)
                       ((? SOME? (app SOME-content (vector c _)))
                        (SOME c))))
                    ((? SOME? (app SOME-content (vector c _)))
                     (SOME c)))))
              toCescape)))
  
  (define*-values (< <= > >=)
    (values ml-< ml-<= ml-> ml->=)))