316 lines
13 KiB
Common Lisp
316 lines
13 KiB
Common 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)))
|
||
(if (not (null dipnotlar))
|
||
(ebeveyn-node! :ol (reverse dipnotlar))
|
||
(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)))
|