Switch to a more sensible error reporting system

1 files changed, 82 insertions, 90 deletions

diff --git a/src/scm/webid-oidc/rdf-index.scm b/src/scm/webid-oidc/rdf-index.scm
index b70dc9a..71919ad 100644
--- a/src/scm/webid-oidc/rdf-index.scm
+++ b/src/scm/webid-oidc/rdf-index.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluid, implementation of the Solid specification
 ;; Copyright (C) 2020, 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -18,56 +18,52 @@
   #:use-module (oop goops)
   #:use-module (rdf rdf)
   #:use-module (web uri)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:declarative? #t
   #:export
   (
    with-index
    ))
 
-(define (normalize uri)
-  ;; It is possible to hide triples by percent-escaping
-  ;; some characters, so that match will fail to see
-  ;; them. With normalization, it should be impossible.
-  (when (string? uri)
-    (set! uri (string->uri uri)))
-  (let ((scheme (uri-scheme uri))
-        (userinfo (uri-userinfo uri))
-        (host (uri-host uri))
-        (port (uri-port uri))
-        (path (uri-path uri))
-        (query (uri-query uri))
-        (fragment (uri-fragment uri)))
-    (let ((normalized-scheme scheme)
-          (normalized-userinfo userinfo)
-          (normalized-host host)
-          (normalized-port port)
-          (normalized-path
-           (let ((path-ends-in-slash? (string-suffix? "/" path)))
-             (string-append
-              "/"
-              (encode-and-join-uri-path
-               (split-and-decode-uri-path path))
-              (if (and (not (equal? path "/"))
-                       path-ends-in-slash?)
-                  "/"
-                  ""))))
-          (normalized-query
-           (and query
-                (uri-encode (uri-decode query))))
-          (normalized-fragment
-           (and fragment
-                (uri-encode (uri-decode fragment)))))
-      (build-uri normalized-scheme
-                 #:userinfo normalized-userinfo
-                 #:host normalized-host
-                 #:port normalized-port
-                 #:path normalized-path
-                 #:query normalized-query
-                 #:fragment normalized-fragment))))
+(define normalize
+  (match-lambda
+    ((and (= uri-scheme scheme)
+          (= uri-userinfo userinfo)
+          (= uri-host host)
+          (= uri-port port)
+          (= uri-path path)
+          (= uri-query query)
+          (= uri-fragment fragment))
+     (let ((normalized-path
+            (let ((path-ends-in-slash? (string-suffix? "/" path)))
+              (string-append
+               "/"
+               (encode-and-join-uri-path
+                (split-and-decode-uri-path path))
+               (if (and (not (equal? path "/"))
+                        path-ends-in-slash?)
+                   "/"
+                   ""))))
+           (normalized-query
+            (and query
+                 (uri-encode (uri-decode query))))
+           (normalized-fragment
+            (and fragment
+                 (uri-encode (uri-decode fragment)))))
+       (build-uri scheme
+                  #:userinfo userinfo
+                  #:host host
+                  #:port port
+                  #:path normalized-path
+                  #:query normalized-query
+                  #:fragment normalized-fragment)))))
 
-(define (normalize-object object)
-  (if (string? object)
-      (uri->string (normalize object))
-      object))
+(define normalize-object
+  (match-lambda
+    ((? string? (= string->uri (? uri? x)))
+     (uri->string (normalize x)))
+    (object object)))
 
 (define-class <rdf-index> ()
   (triples #:init-keyword #:triples #:getter triples)
@@ -80,43 +76,41 @@
 
 (define (build-index triples)
   (let ((ret (make <rdf-index> #:triples (list->vector triples))))
-    (define (do-index n triples)
-      (unless (null? triples)
-        (let ((first (car triples))
-              (rest (cdr triples)))
-          (let ((s (normalize-object (rdf-triple-subject first)))
-                (p (normalize-object (rdf-triple-predicate first)))
-                (o (normalize-object (rdf-triple-object first))))
-            (let ((other-s (hash-ref (subject-index ret) s '()))
-                  (other-p (hash-ref (predicate-index ret) p '()))
-                  (other-o (hash-ref (object-index ret) o '()))
-                  (i (- n 1)))
-              (hash-set! (subject-index ret) s (cons i other-s))
-              (hash-set! (predicate-index ret) p (cons i other-p))
-              (hash-set! (object-index ret) o (cons i other-o))))
-          (do-index (- n 1) rest))))
-    (do-index (length triples) (reverse triples))
-    ret))
+    (let do-index ((n (length triples))
+                   (triples (reverse triples)))
+      (match triples
+        (() ret)
+        ((($ rdf-triple
+             (= normalize-object s)
+             (= normalize-object p)
+             (= normalize-object o))
+          triples ...)
+         (let ((other-s (hash-ref (subject-index ret) s '()))
+               (other-p (hash-ref (predicate-index ret) p '()))
+               (other-o (hash-ref (object-index ret) o '()))
+               (i (- n 1)))
+           (hash-set! (subject-index ret) s `(,i ,@other-s))
+           (hash-set! (predicate-index ret) p `(,i ,@other-p))
+           (hash-set! (object-index ret) o `(,i ,@other-o)))
+         (do-index (- n 1) triples))))))
 
-(define (intersection-2 a b)
-  (cond
-   ((not a) b)
-   ((not b) a)
-   ((or (null? a) (null? b))
-    '())
-   ((< (car a) (car b))
-    (intersection-2 (cdr a) b))
-   ((> (car a) (car b))
-    (intersection-2 a (cdr b)))
-   (else
-    (cons (car a) (intersection-2 (cdr a) (cdr b))))))
+(define intersection-2
+  ;; Intersection of two lists of integers, but if one is false, only
+  ;; consider the other.
+  (match-lambda*
+    ((or (#f x) (x #f)) x)
+    ((or (() _) (_ ())) '())
+    ((and (a b)
+          ((hda tla ...) (hdb tlb ...)))
+     (cond ((< hda hdb) (intersection-2 tla b))
+           ((> hda hdb) (intersection-2 a tlb))
+           (else `(,hda ,@(intersection-2 tla tlb)))))))
 
-(define (intersection a . rest)
-  (if (null? rest)
-      a
-      (let ((b (car rest))
-            (true-rest (cdr rest)))
-        (apply intersection (intersection-2 a b) true-rest))))
+(define intersection
+  (match-lambda*
+    ((x) x)
+    ((a b c ...)
+     (apply intersection (intersection-2 a b) c))))
 
 (define (rdf-match index subject predicate object)
   (let ((by-subject
@@ -135,17 +129,15 @@
                         (normalize-object object)
                         '()))))
     (let ((indices (intersection by-subject by-predicate by-object)))
-      (define (accumulate-triples acc i)
-        (if (null? i)
-            (reverse acc)
-            (let ((t (vector-ref (triples index) (car i))))
-              (accumulate-triples (cons t acc) (cdr i)))))
       (if indices
-          (accumulate-triples '() indices)
+          (let accumulate-triples ((acc '())
+                                   (i indices))
+            (match i
+              (() (reverse acc))
+              ((next i ...)
+               (let ((t (vector-ref (triples index) next)))
+                 (accumulate-triples `(,t ,@acc) i)))))
           (vector->list (triples index))))))
         
-        
 (define (with-index graph f)
-  (let ((index (build-index graph)))
-    (f (lambda (s p o)
-         (rdf-match index s p o)))))
+  (f (cute rdf-match (build-index graph) <> <> <>)))