# [ʞ] lib/core.janet
#  ~ lexi hale <lexi@hale.su>
#  🄯 AGPLv3
#  ? provides a nicer interface to gdprims
#  > (import :/lib/core)

(import /lib/prim)

# this parameter controls the class to inherit from
# when a superclass is not explicitly specified.
# this should be set to point at RefCounted
(def *class-base* (gensym))
(def *class-path* (gensym))

(def- valid-class-flags
	(do (def list [:abstract :final])
		(tabseq [f :in list] f true)))

(defn- assemble-meta [args]
	(defn recurse [acc dox t & r]
		(cond
			(string? t)
				(recurse acc [;dox t] ;r)
			(or (struct?  t)
				(keyword? t))
				(recurse [;acc t] dox ;r)
			[[;(if (empty? dox) []
				   [{:doc (string/join dox)}])
			  ;acc] t ;r]))
	(recurse [] [] ;args))

(defmacro class [name & dfn]
	(def def-map (tuple tuple (dyn *current-file*)
	                   ;(tuple/sourcemap (dyn :macro-form))))
	(defn mapped-val [val]
		@{:value val
		 :source-map def-map})
	(var spec dfn)
	(var super (dyn *class-base*))
	(var export-name (string name))
	# documentation is stored differently for classes,
	# as godot needs to be able to retrieve the text
	# from a reference to @scope
	(def dox @[])
	(def mode @{})

	(forever
		(match spec
			[:is super_ & r] # set superclass
				(do (set super (eval super_)) 
					(set spec r))

			[:as ident & r]
				(do (set export-name (string ident))
					(set spec r))

			([m & r] (has-key? valid-class-flags m))
				(do (put mode m true)
					(set spec r))

			([x & r] (string? x)) # docstring
				(do (array/push dox x)
					(set spec r))

			_ (break)))

	(def doc-str (string/join dox))
	(def body spec)
	(with-dyns [*class-path*
				[;(or (dyn *class-path*) []) name]]
	(with-syms [$local-env $parent-env $form]
			~(let [,$parent-env (or @scope (curenv))
				   ,$local-env (,table/setproto
						@{ '@name    ,(mapped-val (keyword name))
						   '@gd-id   ,(mapped-val (string export-name))
						   '@inherit ,(mapped-val super)
						   '@mode    ,(mapped-val mode)
						   '@doc     ,(if (empty? dox) nil
										  (mapped-val doc-str))}
						,$parent-env)
				  ,name ,$local-env]
				  (,put ,$local-env '@scope @{:value ,$local-env})

				  # *self* can be used to access statics
				  (put ,$local-env '@self @{:value
					   (fn @self[& x]
						   (get-in ,$local-env [;x :value]))})
				  (each ,$form ',body 
					  (,eval ,$form ,$local-env))
				  ,$local-env))))

(defn- member [& x]
	(string/join [;(or (dyn *class-path*) [])
				  ;x] "."))

(defmacro defclass* [id meta & r]
	~(def ,id ,;meta (class ,id ,;r)))

(defmacro defclass  [id & r] ~(defclass* ,id [] ,;r))
(defmacro defclass- [id & r] ~(defclass* ,id [:private] ,;r))

(defn- parse-sig [sig]
	(match sig
		([ty id dox & r] (string? dox))
		 [{:type (eval ty) :id id :doc dox}
		  ;(parse-sig r)]
		[ty id & r] [{:type (eval ty) :id id}
					 ;(parse-sig r) ]
		_ []))

(defmacro defm [id & rest]
	(def (meta ret sig & body) (assemble-meta rest))
	(def args (parse-sig sig))
	(def md [;meta :method {:sig args :ret (eval ret)}])
	(def arg-names ['me ;(map (fn [{:id id}] id) args)])
	(def path (symbol (member id)))
	~(def ,id ,;md (fn ,path ,arg-names ,;body)))

(defmacro defm- [id & r] ~(defm ,id :private ,;r))

(defmacro prop [id & args]
	(def (meta-list ty init-val)
		(assemble-meta args))
	(assert init-val "property missing initial value")
	~(def ,id :prop {:type ,ty} ,;meta-list ,init-val))

(defmacro const [id & args]
	(def (meta-list ty init-val)
		(assemble-meta args))
	(assert init-val "constant missing value")
	~(def ,id :const {:type ,ty} ,;meta-list ,init-val))

(defmacro hoist [ids & body]
	~(upscope (def ,ids
				  (do ,;body
					  ,ids))))
