path: root/src/okur.lisp

(in-package :html-jen)

(defun dosya-metni-oku (dosya)
  (let* ((uzunluk 0)
         (metin
           (with-output-to-string (out)
             (with-open-file (in dosya :external-format :utf-8)
               (loop :with arabellek := (make-array 8192 :element-type 'character)
                     :for n := (read-sequence arabellek in)
                     :while (< 0 n)
                     :do (incf uzunluk n)
                         (write-sequence arabellek out :start 0 :end n))))))
    (values metin uzunluk)))

(defclass okur ()
  ((metin :initarg :metin :accessor metin
          :documentation "Markdown string")
   (i :initform 0 :accessor i
      :documentation "Metin indeksi")
   (uzunluk :initarg :uzunluk :accessor uzunluk
            :documentation "Metin uzunluğu")
   (blok-baş :accessor blok-baş :initform 0
             :documentation "Bloğun başının indexi")
   (blok-son :accessor blok-son :initform 0
             :documentation "Bloğun sonunun indexi")
   (dosya-ismi :initarg :dosya-ismi
               :documentation "Okunan markdown dosyasının ismi")))

(defun okur! (dosya-ismi)
  (multiple-value-bind (metin uzunluk)
      (dosya-metni-oku dosya-ismi)
    (make-instance 'okur :metin metin :uzunluk uzunluk :dosya-ismi dosya-ismi)))

(defun metin-okur! (metin)
  (make-instance 'okur :metin metin :uzunluk (length metin) :dosya-ismi ""))

(defmethod son? ((okur okur) index)
  (>= index
      (uzunluk okur)))

(defmethod index-reset ((okur okur))
  (setf (i okur) 0
        (blok-son okur) 0))

(defmethod blok-reset ((okur okur))
  (setf (i okur) (blok-baş okur)))

(defmethod bak ((okur okur))
  (and (not (son? okur (i okur)))
       (char (metin okur) (i okur))))

(defmethod ye ((okur okur))
  (with-slots (metin i) okur
    (and (son? okur i)
         (prog1 (char metin i)
           (incf i)))))

(defun son-ara (parça metin baş)
  (let ((eş (search parça metin :start2 baş)))
    (when (numberp eş)
      (+ eş (length parça)))))

(let ((blok-sonu (format nil "~%~%")))
  (defmethod sonraki-blok ((okur okur))
    "blok-baş ve blok-son indexlerinin atamasını yapar. Başka blok kalmadıysa nil döndürür."
    (unless (son? okur (blok-son okur))
      (with-slots (i uzunluk metin blok-son blok-baş) okur
        (let ((yeni-baş (progn (setf i blok-son)
                               (loop :for ch := (bak okur)
                                     :while (and ch
                                                 (or (char= #\Newline ch)
                                                     (char= #\Space ch)))
                                     :do (incf i)
                                     :finally (return i))))
              (yeni-son (or (if (string= "```" metin :start2 i :end2 (+ i 3))
                                (progn (setf i (son-ara "```" metin (+ i 3)))
                                       (son-ara blok-sonu metin i))
                                (son-ara blok-sonu metin i))
                            uzunluk)))
          (setf blok-son yeni-son
                blok-baş yeni-baş
                i blok-baş))))))

(defmethod boşluk-yut ((okur okur))
  (with-slots (i metin) okur
    (loop :while (char= #\Space (char metin i))
          :do (incf i))))

(defmethod metin-parçası ((okur okur) uzunluk baş)
  (make-array uzunluk
              :element-type 'character
              :displaced-to (metin okur)
              :displaced-index-offset baş))

(defgeneric ayrıştır (okur tag)
  (:documentation "Tag'a göre bloktaki elementleri belirler."))

(defmethod ayrıştır ((okur okur) (tag (eql :h)))
  (with-slots (i blok-son metin) okur
    (let ((h-sayı 0))
      (loop :while (char= #\# (char metin i))
            :do (incf i)
                (incf h-sayı))
      (assert (char= #\Space (char metin i)))
      (assert (< h-sayı 7))
      (boşluk-yut okur)
      (çocuk-node! (intern (format nil "H~D" h-sayı) "KEYWORD")
                   (metin-parçası okur
                                  (- (or (position #\Newline metin :start i)
                                         blok-son)
                                     i)
                                  i)))))

(defmethod ayrıştır ((okur okur) (tag (eql :ul)))
  (with-slots (i blok-son metin) okur
    (let ((itemler (loop :while (and (< i blok-son)
                                     (not (char= #\Newline (char metin i))))
                         :do (assert (string= "- " metin :start2 i :end2 (+ i 2)))
                             (incf i 2)
                         :collect (let ((yeni (or (position #\Newline metin :start i)
                                                  blok-son)))
                                    (prog1 (metin-parçası okur (- yeni i) i)
                                      (setf i (+ yeni 1)))))))
      (ebeveyn-node! :ul
                     (mapcar (lambda (item)
                               (çocuk-node! :li item))
                             itemler)))))

(defmethod ayrıştır ((okur okur) (tag (eql :ol)))
  (with-slots (i blok-son metin) okur
    (let ((item-sayısı 1))
      (let ((itemler
              (loop :while (and (< i blok-son)
                                (not (char= #\Newline (char metin i))))
                    :do (let ((i2 i))
                          (loop :while (char<= #\0 (char metin i2) #\9)
                                :do (incf i2))
                          (assert (string= ". " metin :start2 i2 :end2 (+ i2 2)))
                          (assert (= item-sayısı (parse-integer metin :start i :end i2)))
                          (incf item-sayısı)
                          (setf i (+ i2 2)))
                    :collect (let ((yeni (or (position #\Newline metin :start i)
                                             blok-son)))
                               (prog1 (metin-parçası okur (- yeni i) i)
                                 (setf i (+ yeni 1)))))))
        (ebeveyn-node! :ol
                       (mapcar (lambda (item)
                                 (çocuk-node! :li item))
                               itemler))))))

(defmethod ayrıştır ((okur okur) (tag (eql :code)))
  (with-slots (i metin blok-son blok-baş) okur
    (assert (string= "```" metin :start2 blok-baş :end2 (+ blok-baş 3)))
    (let ((kod-baş (+ 1 (position #\Newline metin :start (+ blok-baş 3)))))
      (let ((kod (metin-parçası okur
                                (- (search "```" metin :from-end t :end2 blok-son)
                                   kod-baş)
                                kod-baş)))
        (ebeveyn-node! :pre
                       (list (çocuk-node! :code
                                          kod)))))))



(defgeneric inline-ayrıştır (okur tag son)
  (:documentation "Paragraf içindeki elementleri ayrıştırır"))

(defmethod inline-ayrıştır ((okur okur) tag str)
  (with-slots (i metin blok-son) okur
    (let ((son (search str metin
                       :start2 i
                       :end2 blok-son)))
      (prog1 (çocuk-node! tag (metin-parçası okur (- son i) i))
        (setf i (+ son (length str)))))))

(defmethod link-ayrıştır ((okur okur))
  (with-slots (i metin blok-son) okur
    (let* ((son (search "]" metin
                        :start2 i
                        :end2 blok-son))
           (link-metni (metin-parçası okur (- son i) i)))
      (setf i (+ son 1))
      (assert (char= #\( (char metin i)))
      (incf i)
      (let ((son (search ")" metin
                         :start2 i
                         :end2 blok-son)))
        (prog1 (çocuk-node! :a link-metni
                            (list :href (metin-parçası okur (- son i) i)))
          (setf i (+ 1 son)))))))

(defparameter *dipnot-limit* 36)
(defparameter *dipnotlar*
  (make-array *dipnot-limit* :element-type 'bit :initial-element 0))

(defun dipnot-var? (n)
  (= 1 (aref *dipnotlar* n)))

(defun dipnot-ata (n)
  (setf (aref *dipnotlar* n) #b1))

(defmethod dipnot-ayrıştır ((okur okur))
  (declare (optimize (debug 3) (safety 3)))
  (with-slots (i metin blok-son) okur
    (let* ((son (position #\] metin
                          :start i
                          :end blok-son))
           (n (parse-integer metin :start i :end son)))
      (prog1 (if (dipnot-var? n)
                 (ebeveyn-node! :li
                                (list (let ((baş (+ 1 son)))
                                        (assert (char= (char metin baş) #\:))
                                        (setf son (or (position #\Newline metin :start baş :end blok-son) blok-son))
                                        (metin-parçası okur (- son baş 1) (+ baş 1)))
                                      (çocuk-node! :a " ↩" (list :href (format nil "#dipnot-ref-~d" n))))
                              (list :id (format nil "dipnot-~d" n)))
                 (progn (dipnot-ata n)
                        (ebeveyn-node! :sup
                                       (list (çocuk-node! :a (metin-parçası okur (- son i) i)
                                                          (list :href (format nil "#dipnot-~d" n)
                                                                :id (format nil "dipnot-ref-~d" n)))))))
        (setf i (min blok-son (+ son 1)))))))

(defmethod paragraf-ayrıştır ((okur okur))
  (with-slots (i blok-son metin) okur
    (let ((elementler (list))
          (dipnotlar (list))
          (baş i))
      (labels ((pushla-ve-ayrıştır (tag str)
                 (push (metin-parçası okur (- i baş) baş) elementler)
                 (incf i (length str))
                 (push (inline-ayrıştır okur tag str) elementler)
                 (setf baş i)))
        (loop :while (< i blok-son)
              :do (case (char metin i)
                    (#\[ (cond ((char= #\^ (char metin (+ 1 i)))
                                (push (metin-parçası okur (- i baş) baş) elementler)
                                (incf i 2)
                                (let ((dipnot (dipnot-ayrıştır okur)))
                                  (case (tag dipnot)
                                    (:sup (push dipnot elementler))
                                    (:li (push dipnot dipnotlar))))
                                (setf baş i))
                               ((char= #\( (char metin (+ 1 (position #\] metin :start i))))
                                (push (metin-parçası okur (- i baş) baş) elementler)
                                (incf i 1)
                                (push (link-ayrıştır okur) elementler)
                                (setf baş i))
                               (t (incf i))))
                    (#\` (pushla-ve-ayrıştır :code "`"))
                    (#\_ (pushla-ve-ayrıştır :i "_"))
                    (#\* (if (char= #\* (char metin (+ i 1)))
                             (pushla-ve-ayrıştır :b "**")
                             (pushla-ve-ayrıştır :i "*")))
                    (#\!
                     (when (char= #\[ (char metin (+ i 1)))
                       (push (metin-parçası okur (- i baş) baş) elementler)
                       (incf i 2)
                       (let ((link (link-ayrıştır okur)))
                         (push (çocuk-node! :img
                                            nil
                                            (list :src (getf (props link) :href)
                                                  :alt (value link)))
                               elementler))
                       (setf baş i))
                     (incf i))
                    (t (incf i)))
              :finally (loop :while (char= #\Newline (char metin (- i 1)))
                             :do (decf i))
                       (when (/= baş i)
                         (push (metin-parçası okur (- i baş) baş) elementler))
                       (when (not (null dipnotlar))
                         (push (ebeveyn-node! :ol (reverse dipnotlar)) elementler)))
        (ebeveyn-node! :p (reverse elementler))))))

(defmethod blok-ayrıştır ((okur okur))
  (when (sonraki-blok okur)
    (with-slots (i metin) okur
      (case (char metin i)
        (#\# (ayrıştır okur :h))
        (#\- (ayrıştır okur :ul))
        (#\` (ayrıştır okur :code))
        (#\> "")
        (t (if (char<= #\0 (char metin i) #\9)
               (ayrıştır okur :ol)
               (paragraf-ayrıştır okur)))))))

(defmethod markdown-ayrıştır ((okur okur))
  (labels ((öz (okur)
             (let ((blok-node (blok-ayrıştır okur)))
               (if (null blok-node)
                   nil
                   (cons blok-node (öz okur))))))
    (ebeveyn-node! :div
                   (öz okur))))


(defparameter *okur* (okur! "/home/riton/projects/html-jen/cheat.md"))

(defmethod blok-yazdır ((okur okur) &optional (stream *standard-output*))
  (write-sequence (metin okur) stream
                  :start (blok-baş okur)
                  :end (blok-son okur))
  (values))

(defmethod blok-metni ((okur okur))
  (with-slots (blok-son blok-baş metin) okur
    (make-array (- blok-son blok-baş)
                :element-type 'character
                :displaced-to metin
                :displaced-index-offset blok-baş)))

(defmethod okur-blok-listesi ((okur okur))
  (loop :while (sonraki-blok okur)
        :collect (blok-metni okur)))