User:Pseudosphere/mwlisp
From The Wiki Camp 2
Jump to navigationJump to search
This is probably the most unreadable program I've ever written (excluding intentionally obfuscated ones like nerpa.c).
This Common Lisp program compiles scripts written in "mwlisp", a lisp dialect I created specifically for generating MediaWiki pages.
mwlisp's syntax is the same as Common Lisp, because I use the Common Lisp READ function to read mwlisp code; however, some mwlisp functions/macros behave differently from their Common Lisp counterparts (for example, LET creates an implicit CAT instead of an implicit PROGN).
Because I'm lazy, some macros don't validate their arguments, and will crash the program with an unhelpful error message if you use the wrong syntax.
mwlisp compiler
The source file is read from *standard-input*, and output wikitext is written to *standard-output*.
When run with a terminal (or some form of "interactive" device) as *standard-input*, the program will present a shitty REPL.
#!/usr/bin/cl
; X X XXXXX XXXXX
; X X X X X X X
; XXXXX X X X X X
; X X X X X X
; X X X X X X
;
; XXX XXXXX XXXXX
; X X X X X X X
; X X X X X X X
; X X X X X X X
; XXXXX XXXXX X X X
;
; XXXXX X XXXXX
; X X X X X X
; XXXXX X X X X
; X X X X X
; X X XXXXX
(setf *random-state* (make-random-state t))
(defparameter *vars* (list (make-hash-table)))
(defparameter *funs* (make-hash-table))
(defparameter *toplevel-funs* (make-hash-table))
(defparameter *toplevel* nil)
(defun symbol-name-downcase (symbol) (string-downcase (symbol-name symbol)))
(defun namep (name) (and name (symbolp name) (not (eq name t))))
(defun parserp (str) (and (not (zerop (length str))) (eql (char str 0) #\{)))
(defun constexprp (s) (or (not s) (eq s t) (numberp s) (not (find-if (lambda (c) (or (eql c #\{) (eql c #\}))) s))))
(defun join (args &optional sep)
(if args (progn
(if sep (let* ((outlist (list (car args))) (endlist outlist))
(loop for arg in (cdr args) do (setf endlist (cdr (setf (cdr endlist) (list sep arg)))))
(setf args outlist)
))
(apply #'concatenate (cons 'string args))
) "")
)
(defun btolwrap (fun) (lambda (&rest args) (if (apply fun args) 1 0)))
(defun genvarname () (format nil "_mwl~X" (random 4294967296)))
(defun getmwvar (symbol &optional no-error)
(loop with var for vars in *vars* do (if (setf var (gethash symbol vars)) (return-from getmwvar var)))
(if (not no-error) (error "Error: ~A is not a defined variable name" (symbol-name symbol)))
)
(defun setmwvar (symbol value) (if value
(if (namep symbol) (setf (gethash symbol (car *vars*)) value) (error "Error: variable name must be a symbol (other than NIL and T), not ~S" symbol))
(remhash symbol (car *vars*))
) nil)
(defun getmwfun (symbol &optional toplevel)
(if (not (symbolp symbol)) (error "Error: can't call non-symbol: ~S" symbol))
(or (gethash symbol *funs*) (let ((fun (gethash symbol *toplevel-funs*))) (if fun
(if toplevel (list fun) (error "Error: macro ~A can only be expanded at top-level" (symbol-name symbol)))
(error "Error: ~A is not a defined function/macro name" (symbol-name symbol))
)))
)
(defun setmwfun (symbol value) (setf (gethash symbol *funs*) value))
(defmacro defmwmacro (name args &body form) `(setmwfun ',name (list (lambda ,args (block ,name ,@form)))))
(defmacro defmwfun (name args &body form) `(setmwfun ',name (cons (lambda ,args (block ,name ,@form)) t)))
(defmacro defmwtopmacro (name args &body form) `(setf (gethash ',name *toplevel-funs*) (lambda ,args (block ,name ,@form))))
(defmacro deftag (name &optional self-closing)
(if self-closing
`(defmwmacro ,name (&optional attributes) `(tag ,',(make-symbol (concatenate 'string (symbol-name name) "/")) ,attributes))
`(defmwmacro ,name (&optional attributes &rest content) `(tag ,',name ,attributes ,@content))
)
)
(defmacro defparsertag (name &optional self-closing)
(if self-closing
`(defmwmacro ,name () `(tag ,',(make-symbol (concatenate 'string (symbol-name name) "/"))))
`(defmwmacro ,name (&rest content) `(tag ,',name () ,@content))
)
)
(defun getvarname (var)
(and (consp var) (eq (car var) 'var) (or (and (cdr var) (not (cddr var)) (cadr var)) (error "Error: bad var syntax: ~S" var)))
)
(defun push-vars () (setf *vars* (cons (make-hash-table) *vars*)))
(defun pop-vars (&optional fallthrough) (setf *vars* (cdr *vars*)) fallthrough)
(defun decmwvar (name &optional value) (let (var)
(if (and (consp name) (if (cdr name) t (progn (setf name (car name)) nil)))
(progn
(setf var (mweval (cadr name)))
(if (not (stringp var)) (error "Error: bad variable name syntax (cadr must evaluate to string): ~S" name))
(setf name (car name))
)
(setf var (genvarname))
)
(setmwvar name `(var ,var))
(if value `(ssetf ,name ,value))
))
(defun letbody (vars form &optional pre-eval)
(if (not (listp vars)) (error "Error: var list is not a list: ~S" vars))
(setf vars (mapcar (lambda (var) (if (symbolp var) `(,var) var)) vars))
(if pre-eval (setf vars (mapcar (lambda (var) (apply (lambda (name &optional value) (cons name (if value (list (mweval value))))) var)) vars)))
(push-vars)
(let* ((outlist (list 'cat)) (listend outlist))
(loop for var in vars do
(setf var (apply #'decmwvar var))
(if var (setf listend (setf (cdr listend) (list var))))
)
(rplacd listend `((cat ,@form)))
(pop-vars (mweval outlist))
)
)
(defun parserform (name sep args)
(if args (let* ((outlist (list (if (parserp name) "{{ " "{{") name sep)) (endcons (cddr outlist)))
(loop with arg = args while arg do
(setf endcons (cdr (setf (cdr endcons) (list (car arg) "|"))))
(setf arg (cdr arg))
)
(rplaca endcons "}}")
(join outlist)
) (concatenate 'string (if (parserp name) "{{ " "{{") name "}}"))
)
(defun mwsetf (pre name value)
(concatenate 'string pre
(let ((form (mwmacroexpand name))) (if (and (consp form) (cdr form) (not (cddr form)) (stringp (cadr form)) (eq (car form) 'var))
(cadr form)
(error "Error: invalid target for setf: ~S" name)
))
"|" (mweval value) "}}")
)
(defun exprreduce (form) (if (numberp form) (flatten form) (concatenate 'string "(" (if (and (consp form) (not (cddr form)) (eq (car form) '_expr)) (mweval (cadr form)) (mweval form)) ")")))
(defmacro defmwunop (name fun expr) `(defmwmacro ,name (x)
(setf x (mwmacroexpand x))
(if (numberp x)
(apply ,fun (list x))
(list '_expr (concatenate 'string ,expr (exprreduce x)))
)
))
(defmacro defmwbinop (name fun expr &optional r-default) `(defmwmacro ,name ,(if r-default `(l &optional (r ,r-default)) '(l r))
(setf l (mwmacroexpand l))
(setf r (mwmacroexpand r))
(if (and (numberp l) (numberp r))
(apply ,fun (list l r))
(list '_expr (concatenate 'string (exprreduce l) ,expr (exprreduce r)))
)
))
(defmacro defmwassoccomop (name fun expr identity) `(defmwmacro ,name (&rest args)
(setf args (mapcar #'mwmacroexpand args))
(if (every #'numberp args)
(apply ,fun args)
(list '_expr (join (let ((num (apply ,fun (remove-if-not #'numberp args))) (str (mapcar #'exprreduce (remove-if #'numberp args)))) (if (= num ,identity)
str
(cons (flatten num) str)
)) ,expr))
)
))
(defmacro defmwacomop (name fun afun expr invexpr identity) `(defmwmacro ,name (&optional l &rest r)
(setf l (mwmacroexpand l))
(setf r (mapcar #'mwmacroexpand r))
(if l
(let ((args (cons l r))) (if (every #'numberp args)
(apply ,fun args)
(if r
(list '_expr (join (let ((num (remove-if-not #'numberp args)) (str (mapcar #'exprreduce (remove-if #'numberp args)))) (if (numberp l)
(cons (flatten (if (cdr num)
(apply ,fun num)
l
)) str)
(let ((num (apply ,afun (cons ,identity num)))) (if (= num ,identity)
str
(nconc str (list (flatten num)))
))
)) ,expr))
(list '_expr (concatenate 'string ,invexpr (exprreduce l)))
)
))
,identity
)
))
;TODO: add whitespace on right if ends in exactly one '}'
;TODO: make all parser function macros use (parserfun); make all parser function functions use a common function to gen output
(defmwfun param (index &optional default) (let ((start (if (parserp index) "{{{ " "{{{"))) (if default (concatenate 'string start index "|" default "}}}") (concatenate 'string start index "}}}"))))
(defmwfun transclude (title &rest args) (parserform title "|" args))
(defmwfun parserfun (title &rest args) (parserform title ":" args))
(defmwfun link (title &rest args) (concatenate 'string "[[" (join (cons title args) "|") "]]"))
(defmwmacro file (title &rest args) `(link ,(concatenate 'string "File:" title) ,@args))
(defmwmacro category (title) `(link ,(concatenate 'string "Category:" title)))
(defmwmacro ! () `(transclude "!"))
(defmwfun var (name) (concatenate 'string "{{#var:" name "}}"))
(defmwmacro cat (&rest args) (join (mapcar (lambda (x) (mweval x (car *toplevel*))) args)))
(defmwfun join (sep &rest args) (join args sep))
(defmwfun void (&rest form) (if form (join (append '("{{#if:") (mapcar #'mweval form) '("}}"))) ""))
(defmwmacro progn (&rest form) (list* 'cat (cons 'void (butlast form)) (last form)))
(defmwmacro style (&rest styles)
(list* 'join ";" (mapcar (lambda (style)
(if (not (and (consp style) (symbolp (car style)) (cdr style))) (error "Error: bad argument to STYLE: ~S" style))
(list* 'cat (symbol-name-downcase (car style)) ":" (cdr style))
) styles))
)
(defmwmacro setf (name value) (mwsetf "{{#vardefineecho:" name value))
(defmwmacro ssetf (name value) (mwsetf "{{#vardefine:" name value))
(defmwmacro varname (var)
(if (not (symbolp var)) (error "Error: argument to VARNAME must be a symbol"))
(or
(getvarname (getmwvar var t))
(error "Error: variable ~A is not bound to a MediaWiki #var" (symbol-name var))
)
)
(defmwmacro let (vars &rest form) (letbody vars form t))
(defmwmacro let* (vars &rest form) (letbody vars form))
(defmwmacro loop (varname start-value iterations &rest form)
(if (not (symbolp varname)) (error "Error: LOOP variable must be a symbol, not ~S" varname))
(if (not (numberp (setf start-value (mwmacroexpand start-value)))) (setf start-value (mweval start-value)))
(setf iterations (mwmacroexpand iterations))
(if (and (integerp iterations) (or (zerop iterations) (= (abs iterations) 1) (getmwvar '*mwlisp-allow-loop-unrolling* t)))
;loop unrolling
;*mwlisp-allow-loop-unrolling* is assumed true if |iterations| is 0 or 1
(if (zerop iterations)
;no iterations, return nothing
""
(if (numberp start-value) (progn
;iterations is an integer and start-value is a number, so if *mwlisp-allow-loop-unrolling* the entire loop is unrolled, substituting for varname its numerical value within the current iteration
(push-vars)
(loop with down = (if (< iterations 0) (setf iterations (- iterations))) with outlist = (list 'cat) for i to (decf iterations) do
(setmwvar varname (if down (- start-value i) (+ start-value i)))
(nconc outlist (list (mweval `(cat ,@form))))
finally
(pop-vars)
(return-from loop outlist)
)
)
;iterations is an integer but start-value is not a number, so if *mwlisp-allow-loop-unrolling* the entire loop is unrolled, substituting for varname an accumulator variable which is updated each iteration
(loop with down = (if (< iterations 0) (setf iterations (- iterations))) with outlist = (list 'cat) for i to (decf iterations) do
(nconc outlist (copy-list form) (if (/= i iterations) (list `(ssetf ,varname (,(if down '- '+) ,start-value ,i 1)))))
finally
(return-from loop `(let ((,varname ,start-value)) ,outlist))
)
))
;no loop unrolling, default to using {{#loop}}
`(let (,varname) (parserfun "#loop" (varname ,varname) ,(mweval start-value) ,iterations (cat ,@form)))
)
)
(defmwmacro repeat (iterations &rest form)
(setf iterations (mwmacroexpand iterations))
(if (and (integerp iterations) (or (zerop iterations) (= (abs iterations) 1) (getmwvar '*mwlisp-allow-loop-unrolling* t)))
(if (zerop iterations)
""
(loop with outlist = (list 'cat) for i to (1- (abs iterations)) do
(nconc outlist (copy-list form))
finally
(return-from repeat outlist)
)
)
`(parserfun "#loop" ,(genvarname) 0 ,iterations (cat ,@form))
)
)
(defmwmacro exists (name &optional if-value else-value)
(join (nconc (list* "{{#varexists:" (if (namep name)
(let ((var (getmwvar name t))) (or var (return-from exists (if else-value else-value ""))))
(if (and (consp name) (cdr name) (not (cddr name)) (stringp (cadr name)) (eq (car name) 'var))
(cadr name)
(error "Error: invalid target for exists: ~S" name))) (if if-value (list* "|" (mweval if-value) (if else-value (list "|" (mweval else-value)))))) '("}}")))
)
(defmwfun _expr (x) (concatenate 'string "{{#expr:" x "}}"))
(defmwmacro expr (x) `(_expr ,x))
(defmwassoccomop + #'+ "+" 0)
(defmwacomop - #'- #'+ "-" "-" 0)
(defmwassoccomop * #'* "*" 1)
(defmwacomop / #'/ #'* "/" "1/" 1)
(defmwbinop expt #'expt "^")
(defmwunop floor #'floor "floor")
(defmwunop truncate #'truncate "trunc")
(defmwbinop round (lambda (n e)
(setf e (expt 1/10 e))
(* (round n e) e)
) "round" 0)
(defmwbinop rem #'rem "fmod")
(defmwbinop truncrem (lambda (l r) (truncate (rem l r))) "mod")
(defmwbinop = (btolwrap #'=) "=")
(defmwbinop /= (btolwrap #'/=) "!=")
(defmwbinop < (btolwrap #'<) "<")
(defmwbinop > (btolwrap #'>) ">")
(defmwbinop <= (btolwrap #'<=) "<=")
(defmwbinop >= (btolwrap #'>=) ">=")
(defmwunop lnot (lambda (x) (if (zerop x) 1 0)) "not")
(defmwassoccomop land (lambda (&rest args) (if (apply 'notany (list #'zerop args)) 1 0)) "and" 1)
(defmwassoccomop lor (lambda (&rest args) (if (apply 'notevery (list #'zerop args)) 1 0)) "or" 0)
(defmwmacro 1+ (number) `(+ ,number 1))
(defmwmacro 1- (number) `(- ,number 1))
(defmwmacro min (&rest args)
(if (not args) (error "Error: MIN requires at least one argument"))
(setf args (mapcar #'mwmacroexpand args))
(if (every #'numberp args)
(apply #'min args)
(let ((nums (remove-if-not #'numberp args)))
(append '(transclude "min") (if nums (list (apply #'min nums))) (remove-if #'numberp args))
)
)
)
(defmwmacro max (&rest args)
(if (not args) (error "Error: MAX requires at least one argument"))
(setf args (mapcar #'mwmacroexpand args))
(if (every #'numberp args)
(apply #'max args)
(let ((nums (remove-if-not #'numberp args)))
(append '(transclude "max") (if nums (list (apply #'max nums))) (remove-if #'numberp args))
)
)
)
(defmwmacro mif (test &optional (then "") (else "")) (if test then else))
(defmwmacro if (test &optional then else)
(setf test (mweval test))
;TODO: figure out exactly which characters are "blank" according to mediawiki
(if (find-if-not (lambda (c) (find c "
")) test)
;NOTE: parser tags (like <skin> or <choose>) are read as non-empty by {{#if}}, even if they would return nothing (I assume they are only expanded after all parser functions are)
(if (constexprp test)
(or then "")
;(join (nconc (list* "{{#if:" test (if then (list* "|" (mweval then) (if else (list "|" (mweval else)))))) '("}}")))
(list* 'parserfun "#if" test (if (or then else) (list* (if then (mweval then) "") (if else (list (mweval else))))))
)
(if else else "")
)
)
(defmwmacro ifeq (test value &optional then else)
(setf test (mwmacroexpand test))
(setf value (mwmacroexpand value))
(if (and (numberp test) (zerop test)) (progn
(setf test value)
(setf value 0)
))
(if (and (not (numberp test)) (numberp value) (zerop value))
(list* 'parserfun "#ifexpr" (mweval (if (and (consp test) (eq (car test) '_expr)) (cadr test) test)) (if (or then else) (list* (if else (mweval else) "") (if then (list (mweval then))))))
(progn
(setf test (mweval test))
(setf value (mweval value))
(if (and (constexprp test) (constexprp value))
(if (equal test value)
(or then "")
(or else "")
)
(list* 'parserfun "#ifeq" test value (if (or then else) (list* (if then (mweval then) "") (if else (list (mweval else))))))
)
))
)
(defmwmacro lif (test &optional then else) `(ifeq ,test 0 ,else ,then))
(defmwmacro switch (value &rest args)
(setf value (mweval value))
(let ((const (constexprp value)) (outlist (list 'cat "{{#switch:" value)))
(loop with endlist = (cddr outlist) for argl on args do (let ((arg (car argl)))
(if (and (consp arg) (listp (car arg)))
(if (car arg) (loop for case in (mapcar #'mweval (car arg)) do
;TODO: can a case value of "#default" be done in #switch with HTML entities or transclusion?
(if (equal case "#default") (error "Error: \"#default\" case conflicts with MediaWiki #switch syntax"))
(if (and const (setf const (constexprp case)) (equal case value)) (return-from switch `(cat ,@(cdr arg))))
(setf endlist (cdr (setf (cdr endlist) (list "|" case))))
finally
(setf endlist (last (setf (cdr endlist) (cons "=" (copy-list (cdr arg))))))
))
(if (eq arg 'default) (progn
(if const (return-from switch `(cat ,@(cdr argl))))
(rplacd endlist (cons "|" (copy-list (cdr argl))))
(loop-finish)
) (error "Error: invalid case: ~S" arg))
)
))
(nconc outlist '("}}"))
)
)
(defmwmacro tag (name &optional attributes &rest content)
(if (symbolp name) (setf name (symbol-name-downcase name)) (error "Error: name parameter to TAG must be a symbol, not ~S" name))
(let ((closepos (position #\/ name)))
(if closepos (progn
(if (/= (1+ closepos) (length name)) (error "Error: self-closing / does not end TAG name: ~S" name))
(if content (error "Error: self-closing TAG ~S not empty" name))
))
(if (not (listp attributes)) (error "Error: attributes parameter to TAG must be a list, not ~S" attributes))
(join (nconc (list* "<" (if closepos (subseq name 0 closepos) name) (mapcar (lambda (c)
(if (or (not (consp c)) (and (cdr c) (cddr c))) (error "Error: bad TAG attribute: ~S" c))
(apply (lambda (key &optional value)
(if (not (symbolp key)) (error "Error: TAG attribute key must be a symbol, not ~S" key))
;TODO: escape quotes n stuff in value?
(join (list* " " (symbol-name-downcase key) (if value (list "=\"" (mweval value) "\""))))
) c)
) attributes)) (if closepos '("/>") (nconc (list* ">" (mapcar #'mweval content)) (list "</" name ">")))))
)
)
(deftag div)
(deftag p)
(deftag span)
(deftag br t)
(deftag table)
(deftag thead)
(deftag tbody)
(deftag tr)
(deftag td)
(defparsertag noinclude)
(defparsertag includeonly)
(defparsertag onlyinclude)
(defmwmacro skin (skin) (if (stringp skin)
(concatenate 'string "<skin>" skin "</skin>")
(error "Error: argument to SKIN must be a string, not ~S" skin)
))
(defmwmacro templatestyles (src) (if (stringp src)
(concatenate 'string "<templatestyles src=\"" src "\"/>")
(error "Error: argument to TEMPLATESTYLES must be a string, not ~S" src)
))
(defmwmacro quote (arg) (error "Error: lisp quoting not supported") arg)
(defun mwsubst (from to object)
(if (consp object)
(cons (mwsubst from to (car object)) (mwsubst from to (cdr object)))
(if (symbolp object)
(let ((i (position object from))) (if i (nth i to) object))
object))
)
(defmwtopmacro defmacrovar (name value) (setmwvar name value) "")
(defmwtopmacro defvar (name &optional value)
(let ((var `(var ,(genvarname))))
(setmwvar name var)
(if value `(ssetf ,var ,value) "")
)
)
(defmwtopmacro defconstant (name value)
(setf value (mwmacroexpand value t))
(if (consp value) (setf value (mweval value t)))
`(,(if (constexprp value) 'defmacrovar 'defvar) ,name ,value)
)
(defmwtopmacro defmacro (name args expansion)
(if (not (namep name)) (error "Error: macro name must be a symbol (other than NIL and T), not ~S" name))
(if (not (listp args)) (error "Error: macro args must be an argument list, not ~S" name))
(let* ((optional nil) (argnames (mapcan (lambda (arg)
(if (namep arg)
(if (eq arg '&optional) (progn (setf optional t) nil) (list arg))
(if (and (consp arg) (namep (car arg)) (consp (cdr arg)) (not (cddr arg)))
(if optional (list (car arg)) (error "Error: default arg values can only be specified for optional arguments"))
(error "Error: not a valid argument name: ~S" arg)
)
)
) args)))
(eval `(defmwmacro ,name ,(mapcar (lambda (arg)
(if (consp arg)
(list (car arg) `',(cadr arg))
arg
)
) args) (mwsubst ',argnames ,(cons 'list argnames) ',expansion)))
)
"")
(defun flatten (form) (format nil "~A" (if (and (numberp form) (not (integerp form))) (let ((x (floor form))) (if (= x form) x (float form))) form)))
(defun mwmacroexpand (form &optional toplevel)
(setf *toplevel* (cons toplevel *toplevel*))
(let ((r (loop while form do
(if (listp form)
(let ((fun (getmwfun (car form) toplevel))) (if (cdr fun)
;function
(return-from mwmacroexpand form)
;macro
(setf form (apply (car fun) (cdr form)))
))
(return-from mwmacroexpand (if (symbolp form)
(if (eq form t)
t
(getmwvar form)
)
form)))
)))
(setf *toplevel* (cdr *toplevel*))
r
)
)
(defun mweval (form &optional toplevel)
(setf form (mwmacroexpand form toplevel))
(if form (if (eq form t) (error "Error: evaluating T is forbidden")
(if (listp form) (let ((fun (getmwfun (car form))))
(if (cdr fun)
;function
(apply (car fun) (mapcar #'mweval (cdr form)))
;macro
(error "Illegal Parser State: macro wasn't expanded")
)
) (if (stringp form)
form
(flatten form)))
) (error "Error: evaluating NIL is forbidden"))
)
(defun rep () (princ (mweval (read *standard-input* nil '(exit)) t)))
(block main
(defmwfun exit () (return-from main))
(if (interactive-stream-p *standard-input*) (loop
(princ "* ")
(finish-output)
(rep)
(princ #\Newline)
))
(loop (rep))
)
(princ #\Newline)
