(module unit-syntax mzscheme
  (require syntax/stx)
  (require-for-template "unit-keywords.ss")
  
  (provide (all-defined))
  
  (define error-syntax (make-parameter #f))
  (define raise-stx-err
    (case-lambda
     ((msg) (raise-syntax-error #f msg (error-syntax)))
     ((msg stx) (raise-syntax-error #f msg (error-syntax) stx))))

  ;; check-id: syntax-object -> identifier
  (define (check-id id)
    (unless (identifier? id)
      (raise-stx-err "not an identifier" id))
    id)
  
  ;; checked-syntax->list : syntax-object -> (listof syntax-object)
  (define (checked-syntax->list s)
    (define l (syntax->list s))
    (unless (or (stx-pair? s) (stx-null? s))
      (raise-stx-err "bad syntax (not a list)" s))
    (unless l
      (raise-stx-err "bad syntax (illegal use of `.')" s))
    l)

  ;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X)
  (define (check-tagged check)
    (λ (o)
      (syntax-case o (tag)
        ((tag . s)
         (syntax-case #'s ()
           ((sym spec) 
            (begin
              (unless (symbol? (syntax-e #'sym))
                (raise-stx-err "tag must be a symbol" #'sym))
              (cons (syntax-e #'sym) (check #'spec))))
           (_ (raise-stx-err "expected (tag <identifier> <syntax>)" #'s))))
        (_ 
         (cons #f (check o))))))

  ;; check-tagged-:-clause : syntax-object -> (cons identifier identifier)
  ;; ensures that clause matches (a : b) or (a : (tag t b))
  (define (check-tagged-:-clause clause)
    (checked-syntax->list clause)
    (syntax-case* clause (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
      ((a : b)
       (identifier? #'a)
       (let ([p ((check-tagged check-id) #'b)])
         (cons (car p) (cons #'a (cdr p)))))
      (_ (raise-stx-err
          "expected syntax matching (<identifier> : <identifier>) or (<identifier> : (tag <identifier> <identifier>))"
          clause))))
  
  (define check-tagged-id (check-tagged check-id))

  ;; check-spec-syntax : syntax-object boolean (syntax-object -> boolean) ->
  ;; ensures that s matches spec.
  ;; tag-spec ::= spec
  ;;            | (tag symbol spec)
  ;; spec ::= prim-spec
  ;;        | (prefix identifier spec)
  ;;        | (rename spec (identifier identifier) ...)
  ;;        | (only spec identifier ...)                 only if import? is true
  ;;        | (except spec identifier ...)               only if import? is true
  (define (check-tagged-spec-syntax s import? prim-spec?)
    ((check-tagged (λ (s) (check-spec-syntax s import? prim-spec?))) s))
          
  (define (check-spec-syntax s import? prim-spec?)
    (unless (prim-spec? s)
      (let ((ie (if import? 'import 'export)))
        (unless (stx-pair? s)
          (raise-stx-err (format "bad ~a spec" ie) s))
        (checked-syntax->list s)
        (syntax-case s (prefix rename)
          ((key . x)
           (or (module-identifier=? #'key #'only)
               (module-identifier=? #'key #'except))
           (begin
             (unless import?
               (raise-stx-err 
                "bad export-spec keyword"
                #'key))
             (syntax-case #'x ()
               (()
                (raise-stx-err (format "missing ~a-spec argument" ie)
                               s))
               ((s y ...)
                (begin
                  (for-each check-id (syntax->list #'(y ...)))
                  (check-spec-syntax #'s import? prim-spec?))))))
          ((prefix)
           (raise-stx-err (format "missing prefix identifier and ~a spec" ie)
                          s))
          ((prefix x)
           (begin
             (check-id #'x)
             (raise-stx-err (format "missing ~a spec" ie) s)))
          ((prefix x y)
           (begin
             (check-id #'x)
             (check-spec-syntax #'y import? prim-spec?)))
          ((prefix . _)
           (raise-stx-err "too many arguments" s))
          ((rename)
           (raise-stx-err (format "missing ~a spec" ie) s))
          ((rename sub-s clause ...)
           (begin
             (for-each
              (lambda (c)
                (syntax-case c ()
                  ((a b) 
                   (begin
                     (check-id #'a)
                     (check-id #'b)))
                  ((a . b)
                   (begin
                     (checked-syntax->list c)
                     (raise-stx-err "bad rename clause" c)))
                  (_
                   (raise-stx-err "bad rename clause" c))))
              (syntax->list #'(clause ...)))
             (check-spec-syntax #'sub-s import? prim-spec?)))
          ((k . x)
           (raise-stx-err (format "bad ~a-spec keyword" ie) #'k))))))
  
  ;; check-unit-syntax : syntax-object -> syntax-object
  ;; ensures that stx matches ((import i ...) (export e ...) b ...)
  ;; or ((import i ...) (export e ...) (init-depend id ...) b ...)
  ;; and returns syntax that matches the latter
  (define (check-unit-syntax stx)
    (syntax-case stx (import export init-depend)
      (((import . isig) (export . esig) (init-depend . id) . body)
       (begin
         (checked-syntax->list (stx-car stx))
         (checked-syntax->list (stx-car (stx-cdr stx)))
         (checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
         (checked-syntax->list #'body)
         stx))
      (((import . isig) (export . esig) . body)
       (begin
         (checked-syntax->list (stx-car stx))
         (checked-syntax->list (stx-car (stx-cdr stx)))
         (checked-syntax->list #'body)
         (syntax/loc stx
           ((import . isig) (export . esig) (init-depend) . body))))
      (()
       (raise-stx-err "missing import and export clauses"))
      (((import . isig))
       (raise-stx-err "missing export clause"))
      (((import . isig) e . rest)
       (raise-stx-err "export clause must start with keyword \"export\"" #'e))
      ((i . rest)
       (raise-stx-err "import clause must start with keyword \"import\"" #'i))))
                     
  
  ;; check-unit-body-syntax : syntax-object -> syntax-object
  ;; ensures that stx matches (exp (import i ...) (export e ...))
  ;; or (exp (import i ...) (export e ...) (init-depend id ...))
  ;; and returns syntax that matches the latter
  (define (check-unit-body-syntax stx)
    (checked-syntax->list stx)
    (syntax-case stx (import export init-depend)
      ((exp (import . isig) (export . esig) (init-depend . id))
       (begin
         (checked-syntax->list (stx-car (stx-cdr stx)))
         (checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
         (checked-syntax->list (stx-car (stx-cdr (stx-cdr (stx-cdr stx)))))
         stx))
      ((exp (import . isig) (export . esig))
       (begin
         (checked-syntax->list (stx-car (stx-cdr stx)))
         (checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
         (syntax/loc stx
           (exp (import . isig) (export . esig) (init-depend)))))
      (()
       (raise-stx-err "missing expression, import and export clauses"))
      ((exp)
       (raise-stx-err "missing import and export clauses"))
      ((exp (import . isig))
       (raise-stx-err "missing export clause"))
      ((exp i e id extra . rest)
       (raise-stx-err "too many clauses" stx))
      ((exp (import . isig) (export . esig) id)
       (raise-stx-err "init-depend clause must start with keyword \"init-depend\"" #'id))
      ((exp (import . isig) e . rest)
       (raise-stx-err "export clause must start with keyword \"export\"" #'e))
      ((exp i . rest)
       (raise-stx-err "import clause must start with keyword \"import\"" #'i))))
                     
  
  
  
  ;; check-link-line-syntax : syntax-object -> 
  ;; ensures that l matches ((x ...) u y ...)
  (define (check-link-line-syntax l)
    (unless (stx-pair? l)
      (raise-stx-err "bad linking line" l))
    (checked-syntax->list l)
    (syntax-case l ()
      (((x ...) u y ...) (void))
      (((x ...))
       (raise-stx-err "missing unit expression" l))
      ((x . y)
       (begin
         (unless (stx-pair? #'x)
           (raise-stx-err "bad export list" #'x))
         (checked-syntax->list #'x)))))
           
  ;; check-compound-syntax : syntax-object -> syntax-object
  ;; ensures that clauses has exactly one clause matching each of
  ;; (import i ...), (export e ...), and (link i ...), in any order.
  ;; returns #'((i ...) (e ...) (l ...))
  (define (check-compound-syntax c)
    (define clauses (checked-syntax->list c))
    (define im #f)
    (define ex #f)
    (define li #f)
    (for-each
     (lambda (clause)
       (syntax-case clause (import export link)
         ((import i ...)
          (begin
            (when im
              (raise-stx-err "multiple import clauses" clause))
            (set! im (syntax->list #'(i ...)))))
         ((export e ...)
          (begin
            (when ex
              (raise-stx-err "multiple export clauses" clause))
            (set! ex (syntax->list #'(e ...)))))
         ((link l ...)
          (begin
            (when li
              (raise-stx-err "duplicate link clauses" clause))
            (set! li (syntax->list #'(l ...)))))
         ((x . y)
          (begin
            (checked-syntax->list clause)
            (raise-stx-err "bad compound-unit clause keyword" #'x)))
         (_
          (raise-stx-err "expected import, export, or link clause" clause))))
     clauses)
    (unless im
      (raise-stx-err "missing import clause"))
    (unless ex
      (raise-stx-err "missing export clause"))
    (unless li
      (raise-stx-err "missing link clause" ))
    #`(#,im #,ex #,li))

  ;; check-def-syntax : syntax-object ->
  ;; d must be a syntax-pair
  ;; ensures that d matches (_ (x ...) e)
  (define (check-def-syntax d)
    (unless (syntax->list d)
      (raise-syntax-error
       #f
       "bad syntax (illegal use of `.')"
       d))
    (syntax-case d ()
      ((_ params expr)
       (let ((l (syntax->list #'params)))
         (unless l
           (raise-syntax-error
            #f
            "bad variable list"
            d #'params))
         (for-each
          (lambda (x)
            (unless (identifier? x)
              (raise-syntax-error
               #f
               "not an identifier"
               d x)))
          l)))
      (_
       (raise-syntax-error
        #f
        (format "bad syntax (has ~a parts after keyword)"
                (sub1 (length (syntax->list d))))
        d))))
  )

;(load "test-unit-syntax.ss")