Add Database.Native

src/libraries/OS-Independent/Database/Native.dcl

+definition module Database.Native
+
+/**
+ * This module provides types and functions to build a database on the native
+ * Clean heap. It can be tedious to add new entries, but access is fast. and
+ * only little memory is used.
+ */
+
+from StdOverloaded import class ==, class <
+
+from Data.Map import :: Map
+from Data.Maybe import :: Maybe
+from Text.GenJSON import generic JSONEncode, generic JSONDecode, :: JSONNode
+
+/**
+ * A database. Entries can be soft deleted. Entries are indexed with integers
+ * which can be difficult to work with but at least provide constant time
+ * access.
+ * Annotations are not designed to be persistent. If you need to add persistent
+ * data to the database use a map over values.
+ *
+ * @var The type of values stored.
+ * @var The key type of annotations.
+ * @var The type of annotations.
+ */
+:: *NativeDB v ak a
+
+:: Index =: Index Int
+
+:: Entry v ak a =
+	{ value       :: !v
+	, included    :: !Bool
+	, annotations :: !Map ak a
+	}
+
+instance == Index
+instance < Index
+
+/**
+ * Two search modes are available.
+ */
+:: SearchMode
+	= Intersect   //* Only consider included entries (i.e., an AND with previous searches)
+	| AddExcluded //* Re-include matching entries but don't remove non-matching entries (i.e., an OR with previous searches)
+
+/**
+ * Create a new database from a list of entries.
+ */
+newDB :: ![v] -> *NativeDB v ak a
+
+/**
+ * Save the database to a file.
+ */
+saveDB :: !*(NativeDB v ak a) !*File -> *(!*NativeDB v ak a, !*File) | JSONEncode{|*|} v
+
+/**
+ * Open a database from a file.
+ */
+openDB :: !*File -> *(!Maybe (*NativeDB v ak a), !*File) | JSONDecode{|*|} v
+
+/**
+ * Reset all entries to included.
+ */
+resetDB :: !*(NativeDB v ak a) -> *NativeDB v ak a
+
+/**
+ * Return all entries (whether they have been excluded or not).
+ */
+allEntries :: !*(NativeDB v ak a) -> *(![v], !*NativeDB v ak a)
+
+/**
+ * Get all entries that are still included, and their annotations.
+ */
+getEntries :: !*(NativeDB v ak a) -> *(![(v, Map ak a)], !*NativeDB v ak a)
+
+/**
+ * An in-place map over all entries (also the excluded ones).
+ */
+mapInPlace :: !(Int v -> v) !*(NativeDB v ak a) -> *(NativeDB v ak a)
+
+/**
+ * Linear search for entries. The search function returns whether the entry
+ * should be included and which annotations should be added (if any). Excluded
+ * entries are ignored.
+ */
+search :: !SearchMode !(v -> (Bool, [(ak, a)])) !*(NativeDB v ak a) -> *NativeDB v ak a | ==, < ak
+
+/**
+ * Like {{`search`}}, but search for specific indices.
+ */
+searchIndices :: !SearchMode ![(!Index, ![(!ak, !a)])] !*(NativeDB v ak a) -> *NativeDB v ak a | ==, < ak
+
+/**
+ * Exclude a list of indices.
+ */
+unsearchIndices :: ![Index] !*(NativeDB v ak a) -> *NativeDB v ak a
+
+/**
+ * Like {{`searchIndices`}}, but also check on some property.
+ * This search always uses the {{`AddExcluded`}} {{`SearchMode`}}.
+ */
+searchWithIndices :: !(v -> (Bool, ![(!ak, !a)])) ![Index] !*(NativeDB v ak a) -> *NativeDB v ak a | ==, < ak
+
+/**
+ * Get an entry and its annotations.
+ * Also see {{`getIndices`}}.
+ */
+getIndex :: !Index !*(NativeDB v ak a) -> *(!Entry v ak a, !*(NativeDB v ak a))
+
+/**
+ * Like {{`getIndex`}}, but for a list of indices.
+ */
+getIndices :: ![Index] !*(NativeDB v ak a) -> *(![Entry v ak a], !*(NativeDB v ak a))

src/libraries/OS-Independent/Database/Native.icl

