(declare (module (jimmy read)))

(import scheme (chicken base)
        (jimmy util)
        (only (chicken condition) handle-exceptions)
        (only (chicken io) read-lines)
        (only (chicken string) string-split))

(define-public line-types
  ;; (sigil type inlines preproc)
  '(("=>" link)
    (">" quot)
    ("#" hdr1)
    ("##" hdr2)
    ("###" hdr3)
    ("*" list)
    ("```" verb)
    ;; extra!
    (":" meta)))

(define-public (parse inport)
  (parse-lines (read-lines inport) '()))

(define (line-type line)
  (let ((it (assoc (car (string-split line)) line-types)))
    (if it (cadr it)
        'para)))

(define (parse-lines lines document)
  (if (null? lines) (reverse document)
      (let ((words (string-split (car lines))))
        (cond
         ((null? words)
          (parse-lines (cdr lines) document))
         ((equal? (car words) "```")
          (parse-verbatim (cdr lines) document '()))
         ((assoc (car words) line-types)
          => (lambda (it)
               (apply parse-block lines document '() (cdr it))))
         (else
          (parse-block lines document '() 'para '(link) identity))))))

(define (parse-verbatim lines document verb)
  (cond
   ((null? lines)
    (parse-lines lines (cons (cons 'verb (reverse verb)) document)))
   ((equal? (car lines) "```")
    (parse-lines (cdr lines) (cons (cons 'verb (reverse verb)) document)))
   (else
    (parse-verbatim (cdr lines) document (cons (car lines) verb)))))

(define (parse-block lines document block type #!optional inlines preproc)
  (let ((inlines (or inlines '()))
        (preproc (or preproc (lambda (ln) (cdr (string-split ln))))))
    (cond
     ((null? lines)
      (parse-lines lines (cons (cons type (reverse block)) document)))
     ((equal? (car lines) "")
      (parse-lines (cdr lines) (cons (cons type (reverse block)) document)))
     ((and (not (eq? type (line-type (car lines))))
           (not (memq (line-type (car lines)) inlines)))
      (parse-lines lines (cons (cons type (reverse block)) document)))
     ((memq (line-type (car lines)) inlines)
      (let* ((ln (car lines))
             (ws (string-split ln))
             (lt (cdr (assoc (car ws) line-types))))
        (parse-block (cdr lines) document
                     (cons (cons (car lt)
                                 ((or (ignore-errors (caddr lt)) cdr) ws))
                           block)
                     type inlines preproc)))
     (else
      (parse-block (cdr lines) document (cons (preproc (car lines)) block)
                   type inlines preproc)))))