mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 10:40:45 -08:00
Pull out functionality from clog-builder
This commit is contained in:
David Botton
parent
6da8638712
commit
46adb40636
9 changed files with 1147 additions and 1132 deletions
6
clog.asd
vendored
6
clog.asd
vendored
|
|
@ -76,6 +76,12 @@
|
||||||
;; clog-builder code
|
;; clog-builder code
|
||||||
(:file "clog-builder-settings")
|
(:file "clog-builder-settings")
|
||||||
(:file "clog-builder")
|
(:file "clog-builder")
|
||||||
|
(:file "clog-builder-control-list")
|
||||||
|
(:file "clog-builder-eval")
|
||||||
|
(:file "clog-builder-files")
|
||||||
|
(:file "clog-builder-panels")
|
||||||
|
(:file "clog-builder-render")
|
||||||
|
(:file "clog-builder-ace")
|
||||||
(:file "clog-builder-templates")
|
(:file "clog-builder-templates")
|
||||||
(:file "clog-builder-projects")
|
(:file "clog-builder-projects")
|
||||||
(:file "clog-builder-asdf-browser")
|
(:file "clog-builder-asdf-browser")
|
||||||
|
|
|
||||||
344
tools/clog-builder-ace.lisp
Normal file
344
tools/clog-builder-ace.lisp
Normal file
|
|
@ -0,0 +1,344 @@
|
||||||
|
(in-package :clog-tools)
|
||||||
|
|
||||||
|
(defun setup-lisp-ace (editor status &key (package "CLOG-USER"))
|
||||||
|
(let ((app (connection-data-item editor "builder-app-data")))
|
||||||
|
;; currently there is only one auto complete event for page
|
||||||
|
(unless (auto-complete-configured app)
|
||||||
|
(clog-ace:set-on-auto-complete editor
|
||||||
|
(lambda (obj prefix)
|
||||||
|
(declare (ignore obj))
|
||||||
|
(when (current-editor-is-lisp app)
|
||||||
|
;; we needed to modify Ace's lisp mode to treat : as part of symbol
|
||||||
|
;; otherwise lookups do not consider the symbols package. I did
|
||||||
|
;; using code mathod but then the automatic replace is only on the symbol
|
||||||
|
(let* ((p (when (current-control app)
|
||||||
|
(attribute (get-placer (current-control app)) "data-panel-id")))
|
||||||
|
(s (if (eq (current-editor-is-lisp app) t)
|
||||||
|
(if (current-control app)
|
||||||
|
(string-upcase (attribute (attach-as-child (current-control app) p)
|
||||||
|
"data-in-package"))
|
||||||
|
"CLOG-USER")
|
||||||
|
(current-editor-is-lisp app)))
|
||||||
|
(l (car (swank:simple-completions prefix s))))
|
||||||
|
(when (current-control app)
|
||||||
|
(let ((n (get-control-list app p)))
|
||||||
|
(when n
|
||||||
|
(maphash (lambda (k v)
|
||||||
|
(declare (ignore k))
|
||||||
|
(let ((name (attribute v "data-clog-name")))
|
||||||
|
(push `(:caption ,name :value ,(format nil "(~A panel)" name)
|
||||||
|
:meta "control")
|
||||||
|
l)))
|
||||||
|
n)
|
||||||
|
(push '(:caption "target" :value "target"
|
||||||
|
:meta "builder")
|
||||||
|
l)
|
||||||
|
(push '(:caption "panel" :value "panel"
|
||||||
|
:meta "builder")
|
||||||
|
l))))
|
||||||
|
l)))
|
||||||
|
:meta "swank"))
|
||||||
|
;; run apropos on symbol
|
||||||
|
(js-execute editor
|
||||||
|
(format nil
|
||||||
|
"~A.commands.addCommand({
|
||||||
|
name: 'find-definition',
|
||||||
|
bindKey: {win: 'Alt-.', mac: 'Command-.'},
|
||||||
|
exec: function(editor) {
|
||||||
|
var row = editor.selection.getCursor().row;
|
||||||
|
var column = editor.selection.getCursor().column;
|
||||||
|
var c;
|
||||||
|
while (column > 0) {
|
||||||
|
c=editor.session.getTextRange(new ace.Range(row, column-1, row, column));
|
||||||
|
if (c=='(' || c==' ') { break; }
|
||||||
|
column--;
|
||||||
|
}
|
||||||
|
var s=column;
|
||||||
|
while (column < 200) {
|
||||||
|
c=editor.session.getTextRange(new ace.Range(row, column, row, column+1));
|
||||||
|
if (c==')' || c==' ') { break; }
|
||||||
|
column++;
|
||||||
|
}
|
||||||
|
c = editor.session.getTextRange(new ace.Range(row, s, row, column));
|
||||||
|
~A.trigger('clog-find', c);
|
||||||
|
},
|
||||||
|
readOnly: true,
|
||||||
|
});"
|
||||||
|
(clog-ace::js-ace editor)
|
||||||
|
(jquery editor)))
|
||||||
|
(set-on-event-with-data editor "clog-find"
|
||||||
|
(lambda (obj data)
|
||||||
|
(declare (ignore obj))
|
||||||
|
(when (current-editor-is-lisp app)
|
||||||
|
(on-new-sys-browser editor :search data))))
|
||||||
|
;; setup save key
|
||||||
|
(js-execute editor
|
||||||
|
(format nil
|
||||||
|
"~A.commands.addCommand({
|
||||||
|
name: 'save-ace',
|
||||||
|
bindKey: {win: 'Ctrl-s', mac: 'Command-s'},
|
||||||
|
exec: function(editor) {
|
||||||
|
~A.trigger('clog-save-ace');
|
||||||
|
},
|
||||||
|
readOnly: true,
|
||||||
|
});"
|
||||||
|
(clog-ace::js-ace editor)
|
||||||
|
(jquery editor)))
|
||||||
|
;; eval form
|
||||||
|
(js-execute editor
|
||||||
|
(format nil
|
||||||
|
"~A.commands.addCommand({
|
||||||
|
name: 'eval-form',
|
||||||
|
bindKey: {win: 'Alt-[', mac: 'Command-['},
|
||||||
|
exec: function(editor) {
|
||||||
|
var position = editor.session.doc.positionToIndex (editor.selection.getCursor(), 0);
|
||||||
|
~A.trigger('clog-eval-form', position);
|
||||||
|
},
|
||||||
|
readOnly: true,
|
||||||
|
});"
|
||||||
|
(clog-ace::js-ace editor)
|
||||||
|
(jquery editor)))
|
||||||
|
(set-on-event-with-data editor "clog-eval-form"
|
||||||
|
(lambda (obj data)
|
||||||
|
(declare (ignore obj))
|
||||||
|
(let ((p (parse-integer data :junk-allowed t))
|
||||||
|
(tv (text-value editor))
|
||||||
|
(pk "CLOG-USER")
|
||||||
|
(lf nil)
|
||||||
|
(cp 0))
|
||||||
|
(loop
|
||||||
|
(setf (values lf cp) (read-from-string tv nil nil :start cp))
|
||||||
|
(unless lf (return nil))
|
||||||
|
(when (eq (car lf) 'in-package)
|
||||||
|
(setf pk (second lf)))
|
||||||
|
(when (> cp p) (return lf)))
|
||||||
|
(when lf
|
||||||
|
(let ((result (capture-eval lf
|
||||||
|
:clog-obj (connection-body editor)
|
||||||
|
:eval-in-package (format nil "~A" pk))))
|
||||||
|
(clog-web-alert (connection-body editor) "Result"
|
||||||
|
(format nil "~&result: ~A" result)
|
||||||
|
:color-class "w3-green"
|
||||||
|
:time-out 3))))))
|
||||||
|
;; macroexpand
|
||||||
|
(js-execute editor
|
||||||
|
(format nil
|
||||||
|
"~A.commands.addCommand({
|
||||||
|
name: 'macroexp',
|
||||||
|
bindKey: {win: 'Alt-m', mac: 'Option-m'},
|
||||||
|
exec: function(editor) {
|
||||||
|
var position = editor.session.doc.positionToIndex (editor.selection.getCursor(), 0);
|
||||||
|
~A.trigger('clog-macroexp', position);
|
||||||
|
},
|
||||||
|
readOnly: true,
|
||||||
|
});"
|
||||||
|
(clog-ace::js-ace editor)
|
||||||
|
(jquery editor)))
|
||||||
|
(set-on-event-with-data editor "clog-macroexp"
|
||||||
|
(lambda (obj data)
|
||||||
|
(let ((p (parse-integer data :junk-allowed t))
|
||||||
|
(tv (text-value editor))
|
||||||
|
(lf nil)
|
||||||
|
(cp 0))
|
||||||
|
(loop
|
||||||
|
(setf (values lf cp) (read-from-string tv nil nil :start cp))
|
||||||
|
(unless lf (return nil))
|
||||||
|
(when (> cp p) (return lf)))
|
||||||
|
(let ((result (handler-case
|
||||||
|
(prin1-to-string (macroexpand lf))
|
||||||
|
(error (condition)
|
||||||
|
(format nil "Error: ~A" condition)))))
|
||||||
|
(on-open-file obj :title-class "w3-blue" :title "macroexpand result" :text result)))))
|
||||||
|
;; expand-region
|
||||||
|
(js-execute editor
|
||||||
|
(format nil
|
||||||
|
"~A.commands.addCommand({
|
||||||
|
name: 'expand-region',
|
||||||
|
bindKey: {win: 'Ctrl-=', mac: 'Control-='},
|
||||||
|
exec: function(editor) {
|
||||||
|
var currentRange = editor.selection.getAllRanges()[0];
|
||||||
|
var start = editor.session.doc.positionToIndex(currentRange.start);
|
||||||
|
var end = editor.session.doc.positionToIndex(currentRange.end);
|
||||||
|
var positions = '(' + start + ' ' + end + ')'
|
||||||
|
~A.trigger('clog-expand-region', positions);
|
||||||
|
},
|
||||||
|
readOnly: true,
|
||||||
|
});"
|
||||||
|
(clog-ace::js-ace editor)
|
||||||
|
(jquery editor)))
|
||||||
|
(set-on-event-with-data editor "clog-expand-region"
|
||||||
|
(lambda (obj data)
|
||||||
|
(declare (ignore obj))
|
||||||
|
(let* ((positions (read-from-string data))
|
||||||
|
(new-region
|
||||||
|
(judge-expand-region (text-value editor)
|
||||||
|
(car positions)
|
||||||
|
(cadr positions))))
|
||||||
|
(js-execute editor
|
||||||
|
(format nil
|
||||||
|
"var startIndex = ~A;
|
||||||
|
var endIndex = ~A;
|
||||||
|
var startRange = ~A.session.doc.indexToPosition(startIndex);
|
||||||
|
var endRange = ~:*~A.session.doc.indexToPosition(endIndex);
|
||||||
|
~:*~A.selection.setRange(new ace.Range(startRange.row, startRange.column, endRange.row, endRange.column));"
|
||||||
|
(car new-region)
|
||||||
|
(cdr new-region)
|
||||||
|
(clog-ace::js-ace editor))))))
|
||||||
|
|
||||||
|
(set-on-change editor
|
||||||
|
(lambda (obj)
|
||||||
|
(let ((s (js-query obj (format nil
|
||||||
|
"var row = ~A.selection.getCursor().row; ~
|
||||||
|
var column = ~A.selection.getCursor().column; ~
|
||||||
|
var o = column;
|
||||||
|
var c; var charRange; var b=0; ~
|
||||||
|
while (column > 0) {
|
||||||
|
column--;
|
||||||
|
charRange = new ace.Range(row, column-1, row, column); ~
|
||||||
|
c = ~A.session.getTextRange(charRange); ~
|
||||||
|
if (c==')') { b++ } ~
|
||||||
|
if (c=='(' && b==0) { ~
|
||||||
|
charRange = new ace.Range(row, column, row, o); column=0;~
|
||||||
|
c = ~A.session.getTextRange(charRange);} ~
|
||||||
|
if (c=='(' && b > 0) { b-- } }~
|
||||||
|
c"
|
||||||
|
(clog-ace::js-ace obj)
|
||||||
|
(clog-ace::js-ace obj)
|
||||||
|
(clog-ace::js-ace obj)
|
||||||
|
(clog-ace::js-ace obj)))))
|
||||||
|
(unless (equal s "")
|
||||||
|
(with-input-from-string (i s)
|
||||||
|
(ignore-errors
|
||||||
|
(let* ((pac (if (or (eq (current-editor-is-lisp app) t)
|
||||||
|
(eq (current-editor-is-lisp app) nil))
|
||||||
|
"CLOG-USER"
|
||||||
|
(string-upcase (current-editor-is-lisp app))))
|
||||||
|
(m (read i))
|
||||||
|
(*PACKAGE* (find-package pac))
|
||||||
|
(SWANK::*buffer-package* (find-package pac))
|
||||||
|
(SWANK::*buffer-readtable* *readtable*)
|
||||||
|
(ms (format nil "~A" m))
|
||||||
|
r)
|
||||||
|
(ignore-errors
|
||||||
|
(setf r (swank::autodoc `(,ms swank::%CURSOR-MARKER%))))
|
||||||
|
(if r
|
||||||
|
(setf r (car r))
|
||||||
|
(setf r (swank:operator-arglist ms package)))
|
||||||
|
(when status
|
||||||
|
(setf (advisory-title status) (documentation (find-symbol ms) 'function)))
|
||||||
|
(when r
|
||||||
|
(when status
|
||||||
|
(setf (text status) (string-downcase r)))))))))))
|
||||||
|
(clog-ace:set-auto-completion editor t)
|
||||||
|
(setf (clog-ace:theme editor) *editor-theme*)
|
||||||
|
(setf (clog-ace:mode editor) *editor-mode*)
|
||||||
|
(setf (clog-ace:tab-size editor) *editor-tab-size*)
|
||||||
|
(js-execute editor
|
||||||
|
(format nil "~A.setKeyboardHandler('~A')"
|
||||||
|
(clog-ace::js-ace editor)
|
||||||
|
*editor-keybinding*))
|
||||||
|
(js-execute editor
|
||||||
|
(format nil "~A.setOptions({~A})"
|
||||||
|
(clog-ace::js-ace editor)
|
||||||
|
*editor-renderer-options*))))
|
||||||
|
|
||||||
|
(defun get-package-from-string (c)
|
||||||
|
"Determine the currect package based on src contained in string C"
|
||||||
|
(with-input-from-string (ins c)
|
||||||
|
(loop
|
||||||
|
(let ((form (read ins nil)))
|
||||||
|
(unless form (return "clog-user"))
|
||||||
|
(unless (consp form) (return "clog-user"))
|
||||||
|
(when (eq (car form) 'in-package)
|
||||||
|
(return (string-downcase (second form))))))))
|
||||||
|
|
||||||
|
;; Expand region
|
||||||
|
|
||||||
|
(defun scan-exps (text)
|
||||||
|
"Scan all expressions (and strings) in the text, return a list of start-end cons.
|
||||||
|
|
||||||
|
It parse the string TEXT without using READ functions."
|
||||||
|
(let ((char-count 0)
|
||||||
|
(backslash 0)
|
||||||
|
exps in-dquotes-p left-dquote left-braces left-brackets)
|
||||||
|
(loop for c across text do
|
||||||
|
(if (= backslash 0) ;current char isn't after a backslash
|
||||||
|
(if (eql c #\\)
|
||||||
|
(incf backslash) ;if it is a backslash, mark for the next word
|
||||||
|
(if (eql c #\") ;if it is double quote,
|
||||||
|
(if in-dquotes-p ;end the last string or start a new string
|
||||||
|
(progn (setf in-dquotes-p nil)
|
||||||
|
(push (cons left-dquote (1+ char-count))
|
||||||
|
exps))
|
||||||
|
(setf in-dquotes-p t
|
||||||
|
left-dquote char-count))
|
||||||
|
(if (not in-dquotes-p) ;if it isn't double quote,
|
||||||
|
(case c ;check if it's braces
|
||||||
|
(#\( (push char-count left-braces)) ;mark a new pair
|
||||||
|
(#\) (if left-braces ;end a pair
|
||||||
|
(push (cons (pop left-braces) (1+ char-count))
|
||||||
|
exps)))
|
||||||
|
(#\[ (push char-count left-brackets))
|
||||||
|
(#\] (if left-brackets
|
||||||
|
(push (cons (pop left-brackets) (1+ char-count))
|
||||||
|
exps)))))))
|
||||||
|
(decf backslash))
|
||||||
|
(incf char-count))
|
||||||
|
exps))
|
||||||
|
|
||||||
|
(defun judge-expand-region (text start end)
|
||||||
|
"Judge the next wider region to expand to."
|
||||||
|
(declare (string text) (number start) (number end))
|
||||||
|
(let ((selected (subseq text start end)))
|
||||||
|
(or (let ((word-range ;expand to current word
|
||||||
|
(ignore-errors
|
||||||
|
(let* ((edge-scanner (ppcre:create-scanner "[^\\w]")))
|
||||||
|
(if (not (ppcre:scan edge-scanner selected)) ;there isn't word edge in selected
|
||||||
|
(cons (- start ;search for previous word edge
|
||||||
|
(or (car (ppcre:all-matches
|
||||||
|
edge-scanner
|
||||||
|
(reverse (subseq text 0 start))))
|
||||||
|
start)) ;if nothing, mark from beginning to end.
|
||||||
|
(+ end ;search for next word edge
|
||||||
|
(or (car (ppcre:all-matches edge-scanner
|
||||||
|
(subseq text end)))
|
||||||
|
(- (length text) end)))))))))
|
||||||
|
(if (not (equal word-range (cons start end)))
|
||||||
|
word-range)) ;return if it isn't same with selected
|
||||||
|
(let ((symbol-range ;expand to current symbol
|
||||||
|
;; just like expand to word, but search for blanks, braces and double quote.
|
||||||
|
(ignore-errors
|
||||||
|
(let* ((edge-scanner (ppcre:create-scanner "[\\s\\(\\)\\[\\]\"]")))
|
||||||
|
(if (not (ppcre:scan edge-scanner selected))
|
||||||
|
(cons (- start
|
||||||
|
(or (car (ppcre:all-matches edge-scanner
|
||||||
|
(reverse (subseq text 0 start))))
|
||||||
|
start))
|
||||||
|
(+ end
|
||||||
|
(or (car (ppcre:all-matches edge-scanner
|
||||||
|
(subseq text end)))
|
||||||
|
(- (length text) end)))))))))
|
||||||
|
(if (not (equal symbol-range (cons start end)))
|
||||||
|
symbol-range))
|
||||||
|
(alexandria:if-let ;expand to curren expression/string
|
||||||
|
((sexp (ignore-errors
|
||||||
|
(car (sort (delete nil
|
||||||
|
(mapcar ;find wider expressions contained selected
|
||||||
|
#'(lambda (pair)
|
||||||
|
(if (or (and (< (car pair) start)
|
||||||
|
(> (cdr pair) end))
|
||||||
|
(and (= (car pair) start)
|
||||||
|
(> (cdr pair) end))
|
||||||
|
(and (< (car pair) start)
|
||||||
|
(= (cdr pair) end)))
|
||||||
|
pair))
|
||||||
|
(scan-exps text)))
|
||||||
|
#'(lambda (obj1 obj2) ;sort it to find the smallest
|
||||||
|
(> (car obj1) (car obj2))))))))
|
||||||
|
(if (or (= (car sexp) start) ;judge "inner" or "outer" to select
|
||||||
|
(= (cdr sexp) end)
|
||||||
|
(and (= (1+ (car sexp)) start)
|
||||||
|
(= (1- (cdr sexp)) end)))
|
||||||
|
sexp
|
||||||
|
(cons (1+ (car sexp)) (1- (cdr sexp))))
|
||||||
|
(cons start end))))) ;if no expressions, select all
|
||||||
39
tools/clog-builder-control-list.lisp
Normal file
39
tools/clog-builder-control-list.lisp
Normal file
|
|
@ -0,0 +1,39 @@
|
||||||
|
(in-package :clog-tools)
|
||||||
|
|
||||||
|
;; Control-List utilities
|
||||||
|
|
||||||
|
(defun init-control-list (app panel-id)
|
||||||
|
"Initialize new control list for PANEL-ID on instance of APP."
|
||||||
|
(setf (gethash panel-id (control-lists app)) (make-hash-table :test #'equalp)))
|
||||||
|
|
||||||
|
(defun destroy-control-list (app panel-id)
|
||||||
|
"Destroy the control-list on PANEL-ID"
|
||||||
|
(remhash panel-id (control-lists app)))
|
||||||
|
|
||||||
|
(defun get-control-list (app panel-id)
|
||||||
|
"Rerieve the control-list hash table on PANEL-ID"
|
||||||
|
(let ((h (gethash panel-id (control-lists app))))
|
||||||
|
(if h
|
||||||
|
h
|
||||||
|
(make-hash-table* :test #'equalp)))) ;; return empty hash to avoid map fails
|
||||||
|
|
||||||
|
(defun add-to-control-list (app panel-id control)
|
||||||
|
"Add a CONTROL on to control-list on PANEL-ID"
|
||||||
|
(let ((html-id (format nil "~A" (html-id control))))
|
||||||
|
(setf (gethash html-id (get-control-list app panel-id)) control)))
|
||||||
|
|
||||||
|
(defun get-from-control-list (app panel-id html-id)
|
||||||
|
"Get control identified my HTML-ID from control-list on PANEL-ID"
|
||||||
|
(gethash html-id (get-control-list app panel-id)))
|
||||||
|
|
||||||
|
(defun remove-from-control-list (app panel-id html-id)
|
||||||
|
"Remove a control identified by HTML-ID from control-list on PANEL-ID"
|
||||||
|
(remhash html-id (get-control-list app panel-id)))
|
||||||
|
|
||||||
|
(defun remove-deleted-from-control-list (app panel-id)
|
||||||
|
"Remove any deleted control from control-list"
|
||||||
|
(maphash (lambda (html-id control)
|
||||||
|
(when (equalp (js-query control (format nil "$.contains(document.documentElement, ~A)"
|
||||||
|
(clog::script-id control))) "false")
|
||||||
|
(remove-from-control-list app panel-id html-id)))
|
||||||
|
(get-control-list app panel-id)))
|
||||||
55
tools/clog-builder-eval.lisp
Normal file
55
tools/clog-builder-eval.lisp
Normal file
|
|
@ -0,0 +1,55 @@
|
||||||
|
(in-package :clog-tools)
|
||||||
|
|
||||||
|
;; Lisp code evaluation utilities
|
||||||
|
|
||||||
|
(defun capture-eval (form &key (clog-obj nil) (eval-in-package "clog-user"))
|
||||||
|
"Capture lisp evaluaton of FORM."
|
||||||
|
(let ((result (make-array '(0) :element-type 'base-char
|
||||||
|
:fill-pointer 0 :adjustable t))
|
||||||
|
(eval-result))
|
||||||
|
(with-output-to-string (stream result)
|
||||||
|
(labels ((my-debugger (condition encapsulation)
|
||||||
|
(declare (ignore encapsulation))
|
||||||
|
(if clog-obj
|
||||||
|
(clog-web-alert (connection-body clog-obj) "Error"
|
||||||
|
(format nil "~&Error: ~A" condition)
|
||||||
|
:time-out 3))
|
||||||
|
(format t "~&Error: ~A" condition)))
|
||||||
|
(unless (stringp form)
|
||||||
|
(let ((r (make-array '(0) :element-type 'base-char
|
||||||
|
:fill-pointer 0 :adjustable t)))
|
||||||
|
(with-output-to-string (s r)
|
||||||
|
(print form s))
|
||||||
|
(setf form r)))
|
||||||
|
(let* ((*standard-output* stream)
|
||||||
|
(*error-output* stream)
|
||||||
|
(*debugger-hook* #'my-debugger)
|
||||||
|
(*package* (find-package (string-upcase eval-in-package))))
|
||||||
|
(setf eval-result (eval (read-from-string (format nil "(progn ~A)" form))))
|
||||||
|
(values
|
||||||
|
(format nil "~A~%=>~A~%" result eval-result)
|
||||||
|
*package*))))))
|
||||||
|
|
||||||
|
(defun do-eval (obj form-string cname &key (package "clog-user") custom-boot)
|
||||||
|
"Render, evalute and run code for panel"
|
||||||
|
(let* ((result (capture-eval (format nil "~A~% (clog:set-on-new-window~
|
||||||
|
(lambda (body)~
|
||||||
|
(clog:debug-mode body)~
|
||||||
|
~A
|
||||||
|
(create-~A body)) ~A:path \"/test\")"
|
||||||
|
form-string
|
||||||
|
(if custom-boot
|
||||||
|
""
|
||||||
|
"(clog-gui:clog-gui-initialize body)
|
||||||
|
(clog-web:clog-web-initialize body :w3-css-url nil)")
|
||||||
|
cname
|
||||||
|
(if custom-boot
|
||||||
|
(format nil ":boot-file \"~A\" " custom-boot)
|
||||||
|
""))
|
||||||
|
:eval-in-package package)))
|
||||||
|
(if *app-mode*
|
||||||
|
(open-browser :url (format nil "http://127.0.0.1:~A/test" *clog-port*))
|
||||||
|
(open-window (window (connection-body obj))
|
||||||
|
(format nil "/test" *clog-port*)))
|
||||||
|
(on-open-file obj :title-class "w3-yellow" :title "test eval" :text result)))
|
||||||
|
|
||||||
30
tools/clog-builder-files.lisp
Normal file
30
tools/clog-builder-files.lisp
Normal file
|
|
@ -0,0 +1,30 @@
|
||||||
|
(in-package :clog-tools)
|
||||||
|
|
||||||
|
;; Local file utilities
|
||||||
|
|
||||||
|
(defun read-file (infile &key clog-obj)
|
||||||
|
"Read local file named INFILE"
|
||||||
|
(handler-case
|
||||||
|
(with-open-file (instream infile :direction :input :if-does-not-exist nil)
|
||||||
|
(when instream
|
||||||
|
(let* ((len (file-length instream))
|
||||||
|
(string (make-string len))
|
||||||
|
(pos (read-sequence string instream)))
|
||||||
|
(subseq string 0 pos))))
|
||||||
|
(error (condition)
|
||||||
|
(if clog-obj
|
||||||
|
(alert-toast clog-obj "File Error" (format nil "Error: ~A" condition))
|
||||||
|
(format t "Error: ~A" condition)))))
|
||||||
|
|
||||||
|
(defun write-file (string outfile &key clog-obj (action-if-exists :rename))
|
||||||
|
"Write local file named OUTFILE"
|
||||||
|
(check-type action-if-exists (member nil :error :new-version :rename :rename-and-delete
|
||||||
|
:overwrite :append :supersede))
|
||||||
|
(handler-case
|
||||||
|
(with-open-file (outstream outfile :direction :output :if-exists action-if-exists)
|
||||||
|
(when outstream
|
||||||
|
(write-sequence string outstream)))
|
||||||
|
(error (condition)
|
||||||
|
(if clog-obj
|
||||||
|
(alert-toast clog-obj "File Error" (format nil "Error: ~A" condition))
|
||||||
|
(format t "Error: ~A" condition)))))
|
||||||
478
tools/clog-builder-panels.lisp
Normal file
478
tools/clog-builder-panels.lisp
Normal file
|
|
@ -0,0 +1,478 @@
|
||||||
|
(in-package :clog-tools)
|
||||||
|
|
||||||
|
;; Cross page syncing
|
||||||
|
|
||||||
|
(defvar *app-sync-hash* (make-hash-table* :test #'equal)
|
||||||
|
"Exchange app instance with new external pages")
|
||||||
|
|
||||||
|
;; Handle per content next-id counts
|
||||||
|
|
||||||
|
(defun next-id (content)
|
||||||
|
"Get next id for CONTENT"
|
||||||
|
(parse-integer (attribute content "data-clog-next-id") :junk-allowed t))
|
||||||
|
|
||||||
|
(defun setf-next-id (content id)
|
||||||
|
"Store ID on CONTENT"
|
||||||
|
(setf (attribute content "data-clog-next-id") (format nil "~A" id)))
|
||||||
|
|
||||||
|
(defun incf-next-id (content)
|
||||||
|
"Increment next id and store it in CONTENT"
|
||||||
|
(setf-next-id content (1+ (next-id content))))
|
||||||
|
|
||||||
|
;; Snap-shots
|
||||||
|
|
||||||
|
(defun panel-snap-shot (content panel-id hide-loc)
|
||||||
|
"Take a snap shot of panel"
|
||||||
|
(with-sync-event (content)
|
||||||
|
(let (snap
|
||||||
|
(app (connection-data-item content "builder-app-data")))
|
||||||
|
(maphash
|
||||||
|
(lambda (html-id control)
|
||||||
|
(declare (ignore html-id))
|
||||||
|
(place-inside-bottom-of hide-loc
|
||||||
|
(get-placer control)))
|
||||||
|
(get-control-list app panel-id))
|
||||||
|
(let ((data
|
||||||
|
(create-child content "<data />"
|
||||||
|
:html-id (format nil "I~A" (get-universal-time)))))
|
||||||
|
(place-inside-top-of content data)
|
||||||
|
(setf (attribute data "data-in-package")
|
||||||
|
(attribute content "data-in-package"))
|
||||||
|
(setf (attribute data "data-custom-slots")
|
||||||
|
(attribute content "data-custom-slots"))
|
||||||
|
(setf (attribute data "data-clog-next-id")
|
||||||
|
(attribute content "data-clog-next-id"))
|
||||||
|
(setf (attribute data "data-clog-title")
|
||||||
|
(attribute content "data-clog-name"))
|
||||||
|
(setf snap (js-query content
|
||||||
|
(format nil
|
||||||
|
"var z=~a.clone();~
|
||||||
|
z.find('*').each(function(){~
|
||||||
|
if($(this).attr('data-clog-composite-control') == 't'){$(this).text('')}~
|
||||||
|
if($(this).attr('id') !== undefined && ~
|
||||||
|
$(this).attr('id').substring(0,5)=='CLOGB'){$(this).removeAttr('id')}});~
|
||||||
|
z.html()"
|
||||||
|
(jquery content))))
|
||||||
|
(destroy data))
|
||||||
|
(maphash
|
||||||
|
(lambda (html-id control)
|
||||||
|
(declare (ignore html-id))
|
||||||
|
(place-after control (get-placer control)))
|
||||||
|
(get-control-list app panel-id))
|
||||||
|
snap)))
|
||||||
|
|
||||||
|
(defun save-panel (fname content panel-id hide-loc)
|
||||||
|
"Save panel to FNAME"
|
||||||
|
(write-file (panel-snap-shot content panel-id hide-loc) fname :clog-obj content))
|
||||||
|
|
||||||
|
;; Add controls to panels
|
||||||
|
|
||||||
|
(defun create-control (parent content control-record uid &key custom-query)
|
||||||
|
"Return a new control based on CONTROL-RECORD as a child of PARENT"
|
||||||
|
(let* ((create-type (getf control-record :create-type))
|
||||||
|
(control-type-name (getf control-record :name))
|
||||||
|
(control (cond ((eq create-type :base)
|
||||||
|
(funcall (getf control-record :create) parent
|
||||||
|
:html-id uid))
|
||||||
|
((eq create-type :custom)
|
||||||
|
(funcall (getf control-record :create) parent
|
||||||
|
(getf control-record :create-content)
|
||||||
|
:html-id uid))
|
||||||
|
((eq create-type :custom-block)
|
||||||
|
(let ((c (funcall (getf control-record :create) parent
|
||||||
|
:content custom-query
|
||||||
|
:html-id uid)))
|
||||||
|
(setf (attribute c "data-original-html") custom-query)
|
||||||
|
c))
|
||||||
|
((eq create-type :custom-query)
|
||||||
|
(funcall (getf control-record :create) parent
|
||||||
|
custom-query
|
||||||
|
:html-id uid))
|
||||||
|
((eq create-type :paste)
|
||||||
|
(let ((c (create-child parent custom-query
|
||||||
|
:html-id uid)))
|
||||||
|
(setf control-type-name (attribute c "data-clog-type"))
|
||||||
|
(when (equalp control-type-name "undefined")
|
||||||
|
(setf (attribute c "data-clog-type") "div")
|
||||||
|
(setf control-type-name "div"))
|
||||||
|
(let ((cr (control-info control-type-name)))
|
||||||
|
(change-class c (getf cr :clog-type)))
|
||||||
|
c))
|
||||||
|
((eq create-type :element)
|
||||||
|
(funcall (getf control-record :create) parent
|
||||||
|
:html-id uid
|
||||||
|
:content (if (equal (getf control-record :create-content) "")
|
||||||
|
""
|
||||||
|
(format nil "~A-~A"
|
||||||
|
(getf control-record :create-content)
|
||||||
|
(next-id content)))))
|
||||||
|
((eq create-type :form)
|
||||||
|
(funcall (getf control-record :create) parent
|
||||||
|
(getf control-record :create-param)
|
||||||
|
:html-id uid
|
||||||
|
:value (if (equal (getf control-record :create-value) "")
|
||||||
|
""
|
||||||
|
(format nil "~A-~A"
|
||||||
|
(getf control-record :create-value)
|
||||||
|
(next-id content)))))
|
||||||
|
((eq create-type :textarea)
|
||||||
|
(funcall (getf control-record :create) parent
|
||||||
|
:html-id uid
|
||||||
|
:value (getf control-record :create-value)))
|
||||||
|
(t nil))))
|
||||||
|
(when control
|
||||||
|
(setf (attribute control "data-clog-type") control-type-name)
|
||||||
|
(when (getf control-record :setup)
|
||||||
|
(funcall (getf control-record :setup) control content control-record)))
|
||||||
|
control))
|
||||||
|
|
||||||
|
(defun drop-new-control (app content data &key win)
|
||||||
|
"Create new control dropped at event DATA location on CONTENT of WIN"
|
||||||
|
;; any click on panel directly will focus window
|
||||||
|
(when win
|
||||||
|
(window-focus win))
|
||||||
|
(let* ((control-record (control-info (value (select-tool app))))
|
||||||
|
(control-type-name (getf control-record :create-type)))
|
||||||
|
(cond ((eq control-type-name :custom-query)
|
||||||
|
(input-dialog win "Enter html (must have an outer element):"
|
||||||
|
(lambda (custom-query)
|
||||||
|
(when custom-query
|
||||||
|
(do-drop-new-control
|
||||||
|
app content data
|
||||||
|
:win win
|
||||||
|
:custom-query custom-query)))
|
||||||
|
:width 500
|
||||||
|
:height 300
|
||||||
|
:rows 5
|
||||||
|
:size 40
|
||||||
|
:title "Custom HTML Control"
|
||||||
|
:default-value (getf control-record :create-content)))
|
||||||
|
((eq control-type-name :custom-block)
|
||||||
|
(input-dialog win "Enter html to create control:"
|
||||||
|
(lambda (custom-query)
|
||||||
|
(when custom-query
|
||||||
|
(do-drop-new-control
|
||||||
|
app content data
|
||||||
|
:win win
|
||||||
|
:custom-query custom-query)))
|
||||||
|
:width 500
|
||||||
|
:height 300
|
||||||
|
:rows 5
|
||||||
|
:size 40
|
||||||
|
:title "Custom HTML Block"
|
||||||
|
:default-value (getf control-record :create-content)))
|
||||||
|
(t
|
||||||
|
(do-drop-new-control app content data :win win)))))
|
||||||
|
|
||||||
|
(defun do-drop-new-control (app content data &key win custom-query)
|
||||||
|
"Create new control dropped at event DATA on CONTENT of WIN)"
|
||||||
|
;; create control
|
||||||
|
(let* ((control-record (control-info (value (select-tool app))))
|
||||||
|
(control-type-name (getf control-record :name))
|
||||||
|
(positioning (cond ((or (getf data :ctrl-key)
|
||||||
|
(getf data :meta-key))
|
||||||
|
:static)
|
||||||
|
((getf control-record :positioning)
|
||||||
|
(getf control-record :positioning))
|
||||||
|
(t
|
||||||
|
:absolute)))
|
||||||
|
(parent (when (getf data :shift-key)
|
||||||
|
(current-control app)))
|
||||||
|
(control (create-control (if parent
|
||||||
|
parent
|
||||||
|
content)
|
||||||
|
content
|
||||||
|
control-record
|
||||||
|
(format nil "CLOGB~A~A"
|
||||||
|
(get-universal-time)
|
||||||
|
(next-id content))
|
||||||
|
:custom-query custom-query)))
|
||||||
|
(cond (control
|
||||||
|
;; panel directly clicked with a control type selected
|
||||||
|
;; setup control
|
||||||
|
(setf (attribute control "data-clog-name")
|
||||||
|
(format nil "~A-~A" control-type-name (next-id content)))
|
||||||
|
(setf (value (select-tool app)) "")
|
||||||
|
(setf (box-sizing control) :content-box)
|
||||||
|
(setf (positioning control) positioning)
|
||||||
|
(set-geometry control
|
||||||
|
:left (getf data :x)
|
||||||
|
:top (getf data :y))
|
||||||
|
(when (equalp (attribute control "data-clog-composite-control") "undefined")
|
||||||
|
(add-sub-controls control content :win win))
|
||||||
|
(setup-control content control :win win)
|
||||||
|
(select-control control)
|
||||||
|
(on-populate-control-list-win content :win win)
|
||||||
|
(jquery-execute (get-placer content) "trigger('clog-builder-snap-shot')")
|
||||||
|
t)
|
||||||
|
(t
|
||||||
|
;; panel directly clicked with select tool or no control type to add
|
||||||
|
(deselect-current-control app)
|
||||||
|
(on-populate-control-properties-win content :win win)
|
||||||
|
(on-populate-control-list-win content :win win)
|
||||||
|
nil))))
|
||||||
|
|
||||||
|
(defun setup-control (content control &key win)
|
||||||
|
"Setup CONTROL by creating pacer and setting up events for manipulation"
|
||||||
|
(let ((app (connection-data-item content "builder-app-data"))
|
||||||
|
(panel-id (html-id content))
|
||||||
|
(touch-x 0)
|
||||||
|
(touch-y 0)
|
||||||
|
(placer (create-div control :auto-place nil
|
||||||
|
:class "placer"
|
||||||
|
:html-id (format nil "p-~A" (html-id control)))))
|
||||||
|
(add-to-control-list app panel-id control)
|
||||||
|
(setf (attribute placer "data-panel-id") panel-id)
|
||||||
|
;; setup placer
|
||||||
|
(set-geometry placer :top (position-top control)
|
||||||
|
:left (position-left control)
|
||||||
|
:width (client-width control)
|
||||||
|
:height (client-height control))
|
||||||
|
(place-after control placer)
|
||||||
|
(setf (box-sizing placer) :content-box)
|
||||||
|
(setf (positioning placer) :absolute)
|
||||||
|
(jquery-execute placer (format nil "draggable({snap:'.placer',snapMode:'inner',cursor:'crosshair'})~
|
||||||
|
.resizable({alsoResize:'#~A',autoHide:true})"
|
||||||
|
(html-id control)))
|
||||||
|
;; setup placer events
|
||||||
|
(setf (tab-index placer) "-1") ; must have a tab-index to accept keyboard input
|
||||||
|
(focus placer)
|
||||||
|
(set-on-key-down placer
|
||||||
|
(lambda (obj data)
|
||||||
|
(declare (ignore obj))
|
||||||
|
(let ((key (getf data :key))
|
||||||
|
(ctrl (getf data :ctrl-key))
|
||||||
|
(meta (getf data :meta-key))
|
||||||
|
(shift (getf data :shift-key)))
|
||||||
|
(cond ((equal key "ArrowUp")
|
||||||
|
(if shift
|
||||||
|
(set-geometry control :height (1- (height control)))
|
||||||
|
(set-geometry control :top (1- (position-top control)))))
|
||||||
|
((equal key "ArrowDown")
|
||||||
|
(if shift
|
||||||
|
(set-geometry control :height (+ (height control) 2))
|
||||||
|
(set-geometry control :top (+ (position-top control) 2))))
|
||||||
|
((equal key "ArrowRight")
|
||||||
|
(if shift
|
||||||
|
(set-geometry control :width (+ (width control) 2))
|
||||||
|
(set-geometry control :left (+ (position-left control) 2))))
|
||||||
|
((equal key "ArrowLeft")
|
||||||
|
(if shift
|
||||||
|
(set-geometry control :width (1- (width control)))
|
||||||
|
(set-geometry control :left (1- (position-left control)))))
|
||||||
|
((and (equal key "c")
|
||||||
|
(or meta ctrl))
|
||||||
|
(blur placer))
|
||||||
|
((and (equal key "v")
|
||||||
|
(or meta ctrl))
|
||||||
|
(blur placer))
|
||||||
|
((and (equal key "x")
|
||||||
|
(or meta ctrl))
|
||||||
|
(blur placer)))
|
||||||
|
(set-geometry placer :top (position-top control)
|
||||||
|
:left (position-left control)
|
||||||
|
:width (client-width control)
|
||||||
|
:height (client-height control))
|
||||||
|
(jquery-execute placer "trigger('clog-builder-snap-shot')")
|
||||||
|
(set-properties-after-geomentry-change control))))
|
||||||
|
(set-on-touch-start placer (lambda (obj data)
|
||||||
|
(declare (ignore obj))
|
||||||
|
(setf touch-x (getf data :X))
|
||||||
|
(setf touch-y (getf data :Y))))
|
||||||
|
(set-on-touch-move placer (lambda (obj data)
|
||||||
|
(declare (ignore obj))
|
||||||
|
(set-geometry control :top (+ (position-top control)
|
||||||
|
(- (getf data :y) touch-y))
|
||||||
|
:left (+ (position-left control)
|
||||||
|
(- (getf data :x) touch-x)))
|
||||||
|
(setf touch-x (getf data :X))
|
||||||
|
(setf touch-y (getf data :Y))))
|
||||||
|
(set-on-touch-end placer (lambda (obj data)
|
||||||
|
(declare (ignore obj data))
|
||||||
|
(set-geometry placer :units ""
|
||||||
|
:top (top control)
|
||||||
|
:left (left control))
|
||||||
|
(select-control control)
|
||||||
|
(jquery-execute placer "trigger('clog-builder-snap-shot')")
|
||||||
|
(set-properties-after-geomentry-change control)))
|
||||||
|
(set-on-mouse-up placer (lambda (obj data)
|
||||||
|
(declare (ignore obj data))
|
||||||
|
(set-geometry control :units ""
|
||||||
|
:top (top placer)
|
||||||
|
:left (left placer))
|
||||||
|
(set-geometry placer :units ""
|
||||||
|
:top (top control)
|
||||||
|
:left (left control))
|
||||||
|
(select-control control)
|
||||||
|
(jquery-execute placer "trigger('clog-builder-snap-shot')")
|
||||||
|
(set-properties-after-geomentry-change control)))
|
||||||
|
(set-on-mouse-down placer
|
||||||
|
(lambda (obj data)
|
||||||
|
(declare (ignore obj))
|
||||||
|
(let ((last (current-control app))
|
||||||
|
(shift (getf data :shift-key)))
|
||||||
|
(if (not (equal (value (select-tool app)) ""))
|
||||||
|
(when (do-drop-new-control app content data :win win)
|
||||||
|
(incf-next-id content)))
|
||||||
|
(cond ((and last
|
||||||
|
shift)
|
||||||
|
(let* ((control1 last)
|
||||||
|
(control2 control)
|
||||||
|
(placer1 (get-placer control1))
|
||||||
|
(placer2 (get-placer control2)))
|
||||||
|
(place-inside-bottom-of control1 control2)
|
||||||
|
(place-after control2 placer2)
|
||||||
|
(place-after control2 placer2)
|
||||||
|
(set-geometry placer1 :top (position-top control1)
|
||||||
|
:left (position-left control1)
|
||||||
|
:width (client-width control1)
|
||||||
|
:height (client-height control1))
|
||||||
|
(set-geometry placer2 :top (position-top control2)
|
||||||
|
:left (position-left control2)
|
||||||
|
:width (client-width control2)
|
||||||
|
:height (client-height control2)))
|
||||||
|
(select-control control)
|
||||||
|
(on-populate-control-properties-win content :win win)
|
||||||
|
(on-populate-control-list-win content :win win))
|
||||||
|
(t
|
||||||
|
(select-control control)))
|
||||||
|
(when win
|
||||||
|
(window-focus win))))
|
||||||
|
:cancel-event t)
|
||||||
|
(set-on-mouse-double-click placer
|
||||||
|
(lambda (obj data)
|
||||||
|
(declare (ignore obj data))
|
||||||
|
(setf (hiddenp placer) t)
|
||||||
|
(on-populate-control-list-win content :win win)))
|
||||||
|
(set-on-event placer "resize"
|
||||||
|
(lambda (obj)
|
||||||
|
(set-properties-after-geomentry-change obj)))
|
||||||
|
(set-on-event placer "resizestop"
|
||||||
|
(lambda (obj)
|
||||||
|
(set-properties-after-geomentry-change obj)
|
||||||
|
(jquery-execute placer "trigger('clog-builder-snap-shot')"))
|
||||||
|
:cancel-event t)
|
||||||
|
(set-on-event placer "drag"
|
||||||
|
(lambda (obj)
|
||||||
|
(declare (ignore obj))
|
||||||
|
(set-geometry control :units ""
|
||||||
|
:top (top placer)
|
||||||
|
:left (left placer))
|
||||||
|
(set-properties-after-geomentry-change control)))))
|
||||||
|
|
||||||
|
(defun on-populate-loaded-window (content &key win)
|
||||||
|
"Setup html imported in to CONTENT for use with Builder"
|
||||||
|
(with-sync-event (content)
|
||||||
|
(add-sub-controls content content :win win)))
|
||||||
|
|
||||||
|
(defun set-property-display (control property value)
|
||||||
|
"Set property in the currently displayed property panel"
|
||||||
|
(js-execute control (format nil "$('.clog-prop-~A').text('~A')"
|
||||||
|
property value)))
|
||||||
|
|
||||||
|
(defun set-properties-after-geomentry-change (control)
|
||||||
|
"Set properties window geometry setting"
|
||||||
|
(set-property-display control "top" (top control))
|
||||||
|
(set-property-display control "left" (left control))
|
||||||
|
(set-property-display control "right" (right control))
|
||||||
|
(set-property-display control "bottom" (bottom control))
|
||||||
|
(set-property-display control "width" (client-width control))
|
||||||
|
(set-property-display control "height" (client-height control)))
|
||||||
|
|
||||||
|
;; Control selection utilities
|
||||||
|
|
||||||
|
(defun get-placer (control)
|
||||||
|
"Get placer for CONTROL. A placer is a div placed on top of CONTROL and
|
||||||
|
prevents access to use or activate the control directy and allows
|
||||||
|
manipulation of the control's location and size."
|
||||||
|
(when control
|
||||||
|
(attach-as-child control (format nil "p-~A" (html-id control)))))
|
||||||
|
|
||||||
|
(defun deselect-current-control (app)
|
||||||
|
"Remove selection on current control and remove visual ques on its placer."
|
||||||
|
(when (current-control app)
|
||||||
|
(set-border (get-placer (current-control app)) (unit "px" 0) :none :blue)
|
||||||
|
(setf (current-control app) nil)))
|
||||||
|
|
||||||
|
(defun delete-current-control (app panel-id html-id)
|
||||||
|
"Delete the current control"
|
||||||
|
(remove-from-control-list app panel-id html-id)
|
||||||
|
(destroy (get-placer (current-control app)))
|
||||||
|
(destroy (current-control app))
|
||||||
|
(setf (current-control app) nil)
|
||||||
|
(remove-deleted-from-control-list app panel-id))
|
||||||
|
|
||||||
|
(defun select-control (control)
|
||||||
|
"Select CONTROL as the current control and highlight its placer.
|
||||||
|
The actual original clog object used for creation must be used and
|
||||||
|
not a temporarily attached one when using select-control."
|
||||||
|
(let ((app (connection-data-item control "builder-app-data"))
|
||||||
|
(placer (get-placer control)))
|
||||||
|
(unless (eq control (current-control app))
|
||||||
|
(deselect-current-control app)
|
||||||
|
(set-geometry placer :top (position-top control)
|
||||||
|
:left (position-left control)
|
||||||
|
:width (client-width control)
|
||||||
|
:height (client-height control))
|
||||||
|
(setf (current-control app) control)
|
||||||
|
(set-border placer (unit "px" 2) :solid :blue)
|
||||||
|
(on-populate-control-properties-win control))))
|
||||||
|
|
||||||
|
(defun add-sub-controls (parent content &key win paste)
|
||||||
|
"Setup html imported in to CONTENT starting with PARENT for use with Builder"
|
||||||
|
(let ((panel-uid (get-universal-time)))
|
||||||
|
;; Assign any elements with no id, an id, name and type
|
||||||
|
(let ((tmp (format nil
|
||||||
|
"var clog_id=~A; var clog_nid=1;~
|
||||||
|
$(~A).find('*').each(function() {var e=$(this);~
|
||||||
|
var t=e.prop('tagName').toLowerCase(); var p=e.attr('data-clog-type');~
|
||||||
|
if((e.attr('id') === undefined) && (e.attr('data-clog-name') === undefined))~
|
||||||
|
{e.attr('id','CLOGB'+clog_id++);~
|
||||||
|
e.attr('data-clog-name','none-'+t+'-'+clog_nid++)}~
|
||||||
|
if(e.attr('id') === undefined){e.attr('id','CLOGB'+clog_id++)}~
|
||||||
|
if(e.attr('data-clog-name') === undefined){e.attr('data-clog-name',e.attr('id'))}~
|
||||||
|
~A ~
|
||||||
|
~{~A~}~
|
||||||
|
if(e.attr('data-clog-type') === undefined){e.attr('data-clog-type','span')}})"
|
||||||
|
(1+ panel-uid)
|
||||||
|
(jquery parent)
|
||||||
|
(if paste
|
||||||
|
(prog1
|
||||||
|
(format nil "e.attr('data-clog-name', e.attr('data-clog-name')+'-'+~A);"
|
||||||
|
(next-id content))
|
||||||
|
(incf-next-id content))
|
||||||
|
"")
|
||||||
|
(mapcar (lambda (l)
|
||||||
|
(format nil "if(p === undefined && t=='~A'){e.attr('data-clog-type','~A')}"
|
||||||
|
(getf l :tag) (getf l :control)))
|
||||||
|
*import-types*))))
|
||||||
|
(js-execute parent tmp))
|
||||||
|
(unless paste
|
||||||
|
(let* ((data (first-child content))
|
||||||
|
(name (attribute data "data-clog-title"))
|
||||||
|
(next-id (attribute data "data-clog-next-id"))
|
||||||
|
(slots (attribute data "data-custom-slots"))
|
||||||
|
(package (attribute data "data-in-package")))
|
||||||
|
(unless (equalp next-id "undefined")
|
||||||
|
(setf-next-id content next-id))
|
||||||
|
(unless (equalp package "undefined")
|
||||||
|
(setf (attribute content "data-in-package") package))
|
||||||
|
(unless (equalp slots "undefined")
|
||||||
|
(setf (attribute content "data-custom-slots") slots))
|
||||||
|
(unless (equalp name "undefined")
|
||||||
|
(setf (attribute content "data-clog-name") name)
|
||||||
|
(destroy data))))
|
||||||
|
(labels ((add-siblings (control)
|
||||||
|
(let (dct)
|
||||||
|
(loop
|
||||||
|
(when (equal (html-id control) "undefined") (return))
|
||||||
|
(setf dct (attribute control "data-clog-type"))
|
||||||
|
(unless (equal dct "undefined")
|
||||||
|
(change-class control (getf (control-info dct) :clog-type))
|
||||||
|
(when (getf (control-info dct) :on-load)
|
||||||
|
(funcall (getf (control-info dct) :on-load) control (control-info dct)))
|
||||||
|
(setup-control content control :win win)
|
||||||
|
(unless (equal dct "block")
|
||||||
|
(add-siblings (first-child control))))
|
||||||
|
(setf control (next-sibling control))))))
|
||||||
|
(add-siblings (first-child parent)))))
|
||||||
134
tools/clog-builder-render.lisp
Normal file
134
tools/clog-builder-render.lisp
Normal file
|
|
@ -0,0 +1,134 @@
|
||||||
|
(in-package :clog-tools)
|
||||||
|
|
||||||
|
;; Code rendering utlities
|
||||||
|
|
||||||
|
(defun render-clog-code (content hide-loc)
|
||||||
|
"Render panel to clog code and add tp CW window"
|
||||||
|
(let* ((app (connection-data-item content "builder-app-data"))
|
||||||
|
(panel-id (html-id content))
|
||||||
|
(package (attribute content "data-in-package"))
|
||||||
|
(slots (attribute content "data-custom-slots"))
|
||||||
|
(cname (attribute content "data-clog-name"))
|
||||||
|
cmembers vars creates events)
|
||||||
|
(unless (or (equal slots "")
|
||||||
|
(equal slots "undefined"))
|
||||||
|
(push slots cmembers))
|
||||||
|
(maphash (lambda (html-id control)
|
||||||
|
(declare (ignore html-id))
|
||||||
|
(place-inside-bottom-of hide-loc
|
||||||
|
(get-placer control)))
|
||||||
|
(get-control-list app panel-id))
|
||||||
|
;; crawl tree
|
||||||
|
;; Insure that on-setup/on-create follow order in tree
|
||||||
|
(labels ((add-siblings (control)
|
||||||
|
(let (dct)
|
||||||
|
(loop
|
||||||
|
(unless control (return))
|
||||||
|
(when (equal (html-id control) "undefined") (return))
|
||||||
|
(setf dct (attribute control "data-clog-name"))
|
||||||
|
(unless (equal dct "undefined")
|
||||||
|
(setf control (get-from-control-list app panel-id (html-id control)))
|
||||||
|
(when control
|
||||||
|
(let ((vname (attribute control "data-clog-name"))
|
||||||
|
(control-record (control-info (attribute control "data-clog-type"))))
|
||||||
|
(unless (and (>= (length vname) 5)
|
||||||
|
(equalp (subseq vname 0 5) "none-"))
|
||||||
|
;; Add to members of the panel's class for each control
|
||||||
|
(push (format nil
|
||||||
|
" \(~A :reader ~A\)~%"
|
||||||
|
vname
|
||||||
|
vname)
|
||||||
|
cmembers)
|
||||||
|
;; On instance of class, set member value for each control
|
||||||
|
(push (format nil
|
||||||
|
" \(setf (slot-value panel '~A\) ~
|
||||||
|
\(attach-as-child clog-obj \"~A\" :clog-type \'~A\ :new-id t)\)~%"
|
||||||
|
vname
|
||||||
|
(html-id control)
|
||||||
|
(format nil "~S" (getf control-record :clog-type)))
|
||||||
|
vars)
|
||||||
|
;; On instance of class, set handers defined for each control
|
||||||
|
(dolist (event (getf control-record :events))
|
||||||
|
;; Set regular handlers
|
||||||
|
(let ((handler (attribute control (format nil "data-~A" (getf event :name)))))
|
||||||
|
(unless (or (equalp handler "undefined")
|
||||||
|
(equal handler ""))
|
||||||
|
(unless (equalp (getf event :name) "on-create")
|
||||||
|
(let ((event-package (or (getf event :package) "clog")))
|
||||||
|
(push (format nil
|
||||||
|
" \(~A:set-~A \(~A panel\) \(lambda \(~A\) \(declare \(ignorable ~A\)\) ~A\)\)~%"
|
||||||
|
event-package
|
||||||
|
(getf event :name)
|
||||||
|
vname
|
||||||
|
(getf event :parameters)
|
||||||
|
(getf event :parameters)
|
||||||
|
handler)
|
||||||
|
events))))))
|
||||||
|
;; Set on-create (from user in builder) and on-setup (from control-record)
|
||||||
|
(let ((handler (attribute control "data-on-create")))
|
||||||
|
(when (equalp handler "undefined")
|
||||||
|
(setf handler ""))
|
||||||
|
(when (getf control-record :on-setup)
|
||||||
|
(setf handler (format nil "~A~A"
|
||||||
|
(funcall (getf control-record :on-setup)
|
||||||
|
control control-record)
|
||||||
|
handler)))
|
||||||
|
(unless (equal handler "")
|
||||||
|
(push (format nil
|
||||||
|
" \(let \(\(target \(~A panel\)\)\) ~
|
||||||
|
\(declare \(ignorable target\)\) ~
|
||||||
|
~A\)~%"
|
||||||
|
vname
|
||||||
|
handler)
|
||||||
|
creates)))))
|
||||||
|
(add-siblings (first-child control))))
|
||||||
|
(when control
|
||||||
|
(setf control (next-sibling control)))))))
|
||||||
|
(add-siblings (first-child content)))
|
||||||
|
(let ((result (format nil
|
||||||
|
"\(in-package :~A)
|
||||||
|
\(defclass ~A \(clog:clog-panel\)
|
||||||
|
\(~{~A~}\)\)
|
||||||
|
\(defun create-~A \(clog-obj &key \(hidden nil\) \(class nil\) \(html-id nil\) \(auto-place t\)\)
|
||||||
|
\(let \(\(panel \(change-class \(clog:create-div clog-obj :content \"~A\"
|
||||||
|
:hidden hidden :class class :html-id html-id :auto-place auto-place\) \'~A\)\)\)
|
||||||
|
~{~A~}~{~A~}~{~A~} panel\)\)~%"
|
||||||
|
(string-downcase package)
|
||||||
|
cname ;;defclass
|
||||||
|
cmembers
|
||||||
|
cname ;;defun
|
||||||
|
(ppcre:regex-replace-all "\""
|
||||||
|
(js-query content
|
||||||
|
(format nil
|
||||||
|
"var z=~a.clone();~
|
||||||
|
z.find('*').each(function(){~
|
||||||
|
var m=$(this).attr('data-clog-name');
|
||||||
|
if($(this).attr('data-clog-composite-control') == 't'){$(this).text('')}~
|
||||||
|
if($(this).attr('data-clog-composite-control') == 'b'){$(this).html($(this).attr('data-original-html'))}~
|
||||||
|
for(n in $(this).get(0).dataset){delete $(this).get(0).dataset[n]}~
|
||||||
|
if(m){$(this).attr('data-clog-name', m);}~
|
||||||
|
});~
|
||||||
|
z.html()"
|
||||||
|
(jquery content)))
|
||||||
|
"\\\"")
|
||||||
|
cname
|
||||||
|
vars
|
||||||
|
(reverse creates) ; Insure that on-setup/on-create follow order in tree
|
||||||
|
(reverse events))))
|
||||||
|
(maphash (lambda (html-id control)
|
||||||
|
(declare (ignore html-id))
|
||||||
|
(place-after control (get-placer control)))
|
||||||
|
(get-control-list app panel-id))
|
||||||
|
;; prety print the code
|
||||||
|
(let ((r (make-array '(0) :element-type 'base-char
|
||||||
|
:fill-pointer 0 :adjustable t)))
|
||||||
|
(with-output-to-string (s r)
|
||||||
|
(with-input-from-string (n result)
|
||||||
|
(let ((*standard-output* s)
|
||||||
|
(*print-case* :downcase))
|
||||||
|
(format t ";;;; CLOG Builder generated code - modify original .clog file and rerender")
|
||||||
|
(loop
|
||||||
|
(let ((l (read n nil)))
|
||||||
|
(unless l (return))
|
||||||
|
(pprint l))))))
|
||||||
|
r))))
|
||||||
|
|
@ -1,5 +1,59 @@
|
||||||
(in-package :clog-tools)
|
(in-package :clog-tools)
|
||||||
|
|
||||||
|
;; Template Utilities
|
||||||
|
|
||||||
|
(defun walk-files-and-directories (path process)
|
||||||
|
"Walk PATH and apply PROCESS on each (path and file)"
|
||||||
|
(let* ((flist (uiop:directory-files path))
|
||||||
|
(dlist (uiop:subdirectories path)))
|
||||||
|
(dolist (f flist)
|
||||||
|
(funcall process path (file-namestring f)))
|
||||||
|
(dolist (d dlist)
|
||||||
|
(walk-files-and-directories d process))))
|
||||||
|
|
||||||
|
(defun template-copy (sys-name start-dir filename &key panel)
|
||||||
|
"Copy START-DIR to FILENAME processing .lt files as cl-template files,
|
||||||
|
if PANEL each copy produces a <b>source</b> to destination added as
|
||||||
|
create-div's"
|
||||||
|
(walk-files-and-directories
|
||||||
|
start-dir
|
||||||
|
(lambda (path file)
|
||||||
|
(let* ((tmpl-ext "lt")
|
||||||
|
(src-file (format nil "~A~A"
|
||||||
|
path file))
|
||||||
|
(out-dir (format nil "~A/~A/~A"
|
||||||
|
filename
|
||||||
|
sys-name
|
||||||
|
(subseq (format nil "~A" path)
|
||||||
|
(length start-dir))))
|
||||||
|
(out-file (format nil "~A~A"
|
||||||
|
out-dir
|
||||||
|
file)))
|
||||||
|
(ensure-directories-exist out-dir)
|
||||||
|
(cond ((equalp (pathname-type file) tmpl-ext)
|
||||||
|
(let* ((nfile (pathname-name file))
|
||||||
|
(afile (cond ((equalp (pathname-name nfile) "tmpl")
|
||||||
|
(format nil "~A~A.~A" out-dir sys-name (pathname-type nfile)))
|
||||||
|
((equalp (pathname-name nfile) "tmpl-tools")
|
||||||
|
(format nil "~A~A-tools.~A" out-dir sys-name (pathname-type nfile)))
|
||||||
|
(t
|
||||||
|
(format nil "~A~A" out-dir nfile)))))
|
||||||
|
(write-file (funcall (cl-template:compile-template (read-file src-file :clog-obj panel))
|
||||||
|
(list :sys-name sys-name))
|
||||||
|
afile :clog-obj panel)
|
||||||
|
(when panel
|
||||||
|
(create-div panel
|
||||||
|
:content (format nil "<b>~A</b> -> ~A"
|
||||||
|
src-file afile)))))
|
||||||
|
(t
|
||||||
|
(uiop:copy-file src-file out-file)
|
||||||
|
(when panel
|
||||||
|
(create-div panel
|
||||||
|
:content (format nil "<b>~A</b> -> ~A"
|
||||||
|
src-file out-file)))))))))
|
||||||
|
|
||||||
|
;; Handle panel-clog-templates events
|
||||||
|
|
||||||
(defun fill-button-clicked (panel)
|
(defun fill-button-clicked (panel)
|
||||||
"Template fill botton clicked"
|
"Template fill botton clicked"
|
||||||
(let* ((app (connection-data-item panel "builder-app-data"))
|
(let* ((app (connection-data-item panel "builder-app-data"))
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load diff
Loading…
Add table
Add a link
Reference in a new issue