Remade exporting structure

4 years ago · a38640a581
parent 92046b7133
commit a38640a581
5 changed files with 80 additions and 121 deletions
--- a/.gitignore
+++ b/.gitignore
@ -1 +1 @@
-utils/
+utils
--- a/3
+++ b/3
@ -1,3 +0,0 @@
-
-flan-utils:
-	./make-asdf-system
--- a/flan-utils.asd
+++ b/flan-utils.asd
@ -0,0 +1,15 @@
+(asdf/parse-defsystem:defsystem :flan-utils
+  :description
+  "Some random utilities"
+  :author
+  "Rin <flanchan@cumallover.me>"
+  :license
+  "None"
+  :version
+  "0.2.0"
+  :serial
+  t
+  :depends-on
+  (#:cl-ppcre #:bordeaux-threads)
+  :components
+  ((:file "flan-utils")))
--- a/flan-utils.lisp
+++ b/flan-utils.lisp
@ -1,115 +1,46 @@
 ;;;; utils.lisp -- some random utils I collect. might be useful, probably won't be.

-(if (boundp '*-utils-lisp*) "Already loaded" (progn
-
-;;; --- internally maintained config, don't put anything above these!!
-
-(defparameter *-utils-lisp* t)
-(defparameter *-utils-depends* '(#:cl-ppcre #:bt-semaphore))
-
-(defparameter *-utils-version* "0.1.6")
-
-;;; -- Handle internal exporting --
-
-(defmacro insystem? (thing &optional (else nil))
-  `(if (boundp '*-utils-system*)
-     ,thing
-     ,else))
-
-(defmacro export? (val)
-  `(if (boundp '*-utils-system*)
-     (export ',val)
-     nil))
-
-;(defmacro export* (&rest syms) 
-;  `(mapc #'export '(,@syms)))
+(defpackage :flan-utils (:use :cl))
+(in-package :flan-utils)

 (defmacro export* (&rest syms)
+  "Export all symbols"
  (cons 'progn (mapcan #'(lambda (x) `((export ',x))) syms)))

 (defmacro eval-all (syms)
+  "Eval all statements, return in list."
  `(mapcar #'eval '(,@syms)))
-(export? eval-all)
+(export 'eval-all)

 (defmacro export*! (&rest syms) 
+  "Eval all statements export return values"
  `(mapc #'export (eval-all ,syms)))

-(export? export*)
-(export? export*!)
+(export 'export*)
+(export 'export*!)

-(defmacro export*? (&rest val)
-  `(insystem? (export*! ,@val) 
-	      (mapc #'eval '(,@val))))

 (defmacro defexport (&rest val)
+  "Same as export*! for some reason"
  `(export*! ,@val))
-(export? defexport)
+(export 'defexport)

 (defun file-get-contents (filename)
+  "Read file into string"
  (with-open-file (stream filename)
    (let ((contents (make-string (file-length stream))))
      (read-sequence contents stream)
      contents)))
-(export? file-get-contents)
-
-;(export? val-if-or)
-
-(defun utils->system (input output &key (name :flan-utils) (description "Some random utilities") (author "Ringo <flanchan@cumallover.me>") (license "None"))
-  (let ((this (cadddr (read-from-string (file-get-contents input))))
-	(sysdef `(asdf:defsystem ,name
-				 :description ,description
-				 :author ,author
-				 :license ,license
-				 :version ,*-utils-version*
-				 :serial t
-				 :depends-on ,*-utils-depends*
-				 :components ((:file ,(car (last (cl-ppcre:split "/" output))))))))
-    (rplaca this `(defpackage ,name (:use #:cl)))
-    (rplaca (cdr this) `(in-package ,name))
-    (rplaca (cddr this) '(defparameter *-utils-system* t))
-    (with-open-file (output-lisp (concatenate 'string output ".lisp") :direction :output :if-exists :supersede)
-      (with-open-file (output-asd (concatenate 'string output ".asd") :direction :output :if-exists :supersede)
-	(mapc #'(lambda (stmt) (write stmt :stream output-lisp :pretty nil)) this)
-	(write sysdef :stream output-asd :case :downcase )))))
-
-;(defun utils->create-for (utils for &key (name 'flan-utils) ) ;;; TODO: Make this work /for structs/ at all
-;  (let ((this (cadddr (read-from-string (file-get-contents utils))))
-;	(for (read-from-string (file-get-contents for))))
-;    (labels ((sieve (li) ;; find all `,name:' functions in list
-;	       (mapcan #'(lambda (part)
-;			   (if (atom part)
-;			     (if (cl-ppcre:scan (concatenate 'string "^" (write-to-string name) ":")
-;			     			(write-to-string part))
-;			       (list part)
-;			       nil)
-;			     (sieve part)))
-;		       li)))
-;      (let ((syms (sieve for))
-;	    (allowed-definitions '(defun
-;				   defmacro
-;				   defparameter))) ;;;; STRUCT
-;	(labels ((find-func (sym-name l) ;;; TODO: here
-;		   (mapcan #'(lambda (part)
-;			       (when (not (atom part))
-;				 (if (eql (cadr part) sym-name) ;; symbol found
-;				   (list part)
-;				   (when (eql (car part) 'export*?) ;; export*?
-;				     (find-func sym-name part)))))
-;			   l)))
-;	  (let ((defs (mapcan #'(lambda (sym)
-;				  (find-func (read-from-string (cadr (cl-ppcre:split (concatenate 'string "^" (write-to-string name) ":") (write-to-string sym)))) this))
-;			      syms)))
-;	    (mapcan #'(lambda (def)
-;			(when (member (car def) allowed-definitions)))
-;		    defs)))))))
+(export 'file-get-contents)

 (defparameter *old-readtables* nil)

-(export*?
+(defexport

 ;;; --- actual (exported) code goes here --

 (defmacro val-if-or (val test or)
+  "(if (test val) val or)"
  `(let ((vv ,val))
     (if (funcall ,test vv) vv ,or)))

@ -122,9 +53,11 @@
  (not (null f)))

 (defun nop ()
+  "Do nothing"
  nil)

 (defun yep ()
+  "Do nothing"
  t)

 (defun mapline (input fi &key (read-line #'read-line))
@ -133,6 +66,7 @@
 	while line do (funcall fi line)))

 (defun strcat (&rest str)
+  "Concat all strings, if item is not string it is written to one."
  (apply #'concatenate (cons 'string (mapcar #'(lambda (x) 
 						 (typecase x
 						   (string x)
@ -141,21 +75,19 @@
 					     str))))

 (defmacro until (stmt)
+  "Repeat stmt until its return is not NIL, then return that value."
  `(let ((ret nil))
     (loop while (null (setf ret ,stmt)))
     ret))

-(defmacro until-trace (stmt)
-  `(let ((ret nil))
-     (loop while (null (setf ret ,stmt))
-	   collect ret)))
-
 (defmacro popor (li or)
+  "If li is list, pop it, else return or"
  `(if (atom ,li) ,or
     (pop ,li)))

 (defun rand-in (l &key (random #'random) )
  "Random member of, slide right if nil"
+  "Pretty sure this doesn't work"
  (let ((rng (funcall random (list-length l))))
    (let ((nl (nthcdr rng l)))
      (until (pop nl)))))
@ -172,6 +104,7 @@
       (<= num s)))

 (defun format-string (fmt &rest r)
+  "Like sprintf I guess"
  (with-output-to-string (stream)
    (apply #'format `(,stream ,fmt . ,r))))

@ -183,29 +116,33 @@
    lst))

 (defun symbol-match (scan &optional (symbols nil))
+  "Return all symbols whose names match regex `scan'. If symbols are not provided, get them all."
  (let ((symbols (val-if-or symbols #'true 
 			    (get-all-symbols))))
    (where #'(lambda (x) (cl-ppcre:scan scan (write-to-string x)))
 	   symbols)))

 (defun index (i max)
+  "Looping index"
  (if (< i 0)
    (index (+ max i) max)
    (mod i max)))

 (defun slice (seq start end)
-  "only works with lists i guess"
+  "Like JS slice()?"
  (let ((start (index start (length seq)))
 	(end   (index end (length seq))))
    (rplacd (nthcdr end seq) nil)
    (nthcdr start seq)))

 (defun flatten-top-level (li)
+  "'( (1 2) 3 4 (5 6 7) (8) ((9 10))) -> ( 1 2 3 4 5 6 7 8 (9 10))"
  (mapcan #'(lambda (x)
 	      (if (atom x) (list x) x))
 	  li))

 (defun flatten (li)
+  "'( (1 2) 3 4 (5 6 7) (8) ((9 10))) -> ( 1 2 3 4 5 6 7 8 9 10)"
  (mapcan #'(lambda (x)
 	      (if (atom x) 
 		(list x)
@ -213,6 +150,7 @@
 	  li))

 (defun strjoin (delim &rest strs)
+  "Join strings with deliminator"
  (let ((strs (flatten-top-level strs)))
  (apply #'strcat
 	 (slice 
@ -221,10 +159,11 @@
 		   strs)
 	   0 -2))))

-(defun export-struct (struct &optional (symbols nil)) ;;XXX: Exporting make-* is a hack and you should fix it
+(defun export-struct (struct &optional (symbols nil)) ;;XXX: Exporting make-* does not check for $
+  "Export all symbols relating to `struct'"
  (mapc #'export (symbol-match (strcat "^(MAKE-)?" (write-to-string struct) "-?") symbols)))

-(defun -export*-struct (structs &optional (symbols nil)) ;;XXX: Exporting make-* is a hack and you should fix it
+(defun -export*-struct (structs &optional (symbols nil)) ;;XXX
  (mapc #'export (symbol-match 
 		   (strcat
 		     "^(MAKE-)?("
@ -233,6 +172,7 @@
 		   symbols)))

 (defmacro export*-struct (&rest structs)
+  "Export all symbols relating to multiple structs"
  `(-export*-struct '(,@structs)))


@ -245,6 +185,7 @@
    ret))

 (defun cyclic (list)
+  "Simple circular list"
  (cdr (rplacd (last list) list)))

 (defun map1 (lam &rest lists)
@ -279,7 +220,9 @@
 	 (mapcar lam (flatten-top-level args))))

 (defmacro lexical-boundp (lex)
+  "XXX: Use (declare (special ...)) instead"
  `(when (ignore-errors ,lex) t))
+
 ;; --- progressive evals

 (defmacro progen (&rest things)
@ -307,6 +250,7 @@
     (apply #'values --yield-var)))

 (defmacro yield (value)
+  "Yield return value `value' if in yield-return(...) block."
  `(when (boundp '--yield-vars)
      (setf --yield-var (multiple-value-list ,value))
      (push (car --yield-var) --yield-vars)))
@ -328,35 +272,43 @@
 ;; ---

 (defmacro push-unique (thing things &key (key nil) (test #'eql))
+  "Push if not member"
  `(let ((lex-thing ,thing))
     (if (member lex-thing ,things :key ,key :test ,test)
       (values ,things nil)
       (values (push lex-thing ,things) t))))

 (defmacro import* (&rest args)
+  "Import all symbols"
  (cons 'progn (mapcan #'(lambda (x) `((import ',x))) args)))

 (defmacro shadowing-import* (&rest args)
+  "Import all symbols (shadowing)"
  (cons 'progn (mapcan #'(lambda (x) `((shadowing-import ',x))) args)))

 (defmacro import*! (&rest args)
+  "Map eval then import all returns"
  `(mapc #'import (progel ,args)))

 (defmacro shadowing-import*! (&rest args)
+  "Map eval then import all returns (shadowing)"
  `(mapc #'shadowing-import (progel ,args)))

 (defmacro import*-from (package &rest args)
+  "Import all symbols from package. NOTE: You shouldn't prefix the symbols with the package name"
  (let ((ret (mapcar #'(lambda (x) (read-from-string (strcat (subseq (write-to-string package) 1) ":" (write-to-string x)))) args)))
    `(shadowing-import* @,ret)))

-(defun restrain-index (i max)
-  (if nil
-  (if (>= i max) (1- max)
-    (if (< i 0) 0
-      i))
-  i))
+;(defun restrain-index (i max)
+;  
+;  (if nil
+;  (if (>= i max) (1- max)
+;    (if (< i 0) 0
+;      i))
+;  i))

 (defun many-equals (items &key (test #'eql))
+  "For some reason equality comparers don't like more than 2 args"
  (let ((comp (car items)))
    (labels ((compare (x to)
 	       (when (null x) t)
@ -367,18 +319,23 @@
 (defun many-eql (&rest items)
  (many-equals items :test #'eql))

+; --- async stuff
+
 (defstruct async-info 
  thread
  handlers
  lock)

 (defmacro push-handler (name lam)
+  "Push new handler to current async-info with name"
+  "NOTE: Should only be used inside an async() body."
  `(bt:with-lock-held
     ((async-info-lock current-async-info))
     (push (cons ,name ,lam)
 	   (async-info-handlers current-async-info))))

 (defmacro async (&rest form)
+  "Run form(s) async"
  `(let ((current-async-info (make-async-info)))
     (setf (async-info-handlers current-async-info) nil)
     (setf (async-info-lock current-async-info) (bt:make-lock))
@ -389,22 +346,26 @@
     current-async-info))

 (defun async-info-handler (async name &key (test 'eql))
+  "Get handler from async-info of name"
  (bt:with-lock-held ((async-info-lock async))
 		     (let ((as (assoc name (async-info-handlers async) :test test )))
 		       (and as
 			    (cdr as)))))

 (defun wait (handle)
+  "Wait on async()"
  (if (async-info-p handle)
    (wait (async-info-thread handle))
    (bt:join-thread handle)))

 (defun async-kill (handle)
+  "Kill async()"
  (if (async-info-p handle)
    (async-kill (async-info-thread handle))
    (bt:destroy-thread handle)))

 (defun async-alive (handle)
+  "Is async() alive"
  (if (async-info-p handle)
    (async-alive (async-info-thread handle))
    (bt:thread-alive-p handle)))
@ -412,6 +373,7 @@
 (defun val (v) v)

 (defun groupn (n list)
+  "Group list into sublists every `n' items."
  (let ((last nil)
 	(ret nil))
    (loop for x in list
@ -424,6 +386,8 @@
 		 (setf last nil))))
    (reverse ret)))

+; --- reader macros
+
 (defun sexpr-reader (stream char &key (func 'val))
  "Read next token only if S expression, else return as is"
  (if (char= (peek-char t stream t nil t) #\()
@ -435,20 +399,7 @@
 (defun bang-reader (stream char)
  (declare (ignore char))
  (list (quote not) (read stream t nil t)))
-;
-;(defmacro enable-reader (char func &optional (keep t))
-;  `(eval-when (:compile-toplevel :load-toplevel :execute)
-;     (when keep
-;       (push *readtable* *old-readtables*)
-;       (setq *readtable* (copy-readtable)))
-;    (set-macro-character ,char ,func)))
-;
-;(defun disable-reader (&optional (char nil))
-;  (if (null char)
-;    '(eval-when (:compile-toplevel :load-toplevel :execute)
-;       (setq *readtable* (pop *old-readtables*)))
-;    `(set-macro-character ,char nil)))
-;
+
 (defun read-delimiter (stream char)
  (declare (ignore stream char)))

@ -539,6 +490,8 @@
 ;    (make-list length :initial-element 1)
 ;    :debug t))

+; --- others
+
 (defmacro popto (li val &key (test #'eql))
  "pop() list <li> until (car li) is equal to <val>, return elements pop()ed in new list"
  `(loop while (not (funcall ,test (car ,li) ,val))
@ -584,6 +537,4 @@

 ) ;; -- end export

-(mapc #'fmakunbound '(insystem? export? export*?))

-)) ;; -- end guard
--- a/4
+++ b/4
@ -1,4 +0,0 @@
-#!/bin/bash
-
-sbcl --eval "(progn (asdf:load-system :cl-ppcre) (asdf:load-system :bt-semaphore)  (load \"utils.lisp\") (print (utils->system \"utils.lisp\" \"utils/flan-utils\")) (quit))"
-echo