├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── TODO.org ├── cli-parser.scm ├── db.scm ├── exceptions.scm ├── io.scm ├── list-procedures.scm ├── main.scm ├── parser.scm ├── pot.1 └── srfi-1.scm /.gitignore: -------------------------------------------------------------------------------- 1 | pot 2 | *~ 3 | \#*\# 4 | *.c 5 | *.o 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PREFIX = /usr 2 | MANPREFIX = $(PREFIX)/share/man 3 | 4 | GSC := gsc 5 | GAMBIT_LIBDIR := $(shell gsi -e '(println (path-expand "~~lib"))') 6 | GAMBIT_INCDIR := $(shell gsi -e '(println (path-expand "~~include"))') 7 | 8 | CC := musl-gcc 9 | CFLAGS := -static -O2 -idirafter $(GAMBIT_INCDIR) 10 | LIBS := -lgambit -lm -lc -ldl -lutil 11 | 12 | sources := srfi-1.scm io.scm exceptions.scm list-procedures.scm db.scm \ 13 | parser.scm cli-parser.scm main.scm 14 | transpiled := $(sources:.scm=.c) 15 | linkfile := link.c 16 | cfiles := $(transpiled) $(linkfile) 17 | 18 | pot: $(cfiles) 19 | $(CC) -o pot -L$(GAMBIT_LIBDIR) $(CFLAGS) $(cfiles) $(LIBS) 20 | strip pot 21 | 22 | clean: 23 | rm -f $(cfiles) 24 | 25 | install: pot 26 | install -D pot $(DESTDIR)$(PREFIX)/bin/pot 27 | install -Dm644 pot.1 $(DESTDIR)$(MANPREFIX)/man1/pot.1 28 | install -Dm644 LICENSE $(DESTDIR)$(PREFIX)/share/licenses/pot/LICENSE 29 | 30 | $(linkfile): $(transpiled) 31 | $(GSC) -o $(linkfile) -link $(transpiled) 32 | 33 | %.c: %.scm 34 | $(GSC) -c $< 35 | 36 | .PHONY: clean install 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | pot 2 | === 3 | 4 | a universal organization tool. 5 | Pot is simple, fast and powerful. 6 | 7 | - [Examples](#examples) 8 | - [Commands](#commands) 9 | - [Installation](#installation) 10 | 11 | Examples 12 | -------- 13 | 14 | ### indexing images 15 | 16 | display the 5 last modified files in sxiv and tag marked ones with 17 | **cute** and **cats**: 18 | 19 | ```shell 20 | ls -1t | head -5 | sxiv -iot | pot tag cute,cats 21 | ``` 22 | 23 | create a randomized rotation of wallpapers satisfying a given filter: 24 | 25 | [potbg] _filter_ 26 | 27 | and advance on command: 28 | 29 | [potbg] 30 | 31 | ### managing bookmarks 32 | 33 | find all resources tagged **sed** that also have the tags 34 | **programming** or **linux** contained in the database located in 35 | bookmarks, select one and load the uri in surf: 36 | 37 | ```shell 38 | pot --path ~/bookmarks filter "(programming;linux),sed" | dmenu -l 20 | xargs surf 39 | ``` 40 | 41 | Commands 42 | -------- 43 | 44 | This is a general overview that should get you started. For deeper 45 | understanding please read the manpage. 46 | 47 | Arguments in square brackets are read from standard input if not given 48 | on the command line. 49 | 50 | `pot delete-tags [tags...]` 51 | 52 | `pot filter ` 53 | 54 | `pot list-tags` 55 | 56 | `pot reverse-search ` 57 | 58 | `pot tag some,tags [resource...]` 59 | 60 | `pot untag maybe,other,tags [resource...]` 61 | 62 | ### Filters 63 | 64 | Filters combine tags into sets of resources. The following operators 65 | (sorted by descending precedence) can be used in filters: 66 | 67 | ``` 68 | () - parens ensure prioritized evaulation 69 | , - commas intersect two sets 70 | / - slashes represent the difference of one set from another 71 | ; - semicolons unite two sets 72 | ``` 73 | 74 | Installation 75 | ------------ 76 | 77 | [Arch User Repository](https://aur.archlinux.org/packages/pot) 78 | 79 | ### Dependencies 80 | 81 | - [Gambit-C][gambit] 82 | - [musl-libc][musl] (default) 83 | 84 | ### Building 85 | 86 | `make` 87 | 88 | #### Variables 89 | 90 | - `GSC:=gsc` Gambit-C compiler 91 | - `CC:=musl-gcc` C compiler 92 | 93 | ### Installing 94 | 95 | `make install` 96 | 97 | By default, pot attempts to install to `/usr`. To change the 98 | installation path, set make variables `DESTDIR` and `PREFIX` accordingly. 99 | 100 | [potbg]: https://github.com/motersen/dotfiles/blob/master/potbg/bin/potbg 101 | [gambit]: http://gambitscheme.org/wiki/index.php/Main_Page 102 | [musl]: http://www.musl-libc.org/ 103 | -------------------------------------------------------------------------------- /TODO.org: -------------------------------------------------------------------------------- 1 | * TODO document complement on man page 2 | * TODO write specification in Texinfo 3 | * TODO rework database system 4 | ** TODO Implement export and import capabilites 5 | To transition between database architectures without keeping legacy code 6 | ** TODO store everything in one file 7 | - uses diskspace more efficiently 8 | - enables for more efficient compression 9 | ** TODO store number of tagged resources in tag-header 10 | ** TODO integrate compression (miniLZO) 11 | * TODO display number of tagged resources in front of name in `list-tags` 12 | * TODO implement tag suggestion command 13 | - suggest tags based on resources sharing already assigned tags 14 | - otherwise scan resource for possible tags 15 | -------------------------------------------------------------------------------- /cli-parser.scm: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2016 Moritz Petersen 2 | ;;; 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;;; you may not use this file except in compliance with the License. 5 | ;;; You may obtain a copy of the License at 6 | ;;; 7 | ;;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;;; 9 | ;;; Unless required by applicable law or agreed to in writing, software 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;;; See the License for the specific language governing permissions and 13 | ;;; limitations under the License. 14 | 15 | ;; Each element of parsers must be a function of one argument which is 16 | ;; the list of arguments to parse. The parser should express the list of 17 | ;; remaining arguments 18 | 19 | (define (parse-command args . parsers) 20 | "Parse a command and its arguments." 21 | (if (not (pair? args)) 22 | (shout "No command given.")) 23 | (let ((cont (call/cc (lambda (cc) (cc cc))))) 24 | (if (null? parsers) 25 | (shout (string-append "Invalid command: " (car args)))) 26 | (let ((p (car parsers))) 27 | (set! parsers (cdr parsers)) 28 | (p (lambda () (cont cont)) args)))) 29 | 30 | (define (parse-flags next-arg flags args parsers) 31 | (let next-flag ((flags flags) 32 | (args args)) 33 | (let cont ((parsers parsers) 34 | (rest-flags flags) 35 | (rest-args args)) 36 | (if (null? rest-flags) 37 | (next-arg rest-args) 38 | (if (null? parsers) 39 | (if (eqv? rest-flags flags) 40 | (shout (string-append "Unknown option: -" 41 | (car rest-flags))) 42 | (next-flag rest-flags rest-args)) 43 | ((caar parsers) 44 | (lambda (flags args) 45 | (cont (cdr parsers) flags args)) 46 | rest-flags 47 | rest-args)))))) 48 | 49 | (define (parse-long-option next-arg opt args parsers) 50 | (let cont ((opt opt) 51 | (args args) 52 | (parsers parsers)) 53 | (if (null? opt) 54 | (next-arg args) 55 | (if (null? parsers) 56 | (shout (string-append "Unknown Option: --" opt)) 57 | ((cdar parsers) 58 | (lambda (opt args) 59 | (cont opt args (cdr parsers))) 60 | opt 61 | args))))) 62 | 63 | (define (parse-options parse-command args . parsers) 64 | "Parse recognized options at front of args and express remaining arguments" 65 | (let parse-options ((args args)) 66 | (if (not (pair? args)) 67 | (parse-command (list)) 68 | (let ((arg (string->list (car args)))) 69 | (if (not (eq? (car arg) #\-)) 70 | (parse-command args) 71 | (if (not (pair? (cdr arg))) 72 | (parse-options (cdr args)) 73 | (if (not (eq? (cadr arg) #\-)) 74 | (parse-flags parse-options 75 | (map (lambda (c) (string c)) 76 | (cdr arg)) 77 | (cdr args) 78 | parsers) 79 | (if (not (pair? (cddr arg))) 80 | (parse-options (cdr args)) 81 | (parse-long-option parse-options 82 | (list->string (cddr arg)) 83 | (cdr args) 84 | parsers))))))))) 85 | 86 | (define-macro (make-option-parser flag long-option success) 87 | `(cons 88 | (lambda (cont flags args) 89 | (if (not (string=? ,flag (car flags))) 90 | (cont flags args) 91 | (,success 92 | (lambda (args) 93 | (cont (cdr flags) args)) 94 | args))) 95 | (lambda (cont option args) 96 | (if (not (string=? ,long-option option)) 97 | (cont option args) 98 | (,success 99 | (lambda (args) 100 | (cont (list) args)) 101 | args))))) 102 | 103 | (define path-option 104 | (make-option-parser 105 | "p" "path" 106 | (lambda (cont args) 107 | (if (not (pair? args)) 108 | (shout "No argument to --path option.")) 109 | (init-base-path (car args)) 110 | (cont (cdr args))))) 111 | 112 | (define louder-option 113 | (make-option-parser 114 | "l" "louder" 115 | (lambda (cont args) 116 | (raise-attention) 117 | (cont args)))) 118 | 119 | (define quieter-option 120 | (make-option-parser 121 | "q" "quieter" 122 | (lambda (cont args) 123 | (lower-attention) 124 | (cont args)))) 125 | 126 | (define version-option 127 | (make-option-parser 128 | "v" "version" 129 | (lambda (cont args) 130 | (print-version)))) 131 | 132 | (define (filter-command cont args) 133 | (if (not (member? string=? (car args) '("f" "filter"))) 134 | (cont) 135 | (begin 136 | (if (not (pair? (cdr args))) 137 | (shout "No filter given.")) 138 | (if (pair? (cddr args)) 139 | (yell "Too many arguments to filter command.")) 140 | (for-each println 141 | (parse-filter-string (cadr args)))))) 142 | 143 | (define (list-tags-command cont args) 144 | (if (not (member? string=? (car args) '("lt" "list-tags"))) 145 | (cont) 146 | (begin 147 | (if (pair? (cdr args)) 148 | (yell "Too many arguments to list-tags command.")) 149 | (for-each println (read-tag-index))))) 150 | 151 | (define (tag-command cont args) 152 | (if (not (member? string=? (car args) '("t" "tag"))) 153 | (cont) 154 | (if (not (pair? (cdr args))) 155 | (shout "No Tag-List given.") 156 | (tag (parse-tag-list (cadr args)) 157 | (if (pair? (cddr args)) 158 | (cddr args) 159 | (read-all (current-input-port) read-line)))))) 160 | 161 | (define (untag-command cont args) 162 | (if (not (member? string=? (car args) '("u" "untag"))) 163 | (cont) 164 | (if (not (pair? (cdr args))) 165 | (shout "No Tag-List given.") 166 | (untag (parse-tag-list (cadr args)) 167 | (if (pair? (cddr args)) 168 | (cddr args) 169 | (read-all (current-input-port) read-line)))))) 170 | 171 | (define (delete-tags-command cont args) 172 | (if (not (member? string=? (car args) '("d" "delete-tags"))) 173 | (cont) 174 | (delete-tags (fold (lambda (xs xt) (unite stringinteger #\newline) (u8vector-ref v (- i 1))) 150 | i 151 | (find-beginning-of-line v (- i 1))))) 152 | (define (find-end-of-line v i) 153 | (if (= (char->integer #\newline) (u8vector-ref v i)) 154 | i 155 | (find-end-of-line v (+ i 1)))) 156 | (define (compare xs v i) 157 | (if (null? xs) 158 | (if (= (char->integer #\newline) (u8vector-ref v i)) 159 | 0 160 | -1) 161 | (if (< (car xs) (u8vector-ref v i)) 162 | -1 163 | (if (> (car xs) (u8vector-ref v i)) 164 | 1 165 | (compare (cdr xs) v (+ i 1)))))) 166 | (let ((left-bound 0) 167 | (right-bound (- (u8vector-length v) 1))) 168 | (let* ((cont (call/cc (lambda (cc) cc))) 169 | (offset (+ left-bound (floor (/ (- right-bound left-bound) 2)))) 170 | (beginning-of-line (find-beginning-of-line v offset)) 171 | (comparison (compare xs v beginning-of-line))) 172 | (if (= comparison 0) 173 | beginning-of-line 174 | (begin 175 | (if (= comparison -1) 176 | (set! right-bound (- (find-beginning-of-line v offset) 1)) 177 | (set! left-bound (+ (find-end-of-line v offset) 1))) 178 | (if (> left-bound right-bound) 179 | #f 180 | (cont cont))))))) 181 | 182 | (define (find-tags-of-resource resource) 183 | (let ((unicode-resource-name (map char->integer (string->list resource)))) 184 | (let find ((tags (read-tag-index))) 185 | (if (null? tags) 186 | (list) 187 | (let ((data (read-entire-file 188 | (string-append (get-db-path) "/" (car tags))))) 189 | (if (> (u8vector-length data) 0) 190 | (if (find-resource-in-tag-register-data 191 | data 192 | unicode-resource-name) 193 | (cons (car tags) (find (cdr tags))) 194 | (find (cdr tags))) 195 | (begin 196 | (yell (string-append "Tag '" (car tags) "' is empty")) 197 | (find (cdr tags))))))))) 198 | 199 | (define get-all-resources 200 | (let ((all-resources #f)) 201 | (lambda () 202 | (if (not (pair? all-resources)) 203 | (set! all-resources 204 | (let find ((tags (read-tag-index)) 205 | (resources (list))) 206 | (if (null? tags) 207 | resources 208 | (find (cdr tags) 209 | (unite string (current-attention) 0) 22 | (display-exception x)) 23 | (shout msg)) 24 | (let ((h (car handlers))) 25 | (set! handlers (cdr handlers)) 26 | (h (lambda () (cont cont)) x msg)))))) 27 | 28 | (define (os-exception-catcher cont x msg) 29 | (if (os-exception? x) 30 | (shout (string-append msg 31 | (let ((os-msg (os-exception-message x))) 32 | (if os-msg 33 | (string-append ": " os-msg) 34 | "")) 35 | " - " 36 | (err-code->string (os-exception-code x)))) 37 | (cont))) 38 | 39 | (define (no-such-f-o-d-exception-catcher cont x msg) 40 | (if (no-such-file-or-directory-exception? x) 41 | (shout (string-append msg ": " "No such file or directory")) 42 | (cont))) 43 | 44 | (define all-exception-catchers (list os-exception-catcher 45 | no-such-f-o-d-exception-catcher)) 46 | -------------------------------------------------------------------------------- /io.scm: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2016 Moritz Petersen 2 | ;;; 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;;; you may not use this file except in compliance with the License. 5 | ;;; You may obtain a copy of the License at 6 | ;;; 7 | ;;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;;; 9 | ;;; Unless required by applicable law or agreed to in writing, software 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;;; See the License for the specific language governing permissions and 13 | ;;; limitations under the License. 14 | 15 | (define version "0.2.1") 16 | 17 | (define (directory-exists? path) 18 | (and (file-exists? path) 19 | (eq? 'directory (file-info-type (file-info path))))) 20 | 21 | (define (regular-file-exists? path) 22 | (and (file-exists? path) 23 | (eq? 'regular (file-info-type (file-info path))))) 24 | 25 | (define (read-entire-file file) 26 | (if (regular-file-exists? file) 27 | (call-with-input-file file 28 | (lambda (port) 29 | (let* ((length (input-port-byte-position port 0 2)) 30 | (data (make-u8vector length))) 31 | (input-port-byte-position port 0) 32 | (read-subu8vector data 0 length port) 33 | data))) 34 | (begin 35 | (yell (string-append "Attempting to read non-existent file " file)) 36 | (u8vector)))) 37 | 38 | (define raise-attention #f) 39 | (define lower-attention #f) 40 | (define current-attention #f) 41 | 42 | (let ((attention 0)) 43 | (set! raise-attention 44 | (lambda () 45 | (if (>= attention 0) 46 | (set! attention (+ attention 1)) 47 | (shout "-q and -l must not be used together.")))) 48 | (set! lower-attention 49 | (lambda () 50 | (if (<= attention 0) 51 | (set! attention (- attention 1)) 52 | (shout "-q and -l must not be used together.")))) 53 | (set! current-attention 54 | (lambda () 55 | attention))) 56 | 57 | (define (shout message) 58 | (println port: (current-error-port) 59 | "Error: " message) 60 | (exit 1)) 61 | 62 | (define (yell message) 63 | (if (>= (current-attention) 0) 64 | (println port: (current-error-port) 65 | "Warning: " message))) 66 | 67 | (define (tell message) 68 | (if (>= (current-attention) 0) 69 | (println port: (current-error-port) 70 | message))) 71 | 72 | (define (mumble message) 73 | (if (>= (current-attention) 1) 74 | (println port: (current-error-port) 75 | message))) 76 | 77 | (define (whisper message) 78 | (if (>= (current-attention) 2) 79 | (println port: (current-error-port) 80 | message))) 81 | 82 | (define (print-version) 83 | (println "pot - version " version)) 84 | 85 | -------------------------------------------------------------------------------- /list-procedures.scm: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2016 Moritz Petersen 2 | ;;; 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;;; you may not use this file except in compliance with the License. 5 | ;;; You may obtain a copy of the License at 6 | ;;; 7 | ;;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;;; 9 | ;;; Unless required by applicable law or agreed to in writing, software 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;;; See the License for the specific language governing permissions and 13 | ;;; limitations under the License. 14 | 15 | (define (unite predicate a b) 16 | "merge two lists sorted by predicate into one such list" 17 | "remove duplicates across lists" 18 | (if (or (null? a) (null? b)) 19 | (append a b) 20 | (let ((ca (car a)) (cb (car b))) 21 | (if (predicate ca cb) 22 | (cons ca (unite predicate (cdr a) b)) 23 | (if (predicate cb ca) 24 | (cons cb (unite predicate a (cdr b))) 25 | (cons cb (unite predicate (cdr a) (cdr b)))))))) 26 | 27 | (define (differ predicate a b) 28 | "a without b" 29 | (if (or (null? a) (null? b)) 30 | a 31 | (let ((ca (car a)) (cb (car b))) 32 | (if (predicate ca cb) 33 | (cons ca (differ predicate (cdr a) b)) 34 | (if (predicate cb ca) 35 | (differ predicate a (cdr b)) 36 | (differ predicate (cdr a) (cdr b))))))) 37 | 38 | (define (intersect predicate a b) 39 | "Intersection of a and b" 40 | (if (or (null? a) (null? b)) 41 | (list) 42 | (let ((ca (car a)) (cb (car b))) 43 | (if (predicate ca cb) 44 | (intersect predicate (cdr a) b) 45 | (if (predicate cb ca) 46 | (intersect predicate a (cdr b)) 47 | (cons ca (intersect predicate (cdr a) (cdr b)))))))) 48 | 49 | (define (alternating-bisect xs) 50 | (let bisect ((xs xs) (sections '(()))) 51 | (if (not (pair? xs)) 52 | (cons (reverse (car sections)) 53 | (reverse (cdr sections))) 54 | (bisect (cdr xs) (cons (cdr sections) 55 | (cons (car xs) (car sections))))))) 56 | 57 | (define (merge-sort predicate xs) 58 | (if (not (pair? xs)) 59 | (list) 60 | (let merge-sort ((xs xs)) 61 | (if (null? (cdr xs)) 62 | xs 63 | (let ((halves (alternating-bisect xs))) 64 | (unite predicate 65 | (merge-sort (car halves)) 66 | (merge-sort (cdr halves)))))))) 67 | -------------------------------------------------------------------------------- /main.scm: -------------------------------------------------------------------------------- 1 | #!gsi-script -:d0 2 | 3 | ;;; Copyright 2016 Moritz Petersen 4 | ;;; 5 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 6 | ;;; you may not use this file except in compliance with the License. 7 | ;;; You may obtain a copy of the License at 8 | ;;; 9 | ;;; http://www.apache.org/licenses/LICENSE-2.0 10 | ;;; 11 | ;;; Unless required by applicable law or agreed to in writing, software 12 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 13 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | ;;; See the License for the specific language governing permissions and 15 | ;;; limitations under the License. 16 | 17 | (init-base-path (current-directory)) 18 | 19 | (with-exception-catcher 20 | (exception-catcher "Sorry, something went wrong" 21 | all-exception-catchers) 22 | (lambda () 23 | (parse-options (lambda (command) 24 | (parse-command 25 | command 26 | filter-command 27 | tag-command 28 | untag-command 29 | reverse-search-command 30 | list-tags-command 31 | delete-tags-command)) 32 | (cdr (command-line)) 33 | louder-option 34 | path-option 35 | quieter-option 36 | version-option))) 37 | -------------------------------------------------------------------------------- /parser.scm: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2016 Moritz Petersen 2 | ;;; 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;;; you may not use this file except in compliance with the License. 5 | ;;; You may obtain a copy of the License at 6 | ;;; 7 | ;;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;;; 9 | ;;; Unless required by applicable law or agreed to in writing, software 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;;; See the License for the specific language governing permissions and 13 | ;;; limitations under the License. 14 | 15 | ; requires: srfi-1 16 | 17 | (define (tag-char? char) 18 | (define (char-ascii-alpha? char) 19 | (let ((codepoint (char->integer char))) 20 | (or (<= #x41 codepoint #x5a) ; uppercase ascii letter 21 | (<= #x61 codepoint #x7a)))) ; lowercase ascii letter 22 | (define (char-ascii-digit? char) 23 | (<= #x30 (char->integer char) #x39)) 24 | (or (char-ascii-alpha? char) 25 | (char-ascii-digit? char) 26 | (char=? #\- char) 27 | (char=? #\: char))) 28 | 29 | (define (if-nth xs n) 30 | (and (pair? xs) 31 | (if (= 0 n) 32 | (car xs) 33 | (if-nth (cdr xs) (- n 1))))) 34 | 35 | (define (tokenize s) 36 | (define-macro (op? c) 37 | `(member? char=? ,c (string->list "^,;/"))) 38 | (let tokenize ((s (string->list s)) 39 | (tokens (list))) 40 | (if (null? s) 41 | (reverse tokens) 42 | (let ((c (car s))) 43 | (cond 44 | ((tag-char? c) 45 | (let ((tag.rest (collect-tag s))) 46 | (tokenize (cdr tag.rest) (cons (car tag.rest) tokens)))) 47 | ((op? c) 48 | (tokenize (cdr s) (cons (list->string (list c)) tokens))) 49 | ((char=? #\( c) 50 | (let ((group.rest (tokenize (cdr s) (list)))) 51 | (tokenize (cdr group.rest) (cons (car group.rest) tokens)))) 52 | ((char=? #\) c) 53 | (cons (reverse tokens) (cdr s))) 54 | (#t 55 | (shout (string-append 56 | "Not a valid symbol: '" 57 | (list->string (list c)) 58 | "'")))))))) 59 | 60 | (define (collect-tag symbols) 61 | "pair of tag-string formed by first symbols and rest of symbols or #f" 62 | (and (pair? symbols) 63 | (tag-char? (car symbols)) 64 | (let collect-tag ((tag (list (car symbols))) 65 | (rest (cdr symbols))) 66 | (if (and (pair? rest) 67 | (tag-char? (car rest))) 68 | (collect-tag (cons (car rest) tag) (cdr rest)) 69 | (cons (list->string (reverse tag)) rest))))) 70 | 71 | (define (syntax-fail tokens) 72 | (shout (string-append "'" tokens "' is not a valid set description."))) 73 | 74 | (define-macro (define-combination-parser name combinator operator) 75 | `(define (,name tokens) 76 | (and (pair? tokens) 77 | (pair? (cdr tokens)) ;all of these are infix operators 78 | (let find-op ((a (list (car tokens))) (b (cdr tokens))) 79 | (and (not (null? b)) 80 | (if (and (string? (car b)) (string=? (car b) ,operator)) 81 | (,combinator stringlist str))) 130 | (if (null? symbols) 131 | (list) 132 | (let ((tag-rest (collect-tag symbols))) 133 | (if (not tag-rest) 134 | (expected "Tagname") 135 | (if (not (pair? (cdr tag-rest))) 136 | (list (car tag-rest)) 137 | (if (not (eq? #\, (cadr tag-rest))) 138 | (expected ",") 139 | (cons (car tag-rest) 140 | (parse-tag-list (cddr tag-rest)))))))))) 141 | -------------------------------------------------------------------------------- /pot.1: -------------------------------------------------------------------------------- 1 | .\" manpage for pot 2 | .TH POT 1 "2016" "pot 0.2.1" 3 | .SH NAME 4 | pot - organize tags 5 | .SH SYNOPSIS 6 | .nf 7 | \fIpot\fR [-l] [-p ] [-q] [argument...] 8 | \fIpot\fR -v 9 | .fi 10 | .SH DESCRIPTION 11 | Pot makes organizing files and other resources simple by providing a powerful and convenient tagging system. 12 | .sp 13 | It is directory based and operates on the current working directory by default. The database is contained in the subdirectory \fI.pot\fR and can easily be moved together with the rest of the directory or without touching other files at all. 14 | .SH OPTIONS 15 | -l, --louder 16 | Be more verbose. 17 | .sp 18 | -p, --path 19 | Run as if pot was started in \fI\fR instead of the current directory. 20 | .sp 21 | -q, --quieter 22 | Be less verbose. 23 | .sp 24 | -v, --version 25 | Display version and exit. 26 | .SH COMMANDS 27 | d, delete-tags [tag-list...] 28 | Remove tags from the database. If no tag-list is given on the command line, standard input is read. 29 | 30 | f, filter 31 | Print the resources which are described by \fI\fR in alphabetical 32 | order to standard output. 33 | 34 | lt, list-tags 35 | Print all tags in alphabetical order. 36 | 37 | r, reverse-search 38 | Print all tags \fI\fR belongs to. 39 | 40 | t, tag [resource...] 41 | Add resources to each of \fI\fR. If resources are absent on the command line they are read from standard input. 42 | 43 | u, untag [resource...] 44 | Remove resources from each of \fI\fR. If resources are absent on the command line they are read from standard input. 45 | .SH SPECIAL FORMS 46 | .SS Resources 47 | A Resource is a string describing an organized object. Examples for resources are files or URLs. 48 | .SS Tagnames 49 | Tagnames represent the categories using which resources can be categorized. They 50 | are made up of alphanumeric symbols and hyphens. 51 | .SS Tag-Lists 52 | A Tag-List is a comma-separated list of Tagnames. Space is not allowed. 53 | .SS Filters 54 | A Filter combines multiple Tagnames to describe a set of resources. 55 | 56 | In a filter, a Tagname represents the set of resources tagged with it. 57 | .PP 58 | Sets can be combined using the following operators (Sorted descending 59 | by precedence): 60 | 61 | () A set can be enclosed in parantheses to prioritize its evaluation. 62 | 63 | , - Intersection: The set of resources shared by both sets. 64 | 65 | / - Difference: The first set without the resources contained in the second set. 66 | 67 | ; - Union: The set of resources contained in either one or both sets. 68 | -------------------------------------------------------------------------------- /srfi-1.scm: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2016 Moritz Petersen 2 | ;;; 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;;; you may not use this file except in compliance with the License. 5 | ;;; You may obtain a copy of the License at 6 | ;;; 7 | ;;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;;; 9 | ;;; Unless required by applicable law or agreed to in writing, software 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;;; See the License for the specific language governing permissions and 13 | ;;; limitations under the License. 14 | 15 | ;srfi-1 procedures required by pot 16 | 17 | (define (any l xs) 18 | (and (pair? xs) 19 | (or (l (car xs)) 20 | (any l (cdr xs))))) 21 | 22 | (define (member? predicate x xs) 23 | (and (pair? xs) 24 | (if (equal? x (car xs)) 25 | xs 26 | (member? predicate x (cdr xs))))) 27 | 28 | (define (fold kons knil xs) 29 | (if (not (pair? xs)) 30 | knil 31 | (fold kons (kons (car xs) knil) (cdr xs)))) 32 | --------------------------------------------------------------------------------