#lang scheme/base

(provide Int-struct)

(require (planet chongkai/sml/ml-package)
         scheme/match
         scheme/math
         "StringCvt-struct.ss"
         (for-syntax scheme/base)
         (rename-in (only-in (planet chongkai/sml/ml-primitives)
                             ~ div + - * / mod
                             > >= < <=
                             Match
                             Div
                             NONE NONE?
                             SOME SOME? SOME-content
                             LESS EQUAL GREATER)
                    (+ ml-+)
                    (- ml--)
                    (* ml-*)
                    (/ ml-/)
                    (< ml-<)
                    (<= ml-<=)
                    (> ml->)
                    (>= ml->=)))

(define-syntax (ml-compare stx)
  (syntax-case stx ()
    ((_ ml-f scheme-f?)
     #'(define ml-f
         (match-lambda
           ((vector i j)
            (scheme-f? i j))
           (_
            (raise (Match (current-continuation-marks)))))))))

(ml-compare ml-min min)
(ml-compare ml-max max)

(define-package Int-struct (toLarge fromLarge toInt fromInt precision minInt maxInt
                                    ~  * div mod quot rem + - compare > >= < <= abs
                                    min max sign sameSign fmt toString fromString scan
                                    )
  (define (toLarge x) x)
  (define (fromLarge x) x)
  (define (toInt x) x)
  (define (fromInt x) x)
  
  (define precision NONE)
  (define minInt NONE)
  (define maxInt NONE)
  
  (define quot
    (match-lambda
      ((vector i j)
       (call-with-exception-handler
        (lambda (e)
          (if (exn:break? e)
              e
              (Div (current-continuation-marks))))
        (lambda () (quotient i j))))))
  (define rem
    (match-lambda
      ((vector i j)
       (call-with-exception-handler
        (lambda (e)
          (if (exn:break? e)
              e
              (Div (current-continuation-marks))))
        (lambda () (remainder i j))))))
  
  (define compare
    (match-lambda
      ((vector c d)
       (cond ((< c d)
              LESS)
             ((= c d)
              EQUAL)
             (else
              GREATER)))))
  
  
  (define min ml-min)
  (define max ml-max)
  (define sign sgn)
  
  (define sameSign
    (match-lambda
      ((vector i j)
       (= (sgn i)
          (sgn j)))))
  
  (define-values (fmt toString fromString scan)
    (let ()
      (open-package StringCvt-struct)
      (define (decval c)
        (- (char->integer c) 48))
      (define (hexval c)
        (if (char<=? #\0 c #\9)
            (- (char->integer c) 48)
            (modulo (- (char->integer c) 55) 32)))
      (define (prhex i)
        (if (< i 10)
            (integer->char (+ i 48))
            (integer->char (+ i 55))))
      (define (skipWSget getc source)
        (getc (((dropl char-whitespace?) getc) source)))
      
      (define ((conv radix) i)
        (define (h n res)
          (if (zero? n)
              res
              (h (quotient n radix)
                 (cons (prhex (modulo n radix))
                       res))))
        (define (tostr n)
          (h (quotient n radix)
             (list (prhex (modulo n radix)))))
        (list->string
         (if (< i 0)
             (cons #\~ (tostr (- i)))
             (tostr i))))
      (define (((scan radix) getc) source)
        (define-values (isDigit factor)
          (match radix
            ((? BIN?)
             (values (lambda (c)
                       (char<=? #\0 c #\1))
                     2))
            ((? OCT?)
             (values (lambda (c)
                       (char<=? #\0 c #\7))
                     8))
            ((? DEC?)
             (values char-numeric? 10))
            ((? HEX?)
             (values (lambda (c)
                       (or (char-numeric? c)
                           (char<=? #\a (char-downcase c)#\f)))
                     16))))
        (define (dig1 sgn)
          (match-lambda
            ((? NONE?)
             NONE)
            ((? SOME? (app SOME-content (vector c rest)))
             (define (digr res src)
               (match (getc src)
                 ((? NONE?)
                  (SOME (vector (* sgn res) src)))
                 ((? SOME? (app SOME-content (vector c rest)))
                  (if (isDigit c)
                      (digr (+ (* factor res)
                               (hexval c))
                            rest)
                      (SOME (vector (* sgn res) src))))))
             (if (isDigit c)
                 (digr (hexval c) rest)
                 NONE))))
        (define (getdigs sgn after0 inp)
          (match ((dig1 sgn) inp)
            ((? NONE?)
             (SOME (vector 0 after0)))
            (res
             res)))
        (define (hexopt sgn)
          (match-lambda
            ((? NONE?)
             NONE)
            ((? SOME? (app SOME-content (vector #\0 after0)))
             (if (HEX? radix)
                 (match (getc after0)
                   ((? NONE?)
                    (SOME (vector 0 after0)))
                   ((? SOME? (app SOME-content (vector (or #\x #\X) rest)))
                    (getdigs sgn after0 (getc rest)))
                   (inp
                    (getdigs sgn after0 inp)))
                 (getdigs sgn after0 (getc after0))))
            (inp
             ((dig1 sgn) inp))))
        (define sign
          (match-lambda
            ((? NONE?)
             NONE)
            ((? SOME? (app SOME-content (vector (or #\~ #\-) rest)))
             ((hexopt -1) (getc rest)))
            ((? SOME? (app SOME-content (vector #\+ rest)))
             ((hexopt 1) (getc rest)))
            (inp
             ((hexopt 1) inp))))
        (sign (skipWSget getc source)))
      
      (define fmt
        (match-lambda
          ((? BIN?)
           (conv 2))
          ((? OCT?)
           (conv 8))
          ((? DEC?)
           (conv 10))
          ((? HEX?)
           (conv 16))))
      
      (values fmt
              (conv 10)
              (scanString (scan DEC))
              scan)))
  
  (define*-values (abs ~ div mod > >= < <=)
    (values abs ~ div mod ml-> ml->= ml-< ml-<=))
  
  
  (define*-values (+ - * /)
    (values ml-+ ml-- ml-* ml-/))
  )