aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/paradigm/object/common.lux65
-rw-r--r--stdlib/source/lux/paradigm/object/inheritance.lux109
-rw-r--r--stdlib/source/lux/paradigm/object/method.lux60
-rw-r--r--stdlib/source/lux/paradigm/object/notation.lux117
4 files changed, 351 insertions, 0 deletions
diff --git a/stdlib/source/lux/paradigm/object/common.lux b/stdlib/source/lux/paradigm/object/common.lux
new file mode 100644
index 000000000..b9d9d0fd6
--- /dev/null
+++ b/stdlib/source/lux/paradigm/object/common.lux
@@ -0,0 +1,65 @@
+(;module:
+ lux
+ (lux (control monad
+ ["p" parser "p/" Monad<Parser>])
+ (data [text]
+ text/format
+ [product]
+ (coll [list "L/" Functor<List> Fold<List>]
+ ["S" set]))
+ [macro]
+ (macro [code]
+ ["s" syntax #+ syntax:]
+ (syntax ["cs" common]
+ (common ["csr" reader]
+ ["csw" writer])))))
+
+(type: #export Declaration
+ [Text (List Text)])
+
+(type: #export Alias Text)
+
+(def: #export default-alias Alias "@")
+
+(def: #export (var-set vars)
+ (-> (List Text) (S;Set Text))
+ (S;from-list text;Hash<Text> vars))
+
+(def: #export (unique-type-vars parser)
+ (-> (s;Syntax (List Text)) (s;Syntax (List Text)))
+ (do p;Monad<Parser>
+ [raw parser
+ _ (p;assert "Cannot repeat the names of type variables/parameters."
+ (n.= (S;size (var-set raw))
+ (list;size raw)))]
+ (wrap raw)))
+
+(def: #export (safe-type-vars exclusions)
+ (-> (S;Set Text) (s;Syntax Text))
+ (do p;Monad<Parser>
+ [raw s;local-symbol
+ _ (p;assert "Cannot re-use names between method type-variables and interface type-parameters."
+ (|> raw (S;member? exclusions) not))]
+ (wrap raw)))
+
+(def: #export declaration
+ (s;Syntax Declaration)
+ (p;either (s;form (p;seq s;local-symbol
+ (unique-type-vars (p;some s;local-symbol))))
+ (p;seq s;local-symbol
+ (p/wrap (list)))))
+
+(def: #export alias
+ (s;Syntax Alias)
+ (|> s;local-symbol
+ (p;after (s;this (' #as)))
+ (p;default default-alias)))
+
+(def: #export (ancestor-inputs ancestors)
+ (-> (List Ident) (List Code))
+ (if (list;empty? ancestors)
+ (list)
+ (|> (list;size ancestors)
+ n.dec
+ (list;n.range +0)
+ (L/map (|>. %n (format "ancestor") code;local-symbol)))))
diff --git a/stdlib/source/lux/paradigm/object/inheritance.lux b/stdlib/source/lux/paradigm/object/inheritance.lux
new file mode 100644
index 000000000..9b384fd1d
--- /dev/null
+++ b/stdlib/source/lux/paradigm/object/inheritance.lux
@@ -0,0 +1,109 @@
+(;module:
+ lux
+ (lux (control monad
+ ["p" parser "p/" Monad<Parser>])
+ (data [text]
+ text/format
+ [ident "Ident/" Eq<Ident>]
+ (coll [list "L/" Functor<List> Fold<List>]))
+ [macro #+ Monad<Lux> "Lux/" Monad<Lux>]
+ (macro [code]
+ ["s" syntax #+ syntax:]
+ (syntax ["cs" common]
+ (common ["csr" reader]
+ ["csw" writer])))
+ [type]))
+
+(type: #export Reference
+ [Ident (List Code)])
+
+(def: #export no-parent Ident ["" ""])
+
+(def: #export (no-parent? parent)
+ (-> Ident Bool)
+ (Ident/= no-parent parent))
+
+(def: #export (with-interface parent interface)
+ (-> Ident Ident cs;Annotations cs;Annotations)
+ (|>. (#;Cons [(ident-for #;;interface-name)
+ (code;tag interface)])
+ (#;Cons [(ident-for #;;interface-parent)
+ (code;tag parent)])))
+
+(def: #export (with-class interface parent class)
+ (-> Ident Ident Ident cs;Annotations cs;Annotations)
+ (|>. (#;Cons [(ident-for #;;class-interface)
+ (code;tag interface)])
+ (#;Cons [(ident-for #;;class-parent)
+ (code;tag parent)])
+ (#;Cons [(ident-for #;;class-name)
+ (code;tag class)])))
+
+(do-template [<name> <name-tag> <parent-tag> <desc>]
+ [(def: #export (<name> name)
+ (-> Ident (Lux [Ident (List Ident)]))
+ (do Monad<Lux>
+ [name (macro;normalize name)
+ [_ annotations _] (macro;find-def name)]
+ (case [(macro;get-ident-ann (ident-for <name-tag>) annotations)
+ (macro;get-ident-ann (ident-for <parent-tag>) annotations)]
+ [(#;Some real-name) (#;Some parent)]
+ (if (Ident/= no-parent parent)
+ (wrap [real-name (list)])
+ (do @
+ [[_ ancestors] (<name> parent)]
+ (wrap [real-name (#;Cons parent ancestors)])))
+
+ _
+ (macro;fail (format "Wrong format for " <desc> " lineage.")))))]
+
+ [interface #;;interface-name #;;interface-parent "interface"]
+ [class #;;class-name #;;class-parent "class"]
+ )
+
+(def: #export (extract newT)
+ (-> Type (Lux [Nat (List Type)]))
+ (loop [depth +0
+ currentT newT]
+ (case currentT
+ (#;UnivQ _ bodyT)
+ (recur (n.inc depth) bodyT)
+
+ (#;Function inputT outputT)
+ (let [[stateT+ objectT] (type;flatten-function currentT)]
+ (Lux/wrap [depth stateT+]))
+
+ _
+ (macro;fail (format "Cannot extract inheritance from type: " (type;to-text newT))))))
+
+(def: #export (specialize mappings typeC)
+ (-> (List Code) Code Code)
+ (case (list;size mappings)
+ +0
+ typeC
+
+ size
+ (|> (n.dec size)
+ (list;n.range +0)
+ (L/map (|>. (n.* +2) n.inc code;nat (~) #;Bound (`)))
+ (list;zip2 (list;reverse mappings))
+ (L/fold (function [[mappingC boundC] genericC]
+ (code;replace boundC mappingC genericC))
+ typeC))))
+
+(def: #export reference
+ (s;Syntax Reference)
+ (p;either (s;form (p;seq s;symbol
+ (p;some s;any)))
+ (p;seq s;symbol
+ (p/wrap (list)))))
+
+(do-template [<name> <keyword>]
+ [(def: #export <name>
+ (s;Syntax Reference)
+ (|> reference
+ (p;after (s;this (' <keyword>)))))]
+
+ [extension #extends]
+ [inheritance #inherits]
+ )
diff --git a/stdlib/source/lux/paradigm/object/method.lux b/stdlib/source/lux/paradigm/object/method.lux
new file mode 100644
index 000000000..1ed759c30
--- /dev/null
+++ b/stdlib/source/lux/paradigm/object/method.lux
@@ -0,0 +1,60 @@
+(;module:
+ lux
+ (lux (control monad
+ ["p" parser "p/" Monad<Parser>])
+ (data [text]
+ text/format
+ [product]
+ (coll [list "L/" Functor<List> Fold<List>]
+ ["S" set]))
+ [macro]
+ (macro [code]
+ ["s" syntax #+ syntax:]
+ (syntax ["cs" common]
+ (common ["csr" reader]
+ ["csw" writer]))))
+ (.. ["../c" common]))
+
+(type: #export Method
+ {#type-vars (List Text)
+ #name Text
+ #inputs (List Code)
+ #output Code})
+
+(def: #export (method exclusions)
+ (-> (S;Set Text) (s;Syntax Method))
+ (s;form ($_ p;seq
+ (p;either (../c;unique-type-vars (s;tuple (p;some (../c;safe-type-vars exclusions))))
+ (p/wrap (list)))
+ s;local-symbol
+ (s;tuple (p;some s;any))
+ s;any)))
+
+(def: #export (declaration g!self (^open))
+ (-> Code Method Code)
+ (let [g!type-vars (L/map code;local-symbol type-vars)
+ g!method (code;local-symbol name)]
+ (` (: (All [(~@ g!type-vars)]
+ (-> (~@ inputs) (~ g!self) (~ output)))
+ (~ g!method)))))
+
+(def: #export (definition export [interface parameters] g!self-object g!ext g!states (^open))
+ (-> (Maybe cs;Export) ../c;Declaration Code Code (List Code) Method Code)
+ (let [g!method (code;local-symbol name)
+ g!parameters (L/map code;local-symbol parameters)
+ g!type-vars (L/map code;local-symbol type-vars)
+ g!_temp (code;symbol ["" "_temp"])
+ g!_object (code;symbol ["" "_object"])
+ g!_behavior (code;symbol ["" "_behavior"])
+ g!_state (code;symbol ["" "_state"])
+ g!_extension (code;symbol ["" "_extension"])
+ g!_args (L/map (|>. product;left nat-to-int %i (format "_") code;local-symbol)
+ (list;enumerate inputs))
+ g!destructuring (L/fold (function [_ g!bottom] (` [(~ g!_temp) (~ g!_temp) (~ g!bottom)]))
+ (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])
+ (default g!states (list;tail g!states)))]
+ (` (def: (~@ (csw;export export)) ((~ g!method) (~@ g!_args) (~ g!_object))
+ (All [(~@ g!parameters) (~ g!ext) (~@ g!states) (~@ g!type-vars)]
+ (-> (~@ inputs) (~ g!self-object) (~ output)))
+ (let [(~ g!destructuring) (~ g!_object)]
+ (:: (~ g!_behavior) (~ g!method) (~@ g!_args) (~ g!_object)))))))
diff --git a/stdlib/source/lux/paradigm/object/notation.lux b/stdlib/source/lux/paradigm/object/notation.lux
new file mode 100644
index 000000000..215963d41
--- /dev/null
+++ b/stdlib/source/lux/paradigm/object/notation.lux
@@ -0,0 +1,117 @@
+(;module:
+ [lux #- struct]
+ (lux (control monad
+ ["p" parser "p/" Monad<Parser>])
+ (data [text]
+ text/format
+ [product]
+ maybe
+ [ident "Ident/" Eq<Ident>]
+ (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
+ [set #+ Set]))
+ [macro #+ Monad<Lux> "Lux/" Monad<Lux>]
+ (macro [code]
+ ["s" syntax #+ syntax:]
+ (syntax ["cs" common]
+ (common ["csr" reader]
+ ["csw" writer])))
+ [type])
+ (.. ["../c" common]))
+
+## [Utils]
+(def: (nest ancestors bottom)
+ (-> (List Code) Code Code)
+ (L/fold (function [[level _] g!bottom]
+ (let [g!_behavior' (code;local-symbol (format "_behavior" (%n level)))
+ g!_state' (code;local-symbol (format "_state" (%n level)))]
+ (` [(~ g!_behavior') (~ g!_state') (~ g!bottom)])))
+ bottom
+ (list;enumerate ancestors)))
+
+## [Names]
+(do-template [<name> <category>]
+ [(def: #export (<name> base)
+ (-> Text Text)
+ (|> base (format <category> "@")))]
+
+ [new "new"]
+ [get "get"]
+ [set "set"]
+ [update "update"]
+ )
+
+(do-template [<name> <category>]
+ [(def: #export (<name> raw)
+ (-> Text Text)
+ (format raw "//OOP:" <category>))]
+
+ [signature "Signature"]
+ [state "State"]
+ [struct "Struct"]
+ )
+
+(def: #export (getter export interface g!parameters g!ext g!child ancestors)
+ (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident)
+ Code)
+ (let [g!get (code;local-symbol (get interface))
+ g!interface (code;local-symbol interface)
+ g!_object (' _object)
+ g!_behavior (' _behavior)
+ g!_state (' _state)
+ g!_extension (' _extension)
+ g!ancestors (../c;ancestor-inputs ancestors)
+ g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))
+ g!tear-down (nest g!ancestors
+ (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))]
+ (` (def: (~@ (csw;export export)) ((~ g!get) (~ g!_object))
+ (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)]
+ (-> (~ g!object) (~ g!child)))
+ (let [(~ g!tear-down) (~ g!_object)]
+ (~ g!_state))))))
+
+(def: #export (setter export interface g!parameters g!ext g!child ancestors)
+ (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident)
+ Code)
+ (let [g!set (code;local-symbol (set interface))
+ g!interface (code;local-symbol interface)
+ g!_object (' _object)
+ g!_behavior (' _behavior)
+ g!_state (' _state)
+ g!_extension (' _extension)
+ g!_input (' _input)
+ g!ancestors (../c;ancestor-inputs ancestors)
+ g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))
+ g!tear-down (nest g!ancestors
+ (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))
+ g!build-up (nest g!ancestors
+ (` [(~ g!_behavior) (~ g!_input) (~ g!_extension)]))]
+ (` (def: (~@ (csw;export export))
+ ((~ g!set) (~ g!_input) (~ g!_object))
+ (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)]
+ (-> (~ g!child) (~ g!object) (~ g!object)))
+ (let [(~ g!tear-down) (~ g!_object)]
+ (~ g!build-up))))))
+
+(def: #export (updater export interface g!parameters g!ext g!child ancestors)
+ (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident)
+ Code)
+ (let [g!update (code;local-symbol (update interface))
+ g!interface (code;local-symbol interface)
+ g!_object (' _object)
+ g!_behavior (' _behavior)
+ g!_state (' _state)
+ g!_extension (' _extension)
+ g!_change (' _change)
+ g!ancestors (../c;ancestor-inputs ancestors)
+ g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))
+ g!tear-down (nest g!ancestors
+ (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))
+ g!build-up (nest g!ancestors
+ (` [(~ g!_behavior) ((~ g!_change) (~ g!_state)) (~ g!_extension)]))]
+ (` (def: (~@ (csw;export export))
+ ((~ g!update) (~ g!_change) (~ g!_object))
+ (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)]
+ (-> (-> (~ g!child) (~ g!child))
+ (-> (~ g!object) (~ g!object))))
+ (let [(~ g!tear-down) (~ g!_object)]
+ (~ g!build-up))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 14:46:19 +0000