From d46183860c1f3f10095e95023adcb79b1896ab0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 22 Mar 2019 20:11:11 +0100 Subject: Move C and Scheme code into subdirs. --- Makefile | 32 ++- calendar.c | 140 ------------ calendar.h | 41 ---- config.scm | 12 -- err.h | 42 ---- exceptions.scm | 5 - fetch.scm | 31 --- graphs.c | 144 ------------- graphs.h | 15 -- guile_interface.h | 28 --- guile_interface.scm.c | 220 ------------------- guile_type_helpers.c | 13 -- guile_type_helpers.h | 13 -- helpers.scm | 43 ---- linked_list.h | 92 -------- linked_list.inc.h | 176 ---------------- macro.h | 134 ------------ main.c | 91 -------- main.scm | 139 ------------ module/config.scm | 12 ++ module/exceptions.scm | 5 + module/fetch.scm | 31 +++ module/helpers.scm | 43 ++++ module/main.scm | 139 ++++++++++++ module/srfi/srfi-19/setters.scm | 15 ++ module/srfi/srfi-19/util.scm | 83 ++++++++ module/srfi/srfi-41/util.scm | 29 +++ module/terminal/escape.scm | 28 +++ module/terminal/termios.scm | 13 ++ module/terminal/util.scm | 37 ++++ module/test.scm | 77 +++++++ module/util.scm | 168 +++++++++++++++ module/vcalendar.scm | 112 ++++++++++ module/vcalendar/control.scm | 39 ++++ module/vcalendar/datetime.scm | 34 +++ module/vcalendar/output.scm | 93 ++++++++ module/vcalendar/primitive.scm | 23 ++ module/vcalendar/recur.scm | 12 ++ module/vcalendar/recurrence/generate.scm | 126 +++++++++++ module/vcalendar/recurrence/internal.scm | 28 +++ module/vcalendar/recurrence/parse.scm | 106 ++++++++++ pair.h | 19 -- pair.inc.h | 34 --- parse.c | 351 ------------------------------- parse.h | 122 ----------- src/calendar.c | 140 ++++++++++++ src/calendar.h | 41 ++++ src/err.h | 42 ++++ src/graphs.c | 144 +++++++++++++ src/graphs.h | 15 ++ src/guile_interface.h | 28 +++ src/guile_interface.scm.c | 220 +++++++++++++++++++ src/guile_type_helpers.c | 13 ++ src/guile_type_helpers.h | 13 ++ src/linked_list.h | 92 ++++++++ src/linked_list.inc.h | 176 ++++++++++++++++ src/macro.h | 134 ++++++++++++ src/main.c | 91 ++++++++ src/pair.h | 19 ++ src/pair.inc.h | 34 +++ src/parse.c | 351 +++++++++++++++++++++++++++++++ src/parse.h | 122 +++++++++++ src/strbuf.c | 151 +++++++++++++ src/strbuf.h | 109 ++++++++++ src/termios.scm.c | 44 ++++ src/trie.h | 54 +++++ src/trie.inc.h | 228 ++++++++++++++++++++ src/vcal.c | 152 +++++++++++++ src/vcal.h | 118 +++++++++++ srfi/srfi-19/setters.scm | 15 -- srfi/srfi-19/util.scm | 83 -------- srfi/srfi-41/util.scm | 29 --- strbuf.c | 151 ------------- strbuf.h | 109 ---------- terminal/escape.scm | 28 --- terminal/termios.scm | 11 - terminal/util.scm | 37 ---- termios.scm.c | 44 ---- test.scm | 77 ------- trie.h | 54 ----- trie.inc.h | 228 -------------------- util.scm | 168 --------------- vcal.c | 152 ------------- vcal.h | 118 ----------- vcalendar.scm | 112 ---------- vcalendar/control.scm | 39 ---- vcalendar/datetime.scm | 34 --- vcalendar/output.scm | 93 -------- vcalendar/primitive.scm | 21 -- vcalendar/recur.scm | 12 -- vcalendar/recurrence/generate.scm | 126 ----------- vcalendar/recurrence/internal.scm | 28 --- vcalendar/recurrence/parse.scm | 106 ---------- 93 files changed, 3805 insertions(+), 3791 deletions(-) delete mode 100644 calendar.c delete mode 100644 calendar.h delete mode 100644 config.scm delete mode 100644 err.h delete mode 100644 exceptions.scm delete mode 100755 fetch.scm delete mode 100644 graphs.c delete mode 100644 graphs.h delete mode 100644 guile_interface.h delete mode 100644 guile_interface.scm.c delete mode 100644 guile_type_helpers.c delete mode 100644 guile_type_helpers.h delete mode 100644 helpers.scm delete mode 100644 linked_list.h delete mode 100644 linked_list.inc.h delete mode 100644 macro.h delete mode 100644 main.c delete mode 100755 main.scm create mode 100644 module/config.scm create mode 100644 module/exceptions.scm create mode 100755 module/fetch.scm create mode 100644 module/helpers.scm create mode 100755 module/main.scm create mode 100644 module/srfi/srfi-19/setters.scm create mode 100644 module/srfi/srfi-19/util.scm create mode 100644 module/srfi/srfi-41/util.scm create mode 100644 module/terminal/escape.scm create mode 100644 module/terminal/termios.scm create mode 100644 module/terminal/util.scm create mode 100755 module/test.scm create mode 100644 module/util.scm create mode 100644 module/vcalendar.scm create mode 100644 module/vcalendar/control.scm create mode 100644 module/vcalendar/datetime.scm create mode 100644 module/vcalendar/output.scm create mode 100644 module/vcalendar/primitive.scm create mode 100644 module/vcalendar/recur.scm create mode 100644 module/vcalendar/recurrence/generate.scm create mode 100644 module/vcalendar/recurrence/internal.scm create mode 100644 module/vcalendar/recurrence/parse.scm delete mode 100644 pair.h delete mode 100644 pair.inc.h delete mode 100644 parse.c delete mode 100644 parse.h create mode 100644 src/calendar.c create mode 100644 src/calendar.h create mode 100644 src/err.h create mode 100644 src/graphs.c create mode 100644 src/graphs.h create mode 100644 src/guile_interface.h create mode 100644 src/guile_interface.scm.c create mode 100644 src/guile_type_helpers.c create mode 100644 src/guile_type_helpers.h create mode 100644 src/linked_list.h create mode 100644 src/linked_list.inc.h create mode 100644 src/macro.h create mode 100644 src/main.c create mode 100644 src/pair.h create mode 100644 src/pair.inc.h create mode 100644 src/parse.c create mode 100644 src/parse.h create mode 100644 src/strbuf.c create mode 100644 src/strbuf.h create mode 100644 src/termios.scm.c create mode 100644 src/trie.h create mode 100644 src/trie.inc.h create mode 100644 src/vcal.c create mode 100644 src/vcal.h delete mode 100644 srfi/srfi-19/setters.scm delete mode 100644 srfi/srfi-19/util.scm delete mode 100644 srfi/srfi-41/util.scm delete mode 100644 strbuf.c delete mode 100644 strbuf.h delete mode 100644 terminal/escape.scm delete mode 100644 terminal/termios.scm delete mode 100644 terminal/util.scm delete mode 100644 termios.scm.c delete mode 100755 test.scm delete mode 100644 trie.h delete mode 100644 trie.inc.h delete mode 100644 util.scm delete mode 100644 vcal.c delete mode 100644 vcal.h delete mode 100644 vcalendar.scm delete mode 100644 vcalendar/control.scm delete mode 100644 vcalendar/datetime.scm delete mode 100644 vcalendar/output.scm delete mode 100644 vcalendar/primitive.scm delete mode 100644 vcalendar/recur.scm delete mode 100644 vcalendar/recurrence/generate.scm delete mode 100644 vcalendar/recurrence/internal.scm delete mode 100644 vcalendar/recurrence/parse.scm diff --git a/Makefile b/Makefile index 59c611df..e0dbd87c 100644 --- a/Makefile +++ b/Makefile @@ -3,42 +3,52 @@ CC := gcc OBJDIR = obj +SRCDIR = src +LIBDIR = lib CFLAGS = -std=gnu11 -Wall -Wextra \ -ggdb -fPIC \ $(shell guile-config compile) LDFLAGS = -fPIC $(shell guile-config link) -H_FILES = $(wildcard *.h) -C_FILES = $(wildcard *.c) +LIBS = libguile-calendar.so libtermios.so +SO_FILES = $(addprefix $(LIBDIR)/, $(LIBS)) -SCM_C_FILES = $(wildcard *.scm.c) +H_FILES = $(wildcard src/*.h) +C_FILES = $(wildcard src/*.c) + +SCM_C_FILES = $(wildcard src/*.scm.c) X_FILES = $(SCM_C_FILES:.scm.c=.x) .SECONDARY: $(X_FILES) -O_FILES = $(C_FILES:%.c=obj/%.o) +O_FILES = $(C_FILES:src/%.c=obj/%.o) -all: parse libguile-calendar.so libtermios.so +all: parse $(SO_FILES) parse: $(O_FILES) $(CC) -o $@ $^ $(LDFLAGS) $(O_FILES): | $(OBJDIR) -%.x : %.scm.c +$(SO_FILES): | $(LIBDIR) + +src/%.x : src/%.scm.c guile-snarf -o $@ $< $(CFLAGS) -$(OBJDIR)/%.scm.o : %.scm.c %.x +$(OBJDIR)/%.scm.o : src/%.scm.c src/%.x $(CC) -c $(CFLAGS) -o $@ $< -$(OBJDIR)/%.o : %.c # $(H_FILES) $(X_FILES) +$(OBJDIR)/%.o : src/%.c # $(H_FILES) $(X_FILES) $(CC) -c $(CFLAGS) -o $@ $< $(OBJDIR): mkdir -p $(OBJDIR) -%.so: $(O_FILES) +$(LIBDIR): + mkdir -p $(LIBDIR) + +$(LIBDIR)/%.so: $(O_FILES) $(CC) -shared -o $@ $^ $(LDFLAGS) .SECONDARY += %.dot @@ -56,8 +66,8 @@ clean: -rm parse -rm $(OBJDIR)/*.o -rmdir $(OBJDIR) - -rm *.so - -rm *.x + -rm $(LIBDIR)/*.so + -rm $(SRCDIR)/*.x clean-scheme: rm -r $$HOME/.cache/guile/ccache/2.2-LE-8-3.A/$$PWD diff --git a/calendar.c b/calendar.c deleted file mode 100644 index edc1151e..00000000 --- a/calendar.c +++ /dev/null @@ -1,140 +0,0 @@ -#include "calendar.h" - -#include -#include -#include -#include -#include - -#include "parse.h" -#include "err.h" - -int read_vcalendar(vcomponent* cal, char* path) { - - struct stat statbuf; - if (stat (path, &statbuf) != 0) { - fprintf(stderr, - "Error stating file or directory, errno = %i\npath = [%s]\n", - errno, path); - } - - int type = statbuf.st_mode & 0777000; - int chmod = statbuf.st_mode & 0777; - INFO_F("file has mode 0%o, with chmod = 0%o", type, chmod); - - switch (type) { - case S_IFREG: handle_file(cal, path); break; - case S_IFDIR: handle_dir (cal, path); break; - case S_IFLNK: - ERR("Found symlink, can't be bothered to check it further."); - break; - - default: ; - } - - return 0; -} - -int handle_file(vcomponent* cal, char* path) { - INFO("Parsing a single file"); - - vcomponent_push_val(cal, "NAME", path); - vcomponent_push_val(cal, "TYPE", "file"); - char* resolved_path = realpath(path, NULL); - open_ics (resolved_path, cal); - free (resolved_path); - - return 0; -} - - -int handle_dir(vcomponent* cal, char* path) { - INFO("Parsing a directory"); - DIR* dir = opendir(path); - - /* Buffer for holding search path and filename */ - char buf[PATH_MAX] = { [0 ... PATH_MAX - 1] = '\0' }; - strcpy(buf, path); - int path_len = strlen(path) + 1; - - /* Slash to guarantee we have at least one */ - buf[path_len - 1] = '/'; - - - vcomponent_push_val(cal, "NAME", path); - vcomponent_push_val(cal, "TYPE", "vdir"); - - struct dirent* d; - while ((d = readdir(dir)) != NULL) { - /* Check that it's a regular file */ - if (d->d_type != DT_REG) continue; - - /* Append filename with currentt searchpath */ - strcat(buf, d->d_name); - char* resolved_path = realpath(buf, NULL); - /* Remove file part from combined path */ - buf[path_len] = '\0'; - - FILE* f; - char info_buf[0x100]; - if (strcmp (d->d_name, "color") == 0) { - f = fopen(resolved_path, "r"); - fgets(info_buf, 0x100, f); - fclose(f); - vcomponent_push_val(cal, "COLOR", info_buf); - } else if (strcmp (d->d_name, "displayname") == 0) { - f = fopen(resolved_path, "r"); - fgets(info_buf, 0x100, f); - fclose(f); - // TODO make sure that this replaces - vcomponent_push_val(cal, "NAME", info_buf); - } else { - open_ics (resolved_path, cal); - } - - free (resolved_path); - } - - closedir(dir); - return 0; -} - -int get_extension(const char* filename, char* ext, ssize_t max_len) { - int ext_idx = -1; - ext[0] = '\0'; - for (int i = 0; filename[i] != '\0'; i++) { - if (filename[i] == '.') ext_idx = i + 1; - if (filename[i] == '/') ext_idx = -1; - } - - if (ext_idx == -1) return 0; - - int ext_len = 0; - for (int i = 0; i < max_len; i++, ext_len++) { - char c = filename[i + ext_idx]; - if (c == '\0') break; - ext[i] = c; - } - ext[ext_len] = '\0'; - return ext_len; -} - -int check_ext (const char* path, const char* ext) { - char buf[10]; - int has_ext = get_extension(path, buf, 9); - - return has_ext && strcmp(buf, ext) == 0; -} - -int open_ics (char* resolved_path, vcomponent* cal) { - if (! check_ext(resolved_path, "ics") ) return 2; - - FILE* f = fopen(resolved_path, "r"); - - if (f == NULL) return 1; - - parse_file(resolved_path, f, cal); - fclose(f); - - return 0; -} diff --git a/calendar.h b/calendar.h deleted file mode 100644 index 20b78a9f..00000000 --- a/calendar.h +++ /dev/null @@ -1,41 +0,0 @@ -#ifndef CALENDAR_H -#define CALENDAR_H - -#include "vcal.h" - -/* - * Reads all ics flies in path into the given vcomponent. The - * component is assumed to be a abstract ROOT element, whose first - * component will most likely become a VCALENDAR. - * - * path should either be a single .ics file (vcalendar), or a - * directory directly containing .ics files (vdir). - */ -int read_vcalendar(vcomponent* cal, char* path); - -/* - * Gets extension from filename. Writes output to ext. - * Assumes that the extension is the text between the last dot and - * the end of the string, and that no slashes can occur between the - * dot and the end. - * - * Returns the length of the extension, 0 if no extension. - */ -int get_extension(const char* filename, char* ext, ssize_t max_len); - -/* Returns 1 if path has extension ext, 0 otherwise */ -int check_ext (const char* path, const char* ext); - -/* Handle a lone ics file */ -int handle_file(vcomponent* cal, char* path); - -/* Handle a directory of ics files */ -int handle_dir(vcomponent* cal, char* path); - -/* - * Helper for opening a single ICS file. Handles file internally, and - * writes output to cal. - */ -int open_ics (char* resolved_path, vcomponent* cal); - -#endif /* CALENDAR_H */ diff --git a/config.scm b/config.scm deleted file mode 100644 index 3c6ebbb0..00000000 --- a/config.scm +++ /dev/null @@ -1,12 +0,0 @@ -;;; Preliminary config file for the system. -;;; Currently loaded by main, and requires that `calendar-files` -;;; is set to a list of files (or directories). - - -(use-modules (srfi srfi-26) - (ice-9 ftw)) - -(define calendar-files - (let ((path (string-append (getenv "HOME") "/.calendars/"))) - (map (cut string-append path <>) - (scandir path (lambda (str) (not (char=? #\. (string-ref str 0)))))))) diff --git a/err.h b/err.h deleted file mode 100644 index d9d19ec7..00000000 --- a/err.h +++ /dev/null @@ -1,42 +0,0 @@ -#ifndef ERR_H -#define ERR_H - -#include - -#include "macro.h" - -#define _RESET "\x1b[m" -#define _BLACK "\x1B[0;30m" -#define _RED "\x1B[0;31m" -#define _GREEN "\x1B[0;32m" -#define _YELLOW "\x1B[0;33m" -#define _BLUE "\x1B[0;34m" -#define _PURPLE "\x1B[0;35m" -#define _CYAN "\x1B[0;36m" -#define _WHITE "\x1B[0;37m" - -#define ERR(msg) fprintf(stderr, _RED "ERR" _RESET " (%s:%i) %s\n", __FILE__, __LINE__, #msg) -#define ERR_F(fmt, ...) fprintf(stderr, _RED "ERR" _RESET " (%s:%i) " fmt "\n", \ - __FILE__, __LINE__, ##__VA_ARGS__) - -/* Parse error */ -#define ERR_P(ctx, fmt, ...) fprintf(stderr, _RED "PARSE" _RESET " (%s:%i) %i:%i " fmt "\n", \ - __FILE__, __LINE__, (ctx)->pline, (ctx)->pcolumn, ##__VA_ARGS__) - -#define INFO(msg) fprintf(stderr, _BLUE "INFO" _RESET " (%s:%i) %s\n", __FILE__, __LINE__, #msg) -#define INFO_F(fmt, ...) fprintf(stderr, _BLUE "INFO" _RESET " (%s:%i) " fmt "\n", \ - __FILE__, __LINE__, ##__VA_ARGS__) - -#define LINE(len) do { \ - printf(_GREEN); \ - FOR(int, i, len) printf("_"); \ - printf("\n"); \ -} while (0) - -#define PRINT(T, v) do { \ - char buf[0x1000]; \ - FMT(T)(v, buf); \ - INFO_F("%s", buf); \ -} while (0) - -#endif /* ERR_H */ diff --git a/exceptions.scm b/exceptions.scm deleted file mode 100644 index 027c75ee..00000000 --- a/exceptions.scm +++ /dev/null @@ -1,5 +0,0 @@ -(define-module (exceptions) - #:export (throw-returnable)) - -(define-syntax-rule (throw-returnable symb args ...) - (call/cc (lambda (cont) (throw symb cont args ...)))) diff --git a/fetch.scm b/fetch.scm deleted file mode 100755 index a91e4d0d..00000000 --- a/fetch.scm +++ /dev/null @@ -1,31 +0,0 @@ -#!/usr/bin/guile -s -!# - -#| - | Example file which reads my regular calendar, filters it down to only - | the events between specific times, and prints that calendar in ICS - | format to standard output. - |# - -(add-to-load-path (dirname (current-filename))) - -(use-modules (srfi srfi-1) - (srfi srfi-19) - (srfi srfi-26) - (vcalendar) - (vcalendar datetime) - (vcalendar output) - (util)) - - -(begin - ;; (define *path* "/home/hugo/.calendars/b85ba2e9-18aa-4451-91bb-b52da930e977/") - (define *path* "/home/hugo/.calendars/D1/") - (define cal (make-vcomponent *path*))) - -(filter-children! - (lambda (ev) (and (eq? 'VEVENT (type ev)) - (event-in? ev (date->time-utc (string->date "2019-04-03" "~Y-~m-~d"))))) - cal) - -(serialize-vcomponent cal) diff --git a/graphs.c b/graphs.c deleted file mode 100644 index 51a26117..00000000 --- a/graphs.c +++ /dev/null @@ -1,144 +0,0 @@ -#include "graphs.h" - -#include -#include -#include -#include "err.h" - -// #define TYPE strbuf -// #include "linked_list.h" -// #include "linked_list.inc.h" -// #undef TYPE - -int create_graph_trie (vcomponent* ev, char* filename) { - FILE* f = fopen(filename, "w"); - - fputs("digraph {\n rankdir=LR;", f); - trie_to_dot(&ev->clines, f); - fputs("}", f); - - fclose(f); - - INFO_F("Wrote '%s' to '%s'", vcomponent_get_val(ev, "X-HNH-FILENAME"), filename); - - return 0; -} - -int helper_vcomponent (vcomponent* root, FILE* f) { - fprintf(f, "subgraph \"cluster_root\" { label=File; \"%p\" [label=%s] }\n", root, root->type); - - TRIE(content_line)* trie = &root->clines; - TRIE_NODE(content_line)* n = trie->root->child; - - if (! EMPTY(TRIE(content_line))(trie)) { - fprintf(f, "subgraph \"cluster_%p\" {\n", root); - fprintf(f, "\"%p\" [label=trie fontcolor=gray, color=gray];", trie); - fprintf(f, "\"%p\" -> \"%p\" [color=red]\n", root, trie); - while (n != NULL) { - fprintf(f, "\"%p\" -> \"%p\" [color=gray]\n", - (void*) trie, - (void*) n); - fprintf(f, "subgraph \"cluster_%c_%p\" {\ncolor=red; \n", - n->c, root); - trie_to_dot_helper( n, f ); - - - fputs("}", f); - n = n->next; - } - fputs("}", f); - } - - FOR(LLIST, vcomponent, child, &root->components) { - fprintf(f, "\"%p\" -> \"%p\"\n", root, child); - helper_vcomponent(child, f); - } - return 0; -} - -int create_graph_vcomponent (vcomponent* root, char* outfile) { - FILE* f = fopen(outfile, "w"); - if (f == NULL) { - ERR_F("Error opening file %s, errno = %i", outfile, errno); - return 1; - } - vcomponent* c = root; - fputs("digraph {", f); - helper_vcomponent(c, f); - fputs("}", f); - fclose(f); - return 0; -} - -#define T content_line - -int trie_to_dot ( TRIE(T)* trie, FILE* f ) { - TRIE_NODE(T)* n = trie->root->child; - fprintf(f, "\"%p\" [label=root fontcolor=gray, color=gray];", trie); - while (n != NULL) { - fprintf(f, "\"%p\" -> \"%p\" [color=gray]\n", - (void*) trie, - (void*) n); - fprintf(f, "subgraph \"cluster_%c\" {\n", - n->c); - trie_to_dot_helper( n, f ); - fputs("}", f); - n = n->next; - } - return 0; -} - -int trie_to_dot_helper ( TRIE_NODE(T)* root, FILE* f ) { - if (L(root) == NULL) { - fprintf(f, "\"%p\"[label = \"%c\" style=filled fillcolor=white];\n", - (void*) root, root->c); - } else { - fprintf(f, "\"%p\"[label = \"%c [%i]\" style=filled fillcolor=green];\n", - (void*) root, root->c, - SIZE(LLIST(content_set))(L(root)) - ); - } - TRIE_NODE(T)* child = root->child; - - // ---------------------------------------- -#if 1 /* Toggle values */ - if (L(root) != NULL) { - - FOR(LLIST, content_set, v, L(root)) { - char buf[0x100]; - FMT(strbuf)(&v->key, buf); - fprintf(f, "\"%p\" [label=\"%s\" shape=rectangle color=darkgreen];\n", - v, buf); - /* Edge between TRIE char node and data node */ - fprintf(f, "\"%p\" -> \"%p\";\n", root, v); - - /* Parameters */ - LLIST(strbuf)* keys = KEYS(TRIE(param_set))(&v->val); - FOR(LLIST, strbuf, key, keys) { - param_set* p = GET(TRIE(param_set))(&v->val, key->mem); - - fprintf(f, "\"%p\" [label=\"%s\" color=blue];\n", - key, key->mem); - /* Edge between data node and param key node */ - fprintf(f, "\"%p\" -> \"%p\";", v, key); - - FOR(LLIST, strbuf, str, p) { - fprintf(f, "\"%p\" [label=\"%s\" color=orange];", - str, str->mem); - /* Edge between param key node and param value node */ - fprintf(f, "\"%p\" -> \"%p\";", key, str); - } - } - } - } -#endif - // ---------------------------------------- - - while (child != NULL) { - fprintf(f, "\"%p\" -> \"%p\";\n", - (void*) root, (void*) child); - trie_to_dot_helper(child, f); - child = child->next; - } - return 0; -} diff --git a/graphs.h b/graphs.h deleted file mode 100644 index fe521003..00000000 --- a/graphs.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef GRAPHS_H -#define GRAPHS_H - -#include "vcal.h" - -int create_graph_trie (vcomponent* ev, char* filename); - -int create_graph_vcomponent (vcomponent* root, char* outfile); - -int helper_vcomponent (vcomponent* root, FILE* f); - -int trie_to_dot ( TRIE(content_line)*, FILE* ); -int trie_to_dot_helper ( TRIE_NODE(content_line)*, FILE* ); - -#endif /* GRAPHS_H */ diff --git a/guile_interface.h b/guile_interface.h deleted file mode 100644 index 76ec24d3..00000000 --- a/guile_interface.h +++ /dev/null @@ -1,28 +0,0 @@ -#ifndef GUILE_INTERFACE_H -#define GUILE_INTERFACE_H - -#include -#include "vcal.h" - -/* - * At a number of places scm_gc_{un,}protect_object is called. - * This is needed since most of my structures are allocated with the - * regular malloc, instead of the scm_gc_malloc variants. - * This leads to the garbage collector not realizing that I still have - * the components, and deletes them. - * - * The protection markers stop the GC from doing its thing. - */ - -void init_lib (void); -void init_vcomponent_type (void); - -SCM make_vcomponent (SCM); -SCM vcomponent_get_attribute (SCM, SCM); -SCM vcomponent_child_count (SCM); -SCM vcomponent_children (SCM); -SCM vcomponent_typeof (SCM); - -SCM scm_from_vcomponent (vcomponent*); - -#endif /* GUILE_INTERFACE_H */ diff --git a/guile_interface.scm.c b/guile_interface.scm.c deleted file mode 100644 index 3d0bff1e..00000000 --- a/guile_interface.scm.c +++ /dev/null @@ -1,220 +0,0 @@ -#include "guile_interface.h" - -#include "calendar.h" -#include "guile_type_helpers.h" - -static SCM vcomponent_type; - -void init_vcomponent_type (void) { - SCM name = scm_from_utf8_symbol("vcomponent"); - SCM slots = scm_list_1(scm_from_utf8_symbol("data")); - - vcomponent_type = scm_make_foreign_object_type(name, slots, NULL); -} - -SCM_DEFINE (make_vcomponent, "%vcomponent-make", 1, 0, 0, - (SCM path), - "Loads a vdir iCalendar from the given path.") -{ - vcomponent* cal = - (vcomponent*) scm_gc_malloc ( - sizeof(*cal), "vcomponent"); - INIT(vcomponent, cal, "ROOT"); - - char* p = scm_to_utf8_stringn(path, NULL); - read_vcalendar(cal, p); - free(p); - - return scm_from_vcomponent (cal); -} - -/* - * Returns a line from a component. - */ -SCM_DEFINE (vcomponent_get_attribute, "%vcomponent-get-attribute", 2, 0, 0, - (SCM calendar, SCM attr), - "Retuns the given attribute from the vevent object at index in calendar.") -{ - scm_assert_foreign_object_type (vcomponent_type, calendar); - vcomponent* cal = scm_foreign_object_ref (calendar, 0); - - char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL); - content_line* c = get_property (cal, key); - free(key); - - if (c == NULL) return SCM_BOOL_F; - - SCM llist = SCM_EOL; - FOR (LLIST, content_set, v, c) { - llist = scm_cons(scm_from_strbuf(&v->key), llist); - } - - /* returns the car of list if list is one long. */ - if (scm_to_int(scm_length(llist)) == 1) { - return SCM_CAR(llist); - } else { - return llist; - } -} - -SCM_DEFINE (vcomponent_set_attr_x, "%vcomponent-set-attribute!", 3, 0, 0, - (SCM component, SCM attr, SCM new_value), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* com = scm_foreign_object_ref (component, 0); - - char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL); - content_line* c = get_property (com, key); - - /* Create the position in the TRIE if it doesn't already exist */ - if (c == NULL) { - /* Insert empty key since this allows me to use the helper - * function */ - vcomponent_push_val(com, key, ""); - c = get_property (com, key); - } else { - /* If the object already exists it should be protected, - * so unprotect it - */ - scm_gc_unprotect_object(c->cur->value->key.scm); - } - - free(key); - - c->cur->value->key.scm = new_value; - scm_gc_protect_object(c->cur->value->key.scm); - - return SCM_UNSPECIFIED; -} - -SCM_DEFINE (vcomponent_child_count, "%vcomponent-child-count", 1, 0, 0, - (SCM component), - "Returns number of child components.") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* c = scm_foreign_object_ref (component, 0); - return scm_from_size_t (SIZE(LLIST(vcomponent))(&c->components)); -} - -SCM_DEFINE(vcomponent_children, "%vcomponent-children", 1, 0, 0, - (SCM component), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* cal = scm_foreign_object_ref (component, 0); - - SCM llist = SCM_EOL; - FOR (LLIST, vcomponent, v, &cal->components) { - llist = scm_cons(scm_from_vcomponent(v), llist); - } - return llist; -} - -SCM_DEFINE(vcomponent_filter_children_x, "%vcomponent-filter-children!", - 2, 0, 0, - (SCM pred, SCM component), - "Remove all children from component who DOESN'T satisfy `pred`") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* cal = scm_foreign_object_ref (component, 0); - - for (LINK(vcomponent)* l = FIRST(&cal->components); - l->after != NULL; - l = l->after) - { - if (scm_is_false(scm_call_1 (pred, scm_from_vcomponent(l->value)))) { - FFREE(vcomponent, l->value); - UNLINK(LINK(vcomponent))(l); - } - } - - return SCM_UNSPECIFIED; -} - -SCM_DEFINE(vcomponent_push_child_x, "%vcomponent-push-child!", 2, 0, 0, - (SCM component, SCM child), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - scm_assert_foreign_object_type (vcomponent_type, child); - vcomponent* comp = scm_foreign_object_ref (component, 0); - vcomponent* chil = scm_foreign_object_ref (child, 0); - - PUSH(vcomponent)(comp, chil); - - return SCM_UNSPECIFIED; -} - -SCM_DEFINE (vcomponent_parent, "%vcomponent-parent", 1, 0, 0, - (SCM component), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - - vcomponent* parent = comp->parent; - if (strcmp(parent->type, "ROOT") == 0) { - return SCM_BOOL_F; - } else { - return scm_from_vcomponent(parent); - } -} - -SCM_DEFINE(vcomponent_typeof, "%vcomponent-type", 1, 0, 0, - (SCM component), - "Returns type of vcomponent") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - return scm_from_utf8_symbol(comp->type); -} - -SCM scm_from_vcomponent(vcomponent* v) { - if (v->scm == NULL) { - v->scm = scm_make_foreign_object_1 (vcomponent_type, v); - scm_gc_protect_object(v->scm); - } - return v->scm; -} - -SCM_DEFINE(vcomponent_attr_list, "%vcomponent-attribute-list", 1, 0, 0, - (SCM component), - "Returns list of all keys in component.") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - LLIST(strbuf)* keys = KEYS(TRIE(content_line))(&comp->clines); - - SCM llist = SCM_EOL; - FOR (LLIST, strbuf, s, keys) { - llist = scm_cons(scm_from_strbuf(s), llist); - } - - FFREE(LLIST(strbuf), keys); - - return llist; -} - -SCM_DEFINE(vcomponent_shallow_copy, "%vcomponent-shallow-copy", 1, 0, 0, - (SCM component), - "Creates a shallow copy of the given component.") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* src = scm_foreign_object_ref (component, 0); - - vcomponent* dest = - (vcomponent*) scm_gc_malloc ( - sizeof(*dest), "vcomponent"); - INIT(vcomponent, dest, src->type, NULL); - vcomponent_copy (dest, src); - return scm_from_vcomponent (dest); -} - -void init_lib (void) { - init_vcomponent_type(); - -#ifndef SCM_MAGIC_SNARFER -#include "guile_interface.x" -#endif -} diff --git a/guile_type_helpers.c b/guile_type_helpers.c deleted file mode 100644 index e231f2b1..00000000 --- a/guile_type_helpers.c +++ /dev/null @@ -1,13 +0,0 @@ -#include "guile_type_helpers.h" -#include "guile_interface.h" - -#include "macro.h" - -SCM scm_from_strbuf(strbuf* s) { - if (s->scm == NULL) { - s->scm = scm_from_utf8_stringn (s->mem, s->len); - scm_gc_protect_object(s->scm); - } - - return s->scm; -} diff --git a/guile_type_helpers.h b/guile_type_helpers.h deleted file mode 100644 index 2ff177e1..00000000 --- a/guile_type_helpers.h +++ /dev/null @@ -1,13 +0,0 @@ -#ifndef GUILE_TYPE_HELPERS_H -#define GUILE_TYPE_HELPERS_H - -#include - -#include "calendar.h" -#include "strbuf.h" - -#define SCM_IS_LIST(x) scm_is_true(scm_list_p(x)) - -SCM scm_from_strbuf(strbuf* s); - -#endif /* GUILE_TYPE_HELPERS_H */ diff --git a/helpers.scm b/helpers.scm deleted file mode 100644 index 717a10d4..00000000 --- a/helpers.scm +++ /dev/null @@ -1,43 +0,0 @@ -(use-modules (srfi srfi-1) - (srfi srfi-8) ; receive - ) - -(define (nlist? l) - "Returns #t if l is a pair that is not a list." - (and (pair? l) - (not (list? l)))) - -(define (flatten tree) - "Flattens tree, should only return propper lists." - (cond ((null? tree) '()) - ((list? tree) - (if (null? (cdr tree)) - (flatten (car tree)) - (let ((ret (cons (flatten (car tree)) - (flatten (cdr tree))))) - (if (nlist? ret) - (list (car ret) (cdr ret)) - ret)))) - (else tree))) - - -(define (map-lists f lst) - "Map f over lst, if (car lst) is a list, pass the list to f. If (car list) -isn't a list, pass the rest of lst to f." - (cond ((null? lst) '()) - ((list? (car lst)) (cons (f (car lst)) - (map-lists f (cdr lst)))) - (else (f lst)))) - -(define (beautify tree) - "Takes a prefix tree and turns some characters to strings." - (define (helper branch) - (receive (head tail) - (span char? branch) - (cons (list->string head) - (beautify tail)))) - (if (or (null? tree) - (not (list? tree))) - tree - (cons (beautify (car tree)) - (map-lists helper (cdr tree))))) diff --git a/linked_list.h b/linked_list.h deleted file mode 100644 index ec1e17e0..00000000 --- a/linked_list.h +++ /dev/null @@ -1,92 +0,0 @@ -#ifndef LINKED_LIST_H -#define LINKED_LIST_H - -#include "macro.h" - -#define LLIST(T) TEMPL(llist, T) -#define LINK(T) TEMPL(llist_link, T) - -#define UNLINK(T) TEMPL(unlink, T) - -#endif /* LINKED_LIST_H */ -#ifdef TYPE - -typedef struct LINK(TYPE) { - struct LINK(TYPE)* before; - struct LINK(TYPE)* after; - TYPE* value; -} LINK(TYPE); - -#define L(link) (link)->value - -typedef struct { - LINK(TYPE)* head; - LINK(TYPE)* tail; - LINK(TYPE)* cur; - int length; -} LLIST(TYPE); - -#define FIRST(lst) (lst)->head->after -#define FIRST_V(lst) (lst)->head->after->value -#define LAST(lst) (lst)->tail->before -#define LAST_V(lst) (lst)->tail->before->value - -INIT_F ( LLIST(TYPE) ); - -/* - * NOTE freeing a linked list alsa FFREE's all its contents. - * TODO some form of shared pointer to ensure nothing is free'd twice - * would be a good idea. - */ -FREE_F ( LLIST(TYPE) ); - -INIT_F ( LINK(TYPE) ); -INIT_F ( LINK(TYPE), TYPE* val ); -FREE_F ( LINK(TYPE) ); - -int UNLINK(LINK(TYPE)) ( LINK(TYPE)* ); - -int PUSH(LLIST(TYPE)) ( LLIST(TYPE)*, TYPE* ); -TYPE* PEEK(LLIST(TYPE)) ( LLIST(TYPE)* ); -TYPE* POP(LLIST(TYPE)) ( LLIST(TYPE)* ); - -int DEEP_COPY(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* src ); - -int APPEND(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* new_ ); - -int SIZE(LLIST(TYPE)) ( LLIST(TYPE)* llist ); -int EMPTY(LLIST(TYPE)) ( LLIST(TYPE)* llist ); - -/* - * Resets a linked list by removing all it's objects. - * FREE's all elements stored in the list. - */ -int RESET(LLIST(TYPE)) ( LLIST(TYPE)* llist ); - -/* - * Takes to lists, and merges them into a single one. Destroys new_ in - * the process. - */ -LLIST(TYPE)* RESOLVE(LLIST(TYPE)) (LLIST(TYPE)* dest, LLIST(TYPE)* new_); - -FMT_F(LLIST(TYPE)); - -/* Iterator */ - -#define __PRE_LLIST(T, l, set) \ - T* l; LINK(T)* __INTER(l); - -#define PRE_FOR_LLIST(T) __PRE_LLIST - -// #define __BEG_LLIST(v, set) v = (set)->head -#define __BEG_LLIST(T, l, set) __INTER(l) = FIRST(set), l = L(__INTER(l)) -#define BEG_LLIST(T) __BEG_LLIST - -#define __END_LLIST(T, l, set) __INTER(l) != (set)->tail -#define END_LLIST(T) __END_LLIST - -#define __NXT_LLIST(T, l, set) __INTER(l) = __INTER(l)->after, l = L(__INTER(l)) -// #define __NXT_LLIST(T, l, set) l = L(__INTER(l) = __INTER(l)->after) -#define NXT_LLIST(T) __NXT_LLIST - -#endif /* TYPE */ diff --git a/linked_list.inc.h b/linked_list.inc.h deleted file mode 100644 index 81974a9c..00000000 --- a/linked_list.inc.h +++ /dev/null @@ -1,176 +0,0 @@ -#ifndef TYPE -#error "Set TYPE before including self file" -#else - -INIT_F ( LLIST(TYPE) ) { - self->length = 0; - NEW(LINK(TYPE), head); - NEW(LINK(TYPE), tail); - self->head = head; - self->tail = tail; - head->after = tail; - tail->before = head; - self->cur = head; - return 0; -} - -FREE_F (LINK(TYPE)) { - UNLINK(LINK(TYPE))(self); - - if (self->value != NULL) FFREE(TYPE, self->value); - return 0; -} - -FREE_F( LLIST(TYPE) ) { - LINK(TYPE) *n, *next; - n = self->head; - while ( n != NULL ) { - next = n->after; - FFREE(LINK(TYPE), n); - n = next; - } - - self->length = -1; - - return 0; -} - -INIT_F ( LINK(TYPE) ) { - self->before = NULL; - self->after = NULL; - self->value = NULL; - return 0; -} - -INIT_F ( LINK(TYPE), TYPE* val ) { - self->before = NULL; - self->after = NULL; - self->value = val; - return 0; -} - -int UNLINK(LINK(TYPE)) ( LINK(TYPE)* self ) { - if (self->before != NULL) self->before->after = self->after; - if (self->after != NULL) self->after->before = self->before; - return 0; -} - - -int PUSH(LLIST(TYPE)) ( LLIST(TYPE)* lst, TYPE* val) { - NEW(LINK(TYPE), link, val); - - link->after = FIRST(lst); - FIRST(lst) = link; - - link->after->before = link; - link->before = lst->head; - - ++lst->length; - - // TODO do I want to change that? - lst->cur = link; - - return 0; -} - -TYPE* PEEK(LLIST(TYPE)) ( LLIST(TYPE)* lst ) { - if (EMPTY(LLIST(TYPE))(lst)) return NULL; - - return FIRST(lst)->value; -} - -TYPE* POP(LLIST(TYPE)) ( LLIST(TYPE)* lst) { - if (EMPTY(LLIST(TYPE))(lst)) return NULL; - - LINK(TYPE)* frst = FIRST(lst); - UNLINK(LINK(TYPE))(frst); - - TYPE* retval = frst->value; - --lst->length; - free (frst); - return retval; -} - -int DEEP_COPY(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* src ) { - LINK(TYPE)* n = FIRST(src); - - while (n->after != NULL) { - NEW(TYPE, cpy); - DEEP_COPY(TYPE)(cpy, n->value); - PUSH(LLIST(TYPE)) ( dest, cpy ); - n = n->after; - } - - return 0; -} - -/* - * Adds two linked lists together. - * O(1) time. - * destroys new__ in the process, but keeps the elements. - * make sure to free(new__) after. - */ -int APPEND(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* new__ ) { - - /* Link end of dest onto start of new__. */ - LAST(dest)->after = FIRST(new__); - FIRST(new__)->before = LAST(dest); - - /* Free the two now not needed end links. */ - free(new__->head); - free(dest->tail); - - /* Update dest with new__ tail ptr. */ - dest->tail = new__->tail; - - dest->length += new__->length; - - return 0; -} - -int SIZE(LLIST(TYPE)) ( LLIST(TYPE)* llist ) { - return llist->length; -} - -int EMPTY(LLIST(TYPE)) ( LLIST(TYPE)* llist ) { - return FIRST(llist) == llist->tail; -} - -LLIST(TYPE)* RESOLVE(LLIST(TYPE)) (LLIST(TYPE)* dest, LLIST(TYPE)* new__) { - if (dest == NULL) return new__; - APPEND(LLIST(TYPE))(dest, new__); - free(new__); - return dest; -} - -int RESET(LLIST(TYPE)) ( LLIST(TYPE)* llist ) { - - LINK(TYPE) *link = FIRST(llist), *next; - /* - * Manual looping rather than itterators since we destroyed the - * loop variable. - */ - while (link != llist->tail) { - next = link->after; - FFREE(LINK(TYPE), link); - link = next; - } - - llist->cur = llist->head; - - return 0; -} - -FMT_F(LLIST(TYPE)) { - int seek = 0; - fmtf("("); - FOR(LLIST, TYPE, v, self) { - seek += FMT(TYPE)(v, buf + seek); - fmtf(" "); - } - fmtf(")"); - - return seek; -} - -#endif /* TYPE */ diff --git a/macro.h b/macro.h deleted file mode 100644 index 7b620f83..00000000 --- a/macro.h +++ /dev/null @@ -1,134 +0,0 @@ -#ifndef MACRO_H -#define MACRO_H - -/* - * Token paste - */ -#define TP(a, b) a ## b -#define TP3(a, b, c) a ## b ## c -#define TP4(a, b, c, d) a ## b ## c ## d -#define TP5(a, b, c, d, e) a ## b ## c ## d ## e -#define TP6(a, b, c, d, e, f) a ## b ## c ## d ## e ## f - -/* - * Get length of __VA_ARGS__ - * Borrowed fram: - * https://stackoverflow.com/a/35986932 - */ -#define VA_ARGS_NUM_PRIV(P1, P2, P3, P4, P5, P6, Pn, ...) Pn -#define VA_ARGS_NUM(...) VA_ARGS_NUM_PRIV(-1, ## __VA_ARGS__, 5, 4, 3, 2, 1, 0) - -/* - * Templatization macros. Forms symbols on the from name, which - * looks really good in debuggers and the like. Unicode characters - * written in \U notation since C apparently doesn't support unicode - * literals. - * - * Can be nested (useful for container types). - * - * Doesn't use ASCII <>, but rather some other ᐸᐳ, meaning that it's - * not a reserved character. - * - * nameᐸTᐳ - */ -#define TEMPL(name, T) TP4(name, \U00001438 , T, \U00001433 ) -#define TEMPL2(name, T, V) TP6(name, \U00001438\U00001438 , T , \U00001433_\U00001438 , V, \U00001433\U00001433) -#define TEMPL_N(name, T, argcount) TP6(name, \U00001438 , T, _, argcount, \U00001433 ) - -/* Constructor type name */ -#define __INIT_T(T, C) TEMPL_N(init, T, C) - -/* Returns full type of constructor */ -#define INIT_F(T, ...) \ - int __INIT_T(T, VA_ARGS_NUM(__VA_ARGS__)) (T* self, ## __VA_ARGS__) - -/* - * Call the constructor of an object - * `int` part of the macro, to ensure that any attempt to call self - * function results in an error. - */ -#define INIT(T, N, ...) \ - __INIT_T(T, VA_ARGS_NUM(__VA_ARGS__)) (N, ## __VA_ARGS__) - -/* Allocate a new_ object on the HEAP */ -#define NEW(T, N, ...) \ - T* N = (T*) malloc(sizeof(*N)); \ - INIT(T, N, ## __VA_ARGS__); - -/* - * Reconstructs a object. Use with caution. - */ -#define RENEW(T, N, ...) do { \ - N = (T*) malloc(sizeof(*N)); \ - INIT(T, N, ## __VA_ARGS__); \ -} while (0) - - -/* Allocate a new_ object on the STACK */ -#define SNEW(T, N, ...) \ - T N; \ - INIT(T, & N, ## __VA_ARGS__); - -/* Destructor for type */ -#define FREE(T) TEMPL(free, T) - -/* Call destructor for type, and free object */ -#define FFREE(T, N) do { FREE(T)(N); free(N); } while (0) - -/* Declare destructor */ -#define FREE_F(T) int FREE(T) (T* self) - -/* generate reusable internal symbol */ -#define __INTER(s) TP3(__, s, __internal) -#define __INTER2(s) __INTER(__INTER(s)) -#define __INTER3(s) __INTER(__INTER(__INTER(s))) - -/* Iterator macros. */ -#define FOR(CONT_T, T, var, set) \ - PRE_FOR_ ## CONT_T (T) (T, var, set); \ - for( BEG_ ## CONT_T (T) (T, var, set); \ - END_ ## CONT_T (T) (T, var, set); \ - NXT_ ## CONT_T (T) (T, var, set)) - -/* Example int implementation - * FOR(int, i, 10) { } */ - -#define PRE_FOR_int(i, set) -#define BEG_int(i, set) int i = 0 -#define NXT_int(i, set) i++ -#define END_int(i, set) i < set - -/* - * General functions that different container types may implement. - * Actuall implementation and type signature is mostly left to - * individual implementations. - */ -#define DEEP_COPY(T) TEMPL(copy , T) -#define RESOLVE(T) TEMPL(resolve , T) -#define APPEND(T) TEMPL(append , T) -#define SIZE(T) TEMPL(size , T) -#define EMPTY(T) TEMPL(empty , T) -#define PUSH(T) TEMPL(push , T) -#define PEEK(T) TEMPL(peek , T) -#define POP(T) TEMPL(pop , T) -#define GET(T) TEMPL(get , T) -#define RESET(T) TEMPL(reset , T) -#define KEYS(T) TEMPL(keys , T) - -/* - * Formatting macros. - * Transform objects into string representation of themselves. - * buf should be a suffisiently large memmory location, if it's to - * small then bad stuff might happen. - * - * Should return the number of bytes written (like sprintf). - */ - -#define FMT_T(T) TEMPL(format , T) -#define FMT_F(T) int FMT_T(T)(T* self, char* buf, ...) -// TODO change order of buf and item -#define __FMT_HELP(item, buf, ...) ((item), (buf), VA_ARGS_NUM(__VA_ARGS__), ## __VA_ARGS__) -#define FMT(T) FMT_T(T) __FMT_HELP -#define fmtf(...) seek += sprintf(buf + seek, __VA_ARGS__) - -#endif /* MACRO_H */ diff --git a/main.c b/main.c deleted file mode 100644 index 791bc5d3..00000000 --- a/main.c +++ /dev/null @@ -1,91 +0,0 @@ -#include -#include -#include -#include - -#include "calendar.h" -#include "macro.h" -#include "vcal.h" -#include "graphs.h" -#include "err.h" - -typedef struct { - int argc; - char** argv; -} arg; - -int arg_shift (arg* a) { - if (a->argc == 0) return 0; - - ++a->argv; - return --a->argc; - -} - -int main (int argc, char** argv) { - arg args = { .argc = argc, .argv = argv }; - - if (arg_shift(&args) == 0) { - ERR("Please give vdir or a vcalendar file as first argument"); - exit (1); - } - - char* rootpath = args.argv[0]; - SNEW(vcomponent, root, "ROOT", rootpath); - read_vcalendar(&root, rootpath); - - arg_shift(&args); - - if (args.argc == 0 || strcmp(args.argv[0], "-p") == 0) { - INFO_F("Parsed calendar file containing [%u] events", - root.components.length); - - puts("CAL : OBJ | Filename | Description"); - puts("----------+----------+------------"); - - /* This loops over all VCALENDAR's in root */ - FOR (LLIST, vcomponent, cal, &root.components) { - assert(strcmp(cal->type, "VCALENDAR") == 0); - - char* filename = vcomponent_get_val(cal, "X-HNH-FILENAME"); - - /* This loop over all VEVENT's in the current VCALENDAR */ - FOR (LLIST, vcomponent, ev, &cal->components) { - if (strcmp(ev->type, "VEVENT") != 0) continue; - - printf("%s | %s\n", - filename, - get_property(ev, "SUMMARY")->cur->value->key.mem); - } - } - } else if (strcmp(args.argv[0], "-g") == 0) { - /* TODO self might be broken */ - if (arg_shift(&args) == 0) { - FOR (LLIST, vcomponent, cal, &root.components) { - assert(strcmp(cal->type, "VCALENDAR") == 0); - - vcomponent* ev = FCHILD(cal); - - char target[0xFF]; - target[0] = '\0'; - strcat(target, "/tmp/dot/"); - strcat(target, vcomponent_get_val(ev, "X-HNH-FILENAME")); - strcat(target, ".dot"); - // create_graph(ev, target); - } - } else { - // create_graph(FCHILD(FCHILD(&root)), args.argv[0]); - INFO("Creating graph for single file"); - INFO_F("output = %s\n", args.argv[0]); - create_graph_vcomponent(&root, args.argv[0]); - } - } - - /* - char buf[0x20000]; - FMT(vcomponent)(&root, buf); - puts(buf); - */ - - FREE(vcomponent)(&root); -} diff --git a/main.scm b/main.scm deleted file mode 100755 index 223b3d2e..00000000 --- a/main.scm +++ /dev/null @@ -1,139 +0,0 @@ -#!/usr/bin/guile \ --e main -s -!# - -(add-to-load-path (dirname (current-filename))) - -(use-modules (srfi srfi-1) - (srfi srfi-19) - (srfi srfi-19 util) - (srfi srfi-26) - (srfi srfi-41) - (srfi srfi-41 util) - (ice-9 format) - (texinfo string-utils) ; string->wrapped-lines - (util) - (vcalendar) - (vcalendar recur) - (vcalendar datetime) - (vcalendar output) - (terminal escape) - (terminal util)) - -(define (ev-timetime-utc (current-date))) - (define cur-event 0) - (let loop ((char #\nul)) - (let ((events - (merge (filter-sorted - (cut event-in? <> time) - regular-events) - - (stream->list - (filter-sorted-stream - (cut event-in? <> time) - repeating-events)) - - ev-timedate time)) - ;; (line) - (format #t "~a┬~a┬~a~%" - (make-string 20 #\─) - (make-string 32 #\─) - (make-string 10 #\─)) - - - (for-each - (lambda (ev i) - (format #t "~a │ ~a~a~a~a │ ~a~a~%" - (time->string (attr ev 'DTSTART) "~1 ~3") ; TODO show truncated string - (if (= i cur-event) "\x1b[7m" "") - (color-escape (attr (parent ev) 'COLOR)) - (trim-to-width (attr ev 'SUMMARY) 30) - STR-RESET - (trim-to-width - (or (attr ev 'LOCATION) "\x1b[1;30mINGEN LOKAL") 20) - STR-RESET)) - events - (iota (length events))) - - (format #t "~a┴~a┴~a~%" - (make-string 20 #\─) - (make-string 32 #\─) - (make-string 10 #\─)) - - (unless (null? events) - (let ((ev (list-ref events cur-event))) - (format #t "~a~%~aStart: ~a Slut: ~a~%~%~a~%" - (attr ev 'SUMMARY) - (or (and=> (attr ev 'LOCATION) (cut string-append "Plats: " <> "\n")) "") - (time->string (attr ev 'DTSTART) "~1 ~3") - (time->string (attr ev 'DTEND) "~1 ~3") - (string-join ; TODO replace this with a better text flower - (take-to ; This one destroys newlines used for layout - (string->wrapped-lines (or (attr ev 'DESCRIPTION) "") - #:line-width 60 - #:collapse-whitespace? #f) - 10) - (string #\newline)) - ))) - - ;; (format #t "c = ~c (~d)~%" char (char->integer char)) - - (unless (or (eof-object? char) - ;; TODO this requires that `q' is pressed as many - ;; times as other inputs where pressed to actually - ;; quit. - ;; ^C only works because it force closes the - ;; program. - (memv char (list #\q (ctrl #\C)))) - (loop (read-char (current-input-port))))))) - -(load "config.scm") - - -(define (main args) - - (define calendars (map make-vcomponent calendar-files)) - (define events (concatenate (map (cut children <> 'VEVENT) calendars))) - - (let* ((repeating regular (partition repeating? events))) - (sort*! repeating time) + (scandir path (lambda (str) (not (char=? #\. (string-ref str 0)))))))) diff --git a/module/exceptions.scm b/module/exceptions.scm new file mode 100644 index 00000000..027c75ee --- /dev/null +++ b/module/exceptions.scm @@ -0,0 +1,5 @@ +(define-module (exceptions) + #:export (throw-returnable)) + +(define-syntax-rule (throw-returnable symb args ...) + (call/cc (lambda (cont) (throw symb cont args ...)))) diff --git a/module/fetch.scm b/module/fetch.scm new file mode 100755 index 00000000..a91e4d0d --- /dev/null +++ b/module/fetch.scm @@ -0,0 +1,31 @@ +#!/usr/bin/guile -s +!# + +#| + | Example file which reads my regular calendar, filters it down to only + | the events between specific times, and prints that calendar in ICS + | format to standard output. + |# + +(add-to-load-path (dirname (current-filename))) + +(use-modules (srfi srfi-1) + (srfi srfi-19) + (srfi srfi-26) + (vcalendar) + (vcalendar datetime) + (vcalendar output) + (util)) + + +(begin + ;; (define *path* "/home/hugo/.calendars/b85ba2e9-18aa-4451-91bb-b52da930e977/") + (define *path* "/home/hugo/.calendars/D1/") + (define cal (make-vcomponent *path*))) + +(filter-children! + (lambda (ev) (and (eq? 'VEVENT (type ev)) + (event-in? ev (date->time-utc (string->date "2019-04-03" "~Y-~m-~d"))))) + cal) + +(serialize-vcomponent cal) diff --git a/module/helpers.scm b/module/helpers.scm new file mode 100644 index 00000000..717a10d4 --- /dev/null +++ b/module/helpers.scm @@ -0,0 +1,43 @@ +(use-modules (srfi srfi-1) + (srfi srfi-8) ; receive + ) + +(define (nlist? l) + "Returns #t if l is a pair that is not a list." + (and (pair? l) + (not (list? l)))) + +(define (flatten tree) + "Flattens tree, should only return propper lists." + (cond ((null? tree) '()) + ((list? tree) + (if (null? (cdr tree)) + (flatten (car tree)) + (let ((ret (cons (flatten (car tree)) + (flatten (cdr tree))))) + (if (nlist? ret) + (list (car ret) (cdr ret)) + ret)))) + (else tree))) + + +(define (map-lists f lst) + "Map f over lst, if (car lst) is a list, pass the list to f. If (car list) +isn't a list, pass the rest of lst to f." + (cond ((null? lst) '()) + ((list? (car lst)) (cons (f (car lst)) + (map-lists f (cdr lst)))) + (else (f lst)))) + +(define (beautify tree) + "Takes a prefix tree and turns some characters to strings." + (define (helper branch) + (receive (head tail) + (span char? branch) + (cons (list->string head) + (beautify tail)))) + (if (or (null? tree) + (not (list? tree))) + tree + (cons (beautify (car tree)) + (map-lists helper (cdr tree))))) diff --git a/module/main.scm b/module/main.scm new file mode 100755 index 00000000..223b3d2e --- /dev/null +++ b/module/main.scm @@ -0,0 +1,139 @@ +#!/usr/bin/guile \ +-e main -s +!# + +(add-to-load-path (dirname (current-filename))) + +(use-modules (srfi srfi-1) + (srfi srfi-19) + (srfi srfi-19 util) + (srfi srfi-26) + (srfi srfi-41) + (srfi srfi-41 util) + (ice-9 format) + (texinfo string-utils) ; string->wrapped-lines + (util) + (vcalendar) + (vcalendar recur) + (vcalendar datetime) + (vcalendar output) + (terminal escape) + (terminal util)) + +(define (ev-timetime-utc (current-date))) + (define cur-event 0) + (let loop ((char #\nul)) + (let ((events + (merge (filter-sorted + (cut event-in? <> time) + regular-events) + + (stream->list + (filter-sorted-stream + (cut event-in? <> time) + repeating-events)) + + ev-timedate time)) + ;; (line) + (format #t "~a┬~a┬~a~%" + (make-string 20 #\─) + (make-string 32 #\─) + (make-string 10 #\─)) + + + (for-each + (lambda (ev i) + (format #t "~a │ ~a~a~a~a │ ~a~a~%" + (time->string (attr ev 'DTSTART) "~1 ~3") ; TODO show truncated string + (if (= i cur-event) "\x1b[7m" "") + (color-escape (attr (parent ev) 'COLOR)) + (trim-to-width (attr ev 'SUMMARY) 30) + STR-RESET + (trim-to-width + (or (attr ev 'LOCATION) "\x1b[1;30mINGEN LOKAL") 20) + STR-RESET)) + events + (iota (length events))) + + (format #t "~a┴~a┴~a~%" + (make-string 20 #\─) + (make-string 32 #\─) + (make-string 10 #\─)) + + (unless (null? events) + (let ((ev (list-ref events cur-event))) + (format #t "~a~%~aStart: ~a Slut: ~a~%~%~a~%" + (attr ev 'SUMMARY) + (or (and=> (attr ev 'LOCATION) (cut string-append "Plats: " <> "\n")) "") + (time->string (attr ev 'DTSTART) "~1 ~3") + (time->string (attr ev 'DTEND) "~1 ~3") + (string-join ; TODO replace this with a better text flower + (take-to ; This one destroys newlines used for layout + (string->wrapped-lines (or (attr ev 'DESCRIPTION) "") + #:line-width 60 + #:collapse-whitespace? #f) + 10) + (string #\newline)) + ))) + + ;; (format #t "c = ~c (~d)~%" char (char->integer char)) + + (unless (or (eof-object? char) + ;; TODO this requires that `q' is pressed as many + ;; times as other inputs where pressed to actually + ;; quit. + ;; ^C only works because it force closes the + ;; program. + (memv char (list #\q (ctrl #\C)))) + (loop (read-char (current-input-port))))))) + +(load "config.scm") + + +(define (main args) + + (define calendars (map make-vcomponent calendar-files)) + (define events (concatenate (map (cut children <> 'VEVENT) calendars))) + + (let* ((repeating regular (partition repeating? events))) + (sort*! repeating timestring + add-day remove-day)) + +#; +(define (copy-date date) + "Returns a copy of the given date structure" + (let* ((date-type (@@ (srfi srfi-19) date)) + (access (lambda (field) ((record-accessor date-type field) date)))) + (apply make-date (map access (record-type-fields date-type))))) + +(define (drop-time! date) + "Sets the hour, minute, second and nanosecond attribute of date to 0." + (set! (hour date) 0) + (set! (minute date) 0) + (set! (second date) 0) + (set! (nanosecond date) 0) + date) + +(define (drop-time date) + "Returns a copy of date; with the hour, minute, second and nanosecond +attribute set to 0. Can also be seen as \"Start of day\"" + (set-fields date + ((date-hour) 0) + ((date-minute) 0) + ((date-second) 0) + ((date-nanosecond) 0))) + +(define (make-duration s) + (make-time time-duration 0 s)) + +(define (in-day? day-date time) + (let* ((now (date->time-utc (drop-time day-date))) + (then (add-duration now (make-duration (* 60 60 24))))) + (and (time<=? now time) + (time<=? time then)))) + +(define (today? time) + (in-day? (current-date) time)) + +(define* (time->string time #:optional (format "~1 ~3")) + (date->string (time-utc->date time) format)) + + +(define (add-day time) + (add-duration time (make-time time-duration 0 (* 60 60 24)))) + +(define (remove-day time) + (add-duration time (make-time time-duration 0 (- (* 60 60 24))))) + +;; A B C D ¬E +;; |s1| : |s2| : |s1| : |s2| : |s1| +;; | | : | | : | ||s2| : |s1|| | : | | +;; | ||s2| : |s1|| | : | || | : | || | : +;; | | : | | : | || | : | || | : |s2| +;; | | : | | : | | : | | : | | +(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end) + "Return whetever or not two timespans overlap." + (or + ;; A + (and (time<=? s2-begin s1-end) + (time<=? s1-begin s2-end)) + + ;; B + (and (time<=? s1-begin s2-end) + (time<=? s2-begin s1-end)) + + ;; C + (and (time<=? s1-begin s2-begin) + (time<=? s2-end s1-end)) + + ;; D + (and (time<=? s2-begin s1-begin) + (time<=? s1-end s2-end)))) diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm new file mode 100644 index 00000000..5bef95cb --- /dev/null +++ b/module/srfi/srfi-41/util.scm @@ -0,0 +1,29 @@ +(define-module (srfi srfi-41 util) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-41) + #:use-module (util) ; let*, find-min + #:export (stream-car+cdr interleave-streams)) + +(define (stream-car+cdr stream) + (values (stream-car stream) + (stream-cdr stream))) + +;; Merges a number of totally ordered streams into a single +;; totally ordered stream. +;; ((≺, stream)) → (≺, stream) +(define (interleave-streams < streams) + ;; Drop all empty streams + (let ((streams (remove stream-null? streams))) + ;; If all streams where empty, end the output stream + (if (null? streams) + stream-null + (let* ((min other (find-min < stream-car streams)) + (m ms (stream-car+cdr min))) + (stream-cons m (interleave-streams < (cons ms other))))))) + +;;; Varför är allting så långsamt‽‽‽‽‽‽‽‽ + +(define-public (filter-sorted-stream proc stream) + (stream-take-while + proc (stream-drop-while + (negate proc) stream))) diff --git a/module/terminal/escape.scm b/module/terminal/escape.scm new file mode 100644 index 00000000..8f1b0c2b --- /dev/null +++ b/module/terminal/escape.scm @@ -0,0 +1,28 @@ +;;; Module for terminal (ANSI) escape codes. + +(define-module (terminal escape) + #:use-module (srfi srfi-60) + #:use-module (terminal termios) + #:export (with-vulgar)) + +(define-public (cls) + (display "\x1b[H") ; Move cursor to the origin + (display "\x1b[J") ; Clear everything after cursor + ) + +;;; I don't curse, I'm just vulgar. + +(define-syntax with-vulgar + (syntax-rules () + ((_ thunk) + (let ((ifd (fileno (current-input-port))) + (ofd (fileno (current-output-port)))) + (dynamic-wind + (lambda () + (let ((bits (bitwise-ior ECHO ICANON))) + (c-lflags-disable! ifd bits) + (c-lflags-disable! ofd bits))) + thunk + (lambda () + (c-lflag-restore! ifd) + (c-lflag-restore! ofd)))) ))) diff --git a/module/terminal/termios.scm b/module/terminal/termios.scm new file mode 100644 index 00000000..50683f84 --- /dev/null +++ b/module/terminal/termios.scm @@ -0,0 +1,13 @@ +;;; Module for termios interaction from Guile, +;;; Since that for some reason isn't built in. + +(define-module (terminal termios) + #:export (c-lflags-disable! c-lflag-restore!)) + +(define-public ECHO #x0000010) +(define-public ICANON #x0000002) + +(setenv "LD_LIBRARY_PATH" + (string-append (dirname (dirname (dirname (current-filename)))) + "/lib")) +(load-extension "libtermios" "init_termios") diff --git a/module/terminal/util.scm b/module/terminal/util.scm new file mode 100644 index 00000000..a7435ad8 --- /dev/null +++ b/module/terminal/util.scm @@ -0,0 +1,37 @@ +(define-module (terminal util) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-60) + #:export (line ctrl color-escape)) + +(define* (line #:optional (width 64)) + (display (make-string width #\_)) + (newline)) + +(define (ctrl char) + (integer->char (bitwise-and #b00011111 (char->integer char)))) + +(define-public (display-calendar-header! date) + (let* ((day (number->string (date-day date))) + (month (number->string (date-month date))) + (year (number->string (date-year date)))) + ;; BSD cal only supports setting highlighted day explicitly for + ;; testing the functionality. This seems to at least give me + ;; an (almost) working display, albeit ugly. + (if (file-exists? "/usr/bin/ncal") + (system* "ncal" "-3" "-H" (format #f "~a-~a-~a" + year month day) + month year) + (system* "cal" "-3" day month year)))) + +(define (color-escape n) + (cond ((not n) "") + ((char=? #\# (string-ref n 0)) + (let* ((str (string-drop n 1)) + (rs (substring str 0 2)) + (gs (substring str 2 4)) + (bs (substring str 4 6))) + (format #f "\x1b[38;2;~a;~a;~am" + (string->number rs 16) + (string->number gs 16) + (string->number bs 16)))))) + diff --git a/module/test.scm b/module/test.scm new file mode 100755 index 00000000..10c6c1a1 --- /dev/null +++ b/module/test.scm @@ -0,0 +1,77 @@ +#!/usr/bin/guile -s +!# + +(add-to-load-path (dirname (current-filename))) + +(use-modules (rnrs base) ; assert + (srfi srfi-1) + (srfi srfi-19) + (srfi srfi-19 util) + (srfi srfi-41) + (vcalendar) + (vcalendar output) + (vcalendar recur)) + +(define cal (make-vcomponent "../testcal/repeating-event.ics")) + +(define ev (car (children cal 'VEVENT))) + +(define ev-copy (copy-vcomponent ev)) + +(assert (equal? (children ev) + (children ev-copy))) + +(define (display-timespan ev) + (format #t "~a ~a ~a -- ~a~%" + (attr ev 'NEW_ATTR) + (attr ev 'N) + (time->string (attr ev "DTSTART")) + (time->string (attr ev "DTEND")))) + +(display (attr ev 'N)) (newline) +(display-timespan ev) +(display (attr ev 'NEW_ATTR)) (newline) +(newline) +(define strm (generate-recurrence-set ev)) +(display (attr ev 'RRULE)) (newline) + +(if #f + (begin + (stream-for-each display-timespan (stream-take 20 strm)) + + (newline) + + ;; (define strm (generate-recurrence-set ev)) + (display (attr ev 'RRULE)) (newline) + + ;; This makes the amount of events lookad at before have the same DTSTART, + ;; which is the last from that set. The one's after that however are fine. + (stream-for-each display-timespan (stream-take 40 strm)) + (newline) + ;; This makes all the DTSTART be the last dtstart + ;; (for-each display-timespan (stream->list (stream-take 20 strm))) + +;;; I believe that I might have something to do with the stream's cache. + + (newline) + + (display-timespan ev) + (display (attr ev 'NEW_ATTR)) + (newline)) + (begin + ;; These two acts as one large unit. + ;; Something modifies the initial ev even though it shouldn't + (display-timespan ev) + (stream-for-each + display-timespan + (stream-take 20 (generate-recurrence-set (copy-vcomponent ev)))) + (newline) + (display-timespan ev) + (newline) + (stream-for-each + display-timespan + (stream-take 40 (generate-recurrence-set (copy-vcomponent ev)))) + (newline) + (display-timespan ev) + )) + diff --git a/module/util.scm b/module/util.scm new file mode 100644 index 00000000..6f1b955a --- /dev/null +++ b/module/util.scm @@ -0,0 +1,168 @@ +(define-module (util) + #:use-module (srfi srfi-1) + #:use-module ((sxml fold) #:select (fold-values)) + #:export (destructure-lambda let-multi fold-lists catch-let + for-each-in + define-quick-record define-quick-record! + mod! sort* sort*! + find-min) + #:replace (let*) + ) + +(define-public upstring->symbol (compose string->symbol string-upcase)) + +(define-public symbol-upcase (compose string->symbol string-upcase symbol->string)) + +(define-public symbol-downcase (compose string->symbol string-downcase symbol->string)) + +(define-syntax destructure-lambda + (syntax-rules () + ((_ expr-list body ...) + (lambda (expr) + (apply (lambda expr-list body ...) expr))))) + +(define-syntax catch-let + (syntax-rules () + ((_ thunk ((type handler) ...)) + (catch #t thunk + (lambda (err . args) + (case err + ((type) (apply handler err args)) ... + (else (format #t "Unhandled error type ~a, rethrowing ~%" err) + (apply throw err args)))))))) + +;;; For-each with arguments in reverse order. +(define-syntax-rule (for-each-in lst proc) + (for-each proc lst)) + + +;;; Helper macros to make define-quick-record better + +(define (class-name symb) (symbol-append '< symb '>)) +(define (constructor symb) (symbol-append 'make- symb)) +(define (pred symb) (symbol-append symb '?)) + +(define (getter name symb) (symbol-append 'get- name '- symb)) +(define* (setter name symb #:optional bang?) + (symbol-append 'set- name '- symb (if bang? '! (symbol)))) + +(define (%define-quick-record internal-define bang? name fields) + (let ((symb (gensym))) + `((,internal-define ,(class-name name) + (,(constructor name) ,@fields) + ,(pred name) + ,@(map (lambda (f) `(,f ,(getter f symb) ,(setter f symb bang?))) + fields)) + ,@(map (lambda (f) `(define ,f (make-procedure-with-setter + ,(getter f symb) ,(setter f symb bang?)))) + fields)))) + +;;; Creates srfi-9 define{-immutable,}-record-type declations. +;;; Also creates srfi-17 accessor ((set! (access field) value)) + +;; (define (define-quick-record-templated define-proc name field)) + +(define-macro (define-quick-record name . fields) + (let ((public-fields (or (assoc-ref fields #:public) '())) + (private-fields (or (assoc-ref fields #:private) '()))) + `(begin + ,@(%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type) + #f name + (append public-fields private-fields)) + ,@(map (lambda (field) `(export ,field)) + public-fields)))) + ;; (define-quick-record-templated 'define-immutable-record-type name fields)) + +;; (define-macro (define-quick-record! name . fields) +;; (define-quick-record-templated 'define-record-type name fields)) + +;; Replace let* with a version that can bind from lists. +;; Also supports SRFI-71 (extended let-syntax for multiple values) +;; @lisp +;; (let* ([a b (values 1 2)] ; @r{SRFI-71} +;; [(c d) '(3 4)] ; @r{Let-list (mine)} +;; [e 5]) ; @r{Regular} +;; (list e d c b a)) +;; ;; => (5 4 3 2 1) +;; @end lisp +(define-syntax let* + (syntax-rules () + + ;; Base case + [(_ () body ...) + (begin body ...)] + + ;; (let (((a b) '(1 2))) (list b a)) => (2 1) + [(_ (((k k* ...) list-value) rest ...) + body ...) + (apply (lambda (k k* ...) + (let* (rest ...) + body ...)) + list-value)] + + ;; "Regular" case + [(_ ((k value) rest ...) body ...) + (let ((k value)) + (let* (rest ...) + body ...))] + + ;; SRFI-71 let-values + [(_ ((k k* ... values) rest ...) body ...) + (call-with-values (lambda () values) + (lambda (k k* ...) + (let* (rest ...) + body ...)))] + + )) + +;; Like set!, but applies a transformer on the already present value. +(define-syntax-rule (mod! field transform-proc) + (set! field (transform-proc field))) + +(define-public (concat lists) + (apply append lists)) + +;; This function borrowed from web-ics (calendar util) +(define* (sort* items comperator #:optional (get identity)) + "A sort function more in line with how python's sorted works" + (sort items (lambda (a b) + (comperator (get a) + (get b))))) + +;;; This function borrowed from web-ics (calendar util) +(define* (sort*! items comperator #:optional (get identity)) + "A sort function more in line with how python's sorted works" + (sort! items (lambda (a b) + (comperator (get a) + (get b))))) + +;; Finds the smallest element in @var{items}, compared with @var{<} after +;; applying @var{foo}. Returns 2 values. The smallest item in @var{items}, +;; and the other items in some order. +(define (find-min < ac items) + (if (null? items) + ;; Vad fan retunerar man här? + (values #f '()) + (fold-values + (lambda (c min other) + (if (< (ac c) (ac min)) + ;; Current stream head is smaller that previous min + (values c (cons min other)) + ;; Previous min is still smallest + (values min (cons c other)))) + (cdr items) + ;; seeds: + (car items) '()))) + +(define-public (filter-sorted proc list) + (take-while + proc (drop-while + (negate proc) list))) + +;; (define (!= a b) (not (= a b))) +(define-public != (negate =)) + +(define-public (take-to lst i) + "Like @var{take}, but might lists shorter than length." + (if (> i (length lst)) + lst (take lst i))) diff --git a/module/vcalendar.scm b/module/vcalendar.scm new file mode 100644 index 00000000..3f7ba6ba --- /dev/null +++ b/module/vcalendar.scm @@ -0,0 +1,112 @@ +(define-module (vcalendar) + #:use-module (vcalendar primitive) + #:use-module (vcalendar datetime) + #:use-module (vcalendar recur) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (util) + #:re-export (repeating?)) + +(define (parse-dates! cal) + "Parse all start times into scheme date objects." + (for-each-in (children cal 'VEVENT) + (lambda (ev) + (mod! (attr ev "DTSTART") parse-datetime) + (mod! (attr ev "DTEND") parse-datetime))) + cal) + + +(define-public (type-filter t lst) + (filter (lambda (e) (eqv? t (type e))) + lst)) + +(define* (children component #:optional only-type) + (let ((childs (%vcomponent-children component))) + (if only-type + (type-filter only-type childs) + childs))) +(export children) + +(define (set-attr! component attr value) + (%vcomponent-set-attribute! + component + (if (symbol? attr) (symbol->string attr) attr) + value)) + +(define (get-attr component attr) + (%vcomponent-get-attribute + component + (if (symbol? attr) (symbol->string attr) attr))) + +;; Enables symmetric get and set: +;; (set! (attr ev "KEY") 10) +(define-public attr (make-procedure-with-setter get-attr set-attr!)) + +(define-public type %vcomponent-type) +(define-public parent %vcomponent-parent) +(define-public push-child! %vcomponent-push-child!) +(define-public (attributes component) (map string->symbol (%vcomponent-attribute-list component))) + +(define-public copy-vcomponent %vcomponent-shallow-copy) + +(define-public filter-children! %vcomponent-filter-children!) + +(define-public (search cal term) + (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev))) + (children cal)))) + (find (lambda (ev) (string-contains-ci (car ev) term)) + (map cons (map (cut get-attr <> "SUMMARY") + events) + events))))) + +(define-public (extract field) + (cut get-attr <> field)) + +(define-public (key=? k1 k2) + (eq? + (if (string? k1) (string->symbol k1) k1) + (if (string? k2) (string->symbol k2) k2))) + +(define-public (make-vcomponent path) + (let* ((root (%vcomponent-make path)) + (component + (parse-dates! + (case (string->symbol (or (attr root "TYPE") "no-type")) + ;; == Single ICS file == + ;; Remove the abstract ROOT component, + ;; returning the wanted VCALENDAR component + ((file) + (car (%vcomponent-children root))) + + ;; == Assume vdir == + ;; Also removes the abstract ROOT component, but also + ;; merges all VCALENDAR's children into the first + ;; VCALENDAR, and return that VCALENDAR. + ;; + ;; TODO the other VCALENDAR components might not get thrown away, + ;; this since I protect them from the GC in the C code. + ((vdir) + (reduce (lambda (cal accum) + (for-each (lambda (component) + (case (type component) + ((VTIMEZONE) + (let ((zones (children cal 'VTIMEZONE))) + (unless (find (lambda (z) + (string=? (attr z "TZID") + (attr component "TZID"))) + zones) + (%vcomponent-push-child! accum component)))) + (else (%vcomponent-push-child! accum component)))) + (%vcomponent-children cal)) + accum) + '() (%vcomponent-children root))) + + ((no-type) (throw 'no-type)) + + (else (throw 'something)))))) + + (set! (attr component "NAME") + (attr root "NAME")) + (set! (attr component "COLOR") + (attr root "COLOR")) + component)) diff --git a/module/vcalendar/control.scm b/module/vcalendar/control.scm new file mode 100644 index 00000000..a38d678f --- /dev/null +++ b/module/vcalendar/control.scm @@ -0,0 +1,39 @@ +(define-module (vcalendar control) + #:use-module (util) + #:use-module (vcalendar) + #:export (with-replaced-attrs)) + + +(eval-when (expand load) ; No idea why I must have load here. + (define href (make-procedure-with-setter hashq-ref hashq-set!)) + + (define (set-temp-values! table component kvs) + (for-each (lambda (kv) + (let* (((key val) kv)) + (when (attr component key) + (set! (href table key) (attr component key)) + (set! (attr component key) val)))) + kvs)) + + (define (restore-values! table component keys) + (for-each (lambda (key) + (and=> (href table key) + (lambda (val) + (set! (attr component key) val)))) + keys))) + +;;; TODO with-added-attributes + +(define-syntax with-replaced-attrs + (syntax-rules () + [(_ (component (key val) ...) + body ...) + + (let ((htable (make-hash-table 10))) + (dynamic-wind + (lambda () (set-temp-values! htable component (quote ((key val) ...)))) ; In guard + (lambda () body ...) + (lambda () (restore-values! htable component (quote (key ...))))))])) ; Out guard + +;;; TODO test that restore works, at all +;;; Test that non-local exit and return works diff --git a/module/vcalendar/datetime.scm b/module/vcalendar/datetime.scm new file mode 100644 index 00000000..360b8348 --- /dev/null +++ b/module/vcalendar/datetime.scm @@ -0,0 +1,34 @@ +(define-module (vcalendar datetime) + #:use-module (vcalendar) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-19 util) + + #:export (parse-datetime + event-overlaps? + event-in?) + ) + +(define (parse-datetime dtime) + "Parse the given date[time] string into a date object." + ;; localize-date + (date->time-utc + (string->date + dtime + (case (string-length dtime) + ((8) "~Y~m~d") + ((15) "~Y~m~dT~H~M~S") + ((16) "~Y~m~dT~H~M~S~z"))))) + +(define (event-overlaps? event begin end) + "Returns if the event overlaps the timespan. +Event must have the DTSTART and DTEND attribute set." + (timespan-overlaps? (attr event 'DTSTART) + (attr event 'DTEND) + begin end)) + +(define (event-in? ev time) + "Does event overlap the date that contains time." + (let* ((date (time-utc->date time)) + (start (date->time-utc (drop-time date))) + (end (add-duration start (make-duration (* 60 60 24))))) + (event-overlaps? ev start end))) diff --git a/module/vcalendar/output.scm b/module/vcalendar/output.scm new file mode 100644 index 00000000..e4635beb --- /dev/null +++ b/module/vcalendar/output.scm @@ -0,0 +1,93 @@ +(define-module (vcalendar output) + #:use-module (vcalendar) + #:use-module (vcalendar control) + #:use-module (util) + #:use-module (srfi srfi-19 util) + #:use-module (srfi srfi-26) + #:export (print-vcomponent + serialize-vcomponent + color-if + STR-YELLOW STR-RESET)) + +(define STR-YELLOW "\x1b[0;33m") +(define STR-RESET "\x1b[m") + +(define-syntax-rule (color-if pred color body ...) + (let ((pred-value pred)) + (format #f "~a~a~a" + (if pred-value color "") + (begin body ...) + (if pred-value STR-RESET "")))) + +(define* (print-vcomponent comp #:optional (depth 0)) + (let ((kvs (map (lambda (key) (cons key (attr comp key))) + (attributes comp)))) + (format #t "~a <~a> :: ~:a~%" + (make-string depth #\:) + (type comp) comp) + (for-each-in kvs + (lambda (kv) + (let ((key (car kv)) + (value (cdr kv))) + (format #t "~a ~20@a: ~a~%" + (make-string depth #\:) + key value)))) + (for-each-in (children comp) + (cut print-vcomponent <> (1+ depth))))) + + + +;;; TODO +;; Error in CREATED /home/hugo/.calendars/b85ba2e9-18aa-4451-91bb-b52da930e977/a1a25238-d63d-46a1-87fd-d0c9334a7a30CalSync.ics: +;; Wrong type argument in position 1 (expecting string): ("20180118T124015Z" "VALARM") + +(define (string->ics-safe-string str) + "TODO wrap at 75(?) columns." + (define (escape char) + (string #\\ char)) + + (string-concatenate + (map (lambda (c) + (case c + ((#\newline) "\\n") + ((#\, #\; #\\) => escape) + (else => string))) + (string->list str)))) + +;;; TODO parameters ( ;KEY=val: ) +(define* (serialize-vcomponent comp #:optional (port (current-output-port))) + "Recursively write a component back to its ICS form. +Removes the X-HNH-FILENAME attribute, and sets PRODID to +\"HugoNikanor-calparse\" in the output." + (with-replaced-attrs + (comp (prodid "HugoNikanor-calparse")) + + (format port "BEGIN:~a~%" (type comp)) + (let ((kvs (map (lambda (key) (list key (attr comp key))) + (filter (negate (cut key=? <> 'X-HNH-FILENAME)) + (attributes comp))))) + (for-each-in + kvs (lambda (kv) + (let* (((key value) kv)) + (catch 'wrong-type-arg + (lambda () + (format port "~a:~a~%" key + (string->ics-safe-string + (case key + ((DTSTART DTEND) + (if (string? value) + value + (time->string value "~Y~m~dT~H~M~S"))) + + ((RRULE DURATION) "Just forget it") + + (else value))))) + + ;; Catch + (lambda (type proc fmt . args) + (apply format (current-error-port) "[ERR] ~a in ~a (~a) ~a:~%~?~%" + type key proc (attr comp 'X-HNH-FILENAME) + fmt args)))))) + + (for-each (cut serialize-vcomponent <> port) (children comp))) + (format port "END:~a~%" (type comp)))) diff --git a/module/vcalendar/primitive.scm b/module/vcalendar/primitive.scm new file mode 100644 index 00000000..b5eb9388 --- /dev/null +++ b/module/vcalendar/primitive.scm @@ -0,0 +1,23 @@ +;;; Primitive export of symbols linked from C binary. + +(define-module (vcalendar primitive) + #:export (%vcomponent-children + %vcomponent-push-child! + %vcomponent-filter-children! + + %vcomponent-parent + + %vcomponent-make + %vcomponent-type + + %vcomponent-set-attribute! + %vcomponent-get-attribute + + %vcomponent-attribute-list + + %vcomponent-shallow-copy)) + +(setenv "LD_LIBRARY_PATH" + (string-append (dirname (dirname (dirname (current-filename)))) + "/lib")) +(load-extension "libguile-calendar" "init_lib") diff --git a/module/vcalendar/recur.scm b/module/vcalendar/recur.scm new file mode 100644 index 00000000..3657cae6 --- /dev/null +++ b/module/vcalendar/recur.scm @@ -0,0 +1,12 @@ +(define-module (vcalendar recur) + #:use-module (vcalendar) + #:use-module (vcalendar recurrence generate) + #:re-export (generate-recurrence-set) + #:export (repeating?)) + +;; EXDATE is also a property linked to recurense rules +;; but that property alone don't create a recuring event. +(define (repeating? ev) + "Does this event repeat?" + (or (attr ev 'RRULE) + (attr ev 'RDATE))) diff --git a/module/vcalendar/recurrence/generate.scm b/module/vcalendar/recurrence/generate.scm new file mode 100644 index 00000000..fae404ec --- /dev/null +++ b/module/vcalendar/recurrence/generate.scm @@ -0,0 +1,126 @@ +(define-module (vcalendar recurrence generate) + ;; #:use-module (srfi srfi-1) + ;; #:use-module (srfi srfi-9 gnu) ; Records + #:use-module (srfi srfi-19) ; Datetime + #:use-module (srfi srfi-19 util) + + #:use-module (srfi srfi-26) ; Cut + #:use-module (srfi srfi-41) ; Streams + ;; #:use-module (ice-9 control) ; call-with-escape-continuation + #:use-module (ice-9 match) + #:use-module (vcalendar) + #:use-module (vcalendar datetime) + #:use-module (util) + + #:use-module (vcalendar recurrence internal) + #:use-module (vcalendar recurrence parse) + + #:export (generate-recurrence-set) + ) + +;;; TODO implement +;;; EXDATE and RDATE + +;;; EXDATE (3.8.5.1) +;;; comma sepparated list of dates or datetimes. +;;; Can have TZID parameter +;;; Specifies list of dates that the event should not happen on, even +;;; if the RRULE say so. +;;; Can have VALUE field specifiying "DATE-TIME" or "DATE". + +;;; RDATE (3.8.5.2) +;;; Comma sepparated list of dates the event should happen on. +;;; Can have TZID parameter. +;;; Can have VALUE parameter, specyfying "DATE-TIME", "DATE" or "PREIOD". +;;; PERIOD (see 3.3.9) + +(define (seconds-in freq) + (case freq + ((SECONDLY) 1) + ((MINUTELY) 60) + ((HOURLY) (* 60 60)) + ((DAILY) (* 60 60 24)) + ((WEEKLY) (* 60 60 24 7)))) + + +;; BYDAY and the like depend on the freq? +;; Line 7100 +;; Table @@ 2430 +;; +;; Event x Rule → Bool (continue?) +;; Alternative, monadic solution using . +;; @example +;; (optional->bool +;; (do (<$> (cut time<=? (attr last 'DTSTART)) (until r)) +;; (<$> (negate zero?) (count r)) +;; (just #t))) +;; @end example +(define-stream (recur-event-stream event rule-obj) + (stream-unfold + + ;; Event x Rule → Event + (match-lambda + ((last r) + (let ((e (copy-vcomponent last))) ; new event + (cond + + ((memv (freq r) '(SECONDLY MINUTELY HOURLY DAILY WEEKLY)) + (mod! (attr e 'DTSTART) ; MUTATE + (cut add-duration! <> + (make-duration + (* (interval r) ; INTERVAL + (seconds-in (freq r))))))) + + ((memv (freq r) '(MONTHLY YEARLY)) + #f ; Hur fasen beräkrnar man det här!!!! + )) + + ;; TODO this is just here for testing + (mod! (attr e 'NEW_ATTR) not) ; MUTATE + ;; This segfaults... + ;; (set! (attr e 'N) #t) ; MUTATE + ((@ (vcalendar output) print-vcomponent) e) + (set! (attr e 'D) #t) + + (set! (attr e 'DTEND) ; MUTATE + (add-duration + (attr e 'DTSTART) + (attr e 'DURATION))) + e))) + + ;; Event x Rule → Bool (continue?) + (match-lambda + ((e r) + + (or (and (not (until r)) (not (count r))) ; Never ending + (and=> (count r) (negate zero?)) ; COUNT + (and=> (until r) (cut time<=? (attr e 'DTSTART) <>))))) ; UNTIL + + ;; _ x Rule → (_, (next) Rule) + (match-lambda + ((e r) + (list + e (if (count r) + ;; Note that this doesn't modify, since r is immutable. + (mod! (count r) 1-) + r)))) + + ;; Seed + (list event rule-obj))) + + +(define (generate-recurrence-set event) + (unless (attr event "DURATION") + (set! (attr event "DURATION") ; MUTATE + (time-difference + (attr event "DTEND") + (attr event "DTSTART")))) + (recur-event-stream event (parse-recurrence-rule (attr event "RRULE")))) + + ;; How doee stream-unfold even work? + ;; What element is used as the next seed? +;;; stream-fold: +;; (stream-let recur ((base base)) +;; (if (pred? base) +;; (stream-cons (mapper base) (recur (generator base))) +;; stream-null)) diff --git a/module/vcalendar/recurrence/internal.scm b/module/vcalendar/recurrence/internal.scm new file mode 100644 index 00000000..b62d75c2 --- /dev/null +++ b/module/vcalendar/recurrence/internal.scm @@ -0,0 +1,28 @@ +(define-module (vcalendar recurrence internal) + #:use-module (util) + #:use-module (srfi srfi-88) + #:export (make-recur-rule + weekdays intervals)) + +;; (list +;; (build-recur-rules "FREQ=HOURLY") +;; (build-recur-rules "FREQ=HOURLY;COUNT=3") +;; (build-recur-rules "FREQ=ERR;COUNT=3") +;; (build-recur-rules "FREQ=HOURLY;COUNT=err") +;; (build-recur-rules "FREQ=HOURLY;COUNT=-1")) + +;; Immutable, since I easily want to be able to generate the recurence set for +;; the same event multiple times. +(define-quick-record recur-rule + (public: freq until count interval bysecond byminute byhour + byday bymonthday byyearday byweekno bymonth bysetpos + wkst)) + +(define (make-recur-rule interval wkst) + ((record-constructor '(interval wkst)) interval wkst)) + +(define weekdays + '(SU MO TU WE TH FR SA)) + +(define intervals + '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) diff --git a/module/vcalendar/recurrence/parse.scm b/module/vcalendar/recurrence/parse.scm new file mode 100644 index 00000000..abead3a9 --- /dev/null +++ b/module/vcalendar/recurrence/parse.scm @@ -0,0 +1,106 @@ +(define-module (vcalendar recurrence parse) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) ; Datetime + #:use-module (srfi srfi-19 util) + #:use-module (srfi srfi-26) + #:use-module ((vcalendar datetime) #:select (parse-datetime)) + #:duplicates (last) ; Replace @var{count} + #:use-module (vcalendar recurrence internal) + #:use-module (util) + #:use-module (exceptions) + #:use-module (ice-9 curried-definitions) + #:export (parse-recurrence-rule)) + +(define (parse-recurrence-rule str) + "Takes a RECUR value (string), and returuns a object" + (catch #t + (lambda () (%build-recur-rules str)) + (lambda (err cont obj key val . rest) + (let ((fmt (case err + ((unfulfilled-constraint) + "ERR ~a [~a] doesn't fulfill constraint of type [~a], ignoring~%") + ((invalid-value) + "ERR ~a [~a] for key [~a], ignoring.~%") + (else "~a ~a ~a")))) + (format #t fmt err val key)) + (cont obj)))) + +(eval-when (expand) + (define ((handle-case stx obj) key val proc) + (with-syntax ((skey (datum->syntax + stx (symbol-downcase (syntax->datum key))))) + #`((#,key) + (let ((v #,val)) + (cond ((not v) (throw-returnable 'invalid-value #,obj (quote #,key) v)) + ((#,proc #,val) (set! (skey #,obj) v)) + (else (set! (skey #,obj) + (throw-returnable 'unfulfilled-constraint + #,obj (quote #,key) v))))))))) + + +;; A special form of case only useful in parse-recurrence-rules above. +;; Each case is on the form (KEY val check-proc) where: +;; `key` is what should be matched against, and what is used for the setter +;; `val` is the value to bind to the loop object and +;; `check` is something the object must conform to +(define-syntax quick-case + (lambda (stx) + (syntax-case stx () + ((_ var-key obj (key val proc) ...) + #`(case var-key + #,@(map (handle-case stx #'obj) + #'(key ...) + #'(val ...) + #'(proc ...)) + (else obj)))))) + +(define-syntax all-in + (syntax-rules () + ((_ var rules ...) + (cut every (lambda (var) (and rules ...)) <>)))) + +(define (string->number-list val delim) + (map string->number (string-split val delim))) + +(define (string->symbols val delim) + (map string->symbol (string-split val delim))) + +(define (%build-recur-rules str) + (fold + (lambda (kv obj) + (let* (((key val) kv) + ;; Lazy fields for the poor man. + (symb (lambda () (string->symbol val))) + (date (lambda () (parse-datetime val))) + (num (lambda () (string->number val))) + (nums (lambda () (string->number-list val #\,)))) + (quick-case (string->symbol key) obj + (FREQ (symb) (cut memv <> intervals)) ; Requirek + (UNTIL (date) identity) + (COUNT (num) (cut <= 0 <>)) + (INTERVAL (num) (cut <= 0 <>)) + (BYSECOND (nums) (all-in n (<= 0 n 60))) + (BYMINUTE (nums) (all-in n (<= 0 n 59))) + (BYHOUR (nums) (all-in n (<= 0 n 23))) + + ;; TODO + ;; ∈ weekdays + ;; ::= [[±] ] ;; +3MO + ;; (, ...) + ;; (BYDAY (string-split val #\,)) + + (BYMONTHDAY (nums) (all-in n (<= -31 n 31) (!= n 0))) + (BYYEARDAY (nums) (all-in n (<= -366 n 366) (!= n 0))) + (BYWEEKNO (nums) (all-in n (<= -53 n 53) (!= n 0))) + (BYMONTH (nums) (all-in n (<= 1 n 12))) + (BYSETPOS (nums) (all-in n (<= -366 n 366) (!= n 0))) + + (WKST (symb) (cut memv <> weekdays)) + ))) + + ;; obj + (make-recur-rule 1 'MO) + + ;; ((key val) ...) + (map (cut string-split <> #\=) + (string-split str #\;)))) diff --git a/pair.h b/pair.h deleted file mode 100644 index e96cf180..00000000 --- a/pair.h +++ /dev/null @@ -1,19 +0,0 @@ -#ifndef PAIR_H -#define PAIR_H - -#define PAIR(T, V) TEMPL2(pair, T, V) - -#endif /* PAIR_H */ -#if defined(T) && defined(V) - -typedef struct { - T key; - V val; -} PAIR(T, V); - -INIT_F(PAIR(T, V)); -FREE_F(PAIR(T, V)); -FMT_F(PAIR(T, V)); -int DEEP_COPY(PAIR(T, V)) (PAIR(T, V)* dest, PAIR(T, V)* src); - -#endif diff --git a/pair.inc.h b/pair.inc.h deleted file mode 100644 index c42b2dfd..00000000 --- a/pair.inc.h +++ /dev/null @@ -1,34 +0,0 @@ -#if ! (defined(T) && defined(V)) -#error "Both T and V must be defiend here" -#else - -INIT_F(PAIR(T, V)) { - INIT(T, &self->key); - INIT(V, &self->val); - - return 0; -} - -FREE_F(PAIR(T, V)) { - FREE(T)(&self->key); - FREE(V)(&self->val); - - return 0; -} - -FMT_F(PAIR(T, V)) { - char lbuf[0x100]; - char rbuf[0x1000]; - FMT(T)(&self->key, lbuf); - FMT(V)(&self->val, rbuf); - - return sprintf(buf, "<%s, %s>", lbuf, rbuf); -} - -int DEEP_COPY(PAIR(T, V)) (PAIR(T, V)* dest, PAIR(T, V)* src) { - DEEP_COPY(T)(&dest->key, &src->key); - DEEP_COPY(V)(&dest->val, &src->val); - return 0; -} - -#endif /* T & V */ diff --git a/parse.c b/parse.c deleted file mode 100644 index 0e37350d..00000000 --- a/parse.c +++ /dev/null @@ -1,351 +0,0 @@ -#include "parse.h" - -#include -#include -#include - -#include "macro.h" -#include "vcal.h" - -#include "err.h" - -// #define TYPE vcomponent -// #include "linked_list.inc.h" -// #undef TYPE - -#define T strbuf -#define V strbuf -#include "pair.h" -#include "pair.inc.h" -#undef T -#undef V - -/* - * name *(";" param) ":" value CRLF - */ -int parse_file(char* filename, FILE* f, vcomponent* root) { - part_context p_ctx = p_key; - - SNEW(parse_ctx, ctx, f, filename); - PUSH(LLIST(vcomponent))(&ctx.comp_stack, root); - - /* - * Create a content_line which we use as storage while we are - * parsing. This object is constantly broken down and rebuilt. - * - * {cline,param}_key is also temporary register used during - * parsing. - */ - SNEW(content_line, cline); - SNEW(strbuf, cline_key); - SNEW(strbuf, param_key); - - char c; - while ( (c = fgetc(f)) != EOF) { - - /* We have a linebreak */ - if (c == '\r' || c == '\n') { - - if (fold(&ctx, c) > 0) { - /* Actuall end of line, handle value */ - TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); - handle_kv(&cline_key, &cline, &ctx); - p_ctx = p_key; - } /* Else continue on current line */ - - /* We have an escaped character */ - } else if (c == '\\') { - handle_escape (&ctx); - - /* Border between param {key, value} */ - } else if (p_ctx == p_param_name && c == '=') { - - /* Save the current parameter key */ - TRANSFER (¶m_key, &ctx.str); - p_ctx = p_param_value; - - /* - * One of four cases: - * 1) end of key , start of value - * 2) ,, key , ,, param - * 3) ,, param, ,, param - * 4) ,, param, ,, value - */ - } else if ((p_ctx == p_key || p_ctx == p_param_value) && (c == ':' || c == ';')) { - - /* We got a parameter value, push the current string to - * the current parameter set. */ - if (p_ctx == p_param_value) { - /* save current parameter value. */ - - NEW(strbuf, s); - TRANSFER(s, &ctx.str); - - NEW(param_set, ps); - PUSH(param_set)(ps, s); - - PUSH(TRIE(param_set))(CLINE_CUR_PARAMS(&cline), param_key.mem, ps); - strbuf_soft_reset (¶m_key); - } - - /* - * Top level key. - * Copy the key into the current cline, and create a - * content_set for the upcomming value and (possible) - * parameters. - */ - if (p_ctx == p_key) { - - TRANSFER(&cline_key, &ctx.str); - - NEW(content_set, p); - PUSH(LLIST(content_set))(&cline, p); - } - - if (c == ':') p_ctx = p_value; - else if (c == ';') p_ctx = p_param_name; - - /* - * Nothing interesting happened, append the read character to - * the current string. - */ - } else { - strbuf_append(&ctx.str, c); - - ++ctx.column; - ++ctx.pcolumn; - } - } - - if (! feof(f)) { - ERR("Error parsing"); - } - /* Check to see if empty line */ - else if (ctx.str.ptr != 0) { - /* - * The standard (3.4, l. 2675) says that each icalobject must - * end with CRLF. My files however does not, so we also parse - * the end here. - */ - - TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); - handle_kv(&cline_key, &cline, &ctx); - - } - - FREE(content_line)(&cline); - FREE(strbuf)(&cline_key); - FREE(strbuf)(¶m_key); - - assert(POP(LLIST(vcomponent))(&ctx.comp_stack) == root); - assert(EMPTY(LLIST(strbuf))(&ctx.key_stack)); - assert(EMPTY(LLIST(vcomponent))(&ctx.comp_stack)); - - FREE(parse_ctx)(&ctx); - - return 0; -} - -/* - * We have a complete key value pair. - */ -int handle_kv ( - strbuf* key, - content_line* cline, - parse_ctx* ctx - ) { - - /* - * The key being BEGIN means that we decend into a new component. - */ - if (strbuf_c(key, "BEGIN")) { - /* key \in { VCALENDAR, VEVENT, VALARM, VTODO, VTIMEZONE, ... } */ - - /* - * Take a copy of the name of the entered component, and store - * it on the stack of component names. - */ - NEW(strbuf, s); - DEEP_COPY(strbuf)(s, CLINE_CUR_VAL(cline)); - PUSH(LLIST(strbuf))(&ctx->key_stack, s); - - /* Clear the value list in the parse content_line */ - RESET(LLIST(content_set))(cline); - - /* - * Create the new curent component, link it with the current - * component in a parent/child relationship. - * Finally push the new component on to the top of the - * component stack. - */ - NEW(vcomponent, e, - s->mem, - ctx->filename); - vcomponent* parent = PEEK(LLIST(vcomponent))(&ctx->comp_stack); - PUSH(vcomponent)(parent, e); - - PUSH(LLIST(vcomponent))(&ctx->comp_stack, e); - - /* - * The end of a component, go back along the stack to the previous - * component. - */ - } else if (strbuf_c(key, "END")) { - strbuf* expected_key = POP(LLIST(strbuf))(&ctx->key_stack); - - if (strbuf_cmp(expected_key, CLINE_CUR_VAL(cline)) != 0) { - - ERR_P(ctx, "Expected END:%s, got END:%s.\n%s line", - expected_key->mem, - CLINE_CUR_VAL(cline)->mem, - vcomponent_get_val( - PEEK(LLIST(vcomponent))(&ctx->comp_stack), - "X-HNH-FILENAME")); - PUSH(LLIST(strbuf))(&ctx->key_stack, expected_key); - - return -1; - - } else { - FFREE(strbuf, expected_key); - POP(LLIST(vcomponent))(&ctx->comp_stack); - } - - /* - * A regular key, value pair. Push it into to the current - * component. - */ - } else { - - /* - * cline is the value store used during parsing, meaning that - * its values WILL mutate at a later point. Therefore we take - * a copy of it here. - */ - NEW(content_line, c); - DEEP_COPY(content_line)(c, cline); - - /* - * The PUSH(TRIE(T)) method handles collisions by calling - * RESOLVE(T). content_line resolves by merging the new value - * into the old value, and freeing the new value's container. - * - * This means that |c| declared above might be destroyed - * here. - */ - PUSH(TRIE(content_line))( - &PEEK(LLIST(vcomponent))(&ctx->comp_stack)->clines, - key->mem, c); - - RESET(LLIST(content_set))(cline); - } - - return 0; -} - -int fold(parse_ctx* ctx, char c) { - int retval; - - char buf[2] = { - (c == '\n' ? '\n' : (char) fgetc(ctx->f)), - (char) fgetc(ctx->f) - }; - - ctx->pcolumn = 1; - - if (buf[0] != '\n') { - ERR_P(ctx, "expected new_line after CR"); - retval = -1; - - } else if (buf[1] == ' ' || buf[1] == '\t') { - retval = 0; - ctx->pcolumn++; - - } else if (ungetc(buf[1], ctx->f) != buf[1]) { - ERR_P(ctx, "Failed to put character back on FILE"); - retval = -2; - - } else { - retval = 1; - ++ctx->line; - ctx->column = 0; - } - - ++ctx->pline; - - return retval; -} - - -INIT_F(parse_ctx, FILE* f, char* filename) { - INIT(LLIST(strbuf), &self->key_stack); - INIT(LLIST(vcomponent), &self->comp_stack); - self->filename = (char*) calloc(sizeof(*filename), strlen(filename) + 1); - strcpy(self->filename, filename); - self->f = f; - - self->line = 0; - self->column = 0; - - self->pline = 1; - self->pcolumn = 1; - - INIT(strbuf, &self->str); - - return 0; -} - -FREE_F(parse_ctx) { - - FREE(LLIST(strbuf))(&self->key_stack); - FREE(LLIST(vcomponent))(&self->comp_stack); - free(self->filename); - - self->line = 0; - self->column = 0; - FREE(strbuf)(&self->str); - - return 0; -} - -int handle_escape (parse_ctx* ctx) { - char esc = fgetc(ctx->f); - char target; - - /* - * Escape character '\' and escaped token sepparated by a newline - * (since the standard for some reason allows that (!!!)) - * We are at least guaranteed that it's a folded line, so just - * unfold it and continue trying to find a token to escape. - */ - if (esc == '\r' || esc == '\n') { - int ret; - if ( (ret = fold(ctx, esc)) != 0) { - if (ret == 1) ERR_P(ctx, "ESC before not folded line"); - else ERR_P(ctx, "other error: val = %i", ret); - exit (2); - } else { - esc = fgetc(ctx->f); - } - } - - /* Escaped new_line */ - if (esc == 'n' || esc == 'N') { - target = '\n'; - - /* "Standard" escaped character */ - } else if (esc == ';' || esc == ',' || esc == '\\') { - target = esc; - - /* Invalid escaped character */ - } else { - ERR_P(ctx, "Non escapable character '%c' (%i)", esc, esc); - } - - /* save escapade character as a normal character */ - strbuf_append(&ctx->str, target); - - ++ctx->column; - ++ctx->pcolumn; - - return 0; -} diff --git a/parse.h b/parse.h deleted file mode 100644 index 53263b4c..00000000 --- a/parse.h +++ /dev/null @@ -1,122 +0,0 @@ -#ifndef PARSE_H -#define PARSE_H - -#include -#include - -#include "strbuf.h" -#include "vcal.h" - -// #define TYPE vcomponent -// #include "linked_list.h" -// #undef TYPE - -/* - * The standard says that no line should be longer than 75 octets. - * This sets the default amount of memory to allocate for each string, - * but strings are reallocated when needed. - */ -#define SEGSIZE 75 - -/* - * Transfers a strbuf from src to target. - * Does this first copying the contents, followed by capping the - * target and reseting the src. - */ -#define TRANSFER(target, src) do { \ - DEEP_COPY(strbuf)((target), (src)); \ - strbuf_cap(target); \ - strbuf_soft_reset(src); \ -} while (0) - -/* - * Current context for the character consumer (parse_file). - */ -typedef enum { - p_key, p_value, p_param_name, p_param_value, p_escape -} part_context; - -/* - * Struct holding most state information needed while parsing. - * Kept together for simplicity. - */ -typedef struct { - /* Which file we are parsing, copied to all components to allow - * writebacks later */ - char* filename; - - FILE* f; - - /* - * context stacks used since ICS files form a tree. key_stack is - * only for sequrity purposes. - */ - LLIST(strbuf) key_stack; - LLIST(vcomponent) comp_stack; - - /* Number for unfolded lines - * TODO remove this - * */ - int line; - int column; - - /* Actuall lines and columns from file */ - int pline; - int pcolumn; - - /* - * String which we write everything read into. - * Later copied to appropiate places. - */ - strbuf str; -} parse_ctx; - -INIT_F(parse_ctx, FILE* f, char* filename); -FREE_F(parse_ctx); - - -/* - * Character consumer. Reads characters from stdin until end of file. - * Whenever it finds a token with a special value (such as ':', ';', - * ...) it saves it away. - * Once It has parsed a full line it calls handel_kv. Which build my - * actuall datastructure. - */ -int parse_file(char* filename, FILE* f, vcomponent* cal); - -/* - * Called whenever parse_file finishes a line. Copies the contents of - * ctx and the current content_line into the object stack, stored in - * ctx. - */ -int handle_kv( - strbuf* key, - content_line* cline, - parse_ctx* ctx - ); - -/* - * Input - * f: file to get characters from - * ctx: current parse context - * c: last read character - * output: - * 0: line folded - * 1: line ended - * - * A carrige return means that the current line is at an - * end. The following character should always be \n. - * However, if the first character on the next line is a - * whitespace then the two lines should be concatenated. - * - * NOTE - * The above is true according to the standard. But I have - * found files with only NL. The code below ends line on the - * first of NL or CR, and then ensures that the program thinks - * it got the expected CRNL. - */ -int fold(parse_ctx* ctx, char c); - -int handle_escape (parse_ctx* ctx); - -#endif /* PARSE_H */ diff --git a/src/calendar.c b/src/calendar.c new file mode 100644 index 00000000..edc1151e --- /dev/null +++ b/src/calendar.c @@ -0,0 +1,140 @@ +#include "calendar.h" + +#include +#include +#include +#include +#include + +#include "parse.h" +#include "err.h" + +int read_vcalendar(vcomponent* cal, char* path) { + + struct stat statbuf; + if (stat (path, &statbuf) != 0) { + fprintf(stderr, + "Error stating file or directory, errno = %i\npath = [%s]\n", + errno, path); + } + + int type = statbuf.st_mode & 0777000; + int chmod = statbuf.st_mode & 0777; + INFO_F("file has mode 0%o, with chmod = 0%o", type, chmod); + + switch (type) { + case S_IFREG: handle_file(cal, path); break; + case S_IFDIR: handle_dir (cal, path); break; + case S_IFLNK: + ERR("Found symlink, can't be bothered to check it further."); + break; + + default: ; + } + + return 0; +} + +int handle_file(vcomponent* cal, char* path) { + INFO("Parsing a single file"); + + vcomponent_push_val(cal, "NAME", path); + vcomponent_push_val(cal, "TYPE", "file"); + char* resolved_path = realpath(path, NULL); + open_ics (resolved_path, cal); + free (resolved_path); + + return 0; +} + + +int handle_dir(vcomponent* cal, char* path) { + INFO("Parsing a directory"); + DIR* dir = opendir(path); + + /* Buffer for holding search path and filename */ + char buf[PATH_MAX] = { [0 ... PATH_MAX - 1] = '\0' }; + strcpy(buf, path); + int path_len = strlen(path) + 1; + + /* Slash to guarantee we have at least one */ + buf[path_len - 1] = '/'; + + + vcomponent_push_val(cal, "NAME", path); + vcomponent_push_val(cal, "TYPE", "vdir"); + + struct dirent* d; + while ((d = readdir(dir)) != NULL) { + /* Check that it's a regular file */ + if (d->d_type != DT_REG) continue; + + /* Append filename with currentt searchpath */ + strcat(buf, d->d_name); + char* resolved_path = realpath(buf, NULL); + /* Remove file part from combined path */ + buf[path_len] = '\0'; + + FILE* f; + char info_buf[0x100]; + if (strcmp (d->d_name, "color") == 0) { + f = fopen(resolved_path, "r"); + fgets(info_buf, 0x100, f); + fclose(f); + vcomponent_push_val(cal, "COLOR", info_buf); + } else if (strcmp (d->d_name, "displayname") == 0) { + f = fopen(resolved_path, "r"); + fgets(info_buf, 0x100, f); + fclose(f); + // TODO make sure that this replaces + vcomponent_push_val(cal, "NAME", info_buf); + } else { + open_ics (resolved_path, cal); + } + + free (resolved_path); + } + + closedir(dir); + return 0; +} + +int get_extension(const char* filename, char* ext, ssize_t max_len) { + int ext_idx = -1; + ext[0] = '\0'; + for (int i = 0; filename[i] != '\0'; i++) { + if (filename[i] == '.') ext_idx = i + 1; + if (filename[i] == '/') ext_idx = -1; + } + + if (ext_idx == -1) return 0; + + int ext_len = 0; + for (int i = 0; i < max_len; i++, ext_len++) { + char c = filename[i + ext_idx]; + if (c == '\0') break; + ext[i] = c; + } + ext[ext_len] = '\0'; + return ext_len; +} + +int check_ext (const char* path, const char* ext) { + char buf[10]; + int has_ext = get_extension(path, buf, 9); + + return has_ext && strcmp(buf, ext) == 0; +} + +int open_ics (char* resolved_path, vcomponent* cal) { + if (! check_ext(resolved_path, "ics") ) return 2; + + FILE* f = fopen(resolved_path, "r"); + + if (f == NULL) return 1; + + parse_file(resolved_path, f, cal); + fclose(f); + + return 0; +} diff --git a/src/calendar.h b/src/calendar.h new file mode 100644 index 00000000..20b78a9f --- /dev/null +++ b/src/calendar.h @@ -0,0 +1,41 @@ +#ifndef CALENDAR_H +#define CALENDAR_H + +#include "vcal.h" + +/* + * Reads all ics flies in path into the given vcomponent. The + * component is assumed to be a abstract ROOT element, whose first + * component will most likely become a VCALENDAR. + * + * path should either be a single .ics file (vcalendar), or a + * directory directly containing .ics files (vdir). + */ +int read_vcalendar(vcomponent* cal, char* path); + +/* + * Gets extension from filename. Writes output to ext. + * Assumes that the extension is the text between the last dot and + * the end of the string, and that no slashes can occur between the + * dot and the end. + * + * Returns the length of the extension, 0 if no extension. + */ +int get_extension(const char* filename, char* ext, ssize_t max_len); + +/* Returns 1 if path has extension ext, 0 otherwise */ +int check_ext (const char* path, const char* ext); + +/* Handle a lone ics file */ +int handle_file(vcomponent* cal, char* path); + +/* Handle a directory of ics files */ +int handle_dir(vcomponent* cal, char* path); + +/* + * Helper for opening a single ICS file. Handles file internally, and + * writes output to cal. + */ +int open_ics (char* resolved_path, vcomponent* cal); + +#endif /* CALENDAR_H */ diff --git a/src/err.h b/src/err.h new file mode 100644 index 00000000..d9d19ec7 --- /dev/null +++ b/src/err.h @@ -0,0 +1,42 @@ +#ifndef ERR_H +#define ERR_H + +#include + +#include "macro.h" + +#define _RESET "\x1b[m" +#define _BLACK "\x1B[0;30m" +#define _RED "\x1B[0;31m" +#define _GREEN "\x1B[0;32m" +#define _YELLOW "\x1B[0;33m" +#define _BLUE "\x1B[0;34m" +#define _PURPLE "\x1B[0;35m" +#define _CYAN "\x1B[0;36m" +#define _WHITE "\x1B[0;37m" + +#define ERR(msg) fprintf(stderr, _RED "ERR" _RESET " (%s:%i) %s\n", __FILE__, __LINE__, #msg) +#define ERR_F(fmt, ...) fprintf(stderr, _RED "ERR" _RESET " (%s:%i) " fmt "\n", \ + __FILE__, __LINE__, ##__VA_ARGS__) + +/* Parse error */ +#define ERR_P(ctx, fmt, ...) fprintf(stderr, _RED "PARSE" _RESET " (%s:%i) %i:%i " fmt "\n", \ + __FILE__, __LINE__, (ctx)->pline, (ctx)->pcolumn, ##__VA_ARGS__) + +#define INFO(msg) fprintf(stderr, _BLUE "INFO" _RESET " (%s:%i) %s\n", __FILE__, __LINE__, #msg) +#define INFO_F(fmt, ...) fprintf(stderr, _BLUE "INFO" _RESET " (%s:%i) " fmt "\n", \ + __FILE__, __LINE__, ##__VA_ARGS__) + +#define LINE(len) do { \ + printf(_GREEN); \ + FOR(int, i, len) printf("_"); \ + printf("\n"); \ +} while (0) + +#define PRINT(T, v) do { \ + char buf[0x1000]; \ + FMT(T)(v, buf); \ + INFO_F("%s", buf); \ +} while (0) + +#endif /* ERR_H */ diff --git a/src/graphs.c b/src/graphs.c new file mode 100644 index 00000000..51a26117 --- /dev/null +++ b/src/graphs.c @@ -0,0 +1,144 @@ +#include "graphs.h" + +#include +#include +#include +#include "err.h" + +// #define TYPE strbuf +// #include "linked_list.h" +// #include "linked_list.inc.h" +// #undef TYPE + +int create_graph_trie (vcomponent* ev, char* filename) { + FILE* f = fopen(filename, "w"); + + fputs("digraph {\n rankdir=LR;", f); + trie_to_dot(&ev->clines, f); + fputs("}", f); + + fclose(f); + + INFO_F("Wrote '%s' to '%s'", vcomponent_get_val(ev, "X-HNH-FILENAME"), filename); + + return 0; +} + +int helper_vcomponent (vcomponent* root, FILE* f) { + fprintf(f, "subgraph \"cluster_root\" { label=File; \"%p\" [label=%s] }\n", root, root->type); + + TRIE(content_line)* trie = &root->clines; + TRIE_NODE(content_line)* n = trie->root->child; + + if (! EMPTY(TRIE(content_line))(trie)) { + fprintf(f, "subgraph \"cluster_%p\" {\n", root); + fprintf(f, "\"%p\" [label=trie fontcolor=gray, color=gray];", trie); + fprintf(f, "\"%p\" -> \"%p\" [color=red]\n", root, trie); + while (n != NULL) { + fprintf(f, "\"%p\" -> \"%p\" [color=gray]\n", + (void*) trie, + (void*) n); + fprintf(f, "subgraph \"cluster_%c_%p\" {\ncolor=red; \n", + n->c, root); + trie_to_dot_helper( n, f ); + + + fputs("}", f); + n = n->next; + } + fputs("}", f); + } + + FOR(LLIST, vcomponent, child, &root->components) { + fprintf(f, "\"%p\" -> \"%p\"\n", root, child); + helper_vcomponent(child, f); + } + return 0; +} + +int create_graph_vcomponent (vcomponent* root, char* outfile) { + FILE* f = fopen(outfile, "w"); + if (f == NULL) { + ERR_F("Error opening file %s, errno = %i", outfile, errno); + return 1; + } + vcomponent* c = root; + fputs("digraph {", f); + helper_vcomponent(c, f); + fputs("}", f); + fclose(f); + return 0; +} + +#define T content_line + +int trie_to_dot ( TRIE(T)* trie, FILE* f ) { + TRIE_NODE(T)* n = trie->root->child; + fprintf(f, "\"%p\" [label=root fontcolor=gray, color=gray];", trie); + while (n != NULL) { + fprintf(f, "\"%p\" -> \"%p\" [color=gray]\n", + (void*) trie, + (void*) n); + fprintf(f, "subgraph \"cluster_%c\" {\n", + n->c); + trie_to_dot_helper( n, f ); + fputs("}", f); + n = n->next; + } + return 0; +} + +int trie_to_dot_helper ( TRIE_NODE(T)* root, FILE* f ) { + if (L(root) == NULL) { + fprintf(f, "\"%p\"[label = \"%c\" style=filled fillcolor=white];\n", + (void*) root, root->c); + } else { + fprintf(f, "\"%p\"[label = \"%c [%i]\" style=filled fillcolor=green];\n", + (void*) root, root->c, + SIZE(LLIST(content_set))(L(root)) + ); + } + TRIE_NODE(T)* child = root->child; + + // ---------------------------------------- +#if 1 /* Toggle values */ + if (L(root) != NULL) { + + FOR(LLIST, content_set, v, L(root)) { + char buf[0x100]; + FMT(strbuf)(&v->key, buf); + fprintf(f, "\"%p\" [label=\"%s\" shape=rectangle color=darkgreen];\n", + v, buf); + /* Edge between TRIE char node and data node */ + fprintf(f, "\"%p\" -> \"%p\";\n", root, v); + + /* Parameters */ + LLIST(strbuf)* keys = KEYS(TRIE(param_set))(&v->val); + FOR(LLIST, strbuf, key, keys) { + param_set* p = GET(TRIE(param_set))(&v->val, key->mem); + + fprintf(f, "\"%p\" [label=\"%s\" color=blue];\n", + key, key->mem); + /* Edge between data node and param key node */ + fprintf(f, "\"%p\" -> \"%p\";", v, key); + + FOR(LLIST, strbuf, str, p) { + fprintf(f, "\"%p\" [label=\"%s\" color=orange];", + str, str->mem); + /* Edge between param key node and param value node */ + fprintf(f, "\"%p\" -> \"%p\";", key, str); + } + } + } + } +#endif + // ---------------------------------------- + + while (child != NULL) { + fprintf(f, "\"%p\" -> \"%p\";\n", + (void*) root, (void*) child); + trie_to_dot_helper(child, f); + child = child->next; + } + return 0; +} diff --git a/src/graphs.h b/src/graphs.h new file mode 100644 index 00000000..fe521003 --- /dev/null +++ b/src/graphs.h @@ -0,0 +1,15 @@ +#ifndef GRAPHS_H +#define GRAPHS_H + +#include "vcal.h" + +int create_graph_trie (vcomponent* ev, char* filename); + +int create_graph_vcomponent (vcomponent* root, char* outfile); + +int helper_vcomponent (vcomponent* root, FILE* f); + +int trie_to_dot ( TRIE(content_line)*, FILE* ); +int trie_to_dot_helper ( TRIE_NODE(content_line)*, FILE* ); + +#endif /* GRAPHS_H */ diff --git a/src/guile_interface.h b/src/guile_interface.h new file mode 100644 index 00000000..76ec24d3 --- /dev/null +++ b/src/guile_interface.h @@ -0,0 +1,28 @@ +#ifndef GUILE_INTERFACE_H +#define GUILE_INTERFACE_H + +#include +#include "vcal.h" + +/* + * At a number of places scm_gc_{un,}protect_object is called. + * This is needed since most of my structures are allocated with the + * regular malloc, instead of the scm_gc_malloc variants. + * This leads to the garbage collector not realizing that I still have + * the components, and deletes them. + * + * The protection markers stop the GC from doing its thing. + */ + +void init_lib (void); +void init_vcomponent_type (void); + +SCM make_vcomponent (SCM); +SCM vcomponent_get_attribute (SCM, SCM); +SCM vcomponent_child_count (SCM); +SCM vcomponent_children (SCM); +SCM vcomponent_typeof (SCM); + +SCM scm_from_vcomponent (vcomponent*); + +#endif /* GUILE_INTERFACE_H */ diff --git a/src/guile_interface.scm.c b/src/guile_interface.scm.c new file mode 100644 index 00000000..3d0bff1e --- /dev/null +++ b/src/guile_interface.scm.c @@ -0,0 +1,220 @@ +#include "guile_interface.h" + +#include "calendar.h" +#include "guile_type_helpers.h" + +static SCM vcomponent_type; + +void init_vcomponent_type (void) { + SCM name = scm_from_utf8_symbol("vcomponent"); + SCM slots = scm_list_1(scm_from_utf8_symbol("data")); + + vcomponent_type = scm_make_foreign_object_type(name, slots, NULL); +} + +SCM_DEFINE (make_vcomponent, "%vcomponent-make", 1, 0, 0, + (SCM path), + "Loads a vdir iCalendar from the given path.") +{ + vcomponent* cal = + (vcomponent*) scm_gc_malloc ( + sizeof(*cal), "vcomponent"); + INIT(vcomponent, cal, "ROOT"); + + char* p = scm_to_utf8_stringn(path, NULL); + read_vcalendar(cal, p); + free(p); + + return scm_from_vcomponent (cal); +} + +/* + * Returns a line from a component. + */ +SCM_DEFINE (vcomponent_get_attribute, "%vcomponent-get-attribute", 2, 0, 0, + (SCM calendar, SCM attr), + "Retuns the given attribute from the vevent object at index in calendar.") +{ + scm_assert_foreign_object_type (vcomponent_type, calendar); + vcomponent* cal = scm_foreign_object_ref (calendar, 0); + + char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL); + content_line* c = get_property (cal, key); + free(key); + + if (c == NULL) return SCM_BOOL_F; + + SCM llist = SCM_EOL; + FOR (LLIST, content_set, v, c) { + llist = scm_cons(scm_from_strbuf(&v->key), llist); + } + + /* returns the car of list if list is one long. */ + if (scm_to_int(scm_length(llist)) == 1) { + return SCM_CAR(llist); + } else { + return llist; + } +} + +SCM_DEFINE (vcomponent_set_attr_x, "%vcomponent-set-attribute!", 3, 0, 0, + (SCM component, SCM attr, SCM new_value), + "") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* com = scm_foreign_object_ref (component, 0); + + char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL); + content_line* c = get_property (com, key); + + /* Create the position in the TRIE if it doesn't already exist */ + if (c == NULL) { + /* Insert empty key since this allows me to use the helper + * function */ + vcomponent_push_val(com, key, ""); + c = get_property (com, key); + } else { + /* If the object already exists it should be protected, + * so unprotect it + */ + scm_gc_unprotect_object(c->cur->value->key.scm); + } + + free(key); + + c->cur->value->key.scm = new_value; + scm_gc_protect_object(c->cur->value->key.scm); + + return SCM_UNSPECIFIED; +} + +SCM_DEFINE (vcomponent_child_count, "%vcomponent-child-count", 1, 0, 0, + (SCM component), + "Returns number of child components.") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* c = scm_foreign_object_ref (component, 0); + return scm_from_size_t (SIZE(LLIST(vcomponent))(&c->components)); +} + +SCM_DEFINE(vcomponent_children, "%vcomponent-children", 1, 0, 0, + (SCM component), + "") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* cal = scm_foreign_object_ref (component, 0); + + SCM llist = SCM_EOL; + FOR (LLIST, vcomponent, v, &cal->components) { + llist = scm_cons(scm_from_vcomponent(v), llist); + } + return llist; +} + +SCM_DEFINE(vcomponent_filter_children_x, "%vcomponent-filter-children!", + 2, 0, 0, + (SCM pred, SCM component), + "Remove all children from component who DOESN'T satisfy `pred`") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* cal = scm_foreign_object_ref (component, 0); + + for (LINK(vcomponent)* l = FIRST(&cal->components); + l->after != NULL; + l = l->after) + { + if (scm_is_false(scm_call_1 (pred, scm_from_vcomponent(l->value)))) { + FFREE(vcomponent, l->value); + UNLINK(LINK(vcomponent))(l); + } + } + + return SCM_UNSPECIFIED; +} + +SCM_DEFINE(vcomponent_push_child_x, "%vcomponent-push-child!", 2, 0, 0, + (SCM component, SCM child), + "") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + scm_assert_foreign_object_type (vcomponent_type, child); + vcomponent* comp = scm_foreign_object_ref (component, 0); + vcomponent* chil = scm_foreign_object_ref (child, 0); + + PUSH(vcomponent)(comp, chil); + + return SCM_UNSPECIFIED; +} + +SCM_DEFINE (vcomponent_parent, "%vcomponent-parent", 1, 0, 0, + (SCM component), + "") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* comp = scm_foreign_object_ref (component, 0); + + vcomponent* parent = comp->parent; + if (strcmp(parent->type, "ROOT") == 0) { + return SCM_BOOL_F; + } else { + return scm_from_vcomponent(parent); + } +} + +SCM_DEFINE(vcomponent_typeof, "%vcomponent-type", 1, 0, 0, + (SCM component), + "Returns type of vcomponent") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* comp = scm_foreign_object_ref (component, 0); + return scm_from_utf8_symbol(comp->type); +} + +SCM scm_from_vcomponent(vcomponent* v) { + if (v->scm == NULL) { + v->scm = scm_make_foreign_object_1 (vcomponent_type, v); + scm_gc_protect_object(v->scm); + } + return v->scm; +} + +SCM_DEFINE(vcomponent_attr_list, "%vcomponent-attribute-list", 1, 0, 0, + (SCM component), + "Returns list of all keys in component.") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* comp = scm_foreign_object_ref (component, 0); + LLIST(strbuf)* keys = KEYS(TRIE(content_line))(&comp->clines); + + SCM llist = SCM_EOL; + FOR (LLIST, strbuf, s, keys) { + llist = scm_cons(scm_from_strbuf(s), llist); + } + + FFREE(LLIST(strbuf), keys); + + return llist; +} + +SCM_DEFINE(vcomponent_shallow_copy, "%vcomponent-shallow-copy", 1, 0, 0, + (SCM component), + "Creates a shallow copy of the given component.") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* src = scm_foreign_object_ref (component, 0); + + vcomponent* dest = + (vcomponent*) scm_gc_malloc ( + sizeof(*dest), "vcomponent"); + INIT(vcomponent, dest, src->type, NULL); + vcomponent_copy (dest, src); + return scm_from_vcomponent (dest); +} + +void init_lib (void) { + init_vcomponent_type(); + +#ifndef SCM_MAGIC_SNARFER +#include "guile_interface.x" +#endif +} diff --git a/src/guile_type_helpers.c b/src/guile_type_helpers.c new file mode 100644 index 00000000..e231f2b1 --- /dev/null +++ b/src/guile_type_helpers.c @@ -0,0 +1,13 @@ +#include "guile_type_helpers.h" +#include "guile_interface.h" + +#include "macro.h" + +SCM scm_from_strbuf(strbuf* s) { + if (s->scm == NULL) { + s->scm = scm_from_utf8_stringn (s->mem, s->len); + scm_gc_protect_object(s->scm); + } + + return s->scm; +} diff --git a/src/guile_type_helpers.h b/src/guile_type_helpers.h new file mode 100644 index 00000000..2ff177e1 --- /dev/null +++ b/src/guile_type_helpers.h @@ -0,0 +1,13 @@ +#ifndef GUILE_TYPE_HELPERS_H +#define GUILE_TYPE_HELPERS_H + +#include + +#include "calendar.h" +#include "strbuf.h" + +#define SCM_IS_LIST(x) scm_is_true(scm_list_p(x)) + +SCM scm_from_strbuf(strbuf* s); + +#endif /* GUILE_TYPE_HELPERS_H */ diff --git a/src/linked_list.h b/src/linked_list.h new file mode 100644 index 00000000..ec1e17e0 --- /dev/null +++ b/src/linked_list.h @@ -0,0 +1,92 @@ +#ifndef LINKED_LIST_H +#define LINKED_LIST_H + +#include "macro.h" + +#define LLIST(T) TEMPL(llist, T) +#define LINK(T) TEMPL(llist_link, T) + +#define UNLINK(T) TEMPL(unlink, T) + +#endif /* LINKED_LIST_H */ +#ifdef TYPE + +typedef struct LINK(TYPE) { + struct LINK(TYPE)* before; + struct LINK(TYPE)* after; + TYPE* value; +} LINK(TYPE); + +#define L(link) (link)->value + +typedef struct { + LINK(TYPE)* head; + LINK(TYPE)* tail; + LINK(TYPE)* cur; + int length; +} LLIST(TYPE); + +#define FIRST(lst) (lst)->head->after +#define FIRST_V(lst) (lst)->head->after->value +#define LAST(lst) (lst)->tail->before +#define LAST_V(lst) (lst)->tail->before->value + +INIT_F ( LLIST(TYPE) ); + +/* + * NOTE freeing a linked list alsa FFREE's all its contents. + * TODO some form of shared pointer to ensure nothing is free'd twice + * would be a good idea. + */ +FREE_F ( LLIST(TYPE) ); + +INIT_F ( LINK(TYPE) ); +INIT_F ( LINK(TYPE), TYPE* val ); +FREE_F ( LINK(TYPE) ); + +int UNLINK(LINK(TYPE)) ( LINK(TYPE)* ); + +int PUSH(LLIST(TYPE)) ( LLIST(TYPE)*, TYPE* ); +TYPE* PEEK(LLIST(TYPE)) ( LLIST(TYPE)* ); +TYPE* POP(LLIST(TYPE)) ( LLIST(TYPE)* ); + +int DEEP_COPY(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* src ); + +int APPEND(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* new_ ); + +int SIZE(LLIST(TYPE)) ( LLIST(TYPE)* llist ); +int EMPTY(LLIST(TYPE)) ( LLIST(TYPE)* llist ); + +/* + * Resets a linked list by removing all it's objects. + * FREE's all elements stored in the list. + */ +int RESET(LLIST(TYPE)) ( LLIST(TYPE)* llist ); + +/* + * Takes to lists, and merges them into a single one. Destroys new_ in + * the process. + */ +LLIST(TYPE)* RESOLVE(LLIST(TYPE)) (LLIST(TYPE)* dest, LLIST(TYPE)* new_); + +FMT_F(LLIST(TYPE)); + +/* Iterator */ + +#define __PRE_LLIST(T, l, set) \ + T* l; LINK(T)* __INTER(l); + +#define PRE_FOR_LLIST(T) __PRE_LLIST + +// #define __BEG_LLIST(v, set) v = (set)->head +#define __BEG_LLIST(T, l, set) __INTER(l) = FIRST(set), l = L(__INTER(l)) +#define BEG_LLIST(T) __BEG_LLIST + +#define __END_LLIST(T, l, set) __INTER(l) != (set)->tail +#define END_LLIST(T) __END_LLIST + +#define __NXT_LLIST(T, l, set) __INTER(l) = __INTER(l)->after, l = L(__INTER(l)) +// #define __NXT_LLIST(T, l, set) l = L(__INTER(l) = __INTER(l)->after) +#define NXT_LLIST(T) __NXT_LLIST + +#endif /* TYPE */ diff --git a/src/linked_list.inc.h b/src/linked_list.inc.h new file mode 100644 index 00000000..81974a9c --- /dev/null +++ b/src/linked_list.inc.h @@ -0,0 +1,176 @@ +#ifndef TYPE +#error "Set TYPE before including self file" +#else + +INIT_F ( LLIST(TYPE) ) { + self->length = 0; + NEW(LINK(TYPE), head); + NEW(LINK(TYPE), tail); + self->head = head; + self->tail = tail; + head->after = tail; + tail->before = head; + self->cur = head; + return 0; +} + +FREE_F (LINK(TYPE)) { + UNLINK(LINK(TYPE))(self); + + if (self->value != NULL) FFREE(TYPE, self->value); + return 0; +} + +FREE_F( LLIST(TYPE) ) { + LINK(TYPE) *n, *next; + n = self->head; + while ( n != NULL ) { + next = n->after; + FFREE(LINK(TYPE), n); + n = next; + } + + self->length = -1; + + return 0; +} + +INIT_F ( LINK(TYPE) ) { + self->before = NULL; + self->after = NULL; + self->value = NULL; + return 0; +} + +INIT_F ( LINK(TYPE), TYPE* val ) { + self->before = NULL; + self->after = NULL; + self->value = val; + return 0; +} + +int UNLINK(LINK(TYPE)) ( LINK(TYPE)* self ) { + if (self->before != NULL) self->before->after = self->after; + if (self->after != NULL) self->after->before = self->before; + return 0; +} + + +int PUSH(LLIST(TYPE)) ( LLIST(TYPE)* lst, TYPE* val) { + NEW(LINK(TYPE), link, val); + + link->after = FIRST(lst); + FIRST(lst) = link; + + link->after->before = link; + link->before = lst->head; + + ++lst->length; + + // TODO do I want to change that? + lst->cur = link; + + return 0; +} + +TYPE* PEEK(LLIST(TYPE)) ( LLIST(TYPE)* lst ) { + if (EMPTY(LLIST(TYPE))(lst)) return NULL; + + return FIRST(lst)->value; +} + +TYPE* POP(LLIST(TYPE)) ( LLIST(TYPE)* lst) { + if (EMPTY(LLIST(TYPE))(lst)) return NULL; + + LINK(TYPE)* frst = FIRST(lst); + UNLINK(LINK(TYPE))(frst); + + TYPE* retval = frst->value; + --lst->length; + free (frst); + return retval; +} + +int DEEP_COPY(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* src ) { + LINK(TYPE)* n = FIRST(src); + + while (n->after != NULL) { + NEW(TYPE, cpy); + DEEP_COPY(TYPE)(cpy, n->value); + PUSH(LLIST(TYPE)) ( dest, cpy ); + n = n->after; + } + + return 0; +} + +/* + * Adds two linked lists together. + * O(1) time. + * destroys new__ in the process, but keeps the elements. + * make sure to free(new__) after. + */ +int APPEND(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* new__ ) { + + /* Link end of dest onto start of new__. */ + LAST(dest)->after = FIRST(new__); + FIRST(new__)->before = LAST(dest); + + /* Free the two now not needed end links. */ + free(new__->head); + free(dest->tail); + + /* Update dest with new__ tail ptr. */ + dest->tail = new__->tail; + + dest->length += new__->length; + + return 0; +} + +int SIZE(LLIST(TYPE)) ( LLIST(TYPE)* llist ) { + return llist->length; +} + +int EMPTY(LLIST(TYPE)) ( LLIST(TYPE)* llist ) { + return FIRST(llist) == llist->tail; +} + +LLIST(TYPE)* RESOLVE(LLIST(TYPE)) (LLIST(TYPE)* dest, LLIST(TYPE)* new__) { + if (dest == NULL) return new__; + APPEND(LLIST(TYPE))(dest, new__); + free(new__); + return dest; +} + +int RESET(LLIST(TYPE)) ( LLIST(TYPE)* llist ) { + + LINK(TYPE) *link = FIRST(llist), *next; + /* + * Manual looping rather than itterators since we destroyed the + * loop variable. + */ + while (link != llist->tail) { + next = link->after; + FFREE(LINK(TYPE), link); + link = next; + } + + llist->cur = llist->head; + + return 0; +} + +FMT_F(LLIST(TYPE)) { + int seek = 0; + fmtf("("); + FOR(LLIST, TYPE, v, self) { + seek += FMT(TYPE)(v, buf + seek); + fmtf(" "); + } + fmtf(")"); + + return seek; +} + +#endif /* TYPE */ diff --git a/src/macro.h b/src/macro.h new file mode 100644 index 00000000..7b620f83 --- /dev/null +++ b/src/macro.h @@ -0,0 +1,134 @@ +#ifndef MACRO_H +#define MACRO_H + +/* + * Token paste + */ +#define TP(a, b) a ## b +#define TP3(a, b, c) a ## b ## c +#define TP4(a, b, c, d) a ## b ## c ## d +#define TP5(a, b, c, d, e) a ## b ## c ## d ## e +#define TP6(a, b, c, d, e, f) a ## b ## c ## d ## e ## f + +/* + * Get length of __VA_ARGS__ + * Borrowed fram: + * https://stackoverflow.com/a/35986932 + */ +#define VA_ARGS_NUM_PRIV(P1, P2, P3, P4, P5, P6, Pn, ...) Pn +#define VA_ARGS_NUM(...) VA_ARGS_NUM_PRIV(-1, ## __VA_ARGS__, 5, 4, 3, 2, 1, 0) + +/* + * Templatization macros. Forms symbols on the from name, which + * looks really good in debuggers and the like. Unicode characters + * written in \U notation since C apparently doesn't support unicode + * literals. + * + * Can be nested (useful for container types). + * + * Doesn't use ASCII <>, but rather some other ᐸᐳ, meaning that it's + * not a reserved character. + * + * nameᐸTᐳ + */ +#define TEMPL(name, T) TP4(name, \U00001438 , T, \U00001433 ) +#define TEMPL2(name, T, V) TP6(name, \U00001438\U00001438 , T , \U00001433_\U00001438 , V, \U00001433\U00001433) +#define TEMPL_N(name, T, argcount) TP6(name, \U00001438 , T, _, argcount, \U00001433 ) + +/* Constructor type name */ +#define __INIT_T(T, C) TEMPL_N(init, T, C) + +/* Returns full type of constructor */ +#define INIT_F(T, ...) \ + int __INIT_T(T, VA_ARGS_NUM(__VA_ARGS__)) (T* self, ## __VA_ARGS__) + +/* + * Call the constructor of an object + * `int` part of the macro, to ensure that any attempt to call self + * function results in an error. + */ +#define INIT(T, N, ...) \ + __INIT_T(T, VA_ARGS_NUM(__VA_ARGS__)) (N, ## __VA_ARGS__) + +/* Allocate a new_ object on the HEAP */ +#define NEW(T, N, ...) \ + T* N = (T*) malloc(sizeof(*N)); \ + INIT(T, N, ## __VA_ARGS__); + +/* + * Reconstructs a object. Use with caution. + */ +#define RENEW(T, N, ...) do { \ + N = (T*) malloc(sizeof(*N)); \ + INIT(T, N, ## __VA_ARGS__); \ +} while (0) + + +/* Allocate a new_ object on the STACK */ +#define SNEW(T, N, ...) \ + T N; \ + INIT(T, & N, ## __VA_ARGS__); + +/* Destructor for type */ +#define FREE(T) TEMPL(free, T) + +/* Call destructor for type, and free object */ +#define FFREE(T, N) do { FREE(T)(N); free(N); } while (0) + +/* Declare destructor */ +#define FREE_F(T) int FREE(T) (T* self) + +/* generate reusable internal symbol */ +#define __INTER(s) TP3(__, s, __internal) +#define __INTER2(s) __INTER(__INTER(s)) +#define __INTER3(s) __INTER(__INTER(__INTER(s))) + +/* Iterator macros. */ +#define FOR(CONT_T, T, var, set) \ + PRE_FOR_ ## CONT_T (T) (T, var, set); \ + for( BEG_ ## CONT_T (T) (T, var, set); \ + END_ ## CONT_T (T) (T, var, set); \ + NXT_ ## CONT_T (T) (T, var, set)) + +/* Example int implementation + * FOR(int, i, 10) { } */ + +#define PRE_FOR_int(i, set) +#define BEG_int(i, set) int i = 0 +#define NXT_int(i, set) i++ +#define END_int(i, set) i < set + +/* + * General functions that different container types may implement. + * Actuall implementation and type signature is mostly left to + * individual implementations. + */ +#define DEEP_COPY(T) TEMPL(copy , T) +#define RESOLVE(T) TEMPL(resolve , T) +#define APPEND(T) TEMPL(append , T) +#define SIZE(T) TEMPL(size , T) +#define EMPTY(T) TEMPL(empty , T) +#define PUSH(T) TEMPL(push , T) +#define PEEK(T) TEMPL(peek , T) +#define POP(T) TEMPL(pop , T) +#define GET(T) TEMPL(get , T) +#define RESET(T) TEMPL(reset , T) +#define KEYS(T) TEMPL(keys , T) + +/* + * Formatting macros. + * Transform objects into string representation of themselves. + * buf should be a suffisiently large memmory location, if it's to + * small then bad stuff might happen. + * + * Should return the number of bytes written (like sprintf). + */ + +#define FMT_T(T) TEMPL(format , T) +#define FMT_F(T) int FMT_T(T)(T* self, char* buf, ...) +// TODO change order of buf and item +#define __FMT_HELP(item, buf, ...) ((item), (buf), VA_ARGS_NUM(__VA_ARGS__), ## __VA_ARGS__) +#define FMT(T) FMT_T(T) __FMT_HELP +#define fmtf(...) seek += sprintf(buf + seek, __VA_ARGS__) + +#endif /* MACRO_H */ diff --git a/src/main.c b/src/main.c new file mode 100644 index 00000000..791bc5d3 --- /dev/null +++ b/src/main.c @@ -0,0 +1,91 @@ +#include +#include +#include +#include + +#include "calendar.h" +#include "macro.h" +#include "vcal.h" +#include "graphs.h" +#include "err.h" + +typedef struct { + int argc; + char** argv; +} arg; + +int arg_shift (arg* a) { + if (a->argc == 0) return 0; + + ++a->argv; + return --a->argc; + +} + +int main (int argc, char** argv) { + arg args = { .argc = argc, .argv = argv }; + + if (arg_shift(&args) == 0) { + ERR("Please give vdir or a vcalendar file as first argument"); + exit (1); + } + + char* rootpath = args.argv[0]; + SNEW(vcomponent, root, "ROOT", rootpath); + read_vcalendar(&root, rootpath); + + arg_shift(&args); + + if (args.argc == 0 || strcmp(args.argv[0], "-p") == 0) { + INFO_F("Parsed calendar file containing [%u] events", + root.components.length); + + puts("CAL : OBJ | Filename | Description"); + puts("----------+----------+------------"); + + /* This loops over all VCALENDAR's in root */ + FOR (LLIST, vcomponent, cal, &root.components) { + assert(strcmp(cal->type, "VCALENDAR") == 0); + + char* filename = vcomponent_get_val(cal, "X-HNH-FILENAME"); + + /* This loop over all VEVENT's in the current VCALENDAR */ + FOR (LLIST, vcomponent, ev, &cal->components) { + if (strcmp(ev->type, "VEVENT") != 0) continue; + + printf("%s | %s\n", + filename, + get_property(ev, "SUMMARY")->cur->value->key.mem); + } + } + } else if (strcmp(args.argv[0], "-g") == 0) { + /* TODO self might be broken */ + if (arg_shift(&args) == 0) { + FOR (LLIST, vcomponent, cal, &root.components) { + assert(strcmp(cal->type, "VCALENDAR") == 0); + + vcomponent* ev = FCHILD(cal); + + char target[0xFF]; + target[0] = '\0'; + strcat(target, "/tmp/dot/"); + strcat(target, vcomponent_get_val(ev, "X-HNH-FILENAME")); + strcat(target, ".dot"); + // create_graph(ev, target); + } + } else { + // create_graph(FCHILD(FCHILD(&root)), args.argv[0]); + INFO("Creating graph for single file"); + INFO_F("output = %s\n", args.argv[0]); + create_graph_vcomponent(&root, args.argv[0]); + } + } + + /* + char buf[0x20000]; + FMT(vcomponent)(&root, buf); + puts(buf); + */ + + FREE(vcomponent)(&root); +} diff --git a/src/pair.h b/src/pair.h new file mode 100644 index 00000000..e96cf180 --- /dev/null +++ b/src/pair.h @@ -0,0 +1,19 @@ +#ifndef PAIR_H +#define PAIR_H + +#define PAIR(T, V) TEMPL2(pair, T, V) + +#endif /* PAIR_H */ +#if defined(T) && defined(V) + +typedef struct { + T key; + V val; +} PAIR(T, V); + +INIT_F(PAIR(T, V)); +FREE_F(PAIR(T, V)); +FMT_F(PAIR(T, V)); +int DEEP_COPY(PAIR(T, V)) (PAIR(T, V)* dest, PAIR(T, V)* src); + +#endif diff --git a/src/pair.inc.h b/src/pair.inc.h new file mode 100644 index 00000000..c42b2dfd --- /dev/null +++ b/src/pair.inc.h @@ -0,0 +1,34 @@ +#if ! (defined(T) && defined(V)) +#error "Both T and V must be defiend here" +#else + +INIT_F(PAIR(T, V)) { + INIT(T, &self->key); + INIT(V, &self->val); + + return 0; +} + +FREE_F(PAIR(T, V)) { + FREE(T)(&self->key); + FREE(V)(&self->val); + + return 0; +} + +FMT_F(PAIR(T, V)) { + char lbuf[0x100]; + char rbuf[0x1000]; + FMT(T)(&self->key, lbuf); + FMT(V)(&self->val, rbuf); + + return sprintf(buf, "<%s, %s>", lbuf, rbuf); +} + +int DEEP_COPY(PAIR(T, V)) (PAIR(T, V)* dest, PAIR(T, V)* src) { + DEEP_COPY(T)(&dest->key, &src->key); + DEEP_COPY(V)(&dest->val, &src->val); + return 0; +} + +#endif /* T & V */ diff --git a/src/parse.c b/src/parse.c new file mode 100644 index 00000000..0e37350d --- /dev/null +++ b/src/parse.c @@ -0,0 +1,351 @@ +#include "parse.h" + +#include +#include +#include + +#include "macro.h" +#include "vcal.h" + +#include "err.h" + +// #define TYPE vcomponent +// #include "linked_list.inc.h" +// #undef TYPE + +#define T strbuf +#define V strbuf +#include "pair.h" +#include "pair.inc.h" +#undef T +#undef V + +/* + * name *(";" param) ":" value CRLF + */ +int parse_file(char* filename, FILE* f, vcomponent* root) { + part_context p_ctx = p_key; + + SNEW(parse_ctx, ctx, f, filename); + PUSH(LLIST(vcomponent))(&ctx.comp_stack, root); + + /* + * Create a content_line which we use as storage while we are + * parsing. This object is constantly broken down and rebuilt. + * + * {cline,param}_key is also temporary register used during + * parsing. + */ + SNEW(content_line, cline); + SNEW(strbuf, cline_key); + SNEW(strbuf, param_key); + + char c; + while ( (c = fgetc(f)) != EOF) { + + /* We have a linebreak */ + if (c == '\r' || c == '\n') { + + if (fold(&ctx, c) > 0) { + /* Actuall end of line, handle value */ + TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); + handle_kv(&cline_key, &cline, &ctx); + p_ctx = p_key; + } /* Else continue on current line */ + + /* We have an escaped character */ + } else if (c == '\\') { + handle_escape (&ctx); + + /* Border between param {key, value} */ + } else if (p_ctx == p_param_name && c == '=') { + + /* Save the current parameter key */ + TRANSFER (¶m_key, &ctx.str); + p_ctx = p_param_value; + + /* + * One of four cases: + * 1) end of key , start of value + * 2) ,, key , ,, param + * 3) ,, param, ,, param + * 4) ,, param, ,, value + */ + } else if ((p_ctx == p_key || p_ctx == p_param_value) && (c == ':' || c == ';')) { + + /* We got a parameter value, push the current string to + * the current parameter set. */ + if (p_ctx == p_param_value) { + /* save current parameter value. */ + + NEW(strbuf, s); + TRANSFER(s, &ctx.str); + + NEW(param_set, ps); + PUSH(param_set)(ps, s); + + PUSH(TRIE(param_set))(CLINE_CUR_PARAMS(&cline), param_key.mem, ps); + strbuf_soft_reset (¶m_key); + } + + /* + * Top level key. + * Copy the key into the current cline, and create a + * content_set for the upcomming value and (possible) + * parameters. + */ + if (p_ctx == p_key) { + + TRANSFER(&cline_key, &ctx.str); + + NEW(content_set, p); + PUSH(LLIST(content_set))(&cline, p); + } + + if (c == ':') p_ctx = p_value; + else if (c == ';') p_ctx = p_param_name; + + /* + * Nothing interesting happened, append the read character to + * the current string. + */ + } else { + strbuf_append(&ctx.str, c); + + ++ctx.column; + ++ctx.pcolumn; + } + } + + if (! feof(f)) { + ERR("Error parsing"); + } + /* Check to see if empty line */ + else if (ctx.str.ptr != 0) { + /* + * The standard (3.4, l. 2675) says that each icalobject must + * end with CRLF. My files however does not, so we also parse + * the end here. + */ + + TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); + handle_kv(&cline_key, &cline, &ctx); + + } + + FREE(content_line)(&cline); + FREE(strbuf)(&cline_key); + FREE(strbuf)(¶m_key); + + assert(POP(LLIST(vcomponent))(&ctx.comp_stack) == root); + assert(EMPTY(LLIST(strbuf))(&ctx.key_stack)); + assert(EMPTY(LLIST(vcomponent))(&ctx.comp_stack)); + + FREE(parse_ctx)(&ctx); + + return 0; +} + +/* + * We have a complete key value pair. + */ +int handle_kv ( + strbuf* key, + content_line* cline, + parse_ctx* ctx + ) { + + /* + * The key being BEGIN means that we decend into a new component. + */ + if (strbuf_c(key, "BEGIN")) { + /* key \in { VCALENDAR, VEVENT, VALARM, VTODO, VTIMEZONE, ... } */ + + /* + * Take a copy of the name of the entered component, and store + * it on the stack of component names. + */ + NEW(strbuf, s); + DEEP_COPY(strbuf)(s, CLINE_CUR_VAL(cline)); + PUSH(LLIST(strbuf))(&ctx->key_stack, s); + + /* Clear the value list in the parse content_line */ + RESET(LLIST(content_set))(cline); + + /* + * Create the new curent component, link it with the current + * component in a parent/child relationship. + * Finally push the new component on to the top of the + * component stack. + */ + NEW(vcomponent, e, + s->mem, + ctx->filename); + vcomponent* parent = PEEK(LLIST(vcomponent))(&ctx->comp_stack); + PUSH(vcomponent)(parent, e); + + PUSH(LLIST(vcomponent))(&ctx->comp_stack, e); + + /* + * The end of a component, go back along the stack to the previous + * component. + */ + } else if (strbuf_c(key, "END")) { + strbuf* expected_key = POP(LLIST(strbuf))(&ctx->key_stack); + + if (strbuf_cmp(expected_key, CLINE_CUR_VAL(cline)) != 0) { + + ERR_P(ctx, "Expected END:%s, got END:%s.\n%s line", + expected_key->mem, + CLINE_CUR_VAL(cline)->mem, + vcomponent_get_val( + PEEK(LLIST(vcomponent))(&ctx->comp_stack), + "X-HNH-FILENAME")); + PUSH(LLIST(strbuf))(&ctx->key_stack, expected_key); + + return -1; + + } else { + FFREE(strbuf, expected_key); + POP(LLIST(vcomponent))(&ctx->comp_stack); + } + + /* + * A regular key, value pair. Push it into to the current + * component. + */ + } else { + + /* + * cline is the value store used during parsing, meaning that + * its values WILL mutate at a later point. Therefore we take + * a copy of it here. + */ + NEW(content_line, c); + DEEP_COPY(content_line)(c, cline); + + /* + * The PUSH(TRIE(T)) method handles collisions by calling + * RESOLVE(T). content_line resolves by merging the new value + * into the old value, and freeing the new value's container. + * + * This means that |c| declared above might be destroyed + * here. + */ + PUSH(TRIE(content_line))( + &PEEK(LLIST(vcomponent))(&ctx->comp_stack)->clines, + key->mem, c); + + RESET(LLIST(content_set))(cline); + } + + return 0; +} + +int fold(parse_ctx* ctx, char c) { + int retval; + + char buf[2] = { + (c == '\n' ? '\n' : (char) fgetc(ctx->f)), + (char) fgetc(ctx->f) + }; + + ctx->pcolumn = 1; + + if (buf[0] != '\n') { + ERR_P(ctx, "expected new_line after CR"); + retval = -1; + + } else if (buf[1] == ' ' || buf[1] == '\t') { + retval = 0; + ctx->pcolumn++; + + } else if (ungetc(buf[1], ctx->f) != buf[1]) { + ERR_P(ctx, "Failed to put character back on FILE"); + retval = -2; + + } else { + retval = 1; + ++ctx->line; + ctx->column = 0; + } + + ++ctx->pline; + + return retval; +} + + +INIT_F(parse_ctx, FILE* f, char* filename) { + INIT(LLIST(strbuf), &self->key_stack); + INIT(LLIST(vcomponent), &self->comp_stack); + self->filename = (char*) calloc(sizeof(*filename), strlen(filename) + 1); + strcpy(self->filename, filename); + self->f = f; + + self->line = 0; + self->column = 0; + + self->pline = 1; + self->pcolumn = 1; + + INIT(strbuf, &self->str); + + return 0; +} + +FREE_F(parse_ctx) { + + FREE(LLIST(strbuf))(&self->key_stack); + FREE(LLIST(vcomponent))(&self->comp_stack); + free(self->filename); + + self->line = 0; + self->column = 0; + FREE(strbuf)(&self->str); + + return 0; +} + +int handle_escape (parse_ctx* ctx) { + char esc = fgetc(ctx->f); + char target; + + /* + * Escape character '\' and escaped token sepparated by a newline + * (since the standard for some reason allows that (!!!)) + * We are at least guaranteed that it's a folded line, so just + * unfold it and continue trying to find a token to escape. + */ + if (esc == '\r' || esc == '\n') { + int ret; + if ( (ret = fold(ctx, esc)) != 0) { + if (ret == 1) ERR_P(ctx, "ESC before not folded line"); + else ERR_P(ctx, "other error: val = %i", ret); + exit (2); + } else { + esc = fgetc(ctx->f); + } + } + + /* Escaped new_line */ + if (esc == 'n' || esc == 'N') { + target = '\n'; + + /* "Standard" escaped character */ + } else if (esc == ';' || esc == ',' || esc == '\\') { + target = esc; + + /* Invalid escaped character */ + } else { + ERR_P(ctx, "Non escapable character '%c' (%i)", esc, esc); + } + + /* save escapade character as a normal character */ + strbuf_append(&ctx->str, target); + + ++ctx->column; + ++ctx->pcolumn; + + return 0; +} diff --git a/src/parse.h b/src/parse.h new file mode 100644 index 00000000..53263b4c --- /dev/null +++ b/src/parse.h @@ -0,0 +1,122 @@ +#ifndef PARSE_H +#define PARSE_H + +#include +#include + +#include "strbuf.h" +#include "vcal.h" + +// #define TYPE vcomponent +// #include "linked_list.h" +// #undef TYPE + +/* + * The standard says that no line should be longer than 75 octets. + * This sets the default amount of memory to allocate for each string, + * but strings are reallocated when needed. + */ +#define SEGSIZE 75 + +/* + * Transfers a strbuf from src to target. + * Does this first copying the contents, followed by capping the + * target and reseting the src. + */ +#define TRANSFER(target, src) do { \ + DEEP_COPY(strbuf)((target), (src)); \ + strbuf_cap(target); \ + strbuf_soft_reset(src); \ +} while (0) + +/* + * Current context for the character consumer (parse_file). + */ +typedef enum { + p_key, p_value, p_param_name, p_param_value, p_escape +} part_context; + +/* + * Struct holding most state information needed while parsing. + * Kept together for simplicity. + */ +typedef struct { + /* Which file we are parsing, copied to all components to allow + * writebacks later */ + char* filename; + + FILE* f; + + /* + * context stacks used since ICS files form a tree. key_stack is + * only for sequrity purposes. + */ + LLIST(strbuf) key_stack; + LLIST(vcomponent) comp_stack; + + /* Number for unfolded lines + * TODO remove this + * */ + int line; + int column; + + /* Actuall lines and columns from file */ + int pline; + int pcolumn; + + /* + * String which we write everything read into. + * Later copied to appropiate places. + */ + strbuf str; +} parse_ctx; + +INIT_F(parse_ctx, FILE* f, char* filename); +FREE_F(parse_ctx); + + +/* + * Character consumer. Reads characters from stdin until end of file. + * Whenever it finds a token with a special value (such as ':', ';', + * ...) it saves it away. + * Once It has parsed a full line it calls handel_kv. Which build my + * actuall datastructure. + */ +int parse_file(char* filename, FILE* f, vcomponent* cal); + +/* + * Called whenever parse_file finishes a line. Copies the contents of + * ctx and the current content_line into the object stack, stored in + * ctx. + */ +int handle_kv( + strbuf* key, + content_line* cline, + parse_ctx* ctx + ); + +/* + * Input + * f: file to get characters from + * ctx: current parse context + * c: last read character + * output: + * 0: line folded + * 1: line ended + * + * A carrige return means that the current line is at an + * end. The following character should always be \n. + * However, if the first character on the next line is a + * whitespace then the two lines should be concatenated. + * + * NOTE + * The above is true according to the standard. But I have + * found files with only NL. The code below ends line on the + * first of NL or CR, and then ensures that the program thinks + * it got the expected CRNL. + */ +int fold(parse_ctx* ctx, char c); + +int handle_escape (parse_ctx* ctx); + +#endif /* PARSE_H */ diff --git a/src/strbuf.c b/src/strbuf.c new file mode 100644 index 00000000..0e56468b --- /dev/null +++ b/src/strbuf.c @@ -0,0 +1,151 @@ +#include "strbuf.h" + +#include +#include + +#include "err.h" + +INIT_F(strbuf) { + self->alloc = 0x10; + self->mem = (char*) calloc(sizeof(*self->mem), self->alloc); + self->ptr = 0; + self->len = 0; + self->scm = NULL; + return 0; +} + +int strbuf_realloc(strbuf* str, size_t len) { + str->mem = (char*) realloc(str->mem, len); + str->alloc = len; + return 0; +} + +FREE_F(strbuf) { + /* has already been freed */ + if (self->mem == NULL) return 1; + + free (self->mem); + self->mem = NULL; + self->alloc = 0; + self->len = 0; + return 0; +} + +/* + * Reallocates memmory for you. Returns 1 if memory was reallocated. + */ +int strbuf_append(strbuf* s, char c) { + int retval = 0; + + if (s->len + 1 > s->alloc) { + s->alloc <<= 1; + s->mem = (char*) realloc(s->mem, s->alloc); + retval = 1; + } + + s->mem[s->len] = c; + s->ptr = ++s->len; + return retval; +} + +char strbuf_pop(strbuf* s) { + char ret = s->mem[--s->len]; + s->mem[s->len + 1] = '\0'; + return ret; +} + +int strbuf_cap(strbuf* s) { + strbuf_append(s, 0); + --s->len; + return 0; +} + +int DEEP_COPY(strbuf)(strbuf* dest, strbuf* src) { + int retval = 0; + + if (dest->alloc < src->len) { + /* +1 in length is to have room for '\0'. */ + strbuf_realloc(dest, src->len + 1); + retval = 1; + } + + if (src->scm != NULL) { + /* The magic SCM type is copied when reassigned. */ + dest->scm = src->scm; + /* NOTE This is a bit of a leaky abstraction. */ + scm_gc_protect_object(dest->scm); + } + + dest->len = src->len; + memcpy(dest->mem, src->mem, src->len); + return retval; +} + +int strbuf_cmp(strbuf* a, strbuf* b) { + if (a == NULL || a->alloc == 0 || + b == NULL || b->alloc == 0) + { + ERR("a or b not alloced"); + // return -1; + } + + return strncmp(a->mem, b->mem, a->len); +} + +int strbuf_c(strbuf* a, const char* b) { + if (a == NULL || a->alloc == 0) { + ERR("a not allocated"); + return -1; + } + + return strcmp(a->mem, b) == 0; +} + +char* charat(strbuf* s, unsigned int idx) { + if (idx > s->len) { + ERR("Index out of bounds"); + return (char*) -1; + } + + return &s->mem[idx]; +} + +char* strbuf_cur(strbuf* s) { + return &s->mem[s->ptr]; +} + +char* strbuf_end(strbuf* s) { + return &s->mem[s->len]; +} + +int strbuf_reset(strbuf* s) { + s->ptr = 0; + return 0; +} + + +int strbuf_soft_reset(strbuf* s) { + s->ptr = s->len = 0; + return 0; +} + +strbuf* RESOLVE(strbuf)(strbuf* dest, strbuf* new_) { + if (dest == NULL) return new_; + else return dest; +} + +FMT_F(strbuf) { + return sprintf(buf, "%s", self->mem); +} + +int SIZE(strbuf)(strbuf* self) { + return self->len; +} + +int strbuf_load(strbuf* self, const char* str) { + for (int i = 0; str[i] != '\0'; i++) { + strbuf_append(self, str[i]); + } + strbuf_cap(self); + return 0; +} diff --git a/src/strbuf.h b/src/strbuf.h new file mode 100644 index 00000000..7f936a9e --- /dev/null +++ b/src/strbuf.h @@ -0,0 +1,109 @@ +#ifndef STRBUF_H +#define STRBUF_H + +#include +#include +#include "macro.h" + +/* + * A high level string type which holds it's own length, how much + * memmory it has allocated for itself, and a seek pointer into the + * string. + * + * Also comes with a number of functions which allow for safe(er) + * access to the memmory. + */ +typedef struct { + char* mem; + SCM scm; + /* TODO add support for negative ptr */ + int ptr; + unsigned int alloc; + unsigned int len; +} strbuf; + +/* + * Init strbuf to size of 10 + */ +INIT_F(strbuf); + +/* + * Like realloc, but for strbuf + */ +int strbuf_realloc(strbuf* str, size_t len); + +/* + * Free's contents of str, but keeps str. + */ +FREE_F(strbuf); + +int strbuf_cmp(strbuf* a, strbuf* b); +int strbuf_c(strbuf* a, const char* b); + +/* + * Copy contents from src to dest. + * Assumes that dest is already initialized. + */ +int DEEP_COPY(strbuf)(strbuf*, strbuf*); + +/* + * Append char to end of strbuf, determined by s->len. + * + * TODO rename this PUSH(strbuf)? + */ +int strbuf_append(strbuf* s, char c); + +char strbuf_pop(strbuf*); + +/* + * Calls strbuf_append with NULL. + */ +int strbuf_cap(strbuf* s); + +/* + * Returns a pointer to character at index. Allows mutation of the + * value pointed to by the return address. + */ +char* charat(strbuf* s, unsigned int idx); + +/* + * Same as `charat`, But returns the current character. + */ +char* strbuf_cur(strbuf* s); + +/* + * Resets the seek for strbuf to 0. + */ +int strbuf_reset(strbuf* s); + +/* + * Sets the length and seek ptr to 0, but doesn't touch the memmory. + */ +int strbuf_soft_reset(strbuf* s); + +/* + * Returns the character after the last, so where null hopefully is. + */ +char* strbuf_end(strbuf* s); + +/* + * Reallocs dest to be the same size as src, and copies the contents + * of src into dest. + */ +int strbuf_realloc_copy(strbuf* dest, strbuf* src); + +/* + * Copies contents from src to dest, also allocating dest in the + * process. dest should not be initialized before self call. + */ +int strbuf_init_copy(strbuf* dest, strbuf* src); + +strbuf* RESOLVE(strbuf)(strbuf*, strbuf*); + +FMT_F(strbuf); + +int SIZE(strbuf)(strbuf*); + +int strbuf_load(strbuf* self, const char* str); + +#endif /* STRBUF_H */ diff --git a/src/termios.scm.c b/src/termios.scm.c new file mode 100644 index 00000000..939c3574 --- /dev/null +++ b/src/termios.scm.c @@ -0,0 +1,44 @@ +#include +#include +#include +#include + +static struct termios *oldt, *newt; + +SCM_DEFINE(termios_lflags_and, "c-lflags-disable!", 2, 0, 0, + (SCM _fd, SCM _bits), + "") +{ + + int fd = scm_to_int (_fd); + int bits = scm_to_int (_bits); + + printf("Setting bits [%x]\n", bits); + + tcgetattr(fd, oldt); + *newt = *oldt; + + // Make the terminal not echo back, + // along with enabling cononical mode + newt->c_lflag &= ~ bits; + tcsetattr(fd, TCSANOW, newt); + return SCM_UNSPECIFIED; +} + +SCM_DEFINE(termios_restore, "c-lflag-restore!", 1, 0, 0, + (SCM _fd), + "") +{ + int fd = scm_to_int (_fd); + tcsetattr(fd, TCSANOW, oldt); + return SCM_UNSPECIFIED; +} + +void init_termios (void) { + oldt = scm_gc_malloc(sizeof(*oldt), "Termios"); + newt = scm_gc_malloc(sizeof(*newt), "Termios"); + +#ifndef SCM_MAGIC_SNARFER +#include "termios.x" +#endif +} diff --git a/src/trie.h b/src/trie.h new file mode 100644 index 00000000..9de38be3 --- /dev/null +++ b/src/trie.h @@ -0,0 +1,54 @@ +#ifndef TRIE_H +#define TRIE_H + +#include + +#include "macro.h" + +#define TRIE(T) TEMPL(trie, T) +#define TRIE_NODE(T) TEMPL(trie_node, T) + +#endif /* TRIE_H */ +#ifdef TYPE + +#include "linked_list.h" +#include "strbuf.h" + +typedef struct TRIE_NODE(TYPE) { + char c; + TYPE* value; + struct TRIE_NODE(TYPE)* next; + struct TRIE_NODE(TYPE)* child; +} TRIE_NODE(TYPE); + +typedef struct { + TRIE_NODE(TYPE)* root; +} TRIE(TYPE); + + +INIT_F ( TRIE(TYPE) ); + +INIT_F (TRIE_NODE(TYPE), char c); + +INIT_F (TRIE_NODE(TYPE), + char c, TRIE_NODE(TYPE)* next, TRIE_NODE(TYPE)* child ); + +int PUSH(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key, TYPE* val ); + +TYPE* GET(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key ); + +FREE_F(TRIE_NODE(TYPE)); + +FREE_F(TRIE(TYPE)); + +int EMPTY(TRIE(TYPE))(TRIE(TYPE)*); + +FMT_F(TRIE_NODE(TYPE)); +FMT_F(TRIE(TYPE)); + +int DEEP_COPY(TRIE_NODE(TYPE)) (TRIE_NODE(TYPE)* dest, TRIE_NODE(TYPE)* src); +int DEEP_COPY(TRIE(TYPE)) (TRIE(TYPE)* dest, TRIE(TYPE)* src); + +LLIST(strbuf)* KEYS(TRIE(TYPE)) (TRIE(TYPE)*); + +#endif /* TYPE */ diff --git a/src/trie.inc.h b/src/trie.inc.h new file mode 100644 index 00000000..ffc8ac8e --- /dev/null +++ b/src/trie.inc.h @@ -0,0 +1,228 @@ +#ifndef TYPE +#error "Set TYPE before including self file" +#else + +#include + +#include "err.h" +#include "macro.h" +#include "linked_list.inc.h" +#include "strbuf.h" + +INIT_F ( TRIE(TYPE) ) { + NEW(TRIE_NODE(TYPE), t, '\0'); + self->root = t; + return 0; +} + +INIT_F (TRIE_NODE(TYPE), char c) { + self->c = c; + self->value = NULL; + self->next = NULL; + self->child = NULL; + return 0; +} + +INIT_F (TRIE_NODE(TYPE), + char c, + TRIE_NODE(TYPE)* next, + TRIE_NODE(TYPE)* child ) +{ + self->c = c; + self->next = next; + self->child = child; + return 0; +} + +int PUSH(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key, TYPE* val ) { + TRIE_NODE(TYPE) *cur, *last; + + last = trie->root; + cur = last->child; + + char* subkey = key; + + while (1) { + if (cur == NULL) { + /* Build direct LL for remaining subkey */ + for (char* c = subkey; c[0] != '\0'; c++) { + NEW(TRIE_NODE(TYPE), t, *c); + last->child = t; + last = t; + } + last->value = RESOLVE(TYPE)(last->value, val); + return 0; + } else if (cur->c == subkey[0]) { + /* This node belongs to the key, + * Decend further */ + last = cur; + cur = cur->child; + subkey++; + } else if (subkey[0] == '\0') { + /* Key finished */ + last->value = RESOLVE(TYPE)(last->value, val); + return 0; + } else if (cur->next != NULL) { + /* This node was not part of the set, but it's sibling might */ + cur = cur->next; + /* `last` not set since we aren't moving down */ + } else { + /* No node on self level was part of the set, create a new__ + * sibling and follow down that parse */ + NEW(TRIE_NODE(TYPE), t, *subkey); + cur->next = t; + last = cur; + cur = t; + } + } + + return 0; +} + +/* + * TODO what happens when I give an invalid key? + */ +TYPE* GET(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key ) { + TRIE_NODE(TYPE)* n = trie->root->child; + char* subkey = key; + + while (n != NULL) { + if (subkey[1] == '\0') { + /* Wanted node found, + * value can however be NULL */ + return n->value; + } else if (subkey[0] == n->c) { + n = n->child; + subkey++; + } else { + n = n->next; + } + } + + /* Position not found */ + return 0; +} + +FREE_F(TRIE_NODE(TYPE)) { + if (self == NULL) return 0; + if (self->value != NULL) FFREE(TYPE, self->value); + if (self->next != NULL) FREE(TRIE_NODE(TYPE))(self->next); + if (self->child != NULL) FREE(TRIE_NODE(TYPE))(self->child); + free (self); + return 0; +} + +FREE_F(TRIE(TYPE)) { + if (self->root->c != '\0') { + // ERR("Invalid trie"); + return 1; + } + return FREE(TRIE_NODE(TYPE))(self->root); +} + +int EMPTY(TRIE(TYPE))(TRIE(TYPE)* self) { + return self->root->child == NULL; +} + +FMT_F(TRIE_NODE(TYPE)) { + + va_list ap; + va_start(ap, buf); + int argc = va_arg(ap, int); + int depth = argc >= 1 + ? va_arg(ap, int) + : 0; + va_end(ap); + + int seek = 0; + + TRIE_NODE(TYPE)* n = self; + + if (n == NULL) { fmtf("\n"); } + while (n != NULL) { + fmtf("|"); + // FOR(int, i, depth) fmtf(" "); + for (int i = 0; i < depth; i++) fmtf(" "); + fmtf("%c ", n->c == '\0' ? '0' : n->c); + if (n->value != NULL) { + seek += FMT(TYPE)(n->value, buf + seek); + fmtf("\n"); + } + + if (n->child != NULL) { + fmtf("\n"); + seek += FMT(TRIE_NODE(TYPE))(n->child, buf + seek, depth + 1); + } + n = n->next; + } + return seek; + +} + +FMT_F(TRIE(TYPE)) { + int seek = 0; + fmtf("Trie: %p: {", self); + if (EMPTY(TRIE(TYPE))(self)) { + fmtf(" [EMPTY] "); + } else { + fmtf("\n"); + seek += FMT(TRIE_NODE(TYPE))(self->root->child, buf + seek); + } + fmtf("}"); + return seek; +} + +int DEEP_COPY(TRIE_NODE(TYPE)) (TRIE_NODE(TYPE)* dest, TRIE_NODE(TYPE)* src) { + dest->c = src->c; + + if (src->value != NULL) { + RENEW(TYPE, dest->value); + DEEP_COPY(TYPE)(dest->value, src->value); + } + + if (src->next != NULL) { + RENEW(TRIE_NODE(TYPE), dest->next, '\0'); + DEEP_COPY(TRIE_NODE(TYPE))(dest->next, src->next); + } + + if (src->child != NULL) { + RENEW(TRIE_NODE(TYPE), dest->child, '\0'); + DEEP_COPY(TRIE_NODE(TYPE))(dest->child, src->child); + } + + return 0; +} + +int DEEP_COPY(TRIE(TYPE)) (TRIE(TYPE)* dest, TRIE(TYPE)* src) { + return DEEP_COPY(TRIE_NODE(TYPE))(dest->root, src->root); +} + +void KEYS(TRIE_NODE(TYPE)) (TRIE_NODE(TYPE)* node, LLIST(strbuf)* list, strbuf* path) { + if (node == NULL) return; + + + if (node->value != NULL) { + strbuf_append(path, node->c); + NEW(strbuf, c); + DEEP_COPY(strbuf)(c, path); + PUSH(LLIST(strbuf))(list, c); + strbuf_pop(path); + } + if (node->next != NULL) { + KEYS(TRIE_NODE(TYPE)) (node->next, list, path); + } + if (node->child != NULL) { + if (node->c != '\0') strbuf_append(path, node->c); + KEYS(TRIE_NODE(TYPE)) (node->child, list, path); + if (node->c != '\0') strbuf_pop(path); + } +} + +LLIST(strbuf)* KEYS(TRIE(TYPE)) (TRIE(TYPE)* trie) { + NEW(LLIST(strbuf), retlist); + SNEW(strbuf, key); + KEYS(TRIE_NODE(TYPE)) (trie->root, retlist, &key); + return retlist; +} + +#endif /* TYPE */ diff --git a/src/vcal.c b/src/vcal.c new file mode 100644 index 00000000..305275e7 --- /dev/null +++ b/src/vcal.c @@ -0,0 +1,152 @@ +#include "vcal.h" + +#include + +#define TYPE strbuf +#include "linked_list.inc.h" +#undef TYPE + +#define TYPE param_set +#include "trie.inc.h" +#undef TYPE + +#define TYPE content_set +#include "linked_list.inc.h" +#undef TYPE + +#define T strbuf + #define V TRIE(param_set) + #include "pair.inc.h" + #undef V +#undef T + +#define TYPE content_line +// #include "hash.inc" +#include "trie.inc.h" +#undef TYPE + +#define TYPE vcomponent +// #include "vector.inc.h" +#include "linked_list.inc.h" +#undef TYPE + +INIT_F(vcomponent) { + (void) self; + ERR("Do not use"); + return 0; +} + +INIT_F(vcomponent, const char* type) { + return INIT(vcomponent, self, type, NULL); +} + +INIT_F(vcomponent, const char* type, const char* filename) { + + INIT(TRIE(content_line), &self->clines); + INIT(LLIST(vcomponent), &self->components); + + if (filename != NULL) { + vcomponent_push_val (self, "X-HNH-FILENAME", filename); + } + + self->type = (char*) calloc(sizeof(*type), strlen(type) + 1); + strcpy(self->type, type); + + self->parent = NULL; + self->scm = NULL; + + return 0; +} + +content_line* get_property (vcomponent* ev, const char* key) { + size_t len = strlen(key) + 1; + char* cpy = (char*) (calloc(sizeof(*cpy), len)); + strncpy (cpy, key, len); + + content_line* ret = GET(TRIE(content_line))(&ev->clines, cpy); + + free (cpy); + return ret; +} + +FREE_F(vcomponent) { + free(self->type); + + if (FREE(TRIE(content_line))(&self->clines) != 0) { + ERR("Error freeing vcomponent"); + } + + FREE(LLIST(vcomponent))(&self->components); + + return 0; +} + +int PUSH(vcomponent)(vcomponent* parent, vcomponent* child) { + child->parent = parent; + return PUSH(LLIST(vcomponent))(&parent->components, child); +} + +int DEEP_COPY(vcomponent)(vcomponent* a, vcomponent* b) { + (void) a; + (void) b; + ERR("Deep copy not implemented for vcomponent"); + return -1; +} + +int vcomponent_copy(vcomponent* dest, vcomponent* src) { + + DEEP_COPY(TRIE(content_line))(&dest->clines, &src->clines); + + /* Children are the same objects */ + FOR(LLIST, vcomponent, c, &src->components) { + PUSH(LLIST(vcomponent))(&dest->components, c); + } + + PUSH(vcomponent)(src->parent, dest); + + return 0; +} + +FMT_F(vcomponent) { + int seek = 0; + + for (int i = 0; i < 40; i++) fmtf("_"); + + seek += sprintf(buf + seek, _YELLOW); + seek += sprintf(buf + seek, "\nVComponet (Type := %s)\n", self->type); + seek += sprintf(buf + seek, _RESET); + seek += FMT(TRIE(content_line))(&self->clines, buf + seek); + seek += sprintf(buf + seek, "\nComponents:\n"); + FOR(LLIST, vcomponent, comp, &self->components) { + seek += FMT(vcomponent)(comp, buf + seek); + } + + return seek; +} + +int vcomponent_push_val (vcomponent* comp, const char* key, const char* val) { + NEW(content_line, cl); + NEW(content_set, cs); + strbuf_load(&cs->key, val); + PUSH(content_line)(cl, cs); + + char* key_cpy = calloc(sizeof(*key_cpy), strlen(key) + 1); + strcpy (key_cpy, key); + PUSH(TRIE(content_line))(&comp->clines, key_cpy, cl); + free (key_cpy); + + return 0; +} + +char* vcomponent_get_val (vcomponent* comp, const char* key) { + char* key_cpy = calloc(sizeof(*key_cpy), strlen(key) + 1); + strcpy (key_cpy, key); + content_line* cl = GET(TRIE(content_line))(&comp->clines, key_cpy); + free (key_cpy); + + if (cl != NULL && cl->cur->value != NULL) { + return cl->cur->value->key.mem; + } + + return NULL; +} diff --git a/src/vcal.h b/src/vcal.h new file mode 100644 index 00000000..1dfc5b17 --- /dev/null +++ b/src/vcal.h @@ -0,0 +1,118 @@ +#ifndef VCAL_H +#define VCAL_H + +#include + +#include + +#include "strbuf.h" + +#define TYPE strbuf +#include "linked_list.h" +// #include "trie.h" +#undef TYPE + +/* + * content_line: + * a mapping between a top level key, and everything it contains. + * content_set: + * A top level value, along with a list of kv pairs for all its + * possible parameters. + * param_set: + * A parameter key, along with a list of all its values. + */ + +#define param_set LLIST(strbuf) + +#define TYPE param_set +#include "trie.h" +#undef TYPE + +#define T strbuf + #define V TRIE(param_set) + #include "pair.h" + /* left := content | right := params */ + #define content_set PAIR(strbuf, TRIE(param_set)) + #undef V +#undef T + +#define TYPE content_set +#include "linked_list.h" +#undef TYPE + +#define content_line LLIST(content_set) + +/* + * Helper macros for accessing fields in + * content_line, content_set, and param_set + */ + +/* content_set */ +#define CLINE_CUR(c) ((c)->cur->value) + +/* strbuf */ +#define CLINE_CUR_VAL(c) (& CLINE_CUR(c)->key) + +/* TRIE(param_set) */ +#define CLINE_CUR_PARAMS(c) (& CLINE_CUR(c)->val) + +#define TYPE content_line +#include "trie.h" +#undef TYPE + +typedef struct s_vcomponent vcomponent; + +#define TYPE vcomponent +// #include "vector.h" +#include "linked_list.h" +#undef TYPE + +struct s_vcomponent { + char* type; + vcomponent* parent; + TRIE(content_line) clines; + LLIST(vcomponent) components; + + /* + * Holds a Guile representation of this object. Used to always + * return the same foreign (for guile) object for the same + * vcomponent. + */ + SCM scm; +}; + +#define FCHILD(v) FIRST_V(&(v)->components) + +INIT_F(vcomponent); +INIT_F(vcomponent, const char* type); +INIT_F(vcomponent, const char* type, const char* filename); +FREE_F(vcomponent); + +content_line* get_property (vcomponent* ev, const char* key); + +int add_content_line (vcomponent* ev, content_line* c); + +int vcomponent_push_val (vcomponent*, const char* key, const char* val); +char* vcomponent_get_val (vcomponent*, const char* key); + +/* + * Appends ev to cal. Doesn't copy ev. So make sure that it wont go + * out of scope. + */ +int PUSH(vcomponent)(vcomponent*, vcomponent*); + +/* + * Deep copy is currently not implemented for vcomponentes. + * The reason for this method being here is since some + * generic methods in other places complain otherwise. + */ +int DEEP_COPY(vcomponent)(vcomponent*, vcomponent*); + +/* + * "Shallow" copy of vcomponent. + */ +int vcomponent_copy(vcomponent*, vcomponent*); + +FMT_F(vcomponent); + +#endif /* VCAL_H */ diff --git a/srfi/srfi-19/setters.scm b/srfi/srfi-19/setters.scm deleted file mode 100644 index 45876382..00000000 --- a/srfi/srfi-19/setters.scm +++ /dev/null @@ -1,15 +0,0 @@ -(define-module (srfi srfi-19 setters) - #:use-module (srfi srfi-19) ; Date/Time - ;; (record-type-fields (@@ (srfi srfi-19) date)) - #:export (nanosecond second minute hour day month year zone-offset)) - - -(define nanosecond (make-procedure-with-setter date-nanosecond (@@ (srfi srfi-19) set-date-nanosecond!))) -(define second (make-procedure-with-setter date-second (@@ (srfi srfi-19) set-date-second!))) -(define minute (make-procedure-with-setter date-minute (@@ (srfi srfi-19) set-date-minute!))) -(define hour (make-procedure-with-setter date-hour (@@ (srfi srfi-19) set-date-hour!))) -(define day (make-procedure-with-setter date-day (@@ (srfi srfi-19) set-date-day!))) -(define month (make-procedure-with-setter date-month (@@ (srfi srfi-19) set-date-month!))) -(define year (make-procedure-with-setter date-year (@@ (srfi srfi-19) set-date-year!))) -(define zone-offset (make-procedure-with-setter date-zone-offset (@@ (srfi srfi-19) set-date-zone-offset!))) - diff --git a/srfi/srfi-19/util.scm b/srfi/srfi-19/util.scm deleted file mode 100644 index a4b704b0..00000000 --- a/srfi/srfi-19/util.scm +++ /dev/null @@ -1,83 +0,0 @@ -(define-module (srfi srfi-19 util) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-19 setters) - #:export (copy-date - drop-time! drop-time - in-day? today? - ;; seconds minutes hours days weeks - ;; time-add - make-duration - time->string - add-day remove-day)) - -#; -(define (copy-date date) - "Returns a copy of the given date structure" - (let* ((date-type (@@ (srfi srfi-19) date)) - (access (lambda (field) ((record-accessor date-type field) date)))) - (apply make-date (map access (record-type-fields date-type))))) - -(define (drop-time! date) - "Sets the hour, minute, second and nanosecond attribute of date to 0." - (set! (hour date) 0) - (set! (minute date) 0) - (set! (second date) 0) - (set! (nanosecond date) 0) - date) - -(define (drop-time date) - "Returns a copy of date; with the hour, minute, second and nanosecond -attribute set to 0. Can also be seen as \"Start of day\"" - (set-fields date - ((date-hour) 0) - ((date-minute) 0) - ((date-second) 0) - ((date-nanosecond) 0))) - -(define (make-duration s) - (make-time time-duration 0 s)) - -(define (in-day? day-date time) - (let* ((now (date->time-utc (drop-time day-date))) - (then (add-duration now (make-duration (* 60 60 24))))) - (and (time<=? now time) - (time<=? time then)))) - -(define (today? time) - (in-day? (current-date) time)) - -(define* (time->string time #:optional (format "~1 ~3")) - (date->string (time-utc->date time) format)) - - -(define (add-day time) - (add-duration time (make-time time-duration 0 (* 60 60 24)))) - -(define (remove-day time) - (add-duration time (make-time time-duration 0 (- (* 60 60 24))))) - -;; A B C D ¬E -;; |s1| : |s2| : |s1| : |s2| : |s1| -;; | | : | | : | ||s2| : |s1|| | : | | -;; | ||s2| : |s1|| | : | || | : | || | : -;; | | : | | : | || | : | || | : |s2| -;; | | : | | : | | : | | : | | -(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end) - "Return whetever or not two timespans overlap." - (or - ;; A - (and (time<=? s2-begin s1-end) - (time<=? s1-begin s2-end)) - - ;; B - (and (time<=? s1-begin s2-end) - (time<=? s2-begin s1-end)) - - ;; C - (and (time<=? s1-begin s2-begin) - (time<=? s2-end s1-end)) - - ;; D - (and (time<=? s2-begin s1-begin) - (time<=? s1-end s2-end)))) diff --git a/srfi/srfi-41/util.scm b/srfi/srfi-41/util.scm deleted file mode 100644 index 5bef95cb..00000000 --- a/srfi/srfi-41/util.scm +++ /dev/null @@ -1,29 +0,0 @@ -(define-module (srfi srfi-41 util) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-41) - #:use-module (util) ; let*, find-min - #:export (stream-car+cdr interleave-streams)) - -(define (stream-car+cdr stream) - (values (stream-car stream) - (stream-cdr stream))) - -;; Merges a number of totally ordered streams into a single -;; totally ordered stream. -;; ((≺, stream)) → (≺, stream) -(define (interleave-streams < streams) - ;; Drop all empty streams - (let ((streams (remove stream-null? streams))) - ;; If all streams where empty, end the output stream - (if (null? streams) - stream-null - (let* ((min other (find-min < stream-car streams)) - (m ms (stream-car+cdr min))) - (stream-cons m (interleave-streams < (cons ms other))))))) - -;;; Varför är allting så långsamt‽‽‽‽‽‽‽‽ - -(define-public (filter-sorted-stream proc stream) - (stream-take-while - proc (stream-drop-while - (negate proc) stream))) diff --git a/strbuf.c b/strbuf.c deleted file mode 100644 index 0e56468b..00000000 --- a/strbuf.c +++ /dev/null @@ -1,151 +0,0 @@ -#include "strbuf.h" - -#include -#include - -#include "err.h" - -INIT_F(strbuf) { - self->alloc = 0x10; - self->mem = (char*) calloc(sizeof(*self->mem), self->alloc); - self->ptr = 0; - self->len = 0; - self->scm = NULL; - return 0; -} - -int strbuf_realloc(strbuf* str, size_t len) { - str->mem = (char*) realloc(str->mem, len); - str->alloc = len; - return 0; -} - -FREE_F(strbuf) { - /* has already been freed */ - if (self->mem == NULL) return 1; - - free (self->mem); - self->mem = NULL; - self->alloc = 0; - self->len = 0; - return 0; -} - -/* - * Reallocates memmory for you. Returns 1 if memory was reallocated. - */ -int strbuf_append(strbuf* s, char c) { - int retval = 0; - - if (s->len + 1 > s->alloc) { - s->alloc <<= 1; - s->mem = (char*) realloc(s->mem, s->alloc); - retval = 1; - } - - s->mem[s->len] = c; - s->ptr = ++s->len; - return retval; -} - -char strbuf_pop(strbuf* s) { - char ret = s->mem[--s->len]; - s->mem[s->len + 1] = '\0'; - return ret; -} - -int strbuf_cap(strbuf* s) { - strbuf_append(s, 0); - --s->len; - return 0; -} - -int DEEP_COPY(strbuf)(strbuf* dest, strbuf* src) { - int retval = 0; - - if (dest->alloc < src->len) { - /* +1 in length is to have room for '\0'. */ - strbuf_realloc(dest, src->len + 1); - retval = 1; - } - - if (src->scm != NULL) { - /* The magic SCM type is copied when reassigned. */ - dest->scm = src->scm; - /* NOTE This is a bit of a leaky abstraction. */ - scm_gc_protect_object(dest->scm); - } - - dest->len = src->len; - memcpy(dest->mem, src->mem, src->len); - return retval; -} - -int strbuf_cmp(strbuf* a, strbuf* b) { - if (a == NULL || a->alloc == 0 || - b == NULL || b->alloc == 0) - { - ERR("a or b not alloced"); - // return -1; - } - - return strncmp(a->mem, b->mem, a->len); -} - -int strbuf_c(strbuf* a, const char* b) { - if (a == NULL || a->alloc == 0) { - ERR("a not allocated"); - return -1; - } - - return strcmp(a->mem, b) == 0; -} - -char* charat(strbuf* s, unsigned int idx) { - if (idx > s->len) { - ERR("Index out of bounds"); - return (char*) -1; - } - - return &s->mem[idx]; -} - -char* strbuf_cur(strbuf* s) { - return &s->mem[s->ptr]; -} - -char* strbuf_end(strbuf* s) { - return &s->mem[s->len]; -} - -int strbuf_reset(strbuf* s) { - s->ptr = 0; - return 0; -} - - -int strbuf_soft_reset(strbuf* s) { - s->ptr = s->len = 0; - return 0; -} - -strbuf* RESOLVE(strbuf)(strbuf* dest, strbuf* new_) { - if (dest == NULL) return new_; - else return dest; -} - -FMT_F(strbuf) { - return sprintf(buf, "%s", self->mem); -} - -int SIZE(strbuf)(strbuf* self) { - return self->len; -} - -int strbuf_load(strbuf* self, const char* str) { - for (int i = 0; str[i] != '\0'; i++) { - strbuf_append(self, str[i]); - } - strbuf_cap(self); - return 0; -} diff --git a/strbuf.h b/strbuf.h deleted file mode 100644 index 7f936a9e..00000000 --- a/strbuf.h +++ /dev/null @@ -1,109 +0,0 @@ -#ifndef STRBUF_H -#define STRBUF_H - -#include -#include -#include "macro.h" - -/* - * A high level string type which holds it's own length, how much - * memmory it has allocated for itself, and a seek pointer into the - * string. - * - * Also comes with a number of functions which allow for safe(er) - * access to the memmory. - */ -typedef struct { - char* mem; - SCM scm; - /* TODO add support for negative ptr */ - int ptr; - unsigned int alloc; - unsigned int len; -} strbuf; - -/* - * Init strbuf to size of 10 - */ -INIT_F(strbuf); - -/* - * Like realloc, but for strbuf - */ -int strbuf_realloc(strbuf* str, size_t len); - -/* - * Free's contents of str, but keeps str. - */ -FREE_F(strbuf); - -int strbuf_cmp(strbuf* a, strbuf* b); -int strbuf_c(strbuf* a, const char* b); - -/* - * Copy contents from src to dest. - * Assumes that dest is already initialized. - */ -int DEEP_COPY(strbuf)(strbuf*, strbuf*); - -/* - * Append char to end of strbuf, determined by s->len. - * - * TODO rename this PUSH(strbuf)? - */ -int strbuf_append(strbuf* s, char c); - -char strbuf_pop(strbuf*); - -/* - * Calls strbuf_append with NULL. - */ -int strbuf_cap(strbuf* s); - -/* - * Returns a pointer to character at index. Allows mutation of the - * value pointed to by the return address. - */ -char* charat(strbuf* s, unsigned int idx); - -/* - * Same as `charat`, But returns the current character. - */ -char* strbuf_cur(strbuf* s); - -/* - * Resets the seek for strbuf to 0. - */ -int strbuf_reset(strbuf* s); - -/* - * Sets the length and seek ptr to 0, but doesn't touch the memmory. - */ -int strbuf_soft_reset(strbuf* s); - -/* - * Returns the character after the last, so where null hopefully is. - */ -char* strbuf_end(strbuf* s); - -/* - * Reallocs dest to be the same size as src, and copies the contents - * of src into dest. - */ -int strbuf_realloc_copy(strbuf* dest, strbuf* src); - -/* - * Copies contents from src to dest, also allocating dest in the - * process. dest should not be initialized before self call. - */ -int strbuf_init_copy(strbuf* dest, strbuf* src); - -strbuf* RESOLVE(strbuf)(strbuf*, strbuf*); - -FMT_F(strbuf); - -int SIZE(strbuf)(strbuf*); - -int strbuf_load(strbuf* self, const char* str); - -#endif /* STRBUF_H */ diff --git a/terminal/escape.scm b/terminal/escape.scm deleted file mode 100644 index 8f1b0c2b..00000000 --- a/terminal/escape.scm +++ /dev/null @@ -1,28 +0,0 @@ -;;; Module for terminal (ANSI) escape codes. - -(define-module (terminal escape) - #:use-module (srfi srfi-60) - #:use-module (terminal termios) - #:export (with-vulgar)) - -(define-public (cls) - (display "\x1b[H") ; Move cursor to the origin - (display "\x1b[J") ; Clear everything after cursor - ) - -;;; I don't curse, I'm just vulgar. - -(define-syntax with-vulgar - (syntax-rules () - ((_ thunk) - (let ((ifd (fileno (current-input-port))) - (ofd (fileno (current-output-port)))) - (dynamic-wind - (lambda () - (let ((bits (bitwise-ior ECHO ICANON))) - (c-lflags-disable! ifd bits) - (c-lflags-disable! ofd bits))) - thunk - (lambda () - (c-lflag-restore! ifd) - (c-lflag-restore! ofd)))) ))) diff --git a/terminal/termios.scm b/terminal/termios.scm deleted file mode 100644 index b0ae585e..00000000 --- a/terminal/termios.scm +++ /dev/null @@ -1,11 +0,0 @@ -;;; Module for termios interaction from Guile, -;;; Since that for some reason isn't built in. - -(define-module (terminal termios) - #:export (c-lflags-disable! c-lflag-restore!)) - -(define-public ECHO #x0000010) -(define-public ICANON #x0000002) - -(setenv "LD_LIBRARY_PATH" (dirname (dirname (current-filename)))) -(load-extension "libtermios" "init_termios") diff --git a/terminal/util.scm b/terminal/util.scm deleted file mode 100644 index a7435ad8..00000000 --- a/terminal/util.scm +++ /dev/null @@ -1,37 +0,0 @@ -(define-module (terminal util) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-60) - #:export (line ctrl color-escape)) - -(define* (line #:optional (width 64)) - (display (make-string width #\_)) - (newline)) - -(define (ctrl char) - (integer->char (bitwise-and #b00011111 (char->integer char)))) - -(define-public (display-calendar-header! date) - (let* ((day (number->string (date-day date))) - (month (number->string (date-month date))) - (year (number->string (date-year date)))) - ;; BSD cal only supports setting highlighted day explicitly for - ;; testing the functionality. This seems to at least give me - ;; an (almost) working display, albeit ugly. - (if (file-exists? "/usr/bin/ncal") - (system* "ncal" "-3" "-H" (format #f "~a-~a-~a" - year month day) - month year) - (system* "cal" "-3" day month year)))) - -(define (color-escape n) - (cond ((not n) "") - ((char=? #\# (string-ref n 0)) - (let* ((str (string-drop n 1)) - (rs (substring str 0 2)) - (gs (substring str 2 4)) - (bs (substring str 4 6))) - (format #f "\x1b[38;2;~a;~a;~am" - (string->number rs 16) - (string->number gs 16) - (string->number bs 16)))))) - diff --git a/termios.scm.c b/termios.scm.c deleted file mode 100644 index 939c3574..00000000 --- a/termios.scm.c +++ /dev/null @@ -1,44 +0,0 @@ -#include -#include -#include -#include - -static struct termios *oldt, *newt; - -SCM_DEFINE(termios_lflags_and, "c-lflags-disable!", 2, 0, 0, - (SCM _fd, SCM _bits), - "") -{ - - int fd = scm_to_int (_fd); - int bits = scm_to_int (_bits); - - printf("Setting bits [%x]\n", bits); - - tcgetattr(fd, oldt); - *newt = *oldt; - - // Make the terminal not echo back, - // along with enabling cononical mode - newt->c_lflag &= ~ bits; - tcsetattr(fd, TCSANOW, newt); - return SCM_UNSPECIFIED; -} - -SCM_DEFINE(termios_restore, "c-lflag-restore!", 1, 0, 0, - (SCM _fd), - "") -{ - int fd = scm_to_int (_fd); - tcsetattr(fd, TCSANOW, oldt); - return SCM_UNSPECIFIED; -} - -void init_termios (void) { - oldt = scm_gc_malloc(sizeof(*oldt), "Termios"); - newt = scm_gc_malloc(sizeof(*newt), "Termios"); - -#ifndef SCM_MAGIC_SNARFER -#include "termios.x" -#endif -} diff --git a/test.scm b/test.scm deleted file mode 100755 index 1b3c539e..00000000 --- a/test.scm +++ /dev/null @@ -1,77 +0,0 @@ -#!/usr/bin/guile -s -!# - -(add-to-load-path (dirname (current-filename))) - -(use-modules (rnrs base) ; assert - (srfi srfi-1) - (srfi srfi-19) - (srfi srfi-19 util) - (srfi srfi-41) - (vcalendar) - (vcalendar output) - (vcalendar recur)) - -(define cal (make-vcomponent "testcal/repeating-event.ics")) - -(define ev (car (children cal 'VEVENT))) - -(define ev-copy (copy-vcomponent ev)) - -(assert (equal? (children ev) - (children ev-copy))) - -(define (display-timespan ev) - (format #t "~a ~a ~a -- ~a~%" - (attr ev 'NEW_ATTR) - (attr ev 'N) - (time->string (attr ev "DTSTART")) - (time->string (attr ev "DTEND")))) - -(display (attr ev 'N)) (newline) -(display-timespan ev) -(display (attr ev 'NEW_ATTR)) (newline) -(newline) -(define strm (generate-recurrence-set ev)) -(display (attr ev 'RRULE)) (newline) - -(if #f - (begin - (stream-for-each display-timespan (stream-take 20 strm)) - - (newline) - - ;; (define strm (generate-recurrence-set ev)) - (display (attr ev 'RRULE)) (newline) - - ;; This makes the amount of events lookad at before have the same DTSTART, - ;; which is the last from that set. The one's after that however are fine. - (stream-for-each display-timespan (stream-take 40 strm)) - (newline) - ;; This makes all the DTSTART be the last dtstart - ;; (for-each display-timespan (stream->list (stream-take 20 strm))) - -;;; I believe that I might have something to do with the stream's cache. - - (newline) - - (display-timespan ev) - (display (attr ev 'NEW_ATTR)) - (newline)) - (begin - ;; These two acts as one large unit. - ;; Something modifies the initial ev even though it shouldn't - (display-timespan ev) - (stream-for-each - display-timespan - (stream-take 20 (generate-recurrence-set (copy-vcomponent ev)))) - (newline) - (display-timespan ev) - (newline) - (stream-for-each - display-timespan - (stream-take 40 (generate-recurrence-set (copy-vcomponent ev)))) - (newline) - (display-timespan ev) - )) - diff --git a/trie.h b/trie.h deleted file mode 100644 index 9de38be3..00000000 --- a/trie.h +++ /dev/null @@ -1,54 +0,0 @@ -#ifndef TRIE_H -#define TRIE_H - -#include - -#include "macro.h" - -#define TRIE(T) TEMPL(trie, T) -#define TRIE_NODE(T) TEMPL(trie_node, T) - -#endif /* TRIE_H */ -#ifdef TYPE - -#include "linked_list.h" -#include "strbuf.h" - -typedef struct TRIE_NODE(TYPE) { - char c; - TYPE* value; - struct TRIE_NODE(TYPE)* next; - struct TRIE_NODE(TYPE)* child; -} TRIE_NODE(TYPE); - -typedef struct { - TRIE_NODE(TYPE)* root; -} TRIE(TYPE); - - -INIT_F ( TRIE(TYPE) ); - -INIT_F (TRIE_NODE(TYPE), char c); - -INIT_F (TRIE_NODE(TYPE), - char c, TRIE_NODE(TYPE)* next, TRIE_NODE(TYPE)* child ); - -int PUSH(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key, TYPE* val ); - -TYPE* GET(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key ); - -FREE_F(TRIE_NODE(TYPE)); - -FREE_F(TRIE(TYPE)); - -int EMPTY(TRIE(TYPE))(TRIE(TYPE)*); - -FMT_F(TRIE_NODE(TYPE)); -FMT_F(TRIE(TYPE)); - -int DEEP_COPY(TRIE_NODE(TYPE)) (TRIE_NODE(TYPE)* dest, TRIE_NODE(TYPE)* src); -int DEEP_COPY(TRIE(TYPE)) (TRIE(TYPE)* dest, TRIE(TYPE)* src); - -LLIST(strbuf)* KEYS(TRIE(TYPE)) (TRIE(TYPE)*); - -#endif /* TYPE */ diff --git a/trie.inc.h b/trie.inc.h deleted file mode 100644 index ffc8ac8e..00000000 --- a/trie.inc.h +++ /dev/null @@ -1,228 +0,0 @@ -#ifndef TYPE -#error "Set TYPE before including self file" -#else - -#include - -#include "err.h" -#include "macro.h" -#include "linked_list.inc.h" -#include "strbuf.h" - -INIT_F ( TRIE(TYPE) ) { - NEW(TRIE_NODE(TYPE), t, '\0'); - self->root = t; - return 0; -} - -INIT_F (TRIE_NODE(TYPE), char c) { - self->c = c; - self->value = NULL; - self->next = NULL; - self->child = NULL; - return 0; -} - -INIT_F (TRIE_NODE(TYPE), - char c, - TRIE_NODE(TYPE)* next, - TRIE_NODE(TYPE)* child ) -{ - self->c = c; - self->next = next; - self->child = child; - return 0; -} - -int PUSH(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key, TYPE* val ) { - TRIE_NODE(TYPE) *cur, *last; - - last = trie->root; - cur = last->child; - - char* subkey = key; - - while (1) { - if (cur == NULL) { - /* Build direct LL for remaining subkey */ - for (char* c = subkey; c[0] != '\0'; c++) { - NEW(TRIE_NODE(TYPE), t, *c); - last->child = t; - last = t; - } - last->value = RESOLVE(TYPE)(last->value, val); - return 0; - } else if (cur->c == subkey[0]) { - /* This node belongs to the key, - * Decend further */ - last = cur; - cur = cur->child; - subkey++; - } else if (subkey[0] == '\0') { - /* Key finished */ - last->value = RESOLVE(TYPE)(last->value, val); - return 0; - } else if (cur->next != NULL) { - /* This node was not part of the set, but it's sibling might */ - cur = cur->next; - /* `last` not set since we aren't moving down */ - } else { - /* No node on self level was part of the set, create a new__ - * sibling and follow down that parse */ - NEW(TRIE_NODE(TYPE), t, *subkey); - cur->next = t; - last = cur; - cur = t; - } - } - - return 0; -} - -/* - * TODO what happens when I give an invalid key? - */ -TYPE* GET(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key ) { - TRIE_NODE(TYPE)* n = trie->root->child; - char* subkey = key; - - while (n != NULL) { - if (subkey[1] == '\0') { - /* Wanted node found, - * value can however be NULL */ - return n->value; - } else if (subkey[0] == n->c) { - n = n->child; - subkey++; - } else { - n = n->next; - } - } - - /* Position not found */ - return 0; -} - -FREE_F(TRIE_NODE(TYPE)) { - if (self == NULL) return 0; - if (self->value != NULL) FFREE(TYPE, self->value); - if (self->next != NULL) FREE(TRIE_NODE(TYPE))(self->next); - if (self->child != NULL) FREE(TRIE_NODE(TYPE))(self->child); - free (self); - return 0; -} - -FREE_F(TRIE(TYPE)) { - if (self->root->c != '\0') { - // ERR("Invalid trie"); - return 1; - } - return FREE(TRIE_NODE(TYPE))(self->root); -} - -int EMPTY(TRIE(TYPE))(TRIE(TYPE)* self) { - return self->root->child == NULL; -} - -FMT_F(TRIE_NODE(TYPE)) { - - va_list ap; - va_start(ap, buf); - int argc = va_arg(ap, int); - int depth = argc >= 1 - ? va_arg(ap, int) - : 0; - va_end(ap); - - int seek = 0; - - TRIE_NODE(TYPE)* n = self; - - if (n == NULL) { fmtf("\n"); } - while (n != NULL) { - fmtf("|"); - // FOR(int, i, depth) fmtf(" "); - for (int i = 0; i < depth; i++) fmtf(" "); - fmtf("%c ", n->c == '\0' ? '0' : n->c); - if (n->value != NULL) { - seek += FMT(TYPE)(n->value, buf + seek); - fmtf("\n"); - } - - if (n->child != NULL) { - fmtf("\n"); - seek += FMT(TRIE_NODE(TYPE))(n->child, buf + seek, depth + 1); - } - n = n->next; - } - return seek; - -} - -FMT_F(TRIE(TYPE)) { - int seek = 0; - fmtf("Trie: %p: {", self); - if (EMPTY(TRIE(TYPE))(self)) { - fmtf(" [EMPTY] "); - } else { - fmtf("\n"); - seek += FMT(TRIE_NODE(TYPE))(self->root->child, buf + seek); - } - fmtf("}"); - return seek; -} - -int DEEP_COPY(TRIE_NODE(TYPE)) (TRIE_NODE(TYPE)* dest, TRIE_NODE(TYPE)* src) { - dest->c = src->c; - - if (src->value != NULL) { - RENEW(TYPE, dest->value); - DEEP_COPY(TYPE)(dest->value, src->value); - } - - if (src->next != NULL) { - RENEW(TRIE_NODE(TYPE), dest->next, '\0'); - DEEP_COPY(TRIE_NODE(TYPE))(dest->next, src->next); - } - - if (src->child != NULL) { - RENEW(TRIE_NODE(TYPE), dest->child, '\0'); - DEEP_COPY(TRIE_NODE(TYPE))(dest->child, src->child); - } - - return 0; -} - -int DEEP_COPY(TRIE(TYPE)) (TRIE(TYPE)* dest, TRIE(TYPE)* src) { - return DEEP_COPY(TRIE_NODE(TYPE))(dest->root, src->root); -} - -void KEYS(TRIE_NODE(TYPE)) (TRIE_NODE(TYPE)* node, LLIST(strbuf)* list, strbuf* path) { - if (node == NULL) return; - - - if (node->value != NULL) { - strbuf_append(path, node->c); - NEW(strbuf, c); - DEEP_COPY(strbuf)(c, path); - PUSH(LLIST(strbuf))(list, c); - strbuf_pop(path); - } - if (node->next != NULL) { - KEYS(TRIE_NODE(TYPE)) (node->next, list, path); - } - if (node->child != NULL) { - if (node->c != '\0') strbuf_append(path, node->c); - KEYS(TRIE_NODE(TYPE)) (node->child, list, path); - if (node->c != '\0') strbuf_pop(path); - } -} - -LLIST(strbuf)* KEYS(TRIE(TYPE)) (TRIE(TYPE)* trie) { - NEW(LLIST(strbuf), retlist); - SNEW(strbuf, key); - KEYS(TRIE_NODE(TYPE)) (trie->root, retlist, &key); - return retlist; -} - -#endif /* TYPE */ diff --git a/util.scm b/util.scm deleted file mode 100644 index 6f1b955a..00000000 --- a/util.scm +++ /dev/null @@ -1,168 +0,0 @@ -(define-module (util) - #:use-module (srfi srfi-1) - #:use-module ((sxml fold) #:select (fold-values)) - #:export (destructure-lambda let-multi fold-lists catch-let - for-each-in - define-quick-record define-quick-record! - mod! sort* sort*! - find-min) - #:replace (let*) - ) - -(define-public upstring->symbol (compose string->symbol string-upcase)) - -(define-public symbol-upcase (compose string->symbol string-upcase symbol->string)) - -(define-public symbol-downcase (compose string->symbol string-downcase symbol->string)) - -(define-syntax destructure-lambda - (syntax-rules () - ((_ expr-list body ...) - (lambda (expr) - (apply (lambda expr-list body ...) expr))))) - -(define-syntax catch-let - (syntax-rules () - ((_ thunk ((type handler) ...)) - (catch #t thunk - (lambda (err . args) - (case err - ((type) (apply handler err args)) ... - (else (format #t "Unhandled error type ~a, rethrowing ~%" err) - (apply throw err args)))))))) - -;;; For-each with arguments in reverse order. -(define-syntax-rule (for-each-in lst proc) - (for-each proc lst)) - - -;;; Helper macros to make define-quick-record better - -(define (class-name symb) (symbol-append '< symb '>)) -(define (constructor symb) (symbol-append 'make- symb)) -(define (pred symb) (symbol-append symb '?)) - -(define (getter name symb) (symbol-append 'get- name '- symb)) -(define* (setter name symb #:optional bang?) - (symbol-append 'set- name '- symb (if bang? '! (symbol)))) - -(define (%define-quick-record internal-define bang? name fields) - (let ((symb (gensym))) - `((,internal-define ,(class-name name) - (,(constructor name) ,@fields) - ,(pred name) - ,@(map (lambda (f) `(,f ,(getter f symb) ,(setter f symb bang?))) - fields)) - ,@(map (lambda (f) `(define ,f (make-procedure-with-setter - ,(getter f symb) ,(setter f symb bang?)))) - fields)))) - -;;; Creates srfi-9 define{-immutable,}-record-type declations. -;;; Also creates srfi-17 accessor ((set! (access field) value)) - -;; (define (define-quick-record-templated define-proc name field)) - -(define-macro (define-quick-record name . fields) - (let ((public-fields (or (assoc-ref fields #:public) '())) - (private-fields (or (assoc-ref fields #:private) '()))) - `(begin - ,@(%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type) - #f name - (append public-fields private-fields)) - ,@(map (lambda (field) `(export ,field)) - public-fields)))) - ;; (define-quick-record-templated 'define-immutable-record-type name fields)) - -;; (define-macro (define-quick-record! name . fields) -;; (define-quick-record-templated 'define-record-type name fields)) - -;; Replace let* with a version that can bind from lists. -;; Also supports SRFI-71 (extended let-syntax for multiple values) -;; @lisp -;; (let* ([a b (values 1 2)] ; @r{SRFI-71} -;; [(c d) '(3 4)] ; @r{Let-list (mine)} -;; [e 5]) ; @r{Regular} -;; (list e d c b a)) -;; ;; => (5 4 3 2 1) -;; @end lisp -(define-syntax let* - (syntax-rules () - - ;; Base case - [(_ () body ...) - (begin body ...)] - - ;; (let (((a b) '(1 2))) (list b a)) => (2 1) - [(_ (((k k* ...) list-value) rest ...) - body ...) - (apply (lambda (k k* ...) - (let* (rest ...) - body ...)) - list-value)] - - ;; "Regular" case - [(_ ((k value) rest ...) body ...) - (let ((k value)) - (let* (rest ...) - body ...))] - - ;; SRFI-71 let-values - [(_ ((k k* ... values) rest ...) body ...) - (call-with-values (lambda () values) - (lambda (k k* ...) - (let* (rest ...) - body ...)))] - - )) - -;; Like set!, but applies a transformer on the already present value. -(define-syntax-rule (mod! field transform-proc) - (set! field (transform-proc field))) - -(define-public (concat lists) - (apply append lists)) - -;; This function borrowed from web-ics (calendar util) -(define* (sort* items comperator #:optional (get identity)) - "A sort function more in line with how python's sorted works" - (sort items (lambda (a b) - (comperator (get a) - (get b))))) - -;;; This function borrowed from web-ics (calendar util) -(define* (sort*! items comperator #:optional (get identity)) - "A sort function more in line with how python's sorted works" - (sort! items (lambda (a b) - (comperator (get a) - (get b))))) - -;; Finds the smallest element in @var{items}, compared with @var{<} after -;; applying @var{foo}. Returns 2 values. The smallest item in @var{items}, -;; and the other items in some order. -(define (find-min < ac items) - (if (null? items) - ;; Vad fan retunerar man här? - (values #f '()) - (fold-values - (lambda (c min other) - (if (< (ac c) (ac min)) - ;; Current stream head is smaller that previous min - (values c (cons min other)) - ;; Previous min is still smallest - (values min (cons c other)))) - (cdr items) - ;; seeds: - (car items) '()))) - -(define-public (filter-sorted proc list) - (take-while - proc (drop-while - (negate proc) list))) - -;; (define (!= a b) (not (= a b))) -(define-public != (negate =)) - -(define-public (take-to lst i) - "Like @var{take}, but might lists shorter than length." - (if (> i (length lst)) - lst (take lst i))) diff --git a/vcal.c b/vcal.c deleted file mode 100644 index 305275e7..00000000 --- a/vcal.c +++ /dev/null @@ -1,152 +0,0 @@ -#include "vcal.h" - -#include - -#define TYPE strbuf -#include "linked_list.inc.h" -#undef TYPE - -#define TYPE param_set -#include "trie.inc.h" -#undef TYPE - -#define TYPE content_set -#include "linked_list.inc.h" -#undef TYPE - -#define T strbuf - #define V TRIE(param_set) - #include "pair.inc.h" - #undef V -#undef T - -#define TYPE content_line -// #include "hash.inc" -#include "trie.inc.h" -#undef TYPE - -#define TYPE vcomponent -// #include "vector.inc.h" -#include "linked_list.inc.h" -#undef TYPE - -INIT_F(vcomponent) { - (void) self; - ERR("Do not use"); - return 0; -} - -INIT_F(vcomponent, const char* type) { - return INIT(vcomponent, self, type, NULL); -} - -INIT_F(vcomponent, const char* type, const char* filename) { - - INIT(TRIE(content_line), &self->clines); - INIT(LLIST(vcomponent), &self->components); - - if (filename != NULL) { - vcomponent_push_val (self, "X-HNH-FILENAME", filename); - } - - self->type = (char*) calloc(sizeof(*type), strlen(type) + 1); - strcpy(self->type, type); - - self->parent = NULL; - self->scm = NULL; - - return 0; -} - -content_line* get_property (vcomponent* ev, const char* key) { - size_t len = strlen(key) + 1; - char* cpy = (char*) (calloc(sizeof(*cpy), len)); - strncpy (cpy, key, len); - - content_line* ret = GET(TRIE(content_line))(&ev->clines, cpy); - - free (cpy); - return ret; -} - -FREE_F(vcomponent) { - free(self->type); - - if (FREE(TRIE(content_line))(&self->clines) != 0) { - ERR("Error freeing vcomponent"); - } - - FREE(LLIST(vcomponent))(&self->components); - - return 0; -} - -int PUSH(vcomponent)(vcomponent* parent, vcomponent* child) { - child->parent = parent; - return PUSH(LLIST(vcomponent))(&parent->components, child); -} - -int DEEP_COPY(vcomponent)(vcomponent* a, vcomponent* b) { - (void) a; - (void) b; - ERR("Deep copy not implemented for vcomponent"); - return -1; -} - -int vcomponent_copy(vcomponent* dest, vcomponent* src) { - - DEEP_COPY(TRIE(content_line))(&dest->clines, &src->clines); - - /* Children are the same objects */ - FOR(LLIST, vcomponent, c, &src->components) { - PUSH(LLIST(vcomponent))(&dest->components, c); - } - - PUSH(vcomponent)(src->parent, dest); - - return 0; -} - -FMT_F(vcomponent) { - int seek = 0; - - for (int i = 0; i < 40; i++) fmtf("_"); - - seek += sprintf(buf + seek, _YELLOW); - seek += sprintf(buf + seek, "\nVComponet (Type := %s)\n", self->type); - seek += sprintf(buf + seek, _RESET); - seek += FMT(TRIE(content_line))(&self->clines, buf + seek); - seek += sprintf(buf + seek, "\nComponents:\n"); - FOR(LLIST, vcomponent, comp, &self->components) { - seek += FMT(vcomponent)(comp, buf + seek); - } - - return seek; -} - -int vcomponent_push_val (vcomponent* comp, const char* key, const char* val) { - NEW(content_line, cl); - NEW(content_set, cs); - strbuf_load(&cs->key, val); - PUSH(content_line)(cl, cs); - - char* key_cpy = calloc(sizeof(*key_cpy), strlen(key) + 1); - strcpy (key_cpy, key); - PUSH(TRIE(content_line))(&comp->clines, key_cpy, cl); - free (key_cpy); - - return 0; -} - -char* vcomponent_get_val (vcomponent* comp, const char* key) { - char* key_cpy = calloc(sizeof(*key_cpy), strlen(key) + 1); - strcpy (key_cpy, key); - content_line* cl = GET(TRIE(content_line))(&comp->clines, key_cpy); - free (key_cpy); - - if (cl != NULL && cl->cur->value != NULL) { - return cl->cur->value->key.mem; - } - - return NULL; -} diff --git a/vcal.h b/vcal.h deleted file mode 100644 index 1dfc5b17..00000000 --- a/vcal.h +++ /dev/null @@ -1,118 +0,0 @@ -#ifndef VCAL_H -#define VCAL_H - -#include - -#include - -#include "strbuf.h" - -#define TYPE strbuf -#include "linked_list.h" -// #include "trie.h" -#undef TYPE - -/* - * content_line: - * a mapping between a top level key, and everything it contains. - * content_set: - * A top level value, along with a list of kv pairs for all its - * possible parameters. - * param_set: - * A parameter key, along with a list of all its values. - */ - -#define param_set LLIST(strbuf) - -#define TYPE param_set -#include "trie.h" -#undef TYPE - -#define T strbuf - #define V TRIE(param_set) - #include "pair.h" - /* left := content | right := params */ - #define content_set PAIR(strbuf, TRIE(param_set)) - #undef V -#undef T - -#define TYPE content_set -#include "linked_list.h" -#undef TYPE - -#define content_line LLIST(content_set) - -/* - * Helper macros for accessing fields in - * content_line, content_set, and param_set - */ - -/* content_set */ -#define CLINE_CUR(c) ((c)->cur->value) - -/* strbuf */ -#define CLINE_CUR_VAL(c) (& CLINE_CUR(c)->key) - -/* TRIE(param_set) */ -#define CLINE_CUR_PARAMS(c) (& CLINE_CUR(c)->val) - -#define TYPE content_line -#include "trie.h" -#undef TYPE - -typedef struct s_vcomponent vcomponent; - -#define TYPE vcomponent -// #include "vector.h" -#include "linked_list.h" -#undef TYPE - -struct s_vcomponent { - char* type; - vcomponent* parent; - TRIE(content_line) clines; - LLIST(vcomponent) components; - - /* - * Holds a Guile representation of this object. Used to always - * return the same foreign (for guile) object for the same - * vcomponent. - */ - SCM scm; -}; - -#define FCHILD(v) FIRST_V(&(v)->components) - -INIT_F(vcomponent); -INIT_F(vcomponent, const char* type); -INIT_F(vcomponent, const char* type, const char* filename); -FREE_F(vcomponent); - -content_line* get_property (vcomponent* ev, const char* key); - -int add_content_line (vcomponent* ev, content_line* c); - -int vcomponent_push_val (vcomponent*, const char* key, const char* val); -char* vcomponent_get_val (vcomponent*, const char* key); - -/* - * Appends ev to cal. Doesn't copy ev. So make sure that it wont go - * out of scope. - */ -int PUSH(vcomponent)(vcomponent*, vcomponent*); - -/* - * Deep copy is currently not implemented for vcomponentes. - * The reason for this method being here is since some - * generic methods in other places complain otherwise. - */ -int DEEP_COPY(vcomponent)(vcomponent*, vcomponent*); - -/* - * "Shallow" copy of vcomponent. - */ -int vcomponent_copy(vcomponent*, vcomponent*); - -FMT_F(vcomponent); - -#endif /* VCAL_H */ diff --git a/vcalendar.scm b/vcalendar.scm deleted file mode 100644 index 3f7ba6ba..00000000 --- a/vcalendar.scm +++ /dev/null @@ -1,112 +0,0 @@ -(define-module (vcalendar) - #:use-module (vcalendar primitive) - #:use-module (vcalendar datetime) - #:use-module (vcalendar recur) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (util) - #:re-export (repeating?)) - -(define (parse-dates! cal) - "Parse all start times into scheme date objects." - (for-each-in (children cal 'VEVENT) - (lambda (ev) - (mod! (attr ev "DTSTART") parse-datetime) - (mod! (attr ev "DTEND") parse-datetime))) - cal) - - -(define-public (type-filter t lst) - (filter (lambda (e) (eqv? t (type e))) - lst)) - -(define* (children component #:optional only-type) - (let ((childs (%vcomponent-children component))) - (if only-type - (type-filter only-type childs) - childs))) -(export children) - -(define (set-attr! component attr value) - (%vcomponent-set-attribute! - component - (if (symbol? attr) (symbol->string attr) attr) - value)) - -(define (get-attr component attr) - (%vcomponent-get-attribute - component - (if (symbol? attr) (symbol->string attr) attr))) - -;; Enables symmetric get and set: -;; (set! (attr ev "KEY") 10) -(define-public attr (make-procedure-with-setter get-attr set-attr!)) - -(define-public type %vcomponent-type) -(define-public parent %vcomponent-parent) -(define-public push-child! %vcomponent-push-child!) -(define-public (attributes component) (map string->symbol (%vcomponent-attribute-list component))) - -(define-public copy-vcomponent %vcomponent-shallow-copy) - -(define-public filter-children! %vcomponent-filter-children!) - -(define-public (search cal term) - (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev))) - (children cal)))) - (find (lambda (ev) (string-contains-ci (car ev) term)) - (map cons (map (cut get-attr <> "SUMMARY") - events) - events))))) - -(define-public (extract field) - (cut get-attr <> field)) - -(define-public (key=? k1 k2) - (eq? - (if (string? k1) (string->symbol k1) k1) - (if (string? k2) (string->symbol k2) k2))) - -(define-public (make-vcomponent path) - (let* ((root (%vcomponent-make path)) - (component - (parse-dates! - (case (string->symbol (or (attr root "TYPE") "no-type")) - ;; == Single ICS file == - ;; Remove the abstract ROOT component, - ;; returning the wanted VCALENDAR component - ((file) - (car (%vcomponent-children root))) - - ;; == Assume vdir == - ;; Also removes the abstract ROOT component, but also - ;; merges all VCALENDAR's children into the first - ;; VCALENDAR, and return that VCALENDAR. - ;; - ;; TODO the other VCALENDAR components might not get thrown away, - ;; this since I protect them from the GC in the C code. - ((vdir) - (reduce (lambda (cal accum) - (for-each (lambda (component) - (case (type component) - ((VTIMEZONE) - (let ((zones (children cal 'VTIMEZONE))) - (unless (find (lambda (z) - (string=? (attr z "TZID") - (attr component "TZID"))) - zones) - (%vcomponent-push-child! accum component)))) - (else (%vcomponent-push-child! accum component)))) - (%vcomponent-children cal)) - accum) - '() (%vcomponent-children root))) - - ((no-type) (throw 'no-type)) - - (else (throw 'something)))))) - - (set! (attr component "NAME") - (attr root "NAME")) - (set! (attr component "COLOR") - (attr root "COLOR")) - component)) diff --git a/vcalendar/control.scm b/vcalendar/control.scm deleted file mode 100644 index a38d678f..00000000 --- a/vcalendar/control.scm +++ /dev/null @@ -1,39 +0,0 @@ -(define-module (vcalendar control) - #:use-module (util) - #:use-module (vcalendar) - #:export (with-replaced-attrs)) - - -(eval-when (expand load) ; No idea why I must have load here. - (define href (make-procedure-with-setter hashq-ref hashq-set!)) - - (define (set-temp-values! table component kvs) - (for-each (lambda (kv) - (let* (((key val) kv)) - (when (attr component key) - (set! (href table key) (attr component key)) - (set! (attr component key) val)))) - kvs)) - - (define (restore-values! table component keys) - (for-each (lambda (key) - (and=> (href table key) - (lambda (val) - (set! (attr component key) val)))) - keys))) - -;;; TODO with-added-attributes - -(define-syntax with-replaced-attrs - (syntax-rules () - [(_ (component (key val) ...) - body ...) - - (let ((htable (make-hash-table 10))) - (dynamic-wind - (lambda () (set-temp-values! htable component (quote ((key val) ...)))) ; In guard - (lambda () body ...) - (lambda () (restore-values! htable component (quote (key ...))))))])) ; Out guard - -;;; TODO test that restore works, at all -;;; Test that non-local exit and return works diff --git a/vcalendar/datetime.scm b/vcalendar/datetime.scm deleted file mode 100644 index 360b8348..00000000 --- a/vcalendar/datetime.scm +++ /dev/null @@ -1,34 +0,0 @@ -(define-module (vcalendar datetime) - #:use-module (vcalendar) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-19 util) - - #:export (parse-datetime - event-overlaps? - event-in?) - ) - -(define (parse-datetime dtime) - "Parse the given date[time] string into a date object." - ;; localize-date - (date->time-utc - (string->date - dtime - (case (string-length dtime) - ((8) "~Y~m~d") - ((15) "~Y~m~dT~H~M~S") - ((16) "~Y~m~dT~H~M~S~z"))))) - -(define (event-overlaps? event begin end) - "Returns if the event overlaps the timespan. -Event must have the DTSTART and DTEND attribute set." - (timespan-overlaps? (attr event 'DTSTART) - (attr event 'DTEND) - begin end)) - -(define (event-in? ev time) - "Does event overlap the date that contains time." - (let* ((date (time-utc->date time)) - (start (date->time-utc (drop-time date))) - (end (add-duration start (make-duration (* 60 60 24))))) - (event-overlaps? ev start end))) diff --git a/vcalendar/output.scm b/vcalendar/output.scm deleted file mode 100644 index e4635beb..00000000 --- a/vcalendar/output.scm +++ /dev/null @@ -1,93 +0,0 @@ -(define-module (vcalendar output) - #:use-module (vcalendar) - #:use-module (vcalendar control) - #:use-module (util) - #:use-module (srfi srfi-19 util) - #:use-module (srfi srfi-26) - #:export (print-vcomponent - serialize-vcomponent - color-if - STR-YELLOW STR-RESET)) - -(define STR-YELLOW "\x1b[0;33m") -(define STR-RESET "\x1b[m") - -(define-syntax-rule (color-if pred color body ...) - (let ((pred-value pred)) - (format #f "~a~a~a" - (if pred-value color "") - (begin body ...) - (if pred-value STR-RESET "")))) - -(define* (print-vcomponent comp #:optional (depth 0)) - (let ((kvs (map (lambda (key) (cons key (attr comp key))) - (attributes comp)))) - (format #t "~a <~a> :: ~:a~%" - (make-string depth #\:) - (type comp) comp) - (for-each-in kvs - (lambda (kv) - (let ((key (car kv)) - (value (cdr kv))) - (format #t "~a ~20@a: ~a~%" - (make-string depth #\:) - key value)))) - (for-each-in (children comp) - (cut print-vcomponent <> (1+ depth))))) - - - -;;; TODO -;; Error in CREATED /home/hugo/.calendars/b85ba2e9-18aa-4451-91bb-b52da930e977/a1a25238-d63d-46a1-87fd-d0c9334a7a30CalSync.ics: -;; Wrong type argument in position 1 (expecting string): ("20180118T124015Z" "VALARM") - -(define (string->ics-safe-string str) - "TODO wrap at 75(?) columns." - (define (escape char) - (string #\\ char)) - - (string-concatenate - (map (lambda (c) - (case c - ((#\newline) "\\n") - ((#\, #\; #\\) => escape) - (else => string))) - (string->list str)))) - -;;; TODO parameters ( ;KEY=val: ) -(define* (serialize-vcomponent comp #:optional (port (current-output-port))) - "Recursively write a component back to its ICS form. -Removes the X-HNH-FILENAME attribute, and sets PRODID to -\"HugoNikanor-calparse\" in the output." - (with-replaced-attrs - (comp (prodid "HugoNikanor-calparse")) - - (format port "BEGIN:~a~%" (type comp)) - (let ((kvs (map (lambda (key) (list key (attr comp key))) - (filter (negate (cut key=? <> 'X-HNH-FILENAME)) - (attributes comp))))) - (for-each-in - kvs (lambda (kv) - (let* (((key value) kv)) - (catch 'wrong-type-arg - (lambda () - (format port "~a:~a~%" key - (string->ics-safe-string - (case key - ((DTSTART DTEND) - (if (string? value) - value - (time->string value "~Y~m~dT~H~M~S"))) - - ((RRULE DURATION) "Just forget it") - - (else value))))) - - ;; Catch - (lambda (type proc fmt . args) - (apply format (current-error-port) "[ERR] ~a in ~a (~a) ~a:~%~?~%" - type key proc (attr comp 'X-HNH-FILENAME) - fmt args)))))) - - (for-each (cut serialize-vcomponent <> port) (children comp))) - (format port "END:~a~%" (type comp)))) diff --git a/vcalendar/primitive.scm b/vcalendar/primitive.scm deleted file mode 100644 index fdce550c..00000000 --- a/vcalendar/primitive.scm +++ /dev/null @@ -1,21 +0,0 @@ -;;; Primitive export of symbols linked from C binary. - -(define-module (vcalendar primitive) - #:export (%vcomponent-children - %vcomponent-push-child! - %vcomponent-filter-children! - - %vcomponent-parent - - %vcomponent-make - %vcomponent-type - - %vcomponent-set-attribute! - %vcomponent-get-attribute - - %vcomponent-attribute-list - - %vcomponent-shallow-copy)) - -(setenv "LD_LIBRARY_PATH" (dirname (dirname (current-filename)))) -(load-extension "libguile-calendar" "init_lib") diff --git a/vcalendar/recur.scm b/vcalendar/recur.scm deleted file mode 100644 index 3657cae6..00000000 --- a/vcalendar/recur.scm +++ /dev/null @@ -1,12 +0,0 @@ -(define-module (vcalendar recur) - #:use-module (vcalendar) - #:use-module (vcalendar recurrence generate) - #:re-export (generate-recurrence-set) - #:export (repeating?)) - -;; EXDATE is also a property linked to recurense rules -;; but that property alone don't create a recuring event. -(define (repeating? ev) - "Does this event repeat?" - (or (attr ev 'RRULE) - (attr ev 'RDATE))) diff --git a/vcalendar/recurrence/generate.scm b/vcalendar/recurrence/generate.scm deleted file mode 100644 index fae404ec..00000000 --- a/vcalendar/recurrence/generate.scm +++ /dev/null @@ -1,126 +0,0 @@ -(define-module (vcalendar recurrence generate) - ;; #:use-module (srfi srfi-1) - ;; #:use-module (srfi srfi-9 gnu) ; Records - #:use-module (srfi srfi-19) ; Datetime - #:use-module (srfi srfi-19 util) - - #:use-module (srfi srfi-26) ; Cut - #:use-module (srfi srfi-41) ; Streams - ;; #:use-module (ice-9 control) ; call-with-escape-continuation - #:use-module (ice-9 match) - #:use-module (vcalendar) - #:use-module (vcalendar datetime) - #:use-module (util) - - #:use-module (vcalendar recurrence internal) - #:use-module (vcalendar recurrence parse) - - #:export (generate-recurrence-set) - ) - -;;; TODO implement -;;; EXDATE and RDATE - -;;; EXDATE (3.8.5.1) -;;; comma sepparated list of dates or datetimes. -;;; Can have TZID parameter -;;; Specifies list of dates that the event should not happen on, even -;;; if the RRULE say so. -;;; Can have VALUE field specifiying "DATE-TIME" or "DATE". - -;;; RDATE (3.8.5.2) -;;; Comma sepparated list of dates the event should happen on. -;;; Can have TZID parameter. -;;; Can have VALUE parameter, specyfying "DATE-TIME", "DATE" or "PREIOD". -;;; PERIOD (see 3.3.9) - -(define (seconds-in freq) - (case freq - ((SECONDLY) 1) - ((MINUTELY) 60) - ((HOURLY) (* 60 60)) - ((DAILY) (* 60 60 24)) - ((WEEKLY) (* 60 60 24 7)))) - - -;; BYDAY and the like depend on the freq? -;; Line 7100 -;; Table @@ 2430 -;; -;; Event x Rule → Bool (continue?) -;; Alternative, monadic solution using . -;; @example -;; (optional->bool -;; (do (<$> (cut time<=? (attr last 'DTSTART)) (until r)) -;; (<$> (negate zero?) (count r)) -;; (just #t))) -;; @end example -(define-stream (recur-event-stream event rule-obj) - (stream-unfold - - ;; Event x Rule → Event - (match-lambda - ((last r) - (let ((e (copy-vcomponent last))) ; new event - (cond - - ((memv (freq r) '(SECONDLY MINUTELY HOURLY DAILY WEEKLY)) - (mod! (attr e 'DTSTART) ; MUTATE - (cut add-duration! <> - (make-duration - (* (interval r) ; INTERVAL - (seconds-in (freq r))))))) - - ((memv (freq r) '(MONTHLY YEARLY)) - #f ; Hur fasen beräkrnar man det här!!!! - )) - - ;; TODO this is just here for testing - (mod! (attr e 'NEW_ATTR) not) ; MUTATE - ;; This segfaults... - ;; (set! (attr e 'N) #t) ; MUTATE - ((@ (vcalendar output) print-vcomponent) e) - (set! (attr e 'D) #t) - - (set! (attr e 'DTEND) ; MUTATE - (add-duration - (attr e 'DTSTART) - (attr e 'DURATION))) - e))) - - ;; Event x Rule → Bool (continue?) - (match-lambda - ((e r) - - (or (and (not (until r)) (not (count r))) ; Never ending - (and=> (count r) (negate zero?)) ; COUNT - (and=> (until r) (cut time<=? (attr e 'DTSTART) <>))))) ; UNTIL - - ;; _ x Rule → (_, (next) Rule) - (match-lambda - ((e r) - (list - e (if (count r) - ;; Note that this doesn't modify, since r is immutable. - (mod! (count r) 1-) - r)))) - - ;; Seed - (list event rule-obj))) - - -(define (generate-recurrence-set event) - (unless (attr event "DURATION") - (set! (attr event "DURATION") ; MUTATE - (time-difference - (attr event "DTEND") - (attr event "DTSTART")))) - (recur-event-stream event (parse-recurrence-rule (attr event "RRULE")))) - - ;; How doee stream-unfold even work? - ;; What element is used as the next seed? -;;; stream-fold: -;; (stream-let recur ((base base)) -;; (if (pred? base) -;; (stream-cons (mapper base) (recur (generator base))) -;; stream-null)) diff --git a/vcalendar/recurrence/internal.scm b/vcalendar/recurrence/internal.scm deleted file mode 100644 index b62d75c2..00000000 --- a/vcalendar/recurrence/internal.scm +++ /dev/null @@ -1,28 +0,0 @@ -(define-module (vcalendar recurrence internal) - #:use-module (util) - #:use-module (srfi srfi-88) - #:export (make-recur-rule - weekdays intervals)) - -;; (list -;; (build-recur-rules "FREQ=HOURLY") -;; (build-recur-rules "FREQ=HOURLY;COUNT=3") -;; (build-recur-rules "FREQ=ERR;COUNT=3") -;; (build-recur-rules "FREQ=HOURLY;COUNT=err") -;; (build-recur-rules "FREQ=HOURLY;COUNT=-1")) - -;; Immutable, since I easily want to be able to generate the recurence set for -;; the same event multiple times. -(define-quick-record recur-rule - (public: freq until count interval bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - wkst)) - -(define (make-recur-rule interval wkst) - ((record-constructor '(interval wkst)) interval wkst)) - -(define weekdays - '(SU MO TU WE TH FR SA)) - -(define intervals - '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) diff --git a/vcalendar/recurrence/parse.scm b/vcalendar/recurrence/parse.scm deleted file mode 100644 index abead3a9..00000000 --- a/vcalendar/recurrence/parse.scm +++ /dev/null @@ -1,106 +0,0 @@ -(define-module (vcalendar recurrence parse) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19) ; Datetime - #:use-module (srfi srfi-19 util) - #:use-module (srfi srfi-26) - #:use-module ((vcalendar datetime) #:select (parse-datetime)) - #:duplicates (last) ; Replace @var{count} - #:use-module (vcalendar recurrence internal) - #:use-module (util) - #:use-module (exceptions) - #:use-module (ice-9 curried-definitions) - #:export (parse-recurrence-rule)) - -(define (parse-recurrence-rule str) - "Takes a RECUR value (string), and returuns a object" - (catch #t - (lambda () (%build-recur-rules str)) - (lambda (err cont obj key val . rest) - (let ((fmt (case err - ((unfulfilled-constraint) - "ERR ~a [~a] doesn't fulfill constraint of type [~a], ignoring~%") - ((invalid-value) - "ERR ~a [~a] for key [~a], ignoring.~%") - (else "~a ~a ~a")))) - (format #t fmt err val key)) - (cont obj)))) - -(eval-when (expand) - (define ((handle-case stx obj) key val proc) - (with-syntax ((skey (datum->syntax - stx (symbol-downcase (syntax->datum key))))) - #`((#,key) - (let ((v #,val)) - (cond ((not v) (throw-returnable 'invalid-value #,obj (quote #,key) v)) - ((#,proc #,val) (set! (skey #,obj) v)) - (else (set! (skey #,obj) - (throw-returnable 'unfulfilled-constraint - #,obj (quote #,key) v))))))))) - - -;; A special form of case only useful in parse-recurrence-rules above. -;; Each case is on the form (KEY val check-proc) where: -;; `key` is what should be matched against, and what is used for the setter -;; `val` is the value to bind to the loop object and -;; `check` is something the object must conform to -(define-syntax quick-case - (lambda (stx) - (syntax-case stx () - ((_ var-key obj (key val proc) ...) - #`(case var-key - #,@(map (handle-case stx #'obj) - #'(key ...) - #'(val ...) - #'(proc ...)) - (else obj)))))) - -(define-syntax all-in - (syntax-rules () - ((_ var rules ...) - (cut every (lambda (var) (and rules ...)) <>)))) - -(define (string->number-list val delim) - (map string->number (string-split val delim))) - -(define (string->symbols val delim) - (map string->symbol (string-split val delim))) - -(define (%build-recur-rules str) - (fold - (lambda (kv obj) - (let* (((key val) kv) - ;; Lazy fields for the poor man. - (symb (lambda () (string->symbol val))) - (date (lambda () (parse-datetime val))) - (num (lambda () (string->number val))) - (nums (lambda () (string->number-list val #\,)))) - (quick-case (string->symbol key) obj - (FREQ (symb) (cut memv <> intervals)) ; Requirek - (UNTIL (date) identity) - (COUNT (num) (cut <= 0 <>)) - (INTERVAL (num) (cut <= 0 <>)) - (BYSECOND (nums) (all-in n (<= 0 n 60))) - (BYMINUTE (nums) (all-in n (<= 0 n 59))) - (BYHOUR (nums) (all-in n (<= 0 n 23))) - - ;; TODO - ;; ∈ weekdays - ;; ::= [[±] ] ;; +3MO - ;; (, ...) - ;; (BYDAY (string-split val #\,)) - - (BYMONTHDAY (nums) (all-in n (<= -31 n 31) (!= n 0))) - (BYYEARDAY (nums) (all-in n (<= -366 n 366) (!= n 0))) - (BYWEEKNO (nums) (all-in n (<= -53 n 53) (!= n 0))) - (BYMONTH (nums) (all-in n (<= 1 n 12))) - (BYSETPOS (nums) (all-in n (<= -366 n 366) (!= n 0))) - - (WKST (symb) (cut memv <> weekdays)) - ))) - - ;; obj - (make-recur-rule 1 'MO) - - ;; ((key val) ...) - (map (cut string-split <> #\=) - (string-split str #\;)))) -- cgit v1.2.3