8e79409cf7f9 — Leonard Ritter a month ago
* more work on module
3 files changed, 373 insertions(+), 300 deletions(-)

M testing/conspire/test_module.sc
M tukan/db.sc
M tukan/module.sc
M testing/conspire/test_module.sc +60 -16
@@ 1,28 1,72 @@ 
 
+using import enum
 using import testing
-
 using import console
-using import ...conspire.module
+
+import ...tukan.use
+using import tukan.module
 
-try
-    let mod = (Module "test.csp")
-    let session = ('select mod)
+#inline trycall (f ...)
+    try (f ...)
+    except (err)
+        let db = (import tukan.db)
+        static-assert ((typeof err) != db.Error)
+        raise (err as Error)
+
+fn main ()
     let blob = (Blob "0123456789012345678901234567890123456789")
     let blob2 = (Blob "012345678901234567890123456789012345678910")
     let blob3 = (Blob "0123456789012345678901234567890123456789")
-    print
+    let blob4 = (Blob "01234567890123456789012345678901234567891023")
+    let digest =
         blob.digest
+    print digest blob2.digest blob3.digest
     print (blob == blob2)
     print (blob == blob3)
-    print
-        'store blob
-    print
-        'store blob
+    print "opening module..."
+    let mod = (Module "test.csp")
+
+    let act = ('edit mod)
+
+    let blobid = ('store-blob act blob)
+
+    inline test (expr)
+        try
+            test expr
+        except (err)
+            raise (err as ModuleError)
+
+    test (blobid == ('store-blob act blob))
+
+    let blobid2 = ('store-blob act blob2)
+    test (blobid2 == ('store-blob act blob2))
+    test (blobid == ('store-blob act blob))
+
+    print ('digest-id act digest) ('digest-id act blob4.digest)
+
+    let blob5 = ('load-blob act ('digest-id act digest))
+    print "blob == blob5?" (blob5 == blob)
+
+    let edge =
+        Edge
+            TypedId blobid blobid
+            TypedId blobid2 blobid2
+            TypedId blobid2 blobid2
+    'store-edge act edge
+    let edge =
+        Edge
+            TypedId blobid blobid
+            TypedId blobid2 blobid2
+    print edge
     print
-        'store blob2
-    print
-        'store blob2
-    print
-        'store blob
+        'load-edge act edge
+
+    #'abort act
+    'commit act
+    ;
+
+try (main)
 except (err)
-    'handle err
+    raise (err as Error)
+
+;
  No newline at end of file

          
M tukan/db.sc +16 -2
@@ 30,6 30,9 @@ typedef DBError : i32
         static-if (T == string)
             inline (self)
                 string (mdb_strerror (storagecast self))
+        elseif (T == Error)
+            inline (self)
+                sc_error_new (string (mdb_strerror (storagecast self)))
 
 inline errorcall (f ...)
     let result = (f ...)

          
@@ 171,8 174,10 @@ typedef+ MDB_val
             mv_size = size
             mv_data = data
     case (cls : type, value)
-        local tmp = value
-        super-type.__typecall cls
+        # value must implement a valid conversion
+        value as cls
+        #local tmp = value
+        #super-type.__typecall cls
             mv_size = (sizeof value)
             mv_data = &tmp
 

          
@@ 182,11 187,20 @@ typedef+ MDB_val
     inline __repr (self)
         .. "<size=" (repr self.mv_size) ">"
 
+    @@ memo
     inline __as (cls T)
         inline (self)
             assert (self.mv_size == (sizeof T))
             @ (bitcast self.mv_data @T)
 
+    @@ memo
+    inline __ras (T cls)
+        static-if (T < integer)
+            sz := ((bitcountof T) + 7) // 8
+            inline (self)
+                local tmp = (copy self)
+                this-type sz &tmp
+
 do
     let
         Error = DBError

          
M tukan/module.sc +297 -282
@@ 1,6 1,7 @@ 
 
 using import struct
 using import enum
+using import Option
 
 using import .libc
 using import .SHA1

          
@@ 9,8 10,11 @@ let db = (import .db)
 """"
     A module consists of three key-value stores mapping following types:
 
+        immutable:
         Blob DB: Id (u32) -> blob (arbitrary size...)
         Hash DB: SHA-1 Hash (u160) -> Id (u32)
+
+        mutable:
         Edge DB: Edge IdId IdId (2 x u64) -> IdId (u64)
 
     All keys and values are aigned to 8 bytes.

          
@@ 27,9 31,9 @@ let db = (import .db)
     contents are opaque.
 
     Edges describe directed connections from one typed Id to another using
-    a typed Id as edge label, in the sense that `source @ label = target`. Edges
-    are mutable, and therefore can be inserted, removed and changed freely.
-
+    a typed Id as edge label, in the sense that `source @ label = target`, or
+    `DB @ source @ target = value` in terms of an adjacency matrix. Edges are
+    mutable, and therefore can be inserted, removed and changed freely.
 
     An Id is typed when it is paired with a second Id that acts as a type
     identifier, which is used to read the schema for the blob. The type

          
@@ 64,6 68,37 @@ let db = (import .db)
     type.typename "builtin" "String" untyped (type.storage.integer 32)
     type.typename "builtin" "Symbol" untyped (type.storage.integer 32)
 
+    when a type is defined
+
+enum ModuleError
+    error : Error
+    database : db.Error
+
+    #inline handle (self)
+        fprintf (stderr) "DB error: %s\n" (mdb_strerror (storagecast self))
+        abort;
+
+    @@ memo
+    inline __ras (T cls)
+        static-if (T == db.Error)
+            fn (self)
+                this-type.database self
+        elseif (T == Error)
+            fn (self)
+                this-type.error self
+
+    @@ memo
+    inline __as (cls T)
+        static-if (T == Error)
+            fn (self)
+                dispatch self
+                case error (err)
+                    copy err
+                case database (err)
+                    err as Error
+                default
+                    sc_error_new (repr self)
+
 let
     DB_ALIGNMENT = 8:u32
 

          
@@ 102,22 137,134 @@ fn format-hex-number (self width)
 inline align-size (offset align)
     (offset + align - 1) & (~ (align - 1))
 
-typedef Id : u32
+type Id : u32
+    let None = (nullof this-type)
+
     inline... wrap
     case (value : u32,)
         bitcast value this-type
     case (value : u64,)
         itrunc value this-type
 
-typedef TypeId : u32
+    let __== = integer.__==
+
+
+    fn __repr (self)
+        .. (tostring (storagecast self)) ":?"
+
+    @@ memo
+    inline __as (self T)
+        static-if (T == bool)
+            let ST = (storageof this-type)
+            let nullval = (nullof ST)
+            inline (self)
+                (storagecast self) != nullval
+
+struct TypedId plain
+    value : Id = Id.None
+    type : Id = Id.None
+
+    fn __repr (self)
+        .. (tostring (storagecast self.value))
+            \ ":" (tostring (storagecast self.type))
+
+static-assert ((sizeof TypedId) == 8)
+
+struct Edge plain
+    tail : TypedId
+    key : TypedId
+    head : TypedId
+
+    fn __repr (self)
+        .. "<" (repr self.tail) " @ " (repr self.key) " = " (repr self.head) ">"
+
+static-assert ((sizeof Edge) == 24)
+
+type Digest
+    \ < integer : (integer 192) # only 160 bits are active, the rest is null
+    #\ < array : (array u64 3)
+    fn __repr (self)
+        local value = (storagecast self)
+        .. "<digest "
+            format-hex-number value ((sizeof SHA1.DigestType) * 8)
+            #format-hex-number value ((sizeof this-type) * 8)
+            ">"
+
+static-assert ((sizeof Digest) == 24)
+
+""""type.typename <uri:StringId> <name:StringId> <super-type:TypeId> <storage-type:TypeId> <memoized-value:Any> ...
+    type.storage.integer <bitcount:i32> (negative bitcount: signed integer)
+    type.storage.real <bitcount:u32>
+    type.storage.pointer <flags:u32> <storage-class:StringId>
+    type.storage.array <element-type:TypeId> <size:u64>
+    type.storage.vector <element-type:TypeId> <size:u64>
+    type.storage.tuple [<element-type:TypeId> ...]
+    type.function <return-tuple-type:TypeId> <arguments-tuple-type:TypeId>
+    type.qualify <type:TypeId> <sorted-qualifier:TypeId> ...
+
+let StringId = Id
+let TypeId = Id
 
-struct Any
+struct TypeHeader plain
+    # string
+    kind : StringId
+
+struct TypenameType plain
+    Kind := "type.typename"
+
+    header : TypeHeader
+    uri : StringId
+    name : StringId
+    super : StringId
+    storage : StringId
+    values : (array TypedId)
+
+struct IntegerType plain
+    Kind := "type.storage.integer"
+
+    header : TypeHeader
+    bitcount : i32
+
+struct RealType plain
+    Kind := "type.storage.real"
+
+    header : TypeHeader
+    bitcount : u32
+struct PointerType plain
+    Kind := "type.storage.pointer"
+
+    header : TypeHeader
+    flags : u32
+    storage : StringId
+struct ArrayType plain
+    Kind := "type.storage.array"
+
+    header : TypeHeader
+    element : TypeId
+    size : u64
+struct VectorType plain
+    Kind := "type.storage.vector"
+
+    header : TypeHeader
+    element : TypeId
+    size : u64
+struct TupleType plain
+    Kind := "type.storage.tuple"
+
+    header : TypeHeader
+    elements : (array TypeId)
+struct FunctionType plain
+    Kind := "type.function"
+
+    header : TypeHeader
+    returns : TypeId
+    params : TypeId
+struct QualifyType plain
+    Kind := "type.qualify"
+
+    header : TypeHeader
     type : TypeId
-    value : Id
-
-struct Edge
-    source : Any
-    label : Any
+    qualifiers : (array TypeId)
 
 let
     DBI_BLOB = "blob"

          
@@ 131,12 278,16 @@ struct Databases plain
     hash : db.Index
     edge : db.Index
 
-struct ViewAct
+type Act < Struct
+
+struct ViewAct < Act
     _txn : db.Transaction
+    _db : Databases
 
-    inline __typecall (cls txn)
+    inline __typecall (cls txn db)
         super-type.__typecall cls
             _txn = txn
+            _db = db
 
     inline __drop (self)
         'abort self._txn

          
@@ 149,135 300,38 @@ struct ViewAct
         'abort self._txn
         lose self
 
-struct EditAct
+struct EditAct < Act
     _txn : db.Transaction
+    _db : Databases
 
-    inline __typecall (cls txn)
+    inline __typecall (cls txn db)
         super-type.__typecall cls
             _txn = txn
+            _db = db
 
     inline __drop (self)
-        static-error "acts must be committed, aborted or reset"
+        'abort self._txn
 
     inline abort (self)
         'abort self._txn
         lose self
 
     inline commit (self)
-        'commit self._txn
-        lose self
-
-#
-    fn... follow
-    case (self, edge : Edge)
-        let value = ('get self._txn self._db.edge (db.Value edge))
-        value as Atom
-    case (self, source : Atom, label : Atom)
-        this-function self (Edge source label)
-
-    fn... deref-tuple
-    case (self, key : Atom)
-        let key = (db.Value ('digest key))
-        let value = ('get self._txn self._db.blob key)
-        let size content = (unpack value)
-        let count = (size // (sizeof Atom))
-        _ count (bitcast content (pointer Atom))
-
-    fn clear (self)
-        let dbs = self._db
-        let txn = self._txn
-        va-map
-            inline (field)
-                'clear txn
-                    getattr dbs (keyof field.Type)
-            Databases.__fields__
-
-    fn... makeblob
-    case (self, data : voidstar, sz : u32)
-        local sha : SHA1
-        'hash sha (bitcast data rawstring) sz
-        static-assert ((sizeof SHA1.DigestType) <= (sizeof Atom.payload-type))
-        local digest = (nullof (array u64 3))
-        let digest20 = (@ (bitcast &digest (mutable @SHA1.DigestType)))
-        'digest sha digest20
-
-        let key = (db.Value digest)
-        let cur = (db.Cursor self._txn self._db.blob)
-        defer
-            inline ()
-                'close cur
         try
-            'get cur key db.Set
-            # if this passes, it already exists
-            ;
+            'commit self._txn
         except (err)
-            if (err == db.NotFound)
-                # new
-                let alignedsz = (align-size (sz + 1) DB_ALIGNMENT)
-                local value = (db.Value alignedsz null)
-                'put cur key value db.Reserve
-                let targetsize target = (unpack value)
-                target := (bitcast target (mutable rawstring))
-                assert ((ptrtoint target usize) % DB_ALIGNMENT == 0)
-                memcpy target data sz
-                memset (& (target @ sz)) 0 (alignedsz - sz)
-            else
-                'handle err
-            ;
-        digest20
-
-    fn... anyblob
-    case (self, data : rawstring, sz : u32, kind : Atom.Kind)
-        let digest = (makeblob self data sz)
-        Atom.ref digest kind
-
-    inline... string
-    case (self, data : rawstring, sz : u32)
-        anyblob self data sz Atom.Kind.StringRef
-    case (self, data : string)
-        let sz = (countof data)
-        assert (sz <= 0xffffffff)
-        sz := sz as u32
-        anyblob self (data as rawstring) sz Atom.Kind.StringRef
-    case (self, data : rawstring)
-        let sz = (strlen data)
-        assert (sz <= 0xffffffff)
-        sz := sz as u32
-        anyblob self data sz Atom.Kind.StringRef
-
-    inline... blob
-    case (self, data : rawstring, sz : u32)
-        anyblob self data sz Atom.Kind.BlobRef
-
-    inline... tuple
-    case (self, data : @Atom, count : u32)
-        let sz = ((sizeof Atom) * count)
-        anyblob self (bitcast data rawstring) sz Atom.Kind.TupleRef
-    case (self)
-        this-function self null 0
-
-    fn... link
-    case (self, edge : Edge, target : Atom)
-        let key = (db.Value edge)
-        'put self._txn self._db.edge key (db.Value target)
-        ;
-    case (self, source : Atom, label : Atom, target : Atom)
-        this-function self (Edge source label) target
-
-    fn... cut
-    case (self, edge : Edge)
-        let key = (db.Value edge)
-        'del self._txn self._db.edge key
-        ;
-    case (self, source : Atom, label : Atom)
-        this-function self (Edge source label)
+            raise (err as ModuleError)
+        lose self
 
 struct Module
     _env : db.Environment
     _db : Databases
 
-    inline __typecall (cls path)
-        let env = (db.Environment)
+    fn from-path (path)
+        let env =
+            try (db.Environment)
+            except (err)
+                raise (err as ModuleError)
         try
             'set-maxdbs env MAX_DBS
             'open env path db.NoSubDir

          
@@ 291,7 345,7 @@ struct Module
                     'open txn DBI_EDGE db.Create
                 'commit txn
                 return
-                    super-type.__typecall cls
+                    super-type.__typecall this-type
                         _env = env
                         _db =
                             Databases

          
@@ 300,44 354,29 @@ struct Module
                                 edge = dbi_edge
             except (err)
                 'abort txn
-                'handle err
+                raise err
         except (err)
             'close env
-            'handle err
+            raise (err as ModuleError)
+
+    inline __typecall (cls path)
+        from-path path
 
-    inline begin-view (self)
-        let txn = ('begin self._env db.ReadOnly)
-        ViewAct txn
+    inline view (self)
+        let txn =
+            try ('begin self._env db.ReadOnly)
+            except (err) (raise (err as ModuleError))
+        ViewAct txn self._db
 
-    inline begin-edit (self)
-        let txn = ('begin self._env)
-        EditAct txn
+    inline edit (self)
+        let txn =
+            try ('begin self._env)
+            except (err) (raise (err as ModuleError))
+        EditAct txn self._db
 
     inline __drop (self)
         'close self._env
 
-global active-module : (Option Module)
-
-struct Session
-    last-module : (Option Module)
-
-    inline reclaim (self)
-        let value = ('swap self.last-module none)
-        let module = ('swap active-module value)
-        lose self
-        module
-
-    inline __drop (self)
-        let value = ('swap self.last-module none)
-        'swap active-module value
-        ;
-
-typedef+ Module
-    inline select (self)
-        local session =
-            Session
-                'swap active-module self
-
 inline static-type (...)
     inline (f)
         static-typify f ...

          
@@ 345,7 384,7 @@ inline static-type (...)
 fn hash-data (sz data)
     local sha : SHA1
     'hash sha (bitcast data rawstring) (sz as u32)
-    local digest = (nullof (array u64 3))
+    local digest = (nullof Digest)
     let digest20 = (@ (bitcast &digest (mutable @SHA1.DigestType)))
     'digest sha digest20
     digest

          
@@ 353,7 392,7 @@ fn hash-data (sz data)
 struct Blob plain
     size : usize
     data : voidstar
-    digest : (array u64 3)
+    digest : Digest
 
     inline... __typecall
     case (cls, size : usize, data : voidstar)

          
@@ 364,142 403,118 @@ struct Blob plain
         local tmp = value
         this-function cls (sizeof value) &value
 
-fn no-active-module-error ()
-    hide-traceback;
-    assert false "no active module selected"
-    unreachable;
+type+ Act
+    fn... id-from-digest-key (act, key : db.Value)
+        try
+            # if this passes, it already exists
+            deref (('get act._txn act._db.hash key) as u64)
+        except (err)
+            if (err == db.NotFound)
+                0:u64
+            else
+                raise (err as ModuleError)
+
+    fn... digest-id (act, digest : Digest)
+        Id.wrap (id-from-digest-key act (digest as db.Value))
+
+    fn... load-edge (act, edge : Edge)
+        local edge = edge
+        let key = (db.Value ((sizeof TypedId) * 2) &edge.tail)
+        let content =
+            try ('get act._txn act._db.edge key)
+            except (err) (raise (err as ModuleError))
+        let contentsz source = (unpack content)
+        assert (contentsz == (sizeof TypedId))
+        source := (bitcast source @TypedId)
+        return (deref @source)
+
+    fn... load-blob (act, id : Id)
+        id := (imply (storagecast id) u64)
+        let content =
+            try ('get act._txn act._db.blob (id as db.Value))
+            except (err) (raise (err as ModuleError))
+        let contentsz source = (unpack content)
+        source := (bitcast source (mutable @u64))
+        sz := @source
+        source := (& (source @ 1))
+        source := (bitcast source (mutable rawstring))
+        Blob sz source
+
+type+ EditAct
+    fn... store-edge (act, edge : Edge)
+        local edge = edge
+        let key = (db.Value ((sizeof TypedId) * 2) &edge.tail)
+        let value = (db.Value (sizeof TypedId) &edge.head)
+        try ('put act._txn act._db.edge key value)
+        except (err) (raise (err as ModuleError))
+        return;
 
-inline with-active-module (f)
-    dispatch active-module
-    case Some (module)
-        f module
-    default
-        no-active-module-error;
+    fn... store-blob (act, blob : Blob)
+        let sz = blob.size
+        let data = blob.data
+        key := blob.digest as db.Value
+        let id = ('id-from-digest-key act key)
+        if (id != 0:u64)
+            return (Id.wrap id)
+        try
+            # need to commit a new chunk
+            let cur = (db.Cursor act._txn act._db.hash)
+            defer (inline () ('close cur))
+            try
+                # it's possible someone else has since added this blob
+                let k v = ('get cur key db.SetKey)
+                id := (deref (v as u64))
+                return (Id.wrap id)
+            except (err)
+                if (err != db.NotFound)
+                    raise err
+            # they have not - do the hard work now
+            # step 1: allocate a new id
+            let blob_cur = (db.Cursor act._txn act._db.blob)
+            defer (inline () ('close blob_cur))
+            term_id := -1:u64 as db.Value
+            let highest_id =
+                try
+                    'get blob_cur term_id db.SetRange
+                    let k v = ('get blob_cur db.Prev)
+                    deref (k as u64)
+                except (err)
+                    if (err != db.NotFound)
+                        raise err
+                    'put blob_cur term_id (db.Value)
+                    0:u64
+            id := (highest_id + 1)
+            let id_key = (db.Value id)
+            do
+                # step 2: map id to content, map hash to id
+                    the first qword of content is its actual size
+                    every blob is zero terminated
+                let alignedsz = (align-size (sz + 1) DB_ALIGNMENT)
+                local content = (db.Value (alignedsz + (sizeof u64)) null)
+                'put blob_cur id_key content db.Reserve
+                let targetsize target = (unpack content)
+                target := (bitcast target (mutable @u64))
+                @target = sz
+                target := (& (target @ 1))
+                target := (bitcast target (mutable rawstring))
+                assert ((ptrtoint target usize) % DB_ALIGNMENT == 0)
+                memcpy target data sz
+                memset (& (target @ sz)) 0 (alignedsz - sz)
+            'put act._txn act._db.hash key id_key
+            return (Id.wrap id)
+        except (err)
+            raise (err as ModuleError)
 
-let do-act =
-    inline "#hidden" (act)
-        inline "#hidden" (f)
-            try (f act)
-            except (err)
-                'abort act._txn
-                'handle err
-
-typedef+ Blob
+type+ Blob
 
     inline __== (cls T)
         static-if (cls == T)
             inline (self other)
                 self.digest == other.digest
 
-    @@ static-type Blob
-    fn store (self)
-        vvv with-active-module
-        inline "#hidden" (module)
-            let sz = self.size
-            let data = self.data
-            let key = (db.Value self.digest)
-            vvv bind id
-            do
-                let act = ('begin-view module)
-                try
-                    # if this passes, it already exists
-                    deref (('get act._txn module._db.hash key) as u64)
-                except (err)
-                    if (err == db.NotFound)
-                        0:u64
-                    else
-                        'handle err
-            if (id != 0:u64)
-                return (Id.wrap id)
-            # need to commit a new chunk
-            # now we need an edit transaction
-            vvv do-act ('begin-edit module)
-            inline "#hidden" (act)
-                let cur = (db.Cursor act._txn module._db.hash)
-                defer (inline () ('close cur))
-                try
-                    # it's possible someone else has since added this blob
-                    let k v = ('get cur key db.SetKey)
-                    id := (deref (v as u64))
-                    'abort act
-                    return (Id.wrap id)
-                except (err)
-                    if (err != db.NotFound)
-                        'handle err
-                # they have not - do the hard work now
-                # step 1: allocate a new id
-                let blob_cur = (db.Cursor act._txn module._db.blob)
-                defer (inline () ('close blob_cur))
-                let term_id = (db.Value -1:u64)
-                let highest_id =
-                    try
-                        'get blob_cur term_id db.SetRange
-                        let k v = ('get blob_cur db.Prev)
-                        deref (k as u64)
-                    except (err)
-                        if (err != db.NotFound)
-                            'handle err
-                        'put blob_cur term_id (db.Value)
-                        0:u64
-                id := (highest_id + 1)
-                let id_key = (db.Value id)
-                do
-                    # step 2: map id to content, map hash to id
-                        the first qword of content is its actual size
-                        every blob is zero terminated
-                    let alignedsz = (align-size (sz + 1) DB_ALIGNMENT)
-                    local content = (db.Value (alignedsz + (sizeof u64)) null)
-                    'put blob_cur id_key content db.Reserve
-                    let targetsize target = (unpack content)
-                    target := (bitcast target (mutable @u64))
-                    @target = sz
-                    target := (& (target @ 1))
-                    target := (bitcast target (mutable rawstring))
-                    assert ((ptrtoint target usize) % DB_ALIGNMENT == 0)
-                    memcpy target data sz
-                    memset (& (target @ sz)) 0 (alignedsz - sz)
-                'put act._txn module._db.hash key id_key
-                'commit act
-                return (Id.wrap id)
 
-#
-    inline begin-view (self)
-        let txn = ('begin self._env db.ReadOnly)
-        Act txn
-
-    inline begin-edit (self)
-        let txn = ('begin self._env)
-        Act txn
-
-    fn clear (self)
-        do-edit self
-            inline (act)
-                #'clear act
-
-    inline create (path)
-        let env = (this-type path)
-        'clear env
-        env
-
-#@@ static-type string
-#fn open (targetpath)
-    close;
-    let mod =
-        try-dbop
-            inline ()
-                Module targetpath
-    'swap active-act
-        inline (act)
-            static-if (none? act)
-            else
-                'abort act
-            try-dbop
-                inline ()
-                    'begin-edit mod
-    active-module = mod
-    ;
 
 do
-    let Module Blob
+    let Module Blob Edge TypedId Id ModuleError
 
     locals;