diff options
Diffstat (limited to 'stdlib/source/lux/paradigm/object.lux')
| -rw-r--r-- | stdlib/source/lux/paradigm/object.lux | 178 |
1 files changed, 178 insertions, 0 deletions
diff --git a/stdlib/source/lux/paradigm/object.lux b/stdlib/source/lux/paradigm/object.lux new file mode 100644 index 000000000..ae742fac7 --- /dev/null +++ b/stdlib/source/lux/paradigm/object.lux @@ -0,0 +1,178 @@ +(;module: + lux + (lux (control monad) + (data text/format + [product] + (coll [list "L/" Functor<List> Monoid<List>])) + [macro #+ Monad<Lux>] + (macro [code] + ["s" syntax #+ syntax: "s/" Monad<Syntax>] + (syntax [common])))) + +(type: #export (Class interface) + (Ex [state] [(interface state) state])) + +(type: Declaration + [Text (List Text)]) + +(type: Reference + [Ident (List Code)]) + +(type: Alias Text) + +(type: Method + {#type-vars (List Text) + #method Text + #inputs (List Code) + #output Code}) + +(def: default-alias Alias "@") + +(def: declaration^ + (s;Syntax Declaration) + (s;either (s;form (s;seq s;local-symbol + (s;some s;local-symbol))) + (s;seq s;local-symbol + (s/wrap (list))))) + +(def: reference^ + (s;Syntax Reference) + (s;either (s;form (s;seq s;symbol + (s;some s;any))) + (s;seq s;symbol + (s/wrap (list))))) + +(def: alias^ + (s;Syntax Alias) + (|> s;local-symbol + (s;after (s;this (' #as))))) + +(def: method^ + (s;Syntax Method) + (s;form ($_ s;seq + (s;either (s;tuple (s;some s;local-symbol)) + (s/wrap (list))) + s;local-symbol + (s;tuple (s;some s;any)) + s;any))) + +(def: (interface-name raw) + (-> Text Text) + (format raw "{Interface}")) + +(def: (state-name raw) + (-> Text Text) + (format raw "{State}")) + +(def: identifier (-> Text Code) (|>. [""] code;symbol)) + +(def: (type-declaration name parameters) + (-> Text (List Text) Code) + (if (list;empty? parameters) + (identifier name) + (` ((~ (identifier name)) (~@ (L/map identifier parameters)))))) + +(def: (method-declaration g!class (^open)) + (-> Code Method Code) + (let [g!type-vars (L/map identifier type-vars)] + (` (: (All [(~@ g!type-vars)] + (-> (~@ inputs) (~ g!class) (~ output))) + (~ (identifier method)))))) + +(def: (method-definition export [interface parameters] g!class g!impl (^open)) + (-> (Maybe common;Export) Declaration Code Code Method Code) + (let [g!object (code;symbol ["" "_object"]) + g!behavior (code;symbol ["" "_behavior"]) + g!state (code;symbol ["" "_state"]) + args (L/map (|>. product;left nat-to-int %i (format "_") identifier) + (list;enumerate inputs))] + (` (def: (~@ (common;gen-export export)) ((~ (identifier method)) (~@ args) (~ g!object)) + (All [(~@ (L/map identifier parameters)) + (~ g!impl) + (~@ (L/map identifier type-vars))] + (-> (~@ inputs) (~ g!class) (~ output))) + (let [[(~ g!behavior) (~ g!state)] (~ g!object)] + (:: (~ g!behavior) (~ (identifier method)) (~@ args) (~ g!object))))))) + +(syntax: #export (interface: [export common;export] + [(^@ decl [interface parameters]) declaration^] + [alias (s;default default-alias alias^)] + [annotations (s;default common;empty-annotations common;annotations)] + [methods (s;many method^)]) + (macro;with-gensyms [g!state] + (do @ + [module macro;current-module-name + #let [g!behavior (` ((~ (identifier (interface-name interface))) (~@ (L/map identifier parameters)))) + g!class (` (;;Class (~ g!behavior) (~ g!state))) + interface-declaration (` ((~ (identifier (interface-name interface))) (~@ (L/map identifier parameters)) (~ g!state))) + de-alias (code;replace (code;symbol ["" alias]) g!class) + methods (L/map (|>. (update@ #inputs (L/map de-alias)) + (update@ #output de-alias)) + methods)]] + (wrap (list& (` (sig: (~@ (common;gen-export export)) (~ interface-declaration) + (~@ (L/map (method-declaration g!class) methods)))) + (` (type: (~@ (common;gen-export export)) (~ (type-declaration interface parameters)) + (~ (common;gen-annotations (|> annotations + (#;Cons [(ident-for #;;interface) + (code;tag [module (interface-name interface)])])))) + (;;Class (~ (type-declaration (interface-name interface) parameters))))) + (L/map (method-definition export decl g!class g!state) methods)))))) + +(syntax: #export (class: [export common;export] + [[instance parameters] declaration^] + [[class mappings] reference^] + [state-type (s;alt (s;record (s;many (s;seq s;any s;any))) + s;any)] + [impls (s;many s;any)]) + (macro;with-gensyms [g!init] + (do @ + [class (macro;normalize class) + [_ annotations _] (macro;find-def class)] + (case (macro;get-ident-ann (ident-for #;;interface) annotations) + #;None + (macro;fail (format (%ident class) " is not a class.")) + + (#;Some interface) + (let [[must-define-state? state-def] (case state-type + (#;Left members) + [true (code;record members)] + + (#;Right type) + [false type]) + g!state (if must-define-state? + (type-declaration (state-name instance) parameters) + state-def) + g!new (|> instance (format "new-") identifier) + g!instance (identifier instance) + g!parameters (L/map identifier parameters) + instance-declaration (type-declaration instance parameters)] + (wrap (L/append (if must-define-state? + (list (` (type: (~@ (common;gen-export export)) + (~ g!state) + (~ state-def)))) + (list)) + (list (` (struct: (~@ (common;gen-export export)) (~ g!instance) + (All [(~@ g!parameters)] + ((~ (code;symbol interface)) (~@ mappings) (~ g!state))) + (~@ impls))) + (` (def: (~@ (common;gen-export export)) ((~ g!new) (~ g!init)) + (All [(~@ g!parameters)] + (-> (~ g!state) + ((~ (code;symbol class)) (~@ mappings) (~ g!state)))) + [(~ g!instance) (~ g!init)])))))) + )))) + +(def: #export (get! object) + (All [I s] (-> (Class I s) s)) + (let [[behavior state] object] + state)) + +(def: #export (set! state object) + (All [I s] (-> s (Class I s) (Class I s))) + (let [[behavior _] object] + [behavior state])) + +(def: #export (update! change object) + (All [I s] (-> (-> s s) (Class I s) (Class I s))) + (let [[behavior state] object] + [behavior (change state)])) |