#lang scheme/base

(require (for-syntax scheme)
         "ml-package.ss"
         scheme/match
         (only-in mzlib/string expr->string)
         (for-syntax "syntax-helper.ss")
         "ml-primitives.ss")

(provide (rename-out (ml-module-begin #%module-begin))
         ;(rename-out (ml-top-interaction #%top-interaction))
         Program:
         STRDECTopDec: SIGDECTopDec: FUNDECTopDec:
         DECStrDec: STRUCTUREStrDec: LOCALStrDec: EMPTYStrDec: SEQStrDec:
         StrBind:
         STRUCTStrExp: IDStrExp: COLONStrExp: SEALStrExp: APPStrExp: LETStrExp:
         VALDec: TYPEDec: DATATYPEDec: DATATYPE2Dec: ABSTYPEDec: EXCEPTIONDec: LOCALDec: OPENDec: EMPTYDec: SEQDec:
         LongStrId:
         ATExp: COLONExp: HANDLEExp: RAISEExp: FNExp:
         (rename-out (#%app APPExp:) (if IFExp:))
         SCONAtExp: PARAtExp: IDAtExp: RECORDAtExp: LETAtExp: SEQAtExp:
         DatBind:
         SigDec: SigBind:
         FunDec: FunBind:
         (all-from-out "ml-primitives.ss")
         (rename-out (list->vector vector)))

(define old-error-display (error-display-handler))

(error-display-handler
 (lambda (message exn)
   (let ((vec (struct->vector exn)))
     (old-error-display
      (if (<= (vector-length vec) 3)
          message
          (string-append message
                         " "
                         (expr->string (vector-ref vec 3))))
      exn))))

(define-for-syntax (my-syntax-local-lift-require spec stx)
  (let ((ctx (syntax-local-get-shadower
              (datum->syntax #f (gensym) #f))))
    (syntax-local-lift-require
     (syntax-local-introduce (datum->syntax ctx spec stx))
     (datum->syntax ctx (syntax-e stx) stx))))

(define-syntax (define-packages stx)
  (syntax-case stx ()
    ((_ (id export . form) ...)
     (with-syntax (((:id ...)
                    (generate-temporaries 
                     (map (lambda (id)
                            (syntax-prepend id ":"))
                          (syntax->list #'(id ...))))))
       #`(begin (define-package :id export . form) ...
                (define*-syntaxes (id ...)
                  (values (make-rename-transformer #':id) ...)))))))

(define-syntax (define-ml-exns stx)
  (syntax-case stx ()
    ((define-ml-exns . exns)
     (with-syntax (((((vids ...) vvalues datatype svalue) ...)
                    (map (lambda (exn)
                           (syntax-case ((syntax-local-value #'define-ml-exn)
                                         #`(define-ml-exn #,@exn))
                             (begin define*-values define*-syntax)
                             ((begin (define*-values vids vvalues)
                                     (define*-syntax datatype svalue))
                              #'(vids vvalues datatype svalue))))
                         (syntax->list #'exns))))
       #'(begin (define*-values (vids ... ...)
                  (let-values (((vids ...)
                                vvalues) ...)
                    (values vids ... ...)))
                (define*-syntaxes (datatype ...)
                  (values svalue ...)))))))
(define-syntax (define-ml-datatypes stx)
  (syntax-case stx ()
    ((define-ml-datatypes . exns)
     (with-syntax (((((vids ...) vvalues datatype svalue) ...)
                    (map (lambda (exn)
                           (syntax-case ((syntax-local-value #'define-ml-datatype)
                                         #`(define-ml-datatype #,@exn))
                             (begin define*-values define*-syntax)
                             ((begin (define*-values vids vvalues)
                                     (define*-syntax datatype svalue))
                              #'(vids vvalues datatype svalue))))
                         (syntax->list #'exns))))
       #'(begin (define*-values (vids ... ...)
                  (let-values (((vids ...)
                                vvalues) ...)
                    (values vids ... ...)))
                (define*-syntaxes (datatype ...)
                  (values svalue ...)))))))

(define-match-expander ml-id
  (lambda (stx)
    (syntax-case stx ()
      ((ml-id (v))
       (let ((s (syntax-local-value (syntax-append (syntax-local-introduce #'v) "-datatype")
                                    (lambda () #f))))
         (if s
             #`(? #,(cadr s))
             #'v)))
      ((ml-id (p ... v))
       (let ((s (syntax-local-value (unlong (syntax-local-introduce #`(p ... #, (syntax-append #'v "-datatype"))))
                                    (lambda () #f))))
         (if (and s
                  (= (length s) 2))
             #`(? #,(cadr s))
             (raise-syntax-error 'expand "not a ML constructor" #'v))))
      ((ml-id (p ... v) content)
       (let ((s (syntax-local-value (unlong (syntax-local-introduce #`(p ... #, (syntax-append #'v "-datatype"))))
                                    (lambda () #f))))
         (if (and s
                  (= (length s) 3))
             #`(? #,(cadr s) (app #,(caddr s) content))
             (raise-syntax-error 'expand "not a ML constructor" #'v)))))))

(define-for-syntax (get-binding stx)
  (syntax-case stx (list list-no-order vector and ml-id ___)
    ((list . pats)
     (apply append
            (map get-binding
                 (syntax->list #'pats))))
    ((list-no-order pat ... _ ___) ;the _ can only be literal _, use (... _) instead?
     (apply append
            (map get-binding
                 (syntax->list #'(pat ...)))))
    ((list-no-order . pats)
     (apply append
            (map get-binding
                 (syntax->list #'pats))))
    ((vector . pats)
     (apply append
            (map get-binding
                 (syntax->list #'pats))))
    ((and pat1 pat2)
     (append (get-binding #'pat1)
             (get-binding #'pat2)))
    ((ml-id (v))
     (let ((s (syntax-local-value (syntax-append #'v "-datatype")
                                  (lambda () #f))))
       (if s
           '()
           (list #'v))))
    ((ml-id _)
     '())
    ((ml-id _ content)
     (get-binding #'content))
    (id
     (identifier? #'id)
     (if (equal? '_ (syntax-e #'id))
         (list)
         (list #'id)))
    (_
     '())))

(define-syntax (ml-valbind stx)
  (syntax-case stx ()
    ((_ (pat exp) ...)
     (let ((l
            (map get-binding
                 (syntax->list #'(pat ...)))))
       (with-syntax ((bindings
                      (apply append l))
                     ((binding ...)
                      l))
         #'(define*-values bindings
             (let-values ((binding
                           (match exp
                             (pat (values . binding))
                             (_ (RAISEExp: Bind))))
                          ...)
               (values . bindings))))))))

(define-for-syntax (my-map f lst)
  (if (null? lst)
      (values '() '())
      (let-values (((a b)
                    (f (car lst)))
                   ((c d)
                    (my-map f (cdr lst))))
        (values (cons a c)
                (cons b d)))))
(define-for-syntax (my-append-map f lst)
  (let-values (((a b)
                (my-map f lst)))
    (values (apply append a)
            (apply append b))))

;ugly of ML, val rec binding will overwrite existing constructor
(define-for-syntax (get-rec-binding stx)
  (syntax-case stx (list list-no-order vector and ml-id ___)
    ((list . pats)
     (my-append-map get-rec-binding (syntax->list #'pats)))
    ((list-no-order pat ... _ ___) ;the _ can only be literal _, use (... _) instead?
     (my-append-map get-rec-binding (syntax->list #'(pat ...))))
    ((list-no-order . pats)
     (my-append-map get-rec-binding (syntax->list #'pats)))
    ((vector . pats)
     (my-append-map get-rec-binding (syntax->list #'pats)))
    ((and pat1 pat2)
     (let-values (((a b)
                   (get-rec-binding #'pat1))
                  ((c d)
                   (get-rec-binding #'pat2)))
       (values (append a c)
               (append b d))))
    ((ml-id (v))
     (let* ((v-datatype (syntax-append #'v "-datatype"))
            (s (syntax-local-value v-datatype (lambda () #f))))
       (values (list #'v)
               (if s (list v-datatype) '()))))
    (id
     (identifier? #'id)
     (values (if (equal? '_ (syntax-e #'id))
                 '()
                 (list #'id))
             '()))
    (_
     (values '() '()))))

(define-syntax (ml-rec-valbind stx)
  (syntax-case stx ()
    ((_ ((pat1 exp1) ...) ;none recursive part
        ((pat2 exp2) ...));recursive part
     (let-values (((l2 ow)
                   (my-map get-rec-binding
                           (syntax->list #'(pat2 ...))))
                  ((l1)
                   (map get-binding
                        (syntax->list #'(pat1 ...)))))
       (let ((rl1
              (map generate-temporaries l1)))
         (with-syntax ((all-binding
                        (apply append (append l1 l2)))
                       ((overwrite ...)
                        (apply append ow))
                       ((binding1 ...)
                        l1)
                       ((binding2 ...)
                        l2)
                       ((renamed-binding1 ...)
                        rl1)
                       (renamed-bindings
                        (apply append (append rl1 l2))))
           #'(begin (define*-values all-binding
                      (let-values ((renamed-binding1
                                    (match exp1
                                      (pat1 (values . binding1))
                                      (_ (RAISEExp: Bind))))
                                   ...)
                        (define*-syntax overwrite #f) ...
                        (letrec-values ((binding2
                                         (match exp2
                                           (pat2 (values . binding2))
                                           (_ (RAISEExp: Bind))))
                                        ...)
                          (values . renamed-bindings))))
                    (define*-syntax overwrite #f) ...)))))))

(define-syntax (ml-module-begin stx)
  (syntax-case stx ()
    ((_ . p)
     (with-syntax ((page (datum->syntax #'p 'page)))
       #'(#%plain-module-begin
          (provide (except-out (all-defined-out) page))
          (define-package page #:all-defined . p)
          (open-package page))))))

#;
(define-syntax (ml-top-interaction stx)
  (syntax-case stx ()
    ((_ . p)
     (with-syntax ((page (datum->syntax #'p 'page)))
       #`(define-package page #:all-defined
           (open-package page) . p)))))

(define-for-syntax (make-module-path stx)
  (let* ((s (symbol->string (syntax-e stx)))
         (lib `(planet ,(string-append "chongkai/sml/lib/" s))))
    (if (void?
         (with-handlers ((values values))
           (namespace-require lib)))
        lib
        (string-append s ".ss"))))

(define-for-syntax (syntax-car s)
  (car (syntax->list s)))
(define-for-syntax (syntax-caddr s)
  (caddr (syntax->list s)))
(define-for-syntax (head-mem? s1 s2 s3)
  (let ((head (syntax-car s1)))
    (or (free-identifier=? head s2)
        (free-identifier=? head s3))))
(define-for-syntax (my-syntax-local-introduce s)
  (if (syntax? s)
      (syntax-local-introduce s)
      (map my-syntax-local-introduce s)))
(define-for-syntax (syntax->exp s)
  (if (list? s)
      #`(list #,@(map syntax->exp s))
      #`#'#,s))

(define-for-syntax (parse-long-string s)
  (let ((r (regexp-match "([^.]+)\\.(.+)" s)))
    (if r
        (cons (string-append (cadr r) "-struct")
              (parse-long-string (caddr r)))
        (list s))))
(define-for-syntax (parse-longid p require?)
  (let ((pp
         (map (lambda (s)
                (datum->syntax p (string->symbol s) p p p))
              (parse-long-string (symbol->string (syntax-e p))))))
    (if (or (and (not require?)
                 (null? (cdr pp)))
            (identifier-binding (car pp)))
        pp
        (cons (my-syntax-local-lift-require
               (make-module-path (car pp))
               (car pp))
              (cdr pp)))))

(define-for-syntax (syntax->number l)
  (string->number
   (symbol->string
    (syntax->datum l))))

(define-for-syntax (tuple? stx)
  (syntax-case stx (list quote)
    (((list (quote l) _) . _)
     (syntax->number #'l))
    (else
     #f)))

(define-for-syntax (subst lst n e)
  (if (zero? n)
      (cons e (cdr lst))
      (cons (car lst)
            (subst (cdr lst) (sub1 n) e))))
(define-for-syntax (to-tuple-help-help n s acc)
  (let ((l (length acc)))
    (if (>= n l)
        (append acc (make-list (sub1 (- n l)) '_) (list s))
        (subst acc l s))))
(define-for-syntax (to-tuple-help stx acc)
  (syntax-case stx (_ ___ list quote)
    (()
     acc)
    ((_ ___)
     (append acc '(_ ___)))
    (((list (quote l) p) . rst)
     (to-tuple-help #'rst (to-tuple-help-help (syntax->number #'l) #'p acc)))))
(define-for-syntax (to-tuple c stx)
  (quasisyntax/loc c
    (vector #,@(to-tuple-help stx '()))))

(define-for-syntax (to-vector c stx)
  ;assume labs are already in order
  (quasisyntax/loc c
    (vector-immutable #,@(map syntax-caddr (syntax->list stx)))))

(define-for-syntax (Begin: stx)
  (syntax-case stx ()
    ((_ p)
     #'p)
    ((_ p1 p2)
     #'(begin p1 p2))))
(define-for-syntax (Trivial: stx)
  (syntax-case stx ()
    ((_ p)
     #'p)))
(define-for-syntax (SEQ: stx)
  (syntax-case stx ()
    ((_ p1 p2)
     (syntax/loc stx
       (begin p1 p2)))))
(define-for-syntax (LOCAL: stx)
  (syntax-case stx ()
    ((LOCAL: p1 p2)
     (with-syntax ((local
                     (datum->syntax #'LOCAL: ':local-struct #f))
                   (inner
                    (datum->syntax #'LOCAL: 'inner-struct #f))
                   (local.inner
                    (datum->syntax #'LOCAL: ':local.inner-struct #f)))
       (syntax/loc stx
         (begin (define-package local (inner) ;why not define*-pakcage local?
                  p1
                  (define-package inner #:all-defined
                    p2))
                (LongStrId: local.inner))))))) ;omit an OPENDec: here
(define-for-syntax (EMPTY: stx)
  #'(define*-values () (values)))

;program = topdec; <program>
(define-syntax Program: Begin:)

;topdec = strdec <topdec>
;         sigdec <topdec>
;         fundec <topdec>
(define-syntax STRDECTopDec: Begin:)
(define-syntax SIGDECTopDec: Begin:)
(define-syntax FUNDECTopDec: Begin:)

;strdec = dec
;         structure strbind
;         local strdec1 in strdec2 end
;
;         strdec1 strdec2
(define-syntax DECStrDec: Trivial:)
(define-syntax STRUCTUREStrDec: Trivial:)
(define-syntax LOCALStrDec: LOCAL:)
(define-syntax EMPTYStrDec: EMPTY:)
(define-syntax SEQStrDec: SEQ:)

;strbind = strid = strexp <and strbind>
(define-syntax (StrBind: stx)
  (syntax-case stx ()
    ((StrBind: (Id: p1) p2)
     (syntax-case (local-expand #'p2
                                (syntax-local-context)
                                (list #'define*-package))
       (define*-package)
       ((define*-package . body)
        (syntax/loc stx
          (define-packages (p1 . body))))))
    ((StrBind: p1 p2 p3)
     (syntax-case ((syntax-local-value #'StrBind:)
                   #'(StrBind: p1 p2))
       (define-packages)
       ((define-packages pp)
        (syntax-case ((syntax-local-value #'StrBind:) #'p3) (define-packages)
          ((define-packages . rst)
           (syntax/loc stx
             (define-packages pp . rst)))))))))

;strexp = basic
;         structure id
;         transparent constraint
;         opaque constraint
;         function application
;         local dec
(define-for-syntax (Scheme-SEALStrExp: p str sig)
  (let ((str (datum->syntax p (syntax->datum str) str))
        (ssig (map (lambda (t)
                     (if (identifier? t)
                         t
                         (car t)))
                   sig))
        (reseals
         (filter pair? sig)))
    #`(define-packages
        (#,str
         #,ssig
         (open-package #,str)
         #,@(map (lambda (t) (Scheme-SEALStrExp: p (car t) (cadr t)))
                 reseals)))))

(define-syntax (STRUCTStrExp: stx)
  (syntax-case stx ()
    ((STRUCTStrExp: p)
     (syntax/loc stx
       (define*-package #:all-defined p)))))
(define-syntax (IDStrExp: stx)
  (syntax-case stx ()
    ((IDStrExp: p)
     (syntax/loc stx
       (define*-package #:all-defined p)))))
(define-syntax (COLONStrExp: stx)
  (syntax-case stx ()
    ((COLONStrExp: p _)
     #'p)))
(define-syntax (SEALStrExp: stx)
  (syntax-case stx ()
    ((SEALStrExp: p1 p2)
     (let* ((sig ((syntax-local-value #'sigexp:) #'p2))
            (ssig (map (lambda (t)
                         (if (identifier? t)
                             t
                             (car t)))
                       sig))
            (reseals
             (filter pair? sig)))
       (syntax-case (local-expand #'p1
                                  (syntax-local-context)
                                  (list #'define*-package))
         (define*-package)
         ((define*-package _ form)
          (syntax-property
           (quasisyntax/loc stx
             (define*-package #,ssig
               (begin form
                      #,@(map (lambda (t) (Scheme-SEALStrExp: #'p1 (car t) (cadr t))) reseals))))
           'certify-mode
           'transparent-binding)))))))
(define-syntax (APPStrExp: stx)
  (syntax-case stx ()
    ((APPStrExp: (Id: p1) p5)
     (with-syntax ((pp
                    (if (identifier-binding #'p1)
                        #'p1
                        (my-syntax-local-lift-require
                         (make-module-path #'p1)
                         #'p1))))
       (syntax/loc stx
         (pp p5))))))
(define-syntax (LETStrExp: stx)
  (syntax-case stx ()
    ((LETStrExp: p1 p2)
     (syntax-case (local-expand #'p2
                                (syntax-local-context)
                                (list #'define*-package))
       (define*-package)
       ((define*-package sig form)
        (quasisyntax/loc stx
          (define*-package sig
            (#,(datum->syntax #'LETStrExp: 'LOCALDec: #f) p1 form))))))))

;dec = val tyvarseq valbind
;      type
;      datatype datbind
;      datatype tycon = datatype longtycon
;      abstype datbind with dec end
;      exception exbind
;      local dec1 in dec2 end
;      open longstrid ...
;     
;      dec1 <;> dec2
;      infix
;      nonfix
(define-syntax (VALDec: stx)
  (syntax-case stx ()
    ((VALDec: _ p)
     ((syntax-local-value #'valbind:) #'p))))
(define-syntax TYPEDec: EMPTY:)
(define-syntax DATATYPEDec: Trivial:)
(define-syntax (DATATYPE2Dec: stx)
  (syntax-case stx ()
    ((DATATYPE2Dec: (_ p1) (_ p2))
     (quasisyntax/loc stx
       (define-ml-type p1
         #,(parse-longid #'p2 #f))))))
(define-syntax ABSTYPEDec: LOCAL:) ;because DATATYPEDec: is Trivial:
(define-syntax (EXCEPTIONDec: stx)
  (syntax-case stx ()
    ((EXCEPTIONDec: p)
     ((syntax-local-value #'exbind:) #'p))))
(define-syntax LOCALDec: LOCAL:)
(define-syntax (OPENDec: stx)
  (syntax-case stx ()
    ((OPENDec: . p)
     (let ((dfns (map (compose (syntax-local-value #'open*-package)
                               (syntax-local-value #'LongStrId:))
                      (syntax->list #'p))))
       (quasisyntax/loc stx
         (begin #,@dfns))))))
(define-syntax EMPTYDec: EMPTY:)
(define-syntax SEQDec: SEQ:)

;LongStrId opens the package
(define-syntax (LongStrId: stx)
  (syntax-case stx ()
    ((LongStrId: p)
     (quasisyntax/loc stx
       (open*-package
        #,(unlong (parse-longid #'p #t))
        p)))))

;todo val pat1 = exp1 and rec pat2 = exp2
;valbind = pat = exp <and valbind>
;          rec valbind
(define-syntax (valbind: stx)
  (syntax-case stx (PLAINValBind: RECValBind:)
    ((PLAINValBind: p1 p2)
     (quasisyntax/loc stx
       (ml-valbind (#,((syntax-local-value #'pat:) #'p1) p2))))
    ((PLAINValBind: p1 p2 p3)
     (syntax-case ((syntax-local-value #'valbind:) #'p3) (ml-valbind ml-rec-valbind)
       ((ml-valbind . rest)
        (quasisyntax/loc stx
          (ml-valbind (#,((syntax-local-value #'pat:) #'p1) p2) . rest)))
       ((ml-rec-valbind r1 r2)
        (quasisyntax/loc stx
          (ml-rec-valbind ((#,((syntax-local-value #'pat:) #'p1) p2) . r1) r2)))))
    ((RECValBind: p)
     (syntax-case ((syntax-local-value #'valbind:) #'p) (ml-valbind ml-rec-valbind)
       ((ml-valbind . rest)
        (syntax/loc stx
          (ml-rec-valbind () rest)))
       ((ml-rec-valbind (r1 ...) r2)
        (syntax/loc stx
          (ml-rec-valbind () (r1 ... . r2))))))))

;pat = atomic
;      constructed
;      typed
;      layered (as pat)
(define-syntax (pat: stx)
  (syntax-case stx (ATPat: CONPat: COLONPat: ASPat:)
    ((ATPat: p)
     ((syntax-local-value #'atpat:) #'p))
    ((CONPat: p1 p2)
     (syntax-case ((syntax-local-value #'longvid:) #'p1) ()
       ((ml-id t)
        (quasisyntax/loc stx
          (ml-id t #,((syntax-local-value #'atpat:) #'p2))))))
    ((COLONPat: p _)
     ((syntax-local-value #'pat:) #'p))
    ((ASPat: (_ p1) p2)
     (quasisyntax/loc stx
       (and p1
            #,((syntax-local-value #'pat:) #'p2))))))

;atpat = wildcard
;        special constant
;        value id
;        record
;        0-tuple
;        n-tuple (n>2)
;        list
;        (pat)
(define-syntax (atpat: stx)
  (syntax-case stx (WILDCARDAtPat: SCONAtPat: IDAtPat: RECORDAtPat: RECORDAtPat:)
    ((WILDCARDAtPat:)
     (syntax/loc stx _))
    ((SCONAtPat: p)
     (Trivial: #'p))
    ((IDAtPat: p)
     ((syntax-local-value #'longvid:) #'p))
    ((RECORDAtPat:)
     (quasisyntax/loc stx (? void?)))
    ((RECORDAtPat: p)
     (let ((pp
            ((syntax-local-value #'patraw:) #'p)))
       (if (tuple? pp)
           (to-tuple stx pp)
           (quasisyntax/loc stx (list-no-order #,@pp)))))
    ((PARAtPat: p)
     ((syntax-local-value #'pat:) #'p))))

;patraw = wildcat
;         lab = pat <, patraw>
(define-syntax (patraw: stx)
  (syntax-case stx (DOTSPatRow: FIELDPatRow: Lab:)
    ((DOTSPatRow:)
     (syntax/loc stx (_ ___)))
    ((FIELDPatRow: (Lab: l) p)
     (quasisyntax/loc stx
       ((list (quote l) #,((syntax-local-value #'pat:) #'p)))))
    ((FIELDPatRow: (Lab: l) p1 p2)
     (quasisyntax/loc stx
       ((list (quote l) #,((syntax-local-value #'pat:) #'p1))
        #,@((syntax-local-value #'patraw:) #'p2))))))

;longvid = vid
;          longstrid.vid
(define-syntax (longvid: stx)
  (syntax-case stx (LongVId:)
    ((LongVId: p)
     (quasisyntax/loc stx
       (ml-id #,(parse-longid #'p #f))))))

;exp = atomic
;      application
;      typed
;      handle
;      raise
;      function
(define-syntax ATExp: Trivial:)
;define-syntax APPExp: #%app
(define-syntax (COLONExp: stx)
  (syntax-case stx ()
    ((COLONExp: e _)
     #'e)))
(define-syntax (HANDLEExp: stx)
  (syntax-case stx ()
    ((HANDLEExp: p1 p2)
     (quasisyntax/loc stx
       (with-handlers (((lambda (e) #t)
                        (lambda (e)
                          (match (lambda (_) e)
                            #,@((syntax-local-value #'match:) #'p2)
                            (_ (raise e))))))
         p1)))))
(define-syntax (RAISEExp: stx)
  (syntax-case stx ()
    ((RAISEExp: p)
     (syntax/loc stx
       (raise (p (current-continuation-marks)))))))
(define-syntax (FNExp: stx)
  (syntax-case stx ()
    ((FNExp: p)
     (quasisyntax/loc stx
       (match-lambda #,@((syntax-local-value #'match:) #'p)
                     (_ (RAISEExp: Match)))))))

;atexp = scon
;        longvid
;        record
;        let dec in exp end
(define-syntax (SCONAtExp: stx)
  (syntax-case stx ()
    ((SCONAtExp: (_ p))
     #`(#%datum . p))))
(define-syntax PARAtExp: Trivial:)
(define-syntax (IDAtExp: stx)
  (syntax-case stx (LongVId:)
    ((IDAtExp: (LongVId: p))
     (unlong (parse-longid #'p #f)))))
(define-syntax (RECORDAtExp: stx)
  (syntax-case stx ()
    ((RECORDAtExp:)
     (syntax/loc stx
       (void)))
    ((RECORDAtExp: p)
     (let ((pp ((syntax-local-value #'exprow:) #'p)))
       (if (tuple? pp)
           (to-vector stx pp)
           (quasisyntax/loc stx
             (list #,@pp)))))))
(define-syntax (LETAtExp: stx)
  (syntax-case stx ()
    ((LETAtExp: p1 p2)
     (syntax/loc stx
       (package-begin
        p1
        p2)))))
(define-syntax SEQAtExp: SEQ:)

;exprow = lab = exp <,exprow>
(define-syntax (exprow: stx)
  (syntax-case stx (ExpRow: Lab:)
    ((ExpRow: (Lab: l) e)
     (syntax/loc stx
       ((list (quote l) e))))
    ((ExpRow: (Lab: l) e rest)
     (quasisyntax/loc stx
       ((list (quote l) e)
        #,@((syntax-local-value #'exprow:) #'rest))))))

;match = mrule <| match>
(define-syntax (match: stx)
  (syntax-case stx (Match:)
    ((Match: p)
     (list ((syntax-local-value #'mrule:) #'p)))
    ((Match: p1 p2)
     (cons ((syntax-local-value #'mrule:) #'p1)
           ((syntax-local-value #'match:) #'p2)))))

;mrule = pat => exp
(define-syntax (mrule: stx)
  (syntax-case stx (Mrule:)
    ((Mrule: p1 p2)
     (quasisyntax/loc stx
       (#,((syntax-local-value #'pat:) #'p1) p2)))))

;datbind = tyvarseq tycon = conbind <and datbind>
(define-syntax (DatBind: stx)
  (syntax-case stx ()
    ((DatBind: _ (_ p1) p2)
     (let-values (((pp ids)
                   ((syntax-local-value #'conbind:) #'p2)))
       (with-syntax (((types ...)
                      (map (lambda (id)
                             (syntax-append id "-datatype"))
                           ids)))
         (quasisyntax/loc stx
           (begin (define*-syntaxes (p1) (values (list #'types ...)))
                  #,pp)))))
    ((DatBind: p0 p1 p2 p3)
     (syntax-case ((syntax-local-value #'DatBind:) #'(DatBind: p0 p1 p2))
       (begin define*-syntaxes define-ml-datatypes values)
       ((begin (define*-syntaxes (pp1) (values pp2))
               (define-ml-datatypes ppp ...))
        (syntax-case ((syntax-local-value #'DatBind:) #'p3)
          (begin define*-syntaxes define-ml-datatypes values)
          ((begin (define*-syntaxes sids (values . svalues))
                  (define-ml-datatypes . datatypes))
           (syntax/loc stx
             (begin (define*-syntaxes (pp1 . sids) (values pp2 . svalues))
                    (define-ml-datatypes ppp ... . datatypes))))))))))

;conbind = <op>vid <of ty> <| conbind>
(define-syntax (conbind: stx)
  (syntax-case stx (ConBind:)
    ((ConBind: (_ p))
     (values (syntax/loc stx
               (define-ml-datatypes (p #f)))
             (list #'p)))
    ((ConBind: (_ p1) p2)
     (if (free-identifier=? (syntax-car #'p2) #'ConBind:)
         (let-values (((pp2 ids)
                       ((syntax-local-value #'conbind:) #'p2)))
           (values (syntax-case pp2 (define-ml-datatypes)
                     ((define-ml-datatypes . rest)
                      (syntax/loc stx
                        (define-ml-datatypes (p1 #f) . rest))))
                   (cons #'p1 ids)))
         (values (syntax/loc stx
                   (define-ml-datatypes (p1 #t)))
                 (list #'p1))))
    ((ConBind: (_ p1) _ p2)
     (let-values (((pp2 ids)
                   ((syntax-local-value #'conbind:) #'p2)))
       (values (syntax-case pp2 (define-ml-datatypes)
                 ((define-ml-datatypes . rest)
                  (syntax/loc stx
                    (define-ml-datatypes (p1 #t) . rest))))
               (cons #'p1 ids))))))

;exbind = <op> vid <of ty> <and exbind>
;         <op> vid = <op> longvid <and exbind>
(define-syntax (exbind: stx)
  (syntax-case stx (NEWExBind: EQUALExBind:)
    ((NEWExBind: (_ p))
     (syntax/loc stx
       (define-ml-exns (p #f))))
    ((NEWExBind: (_ p1) p2)
     (if (head-mem? #'p2 #'NEWExBind: #'EQUALExBind:)
         (syntax-case ((syntax-local-value #'exbind:) #'p2) (define-ml-exns)
           ((define-ml-exns . exns)
            (syntax/loc stx
              (define-ml-exns (p1 #f) . exns))))
         (syntax/loc stx
           (define-ml-exns (p1 #t)))))
    ((NEWExBind: (_ p1) _ p2)
     (syntax-case ((syntax-local-value #'exbind:) #'p2) (define-ml-exns)
       ((define-ml-exns . exns)
        (syntax/loc stx
          (define-ml-exns (p1 #t) . exns)))))
    ((EQUALExBind: (_ p1) (_ p2))
     (quasisyntax/loc stx
       (define-ml-exns (p1 #,(parse-longid #'p2 #f)))))
    ((EQUALExBind: (_ p1) (_ p2) p3)
     (syntax-case ((syntax-local-value #'exbind:) #'p3) (define-ml-exns)
       ((define-ml-exns . exns)
        (quasisyntax/loc stx
          (define-ml-exns (p1 #,(parse-longid #'p2 #f)) . exns)))))))

;sigexp = sig spec end
;         sigid
;         type realisation
;Scheme sigspec = ((or id (id type)) ...)
;type is only used for ML structures
(define-syntax (sigexp: stx)
  (syntax-case stx (SIGSigExp: IDSigExp: WHERETYPESigExp:)
    ((SIGSigExp: p)
     ((syntax-local-value #'spec:) #'p))
    ((IDSigExp: (_ p))
     (let ((pp (if (identifier-binding #'p)
                   #'p
                   (my-syntax-local-lift-require
                    (make-module-path #'p)
                    #'p))))
       (my-syntax-local-introduce
        (syntax-local-value pp))))
    ((WHERETYPESigExp: p . _)
     ((syntax-local-value #'sigexp:) #'p))))

;spec = val valdesc
;     = type typdesc
;     = eqtype typdesc
;     = datatype datdesc
;     = datatype tycon = datatype longtycon
;     = exception exdesc
;     = structure strdesc
;     = include sigexp
;     = empty
;     = sequential
;     = sharing
(define-syntax (spec: stx)
  (syntax-case stx (VALSpec: TYPESpec: EQTYPESpec: EMPTYSpec: DATATYPESpec: DATATYPE2Spec: EXCEPTIONSpec: STRUCTURESpec: INCLUDESpec: SEQSpec: SHARINGTYPESpec: SHARINGSpec:)
    ((VALSpec: p)
     ((syntax-local-value #'valdesc:) #'p))
    ((TYPESpec: . _)
     '())
    ((EQTYPESpec: . _)
     '())
    ((DATATYPESpec: p)
     ((syntax-local-value #'datdesc:) #'p))
    ((DATATYPE2Spec: (_ p1) (_ p2))
     (cons #'p1
           (let ((lt (parse-longid #'p2 #f)))
             (if (null? (cdr lt))
                 '()
                 (syntax-local-value (unlong lt))))))
    ((EXCEPTIONSpec: p)
     ((syntax-local-value #'condesc:) #'p))
    ((STRUCTURESpec: p)
     ((syntax-local-value #'strdesc:) #'p))
    ((INCLUDESpec: p)
     ((syntax-local-value #'sigexp:) #'p))
    ((EMPTYSpec: . _)
     '())
    ((SEQSpec: p1 p2)
     (append ((syntax-local-value #'spec:) #'p1)
             ((syntax-local-value #'spec:) #'p2)))
    ((SHARINGTYPESpec: p . _)
     ((syntax-local-value #'spec:) #'p))
    ((SHARINGSpec: p . _)
     ((syntax-local-value #'spec:) #'p))))

;valdesc = vid : ty <and valdesc>
(define-syntax (valdesc: stx)
  (syntax-case stx (ValDesc:)
    ((ValDesc: (_ p) _)
     (list #'p))
    ((ValDesc: (_ p1) _ p2)
     (cons #'p1
           ((syntax-local-value #'valdesc:) #'p2)))))

;datdesc = tyvarseq tycon = condesc <and datdesc>
(define-syntax (datdesc: stx)
  (syntax-case stx (DatDesc:)
    ((DatDesc: _ (_ p1) p2)
     (cons #'p1
           ((syntax-local-value #'condesc:) #'p2)))
    ((DatDesc: _ (_ p1) p2 p3)
     (cons #'p1
           (append ((syntax-local-value #'condesc:) #'p2)
                   ((syntax-local-value #'datdesc:) #'p3))))))

;condesc = vid <of ty> <| condesc>
;exdesc = vid <of ty> <and exdesc>
(define-syntax (condesc: stx)
  (syntax-case stx ()
    ((_ (_ p))
     (list #'p
           (syntax-append #'p "-datatype")
           (syntax-append #'p "?")))
    ((_ (_ p1) p2)
     (if (head-mem? #'p2 #'ConDesc: #'ExDesc:)
         (list* #'p1
                (syntax-append #'p1 "-datatype")
                (syntax-append #'p1 "?")
                ((syntax-local-value #'condesc:) #'p2))
         (list #'p1
               (syntax-append #'p1 "-datatype")
               (syntax-append #'p1 "?")
               (syntax-append #'p1 "-content"))))
    ((_ (_ p1) _ p2)
     (list* #'p1
            (syntax-append #'p1 "-datatype")
            (syntax-append #'p1 "?")
            (syntax-append #'p1 "-content")
            ((syntax-local-value #'condesc:) #'p2)))))

;strdesc = strid : sigexp <and strdesc>
(define-syntax (strdesc: stx)
  (syntax-case stx (StrDesc:)
    ((StrDesc: (_ p1) p2)
     (list (list #'p1
                 ((syntax-local-value #'sigexp:) #'p2))))
    ((StrDesc: (_ p1) p2 p3)
     (cons (list #'p1
                 ((syntax-local-value #'sigexp:) #'p2))
           ((syntax-local-value #'strdesc:) #'p3)))))

;sigdec = signature sigbind
(define-syntax SigDec: Trivial:)

;sigbind = sigid = sigexp <and sigbind>
(define-syntax (SigBind: stx)
  (syntax-case stx ()
    ((SigBind: (Id: p1) p2)
     (quasisyntax/loc stx
       (define*-syntaxes (p1)
         (values #,(syntax->exp ((syntax-local-value #'sigexp:) #'p2))))))
    ((SigBind: (Id: p1) p2 p3)
     (syntax-case ((syntax-local-value #'SigBind:) #'p3) (define*-syntaxes values)
       ((define*-syntaxes ids (values . vs))
        (quasisyntax/loc stx
          (define*-syntaxes (p1 . ids)
            (values #,(syntax->exp ((syntax-local-value #'sigexp:) #'p2)) . vs))))))))

;fundec = functor funbind
(define-syntax FunDec: Trivial:)

;funbind = funid ( strid : sigexp) = strexp <and funbind>
(define-syntax (FunBind: stx)
  (syntax-case stx ()
    ((FunBind: (_ p1) p2 p3 p4)
     (with-syntax ((LETStrExp: (datum->syntax #'FunBind: 'LETStrExp: #f)))
       (syntax/loc stx
         (define*-syntaxes (p1)
           (values
            (lambda (stx)
              (syntax-case stx ()
                ((_ p5)
                 (quasisyntax/loc stx
                   (#,(syntax-local-introduce #'LETStrExp:)
                    (StrBind: p2 (SEALStrExp: p5 p3))
                    p4))))))))))
    ((FunBind: p1 p2 p3 p4 p5)
     (syntax-case ((syntax-local-value #'FunBind) #'(FunBind: p1 p2 p3 p4)) (define*-syntaxes values)
       ((define*-syntaxes (id) (values v))
        (syntax-case ((syntax-local-value #'FunBind) #'p5) (define*-syntaxes values)
          ((define*-syntaxes ids (values . rst))
           (syntax/loc stx
             (define*-syntaxes (id . ids) (values v . rst))))))))))