#lang scheme/base

(require (planet chongkai/sml/ml-package)
         scheme/match
         (rename-in (only-in (planet chongkai/sml/ml-primitives)
                             size
                             ^
                             str
                             concat
                             implode
                             explode
                             substring
                             SOME? SOME SOME-content
                             NONE? NONE
                             Div? Div
                             Subscript? Subscript
                             LESS? LESS
                             EQUAL? EQUAL
                             GREATER? GREATER
                             < > <= >=)
                    (substring ml-substring)
                    (< ml-<)
                    (> ml->)
                    (>= ml->=)
                    (<= ml-<=))
         (only-in srfi/13
                  string-prefix?)
         (planet chongkai/sml/lib/Strbase-struct))

(provide String-struct)

(define-package String-struct (maxSize size sub substring extract concat ^ str implode explode map translate tokens
                                       fields isPrefix compare collate fromString toString fromCString toCString
                                       < <= > >=)
  
  (define maxSize +inf.0)
  
  (define* size size)
  
  (define sub
    (match-lambda
      ((vector s i)
       (call-with-exception-handler
        (lambda (e)
          (if (exn:break? e)
              e
              (Subscript  (current-continuation-marks))))
        (lambda () (string-ref s i))))))
  
  (define extract
    (match-lambda
      ((vector s i (? NONE?))
       (call-with-exception-handler
        (lambda (e)
          (if (exn:break? e)
              e
              (Subscript (current-continuation-marks))))
        (lambda () (substring s i))))
      ((vector s i (? SOME? (app SOME-content j)))
       (call-with-exception-handler
        (lambda (e)
          (if (exn:break? e)
              e
              (Subscript (current-continuation-marks))))
        (lambda ()
          (if (and (zero? j)
                   (= i (string-length s)))
              ""
              (substring s i (+ i j))))))))
  
  (define*-values (concat ^ str implode explode)
    (values concat ^ str implode explode))
  
  (define ((translate f) s)
    (concat (map f (string->list s))))
  
  (define ((isPrefix s1) s2)
    (string-prefix? s1 s2))
  
  (define compare
    (match-lambda
      ((vector c d)
       (cond ((string<? c d)
              LESS)
             ((string=? c d)
              EQUAL)
             (else
              GREATER)))))
  
  (define (collate cmp)
    (match-lambda
      ((vector s1 s2)
       (let* ((n1 (string-length s1))
              (n2 (string-length s2))
              (stop (min n1 n2)))
         (define (h j)
           (if (= j stop)
               (cond ((< n1 n2)
                      LESS)
                     ((> n1 n2)
                      GREATER)
                     (else
                      EQUAL))
               (match (cmp (vector (string-ref s1 j)
                                   (string-ref s2 j)))
                 ((? EQUAL?)
                  (h (add1 j)))
                 (x x))))
         (h 0)))))
  
  (define-values (tokens fields fromString toString fromCString toCString)
    (let ()
      (open-package Strbase-struct)
      (values
       ;tokens
       (lambda (p)
         (lambda (s)
           (map ml-substring
                ((tokens p) (vector s 0 (string-length s))))))
       ;fields
       (lambda (p)
         (lambda (s)
           (map ml-substring
                ((fields p) (vector s 0 (string-length s))))))
       ;fromString
       (lambda (s)
         (letrec ((getc
                   (lambda (i)
                     (if (< i (string-length s))
                         (SOME (vector (string-ref s i)
                                       (add1 i)))
                         NONE)))
                  (h
                   (lambda (src res)
                     (match (getc src)
                       ((? NONE?)
                        (SOME (list->string (reverse res))))
                       ((? SOME? (app SOME-content (vector #\\ src1)))
                        (match ((fromMLescape getc) src1)
                          ((? NONE?)
                           NONE)
                          ((? SOME? (app SOME-content (vector c src2)))
                           (h src2 (cons c res)))))
                       ((? SOME? (app SOME-content (vector c src1)))
                        (h src1 (cons c res)))))))
           (h 0 '())))
       ;toString
       (lambda (s)
         ((translate toMLescape) (vector s 0 (string-length s))))
       fromCString
       ;toCString
       (lambda (s)
         ((translate toCescape) (vector s 0 (string-length s)))))))
  
  (define* ((map f) s)
    (list->string (map f (string->list s))))
  
  (define* substring ml-substring)
  (define*-values (< <= > >=)
    (values ml-< ml-<= ml-> ml->=)))