+implementation module Database.Native
+
+import StdArray
+import StdBool
+import StdFile
+import StdInt
+import StdString
+import StdTuple
+
+from Data.Func import $, hyperstrict
+import Data.Functor
+import Data.Map
+import Data.Maybe
+import Text.GenJSON
+
+:: *NativeDB v ak a = DB *{!Entry v ak a}
+
+instance == Index where == (Index a) (Index b) = a == b
+instance < Index where < (Index a) (Index b) = a < b
+
+newDB :: ![v] -> *NativeDB v ak a
+newDB vs = DB {{value=hyperstrict v,included=True,annotations=newMap} \\ v <- vs}
+
+saveDB :: !*(NativeDB v ak a) !*File -> *(!*NativeDB v ak a, !*File) | JSONEncode{|*|} v
+saveDB (DB db) f
+# (s,db) = usize db
+# f = f <<< toString s <<< "\n"
+# (db,f) = loop 0 (s-1) db f
+= (DB db, f)
+where
+	loop :: !Int !Int !*{!Entry v ak a} !*File -> *(*{!Entry v ak a}, !*File) | JSONEncode{|*|} v
+	loop i s es f
+	| i > s = (es,f)
+	# (e,es) = es![i]
+	# f = f <<< toJSON e.value <<< '\n'
+	= loop (i+1) s es f
+
+openDB :: !*File -> *(!Maybe (*NativeDB v ak a), !*File) | JSONDecode{|*|} v
+openDB f
+# (line,f) = freadline f
+# n = toInt (line % (0, size line - 2))
+# (es,f) = loop n f
+= case es of
+	Nothing -> (Nothing, f)
+	Just es -> (Just $ newDB es, f)
+where
+	loop :: !Int !*File -> *(Maybe [v], !*File) | JSONDecode{|*|} v
+	loop 0 f = (Just [], f)
+	loop n f
+	# (end,f) = fend f
+	| end = (Nothing, f)
+	# (line,f) = freadline f
+	= case fromJSON $ fromString line of
+		Nothing -> (Nothing, f)
+		Just e  -> case loop (n-1) f of
+			(Nothing, f) -> (Nothing, f)
+			(Just es, f) -> (Just [e:es], f)
+
+resetDB :: !*(NativeDB v ak a) -> *NativeDB v ak a
+resetDB (DB db)
+# (s,db) = usize db
+# db = upd (s-1) db
+= DB db
+where
+	upd :: !Int !*{!Entry v ak a} -> *{!Entry v ak a}
+	upd -1 es = es
+	upd i  es
+	# (e,es) = es![i]
+	= upd (i-1) {es & [i]={e & included=True}}
+
+allEntries :: !*(NativeDB v ak a) -> *(![v], !*NativeDB v ak a)
+allEntries (DB db)
+# (s,db) = usize db
+# (es,db) = collect (s-1) db
+= (es, DB db)
+where
+	collect :: !Int !*{!Entry v ak a} -> *(![v], !*{!Entry v ak a})
+	collect -1 es = ([], es)
+	collect i  es
+	# (e,es) = es![i]
+	# (r,es) = collect (i-1) es
+	= ([e.value:r], es)
+
+getEntries :: !*(NativeDB v ak a) -> *(![(v, Map ak a)], !*NativeDB v ak a)
+getEntries (DB db)
+# (s,db) = usize db
+# (es,db) = collect (s-1) db
+= (es,DB db)
+where
+	collect :: !Int !*{!Entry v ak a} -> *(![(v, Map ak a)], !*{!Entry v ak a})
+	collect -1 es = ([], es)
+	collect i  es
+	# (e,es) = es![i]
+	# (r,es) = collect (i-1) es
+	= (if e.included [(e.value,e.annotations):r] r, es)
+
+mapInPlace :: !(Int v -> v) !*(NativeDB v ak a) -> *(NativeDB v ak a)
+mapInPlace f (DB db)
+# (s,db) = usize db
+= DB (upd 0 s db)
+where
+	//upd :: !Int !Int !*{!Entry v ak a} -> *{!Entry v ak a}
+	upd i s es
+	| i == s = es
+	#! (e,es) = es![i]
+	#! e & value = hyperstrict $ f i e.value
+	= upd (i+1) s {es & [i]=e}
+
+search :: !SearchMode !(v -> (Bool, [(ak, a)])) !*(NativeDB v ak a) -> *NativeDB v ak a | ==, < ak
+search mode f (DB db)
+# (s,db) = usize db
+= DB (upd (s - 1) db)
+where
+	//upd :: (!Int !*{!Entry v ak a} -> *{!Entry v ak a}) | ==, < ak
+	upd = case mode of
+		Intersect   -> intersect
+		AddExcluded -> addExcluded
+
+	intersect -1 es = es
+	intersect i  es
+	# (e,es) = es![i]
+	| not e.included = intersect (i-1) es
+	# (include,annotations) = f e.value
+	= intersect (i-1) {es & [i]=
+		{ e
+		& included=include
+		, annotations=foldr (uncurry put) e.annotations annotations
+		}}
+
+	addExcluded -1 es = es
+	addExcluded i  es
+	# (e,es) = es![i]
+	# (include,annotations) = f e.value
+	= addExcluded (i-1) {es & [i]=
+		{ e
+		& included=e.included || include
+		, annotations=foldr (uncurry put) e.annotations annotations
+		}}
+
+searchIndices :: !SearchMode ![(!Index, ![(!ak, !a)])] !*(NativeDB v ak a) -> *NativeDB v ak a | ==, < ak
+searchIndices mode idxs (DB db)
+# (s,db) = usize db
+# db = upd 0 (s-1) idxs db
+= (DB db)
+where
+	upd :: !Int !Int ![(!Index, ![(!ak, !a)])] !*{!Entry v ak a} -> *{!Entry v ak a} | ==, < ak
+	upd i s _  es
+		| i > s = es
+	upd i s [] es
+		| mode=:AddExcluded = es
+		# (e,es) = es![i]
+		= upd (i+1) s [] {es & [i]={e & included=False}}
+	upd i s allidxs=:[match=:(Index idx,annots):idxs] es
+		# (e,es) = es![i]
+		# e & included = case mode of
+			Intersect   -> e.included && match
+			AddExcluded -> e.included || match
+		# e & annotations = if e.included (foldr (uncurry put) e.annotations annots) e.annotations
+		= upd (i+1) s (if match idxs allidxs) {es & [i]=e}
+	where
+		match = i == idx
+
+unsearchIndices :: ![Index] !*(NativeDB v ak a) -> *NativeDB v ak a
+unsearchIndices idxs (DB db)
+# db = upd idxs db
+= (DB db)
+where
+	upd :: ![Index] !*{!Entry v ak a} -> *{!Entry v ak a}
+	upd [] es = es
+	upd [Index i:is] es
+	# (e,es) = es![i]
+	= upd is {es & [i].included=False}
+
+searchWithIndices :: !(v -> (Bool, ![(!ak, !a)])) ![Index] !*(NativeDB v ak a) -> *NativeDB v ak a | ==, < ak
+searchWithIndices prop idxs (DB db)
+# db = upd idxs db
+= (DB db)
+where
+	upd [] es = es
+	upd [Index i:is] es
+	# (e,es) = es![i]
+	# e = case prop e.value of
+		(False, _)     -> {e & included=False}
+		(True, annots) -> {e & included=True, annotations=foldr (uncurry put) e.annotations annots}
+	= upd is {es & [i]=e}
+
+getIndex :: !Index !*(NativeDB v ak a) -> *(!Entry v ak a, !*(NativeDB v ak a))
+getIndex (Index n) (DB db)
+# (e,db) = db![n]
+= (e, DB db)
+
+getIndices :: ![Index] !*(NativeDB v ak a) -> *(![Entry v ak a], !*(NativeDB v ak a))
+getIndices is (DB db)
+# (es,db) = get is db
+= (es, DB db)
+where
+	get :: ![Index] !*{!Entry v ak a} -> *(![Entry v ak a], !*{!Entry v ak a})
+	get [] db = ([], db)
+	get [Index i:is] db
+	# (e,db) = db![i]
+	# (es,db) = get is db
+	= ([e:es], db)

tests/linux64/test.icl

@@ -93,6 +93,7 @@ import qualified Data.Tuple
 import qualified Data.Word8
 import qualified Data._Array
 import qualified Data.Generics
+import qualified Database.Native
 import qualified Database.SQL
 import qualified Database.SQL.MySQL
 import qualified Database.SQL.RelationalMapping