(import messages checks simple-cells simple-tests)

(define msg (make-message #:Type #:foo 0 1 2))

(define-checks (messages? verbose?)
  (message? msg)
  #t
  (message? #(0 1 2))
  #f
  ((message-of? #:Type) msg)
  #t
  ((message-of? #:Bar) msg)
  #f
  (message-type msg)
  #:Type
  (message-key msg)
  #:foo
  (message-data msg)
  #(0 1 2)
  )
(messages? #t)

(define-algebraic-type Foo
  (#:make (x number?) xs number?)
  )

(define foo ((Foo #:make) 0 1 2 3))

(define-checks (vargs? verbose?)
  ((Foo #:?) foo)
  #t
  (case-variant Foo foo
    (#:make (x xs) x)
    (else #f))
  0
  (case-variant Foo foo
    (#:make (x xs) xs)
    (else #f))
  '(1 2 3)
  )
(vargs? #t)

(define-algebraic-type Option
  (#:none)
  (#:some (arg)))

(define (qux opt)
  (case-variant Option opt
    (#:none () #f)
    (#:some (arg) arg)))
;(pe '(case-variant Option ((Option #:none))
;                   (#:none () #f)
;                   (#:some (arg) arg)))
(define-checks (options? verbose?)
  (case-variant Option ((Option #:none))
    (#:none () #f)
    (#:some (arg) arg))
  #f
  (case-variant Option ((Option #:some) 5)
    (#:none () #f)
    (#:some (arg) arg))
  5
  (case-variant Option ((Option #:some) #f)
    (#:none () #f)
    (#:some (arg) arg))
  #f
  ((Option #:?) ((Option #:none)))
  #t
  ((Option #:?) ((Option #:some) 5))
  #t
  (qux ((Option #:some) 5))
  5
)
(options? #t)

(define-algebraic-type Slist
  (#:null)
  (#:cons (front (Sexpr #:?))
          (rest  (Slist #:?))))

(define-algebraic-type Sexpr
  (#:sym  (data symbol?))
  (#:list (data (Slist #:?))))

(define Slist-in
  (letrec (
    (in-sx (lambda (sx)
             (if (symbol? sx)
               ((Sexpr #:sym) sx)
               ((Sexpr #:list)
                (in-sl sx)))))
    (in-sl (lambda (sl)
             (cond
               ((null? sl)
                ((Slist #:null)))
               ((symbol? sl)
                ((Sexpr #:sym) sl))
               (else
                 ((Slist #:cons)
                  (in-sx (car sl))
                  (in-sl (cdr sl)))))))
    )
    in-sl))

(define (Slist-out ss)
  (letrec (
    (out-sx (lambda (sx)
              (case-variant Sexpr sx
                (#:sym (data)
                 data)
                (#:list (data)
                 (out-sl data)))))
    (out-sl (lambda (sl)
              (case-variant Slist sl
                (#:null ()
                 '())
                (#:cons (front rest)
                  (cons (out-sx front)
                        (out-sl rest))))))
    )
    (if ((Sexpr #:?) ss)
      (out-sx ss)
      (out-sl ss))))

(define (Slist-subst new old ss)
  (letrec (
    (subst-sx (lambda (sx)
                (case-variant Sexpr sx
                  (#:sym (data)
                   (if (eq? data old)
                     ((Sexpr #:sym) new)
                     ((Sexpr #:sym) data)))
                     ;sx))
                  (#:list (data) ;else
                    ((Sexpr #:list) 
                     (subst-sl data))))))
    (subst-sl (lambda (sl)
                (case-variant Slist sl
                  (#:null ()
                    ((Slist #:null)))
                   (#:cons (front rest)
                    ((Slist #:cons)
                      (subst-sx front)
                      (subst-sl rest))))))
    )
    (if ((Sexpr #:?) ss)
      (subst-sx ss)
      (subst-sl ss))))

(define sl (Slist-in '()))
(define sx (Slist-in 'old))
(define sxl (Slist-in '(old)))
(define sxx (Slist-in '(())))
(define sll (Slist-in '((old c) (old () d))))
(define xxx (Slist-in '(old ((old) ((old x)) y))))

(define-checks (slists? verbose?)
  ((Slist #:?) sl)
  #t
  ((Slist #:?) (Slist-subst 'new 'old sl))
  #t
  ((Sexpr #:?) sx)
  #t
  ((Sexpr #:?) (Slist-subst 'new 'old sx))
  #t
  ((Slist #:?) sxl)
  #t
  ((Slist #:?) (Slist-subst 'new 'old sxl))
  #t
  ((Slist #:?) sxx)
  #t
  ((Slist #:?) (Slist-subst 'new 'old sxx))
  #t
  ((Slist #:?) sll)
  #t
  ((Slist #:?) (Slist-subst 'new 'old sll))
  #t
  ((Slist #:?) xxx)
  #t
  ((Slist #:?) (Slist-subst 'new 'old xxx))
  #t
  (Slist-out sl)
  '()
  (Slist-out (Slist-subst 'new 'old sl))
  '()
  (Slist-out sx)
  'old
  (Slist-out (Slist-subst 'new 'old sx))
  'new
  (Slist-out sxl)
  '(old)
  (Slist-out (Slist-subst 'new 'old sxl))
  '(new)
  (Slist-out sxx)
  '(())
  (Slist-out (Slist-subst 'new 'old sxx))
  '(())
  (Slist-out sll)
  '((old c) (old () d))                       
  (Slist-out (Slist-subst 'new 'old sll))
  '((new c) (new () d))
  (Slist-out xxx)
  '(old ((old) ((old x)) y))
  (Slist-out (Slist-subst 'new 'old xxx))
  '(new ((new) ((new x)) y))
  )
(slists? #t)

(define-algebraic-type Single
  (#:maker (x number?))
  )

(define sgl ((Single #:maker) 1))

(define-algebraic-type Couple Single
  (#:maker (parent (Single #:?)) (y number?))
  )

(define cpl ((Couple #:maker)
             ((Single #:maker) 1)
             2))

(define-algebraic-type Triple Couple
  (#:maker (parent (Couple #:?)) (z number?))
  )

(define trp ((Triple #:maker)
             ((Couple #:maker)
              ((Single #:maker) 1)
              2)
             3))

(define-checks (tuples? verbose?)
  ((Triple #:?) trp)
  #t
  ((Couple #:?) trp)
  #f
  ((Single #:?) trp)
  #f
  ((Couple #:?) sgl)
  #t
  ((Triple #:?) sgl)
  #t
  ((Triple #:?) cpl)
  #t
  (let* ((cpl ;(case-variant Triple trp
              (Triple-case trp
                (#:maker (parent z) parent)))
         (sgl ;(case-variant Couple cpl
              (Couple-case cpl
                (#:maker (parent y) parent))))
    ;(case-variant Single sgl
    (Single-case sgl
      (#:maker (x) x)))
  1
  (let ((cpl ;(case-variant Triple trp
             (Triple-case trp
               (#:maker (parent z) parent))))
    ;(case-variant Couple cpl
    (Couple-case cpl
      (#:maker (parent y) y)))
  2
  ;(case-variant Triple trp
  (Triple-case trp
    (#:maker (parent z) z))
  3
  )
(tuples? #t)

(define (0<= x) (and (number? x) (not (negative? x))))
(define-abstract-type List
  (#:null)
  (#:cons (first number?) (rest (List #:?)))
  (with
    ((#:maker args number?)
     (let loop ((args args))
       (if (null? args)
         ((List #:null))
         ((List #:cons) (car args)
                        (loop (cdr args))))))
    ((#:null? (xs (List #:?)))
     (case-variant List xs
       (#:null () #t)
       (else #f)))
    ((#:ref (xs (List #:?))
            (k 0<=))
     (let loop ((xs xs) (k k))
       (case-variant List xs
         (#:null () (error '(List #:ref)))
         (#:cons (a as) (if (zero? k)
                          a
                          (loop as (- k 1)))))))
    ((#:tail (xs (List #:?))
             (k 0<=))
     (let loop ((xs xs) (k k))
       (case-variant List xs
         (#:null () xs)
         (#:cons (a as) (if (zero? k)
                          xs
                          (loop as (- k 1)))))))
    ))

(define as0123 ((List #:maker) 0 1 2 3)) 

(define-checks (abstract-lists? verbose?)
  ((List #:?) as0123)
  #t
  ((List #:?) '(a b c))
  #f
  ((List #:null?) as0123)
  #f
  ((List #:null?) ((List #:maker)))
  #t
  ((List #:ref) as0123 2)
  2
  ((List #:ref) ((List #:tail) as0123 2) 0)
  2
  ((List #:null?) ((List #:tail) as0123 4))
  #t
  (condition-case ((List #:ref) as0123 5)
    ((exn) #f))
  #f
  )
(abstract-lists? #t)

(define-abstract-type Point
  (#:maker (x (cell-of? number?)) (y (cell-of? number?))) ; hidden
  (with
    ((#:make (x (cell-of? number?)) (y (cell-of? number?))) ; exported
     ((Point #:maker) x y))
    ((#:x (pt (Point #:?)))
     ;(case-variant Point pt
     (Point-case pt
       (#:maker (x y) (x))))
    ((#:x! (pt (Point #:?)) (arg number?))
     ;(case-variant Point pt
     (Point-case pt
       (#:maker (x y) (x arg))))
    ((#:y (pt (Point #:?)))
     ;(case-variant Point pt
     (Point-case pt
       (#:maker (x y) (y))))
    ((#:y! (pt (Point #:?)) (arg number?))
     ;(case-variant Point pt
     (Point-case pt
       (#:maker (x y) (y arg))))
    ))

(define pt ((Point #:make) (cell 1) (cell 2)))

(define-checks (mutable-points? verbose?)
  (condition-case ((Point #:maker) 10 20)
    ((exn) #f))
  #f
  ((Point #:x) pt)
  1
  ((Point #:x!) pt 10)
  1 ; old value
  ((Point #:x) pt)
  10
  ((Point #:y) pt)
  2
  ((Point #:y!) pt 20)
  2 ; old value
  ((Point #:y) pt)
  20
  ((Point #:?) pt)
  #t
  ((Point #:?) 5)
  #f
  )
(mutable-points? #t)


(check-all DATATYPES)
  (messages?)
  (vargs?)
  (options?)
  (slists?)
  (tuples?)
  (abstract-lists?)
  (mutable-points?)
  )