;; 
;; %%HEADER%%
;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DSL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module chickumber
( *step-definitions* add-step Given When Then step-id step-code step-regex
  step-regex-string step-source reset-step-id-generator current-steps-file
  $ reset-state! Before After add-hook apply-hooks hooks-clear! find-step
  pending current-exit-continuation
  
  )

(import chicken scheme regex-literals regex irregex extras)
(require-library regex-literals defstruct srfi-69 srfi-1)
(import defstruct regex-literals)
(import (only srfi-69 hash-table-set! hash-table-ref/default hash-table-clear! make-hash-table))
(import (only srfi-1 filter))

(define current-steps-file (make-parameter #f))
(define *step-definitions* '())
(define current-exit-continuation (make-parameter  values))

(define-values (next-step-id reset-step-id-generator)
  (let ((step-id 1))
    (values
     (lambda ()
       (let ((current-id step-id))
         (set! step-id (+ 1 step-id))
         current-id))
     (lambda ()
       (set! step-id 1)))))

(defstruct step id regex regex-string code source)

(define (add-step rx quoted-rx code)
  (set! *step-definitions*
    (cons (make-step id: (next-step-id) regex-string: (cadr quoted-rx) regex: rx code: code source: (current-steps-file)) *step-definitions*)))

(define (find-step id)
  (let ((result (filter (lambda (step)  (= (step-id step) id)) *step-definitions*)))
    (if (null? result) #f (car result))))

(define-syntax Given
  (syntax-rules ()
    ((_ rx (argument ...) code more-code ...)
     (add-step rx (quote rx) (lambda (argument ...) code more-code ...)))
    ((_ rx code more-code ...)
     (add-step rx (quote rx) (lambda () code more-code ...)))))

(define-syntax When
  (syntax-rules ()
    ((_ arguments ...)
     (Given arguments ...))))

(define-syntax Then
  (syntax-rules ()
    ((_ arguments  ...)
     (Given arguments ...))))

(define (pending #!optional (message #f))
  (let ((return (current-exit-continuation)))
    (return message)))

(define *before-hooks* (list))
(define *after-hooks* (list))

(define (add-hook where-to code)
  (case where-to
    ((before) (set! *before-hooks* (cons code *before-hooks*)))
    ((after)  (set! *after-hooks* (cons code *after-hooks*)))
    (else (error "Invalid hook-queue " where-to))))

(define (apply-hooks which)
  (define (apply-hooks-in queue)
    (for-each (cut apply <> (list)) queue))
  (case which
    ((before) (apply-hooks-in *before-hooks*))
    ((after)  (apply-hooks-in *after-hooks*))
    (else (error "Invalid hook-queue " which))))

(define (hooks-clear!)
  (set! *before-hooks* '())
  (set! *after-hooks* '()))

(define-syntax Before
  (syntax-rules ()
    ((_ (tag ...) code more-code ...)
     (add-hook 'before (lambda () code more-code ...)))))

(define-syntax After
  (syntax-rules ()
    ((_ (tag ...) code more-code ...)
     (add-hook 'after (lambda () code more-code ...)))))

;; State
;; The hooks to actually only make sense if we're able to maintain
;; state between steps
(define *variables* (make-hash-table))

(define ($ variable #!key (default #f))
  (hash-table-ref/default *variables* variable default))

(define (reset-state!)
  (hash-table-clear! *variables*))

(define (set-variable! key value)
  (hash-table-set! *variables* key value))

(set! (setter $) set-variable!))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Server
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;