gdjn  Check-in [351bb17bed]

%toc
#top gdjn
allow use of Godot 4 with a [^civ civilized] scripting language, viz. [>janet Janet].

	janet: https://janet-lang.org
	godot: https://godotengine.org



@civ {
	to meet the bare minimum standards necessary to qualify as [!civilized] to my mind, a language must:
	* support compilation, whether to bytecode or machine code (excludes gdscript)
	* parse into an AST (excludes bash, php (or used to))
	* support AST-rewriting macros (excludes everything outside the lisp family except maybe rust)
	* use real syntax, not whitespace-based kludges (excludes python, gdscript inter alia)

#top gdjn
allow use of Godot 4 with a [^civ civilized] scripting language, viz. [>janet Janet].

	janet: https://janet-lang.org
	godot: https://godotengine.org

%toc

@civ {
	to meet the bare minimum standards necessary to qualify as [!civilized] to my mind, a language must:
	* support compilation, whether to bytecode or machine code (excludes gdscript)
	* parse into an AST (excludes bash, php (or used to))
	* support AST-rewriting macros (excludes everything outside the lisp family except maybe rust)
	* use real syntax, not whitespace-based kludges (excludes python, gdscript inter alia)

	};
	impl _set_path(string path, bool takeOver) {
		if (takeOver) {
			_t(string).dtor(&me -> path);
			me -> path = path;
		} else {
			_t(string).dtor(&me -> path);
			_t(string).copy(&me -> path, (void const*[]) {&path});

		}
	};
	impl _get_base_script() -> ref Script {
		return nullptr;
	};
	impl _has_static_method(string-name method) -> bool {
		return false;
	};
	impl _is_tool() -> bool { return false; }; (* FIXME *)





















};

class JanetScriptText extends JanetScript {
	var as string: src;
	new {
		_t(string).empty(&me -> src, nullptr);
	};
	del {
		_t(string).dtor(&me -> src);
	};

	impl _get_instance_base_type() -> string-name {
		return _gdu_intern("ScriptExtension");
	};
	impl _has_source_code() -> bool   { return true; };
	impl _get_source_code() -> string {
		auto d = gdu_string_dup(&me -> src);
		return d;
	};
	impl _set_source_code(string s) {
		_t(string).dtor(&me -> src);
		_t(string).copy(&me -> src, (void const*[]) {&s});
	};











};

class JanetScriptImage extends JanetScript {
	impl _has_source_code() -> bool { return false; };
	var struct gdjn_class_JanetScript_image {
		size_t   sz;
		uint8_t* buf;
	}: image;
	impl _get_instance_base_type() -> string-name {
		return _gdu_intern("ScriptExtension");
	};



};

	};
	impl _set_path(string path, bool takeOver) {
		if (takeOver) {
			_t(string).dtor(&me -> path);
			me -> path = path;
		} else {
			_t(string).dtor(&me -> path);
			/* _t(string).copy(&me -> path, (void const*[]) {&path}); */
			me -> path = gdu_string_dup(&path);
		}
	};
	impl _get_base_script() -> ref Script {
		return nullptr;
	};
	impl _has_static_method(string-name method) -> bool {
		return false;
	};
	impl _is_tool() -> bool { return false; }; (* FIXME *)
	impl _get_global_name(string-name id) -> string-name {
		return gdu_sym_null();
	};
	impl _is_abstract() -> bool {
		return false; (* TODO abuse for non-class scripts? *)
	};
	impl _get_instance_base_type() -> string-name {
		return _gdu_intern("Object");
	};
	impl _is_valid() -> bool {
		return true;
	};
	impl _get_documentation() -> array[dictionary] {
		gd_array dox;
		_t(array).empty(&dox, nullptr);
		auto empty = gdu_sym_null();
		_t(array).setTyped(&dox,
			GDEXTENSION_VARIANT_TYPE_DICTIONARY, &empty, &empty);
		_t(stringName).dtor(&empty);
		return dox;
	};
};

class JanetScriptText extends JanetScript {
	var as string: src;
	new {
		_t(string).empty(&me -> src, nullptr);
	};
	del {
		_t(string).dtor(&me -> src);
	};




