#lang scheme/base

(require (for-syntax "syntax-helper.ss"
                     scheme/base)
         scheme/match
         scheme/list
         "ml-package.ss")

(provide (except-out (all-defined-out)
                     ml-floor ml-round
                     ml-/ ml-+ ml-- ml-*
                     ml-=
                     ml-<-help
                     ml-< ml-<= ml-> ml->=
                     ml-foldl ml-foldr ml-map
                     ml-substring
                     ml-last
                     ml-take ml-drop
                     ml-filter ml-partition)
         (rename-out (- ~)
                     (char->integer ord)
                     (box ref)
                     (unbox !)
                     (void ignore))
         abs
         (rename-out (string->list explode)
                     (ml-floor floor)
                     (ml-round round)
                     (void help)
                     (exact->inexact real)
                     (list->string implode))
         length
         not
         (rename-out (ml-/ /)
                     (ml-* *)
                     (ml-+ +)
                     (ml-- -)
                     (reverse rev)
                     (ml-= =)
                     (ml-< <)
                     (ml-<= <=)
                     (ml-> >)
                     (ml->= >=)
                     (null? null)
                     (ml-foldl foldl)
                     (ml-foldr foldr)
                     (ml-map map)
                     (ml-substring substring)
                     (ml-last last)
                     (ml-take take)
                     (ml-drop drop)
                     (ml-filter filter)
                     (ml-partition partition)
                     (string-length size)
                     (number->string makestring)))

