(import scheme)
(import (chicken base))
(import (chicken condition))
(import (chicken file))
(import (chicken format))
(import (chicken io))
(import (chicken irregex))
(import (chicken pathname))
(import (chicken platform))
(import (chicken process-context))
(import (chicken string))
(import (srfi 1))
(import (srfi 69))
(import getopt-long)
(import utf8)

(define (fill-keymap sexps)
  (let ((keymap (make-hash-table eqv? eqv?-hash)))
    (for-each
     (lambda (sexp)
       (hash-table-set! keymap (car sexp) (cdr sexp)))
     sexps)
    keymap))

(define (built-in-path name)
  (make-pathname (chicken-home) (make-pathname "duckyscript" name)))

(define built-in-layout-directory (built-in-path "layouts"))
(define built-in-templates-directory (built-in-path "templates"))

(define built-in-key-codes-file (built-in-path "usb-hid-keys"))
(define built-in-key-aliases-file (built-in-path "key-aliases"))
(define built-in-modifier-aliases-file (built-in-path "modifier-aliases"))

(define (built-in-layouts) (directory built-in-layout-directory))
(define (built-in-templates) (directory built-in-templates-directory))

(define (try-read-file path reader)
  (condition-case
   (call-with-input-file path reader)
   (e (exn i/o file) #f)))

(define (try-read-layout name-or-path)
  (or (try-read-file (make-pathname built-in-layout-directory name-or-path)
                     read-list)
      (try-read-file name-or-path read-list)
      (abort
       (condition '(exn location try-read-layout message "Layout not found")
                  '(i/o)
                  '(file)))))

(define (try-read-template name-or-path)
  (or (try-read-file (make-pathname built-in-templates-directory name-or-path)
                     read-list)
      (try-read-file name-or-path read-list)
      (abort
       (condition '(exn location try-read-template message "Template not found")
                  '(i/o)
                  '(file)))))

(define (list->hash-table list #!rest args)
  (let ((hash-table (apply make-hash-table args)))
    (for-each
     (lambda (binding)
       (hash-table-set! hash-table (car list) (cadr list)))
     list)
    hash-table))

(define (built-in-key-file name) (list->hash-table (call-with-input-file name)))
(define modifier-aliases (built-in-key-file built-in-modifier-aliases-file))
(define key-aliases (built-in-key-file built-in-key-aliases-file))
(define key-codes (built-in-key-file built-in-key-codes-file))

(define (dump-keys)
  (for-each
   (lambda (label hash-table)
     (print label)
     (hash-table-for-each
      hash-table
      (lambda (key alias)
        (printf " ~a (~a)\n" key alias))))
   (list "Modifiers:" "Key aliases:" "Key codes:")
   (list modifier-aliases key-aliases key-codes)))

(define dashed-shortcut-irx
  '(: bol (or "CTRL-ALT" "CTRL-SHIFT"
              "ALT-SHIFT" "ALT-TAB"
              "COMMAND-OPTION")))

(define (replace-dashed-shortcuts line)
  (irregex-replace dashed-shortcut-irx line
                   (lambda (match)
                     (let ((dashed-modifier (irregex-match-substring match)))
                       (string-translate dashed-modifier "-" " ")))))

(define (irregex-split-once irx string)
  (let ((match (irregex-search irx string)))
    (if match
        (list (substring string 0 (irregex-match-start-index match))
              (substring string (irregex-match-end-index match)))
        (list string))))

(define (tokenize-duckyscript input)
  (define blank "[\t ]+")
  (define newline "\r?\n")
  (let ((lines (remove (lambda (line)
                         (or (irregex-match blank line)
                             (irregex-search "^(//|REM)" line)))
                       (irregex-split newline input))))
    (filter-map (lambda (line)
                  (let* ((line (replace-dashed-shortcuts line))
                         (command+args (irregex-split-once blank line))
                         (command (car command+args))
                         (args (cdr command+args)))
                    (case (string->symbol command)
                      ((STRING) command+args)
                      ((STRING_DELAY)
                       (if (null? args)
                           (list command)
                           (cons command (irregex-split-once blank (car args)))))
                      (else
                       (if (null? args)
                           (list command)
                           (cons command (string-split (car args))))))))
                lines)))

(define (parse-duckyscript input)
  (define modifiers
    '("WINDOWS" "GUI" "SHIFT" "ALT" "CONTROL" "CTRL" "COMMAND" "OPTION"))
  (define key-irx '(: upper (+ (or upper numeric #\_))))
  (define key-or-letter-irx `(or (or lower upper numeric) ,key-irx))
  (define (check-args caller args . converters)
    (when (not (= (length args) (length converters)))
      (error "unexpected number of arguments"
             caller (length args) (length converters)))
    (map (lambda (arg converter)
           (or (converter arg) (error "invalid argument" arg)))
         args converters))
  (map
   (lambda (line)
     (let ((command (car line))
           (args (cdr line)))
       (case (string->symbol command)
         ((DEFAULTDELAY DEFAULT_DELAY)
          `(default-delay ,@(check-args 'default-delay args string->number)))
         ((DELAY)
          `(delay ,@(check-args 'delay args string->number)))
         ((STRING_DELAY)
          `(string-delay ,@(check-args 'string-delay args string->number identity)))
         ((STRING)
          `(string ,@(check-args 'string args identity)))
         ((REPEAT)
          `(repeat ,@(check-args 'repeat args string->number)))
         ((WINDOWS GUI SHIFT ALT CONTROL CTRL COMMAND OPTION)
          (receive (mods keys)
              (span (lambda (arg) (member arg modifiers)) line)
            (when (> (length keys) 1)
              (error "trailing keys after modifiers" mods keys))
            (if (null? keys)
                `(shortcut ,(drop-right mods 1) ,(last mods))
                (let ((key (car keys)))
                  (when (not (irregex-match key-or-letter-irx key))
                    (error "invalid key" key))
                  `(shortcut ,mods ,key)))))
         (else ; all-caps key
          (when (not (null? args))
            (error "trailing keys" args))
          (when (not (irregex-match key-irx command))
            (error "expected key" command))
          `(shortcut () ,command)))))
   (tokenize-duckyscript input)))

(define (compile commands keymap)
  (define stack (list))
  (define (compile-delay delay)
    (let loop ((delay delay))
      (cond
       ((> delay 255)
        (set! stack (append '("255" "0") stack))
        (loop (- delay 255)))
       ((> delay 0) ; skip delay of 0
        (set! stack (append (list (number->string delay) "0") stack))))))
  (define (compile-char char)
    (let ((bindings (hash-table-ref/default keymap char #f)))
      (when (not bindings)
        (error (format "Unknown char: ~s (~a)" char (char->integer char))))
      (let loop ((bindings bindings))
        (when (pair? bindings)
          (let* ((binding (car bindings))
                 (key (if (pair? binding) (car binding) binding))
                 (modifiers (if (pair? binding) (cdr binding) '("0"))))
            (set! stack (cons key stack))
            (set! stack (cons (string-intersperse modifiers "|") stack))
            (loop (cdr bindings)))))))
  (define (key-or-alias key hash-table)
    (format "KEY_~a"
            (if (= (string-length key) 1)
                (list->string (map char-upcase (string->list key)))
                (hash-table-ref/default hash-table key key))))
  (define (lookup key-name)
    (or (hash-table-ref/default key-codes key-name #f)
        (error "unknown key name" key-name)))
  (define (compile-shortcut modifiers key-or-char)
    (let ((key (lookup (key-or-alias key-or-char key-aliases))))
      (set! stack (cons key stack)))
    (let* ((modifiers (map (lambda (key) (lookup (key-or-alias key modifier-aliases)))
                           modifiers))
           (modifiers (if (pair? modifiers) modifiers '("0"))))
      (set! stack (cons (string-intersperse modifiers "|") stack))))
  (let loop ((default-delay 0)
             (last-command #f)
             (commands commands))
    (if (pair? commands)
        (let* ((command (car commands))
               (type (car command))
               (args (cdr command)))
          (case type
            ((comment)
             (loop default-delay last-command (cdr commands)))
            ((default-delay)
             (loop (car args) last-command (cdr commands)))
            ((delay)
             (compile-delay (car args))
             (loop default-delay command (cdr commands)))
            ((string)
             (for-each compile-char (string->list (car args)))
             (compile-delay default-delay)
             (loop default-delay command (cdr commands)))
            ((string-delay)
             (let ((delay (car args))
                   (string (cadr args)))
               (for-each (lambda (char)
                           (compile-char char)
                           (compile-delay delay))
                         (string->list string)))
             (compile-delay default-delay)
             (loop default-delay command (cdr commands)))
            ((repeat)
             (when (not last-command)
               (error "Last command not found"))
             (let* ((repeated (make-list (car args) last-command))
                    (commands (append repeated (cdr commands))))
               (loop default-delay last-command commands)))
            ((shortcut)
             (compile-shortcut (car args) (cadr args))
             (compile-delay default-delay)
             (loop default-delay command (cdr commands)))))
        (reverse stack))))

(define (replace-template-patterns template keys loop-count loop-delay)
  (let ((patterns `(("@key-array@" . ,(string-intersperse keys ", "))
                    ("@key-length@" . ,(length keys))
                    ("@loop-count@" . ,loop-count)
                    ("@loop-delay@" . ,loop-delay))))
    (string-translate* template patterns)))

(define (dump-code port template-name keys loop-count loop-delay)
  (let* ((template (try-read-template template-name))
         (code (replace-template-patterns template keys loop-count loop-delay)))
    (display code port)))

(define (die #!rest messages)
  (for-each
   (lambda (message)
     (display message (current-error-port))
     (newline (current-error-port)))
   messages)
  (exit 1))

(define options
  `((input
     "Input file"
     (value (required "FILE"))
     (single-char #\i))
    (output
     "Output file"
     (value (required "FILE"))
     (single-char #\o))
    (layout
     "Keyboard layout (us/de or a path to a file)"
     (value (required "FILE"))
     (single-char #\l))
    ;; TODO: option to stop translation
    ;; TODO: option to use template
    ;; TODO: option to decompile
    (loop-count
     "Amount of loop iterations to perform (default: 1, infinite: -1)"
     (value (required "COUNT")
            (transformer ,string->number)))
    (loop-delay
     "Amount of ms to wait after each loop iteration (default: 1000ms)"
     (value (required "COUNT")
            (transformer ,string->number)))
    (list-layouts
     "Lists available layouts")
    (list-templates
     "Lists available templates")
    (list-keys
     "Lists available keys")
    (help
     "Prints this help"
     (single-char #\h))))

(define usage-hint (format "Usage: ~a [options]" (program-name)))

(define (main)
  (let* ((opts (condition-case
                (getopt-long (command-line-arguments) options)
                (e (exn)
                   (die (format "Error: ~a: ~a"
                                (get-condition-property e 'exn 'message)
                                (get-condition-property e 'exn 'arguments))
                        usage-hint
                        (usage options)))))
         (input-path (alist-ref 'input opts))
         (help? (alist-ref 'help opts))
         (list-layouts? (alist-ref 'list-layouts opts))
         (list-templates? (alist-ref 'list-templates opts))
         (list-keys? (alist-ref 'list-keys opts)))
    (when help?
      (print usage-hint)
      (display (usage options))
      (exit 0))
    (when list-layouts?
      (for-each print (built-in-layouts))
      (exit 0))
    (when list-templates?
      (for-each print (built-in-templates))
      (exit 0))
    (when list-keys?
      (dump-keys))
    (let* ((input (if input-path
                      (call-with-input-file input-path
                        (lambda (in)
                          (read-string #f in)))
                      (read-string #f (current-input-port))))
           (output-path (alist-ref 'output opts))
           (keymap (fill-keymap (try-read-layout (or (alist-ref 'layout opts) "us"))))
           (code (compile (parse-duckyscript input) keymap))
           (loop-count (or (alist-ref 'loop-count opts) 1))
           (loop-delay (or (alist-ref 'loop-delay opts) 1000))
           (dumper (if (alist-ref 'compact opts) dump-compact-code dump-code)))
      (if output-path
          (call-with-output-file output-path
            (lambda (out)
              (dumper out code loop-count loop-delay)))
          (dump-code (current-output-port) code loop-count loop-delay)))))

(when (not (get-environment-variable "TEST_MODE"))
  (main))