From cdf9aaa4b0bf2a8cc125677f6e68e5c6df9e44e0 Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Fri, 18 May 2018 12:02:13 +0200 Subject: [PATCH] Add Database.Native --- .../OS-Independent/Database/Native.dcl | 113 ++++++++++ .../OS-Independent/Database/Native.icl | 202 ++++++++++++++++++ tests/linux64/test.icl | 1 + 3 files changed, 316 insertions(+) create mode 100644 src/libraries/OS-Independent/Database/Native.dcl create mode 100644 src/libraries/OS-Independent/Database/Native.icl diff --git a/src/libraries/OS-Independent/Database/Native.dcl b/src/libraries/OS-Independent/Database/Native.dcl new file mode 100644 index 00000000..aae9b1c7 --- /dev/null +++ b/src/libraries/OS-Independent/Database/Native.dcl @@ -0,0 +1,113 @@ +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)) diff --git a/src/libraries/OS-Independent/Database/Native.icl b/src/libraries/OS-Independent/Database/Native.icl new file mode 100644 index 00000000..bf993fec --- /dev/null +++ b/src/libraries/OS-Independent/Database/Native.icl @@ -0,0 +1,202 @@ +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) diff --git a/tests/linux64/test.icl b/tests/linux64/test.icl index d5561608..56181c89 100644 --- a/tests/linux64/test.icl +++ b/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 -- GitLab