new file mode 100644

@@ -0,0 +1,204 @@

+(defpackage :fwoar.lisp-sandbox.awk

+  (:use :cl )

+  (:export ))

+(in-package :fwoar.lisp-sandbox.awk)

+

+(named-readtables:defreadtable :fwoar-awk

+  (:macro-char #\@ 'read-col-designator t))

+

+(defun read-col-designator (s _)

+  (declare (ignore _))

+  (let ((designator (read s t nil t)))

+    `(resolve-column *client*

+                     *record*

+                     ,(etypecase designator

+                        (fixnum designator)

+                        (symbol (string-downcase designator))

+                        (string designator)))))

+

+(defmacro with-command-output ((s command &rest args &key (output nil output-p)

+                                &allow-other-keys)

+                               &body body)

+  (declare (ignore output))

+  (when output-p

+    (error "can't override :output"))

+  `(let ((,s (uiop:process-info-output

+              (uiop:launch-program ,command :output :stream ,@args))))

+     ,@body))

+

+(defvar *eof-sentinel* '#:eof)

+(defgeneric make-client (client source))

+(defgeneric next-record (client source))

+(defgeneric parse-record (client raw-record))

+(defgeneric unpack-binders (client record))

+(defgeneric field-count (client record))

+(defgeneric resolve-column (client record column-designator))

+

+(defclass lines ()

+  ((%column-cache :initform (make-hash-table))))

+(fw.lu:defclass+ stream-lines (lines)

+  ())

+(fw.lu:defclass+ string-lines (lines)

+  ((%pos :initform 0 :accessor lines-pos)))

+

+(defmethod resolve-column ((client lines) (record cons) (column-designator number))

+  (let ((column-designator (1- column-designator)))

+    (with-slots (%column-cache) client

+      ;; manually tuned

+      (if (> column-designator 60)

+          (alexandria:ensure-gethash column-designator

+                                     %column-cache

+                                     (nth column-designator record))

+          (nth column-designator record)))))

+(defmethod parse-record ((client lines) (raw-record string))

+  (serapeum:tokens raw-record))

+(defmethod field-count ((client lines) (record list))

+  (length record))

+(defmethod unpack-binders ((client lines) (record list))

+  record)

+

+

+(defmethod make-client ((client (eql :lines)) (source stream))

+  (stream-lines))

+(defmethod make-client ((client (eql :lines)) (source string))

+  (string-lines))

+

+(defmethod next-record :before ((client lines) (source stream))

+  (clrhash (slot-value client '%column-cache)))

+(defmethod next-record ((client stream-lines) (source stream))

+  (read-line source nil *eof-sentinel*))

+(defmethod next-record ((client string-lines) (source string))

+  (let ((next-newline (position #\newline source :start (lines-pos client))))

+    (if (< (lines-pos client) (length source))

+        (prog1 (subseq source (lines-pos client) next-newline)

+          (setf (lines-pos client) (if next-newline

+                                       (1+ next-newline)

+                                       (length source))))

+        *eof-sentinel*)))

+

+(fw.lu:defclass+ ndjson ()

+  ())

+

+(defmethod make-client ((client (eql :ndjson)) (source stream))

+  (ndjson))

+(defmethod next-record ((client ndjson) (source stream))

+  (let ((line (read-line source nil *eof-sentinel*)))

+    (if (eql line *eof-sentinel*)

+        line

+        (let ((yason:*parse-json-arrays-as-vectors* t))

+          (yason:parse line)))))

+(defmethod resolve-column ((client ndjson) (record hash-table) column-designator)

+  (gethash column-designator record))

+(defmethod resolve-column ((client ndjson) (record vector) (column-designator number))

+  (aref record (1- column-designator)))

+(defmethod parse-record ((client ndjson) raw-record)

+  raw-record)

+(defmethod field-count ((client ndjson) record)

+  0)

+(defmethod field-count ((client ndjson) (record vector))

+  (length record))

+(defmethod unpack-binders ((client ndjson) record)

+  nil)

+(defmethod unpack-binders ((client ndjson) (record vector))

+  (coerce record 'list))

+

+

+(defvar *client*)

+(defvar *record*)

+(defvar *nr*)

+(defvar *nf*)

+(defmacro do-lines ((line s &optional (client :lines)) &body body)

+  (multiple-value-bind (body decls)

+      (alexandria:parse-body body)

+    (alexandria:with-gensyms (client-instance)

+      (alexandria:once-only (s)

+        `(let* ((,client-instance (make-client ,client ,s))

+                (*client* ,client-instance))

+           (loop for ,line = (next-record *client* ,s)

+                 until (eql ,line *eof-sentinel*)

+                 do ((lambda (,line)

+                       ,@decls

+                       (let ((*client* ,client-instance))

+                         ,@body))

+                     ,line)))))))

+

+(defmacro awk ((s &key (args nil args-p) (client :lines)) &body pattern-actions)

+  (let* ((begin (when (eql (caar pattern-actions) :begin)

+                  (car pattern-actions)))

+         (end (when (eql (caar (last pattern-actions)) :end)

+                (car (last pattern-actions))))

+         (pattern-actions (if begin

+                              (cdr pattern-actions)

+                              pattern-actions))

+         (pattern-actions (if end

+                              (butlast pattern-actions)

+                              pattern-actions))

+         (binders (when args-p

+                    (mapcar (lambda (n)

+                              (intern (format nil "$~d" n)))

+                            (alexandria:iota args :start 1)))))

+    `(block nil

+       ,@(cdr begin)

+       (let ((*nr* 0))

+         (do-lines ($0 ,s ,client)

+           (declare (ignorable $0))

+           (let* (($* (parse-record *client* $0))

+                  (*record* $*)

+                  (*nf* (field-count *client* $*)))

+             (declare (ignorable $*))

+             (destructuring-bind (&optional ,@binders &rest $@)

+                 (unpack-binders *client* $*)

+               (declare (ignorable $@ ,@binders))

+               ,@(mapcar (lambda (it)

+                           (if (= 1 (length it))

+                               (alexandria:with-gensyms (v)

+                                 `(let ((,v ,(car it)))

+                                    (when ,v

+                                      (princ $0)

+                                      (terpri))))

+                               (cons 'when it)))

+                         pattern-actions)))

+           (incf *nr*)))

+       ,@(cdr end)

+       (values))))

+

+(defmacro defawk (name (s args) &body body)

+  `(defun ,name (,s)

+     (awk (,s :args ,args)

+       ,@body)))

+

+#+(or)

+(

+ (spinneret:with-html

+   (:table

+    (with-input-from-string (s (format nil "a b~%c d~% e f"))

+      (awk (s :args 2)

+        (:begin (:thead (:th "first") (:th "second")))

+        (t (:tr (mapc (lambda (cell)

+                        (:td $1 cell))

+                      $*)))

+        (:end (:tfoot (:td "end first") (:td "end second")))))))

+

+ (spinneret:with-html

+   (:table

+    (awk ((format nil "a b~%c d~% e f~%g") :args 2)

+      (t (:tr (mapc (lambda (cell)

+                      (:td $1 cell))

+                    $*)))

+      (:end (:tfoot (:td "end first") (:td "end second"))))))

+

+ (spinneret:with-html

+   (:table

+    (with-command-output (s "ps aux")

+      (awk (s :args 9)

+        (:begin (:thead (:th "first") (:th "second")))

+        (t (:tr (:td $1) (:td $2) (:td $3 "%") (:td $4)

+                (:td (serapeum:string-join $@ " "))))

+        (:end (:tfoot (:td "end first") (:td "end second")))))))

+

+ (serapeum:with-collector (c)

+   (with-command-output (s "ps aux")

+     (awk (s :args 10)

+       ((> *nf* 30) (c *nf* (car $@))))))

+

+ )