#lang scheme/base
(require parser-tools/lex
         "deriv.ss")
(provide (all-defined-out))

(define-tokens basic-tokens
  (start                ; .
   visit                ; syntax
   resolve              ; identifier
   next                 ; .
   next-group           ; .
   enter-macro          ; syntax
   macro-pre-transform  ; syntax
   macro-post-transform ; syntax
   exit-macro           ; syntax
   enter-prim           ; syntax
   exit-prim            ; syntax
   return               ; syntax
   enter-block          ; syntaxes
   block->list          ; syntaxes
   block->letrec        ; syntax(es?)
   splice               ; syntaxes
   enter-list           ; syntaxes
   exit-list            ; syntaxes
   enter-check          ; syntax
   exit-check           ; syntax
   phase-up             ; .
   module-body          ; (list-of (cons syntax boolean))
   ...                  ; .
   EOF                  ; .
   syntax-error         ; exn
   lift-loop            ; syntax = new form (let or begin; let if for_stx)
   lift/let-loop        ; syntax = new let form
   module-lift-loop     ; syntaxes = def-lifts, in reverse order lifted (???)
   module-lift-end-loop ; syntaxes = statement-lifts ++ provide-lifts, in order lifted
   lift                 ; (cons (listof id) syntax)
   lift-statement       ; syntax
   lift-require         ; (cons syntax (cons syntax syntax))
   lift-provide         ; syntax

   enter-local          ; syntax
   local-pre            ; syntax
   local-post           ; syntax
   exit-local           ; syntax

   local-bind           ; (listof identifier)
   enter-bind           ; .
   exit-bind            ; .
   opaque               ; opaque-syntax

   variable             ; (cons identifier identifier)
   tag                  ; syntax

   rename-one           ; syntax
   rename-list          ; (list-of syntax)

   IMPOSSIBLE           ; useful for error-handling clauses that have no NoError counterpart

   top-begin            ; identifier
   top-non-begin        ; .

   local-remark         ; (listof (U string syntax))
   local-artificial-step ; (list syntax syntax syntax syntax)
   ))

(define-tokens renames-tokens
  (renames-lambda           ; (cons syntax syntax)
   renames-case-lambda      ; (cons syntax syntax)
   renames-let              ; (cons (listof syntax) syntax)
   renames-letrec-syntaxes  ; (cons (listof syntax) (cons (listof syntax) syntax))
   renames-block            ; (cons syntax syntax) ... different, contains both pre+post
   ))

;; Empty tokens
(define-tokens prim-tokens
  (prim-module prim-#%module-begin
   prim-define-syntaxes prim-define-values
   prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda
   prim-case-lambda prim-let-values prim-let*-values prim-letrec-values 
   prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop
   prim-quote prim-quote-syntax prim-require prim-require-for-syntax
   prim-require-for-template prim-provide
   prim-set!
   prim-expression
   prim-varref
   ))

;; ** Signals to tokens

(define signal-mapping
  ;; (number/#f symbol [token-constructor])
  `(;; Emitted from Scheme
    (#f  EOF)
    (#f  error                   ,token-syntax-error)
    (#f  start                   ,token-start)
    (#f  top-begin               ,token-top-begin)
    (#f  top-non-begin           ,token-top-non-begin)
    (#f  local-remark            ,token-local-remark)
    (#f  local-artificial-step   ,token-local-artificial-step)

    ;; Standard signals
    (0   visit                   ,token-visit)
    (1   resolve                 ,token-resolve)
    (2   return                  ,token-return)
    (3   next                    ,token-next)
    (4   enter-list              ,token-enter-list)
    (5   exit-list               ,token-exit-list)
    (6   enter-prim              ,token-enter-prim)
    (7   exit-prim               ,token-exit-prim)
    (8   enter-macro             ,token-enter-macro)
    (9   exit-macro              ,token-exit-macro)
    (10  enter-block             ,token-enter-block)
    (11  splice                  ,token-splice)
    (12  block->list             ,token-block->list)
    (13  next-group              ,token-next-group)
    (14  block->letrec           ,token-block->letrec)
    (16  renames-let             ,token-renames-let)
    (17  renames-lambda          ,token-renames-lambda)
    (18  renames-case-lambda     ,token-renames-case-lambda)
    (19  renames-letrec-syntaxes ,token-renames-letrec-syntaxes)
    (20  phase-up)
    (21  macro-pre-transform     ,token-macro-pre-transform)
    (22  macro-post-transform    ,token-macro-post-transform)
    (23  module-body             ,token-module-body)
    (24  renames-block           ,token-renames-block)

    (100 prim-stop)
    (101 prim-module)
    (102 prim-#%module-begin)
    (103 prim-define-syntaxes)
    (104 prim-define-values)
    (105 prim-if)
    (106 prim-wcm)
    (107 prim-begin)
    (108 prim-begin0)
    (109 prim-#%app)
    (110 prim-lambda)
    (111 prim-case-lambda)
    (112 prim-let-values)
    (113 prim-letrec-values)
    (114 prim-letrec-syntaxes+values)
    (115 prim-#%datum)
    (116 prim-#%top)
    (117 prim-quote)
    (118 prim-quote-syntax)
    (119 prim-require)
    (120 prim-require-for-syntax)
    (121 prim-require-for-template)
    (122 prim-provide)
    (123 prim-set!)
    (124 prim-let*-values)
    (125 variable                ,token-variable)
    (126 enter-check             ,token-enter-check)
    (127 exit-check              ,token-exit-check)
    (128 lift-loop               ,token-lift-loop)
    (129 lift                    ,token-lift)
    (130 enter-local             ,token-enter-local)
    (131 exit-local              ,token-exit-local)
    (132 local-pre               ,token-local-pre)
    (133 local-post              ,token-local-post)
    (134 lift-statement          ,token-lift-statement)
    (135 lift-end-loop           ,token-module-lift-end-loop)
    (136 lift/let-loop           ,token-lift/let-loop)
    (137 module-lift-loop        ,token-module-lift-loop)
    (138 prim-expression)
    (141 start                   ,token-start)
    (142 tag                     ,token-tag)
    (143 local-bind              ,token-local-bind)
    (144 enter-bind              ,token-enter-bind)
    (145 exit-bind               ,token-exit-bind)
    (146 opaque                  ,token-opaque)
    (147 rename-list             ,token-rename-list)
    (148 rename-one              ,token-rename-one)
    (149 prim-varref)
    (150 lift-require            ,token-lift-require)
    (151 lift-provide            ,token-lift-provide)
    ))

(define (signal->symbol sig)
  (if (symbol? sig)
      sig
      (cadr (assv sig signal-mapping))))

(define token-mapping (map cdr signal-mapping))

(define (tokenize sig val pos)
  (let ([p (assv sig token-mapping)])
    (cond [(not p)
           (error 'tokenize "bad signal: ~s" sig)]
          [(null? (cdr p))
           (make-position-token sig pos pos)]
          [else
           (make-position-token ((cadr p) val) pos pos)])))