cor/scheme-dql
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit.

Browse source
This commit is contained in:
Cor Legemaat 2025-06-30 08:20:21 +02:00
parent 91bebfc088
commit 68e8af2403
5 changed files with 457 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
.dir-locals.el Normal file
View file

@ -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))))

9
Makefile.am
View file

@ -16,7 +16,7 @@
ACLOCAL_AMFLAGS=-I m4 ACLOCAL_AMFLAGS=-I m4
SUBDIRS = po src doc SUBDIRS = po dql doc
dist_doc_DATA = \ dist_doc_DATA = \
README.org \ README.org \
@ -28,17 +28,20 @@ dist_doc_DATA = \
README: README.org README: README.org
AUTHORS: AUTHORS:
$(file >AUTHORS,$(shell git shortlog --summary --numbered --email)) $(file >AUTHORS,$(shell git --no-pager shortlog -sn --email HEAD))
.PHONY: AUTHORS
ChangeLog: ChangeLog:
$(file >ChangeLog,$(shell git log --oneline --graph)) $(file >ChangeLog,$(shell git log --oneline --graph))
.PHONY: ChangeLog
release-tag: release-tag:
$(shell git tag -a "v$(VERSION)" -m "Release v$(VERSION)") $(shell git tag -a "v$(VERSION)" -m "Release v$(VERSION)")
$(shell git push origin "v$(VERSION)")
live: live:
mkdir -p /usr/share/guile/site/dql 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 # Remove doc directory on uninstall
uninstall-local: uninstall-local:

23
configure.ac
View file

@ -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. 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 You should have received a copy of the GNU General Public License along with
<Project-name>. If not, see <https://www.gnu.org/licenses/>. scheme-dql. If not, see <https://www.gnu.org/licenses/>.
]]) ]])
m4_define([version_major], [0]) m4_define([version_major], [0])
@ -25,7 +25,7 @@ AC_INIT(scheme-dql,
[], [],
[http://www.cor.za.net/code/scheme-dql]) [http://www.cor.za.net/code/scheme-dql])
AC_COPYRIGHT(SCHEME_DQL_CONFIGURE_COPYRIGHT) AC_COPYRIGHT(SCHEME_DQL_CONFIGURE_COPYRIGHT)
AM_INIT_AUTOMAKE([1.16]) AM_INIT_AUTOMAKE([1.16 gnu])
AC_CONFIG_MACRO_DIR([m4]) AC_CONFIG_MACRO_DIR([m4])
@ -88,28 +88,11 @@ AM_EXTRA_RECURSIVE_TARGETS([doc])
AC_CONFIG_FILES([Makefile AC_CONFIG_FILES([Makefile
po/Makefile.in po/Makefile.in
src/Makefile dql/Makefile
doc/Makefile]) doc/Makefile])
AC_CONFIG_COMMANDS([timestamp], [date >timestamp]) AC_CONFIG_COMMANDS([timestamp], [date >timestamp])
AC_OUTPUT 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. # End the configure script.

43
dql/Makefile.am Normal file
View file

@ -0,0 +1,43 @@
################################################################################
# Makefile.am
# Copyright (C) 2025 Cor Legemaat <cor@cor.za.net>
#
# 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 <https://www.gnu.org/licenses/>.
################################################################################
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
# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
# 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 "$@" "$<"

401
dql/dql.scm Normal file
View file

@ -0,0 +1,401 @@
;; -*- Mode: Scheme; geiser-scheme-implementation: guile; tab-width: 2 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; dql.scm
;;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net>
;;;
;;; 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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
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 <callback> <key> <key-n>)} 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)))