diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/source/lux/paradigm/object.lux | 388 | ||||
| -rw-r--r-- | stdlib/test/test/lux/paradigm/object.lux | 109 | ||||
| -rw-r--r-- | stdlib/test/tests.lux | 2 |
3 files changed, 291 insertions, 208 deletions
diff --git a/stdlib/source/lux/paradigm/object.lux b/stdlib/source/lux/paradigm/object.lux index ae742fac7..16269b66d 100644 --- a/stdlib/source/lux/paradigm/object.lux +++ b/stdlib/source/lux/paradigm/object.lux @@ -1,178 +1,226 @@ (;module: lux - (lux (control monad) - (data text/format + (lux (control monad + ["p" parser "p/" Monad<Parser>]) + (data [text] + text/format [product] - (coll [list "L/" Functor<List> Monoid<List>])) - [macro #+ Monad<Lux>] + maybe + (coll [list "L/" Functor<List> Fold<List> Monoid<List>] + [set #+ Set])) + [macro #+ Monad<Lux> "Lux/" 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] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))) + [type]) + (. ["./c" common] + ["./n" notation] + ["./i" inheritance] + ["./m" method])) + +(def: (type-to-code type) + (-> Type (Lux Code)) + (case type + (#;Host name params) + (do Monad<Lux> + [paramsC+ (mapM @ type-to-code params)] + (wrap (` (;host (~ (code;symbol ["" name])) + (~@ paramsC+))))) + + #;Void + (Lux/wrap (` (;|))) + + #;Unit + (Lux/wrap (` (;&))) + + (^template [<tag> <macro> <flatten>] + (<tag> _) + (do Monad<Lux> + [partsC+ (mapM @ type-to-code (<flatten> type))] + (wrap (` (<macro> (~@ partsC+)))))) + ([#;Sum ;| type;flatten-variant] + [#;Product ;& type;flatten-tuple]) + + (#;Function input output) + (do Monad<Lux> + [#let [[insT+ outT] (type;flatten-function type)] + insC+ (mapM @ type-to-code insT+) + outC (type-to-code outT)] + (wrap (` (;-> (~@ insC+) (~ outC))))) + + (^template [<tag>] + (<tag> idx) + (Lux/wrap (` (<tag> (~ (code;nat idx)))))) + ([#;Bound] + [#;Var] + [#;Ex]) + + (#;Apply param fun) + (do Monad<Lux> + [#let [[funcT argsT+] (type;flatten-application type)] + funcC (type-to-code funcT) + argsC+ (mapM @ type-to-code argsT+)] + (wrap (` ((~ funcC) (~@ argsC+))))) + + (#;Named name unnamedT) + (Lux/wrap (code;symbol name)) + + _ + (macro;fail (format "Cannot convert type to code: " (type;to-text type))))) + +(syntax: #export (interface: [export csr;export] + [(^@ decl [interface parameters]) ./c;declaration] + [?extends (p;opt ./i;extension)] + [alias ./c;alias] + [annotations (p;default cs;empty-annotations csr;annotations)] + [methods (p;many (./m;method (./c;var-set parameters)))]) + (macro;with-gensyms [g!self-class g!child g!ext] (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] + [parent ancestors mappings] (: (Lux [Ident (List Ident) (List Code)]) + (case ?extends + #;None + (wrap [./i;no-parent (list) (list)]) + + (#;Some [super mappings]) + (do @ + [[parent ancestors] (./i;interface super)] + (wrap [parent (list& parent ancestors) mappings])))) + #let [g!signature (code;local-symbol (./n;signature interface)) + g!interface (code;local-symbol interface) + g!parameters (L/map code;local-symbol parameters) + g!self-ref (if (list;empty? g!parameters) + (list g!interface) + (list)) + g!interface-def (if (./i;no-parent? parent) + (let [g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~ g!child)))] + (` (Ex (~@ g!self-ref) [(~ g!ext) (~ g!child)] + [((~ g!signature) (~@ g!parameters) (~ g!recur)) + (~ g!child) + (~ g!ext)]))) + (let [g!parent (code;symbol parent) + g!ancestors (./c;ancestor-inputs ancestors) + g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))] + (` (Ex (~@ g!self-ref) [(~ g!ext) (~@ g!ancestors) (~ g!child)] + ((~ g!parent) (~@ mappings) + [((~ g!signature) (~@ g!parameters) (~ g!recur)) + (~ g!child) + (~ g!ext)] + (~@ g!ancestors))))))]] + (wrap (list& (` (sig: (~@ (csw;export export)) + ((~ g!signature) (~@ g!parameters) (~ g!self-class)) + (~@ (let [de-alias (code;replace (code;local-symbol alias) g!self-class)] + (L/map (|>. (update@ #./m;inputs (L/map de-alias)) + (update@ #./m;output de-alias) + (./m;declaration g!self-class)) + methods))))) + + (` (type: (~@ (csw;export export)) ((~ g!interface) (~@ g!parameters)) + (~ (|> annotations + (./i;with-interface parent [module interface]) + csw;annotations)) + (~ g!interface-def))) + + (./n;getter export interface g!parameters g!ext g!child ancestors) + (./n;setter export interface g!parameters g!ext g!child ancestors) + (./n;updater export interface g!parameters g!ext g!child ancestors) + + (let [g!ancestors (./c;ancestor-inputs ancestors) + g!states (L/append g!ancestors (list g!child)) + g!self-object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + de-alias (code;replace (code;symbol ["" alias]) g!self-object)] + (L/map (|>. (update@ #./m;inputs (L/map de-alias)) + (update@ #./m;output de-alias) + (./m;definition export decl g!self-object g!ext g!states)) + methods)))) + ))) + +(syntax: #export (class: [export csr;export] + [[instance parameters] ./c;declaration] + [annotations (p;default cs;empty-annotations csr;annotations)] + [[interface interface-mappings] ./i;reference] + [super (p;opt ./i;inheritance)] + state-type + [impls (p;many s;any)]) + (macro;with-gensyms [g!init g!extension] (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)] + [module macro;current-module-name + [interface _] (./i;interface interface) + [parent ancestors parent-mappings] (: (Lux [Ident (List Ident) (List Code)]) + (case super + (#;Some [super-class super-mappings]) + (do @ + [[parent ancestors] (./i;class super-class)] + (wrap [parent ancestors super-mappings])) - (#;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)])) + #;None + (wrap [./i;no-parent (list) (list)]))) + g!inheritance (: (Lux (List Code)) + (if (./i;no-parent? parent) + (wrap (list)) + (do @ + [newT (macro;find-def-type (product;both id ./n;new parent)) + [depth rawT+] (./i;extract newT) + codeT+ (mapM @ type-to-code rawT+)] + (wrap (L/map (./i;specialize parent-mappings) codeT+))))) + #let [g!parameters (L/map code;local-symbol parameters) + + g!state (code;local-symbol (./n;state instance)) + g!struct (code;local-symbol (./n;struct instance)) + g!class (code;local-symbol instance) + + g!signature (code;symbol (product;both id ./n;signature interface)) + g!interface (code;symbol interface) + + g!parent-structs (if (./i;no-parent? parent) + (list) + (L/map (|>. (product;both id ./n;struct) code;symbol) (list& parent ancestors)))] + g!parent-inits (mapM @ (function [_] (macro;gensym "parent-init")) + g!parent-structs) + #let [g!full-init (L/fold (function [[parent-struct parent-state] child] + (` [(~ parent-struct) (~ parent-state) (~ child)])) + (` [(~ g!struct) (~ g!init) []]) + (list;zip2 g!parent-structs g!parent-inits)) + g!new (code;local-symbol (./n;new instance)) + g!recur (` ((~ g!class) (~@ g!parameters) (~ g!extension))) + g!rec (if (list;empty? g!parameters) + (list (' #rec)) + (list))]] + (wrap (list (` (type: (~@ (csw;export export)) + ((~ g!state) (~@ g!parameters)) + (~ state-type))) + + (` (type: (~@ (csw;export export)) (~@ g!rec) ((~ g!class) (~@ g!parameters)) + (~ (|> annotations + (./i;with-class interface parent [module instance]) + csw;annotations)) + (Ex [(~ g!extension)] + (~ (if (./i;no-parent? parent) + (` ((~ g!interface) (~@ interface-mappings) + (~ g!extension) + ((~ g!state) (~@ g!parameters)))) + (let [g!parent (code;symbol parent)] + (` ((~ g!parent) (~@ parent-mappings) + [((~ g!signature) (~@ interface-mappings) (~ g!recur)) + ((~ g!state) (~@ g!parameters)) + (~ g!extension)])))))))) + + (` (struct: (~@ (csw;export export)) (~ g!struct) + (All [(~@ g!parameters) (~ g!extension)] + ((~ g!signature) (~@ interface-mappings) + ((~ g!interface) (~@ interface-mappings) + (~ g!extension) + (~@ g!inheritance) + ((~ g!state) (~@ g!parameters))))) + (~@ impls))) + + (` (def: (~@ (csw;export export)) ((~ g!new) (~@ g!parent-inits) (~ g!init)) + (All [(~@ g!parameters)] + (-> (~@ g!inheritance) + ((~ g!state) (~@ g!parameters)) + ((~ g!class) (~@ g!parameters)))) + (~ g!full-init))) + )) + ))) diff --git a/stdlib/test/test/lux/paradigm/object.lux b/stdlib/test/test/lux/paradigm/object.lux index 0171ab41f..7998d0000 100644 --- a/stdlib/test/test/lux/paradigm/object.lux +++ b/stdlib/test/test/lux/paradigm/object.lux @@ -3,46 +3,81 @@ (lux (data (coll [list])) (paradigm object))) -(interface: (Queue a) - (push [a] @) - (peek [] (Maybe a)) - (pop [] @) +## No parameters +(interface: Counter + (inc [] @) + (read [] Nat)) + +(class: NatC Counter + Nat + + (def: inc + (update@Counter n.inc)) + + (def: read + get@Counter)) + +(interface: Resettable-Counter + #extends Counter + (reset [] @)) + +(class: NatRC Resettable-Counter + #inherits NatC + Unit + + (def: reset + (set@Counter +0))) + +## With parameters +(interface: (Collection a) + (add [a] @) (size [] Nat)) -(class: (List-Queue a) (Queue a) +(class: (ListC a) (Collection a) (List a) - - (def: (push a) - (update! (|>. (#;Cons a)))) - (def: peek - (|>. get! list;head)) + (def: (add elem) + (update@Collection (|>. (#;Cons elem)))) - (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]])) + (|>. get@Collection list;size))) + +(interface: (Iterable a) + #extends (Collection a) + (enumerate [] (List a))) + +(class: (ListI a) (Iterable a) + #inherits (ListC a) + Unit + + (def: enumerate + get@Collection)) + +## Polymorphism +(def: (poly0 counter) + (-> Counter Nat) + (read counter)) + +(def: poly0-0 Nat (poly0 (new@NatC +0))) +(def: poly0-1 Nat (poly0 (new@NatRC +0 []))) + +(def: (poly1 counter) + (-> Resettable-Counter Nat) + (n.+ (read counter) + (read (reset counter)))) + +(def: poly1-0 Nat (poly1 (new@NatRC +0 []))) + +(def: (poly2 counter) + (-> NatC Nat) + (read counter)) + +(def: poly2-0 Nat (poly2 (new@NatC +0))) +(def: poly2-1 Nat (poly2 (new@NatRC +0 []))) + +(def: (poly3 counter) + (-> NatRC Nat) + (n.+ (read counter) + (read (reset counter)))) + +(def: poly3-0 Nat (poly3 (new@NatRC +0 []))) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index 7bfff1634..7fb6eafb7 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -68,7 +68,7 @@ ["_;" type] (type ["_;" check] ["_;" auto]) - ## (paradigm ["_;" object]) + (paradigm ["_;" object]) )) (lux (control [contract]) (data [env] |