	impl _has_source_code() -> bool   { return true; };
	impl _get_source_code() -> string {
		auto d = gdu_string_dup(&me -> src);
		return d;
	};
	impl _set_source_code(string s) {
		_t(string).dtor(&me -> src);
		_t(string).copy(&me -> src, (void const*[]) {&s});
	};
	impl _reload(bool keepState) -> int (* Error *) {
		(* TODO *)
		return gd_Error_ok;
	};
};

import {
	typedef struct gdjn_janet_image {
		size_t   sz;
		uint8_t* buf;
	} gdjn_janet_image;
};

class JanetScriptImage extends JanetScript {
	impl _has_source_code() -> bool { return false; };
	var gdjn_janet_image: image;
	new {
		me -> image = (gdjn_janet_image) {};
	};
	del {
		if (me -> image.buf != nullptr) _free(me -> image.buf);
	};
	impl _reload(bool keepState) -> int (* Error *) {
		(* TODO *)
		return gd_Error_ok;
	};
};

		gd_refCounted_reference(fd);

		if (_gdu_objIs(res, JanetScriptText)) {
			auto asText = gdu_cast(res, "JanetScriptText");
			gd_string src = gd_script_getSourceCode(asText);
			gd_fileAccess_storeString(fd, src);
			_t(string).dtor(&src);

		} else if (_gdu_objIs(res, JanetScriptImage)) {
			auto asImg = gdu_cast(res, "JanetScriptImage");

		};

		gd_fileAccess_close(fd);
		_t(string).dtor(&path_mine);
		gd_refCounted_unreference(fd);
		gd_refCounted_unreference(res);
	};
};

		gd_refCounted_reference(fd);

		if (_gdu_objIs(res, JanetScriptText)) {
			auto asText = gdu_cast(res, "JanetScriptText");
			gd_string src = gd_script_getSourceCode(asText);
			gd_fileAccess_storeString(fd, src);
			_t(string).dtor(&src);
			auto data = gdjn_class_JanetScriptText_data(res);
		} else if (_gdu_objIs(res, JanetScriptImage)) {
			auto asImg = gdu_cast(res, "JanetScriptImage");
			auto data = gdjn_class_JanetScriptImage_data(res);
		};

		gd_fileAccess_close(fd);
		_t(string).dtor(&path_mine);
		gd_refCounted_unreference(fd);
		gd_refCounted_unreference(res);
	};
};

	return r;
}

static inline gd_stringName
gdu_intern (const char* str) {
	return gdu_intern_sz(str, 0);
}















static inline gd_string
gdu_str_sz (const char* str, const size_t sz) {
	gd_string r = {};
	if (sz == 0) _t(string).newWithUtf8Chars(&r, str);
	        else _t(string).newWithUtf8CharsAndLen(&r, str, sz);
	return r;

	return r;
}

static inline gd_stringName
gdu_intern (const char* str) {
	return gdu_intern_sz(str, 0);
}

static inline gd_stringName
gdu_sym_null(void) {
	gd_stringName n;
	_t(stringName).empty(&n, nullptr);
	return n;
}

static inline gd_string
gdu_str_null(void) {
	gd_string n;
	_t(string).empty(&n, nullptr);
	return n;
}

static inline gd_string
gdu_str_sz (const char* str, const size_t sz) {
	gd_string r = {};
	if (sz == 0) _t(string).newWithUtf8Chars(&r, str);
	        else _t(string).newWithUtf8CharsAndLen(&r, str, sz);
	return r;

						  register-extension-class-method
						  register-extension-class-virtual-method
						  get-method-bind
						  get-class-tag
						 [construct-object 2]]}
	{:id object :binds [set-instance
						set-instance-binding

						get-class-name
						cast-to
						has-script-method
						call-script-method
						method-bind-ptrcall
						destroy
						]}
