From 94c423ba5d81b28fb5eb3955e66b5420e7c3cf51 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 26 Jun 2017 19:35:49 -0400 Subject: - Forgot to commit some of the sub-modules for lux/paradigm/object. --- stdlib/source/lux/paradigm/object/common.lux | 65 ++++++++++++ stdlib/source/lux/paradigm/object/inheritance.lux | 109 ++++++++++++++++++++ stdlib/source/lux/paradigm/object/method.lux | 60 +++++++++++ stdlib/source/lux/paradigm/object/notation.lux | 117 ++++++++++++++++++++++ 4 files changed, 351 insertions(+) create mode 100644 stdlib/source/lux/paradigm/object/common.lux create mode 100644 stdlib/source/lux/paradigm/object/inheritance.lux create mode 100644 stdlib/source/lux/paradigm/object/method.lux create mode 100644 stdlib/source/lux/paradigm/object/notation.lux 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]) + (data [text] + text/format + [product] + (coll [list "L/" Functor Fold] + ["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 vars)) + +(def: #export (unique-type-vars parser) + (-> (s;Syntax (List Text)) (s;Syntax (List Text))) + (do p;Monad + [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 + [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]) + (data [text] + text/format + [ident "Ident/" Eq] + (coll [list "L/" Functor Fold])) + [macro #+ Monad "Lux/" Monad] + (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 [ ] + [(def: #export ( name) + (-> Ident (Lux [Ident (List Ident)])) + (do Monad + [name (macro;normalize name) + [_ annotations _] (macro;find-def name)] + (case [(macro;get-ident-ann (ident-for ) annotations) + (macro;get-ident-ann (ident-for ) annotations)] + [(#;Some real-name) (#;Some parent)] + (if (Ident/= no-parent parent) + (wrap [real-name (list)]) + (do @ + [[_ ancestors] ( parent)] + (wrap [real-name (#;Cons parent ancestors)]))) + + _ + (macro;fail (format "Wrong format for " " 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 [ ] + [(def: #export + (s;Syntax Reference) + (|> reference + (p;after (s;this (' )))))] + + [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]) + (data [text] + text/format + [product] + (coll [list "L/" Functor Fold] + ["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]) + (data [text] + text/format + [product] + maybe + [ident "Ident/" Eq] + (coll [list "L/" Functor Fold Monoid] + [set #+ Set])) + [macro #+ Monad "Lux/" Monad] + (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 [ ] + [(def: #export ( base) + (-> Text Text) + (|> base (format "@")))] + + [new "new"] + [get "get"] + [set "set"] + [update "update"] + ) + +(do-template [ ] + [(def: #export ( raw) + (-> Text Text) + (format raw "//OOP:" ))] + + [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)))))) -- cgit v1.2.3