(module gmi
  (
   *strict-gemtext-headers*

   gmi:read
   gmi:write
   gmi:write1

   gmi:text
   gmi:header
   gmi:link
   gmi:list
   gmi:list*
   gmi:blockquote
   gmi:code
   gmi:code*

   gmi:text?
   gmi:header?
   gmi:link?
   gmi:list?
   gmi:blockquote?
   gmi:code?

   gmi:header:level
   gmi:header:text
   gmi:link:uri
   gmi:link:text
   gmi:list:items
   gmi:blockquote:text
   gmi:code:text
   gmi:code:lines

   gmi:tag/header
   gmi:tag/link
   gmi:tag/list
   gmi:tag/blockquote
   gmi:tag/code
   )

  (import
    scheme
    (only (chicken base)
          cute
          fixnum?
          make-parameter
          o)
    (only (chicken io)
          read-lines
          write-line)
    (only (chicken irregex)
          irregex
          irregex-match
          irregex-match-substring))

  (define gmi:tag/header 'gmi:header)
  (define gmi:tag/link 'gmi:link)
  (define gmi:tag/list 'gmi:list)
  (define gmi:tag/blockquote 'gmi:blockquote)
  (define gmi:tag/code 'gmi:code)

  (define (gmi:text text) text)
  (define (gmi:header level title) `(,gmi:tag/header ,level ,title))
  (define (gmi:link uri text) `(,gmi:tag/link ,uri ,text))
  (define (gmi:list* items) `(,gmi:tag/list . ,items))
  (define (gmi:list . items) (gmi:list* items))
  (define (gmi:blockquote text) `(,gmi:tag/blockquote ,text))
  (define (gmi:code* lines) `(,gmi:tag/code . ,lines))
  (define (gmi:code alt-text . lines) (gmi:code* (cons alt-text lines)))

  (define (tagged-list? tag l)
    (and (list? l)
         (not (null? l))
         (eq? (car l) tag)))

  (define (all p? l)
    (or (null? l)
        (and (p? (car l))
             (all p? (cdr l)))))

  (define (tag? tag) (cute eq? <> tag))

  (define ((elem-type? . preds?) l)
    (and (list? l)
         (let loop ((preds? preds?)
                    (l l))
           (cond
             ((null? l) (null? preds?))
             ((null? preds?) #f)
             (else (let ((h (car l))
                         (t (cdr l))
                         (h? (car preds?))
                         (t? (cdr preds?)))
                     (and (h? h) (loop t? t))))))))


  (define gmi:text? string?)

  (define gmi:header? (elem-type? (tag? gmi:tag/header)
                                  fixnum?
                                  gmi:text?))

  (define gmi:link? (elem-type? (tag? gmi:tag/link)
                                gmi:text?
                                gmi:text?))

  (define (gmi:list? l)
    (and (tagged-list? gmi:tag/list l)
         (not (null? (cdr l)))
         (all gmi:text? (cdr l))))

  (define gmi:blockquote? (elem-type? (tag? gmi:tag/blockquote)
                                      gmi:text?))

  (define (gmi:code? l)
    (and (tagged-list? gmi:tag/code l)
         (not (null? (cdr l)))
         (gmi:text? (cadr l))
         (all gmi:text? (cddr l))))

  (define gmi:header:level cadr)
  (define gmi:header:text caddr)
  (define gmi:link:uri cadr)
  (define gmi:link:text caddr)
  (define gmi:list:items cdr)
  (define gmi:blockquote:text cadr)
  (define gmi:code:text cadr)
  (define gmi:code:lines cddr)


  ;;; If enabled (default), header lines of level > 3 are not considered
  ;;; headers but normal text instead.
  (define *strict-gemtext-headers* (make-parameter #t))

  (define (gmi:read #!optional (port (current-input-port)))
    ;; Predicates return either an irregex match object if the regex matches
    ;; the line, or #f otherwise
    (define (match? re) (cute irregex-match (irregex re) <>))

    (define p:header? (match? "(#+)\\s+(.*)"))
    (define p:link? (match? "=>\\s*([^\\s]+)(\\s+(.*))?"))
    (define p:list-item? (match? "\\*\\s+(.*)"))
    (define p:blockquote? (match? ">\\s*(.*)"))
    (define p:begin-code-line? (match? "```(.*)"))
    (define p:end-code-line? (cute string=? "```" <>))

    (define-syntax match-let
      (syntax-rules ()
        ((match-let match ((var idx) ...) body ...)
         (let ((%match match))
           (let ((var (irregex-match-substring %match idx)) ...)
             body ...)))))


    (define ((p:header line) ret match)
      (match-let match ((level 1) (title 2))
        (let* ((level (string-length level))
               (elem (if (and (> level 3) (*strict-gemtext-headers*))
                         line
                         (gmi:header level title))))
          (cons elem ret))))

    (define (p:link ret match)
      (match-let match ((uri 1) (text 3))
        (let ((text (or text "")))
          (cons (gmi:link uri text) ret))))

    (define (p:list-item ret match)
      (match-let match ((text 1))
        (cons text ret)))

    (define (p:blockquote ret match)
      (match-let match ((text 1))
        (cons (gmi:blockquote text) ret)))

    (define (p:end-list items ret)
      (cons (gmi:list* (reverse items)) ret))

    (define (p:begin-code ret match)
      (match-let match ((text 1))
        (cons text ret)))

    (define (p:end-code code-lines ret)
      (cons (gmi:code* (reverse code-lines)) ret))

    (define (p:text ret txt)
      (cons (gmi:text txt) ret))


    (define eof? null?)
    (define (finish-off lst #!optional err)
      (values (reverse lst) err))

    (define ((goto st piece ret tail) match)
      (st (piece ret match) tail))


    (define ((st:list ret) items lines)
      (if (eof? lines)
          (finish-off (p:end-list items ret))
          (let ((head (car lines))
                (tail (cdr lines)))
            (cond
              ((p:list-item? head)
               => (goto (st:list ret) p:list-item items tail))
              (else
                (st:text (p:end-list items ret) lines))))))

    (define ((st:code ret) code-lines lines)
      (if (eof? lines)
          ; The file ended before a code-closing line was found -- throw away
          ; the partial code block. The following line can be used instead to
          ; keep this partially parsed code block.
          ;(finish-off (p:end-code code-lines ret))
          (finish-off ret "Malformed Gemtext document")

          (let ((head (car lines))
                (tail (cdr lines)))
            (cond
              ((p:end-code-line? head)
               (st:text (p:end-code code-lines ret) tail))
              (else
                ((st:code ret) (cons head code-lines) tail))))))


    (define (st:text ret lines)
      (if (eof? lines)
          (finish-off ret)
          (let ((head (car lines))
                (tail (cdr lines)))
            (cond
              ((p:header? head)
               => (goto st:text (p:header head) ret tail))
              ((p:link? head)
               => (goto st:text p:link ret tail))
              ((p:list-item? head)
               => (goto (st:list ret) p:list-item '() tail))
              ((p:blockquote? head)
               => (goto st:text p:blockquote ret tail))
              ((p:begin-code-line? head)
               => (goto (st:code ret) p:begin-code '() tail))
              (else
                ((goto st:text p:text ret tail) head))))))


    (st:text '() (read-lines port)))

  (define (gmi:write1 elem #!optional (port (current-output-port)))
    (define !string-null? (o positive? string-length))
    (define (writeln str)
      (write-line str port))

    (cond
      ((gmi:text? elem)
       (writeln elem))

      ((gmi:header? elem)
       (writeln (string-append (make-string (gmi:header:level elem) #\#)
                               " " (gmi:header:text elem))))

      ((gmi:link? elem)
       (let ((text (gmi:link:text elem)))
         (writeln (if (!string-null? text)
                      (string-append "=> " (gmi:link:uri elem) " " text)
                      (string-append "=> " (gmi:link:uri elem))))))

      ((gmi:list? elem)
       (for-each (o writeln (cute string-append "* " <>))
                 (gmi:list:items elem)))

      ((gmi:blockquote? elem)
       (let ((text (gmi:blockquote:text elem)))
         (writeln (if (!string-null? text)
                      (string-append "> " text)
                      ">"))))

      ((gmi:code? elem)
       (writeln (string-append "```" (gmi:code:text elem)))
       (for-each writeln (gmi:code:lines elem))
       (writeln "```"))))

  (define (gmi:write gmi #!optional (port (current-output-port)))
    (for-each (cute gmi:write1 <> port) gmi))
  )