................................................................................
			(with-names ln
				[["className"  (:tall  i)]
				 ["methodName" (:sulk m)]]
				(fn [] 
					(ln (string
							"auto ptr = t -> gd_classdb.getMethodBind(&className, &methodName, %d);\n"
							"\tt -> %s.%s_ptr = ptr;\n"
							"\t"`printf("* bind method %s.%s (%%p)\n",ptr);` "\n"
							"\tassert(ptr != nullptr);")
					(method :hash)
					ctr-id    (:name m)
					(:name i) (:name m)
					))))
		(add-ctors i (i :ctors))
		(add (api :decls) "} %s;" ctr-id))

						  register-extension-class-method
						  register-extension-class-virtual-method
						  get-method-bind
						  get-class-tag
						 [construct-object 2]]}
	{:id object :binds [set-instance
						set-instance-binding
						get-instance-binding
						get-class-name
						cast-to
						has-script-method
						call-script-method
						method-bind-ptrcall
						destroy
						]}
................................................................................
			(with-names ln
				[["className"  (:tall  i)]
				 ["methodName" (:sulk m)]]
				(fn [] 
					(ln (string
							"auto ptr = t -> gd_classdb.getMethodBind(&className, &methodName, %d);\n"
							"\tt -> %s.%s_ptr = ptr;\n"
							#"\t"`printf("* bind method %s.%s (%%p)\n",ptr);` "\n"
							"\tassert(ptr != nullptr);")
					(method :hash)
					ctr-id    (:name m)
					(:name i) (:name m)
					))))
		(add-ctors i (i :ctors))
		(add (api :decls) "} %s;" ctr-id))

#  🄯 AGPLv3
#  ? compiles a godot class definition to C source
#  > janet tool/class-compile.janet <class> (loader|header)

(def *src-file* (gensym))

