;; requires klipspringer.scm
;;
;; This is an EXPERIMENTAL parser for the block-level of Markdown.
;; The actual Markdown parser is in parse-markdown.lex/y, still.
;; This uses the lexer in parse-markdown.lex.
;;
;; This file is part of Beastie <https://purl.org/nxg/dist/beastie>
;; SPDX-FileCopyrightText: 2024 Norman Gray <https://nxg.me.uk>
;; SPDX-License-Identifier: BSD-2-Clause

(define *requires-implementation-functions*
  '(mdblock-load-hook*))
(define *module-load-hook* 'mdblock-load-hook*)

(define-macro (%module-verbosity-flag%) 32) ;same as parse-markdown.scm

(define mdblock-env
  (let ()
    ;; This currently needs internal functions: I should either
    ;; rewrite it to use only the exposed ones, or change my mind
    ;; about what should and shouldn't be the exposed interface.
    ;;
    ;; As of April, I think this probably _can_ straightforwardly be done
    ;; using only exposed functions.  So there's a project.
    (module/expose 'klipspringer)

    ;; mdblock lexeme handling
    ;; lexemes from parse-mdblock.lex:mdblocklex are #(type/symbol value annot/assq)
    (define (mdblock-lexeme? x)
      (and (vector? x)
           (= (vector-length x) 3)
           (symbol? (vector-ref x 0))))
    (define (mdblock-lexeme-type l)
      (and (mdblock-lexeme? l)
           (vector-ref l 0)))
    (define (mdblock-lexeme-type? l type)
      (eqv? (mdblock-lexeme-type l) type))
    (define (mdblock-lexeme-value l)
      ;(printf "  value: ~s~%" l)
      (if (mdblock-lexeme? l)
          (vector-ref l 1)
          (beastie-error "mdblock-lexeme-value: ~s is not a mdblock-lexeme" l)))
    ;; given a lexeme L, and no second argument, return the lexeme's annotations;
    ;; with an argument, return the corresponding annotation value
    ;; or #f if it isn't present
    (define (mdblock-lexeme-annot l . k)
      (cond ((not (mdblock-lexeme? l))
             (beastie-error "mdblock-lexeme-annot: ~s is not a mdblock-lexeme" l))
            ((null? k)                  ;the annotations as an assq
             (vector-ref l 2))
            (else                       ;one annotation value
             (get-annot (vector-ref l 2) (car k)))))

    ;; look up an assq A for key K, return its value,
    ;; or #f if it isn't present
    (define (get-annot a k)
      (cond ((assq k a) => cdr)
            (else #f)))

    ;; (define (call-with-mdblock-input/file filename proc)
    ;;   (let ((*l* (mdblock-make-lexer/file filename)))
    ;;     (dynamic-wind
    ;;         #f
    ;;         (λ ()
    ;;           (proc (make-input
    ;;                  (λ ()
    ;;                    (mdblock-get-lexeme *l*)))))
    ;;         (λ ()
    ;;           (mdblock-destroy-lexer *l*)))))
    (define (call/input lexeme-source proc)
      (let ((*l* lexeme-source))
        (dynamic-wind
            #f
            (λ ()
              (proc (make-input/source* (λ () (mdblock-get-lexeme *l*)) #f)))
            (λ ()
              (mdblock-destroy-lexer *l*)))))

    ;; return a parser which will match a lexeme of the given type;
    ;; if PREDICATES is non-null, then it must also match each
    ;; of the predicates in the list
    (define (lexeme-of-type type-symbol . predicates)
      (let ((+description+ (delay (sprintf "<~a>" type-symbol))))
        (λ (inp)
          (let ((l0 (input-car inp)))
            (if (and (mdblock-lexeme-type? l0 type-symbol)
                     (let loop ((ps predicates))
                       (cond ((null? ps) #t)
                             (((car ps) l0) (loop (cdr ps)))
                             (else #f))))
                (make-consumed (make-ok l0 (input-cdr inp)))
                (make-empty (make-error (list +description+) (list inp))))))))
    (define $space (lexeme-of-type 'blank))
    (define $li (lexeme-of-type 'li))
    (define $h1underline (lexeme-of-type 'h1underline))
    (define $hr (lexeme-of-type 'hr))
    (define $hn (lexeme-of-type 'hn))

    (define $text (lexeme-of-type 'text))
    (define $text0
      ;; a parser which matches text lexemes with indent exactly 0
      (lexeme-of-type 'text
                      (λ (l)
                        (let ((i (mdblock-lexeme-annot l 'indent)))
                          (and i (= i 0))))))
    (define $text1
      ;; a parser which matches text lexemes with indent exactly 1
      (lexeme-of-type 'text
                      (λ (l)
                        (let ((i (mdblock-lexeme-annot l 'indent)))
                          (and i (= i 1))))))
    (define $text1+
      ;; a parser which matches text lexemes with indent at least 1
      (lexeme-of-type 'text
                      (λ (l)
                        (let ((i (mdblock-lexeme-annot l 'indent)))
                          (and i (>= i 1))))))

    ;; the parsers el-FOO produce xexpr elements,
    ;; and el-FOO/a produce (assq? . xexpr?)

    (define el-p
      ;; a paragraph
      (parser-compose
       ;(many $space)                    ;leading space
       (content <- (many1 $text))
       (many $space)                    ;trailing space
       (return (list 'p (string-join (map mdblock-lexeme-value content) " ")))))
    (define el-p1
      ;; a paragraph of lines where the first one is indented one step,
      ;; but the others need not be
      ;; (ie, a LI body)
      (parser-compose
       (c1 <- $text1)
       (cs <- (many $text))
       (many $space)
       (return (list 'p (string-join (map mdblock-lexeme-value (cons c1 cs)) " ")))))

    (define el-blockquote
      (parser-compose
       (content <- (many1 (<or> $text1+ $space)))
       ;(many $space)
       (return
        (list 'blockquote
              (string-join
               (map (λ (l)
                      ;; the space lexeme has value #f
                      (cond ((mdblock-lexeme-value l)
                             => (λ (line)
                                  (let ((indent4 (mdblock-lexeme-annot l 'indent))
                                        (indent1 (mdblock-lexeme-annot l 'indent+)))
                                    ;; the actual indent is indent4*4 + (indent1)
                                    (string-append
                                     (make-string (+ (* (- indent4 1) 4) indent1)
                                                  #\space)
                                     line))))
                            (else "")))
                    content)
               "\n")))))

    (define el-li/a
      ;; a list-item -- return not '(li ...) but either
      ;; '(((is-ol? . #t) ...) "li-content")
      ;; for an unparagraphed li, or
      ;; '(((is-ol? . #t) ...) (p "li-content") (p "xxx") ...)
      ;; for multiple paragraphs.
      ;; That is, we include the annotations from the lexeme.
      (parser-compose
       (li <- $li)
       (contn <- (many $text))
       (many $space)
       (px <- (many el-p1))
       (let ((p1-body (string-join
                       (cons (mdblock-lexeme-value li)
                             (map mdblock-lexeme-value contn))
                       " "))
             (annots (mdblock-lexeme-annot li)))
         ;(printf "el-li/a: li=~s  contn=~s  px=~s annot=~s~%" li contn px annots)
         (if (null? px)
             (return `(,annots ,p1-body))
             (return `(,annots (p ,p1-body) . ,px))))))
    (define el-olul
      ;; an ol or ul element
      (>>= (many1 el-li/a)
           (λ (lis)
             ;(printf "lis=~s~%" lis)
             (let ((gi (if (get-annot (caar lis) 'is-ol?) ;check annots of first li
                           'ol
                           'ul))
                   (compact? (let loop ((l (reverse (cdr lis))))
                               ;; examine the annotations of (cdr lis),
                               ;; starting from the end, to work out
                               ;; whether we should be putting
                               ;; everything into (p...)
                               (cond ((null? l)
                                      ;; default to compact
                                      #t)
                                     ((> (length (car l)) 2)
                                      ;; multiple paragraphs
                                      #f)
                                     ((get-annot (caar l) 'blank-before?)
                                      ;; li with a blank line separating it from previous
                                      #f)
                                     (else
                                      (loop (cdr l)))))))
               ;(printf "  el-olul:  gi=~s  compact?=~s~%" gi compact?)
               (return (cons gi
                             (map (λ (li)
                                    (cond ((> (length li) 2) `(li . ,(cdr li)))
                                          (compact? `(li . ,(cdr li)))
                                          (else `(li (p ,(cadr li))))))
                                  lis)))))))
    (define el-olul-NOT
      ;; an ol or ul element
      (>>= (many1 el-li/a)
           (λ (lis)
             (return (cons (if (get-annot (caar lis) 'is-ol?) 'ol 'ul)
                           (map cdr lis))))))

    (define el-h1
      (parser-compose
       (t <- $text)
       $h1underline
       ;(many $space)
       (return (list 'h1 (mdblock-lexeme-value t)))))
    (define el-h2
      (parser-compose
       (t <- $text)
       $hr
       ;(many $space)
       (return (list 'h2 (mdblock-lexeme-value t)))))
    (define el-hn
      (parser-compose
       (title <- $hn)
       ;(many $space)
       (let ((level (case (mdblock-lexeme-annot title 'level)
                      ((1) 'h1)
                      ((2) 'h2)
                      ((3) 'h3)
                      ((4) 'h4)
                      ((5) 'h5)
                      (else 'h6))))
         (return (list level (mdblock-lexeme-value title))))))
    (define el-hr
      (parser-compose
       $hr
       ;(many $space)
       (return '(hr))))

    (define mdblock-parser
      ;; this parser parses a single markdown block element from the input
      (many
       (parser-seq (~ (many $space))
                   (<or>
                    (try el-h1)
                    (try el-h2)
                    (try el-hn)
                    (try el-olul)
                    (try el-hr)
                    (try el-blockquote)
                    (try el-p)
                    #;(λ (inp)
                    (let ((l (input-car inp))) ;
                    (if (eof-object? l) ;
                    (make-empty (make-error #f inp)) ;
                    (make-consumed      ;
                    (make-ok `(p ,(mdblock-lexeme-value l)) ;
                    (input-cdr inp)))))))
                   :combine-with values
                   )))
    ;; (define mdblock-parser-multiblock
    ;;   (<or> (parser-seq el-p
    ;;                     (many (parser-seq (~ $space) el-p)))))

    (define (parse-mdblock/input inp)
      ;(printf "~%parse: ~s~%" inp)
      (let ((results (mdblock-parser inp)))
        ;(printf "   -> ~s~%" results)
        (cond ((not results) ; ??? is this the correct error (I think not)
               (beastie-error "unmatched lexeme: ~s~%" (input-car inp)))
              ((consumed? results)
               (let ((c (consumed-result results)))
                 ;(printf ">>> consumed: ~a~%" (if (ok? c) (sprintf "OK ~s" (ok-value c)) "ERROR"))
                 (if (ok? c)
                     (ok-value c)
                     (beastie-error "failed to parse \"~a\": error ~a at ~s~%"
                                        ;(object->string inp :display 32)
                                    (object->string inp :display)
                                    (or (error-msg c) "??")
                                    (object->string (input-car inp))))))
              ((empty? results) ; this is a bit unexpected -- blank input?
               ;(printf ">>> empty: ~s~%" results)
               (let ((e (empty-result results)))
                 (if (ok? e)
                     (ok-value e)
                     (beastie-error                        ; better error reporting?
                      "failed to parse file \"~a\": error ~a at ~s~%"
                                 (object->string inp)
                                 (or (error-msg e) "??")
                                 (object->string (input-car inp)))))))))
    (define (parse-mdblock/input/not initial-input)
      (let loop ((inp initial-input)
                 (res '()))
        (printf "~%parse: ~s~%" inp)
        (let ((results (mdblock-parser inp)))
          (printf "    -> ~s~%" results)
          (cond ((not results)
                 (eprint "unmatched lexeme: ~s~%" (input-car inp))
                 (loop inp res))
                ((consumed? results)
                 (let ((r1 (consumed-result results)))
                   (printf ">>> consumed: ~a~%" (if (ok? r1) (sprintf "OK ~s" (ok-value r1)) "X"))
                   (if (ok? r1)
                       (loop (ok-input r1) (cons (ok-value r1) res))
                       (begin
                         (eprintf "failed to parse \"~a\": error at ~s~%"
                                  ;(object->string initial-input :display 32)
                                  (object->string initial-input :display)
                                  (object->string (input-car inp) :display))
                         (cons 'div (reverse! res))))))
                ((empty? results)
                 (printf ">>> empty: ~s~%" results)
                 (let* ((e (empty-result results))
                        (next (input-car (if (ok? e) (ok-input e) (error-input e)))))
                   (cond ((error? e)
                          ;; better error reporting?
                          (eprintf "failed to parse file \"~a\": error ~a at ~s~%"
                                   (object->string initial-input)
                                   (error-msg e)
                                   next)
                          (cons 'div (reverse! res)))
                         ((eof-object? next)
                          (cons 'div (reverse! res)))
                         (else
                          ;; failed to parse before end
                          (eprintf "failed to parse file \"~a\": unexpected ~a at line ~a~%"
                                   fn
                                   (mdblock-lexeme-type next)
                                   (mdblock-lexeme-annot next 'line-number))
                          (cons 'div (reverse! res))))))
                (else
                 (beastie-error "unexpected return from parse-mdblock: ~s" results))))))

    (curlet)))


;; Parse markdown block elements from a file.
;; Hmm: it feels like I should be able to reimplement this using just >>=
(define/provide (parse-mdblock-file fn)
  (with-let (sublet mdblock-env
                    'fn fn)
    ;; why don't I need to include 'fn fn here?
    (call/input (mdblock-make-lexer/file fn) parse-mdblock/input)))
(define/provide (parse-mdblock-string str)
  (with-let (sublet mdblock-env
              'str str)
    (call/input (mdblock-make-lexer/string str) parse-mdblock/input)))