(import scheme)
(import (chicken base))
(import (chicken irregex))
(import (chicken pretty-print))
(import comparse)

;; key = "[A-Z0-9_]+"
;; char = "[^\r\n ]"
;; string-arg = "[^\r\n]+"
;; number = "[0-9]+"
;; newline = ("\r\n" | "\n")
;; whitespace = "[\t\v ]+"
;; comment = "REM" whitespace string-arg
;; default_delay = ("DEFAULTDELAY" | "DEFAULT_DELAY") whitespace number
;; delay = "DELAY" whitespace number
;; string = "STRING" whitespace string-arg
;; mod = ("WINDOWS" | "GUI" | "MENU" | "APP" | "SHIFT" | "ALT" | "CONTROL" | "CTRL")
;; modifiers = (mod whitespace)*
;; shortcut = modifiers? (char | key)
;; repeat = "REPEAT" whitespace number
;; command = (comment | default_delay | delay | string | repeat | shortcut)

(define (parse-duckyscript input)
  (define (as-number parser)
    (bind (as-string parser)
          (lambda (s) (result (string->number s)))))
  (define (prefixed-argument prefix-parser arg-parser type)
    (sequence* ((_ prefix-parser)
                (_ whitespace)
                (arg arg-parser))
               (result (list type arg))))

  (define key (char-seq-match "[A-Z0-9_]+"))
  (define char (char-seq-match "[^\t\v ]"))
  (define string-arg (char-seq-match ".+"))
  (define digits (char-seq-match "[0-9]+"))
  (define whitespace (char-seq-match "[\t\v ]+"))
  (define comment
    (prefixed-argument (char-seq "REM") string-arg 'comment))
  (define default-delay
    (prefixed-argument (any-of (char-seq "DEFAULTDELAY")
                               (char-seq "DEFAULT_DELAY"))
                       (as-number digits)
                       'default-delay))
  (define delay
    (prefixed-argument (char-seq "DELAY") (as-number digits) 'delay))
  (define string
    (prefixed-argument (char-seq "STRING") string-arg 'string))
  (define repeat
    (prefixed-argument (char-seq "REPEAT") (as-number digits) 'repeat))
  (define modifier
    (any-of (char-seq "WINDOWS") (char-seq "GUI")
            (char-seq "MENU") (char-seq "APP")
            (char-seq "SHIFT")
            (char-seq "ALT")
            (char-seq "CONTROL") (char-seq "CTRL")))
  (define modifiers (zero-or-more (sequence* ((mod modifier)
                                              (_ whitespace))
                                             (result mod))))
  (define shortcut (sequence* ((mods modifiers)
                               (key (any-of key char)))
                              (result (list 'shortcut mods key))))
  (define command (any-of comment default-delay delay string repeat shortcut))

  (map (lambda (line)
         (parse (followed-by command end-of-input) line))
       (irregex-split "\r\n\|\n" input)))

(pp (parse-duckyscript "REM Hello Rick!
DEFAULTDELAY 30
DELAY 3000
GUI r
DELAY 200
STRING https://www.youtube.com/watch?v=dQw4w9WgXcQ
ENTER
DELAY 3000
STRING f"))

(define (parse-duckyscript input)
  (define blank '(+ ("\t\v ")))
  (define number '(+ numeric))
  (define string '(+ nonl))
  (define comment-rx `(: "REM" ,blank ($ ,string)))
  (define default-delay-rx `(: "DEFAULT" (? "_") "DELAY" ,blank ($ ,number)))
  (define delay-rx `(: "DELAY" ,blank ($ ,number)))
  (define string-rx `(: "STRING" ,blank ($ ,string)))
  (define repeat-rx `(: "REPEAT" ,blank ($ ,number)))
  (define mod '(or "WINDOWS" "GUI" "MENU" "APP" "SHIFT" "ALT" "CONTROL" "CTRL"))
  (define key '(+ (or upper numeric #\_)))
  (define char '(~ #\space))
  (define shortcut-rx `(: ($ (* (: ,mod ,blank))) ($ (or ,key ,char))))

  (define submatch irregex-match-substring)
  (define (parse line)
    (cond
     ((irregex-match comment-rx line)
      => (lambda (m) `(comment ,(submatch m 1))))
     ((irregex-match default-delay-rx line)
      => (lambda (m) `(default-delay ,(string->number (submatch m 1)))))
     ((irregex-match delay-rx line)
      => (lambda (m) `(delay ,(string->number (submatch m 1)))))
     ((irregex-match string-rx line)
      => (lambda (m) `(string ,(submatch m 1))))
     ((irregex-match repeat-rx line)
      => (lambda (m) `(repeat ,(string->number (submatch m 1)))))
     ((irregex-match shortcut-rx line)
      => (lambda (m) `(shortcut ,(irregex-split blank (submatch m 1))
                                ,(submatch m 2))))
     (else
      (error "Unrecognized line" line))))

  (map parse (irregex-split "\r\n|\n" input)))

(define (parse-duckyscript input)
  (define blank '(+ ("\t\v ")))
  (define number '(+ numeric))
  (define string '(+ nonl))
  (define comment-cmd `(: (=> cmd "REM") ,blank (=> string ,string)))
  (define default-delay-name '(: (=> cmd "DEFAULT") (? "_") "DELAY"))
  (define default-delay-cmd `(: ,default-delay-name ,blank (=> number ,number)))
  (define delay-cmd `(: (=> cmd "DELAY") ,blank (=> number ,number)))
  (define string-cmd `(: (=> cmd "STRING") ,blank (=> string ,string)))
  (define repeat-cmd `(: (=> cmd "REPEAT") ,blank (=> number ,number)))
  (define mod '(or "WINDOWS" "GUI" "MENU" "APP" "SHIFT" "ALT" "CONTROL" "CTRL"))
  (define key '(+ (or upper numeric #\_)))
  (define char '(~ #\space))
  (define shortcut-cmd `(: (=> strings (* (: ,mod (? ,blank))))
                           (=> string (? (or ,key ,char)))))

  (define command-rx `(: (or ,comment-cmd ,default-delay-cmd ,delay-cmd
                             ,string-cmd ,repeat-cmd ,shortcut-cmd)))
  (define (to-lower s) (list->string (map char-downcase (string->list s))))
  (define (non-blank-string s) (if (zero? (string-length s)) #f s))
  (define (parse line)
    (define $ irregex-match-substring)
    (let ((m (irregex-match command-rx line)))
      (if m
          (let ((command ($ m 'cmd)))
            (case (and command (string->symbol (to-lower command)))
              ((rem) `(comment ,($ m 'string)))
              ((default) `(default-delay ,(string->number ($ m 'number))))
              ((delay) `(delay ,(string->number ($ m 'number))))
              ((string) `(string ,($ m 'string)))
              ((repeat) `(repeat ,(string->number ($ m 'number))))
              (else
               `(shortcut ,(irregex-split blank ($ m 'strings))
                          ,(or (non-blank-string ($ m 'string))
                               (error "Missing key or character" line))))))
          (error "Unrecognized line" line))))

  (map parse (irregex-split "\r\n|\n" input)))

(pp (parse-duckyscript "REM Hello Rick!
DEFAULTDELAY 30
DELAY 3000
GUI r
DELAY 200
STRING https://www.youtube.com/watch?v=dQw4w9WgXcQ
ENTER
DELAY 3000

STRING f
REPEAT 3"))

;; ((comment "REM") ; why
;;  (default-delay 30)
;;  (delay 3000)
;;  (shortcut ("GUI") "r")
;;  (delay 200)
;;  (string "STRING") ; no
;;  (shortcut () "ENTER")
;;  (delay 3000)
;;  (string "STRING") ; plz
;;  (repeat 3))

(define (parse-duckyscript input)
  (define blank '(+ ("\t\v ")))
  (define number '(+ numeric))
  (define string '(+ nonl))
  (define comment-cmd `(: (=> cmd "REM") ,blank (=> comment ,string)))
  (define default-delay '((=> cmd "DEFAULT") (? "_") "DELAY"))
  (define default-delay-cmd `(: ,@default-delay ,blank (=> default-delay ,number)))
  (define delay-cmd `(: (=> cmd "DELAY") ,blank (=> delay ,number)))
  (define string-cmd `(: (=> cmd "STRING") ,blank (=> string ,string)))
  (define repeat-cmd `(: (=> cmd "REPEAT") ,blank (=> repetitions ,number)))
  (define mod '(or "WINDOWS" "GUI" "MENU" "APP" "SHIFT" "ALT" "CONTROL" "CTRL"))
  (define key '(+ (or upper numeric #\_)))
  (define char '(~ #\space))
  (define shortcut-cmd `(: (=> modifiers (* (: ,mod (? ,blank))))
                           (=> key-or-char (? (or ,key ,char)))))

  (define command-rx `(: (or ,comment-cmd ,default-delay-cmd ,delay-cmd
                             ,string-cmd ,repeat-cmd ,shortcut-cmd)))
  (define (to-lower s) (list->string (map char-downcase (string->list s))))
  (define (non-blank-string s) (if (zero? (string-length s)) #f s))
  (define (parse line)
    (define $ irregex-match-substring)
    (let ((m (irregex-match command-rx line)))
      (if m
          (let ((command ($ m 'cmd)))
            (case (and command (string->symbol (to-lower command)))
              ((rem) `(comment ,($ m 'comment)))
              ((default) `(default-delay ,(string->number ($ m 'default-delay))))
              ((delay) `(delay ,(string->number ($ m 'delay))))
              ((string) `(string ,($ m 'string)))
              ((repeat) `(repeat ,(string->number ($ m 'repetitions))))
              (else
               `(shortcut ,(irregex-split blank ($ m 'modifiers))
                          ,(or (non-blank-string ($ m 'key-or-char))
                               (error "Missing key or character" line))))))
          (error "Unrecognized line" line))))

  (map parse (irregex-split "\r\n|\n" input)))

(pp (parse-duckyscript "REM Hello Rick!
DEFAULTDELAY 30
DELAY 3000
GUI r
DELAY 200
STRING https://www.youtube.com/watch?v=dQw4w9WgXcQ
ENTER
DELAY 3000

STRING f
REPEAT 3
CTRL ALT DELETE"))

;; ((comment "Hello Rick!")
;;  (default-delay 30)
;;  (delay 3000)
;;  (shortcut ("GUI") "r")
;;  (delay 200)
;;  (string "https://www.youtube.com/watch?v=dQw4w9WgXcQ")
;;  (shortcut () "ENTER")
;;  (delay 3000)
;;  (string "f")
;;  (repeat 3)
;;  (shortcut ("CTRL" "ALT") "DELETE"))

(define (parse-duckyscript input)
  (define blank '(+ ("\t\v ")))
  (define number '(+ numeric))
  (define string '(+ nonl))
  (define mod '(or "WINDOWS" "GUI" "SHIFT" "ALT" "CONTROL" "CTRL"
                   "COMMAND" "OPTION"))
  (define key '(+ (or upper numeric #\_)))
  (define char '(~ #\space))

  (define comment-cmd `(: bol (or "REM" "//")))
  (define default-delay-cmd `(: bol "DEFAULT" (? "_") "DELAY" ,blank))
  (define delay-cmd `(: bol "DELAY" ,blank))
  (define string-cmd `(: bol "STRING" ,blank))
  (define string-delay-cmd `(: bol "STRING_DELAY" ,blank))
  (define repeat-cmd `(: bol "REPEAT" ,blank))
  (define shortcut-cmd `(: ($ (* (: ,mod (? ,blank)))) ($ (or ,key ,char))))
  (define optional-string-arg `(: (? ,blank) ($ (? ,string))))
  (define number-arg `($ ,number))
  (define string-arg `($ ,string))
  (define number-string-arg `(: ($ ,number) ,blank ($ ,string)))

  (define dashed-modifier `(: bol ,mod "-" ,key (* (: "-" ,key))))
  (define (preprocess line)
    (if (irregex-search dashed-modifier line)
        (string-translate line "-" " ")
        line))

  (define (command-match line type-rx args-rx)
    (and-let* (((irregex-search type-rx line))
               (rest (irregex-replace type-rx line "")))
      (or (irregex-match args-rx rest)
          (error "Invalid arguments" line))))

  (define (parse line)
    (define $ irregex-match-substring)
    (define ->int string->number)
    (let ((line (preprocess line)))
      (cond
       ((command-match line comment-cmd optional-string-arg)
        => (lambda (m) `(comment ,($ m 1))))
       ((command-match line default-delay-cmd number-arg)
        => (lambda (m) `(default-delay ,(->int ($ m 1)))))
       ((command-match line delay-cmd number-arg)
        => (lambda (m) `(delay ,(->int ($ m 1)))))
       ((command-match line string-cmd string-arg)
        => (lambda (m) `(string ,($ m 1))))
       ((command-match line string-delay-cmd number-string-arg)
        => (lambda (m) `(string-delay ,(->int ($ m 1)) ,($ m 2))))
       ((command-match line repeat-cmd number-arg)
        => (lambda (m) `(repeat ,(->int ($ m 1)))))
       ((irregex-match shortcut-cmd line)
        => (lambda (m) `(shortcut ,(irregex-split blank ($ m 1)) ,($ m 2))))
       (else
        (error "Unrecognized line" line)))))

  (map parse (irregex-split "\r\n|\n" input)))