[elpa] externals/triples cd29901fb0 1/4: Allow storage of cons-types

[ELPA Syncer]

branch: externals/triples
commit cd29901fb023c567680950d5be21baab3786b1aa
Author: Andrew Hyatt <ahyatt@gmail.com>
Commit: Andrew Hyatt <ahyatt@gmail.com>

    Allow storage of cons-types
    
    This is a form that is a list in lisp, but not stored as in the form where 
each
    element is a row, because it could have inner lists and things like that.  
This
    is meant to store data structures.
---
 triples-test.el | 45 +++++++++++++++++++++++++++++++--------------
 triples.el      | 45 +++++++++++++++++++++++++++++++++------------
 2 files changed, 64 insertions(+), 26 deletions(-)

diff --git a/triples-test.el b/triples-test.el
index 30ae31a6ae..fea404a79e 100644
--- a/triples-test.el
+++ b/triples-test.el
@@ -220,7 +220,9 @@ easily debug into it.")
   (should (triples-test-op-equals
            (triples--set-type-op "Bert" 'named
                                  '(:name "Bertholomew The Second"
-                                         :alias ("Bert" "Berty")))
+                                         :alias ("Bert" "Berty"))
+                                 '((name :base/type string :base/unique t)
+                                   (alias :base/type string :base/unique nil)))
            '(replace-subject-type
              .
              (("Bert" base/type named)
@@ -229,15 +231,18 @@ easily debug into it.")
               ("Bert" named/alias "Berty" (:index 1)))))))
 
 (ert-deftest triples-schema-compliant ()
-  (triples-test-with-temp-db
-    (triples-add-schema db 'named
-                        '(name :base/unique t :base/type string)
-                        'alternate-names)
-    (triples-set-type db "foo" 'named :name "name")
-    (should (triples-verify-schema-compliant db '(("foo" named/name "bar"))))
-    (should-error (triples-verify-schema-compliant db '(("foo" named/name 5))))
-    (should-error (triples-verify-schema-compliant db '(("foo" named/name 
"bar" (:index 0)))))
-    (should (triples-verify-schema-compliant db '(("foo" named/alternate-names 
"bar" (:index 0)))))))
+  (let ((pal '((named/name :base/type string :base/unique t)
+               (named/alternate-names :base/type string :base/unique nil)
+               ;; Alias doesn't specify base/unique or base/type, so anything 
is fine.
+               (named/alias))))
+    (should (triples-verify-schema-compliant '(("foo" named/name "bar")) pal))
+    (should-error (triples-verify-schema-compliant '(("foo" named/name 5)) 
pal))
+    (should-error (triples-verify-schema-compliant '(("foo" named/name "bar" 
(:index 0))) pal))
+    (should (triples-verify-schema-compliant '(("foo" named/alternate-names 
"bar" (:index 0))) pal))
+    (should-error (triples-verify-schema-compliant '(("foo" 
named/alternate-names "bar" nil)) pal))
+    (should (triples-verify-schema-compliant '(("foo" named/alias "bar" nil)) 
pal))
+    (should (triples-verify-schema-compliant '(("foo" named/alias 5 nil)) pal))
+    (should (triples-verify-schema-compliant '(("foo" named/alias 5 (:index 
0))) pal))))
 
 (defun triples-test-plist-sort (plist)
   "Sort PLIST in a standard way, for comparison."
@@ -268,7 +273,7 @@ easily debug into it.")
   (triples-test-with-temp-db
     (triples-add-schema db 'named
                         '(name :base/unique t))
-    (triples-add-schema db 'positioned '(position :/base/unique t))
+    (triples-add-schema db 'positioned '(position :base/unique t))
     (should-not (triples-get-subject db "foo"))
     (triples-set-subject db "foo"
                          '(named :name "bar")
@@ -281,7 +286,7 @@ easily debug into it.")
 (ert-deftest triples-set-types ()
   (triples-test-with-temp-db
     (triples-add-schema db 'named
-                        '(name :/base/unique t)
+                        '(name :base/unique t)
                        'alias)
     (triples-add-schema db 'reachable 'phone)
     (triples-set-type db "foo" 'named :name "Name" :alias '("alias1" "alias2"))
@@ -316,6 +321,18 @@ easily debug into it.")
                   (triples-get-type db "foo" 'embedding)))
    (should-error (triples-set-type db "foo" 'embedding :embedding '(1 2 3)))))
 
+(ert-deftest triples-cons ()
+  (triples-test-with-temp-db
+   (triples-add-schema db 'data '(data :base/unique t :base/type cons))
+   (triples-set-type db "foo" 'data :data '(a (b c)))
+   (should (equal '(:data (a (b c)))
+                  (triples-get-type db "foo" 'data)))
+   (should (= 1 (length (triples-db-select db nil 'data/data))))
+   ;; Let's also make sure if we store it as a straight list triples doesn't 
get
+   ;; confused and try to store it as separate rows in the db.
+   (triples-set-type db "foo" 'data :data '(a b c))
+   (should (= 1 (length (triples-db-select db nil 'data/data))))))
+
 (ert-deftest triples-reversed ()
   (triples-test-with-temp-db
    (triples-add-schema db 'named
@@ -367,8 +384,8 @@ easily debug into it.")
 
 (ert-deftest triples-move-subject ()
   (triples-test-with-temp-db
-   (triples-add-schema db 'named '(name))
-   (triples-add-schema db 'friend '(id))
+   (triples-add-schema db 'named '(name :base/unique t))
+   (triples-add-schema db 'friend '(id :base/unique t))
    (triples-set-subject db 123 '(named :name "Ada Lovelace"))
    (triples-set-subject db 456 '(named :name "Michael Faraday")
                         '(friend :id 123))
diff --git a/triples.el b/triples.el
index aa03450eb7..817d7b6d02 100644
--- a/triples.el
+++ b/triples.el
@@ -379,12 +379,14 @@ merged into NEW-SUBJECT."
   (mapcar #'car
           (triples-db-select db type 'schema/property nil nil '(object))))
 
-(defun triples-verify-schema-compliant (db triples)
-  "Error if TRIPLES is not compliant with schema in DB."
+(defun triples-verify-schema-compliant (triples prop-schema-alist)
+  "Error if TRIPLES is not compliant with schema in PROP-SCHEMA-ALIST.
+PROP-SCHEMA-ALIST is an alist of the relevant properties to the
+data stored, in combined type/property form, and their schema
+definitions."
   (mapc (lambda (triple)
-          (pcase-let ((`(,type . ,prop) (triples-combined-to-type-and-prop 
(nth 1 triple))))
-            (unless (or (eq type 'base)
-                        (triples-db-select db type 'schema/property prop nil))
+          (pcase-let ((`(,type . ,_) (triples-combined-to-type-and-prop (nth 1 
triple))))
+            (unless (or (eq type 'base) (assoc (nth 1 triple) 
prop-schema-alist))
               (error "Property %s not found in schema" (nth 1 triple)))))
         triples)
   (mapc (lambda (triple)
@@ -393,7 +395,7 @@ merged into NEW-SUBJECT."
                                                           (triples--decolon 
pred-prop)))))
                                  (if (fboundp f)
                                      (funcall f val triple))))
-                             (triples-properties-for-predicate db (nth 1 
triple)))) triples))
+                               (cdr (assoc (nth 1 triple) 
prop-schema-alist)))) triples))
 
 (defun triples-add-schema (db type &rest props)
   "Add schema for TYPE and its PROPS to DB."
@@ -424,8 +426,21 @@ them."
 (defun triples-set-type (db subject type &rest properties)
   "Create operation to replace PROPERTIES for TYPE for SUBJECT in DB.
 PROPERTIES is a plist of properties, without TYPE prefixes."
-  (let ((op (triples--set-type-op subject type properties)))
-    (triples-verify-schema-compliant db (cdr op))
+  (let* ((prop-schema-alist
+          (mapcar (lambda (prop)
+                    (cons (triples--decolon prop)
+                          (triples-properties-for-predicate
+                           db
+                           (triples-type-and-prop-to-combined type prop))))
+                  (triples--plist-mapcar (lambda (k _) k) properties)))
+         (op (triples--set-type-op subject type properties prop-schema-alist)))
+    (triples-verify-schema-compliant
+     (cdr op)
+     ;; triples-verify-schema-compliant can act on triples from many types, so
+     ;; we have to include the type information in our schema property alist.
+     (mapcar (lambda (c)
+               (cons (triples-type-and-prop-to-combined type (car c))
+                     (cdr c))) prop-schema-alist))
     (triples--add db op)))
 
 (defmacro triples-with-transaction (db &rest body)
@@ -473,21 +488,27 @@ given in the COMBINED-PROPS will be removed."
       (cl-loop for k being the hash-keys of type-to-plist using (hash-values v)
                do (apply #'triples-set-type db subject k v)))))
 
-(defun triples--set-type-op (subject type properties)
+(defun triples--set-type-op (subject type properties type-schema)
   "Create operation to replace PROPERTIES for TYPE for SUBJECT.
-PROPERTIES is a plist of properties, without TYPE prefixes."
+PROPERTIES is a plist of properties, without TYPE prefixes.
+TYPE-SCHEMA is an alist of property symbols to their schema,
+which is necessary to understand when lists are supposed to be
+broken down into separate rows, and when to leave as is."
   (cons 'replace-subject-type
         (cons (list subject 'base/type type)
               (triples--plist-mapcan
                (lambda (prop v)
-                 (if (listp v)
+                 (let ((prop-schema (cdr (assoc (triples--decolon prop) 
type-schema))))
+                   (if (and
+                        (listp v)
+                        (not (plist-get prop-schema :base/unique)))
                      (cl-loop for e in v for i from 0
                               collect
                               (list subject
                                     (triples-type-and-prop-to-combined type 
prop)
                                     e
                                     (list :index i)))
-                   (list (list subject (triples-type-and-prop-to-combined type 
prop) v))))
+                   (list (list subject (triples-type-and-prop-to-combined type 
prop) v)))))
                properties))))
 
 (defun triples-get-type (db subject type)