(define-syntax (define-ml-datatype stx)
  (syntax-case stx ()
    ((define-ml-datatype id #f)
     (with-syntax ((id-datatype (syntax-append #'id "-datatype"))
                   (id? (syntax-append #'id "?"))
                   (make-id (syntax-prepend #'id "make-")))
       #'(begin
           (define*-values (id id?)
             (let ()
               (define-struct id () #:transparent)
               (values (make-id) id?)))
           (define*-syntax id-datatype
             (list (quote-syntax/prune id) (quote-syntax/prune id?))))))
    ((define-ml-datatype id #t)
     (with-syntax ((id-datatype (syntax-append #'id "-datatype"))
                   (id? (syntax-append #'id "?"))
                   (id-content (syntax-append #'id "-content"))
                   (make-id (syntax-prepend #'id "make-")))
       #'(begin
           (define*-values (id id? id-content)
             (let ()
               (define-struct id (content) #:transparent)
               (values make-id id? id-content)))
           (define*-syntax id-datatype
             (list (quote-syntax/prune id) (quote-syntax/prune id?) (quote-syntax/prune id-content))))))))

(define-syntax (define-ml-type stx)
  (syntax-case stx ()
    ((define-ml-type t (s))
     (let ((dt-list (map syntax-local-introduce (syntax-local-value #'s))))
       (with-syntax (((dt ...)
                      dt-list)
                     (((v ...) ...)
                      (map (lambda (dt)
                             (map syntax-local-introduce (syntax-local-value dt)))
                           dt-list)))
         (syntax/loc stx
           (begin (define*-values (v ...) (values v ...)) ...
                  (define*-syntax dt (list #'v ...)) ...
                  (define*-syntax t (list #'dt ...)))))))
    ((define-ml-type t longid)
     (let* ((dt-list (map syntax-local-introduce
                          (syntax-local-value (unlong #'longid))))
            (to-exported-identifier
             (lambda (id)
               (datum->syntax #'t (syntax-e id) #f)) )
            (dt1-list
             (map to-exported-identifier dt-list))
            (v-list
             (map (lambda (dt)
                    (map syntax-local-introduce
                         (syntax-local-value dt)))
                  dt-list))
            (v1-list
             (map (lambda (lst)
                    (map to-exported-identifier lst))
                  v-list)))
       (with-syntax (((dt1 ...)
                      dt1-list)
                     (((v ...) ...)
                      v-list)
                     (((v1 ...) ...)
                      v1-list))
         (syntax/loc stx
           (begin (define*-values (v1 ...) (values v ...)) ...
                  (define*-syntax dt1 (list #'v1 ...)) ...
                  (define*-syntax t (list #'dt1 ...)))))))))

(define-syntax (define-ml-exn stx)
  (syntax-case stx ()
    ((_ id #f)
     (with-syntax ((id-datatype (syntax-append #'id "-datatype"))
                   (id? (syntax-append #'id "?"))
                   (make-id (syntax-prepend #'id "make-"))
                   (id-string (symbol->string (syntax-e #'id))))
       #`(begin
           (define*-values (id id?)
             (let ()
               (define-struct (id exn) () #:transparent)
               (values (lambda (m) (make-id id-string m))
                       (lambda (t) (id? (t (current-continuation-marks)))))))
           (define*-syntax id-datatype
             (list (quote-syntax/prune id) (quote-syntax/prune id?))))))
    ((_ id #t)
     (with-syntax ((id-datatype (syntax-append #'id "-datatype"))
                   (id? (syntax-append #'id "?"))
                   (id-content (syntax-append #'id "-content"))
                   (make-id (syntax-prepend #'id "make-"))
                   (id-string (symbol->string (syntax-e #'id))))
       #'(begin
           (define*-values (id id? id-content)
             (let ()
               (define-struct (id exn) (content) #:transparent)
               (values (lambda (content)
                         (lambda (m)
                           (make-id id-string m content)))
                       (lambda (t)
                         (id? (t (current-continuation-marks))))
                       (lambda (t)
                         (id-content (t (current-continuation-marks)))))))
           (define*-syntax id-datatype
             (list (quote-syntax/prune id) (quote-syntax/prune id?) (quote-syntax/prune id-content))))))
    ((_ id (p-list ... id2))
     (let ((bindings
            (map syntax-local-introduce
                 (syntax-local-value
                  (unlong #`(p-list ... #,(syntax-append #'id2 "-datatype")))))))
       (if (= (length bindings) 2)
           (with-syntax ((id-datatype (syntax-append #'id "-datatype"))
                         (id? (syntax-append #'id "?")))
             #`(begin (define*-values (id id?)
                        (values #,@bindings))
                      (define*-syntax id-datatype (list #'id #'id?))))
           (with-syntax ((id-datatype (syntax-append #'id "-datatype"))
                         (id? (syntax-append #'id "?"))
                         (id-content (syntax-append #'id "-content")))
             #`(begin (define*-values (id id? id-content)
                        (values #,@bindings))
                      (define*-syntax id-datatype (list #'id #'id? #'id-content)))))))))

(define ref-datatype (list #'box #'box? #'unbox))

(define-syntax ml-devector
  (syntax-rules ()
    ((_ name arg body)
     (define-syntax name
       (syntax-id-rules (vector vector-immutable)
         ((_ (vector . arg))
          body)
         ((_ (vector-immutable . arg))
          body)
         ((_ t)
          (match t
            ((vector . arg)
             body)))
         (_
          (match-lambda
            ((vector . arg)
             body))))))))

(ml-devector := (b v) (set-box! b v))

(define-ml-exn Bind #f)
(define-ml-exn Chr #f)
(define-ml-exn Domain #f)
(define-ml-exn Div #f)
(define-ml-exn Fail #t)
(define-ml-exn Graphic #f)
(define-ml-exn Interrupt #f)
(define-ml-exn Io #f)
(define-ml-exn Match #f)
(define-ml-exn Option #f)
(define-ml-exn Ord #f)
(define-ml-exn Overflow #f)
(define-ml-exn Size #f)
(define-ml-exn Subscript #f)
(define-ml-exn SysErr #f)
(define-ml-exn Empty #f)

(define-syntax order-type
  (list #'LESS-datatype #'EQUAL-datatype #'GREATER-datatype))
(define-ml-datatype LESS #f)
(define-ml-datatype EQUAL #f)
(define-ml-datatype GREATER #f)

(define (ceil n)
  (inexact->exact (ceiling n)))

(define (chr c)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Chr (current-continuation-marks))))
   (lambda () (integer->char c))))

(define (ml-floor n)
  (inexact->exact (floor n)))
(define (ml-round n)
  (inexact->exact (round n)))

(define (hd p)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Empty (current-continuation-marks))))
   (lambda () (car p))))
(define (tl p)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Empty (current-continuation-marks))))
   (lambda () (cdr p))))

(define (trunc n)
  (inexact->exact (truncate n)))

(ml-devector ml-/ (n1 n2) (/ n1 n2))
(ml-devector div (n1 n2)
             (if (zero? n2)
                 (raise (Div (current-continuation-marks)))
                 (/ (- n1 (modulo n1 n2)) n2)))
(ml-devector mod (n1 n2)
             (if (zero? n2)
                 (raise (Div (current-continuation-marks)))
                 (modulo n1 n2)))
(ml-devector ml-* (n1 n2) (* n1 n2))
(ml-devector ml-+ (n1 n2) (+ n1 n2))
(ml-devector ml-- (n1 n2) (- n1 n2))

(ml-devector ^ (s1 s2) (string-append s1 s2))

(ml-devector @ (l1 l2) (append l1 l2))

(define (ml-equal? a b)
  (cond ((or (box? a)
             (and (vector? a)
                  (not (immutable? a))))
         (eq? a b))
        ((pair? a)
         (and (ml-equal? (car a) (car b))
              (ml-equal? (cdr a) (cdr b))))
        ((vector? a)
         (let lp ((l (sub1 (vector-length a))))
           (if (zero? l)
               (ml-equal? (vector-ref a 0)
                          (vector-ref b 0))
               (and (ml-equal? (vector-ref a l)
                               (vector-ref b l))
                    (lp (sub1 l))))))
        ((struct? a)
         (ml-equal? (vector-ref (struct->vector a) 0)
                    (vector-ref (struct->vector b) 0)))
        (else #t)))

(ml-devector ml-= (a b)
             (and (equal? a b)
                  (ml-equal? a b)))
(ml-devector <> (a b)
             (not (and (equal? a b)
                       (ml-equal? a b))))

(define-syntax ml-<-help
  (syntax-rules ()
    ((_ ml-< < char<? string<?)
     (ml-devector ml-< (a b)
                  (cond ((number? a)
                         (< a b))
                        ((char? a)
                         (char<? a b))
                        ((string? a)
                         (string<? a b)))))))

(ml-<-help ml-< < char<? string<?)
(ml-<-help ml-<= <= char<=? string<=?)
(ml-<-help ml-> > char>? string>?)
(ml-<-help ml->= >= char>=? string>=?)

(define-syntax list-type
  (list #'nil-datatype #'::-datatype))
(define-syntax nil-datatype
  (list #'nil #'nil?))
(define nil '())
(define nil? null?)
(define-syntax ::-datatype
  (list #':: #'::? #'::-content))
(ml-devector :: (a d) (cons a d))
(define ::? pair?)
(define (::-content p)
  (vector (car p)
          (cdr p)))

(define-syntax bool-type
  (list #'true-datatype #'false-datatype))
(define-syntax true-datatype
  (list #'true #'true?))
(define true #t)
(define (true? x) x)
(define-syntax false-datatype
  (list #'false #'false?))
(define false #f)
(define (false? x) (not x))

(define-syntax option-type
  (list #'NONE-datatype #'SOME-datatype))
(define-ml-datatype NONE #f)
(define-ml-datatype SOME #t)

(define ((app f) l)
  (for-each f l))

(define (concat sl)
  (apply string-append sl))

(define (((ml-foldl f) b) l)
  (foldl (lambda (a b)
           (f (vector-immutable a b)))
         b l))
(define (((ml-foldr f) b) l)
  (foldr (lambda (a b)
           (f (vector-immutable a b)))
         b l))

(define ((ml-map f) l)
  (map f l))

(define (str c)
  (list->string (list c)))

(ml-devector ml-substring (str start end)
             (call-with-exception-handler
              (lambda (e)
                (if (exn:break? e)
                    e
                    (Subscript  (current-continuation-marks))))
              (lambda () (substring str start (+ start end)))))

(ml-devector o (f g)
             (lambda (x) (f (g x))))

(ml-devector before (a b) a)

;List
(define (ml-last l)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Empty (current-continuation-marks))))
   (lambda () (last l))))

(define (getItem l)
  (if (null? l)
      NONE
      (SOME (vector-immutable (car l) (cdr l)))))

(ml-devector nth (l i)
             (call-with-exception-handler
              (lambda (e)
                (if (exn:break? e)
                    e
                    (Subscript (current-continuation-marks))))
              (lambda () (list-ref l i))))

(ml-devector ml-take (l i)
             (call-with-exception-handler
              (lambda (e)
                (if (exn:break? e)
                    e
                    (Subscript (current-continuation-marks))))
              (lambda () (take l i))))

(ml-devector ml-drop (l i)
             (call-with-exception-handler
              (lambda (e)
                (if (exn:break? e)
                    e
                    (Subscript (current-continuation-marks))))
              (lambda () (drop l i))))

(ml-devector revAppend (l1 l2)
             (append (reverse l1) l2))

(define ((mapPartial f) l)
  (map SOME-content (filter SOME? (map f l))))

(define ((find f) l)
  (cond ((null? l)
         NONE)
        ((f (car l))
         (SOME (car l)))
        (else
         ((find f) (cdr l)))))

(define ((ml-filter f) l)
  (filter f l))

(define ((ml-partition f) l)
  (call-with-values
   (lambda () (partition f l))
   vector-immutable))

(define ((exists f) l)
  (ormap f l))
(define ((all f) l)
  (andmap f l))

(define (my-make-list n f a)
  (if (= n a)
      '()
      (cons (f a)
            (make-list n f (add1 a)))))
(ml-devector tabulate (n f)
             (if (< n 0)
                 (raise (Size (current-continuation-marks)))
                 (my-make-list n f 0)))

;TextIO
(define (closeIn p)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Io (current-continuation-marks))))
   (lambda () (close-input-port p))))
(define (closeOut p)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Io (current-continuation-marks))))
   (lambda () (close-output-port p))))
(define (endOfStream p)
  (eof-object? (peek-char p)))
(define (flushOut p)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Io (current-continuation-marks))))
   (lambda () (flush-output p))))

(define (input p)
  (let ((t (read-string 16 p)))
    (if (eof-object? t)
        ""
        t)))

(define (input1 p)
  (let ((t (read-char p)))
    (if (eof-object? t)
        NONE
        (SOME t))))

(ml-devector inputN (p n)
             (call-with-exception-handler
              (lambda (e)
                (if (exn:break? e)
                    e
                    (Size (current-continuation-marks))))
              (lambda ()
                (let ((t (read-string n p)))
                  (if (eof-object? t)
                      ""
                      t)))))

(define (inputAll p)
  (let lp ((acc '()))
    (let ((t (read-string 16 p)))
      (if (eof-object? t)
          (apply string-append (reverse acc))
          (lp (cons t acc))))))

(define (inputLine p)
  (let ((t (read-line p)))
    (if (eof-object? t)
        NONE
        (SOME (string-append t "\n")))))

(define (lookahead p)
  (let ((t (peek-char p)))
    (if (eof-object? t)
        NONE
        (SOME t))))

(define (openAppend name)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Io (current-continuation-marks))))
   (lambda () (open-output-file name #:exists 'append))))

(define (openIn name)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Io (current-continuation-marks))))
   (lambda () (open-input-file name))))

(define (openOut name)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Io (current-continuation-marks))))
   (lambda () (open-output-file name #:exists 'truncate/replace))))

(ml-devector output (p b)
             (call-with-exception-handler
              (lambda (e)
                (if (exn:break? e)
                    e
                    (Io (current-continuation-marks))))
              (lambda () (write-string b p))))

(ml-devector output1 (p b)
             (call-with-exception-handler
              (lambda (e)
                (if (exn:break? e)
                    e
                    (Io (current-continuation-marks))))
              (lambda () (write-char b p))))

(define (print s)
  (call-with-exception-handler
   (lambda (e)
     (if (exn:break? e)
         e
         (Io (current-continuation-marks))))
   (lambda ()
     (write-string s)
     (flush-output))))

(define stdErr (current-error-port))
(define stdIn (current-input-port))
(define stdOut (current-output-port))

;String
;(define size string-length)

(define (valOf x)
  (if (SOME? x)
      (SOME-content x)
      (raise (Option (current-continuation-marks)))))

;General
(define (exnName exn)
  (exn-message (exn (current-continuation-marks))))
(define exnMessage exnName)