diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..2e29a0b --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,4 @@ +((nil . ((eval . (add-hook 'before-save-hook 'copyright-update)))) + (scheme-mode . ((tab-width . 2) + (indent-tabs-mode . t) + (geiser-scheme-implementation . guile)))) diff --git a/Makefile.am b/Makefile.am index 2deadd6..4993ec7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -16,7 +16,7 @@ ACLOCAL_AMFLAGS=-I m4 -SUBDIRS = po src doc +SUBDIRS = po dql doc dist_doc_DATA = \ README.org \ @@ -28,17 +28,20 @@ dist_doc_DATA = \ README: README.org AUTHORS: - $(file >AUTHORS,$(shell git shortlog --summary --numbered --email)) + $(file >AUTHORS,$(shell git --no-pager shortlog -sn --email HEAD)) +.PHONY: AUTHORS ChangeLog: $(file >ChangeLog,$(shell git log --oneline --graph)) +.PHONY: ChangeLog release-tag: $(shell git tag -a "v$(VERSION)" -m "Release v$(VERSION)") + $(shell git push origin "v$(VERSION)") live: mkdir -p /usr/share/guile/site/dql - mount --bind -o ro src /usr/share/guile/site/dql/ + mount --bind -o ro dql /usr/share/guile/site/dql/ # Remove doc directory on uninstall uninstall-local: diff --git a/configure.ac b/configure.ac index 7d33755..98429f3 100644 --- a/configure.ac +++ b/configure.ac @@ -11,7 +11,7 @@ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with -. If not, see . +scheme-dql. If not, see . ]]) m4_define([version_major], [0]) @@ -25,7 +25,7 @@ AC_INIT(scheme-dql, [], [http://www.cor.za.net/code/scheme-dql]) AC_COPYRIGHT(SCHEME_DQL_CONFIGURE_COPYRIGHT) -AM_INIT_AUTOMAKE([1.16]) +AM_INIT_AUTOMAKE([1.16 gnu]) AC_CONFIG_MACRO_DIR([m4]) @@ -88,28 +88,11 @@ AM_EXTRA_RECURSIVE_TARGETS([doc]) AC_CONFIG_FILES([Makefile po/Makefile.in -src/Makefile +dql/Makefile doc/Makefile]) AC_CONFIG_COMMANDS([timestamp], [date >timestamp]) AC_OUTPUT -dnl This is just for printing $libdir below. -LIBDIR=`eval echo $libdir` -LIBDIR=`eval echo $LIBDIR` -AC_SUBST([LIBDIR]) - -echo -echo "*** $PACKAGE $VERSION has been successfully configured ***" -echo -echo "$PACKAGE is using:" -echo -echo " --prefix=$prefix --libdir=$LIBDIR" -echo -echo "If you want to install in Guile system's directory re-run with:" -echo -echo " --prefix=$GUILE_PREFIX --libdir=$GUILE_LIBDIR" -echo - # End the configure script. diff --git a/dql/Makefile.am b/dql/Makefile.am new file mode 100644 index 0000000..4143f08 --- /dev/null +++ b/dql/Makefile.am @@ -0,0 +1,43 @@ +################################################################################ +# Makefile.am +# Copyright (C) 2025 Cor Legemaat +# +# This file is part of scheme-dql: you can redistribute it and/or modify it +# under the terms of the GNU Affero General Public License as published by the +# Free Software Foundation, version 3 of the License. + +# scheme-dql is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along with +# scheme-dql. If not, see . +################################################################################ + +moddir=$(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION)/dql +objdir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache/dql + +SOURCES = dql.scm + +GOBJECTS = $(SOURCES:%.scm=%.go) + +nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) +nobase_obj_DATA = $(GOBJECTS) + +# Make sure source files are installed first, so that the mtime of +# installed compiled files is greater than that of installed source +# files. See +# +# for details. +guile_install_obj_files = install-nobase_obj_DATA +$(guile_install_obj_files): install-nobase_mod_DATA + +EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) + +CLEANFILES = $(GOBJECTS) + +GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat +GUILE_OPTS = -L $(abs_top_builddir)/src +SUFFIXES = .scm .go +.scm.go: + $(GUILD) compile $(GUILE_TARGET) $(GUILE_OPTS) $(GUILE_WARNINGS) -o "$@" "$<" diff --git a/dql/dql.scm b/dql/dql.scm new file mode 100644 index 0000000..b9d2dac --- /dev/null +++ b/dql/dql.scm @@ -0,0 +1,401 @@ +;; -*- Mode: Scheme; geiser-scheme-implementation: guile; tab-width: 2 -*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; dql.scm +;;; Copyright (C) 2025 Cor Legemaat +;;; +;;; This file is part of scheme-dql: you can redistribute it and/or modify it +;;; under the terms of the GNU Affero General Public License as published by the +;;; Free Software Foundation, version 3 of the License. +;;; +;;; scheme-dql is distributed in the hope that it will be useful, but WITHOUT +;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for +;;; more details. +;;; +;;; You should have received a copy of the GNU General Public License along with +;;; scheme-dql. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#| +This module creates an interface for processing alist data in the same sense as +how sqlite is used for processing data. The data is in alists stored and read +by the calling application in the same way as how json is used. The querry +syntax is fixed from SQL like how irregex fixed regular expressions. +|# + +;; TODO move non public functions to sub modules and generate api documentation +;; for this module with https://luis-felipe.gitlab.io/guile-documenta/. + +(define-module (dql dql) + #:use-module (srfi srfi-1) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 optargs) + #:use-module (oop goops)) + +(define-public alist? + (lambda (test-list) + "Check if the test data is an alist with the keys as strings. + + @strong{test-list} (list): + The data to check. + + @strong{return} (bool): + True if the test data is an alist with the keys as strings, false + otherwise." + (if (pair? test-list) + (every (lambda (ass) + (if (pair? ass) + (or (string? (car ass)) + (symbol? (car ass))) + #f)) + test-list) + #f))) + +(define path-val + (lambda (path data) + "Return the code that can determine the last key of the path, where the path + forms a list of keys with each following key is read from the data of the + preceding key. + + @strong{path} (list): + A list of key strings in the sequence as how you should traverse the + data to get to the value. + + @strong{data} (alist): + The a-list data tree to retrieve the value from. + + @strong{return} (any): + The value stored by the last key in the path." + (if (null? (cdr path)) + `(assoc-ref ,data ,(car path)) + (path-val (cdr path) + `(assoc-ref ,data ,(car path)))))) + +(define-public dql-data->list + (lambda (data) + "Function to convert the supplied data into a list of alists from a non + list like a vector that could be represented as a list of alists or ill + formatted data. + + @strong{data} (any data type that could be represented as a list): + The source data to convert. + + @strong{return} (list of alists): + The input data converted to a list of alists. + + Only vectors and ill formatted lists of alists are supported at the moment + but more could be added like arrays etc." + (cond ((vector? data) + (vector->list data)) + ((list? data) + (cond ((and (pair? data) (pair? (car data)) (null? (cdr data)) + (pair? (car data)) (pair? (caar data)) (null? (cdar data))) + ;;Hack to handle nestling of answers. + (caar data)) + ((alist? data) + ;;Hack for if alist no inside list. + (list data)) + (else data))) + (else (error (string-append "Data not a list but \"" + (object->string (class-of data)) + "\"!\n")))))) + +(define map-query-symbols + (lambda (query data) + "Function to map the querry keywords to their representative functions. + + @strong{query} (dql-querry): + The querry to map. + + @strong{data} (symbol) + The symbol representing the data. + + @strong(return) (function call): + The call to the correct function. + + Only the first symbol is used to determine what function to apply the + function handle it from there and will call this function again if needed." + (cond ((eq? (car query) 'filter) + (dql-filter (cdr query) data)) + ((eq? (car query) 'select) + (dql-select (cdr query) data)) + ((eq? (car query) 'sort) + (dql-sort (cdr query) data)) + ((eq? (car query) 'alter) + (dql-alter (cdr query) data)) + (else (error (string-append "ERROR: Unimplemented query \"" + (object->string (car query)) + "\"!")))))) + +(define first-parm-other + (lambda (parms . local) + "Function to determine if the first parameter is a local parameter or an + sub querry that will supply the data for this query. + + @strong{parms} (dql-query): + The query to analyze. + + @strong{local} (symbols): + The function local symbols that define local parameters. + + @strong{return} (bool): + True if the first parameter is a sub query false otherwise." + (and (pair? parms) + (pair? (car parms)) + (not (any (lambda (parm) + (eq? (caar parms) parm)) + local))))) + +(define dql-boolean-where + (lambda (bool-op filters entry) + "Function to return the code that can determine if the data processed by the + code should be selected for processing or not. + + @strong{bool-op} (symbol): + The boolean operation to use for multiple selections. + + @strong{filters} (filter list): + The list of callback filters for this query. + + @strong{entry} (symbol) + The symbol representing the data entry. + + @strong{return} (code): + The code that will analyze the data. + + A filter is in the form of @code{(where )} where the + keys are passed as is to @ref(path-val) and the return from that as the data + to the callback function. + + A boolean keyword like @samp{and} or @samp{or} will result in a tail call + with the rest of the entries as filters." + (if (or (eq? bool-op 'and) + (eq? bool-op 'or)) + (append (list bool-op) + (map (lambda (rule) + (if (eq? (car rule) 'where) + `(,(cadr rule) ,(path-val (cddr rule) + entry)) + (dql-boolean-where (car rule) + (cdr rule) + entry))) + filters)) + (error (string-append "Unimplemented boolean operand \"" + (symbol->string bool-op) + "\" for where!"))))) + +(define dql-filter + (lambda (query data) + "Function to return the code that will filter the data entries based on the + @xref{where, dql-boolean-where} rules of the query. + + @strong{query} (dql-query): + The query to generate the code for. + + @strong{data} (symbol) + The symbol representing the data. + + @strong{return} (code): + The code that will process the data according to the query." + (let ((fpo (first-parm-other query 'where 'and 'or)) + (entry (gensym))) + `(filter-map (lambda (,entry) + (if ,(dql-boolean-where 'and + (if fpo + (cdr query) + query) + entry) + ,entry #f)) + (dql-data->list ,(if fpo + (map-query-symbols (car query) + data) + data)))))) + +(define dql-sort + (lambda (query data) + "Function to return the code that will sort the data entries based on the + @code{by} rules of the query. + + @strong{query} (dql-query): + The query to generate the code for. + + @strong{data} (symbol) + The symbol representing the data. + + @strong{return} (code): + The code that will process the data according to the query." + (let ((fpo (first-parm-other query 'by))) + (let ((first-parm (if fpo + (cadr query) + (car query))) + (a (gensym)) + (b (gensym))) + `(sort (dql->data->list ,(if fpo + (map-query-symbols (car query) + data) + (if (null? (cdr query)) + data + `(dql-sort ,(cdr query))))) + (lambda (,a ,b) + ,((cadr first-parm) + (path-val (cddr first-parm) a) + (path-val (cddr first-parm) b)))))))) + +(define dql-alter + (lambda (query data) + "Function to return the code that will alter the data entries based on the + @xref{where, dql-boolean-where} filter as the first rule and then the + subsequent @code{insert}, @code{update} and @code{drop} rules of the query. + + @strong{query} (dql-query): + The query to generate the code for. + + @strong{data} (symbol) + The symbol representing the data. + + @strong{return} (code): + The code that will process the data according to the query." + (let* ((fpo (first-parm-other query 'insert 'update 'drop 'where)) + (entry (gensym)) + (parm->code + (lambda (parm) + ;;TODO get entry from path-val. + (cond ((eq? (car parm) 'update) + `(set! ,entry + (assoc-set! ,entry ,(second parm) ,(third parm)))) + ((eq? (car parm) 'insert) + `(set! ,entry + (acons ,(second parm) ,(third parm) ,entry))) + ((eq? (car parm) 'drop) + `(set! ,entry + (assoc-remove! ,entry + ,(second parm)))) + (else (error (string-append "Illegal parameter \"" + (symbol->string (car parm)) + "\" for alter"))))))) + `(map ,(append (list 'lambda (list entry)) + (list (append (list 'if + (if fpo + (if (first-parm-other (cdr query) + 'where) + #t + (dql-boolean-where 'where + (cadr query) + entry)) + (if (first-parm-other query 'where) + #t + (dql-boolean-where 'where + (car query) + entry)))) + (list (append (list 'begin) + (map parm->code + (if fpo + (cdr query) + query)))))) + (list entry)) + (dql-data->list ,(if fpo + (map-query-symbols (car query) data) + data)))))) + +(define dql-select + (lambda (query data) + "Function to return the code that will select a subsections of the + associations of the alist data entries based on the @code{parm}, + @code{parm-as} and @code{parm-val} rules of the query. + + @strong{query} (dql-query): + The query to generate the code for. + + @strong{data} (symbol) + The symbol representing the data. + + @strong{return} (code): + The code that will process the data according to the query." + (let* ((fpo (first-parm-other query 'parm 'parm-as 'parm-val)) + (entry (gensym)) + (parm->code + (lambda (parm) + (cond ((eq? (car parm) 'parm) + (let ((last-parm (last parm)) + (rest-parms (drop-right (cdr parm) 1))) + `(assoc ,last-parm + ,(if (null? rest-parms) + entry + (path-val rest-parms + entry))))) + ((eq? (car parm) 'parm-as) + `(cons ,(car (cdr parm)) + ,(path-val (cdr (cdr parm)) + entry))) + ((eq? (car parm) 'parm-val) + (let ((last-parm (last parm)) + (rest-parms (drop-right (cdr parm) 1))) + `(assoc-ref ,(if (null? rest-parms) + entry + (path-val rest-parms + entry)) + ,last-parm))) + (else + (error "Illegal parameter for select.")))))) + `(map (lambda (,entry) + ,(append (list 'list) + (map parm->code + (if fpo (cdr query) query)))) + (dql-data->list ,(if fpo + (map-query-symbols (car query) data) + data)))))) + +(defmacro*-public dql (query #:key (print-query #f)) + "The main exported macro to return the lambda that will process the data + based on the query. + + @strong{query} (dql-query): + The query to generate the code for. + + @strong{print-query} (boolean) + Option to @code{pretty-print} the generated lambda's code. + + @strong{return} (lambda): + The lambda function that will process the data according to the query." + (let ((data (gensym))) + (if print-query + (begin (display "generated query for ") + (display print-query) + (display ":") + (newline) + (pretty-print `(lambda (,data) + ,(map-query-symbols query data))))) + `(lambda (,data) + ,(map-query-symbols query data)))) + +(define-public dql-write + (lambda (data path) + "A helper procedure to write the data to a file. + + @strong{data} (alist-data): + The data to write to the file. + + @strong{path} (string): + The file path to write the data to. + + @strong{return} (undefined):" + (let ((output-port (open-output-file path))) + (pretty-print data output-port + #:display? #f + #:width 600 + #:max-expr-width 600) + (close output-port)))) + +(define-public dql-read + (lambda (path) + "A helper function to read data from a file. + + @strong{path} (string): + The file path to read the data from. + + @strong{return} (alist-data): + The data read from the file." + (let* ((input-port (open-input-file path)) + (data (read input-port))) + (close input-port) + data)))