# [ʞ] 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))))