changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/bin/skel.lisp

changeset 337: 4fc0ccc55bca
parent: 1e5e4bbcdf8b
child: 1d281be30842
author: Richard Westhaver <ellis@rwest.io>
date: Mon, 13 May 2024 17:07:11 -0400
permissions: -rw-r--r--
description: edits to cli/clap arg processing
1 ;;; Code:
2 
3 ;; TODO 2024-05-09: add shell configurables to rules - maybe at sk-command
4 ;; level. :INPUT :WAIT :OUTPUT
5 
6 (uiop:define-package :bin/skel
7  (:use :cl :std :cli/clap :vc :sb-ext)
8  (:import-from :cli/shell :*shell-input*)
9  (:use-reexport :skel :log)
10  (:export :main))
11 
12 (in-package :bin/skel)
13 (in-readtable :shell)
14 
15 (defopt skc-help (print-help $cli) $val)
16 (defopt skc-version (print-version $cli))
17 (defopt skc-level *log-level* (setq *log-level* (if $val (if (stringp $val)
18  (sb-int:keywordicate (string-upcase $val))
19  $val)
20  :info)))
21 
22 ;; TODO 2023-10-13: almost there
23 (defopt skc-config
24  (init-user-skelrc (when $val (parse-file-opt $val))))
25 
26 (defcmd skc-edit
27  (let ((file (or (when $args (pop $args)) (find-skelfile #P"."))))
28  (cli/ed:run-emacsclient (namestring file))))
29 
30 (defcmd skc-init
31  (let ((file (when $args (pop $args)))
32  (name (if (> $argc 1) (pop $args))))
33  (handler-bind
34  ((sb-ext:file-exists
35  #'(lambda (s)
36  (uiop:println (format nil "file already exists: ~A" (or file *default-skelfile*)))
37  (let ((f2 (read-line)))
38  (if (string= f2 "")
39  (error s)
40  (use-value f2 s))))))
41  (init-skelfile file name))))
42 
43 (defcmd skc-describe
44  (describe
45  (find-skelfile
46  (if $args (pathname (car $args))
47  #P".")
48  :load t)))
49 
50 (defcmd skc-inspect
51  (sb-ext:enable-debugger)
52  (setq *no-exit* t)
53  (inspect
54  (find-skelfile
55  (if $args (pathname (car $args))
56  #P".")
57  :load t)))
58 
59 (defcmd skc-id
60  (println (std:format-sxhash (obj/id:id (find-skelfile #P"." :load t)))))
61 
62 (defcmd skc-rev
63  (case (sk-vc (find-skelfile #P"." :load t))
64  (:hg (progn
65  (let ((proc (run-hg-command "id" (list "-i") :stream)))
66  (copy-stream (process-output proc) *standard-output*)
67  (finish-output))))
68  (t (progn
69  (let ((proc (run-git-command "rev-parse" (list "HEAD") :stream)))
70  (copy-stream (process-output proc) *standard-output*)
71  (finish-output))))))
72 
73 (defun skc-show-case (sel)
74  (std/string:string-case (sel :default (skel-error))
75  (":id" (std:format-sxhash (obj/id:id (find-skelfile #P"." :load t))))
76  (":name" (sk-name (find-skelfile #P"." :load t)))
77  (":author" (sk-author (find-skelfile #P"." :load t)))
78  (":version" (sk-version (find-skelfile #P"." :load t)))
79  (":description" (sk-description (find-skelfile #P"." :load t)))
80  (":tags" (sk-tags (find-skelfile #P"." :load t)))
81  (":license" (sk-license (find-skelfile #P"." :load t)))
82  (":vc" (sk-vc (find-skelfile #P"." :load t)))
83  (":docs" (sk-docs (find-skelfile #P"." :load t)))
84  (":scripts" (sk-scripts (find-skelfile #P"." :load t)))
85  (":snippets" (sk-snippets (find-skelfile #P"." :load t)))
86  (":rules" (sk-rules (find-skelfile #P"." :load t)))
87  (":imports" (sk-imports (find-skelfile #P"." :load t)))
88  (":stash" (sk-stash (find-skelfile #P"." :load t)))
89  (":store" (sk-store (find-skelfile #P"." :load t)))
90  (":config" (if (probe-file *user-skelrc*)
91  (describe (load-user-skelrc) t)
92  (describe *skel-user-config* nil)))
93  (":cache" (sk-cache (find-skelfile #P"." :load t)))))
94 
95 (defcmd skc-show
96  (if $args
97  (mapc (lambda (x) (when-let ((ret (skc-show-case x))) (println ret))) $args)
98  (describe (find-skelfile #P"." :load t))))
99 
100 (defcmd skc-push
101  (case (sk-vc-meta-kind (sk-vc (find-skelfile #P"." :load t)))
102  (:git (run-git-command "push" $args t))
103  (:hg (run-hg-command "push" $args t))
104  (t (skel-error "unknown VC type"))))
105 
106 (defcmd skc-pull
107  (case (sk-vc-meta-kind (sk-vc (find-skelfile #P"." :load t)))
108  (:git (run-git-command "pull" $args t))
109  (:hg (run-hg-command "pull" (push "-u" $args) t))
110  (t (skel-error "unknown VC type"))))
111 
112 (defun hg-status ()
113  (let ((proc (run-hg-command "status" nil :stream)))
114  (copy-stream (process-output proc) *standard-output*)
115  (finish-output)))
116 
117 (defun git-status ()
118  (let ((proc (run-git-command "status" nil :stream)))
119  (copy-stream (process-output proc) *standard-output*)
120  (finish-output)))
121 
122 (defcmd skc-status
123  (case (sk-vc-meta-kind (sk-vc (find-skelfile #P"." :load t)))
124  (:git (git-status))
125  (:hg (hg-status))
126  (t (hg-status))))
127 
128 (defcmd skc-clone
129  (case (sk-vc-meta-kind (sk-vc (find-skelfile #P"." :load t)))
130  (:git (run-git-command "clone" $args t))
131  (:hg (run-hg-command "clone" $args t))
132  (t (skel-error "unknown VC type"))))
133 
134 (defcmd skc-commit
135  (debug! $optc $argc)
136  (case (sk-vc-meta-kind (sk-vc (find-skelfile #P"." :load t)))
137  (:git (run-git-command "commit" $args t))
138  (:hg (run-hg-command "commit" $args t))
139  (t (skel-error "unknown VC type"))))
140 
141 (defcmd skc-make
142  (let ((sk (find-skelfile #P"." :load t)))
143  (sb-ext:enable-debugger)
144  (if $args
145  (loop for a in $args
146  do (debug!
147  (when-let ((rule (sk-find-rule a sk)))
148  (sk-make sk rule))))
149  (debug! (sk-make sk (aref (sk-rules sk) 0))))))
150 
151 (defcmd skc-run
152  (if $args
153  (mapc (lambda (script)
154  (debug!
155  (sk-run
156  (sk-find-script
157  (pathname-name script)
158  (find-skelfile #P"." :load t))))) $args)
159  (required-argument :script)))
160 
161 (defcmd skc-shell
162  (sb-ext:enable-debugger)
163  (setq *no-exit* t)
164  (cli/clap::with-cli-handlers
165  (progn
166  (use-package :cl-user)
167  (use-package :sb-ext)
168  (use-package :std-user)
169  (init-skel-vars)
170  (sb-impl::toplevel-repl nil))))
171 
172 (define-cli $cli
173  :name "skel"
174  :version "0.1.1"
175  :description "A hacker's project compiler and build tool."
176  :thunk skc-describe
177  :opts (make-opts
178  (:name "help" :global t :description "print this message"
179  :thunk skc-help)
180  (:name "version" :global t :description "print version"
181  :thunk skc-version)
182  (:name "level" :global t :description "set log level (warn,info,debug,trace)"
183  :thunk skc-level)
184  (:name "config" :global t :description "set a custom skel user config" :kind file
185  :thunk skc-config)
186  (:name "input" :global t :description "input source" :kind string)
187  (:name "output" :global t :description "output target" :kind string))
188  :cmds (make-cmds
189  (:name init
190  :description "initialize a skelfile in the current directory"
191  :opts (make-opts (:name "name" :description "project name" :kind string))
192  :thunk skc-init)
193  (:name describe
194  :description "describe a skelfile"
195  :thunk skc-describe)
196  (:name show
197  :description "show project slots"
198  :opts (make-opts
199  (:name "file" :description "path to skelfile" :kind file)
200  (:name "user" :description "print user configuration")
201  (:name "system" :description "print system configuration"))
202  :thunk skc-show)
203  (:name id
204  :description "print the project id"
205  :thunk skc-id)
206  (:name rev
207  :description "print the current vc revision id"
208  :thunk skc-rev)
209  (:name inspect
210  :description "inspect the project skelfile"
211  :opts (make-opts (:name "file" :description "path to skelfile" :kind file))
212  :thunk skc-inspect)
213  (:name make
214  :description "build project targets"
215  :opts (make-opts (:name "target" :description "target to build" :kind string))
216  :thunk skc-make)
217  (:name run
218  :description "run a script or command"
219  :thunk skc-run)
220  (:name status
221  :description "print the vc status"
222  :thunk skc-status)
223  (:name push
224  :description "push the current project upstream"
225  :thunk skc-push)
226  (:name pull
227  :description "pull the current project from remote"
228  :thunk skc-pull)
229  (:name clone
230  :description "clone a remote project"
231  :thunk skc-clone)
232  (:name commit
233  :description "commit changes to the project vc"
234  :opts (make-opts (:name "message" :description "commit message" :kind string :thunk identity))
235  :thunk skc-commit)
236  (:name edit
237  :description "edit a project file in emacs."
238  :thunk skc-edit)
239  (:name shell
240  :description "open the sk-shell interpreter"
241  :thunk skc-shell)))
242 
243 (defpackage :sk-user
244  (:use :cl :std :skel))
245 
246 (defmain ()
247  (in-package :sk-user)
248  (let ((*log-level* :info))
249  (in-readtable :shell)
250  (with-cli (opts cmds) $cli
251  (load-skelrc)
252  ;; TODO 2024-01-01: need to parse out CMD opts from args slot - they still there
253  (do-opt (find-opt $cli "level"))
254  (do-cmd $cli)
255  (debug-opts $cli))))