5ce85ea3644f — Leonard Ritter a month ago
* more work on tukan console
7 files changed, 502 insertions(+), 263 deletions(-)

A => testing/test_typeschema.sc
M testing/conspire-cl.sc => tukan-console
M tukan/GLMain.sc
A => tukan/console.sc
M tukan/main.sc
M tukan/module.sc
M tukan/view/events.sc
A => testing/test_typeschema.sc +156 -0
@@ 0,0 1,156 @@ 
+using import struct
+
+#
+    type system for conspire modules
+    the primary purpose of types is to provide encoding information for C
+    structures that can be used by a visual editor to show default editing tools
+
+    types are declared as ASCII strings:
+
+    b - bool
+    c - i8
+    h - i16
+    i - i32
+    l - i64
+    C - u8
+    H - u16
+    I - u32
+    L - u64
+    pT - pointer
+    (T...) - tuple
+    [T<hexsize>] - array
+    <T<hexsize>> - vector
+
+import UTF-8
+using import Array
+let char = UTF-8.char
+
+fn decode-schemastr (s ofs)
+    returning type i32
+    if (ofs > (countof s))
+        error "schemastr is empty"
+    c := s @ ofs
+    nextofs := ofs + 1
+    switch c
+    case (char "b") (_ bool nextofs)
+    case (char "c") (_ i8 nextofs)
+    case (char "h") (_ i16 nextofs)
+    case (char "i") (_ i32 nextofs)
+    case (char "l") (_ i64 nextofs)
+    case (char "C") (_ u8 nextofs)
+    case (char "H") (_ u16 nextofs)
+    case (char "I") (_ u32 nextofs)
+    case (char "L") (_ u64 nextofs)
+    case (char "f") (_ f32 nextofs)
+    case (char "d") (_ f64 nextofs)
+    case (char "p")
+        let T nextofs = (this-function s nextofs)
+        _ (pointer.type T) nextofs
+    case (char "(")
+        local types : (Array type)
+        loop (ofs = nextofs)
+            c := s @ ofs
+            switch c
+            case (char ")")
+                let firstval = (reftoptr (types @ 0))
+                break (sc_tuple_type ((countof types) as i32) firstval) (ofs + 1)
+            default
+                let T nextofs = (this-function s ofs)
+                assert (nextofs != ofs)
+                'append types T
+                repeat nextofs
+    default
+        error
+            .. "can't parse schemastr: " (repr s)
+
+fn... from-schemastr (s)
+    let T c = (decode-schemastr s 0)
+    assert (c == (countof s))
+    T
+
+
+fn encode-schemastr (stack T)
+    returning string
+    T := ('storageof T)
+    for i elem in (enumerate ('reverse stack))
+        if (elem == T)
+            if (i > 9)
+                error
+                    .. "recursion limit reached (" (repr i) ")"
+            return
+                hex i
+    kind := ('kind T)
+    let parent = this-function
+    inline array-like-type (open-token close-token)
+        let size = ('element-count T)
+        .. open-token
+            parent stack ('element@ T 0)
+            hex size
+            close-token
+    switch kind
+    case type-kind-tuple
+        'append stack T
+        let size = ('element-count T)
+        ..
+            fold (s = "(") for i in (range size)
+                elem := ('element@ T i)
+                .. s (this-function stack elem)
+            ")"
+    case type-kind-array
+        array-like-type "[" "]"
+    case type-kind-vector
+        array-like-type "<" ">"
+    case type-kind-integer
+        width := ('bitcount T)
+        signed := ('signed? T)
+        switch width
+        case 1 "b"
+        case 8 (? signed "c" "C")
+        case 16 (? signed "h" "H")
+        case 32 (? signed "i" "I")
+        case 64 (? signed "l" "L")
+        default
+            error
+                .. "can't handle integer bitcount: " (repr width)
+    case type-kind-real
+        width := ('bitcount T)
+        switch width
+        case 32 "f"
+        case 64 "d"
+        default
+            error
+                .. "can't handle real bitcount: " (repr width)
+    case type-kind-pointer
+        .. "p" (this-function stack ('element@ T 0))
+    default
+        error
+            .. "can't handle kind: " (repr kind)
+
+fn schemastr (T)
+    local stack : (Array type)
+    encode-schemastr stack T
+
+struct Foo
+
+struct Tree
+    child : @Foo
+
+struct Foo
+    child : @Tree
+
+s :=
+    schemastr Tree
+print s
+#print
+    from-schemastr s
+
+#type PersistentArray
+    @@ memo
+    inline __typecall (cls T)
+        struct (.. "<PersistentArray " (tostring T) ">")
+            content : voidstar
+
+
+
+#dump
+    PersistentArray i32
  No newline at end of file

          
M testing/conspire-cl.sc => tukan-console +5 -252
@@ 1,254 1,7 @@ 
 #!/usr/bin/env scopes
-using import console
-using import ...conspire.module
-
-#
-    inline static-type (...)
-        inline (f)
-            static-typify f ...
-
-    inline try-dbop (f ...)
-        try
-            f ...
-        except (err)
-            error (err as string)
-
-    @@ static-type ()
-    fn close ()
-        'swap active-act
-            inline (act)
-                static-if (none? act)
-                else
-                    'abort act
-        active-module = none
-
-    @@ static-type ()
-    fn clear ()
-        dispatch active-act
-        case Some (act)
-            try-dbop
-                inline ()
-                    'clear act
-        default;
-
-    @@ static-type ()
-    fn commit ()
-        dispatch active-module
-        case Some (mod)
-            'swap active-act
-                inline (act)
-                    static-if (none? act)
-                    else
-                        try
-                            'commit act
-                        except (err)
-                            'abort act
-                            error (err as string)
-                    try-dbop
-                        inline ()
-                            'begin-edit mod
-        default;
-
-    @@ static-type ()
-    fn abort ()
-        dispatch active-module
-        case Some (mod)
-            'swap active-act
-                inline (act)
-                    static-if (none? act)
-                    else
-                        'abort act
-                    try-dbop
-                        inline ()
-                            'begin-edit mod
-        default;
-
-    inline transaction-error ()
-        hide-traceback;
-        error "no active transaction available"
-
-    inline with-module (f)
-        dispatch active-module
-        case Some (mod)
-            try-dbop f mod
-        default
-            transaction-error;
-
-    inline with-act (f)
-        dispatch active-act
-        case Some (act)
-            try-dbop f act
-        default
-            transaction-error;
-
-    inline with-module-act (f)
-        dispatch active-module
-        case Some (mod)
-            dispatch active-act
-            case Some (act)
-                try-dbop f mod act
-            default
-                transaction-error;
-        default
-            transaction-error;
-
-    @@ static-type string
-    fn makestring (str)
-        with-act
-            inline (act)
-                'string act str
-
-    inline maketuple (...)
-        with-act
-            inline (act)
-                local atoms = (arrayof Atom ...)
-                'tuple act &atoms (va-countof ...)
-
-    inline... makenumber
-    case (value : integer,)
-        value as Atom
-    case (value : real,)
-        value as Atom
-
-    fn... link
-    case (source : Atom, label : Atom, target : Atom)
-        with-act
-            inline (act)
-                'link act source label target
-    case (edge : Edge, target : Atom)
-        with-act
-            inline (act)
-                'link act edge target
 
-    fn... cut
-    case (source : Atom, label : Atom)
-        with-act
-            inline (act)
-                'cut act source label
-    case (edge : Edge,)
-        with-act
-            inline (act)
-                'cut act edge
-
-    spice follow2 (value)
-        let value = (value as Atom)
-        print value
-        spice-quote
-            print "hello"
-
-    fn... follow
-    case (source : Atom, label : Atom)
-        with-act
-            inline (act)
-                'follow act source label
-    case (edge : Edge,)
-        with-act
-            inline (act)
-                'follow act edge
-    case (value : Atom,)
-        with-act
-            inline (act)
-                let k = ('kind value)
-                switch k
-                #pass Kind.StringRef
-                #pass Kind.BlobRef
-                case Atom.Kind.TupleRef
-                    let count atoms = ('deref-tuple act value)
-                    sc_argument_list_map_new (count as i32)
-                        inline (i)
-                            atoms @ i
-                default
-                    `value
-
-    @@ static-type ()
-    fn print-stats ()
-        with-module-act
-            inline (mod act)
-                inline dump-fields (info)
-                    va-map
-                        inline (T)
-                            let key = (keyof T)
-                            print key
-                                getattr info key
-                        elementsof (typeof info)
-                print "env info:"
-                dump-fields ('info mod._env)
-                print;
-                print "env stat:"
-                dump-fields ('stat mod._env)
-                print;
-                print "blob db stat:"
-                dump-fields ('stat act._txn mod._db.blob)
-                print;
-                print "edge db stat:"
-                dump-fields ('stat act._txn mod._db.edge)
-
-#-------------------------------------------------------------------------------
-
-# build scope with which we're going to evaluate commands
-let repl-scope =
-    do
-        #let open clear close commit link cut follow abort follow2
-        #let
-            string = makestring
-            symbol = Atom.symbol
-            tuple = maketuple
-            number = makenumber
-            none = (none as Atom)
-            stats = print-stats
-            edge = Edge
-        #let
-            s = symbol
-            t = tuple
-            n = number
-        # must keep sugar support
-        indirect-let list-handler-symbol
-        let sugar-quote
-        locals;
-
-let scope =
-    repl-scope
-    # use the line below to prepend your symbols to existing globals
-    #.. repl-scope
-        globals;
-
-#-------------------------------------------------------------------------------
-
-let source-path argc argv = (script-launch-args)
-
-if (argc < 1)
-    print
-        .. "syntax: " source-path " path/to/database [command ...]"
-    exit -1
-
-open (string (argv @ 0))
-
-# transform command line to symbolic list
-let cmd =
-    fold (cmd = '()) for i in (rrange 1 argc)
-        let arg = (argv @ i)
-        let str = (string arg)
-        let val =
-            if (i == 1) `[(Symbol str)]
-            else `str
-        cons val cmd
-
-# if no shell command has been issued, enter REPL console
-if (cmd == '())
-    print "Conspire REPL"
-    read-eval-print-loop scope false
-        .. cache-dir "/conspire.history"
-    close;
-    exit 0
-
-# otherwise evaluate command (which includes compilation)
-let f =
-    try
-        sc_eval unknown-anchor (list cmd) scope
-    except (err)
-        print
-            'format err
-        exit -1
-run-stage;
-# and execute it in the next stage
-f;
+hide-traceback;
+load-module ""
+    find-module-path module-dir ".tukan.console"
+    scope = (__this-scope)
+    main-module? = true

          
M tukan/GLMain.sc +8 -0
@@ 4,6 4,7 @@ import .stage
 using import glm
 using import FunctionChain
 using import struct
+using import property
 
 using import .gl
 using import .sdl

          
@@ 88,6 89,13 @@ struct GLMain
         stage.init-gfx (glmain = self)
         self
 
+    title :=
+        property
+            inline (self)
+                SDL_GetWindowTitle self.window
+            inline (self title)
+                SDL_SetWindowTitle self.window title
+
     inline handle-events (self)
         local event = (SDL_Event)
         loop (quit = false)

          
A => tukan/console.sc +260 -0
@@ 0,0 1,260 @@ 
+using import console
+using import Option
+using import .module
+
+#
+    inline static-type (...)
+        inline (f)
+            static-typify f ...
+
+    inline try-dbop (f ...)
+        try
+            f ...
+        except (err)
+            error (err as string)
+
+    @@ static-type ()
+    fn close ()
+        'swap active-act
+            inline (act)
+                static-if (none? act)
+                else
+                    'abort act
+        active-module = none
+
+    @@ static-type ()
+    fn clear ()
+        dispatch active-act
+        case Some (act)
+            try-dbop
+                inline ()
+                    'clear act
+        default;
+
+    @@ static-type ()
+    fn commit ()
+        dispatch active-module
+        case Some (mod)
+            'swap active-act
+                inline (act)
+                    static-if (none? act)
+                    else
+                        try
+                            'commit act
+                        except (err)
+                            'abort act
+                            error (err as string)
+                    try-dbop
+                        inline ()
+                            'begin-edit mod
+        default;
+
+    @@ static-type ()
+    fn abort ()
+        dispatch active-module
+        case Some (mod)
+            'swap active-act
+                inline (act)
+                    static-if (none? act)
+                    else
+                        'abort act
+                    try-dbop
+                        inline ()
+                            'begin-edit mod
+        default;
+
+    inline transaction-error ()
+        hide-traceback;
+        error "no active transaction available"
+
+    inline with-module (f)
+        dispatch active-module
+        case Some (mod)
+            try-dbop f mod
+        default
+            transaction-error;
+
+    inline with-act (f)
+        dispatch active-act
+        case Some (act)
+            try-dbop f act
+        default
+            transaction-error;
+
+    inline with-module-act (f)
+        dispatch active-module
+        case Some (mod)
+            dispatch active-act
+            case Some (act)
+                try-dbop f mod act
+            default
+                transaction-error;
+        default
+            transaction-error;
+
+    @@ static-type string
+    fn makestring (str)
+        with-act
+            inline (act)
+                'string act str
+
+    inline maketuple (...)
+        with-act
+            inline (act)
+                local atoms = (arrayof Atom ...)
+                'tuple act &atoms (va-countof ...)
+
+    inline... makenumber
+    case (value : integer,)
+        value as Atom
+    case (value : real,)
+        value as Atom
+
+    fn... link
+    case (source : Atom, label : Atom, target : Atom)
+        with-act
+            inline (act)
+                'link act source label target
+    case (edge : Edge, target : Atom)
+        with-act
+            inline (act)
+                'link act edge target
+
+    fn... cut
+    case (source : Atom, label : Atom)
+        with-act
+            inline (act)
+                'cut act source label
+    case (edge : Edge,)
+        with-act
+            inline (act)
+                'cut act edge
+
+    spice follow2 (value)
+        let value = (value as Atom)
+        print value
+        spice-quote
+            print "hello"
+
+    fn... follow
+    case (source : Atom, label : Atom)
+        with-act
+            inline (act)
+                'follow act source label
+    case (edge : Edge,)
+        with-act
+            inline (act)
+                'follow act edge
+    case (value : Atom,)
+        with-act
+            inline (act)
+                let k = ('kind value)
+                switch k
+                #pass Kind.StringRef
+                #pass Kind.BlobRef
+                case Atom.Kind.TupleRef
+                    let count atoms = ('deref-tuple act value)
+                    sc_argument_list_map_new (count as i32)
+                        inline (i)
+                            atoms @ i
+                default
+                    `value
+
+    @@ static-type ()
+    fn print-stats ()
+        with-module-act
+            inline (mod act)
+                inline dump-fields (info)
+                    va-map
+                        inline (T)
+                            let key = (keyof T)
+                            print key
+                                getattr info key
+                        elementsof (typeof info)
+                print "env info:"
+                dump-fields ('info mod._env)
+                print;
+                print "env stat:"
+                dump-fields ('stat mod._env)
+                print;
+                print "blob db stat:"
+                dump-fields ('stat act._txn mod._db.blob)
+                print;
+                print "edge db stat:"
+                dump-fields ('stat act._txn mod._db.edge)
+
+#-------------------------------------------------------------------------------
+
+global g_module : (Option Module)
+
+
+#-------------------------------------------------------------------------------
+
+# build scope with which we're going to evaluate commands
+let repl-scope =
+    do
+        #let open clear close commit link cut follow abort follow2
+        #let
+            string = makestring
+            symbol = Atom.symbol
+            tuple = maketuple
+            number = makenumber
+            none = (none as Atom)
+            stats = print-stats
+            edge = Edge
+        #let
+            s = symbol
+            t = tuple
+            n = number
+        # must keep sugar support
+        #indirect-let list-handler-symbol
+        #let sugar-quote
+        locals;
+
+let scope =
+    #repl-scope
+     use the line below to prepend your symbols to existing globals
+    .. repl-scope
+        globals;
+
+#-------------------------------------------------------------------------------
+
+let source-path argc argv = (script-launch-args)
+
+if (argc < 1)
+    print
+        .. "syntax: " source-path " path/to/database [command ...]"
+    exit -1
+
+#open (string (argv @ 0))
+
+# transform command line to symbolic list
+let cmd = '()
+let cmd =
+    fold (cmd = '()) for i in (rrange 1 argc)
+        let arg = (argv @ i)
+        let str = (string arg)
+        let val =
+            if (i == 1) `[(Symbol str)]
+            else `str
+        cons val cmd
+
+# if no shell command has been issued, enter REPL console
+if (cmd == '())
+    print "Conspire REPL"
+    read-eval-print-loop scope false
+        .. cache-dir "/conspire.history"
+    #close;
+    exit 0
+
+# otherwise evaluate command (which includes compilation)
+let f =
+    try
+        sc_eval unknown-anchor (list cmd) scope
+    except (err)
+        print
+            'format err
+        exit -1
+run-stage;
+# and execute it in the next stage
+f;

          
M tukan/main.sc +70 -10
@@ 1,5 1,8 @@ 
 #!/usr/bin/env scopes
 
+using import struct
+
+using import Option
 using import Capture
 using import Map
 

          
@@ 7,24 10,68 @@ using import .GLMain
 using import .DockGUI
 
 using import .imgui
+using import .nfd
+using import .module
 
 using import .view.events
 
-using import .view.blocktree
-using import .view.shader
-using import .view.hexedit
+#using import .view.blocktree
+#using import .view.shader
+#using import .view.hexedit
+
+#-------------------------------------------------------------------------------
+
+let OptModule = (Option Module)
+
+struct App
+    path : string = (string "")
+    module : OptModule
+
+    fn init (self)
+        on-module-changed self
 
-vvv bind glmain
-GLMain
-    title = "Tukan"
-    width = 960
-    height = 540
-    resizable = true
+    fn new-module (self path)
+        try
+            module :=
+                (Module.from-path path) as OptModule
+            self.path = (string path)
+            self.module = module
+            on-module-changed self
+        except (err)
+            self.module = none as OptModule
+            self.path = (string "")
+            on-module-changed self
+            raise err
+        ;
+
+global app : App
+
+#-------------------------------------------------------------------------------
+
+fn handle-gui-error (err)
+    print "error:" err
+
+#-------------------------------------------------------------------------------
+
+global glmain =
+    GLMain
+        title = "Tukan"
+        width = 960
+        height = 540
+        resizable = true
 
 DockGUI glmain
 
 #-------------------------------------------------------------------------------
 
+@@ 'on on-module-changed
+inline (app)
+    let title =
+        if (empty? app.path) "Tukan"
+        else
+            .. app.path " - Tukan"
+    glmain.title = title
+
 global test-window-visible = false
 @@ 'on DockGUI.on-define-windows
 inline ()

          
@@ 33,6 80,18 @@ inline ()
 
 @@ 'on DockGUI.on-define-main-menu
 inline ()
+    if (WithMenu "File")
+        if (MenuItem "New Module")
+            local target_path : (mutable rawstring)
+            let result =
+                NFD_SaveDialog "tuk"
+                    module-dir
+                    &target_path
+            if (result as integer == 1)
+                try
+                    'new-module app target_path
+                except (err)
+                    handle-gui-error err
     if (WithMenu "View")
         MenuItem "Show Demo Window"
             selected = test-window-visible

          
@@ 48,8 107,9 @@ fn (s size)
 
 print "running main program"
 
+'init app
 'run glmain
 
-drop glmain
+__drop glmain
 
 print "done."

          
M tukan/module.sc +2 -1
@@ 15,7 15,8 @@ let db = (import .db)
         Hash DB: SHA-1 Hash (u160) -> Id (u32)
 
         mutable:
-        Edge DB: Edge IdId IdId (2 x u64) -> IdId (u64)
+        Edge DB: IdId IdId (2 x u64) -> IdId (u64)
+                 TypeId TypeId Id u32 (4 x u32) -> TypeId Id (u64)
 
     All keys and values are aigned to 8 bytes.
 

          
M tukan/view/events.sc +1 -0
@@ 2,5 2,6 @@ 
 using import FunctionChain
 
 fnchain on-define-view-menu
+fnchain on-module-changed
 
 locals;