(def parse-doc
	(do
		(def doc-parser (peg/compile '{
			:hs          (+ " " "\t")
			:-           "-"
			:open-line   (* (? " ") (? '(some (if-not "\n" 1))) "\n")
			:single-line (* (? " ") (? '(some (* (not :hs) 1))) (any :hs) -1)
			:mid-line    (+ (* (any :hs) :- (? " ")
			                   (? '(some (if-not "\n" 1))) "\n")
			                (* (? '(some (if-not "\n" 1))) "\n"))
................................................................................
			:close-line  (+ (* (any :hs) -1)
							(* (any :hs) :- (? " ")
							   (? '(some (if-not (* (any :hs) -1) 1)))
			                   (any :hs) -1))
			:main        (+ (* :open-line (any :mid-line) :close-line)
			                :single-line
							'(any 1)) # admit defeat
	   }))

		(fn parse-doc[str]
			(peg/match doc-parser str))))

(def syntaxes
	(do (def quot-syntax
			'(nth 1 (unref (* (<- (+ `"` `'`) :quo)
................................................................................
					(string "\t.has_return_value = "
							(if (= :void (f :ret)) "false" "true") ",")
					(string "\t.call_func = " invocant ",")
					(string "\t.ptrcall_func = " invocant-ptr ",")
				] [])
				;ret-info
				`};`
				(string `printf("binding method %s\n",`
						(string/format "%q" fn-path)
						`);`)
				(string `_t(classdb).`
						(case kind
							:method "registerExtensionClassMethod"
							:impl "registerExtensionClassVirtualMethod")
						`(gdjn_ctx -> gd.lib, &s_className, &info);`)))
	   (array/concat @[] "{" ;(with-names [:s_className (class :id)]
				 ;(map |(bind $ :method) (class :methods))
................................................................................
						   ;(if (= :native (c :base-mode))
							   (with-names ["superName" (c :base)]
								   "super = _t(classdb).constructObject(&superName);")
							   [(string/format "super = %s_create();"
											   id-base)])
						   "return super;"))


		(array/push (unit :funcs)
					(:dec <func-c> self-ref-t id-ctor []
					  (string "typeof("id")* me = _alloc("id", 1);")
					  ;(with-names ["className" (c :id)]
						   (string/format "auto gdobj = %s();"
										  id-create)
						   `printf("constructed super object %p\n", gdobj);`
						   "_t(object).setInstance(gdobj, &className, me);"







						   (string id-init "(me, gdobj);"))
					  "return me;"))
		(push-event :dtor id-dtor :void
					[[:void* :_data]
					 [:GDExtensionClassInstancePtr :_ptr_me]]
					|[(string "typeof("id")* me = _ptr_me;")
					  ;$
					  "_free(me);"])
		(def id-virt (class-prefix (c :cursor) (c :id) "virt"))









		(array/push (unit :funcs) (:dec- <func-c> :void* id-virt
			 [[:void* :data]
			  [:GDExtensionConstStringNamePtr :method]
			  [:uint32_t :hash]]
			 `bool res = false;`
			 ;(catseq [[name idx] :pairs (c :vtbl-map)] [

#  🄯 AGPLv3
#  ? compiles a godot class definition to C source
#  > janet tool/class-compile.janet <class> (loader|header)

(def *src-file* (gensym))

(def parse-doc

	(do (def doc-parser (peg/compile '{
			:hs          (+ " " "\t")
			:-           "-"
			:open-line   (* (? " ") (? '(some (if-not "\n" 1))) "\n")
			:single-line (* (? " ") (? '(some (* (not :hs) 1))) (any :hs) -1)
			:mid-line    (+ (* (any :hs) :- (? " ")
			                   (? '(some (if-not "\n" 1))) "\n")
			                (* (? '(some (if-not "\n" 1))) "\n"))
................................................................................
			:close-line  (+ (* (any :hs) -1)
							(* (any :hs) :- (? " ")
							   (? '(some (if-not (* (any :hs) -1) 1)))
			                   (any :hs) -1))
			:main        (+ (* :open-line (any :mid-line) :close-line)
			                :single-line
							'(any 1)) # admit defeat
		}))

		(fn parse-doc[str]
			(peg/match doc-parser str))))

(def syntaxes
	(do (def quot-syntax
			'(nth 1 (unref (* (<- (+ `"` `'`) :quo)
................................................................................
					(string "\t.has_return_value = "
							(if (= :void (f :ret)) "false" "true") ",")
					(string "\t.call_func = " invocant ",")
					(string "\t.ptrcall_func = " invocant-ptr ",")
				] [])
				;ret-info
				`};`
				(comment (string `printf("binding method %s\n",`
						(string/format "%q" fn-path)
						`);`))
				(string `_t(classdb).`
						(case kind
							:method "registerExtensionClassMethod"
							:impl "registerExtensionClassVirtualMethod")
						`(gdjn_ctx -> gd.lib, &s_className, &info);`)))
	   (array/concat @[] "{" ;(with-names [:s_className (class :id)]
				 ;(map |(bind $ :method) (class :methods))
................................................................................
						   ;(if (= :native (c :base-mode))
							   (with-names ["superName" (c :base)]
								   "super = _t(classdb).constructObject(&superName);")
							   [(string/format "super = %s_create();"
											   id-base)])
						   "return super;"))

		(def icb-null "(&(GDExtensionInstanceBindingCallbacks){})")
		(array/push (unit :funcs)
					(:dec <func-c> self-ref-t id-ctor []
					  (string "typeof("id")* me = _alloc("id", 1);")
					  ;(with-names ["className" (c :id)]
						   (string/format "auto gdobj = %s();"
										  id-create)
						   #`printf("constructed super object %p\n", gdobj);`
						   "_t(object).setInstance(gdobj, &className, me);"
						   # register the instance as a binding so
						   # that other classes can access it. this
						   # is so dumb
						   "_t(object).setInstanceBinding("
						   "	gdobj, gdjn_ctx -> gd.lib, me,"
								icb-null
						   ");"
						   (string id-init "(me, gdobj);"))
					  "return me;"))
		(push-event :dtor id-dtor :void
					[[:void* :_data]
					 [:GDExtensionClassInstancePtr :_ptr_me]]
					|[(string "typeof("id")* me = _ptr_me;")
					  ;$
					  "_free(me);"])
		(def id-virt (class-prefix (c :cursor) (c :id) "virt"))
		(array/push (unit :funcs)
					(:dec* <func-c> [:inline :static]
						   self-ref-t (string id "_data")
						  [[:GDExtensionObjectPtr :self]]
						  "return _t(object).getInstanceBinding("
						  "	self, gdjn_ctx -> gd.lib,"
							icb-null
						  ");"))

		(array/push (unit :funcs) (:dec- <func-c> :void* id-virt
			 [[:void* :data]
			  [:GDExtensionConstStringNamePtr :method]
			  [:uint32_t :hash]]
			 `bool res = false;`
			 ;(catseq [[name idx] :pairs (c :vtbl-map)] [