aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/paradigm/object.lux178
-rw-r--r--stdlib/test/test/lux/paradigm/object.lux48
-rw-r--r--stdlib/test/tests.lux1
3 files changed, 227 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)]))
diff --git a/stdlib/test/test/lux/paradigm/object.lux b/stdlib/test/test/lux/paradigm/object.lux
new file mode 100644
index 000000000..0171ab41f
--- /dev/null
+++ b/stdlib/test/test/lux/paradigm/object.lux
@@ -0,0 +1,48 @@
+(;module:
+ lux
+ (lux (data (coll [list]))
+ (paradigm object)))
+
+(interface: (Queue a)
+ (push [a] @)
+ (peek [] (Maybe a))
+ (pop [] @)
+ (size [] Nat))
+
+(class: (List-Queue a) (Queue a)
+ (List a)
+
+ (def: (push a)
+ (update! (|>. (#;Cons a))))
+
+ (def: peek
+ (|>. get! list;head))
+
+ (def: pop
+ (update! (function [state] (|> state list;tail (default state)))))
+
+ (def: size
+ (|>. get! list;size)))
+
+(type: Coord [Real Real])
+(type: Angle Real)
+
+(interface: Geometry
+ (translate [Coord] @)
+ (rotate [Coord Angle] @)
+ (scale [Real Real] @))
+
+(class: Point Geometry
+ {#label Text
+ #coord Coord}
+ (def: (translate coord self) self)
+ (def: (rotate coord angle self) self)
+ (def: (scale width height self) self))
+
+(def: queue0 (|> (new-List-Queue (list))
+ (: (Queue Nat))
+ (push +123)
+ (push +456)
+ (push +789)
+ pop))
+(def: point0 (new-Point ["YOLO" [123.4 567.8]]))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index b55373330..0a609ce13 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -67,6 +67,7 @@
["_;" type]
(type ["_;" check]
["_;" auto])
+ (paradigm ["_;" object])
))
(lux (control [contract])
(data [env]
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 17:16:51 +0000