From fd9def43d37bfa548f62915f62e5e6cb0a1dfcac Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 11 Feb 2018 19:58:20 -0400 Subject: - Re-named lux/type/object to lux/type/object/interface. --- stdlib/source/lux/type/object.lux | 514 ------------------------- stdlib/source/lux/type/object/interface.lux | 514 +++++++++++++++++++++++++ stdlib/source/lux/world/console.lux | 2 +- stdlib/test/test/lux/type/object.lux | 83 ---- stdlib/test/test/lux/type/object/interface.lux | 83 ++++ stdlib/test/tests.lux | 2 +- 6 files changed, 599 insertions(+), 599 deletions(-) delete mode 100644 stdlib/source/lux/type/object.lux create mode 100644 stdlib/source/lux/type/object/interface.lux delete mode 100644 stdlib/test/test/lux/type/object.lux create mode 100644 stdlib/test/test/lux/type/object/interface.lux diff --git a/stdlib/source/lux/type/object.lux b/stdlib/source/lux/type/object.lux deleted file mode 100644 index d7ebb1e8c..000000000 --- a/stdlib/source/lux/type/object.lux +++ /dev/null @@ -1,514 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do Monad] - ["p" parser "p/" Monad]) - (data [text] - text/format - [product] - [maybe] - [ident #+ "ident/" Eq] - (coll [list "list/" Functor Fold Monoid] - [set #+ Set])) - [macro #+ Monad "macro/" Monad] - (macro [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))) - (lang [type]))) - -## [Common] -(type: Declaration - [Text (List Text)]) - -(type: Alias Text) - -(def: default-alias Alias "@") - -(def: (var-set vars) - (-> (List Text) (Set Text)) - (set.from-list text.Hash vars)) - -(def: (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/= (set.size (var-set raw)) - (list.size raw)))] - (wrap raw))) - -(def: (safe-type-vars exclusions) - (-> (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 (set.member? exclusions) not))] - (wrap raw))) - -(def: declarationS - (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: aliasS - (s.Syntax Alias) - (|> s.local-symbol - (p.after (s.this (' #as))) - (p.default default-alias))) - -(def: (ancestor-inputs ancestors) - (-> (List Ident) (List Code)) - (if (list.empty? ancestors) - (list) - (|> (list.size ancestors) - n/dec - (list.n/range +0) - (list/map (|>> %n (format "ancestor") code.local-symbol))))) - -## [Methods] -(type: Method - {#type-vars (List Text) - #name Text - #inputs (List Code) - #output Code}) - -(def: (method exclusions) - (-> (Set Text) (s.Syntax Method)) - (s.form ($_ p.seq - (p.either (unique-type-vars (s.tuple (p.some (safe-type-vars exclusions)))) - (p/wrap (list))) - s.local-symbol - (s.tuple (p.some s.any)) - s.any))) - -(def: (declarationM g!self (^open)) - (-> Code Method Code) - (let [g!type-vars (list/map code.local-symbol type-vars) - g!method (code.local-symbol name)] - (` (: (All [(~+ g!type-vars)] - (-> (~+ inputs) (~ g!self) (~ output))) - (~ g!method))))) - -(def: (definition export [interface parameters] g!self-object g!ext g!states (^open)) - (-> Bool Declaration Code Code (List Code) Method Code) - (let [g!method (code.local-symbol name) - g!parameters (list/map code.local-symbol parameters) - g!type-vars (list/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 (list/map (|>> product.left nat-to-int %i (format "_") code.local-symbol) - (list.enumerate inputs)) - g!destructuring (list/fold (function [_ g!bottom] (` [(~ g!_temp) (~ g!_temp) (~ g!bottom)])) - (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]) - (maybe.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))))))) - -## [Inheritance] -(type: Reference - [Ident (List Code)]) - -(def: no-parent Ident ["" ""]) - -(def: (no-parent? parent) - (-> Ident Bool) - (ident/= no-parent parent)) - -(def: (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: (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: ( name) - (-> Ident (Meta [Ident (List Ident)])) - (do Monad - [[_ annotations _] (macro.find-def name)] - (case [(macro.get-tag-ann (ident-for ) annotations) - (macro.get-tag-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.")))))] - - [interfaceN #..interface-name #..interface-parent "interface"] - [classN #..class-name #..class-parent "class"] - ) - -(def: (extract newT) - (-> Type (Meta [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)] - (macro/wrap [depth stateT+])) - - _ - (macro.fail (format "Cannot extract inheritance from type: " (type.to-text newT)))))) - -(def: (specialize mappings typeC) - (-> (List Code) Code Code) - (case (list.size mappings) - +0 - typeC - - size - (|> (n/dec size) - (list.n/range +0) - (list/map (|>> (n/* +2) n/inc code.nat (~) #.Bound (`))) - (list.zip2 (list.reverse mappings)) - (list/fold (function [[mappingC boundC] genericC] - (code.replace boundC mappingC genericC)) - typeC)))) - -(def: referenceS - (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: - (s.Syntax Reference) - (|> referenceS - (p.after (s.this (' )))))] - - [extension #super] - [inheritance #super] - ) - -## [Notation] -## Utils -(def: (nest ancestors bottom) - (-> (List Code) Code Code) - (list/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: ( base) - (-> Text Text) - (|> base (format "@")))] - - [newN "new"] - [getN "get"] - [setN "set"] - [updateN "update"] - ) - -(do-template [ ] - [(def: ( raw) - (-> Text Text) - (let [[module kind] (ident-for )] - (format "{" kind "@" module "}" raw)))] - - [signatureN #..Signature] - [stateN #..State] - [structN #..Struct] - ) - -(def: (getterN export interface g!parameters g!ext g!child ancestors) - (-> Bool Text (List Code) Code Code (List Ident) - Code) - (let [g!get (code.local-symbol (getN interface)) - g!interface (code.local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!ancestors (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: (setterN export interface g!parameters g!ext g!child ancestors) - (-> Bool Text (List Code) Code Code (List Ident) - Code) - (let [g!set (code.local-symbol (setN interface)) - g!interface (code.local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!_input (' _input) - g!ancestors (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: (updaterN export interface g!parameters g!ext g!child ancestors) - (-> Bool Text (List Code) Code Code (List Ident) - Code) - (let [g!update (code.local-symbol (updateN interface)) - g!interface (code.local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!_change (' _change) - g!ancestors (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)))))) - -## [Macros] -(def: (type-to-code type) - (-> Type (Meta Code)) - (case type - (#.Primitive name params) - (do Monad - [paramsC+ (monad.map @ type-to-code params)] - (wrap (` (.primitive (~ (code.symbol ["" name])) - (~+ paramsC+))))) - - #.Void - (macro/wrap (` (.|))) - - #.Unit - (macro/wrap (` (.&))) - - (^template [ ] - ( _) - (do Monad - [partsC+ (monad.map @ type-to-code ( type))] - (wrap (` ( (~+ partsC+)))))) - ([#.Sum .| type.flatten-variant] - [#.Product .& type.flatten-tuple]) - - (#.Function input output) - (do Monad - [#let [[insT+ outT] (type.flatten-function type)] - insC+ (monad.map @ type-to-code insT+) - outC (type-to-code outT)] - (wrap (` (.-> (~+ insC+) (~ outC))))) - - (^template [] - ( idx) - (macro/wrap (` ( (~ (code.nat idx)))))) - ([#.Bound] - [#.Var] - [#.Ex]) - - (#.Apply param fun) - (do Monad - [#let [[funcT argsT+] (type.flatten-application type)] - funcC (type-to-code funcT) - argsC+ (monad.map @ type-to-code argsT+)] - (wrap (` ((~ funcC) (~+ argsC+))))) - - (#.Named name unnamedT) - (macro/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]) declarationS] - [?extends (p.maybe extension)] - [alias aliasS] - [annotations (p.default cs.empty-annotations csr.annotations)] - [methods (p.many (method (var-set parameters)))]) - (macro.with-gensyms [g!self-class g!child g!ext] - (do @ - [module macro.current-module-name - [parent ancestors mappings] (: (Meta [Ident (List Ident) (List Code)]) - (case ?extends - #.None - (wrap [no-parent (list) (list)]) - - (#.Some [super mappings]) - (do @ - [[parent ancestors] (interfaceN super)] - (wrap [parent (list& parent ancestors) mappings])))) - #let [g!signature (code.local-symbol (signatureN interface)) - g!interface (code.local-symbol interface) - g!parameters (list/map code.local-symbol parameters) - g!self-ref (if (list.empty? g!parameters) - (list g!interface) - (list)) - g!interface-def (if (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 (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)] - (list/map (|>> (update@ #inputs (list/map de-alias)) - (update@ #output de-alias) - (declarationM g!self-class)) - methods))))) - - (` (type: (~+ (csw.export export)) ((~ g!interface) (~+ g!parameters)) - (~ (|> annotations - (with-interface parent [module interface]) - csw.annotations)) - (~ g!interface-def))) - - (getterN export interface g!parameters g!ext g!child ancestors) - (setterN export interface g!parameters g!ext g!child ancestors) - (updaterN export interface g!parameters g!ext g!child ancestors) - - (let [g!ancestors (ancestor-inputs ancestors) - g!states (list/compose 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)] - (list/map (|>> (update@ #inputs (list/map de-alias)) - (update@ #output de-alias) - (definition export decl g!self-object g!ext g!states)) - methods)))) - ))) - -(syntax: #export (class: [export csr.export] - [[instance parameters] declarationS] - [annotations (p.default cs.empty-annotations csr.annotations)] - [[interface interface-mappings] referenceS] - [super (p.maybe inheritance)] - state-type - [impls (p.many s.any)]) - (macro.with-gensyms [g!init g!extension] - (do @ - [module macro.current-module-name - [interface _] (interfaceN interface) - [parent ancestors parent-mappings] (: (Meta [Ident (List Ident) (List Code)]) - (case super - (#.Some [super-class super-mappings]) - (do @ - [[parent ancestors] (classN super-class)] - (wrap [parent ancestors super-mappings])) - - #.None - (wrap [no-parent (list) (list)]))) - g!inheritance (: (Meta (List Code)) - (if (no-parent? parent) - (wrap (list)) - (do @ - [newT (macro.find-def-type (product.both id newN parent)) - [depth rawT+] (extract newT) - codeT+ (monad.map @ type-to-code rawT+)] - (wrap (list/map (specialize parent-mappings) codeT+))))) - #let [g!parameters (list/map code.local-symbol parameters) - - g!state (code.local-symbol (stateN instance)) - g!struct (code.local-symbol (structN instance)) - g!class (code.local-symbol instance) - - g!signature (code.symbol (product.both id signatureN interface)) - g!interface (code.symbol interface) - - g!parent-structs (if (no-parent? parent) - (list) - (list/map (|>> (product.both id structN) code.symbol) (list& parent ancestors)))] - g!parent-inits (monad.map @ (function [_] (macro.gensym "parent-init")) - g!parent-structs) - #let [g!full-init (list/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 (newN 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 - (with-class interface parent [module instance]) - csw.annotations)) - (Ex [(~ g!extension)] - (~ (if (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/source/lux/type/object/interface.lux b/stdlib/source/lux/type/object/interface.lux new file mode 100644 index 000000000..d7ebb1e8c --- /dev/null +++ b/stdlib/source/lux/type/object/interface.lux @@ -0,0 +1,514 @@ +(.module: + lux + (lux (control [monad #+ do Monad] + ["p" parser "p/" Monad]) + (data [text] + text/format + [product] + [maybe] + [ident #+ "ident/" Eq] + (coll [list "list/" Functor Fold Monoid] + [set #+ Set])) + [macro #+ Monad "macro/" Monad] + (macro [code] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))) + (lang [type]))) + +## [Common] +(type: Declaration + [Text (List Text)]) + +(type: Alias Text) + +(def: default-alias Alias "@") + +(def: (var-set vars) + (-> (List Text) (Set Text)) + (set.from-list text.Hash vars)) + +(def: (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/= (set.size (var-set raw)) + (list.size raw)))] + (wrap raw))) + +(def: (safe-type-vars exclusions) + (-> (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 (set.member? exclusions) not))] + (wrap raw))) + +(def: declarationS + (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: aliasS + (s.Syntax Alias) + (|> s.local-symbol + (p.after (s.this (' #as))) + (p.default default-alias))) + +(def: (ancestor-inputs ancestors) + (-> (List Ident) (List Code)) + (if (list.empty? ancestors) + (list) + (|> (list.size ancestors) + n/dec + (list.n/range +0) + (list/map (|>> %n (format "ancestor") code.local-symbol))))) + +## [Methods] +(type: Method + {#type-vars (List Text) + #name Text + #inputs (List Code) + #output Code}) + +(def: (method exclusions) + (-> (Set Text) (s.Syntax Method)) + (s.form ($_ p.seq + (p.either (unique-type-vars (s.tuple (p.some (safe-type-vars exclusions)))) + (p/wrap (list))) + s.local-symbol + (s.tuple (p.some s.any)) + s.any))) + +(def: (declarationM g!self (^open)) + (-> Code Method Code) + (let [g!type-vars (list/map code.local-symbol type-vars) + g!method (code.local-symbol name)] + (` (: (All [(~+ g!type-vars)] + (-> (~+ inputs) (~ g!self) (~ output))) + (~ g!method))))) + +(def: (definition export [interface parameters] g!self-object g!ext g!states (^open)) + (-> Bool Declaration Code Code (List Code) Method Code) + (let [g!method (code.local-symbol name) + g!parameters (list/map code.local-symbol parameters) + g!type-vars (list/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 (list/map (|>> product.left nat-to-int %i (format "_") code.local-symbol) + (list.enumerate inputs)) + g!destructuring (list/fold (function [_ g!bottom] (` [(~ g!_temp) (~ g!_temp) (~ g!bottom)])) + (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]) + (maybe.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))))))) + +## [Inheritance] +(type: Reference + [Ident (List Code)]) + +(def: no-parent Ident ["" ""]) + +(def: (no-parent? parent) + (-> Ident Bool) + (ident/= no-parent parent)) + +(def: (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: (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: ( name) + (-> Ident (Meta [Ident (List Ident)])) + (do Monad + [[_ annotations _] (macro.find-def name)] + (case [(macro.get-tag-ann (ident-for ) annotations) + (macro.get-tag-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.")))))] + + [interfaceN #..interface-name #..interface-parent "interface"] + [classN #..class-name #..class-parent "class"] + ) + +(def: (extract newT) + (-> Type (Meta [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)] + (macro/wrap [depth stateT+])) + + _ + (macro.fail (format "Cannot extract inheritance from type: " (type.to-text newT)))))) + +(def: (specialize mappings typeC) + (-> (List Code) Code Code) + (case (list.size mappings) + +0 + typeC + + size + (|> (n/dec size) + (list.n/range +0) + (list/map (|>> (n/* +2) n/inc code.nat (~) #.Bound (`))) + (list.zip2 (list.reverse mappings)) + (list/fold (function [[mappingC boundC] genericC] + (code.replace boundC mappingC genericC)) + typeC)))) + +(def: referenceS + (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: + (s.Syntax Reference) + (|> referenceS + (p.after (s.this (' )))))] + + [extension #super] + [inheritance #super] + ) + +## [Notation] +## Utils +(def: (nest ancestors bottom) + (-> (List Code) Code Code) + (list/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: ( base) + (-> Text Text) + (|> base (format "@")))] + + [newN "new"] + [getN "get"] + [setN "set"] + [updateN "update"] + ) + +(do-template [ ] + [(def: ( raw) + (-> Text Text) + (let [[module kind] (ident-for )] + (format "{" kind "@" module "}" raw)))] + + [signatureN #..Signature] + [stateN #..State] + [structN #..Struct] + ) + +(def: (getterN export interface g!parameters g!ext g!child ancestors) + (-> Bool Text (List Code) Code Code (List Ident) + Code) + (let [g!get (code.local-symbol (getN interface)) + g!interface (code.local-symbol interface) + g!_object (' _object) + g!_behavior (' _behavior) + g!_state (' _state) + g!_extension (' _extension) + g!ancestors (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: (setterN export interface g!parameters g!ext g!child ancestors) + (-> Bool Text (List Code) Code Code (List Ident) + Code) + (let [g!set (code.local-symbol (setN interface)) + g!interface (code.local-symbol interface) + g!_object (' _object) + g!_behavior (' _behavior) + g!_state (' _state) + g!_extension (' _extension) + g!_input (' _input) + g!ancestors (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: (updaterN export interface g!parameters g!ext g!child ancestors) + (-> Bool Text (List Code) Code Code (List Ident) + Code) + (let [g!update (code.local-symbol (updateN interface)) + g!interface (code.local-symbol interface) + g!_object (' _object) + g!_behavior (' _behavior) + g!_state (' _state) + g!_extension (' _extension) + g!_change (' _change) + g!ancestors (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)))))) + +## [Macros] +(def: (type-to-code type) + (-> Type (Meta Code)) + (case type + (#.Primitive name params) + (do Monad + [paramsC+ (monad.map @ type-to-code params)] + (wrap (` (.primitive (~ (code.symbol ["" name])) + (~+ paramsC+))))) + + #.Void + (macro/wrap (` (.|))) + + #.Unit + (macro/wrap (` (.&))) + + (^template [ ] + ( _) + (do Monad + [partsC+ (monad.map @ type-to-code ( type))] + (wrap (` ( (~+ partsC+)))))) + ([#.Sum .| type.flatten-variant] + [#.Product .& type.flatten-tuple]) + + (#.Function input output) + (do Monad + [#let [[insT+ outT] (type.flatten-function type)] + insC+ (monad.map @ type-to-code insT+) + outC (type-to-code outT)] + (wrap (` (.-> (~+ insC+) (~ outC))))) + + (^template [] + ( idx) + (macro/wrap (` ( (~ (code.nat idx)))))) + ([#.Bound] + [#.Var] + [#.Ex]) + + (#.Apply param fun) + (do Monad + [#let [[funcT argsT+] (type.flatten-application type)] + funcC (type-to-code funcT) + argsC+ (monad.map @ type-to-code argsT+)] + (wrap (` ((~ funcC) (~+ argsC+))))) + + (#.Named name unnamedT) + (macro/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]) declarationS] + [?extends (p.maybe extension)] + [alias aliasS] + [annotations (p.default cs.empty-annotations csr.annotations)] + [methods (p.many (method (var-set parameters)))]) + (macro.with-gensyms [g!self-class g!child g!ext] + (do @ + [module macro.current-module-name + [parent ancestors mappings] (: (Meta [Ident (List Ident) (List Code)]) + (case ?extends + #.None + (wrap [no-parent (list) (list)]) + + (#.Some [super mappings]) + (do @ + [[parent ancestors] (interfaceN super)] + (wrap [parent (list& parent ancestors) mappings])))) + #let [g!signature (code.local-symbol (signatureN interface)) + g!interface (code.local-symbol interface) + g!parameters (list/map code.local-symbol parameters) + g!self-ref (if (list.empty? g!parameters) + (list g!interface) + (list)) + g!interface-def (if (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 (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)] + (list/map (|>> (update@ #inputs (list/map de-alias)) + (update@ #output de-alias) + (declarationM g!self-class)) + methods))))) + + (` (type: (~+ (csw.export export)) ((~ g!interface) (~+ g!parameters)) + (~ (|> annotations + (with-interface parent [module interface]) + csw.annotations)) + (~ g!interface-def))) + + (getterN export interface g!parameters g!ext g!child ancestors) + (setterN export interface g!parameters g!ext g!child ancestors) + (updaterN export interface g!parameters g!ext g!child ancestors) + + (let [g!ancestors (ancestor-inputs ancestors) + g!states (list/compose 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)] + (list/map (|>> (update@ #inputs (list/map de-alias)) + (update@ #output de-alias) + (definition export decl g!self-object g!ext g!states)) + methods)))) + ))) + +(syntax: #export (class: [export csr.export] + [[instance parameters] declarationS] + [annotations (p.default cs.empty-annotations csr.annotations)] + [[interface interface-mappings] referenceS] + [super (p.maybe inheritance)] + state-type + [impls (p.many s.any)]) + (macro.with-gensyms [g!init g!extension] + (do @ + [module macro.current-module-name + [interface _] (interfaceN interface) + [parent ancestors parent-mappings] (: (Meta [Ident (List Ident) (List Code)]) + (case super + (#.Some [super-class super-mappings]) + (do @ + [[parent ancestors] (classN super-class)] + (wrap [parent ancestors super-mappings])) + + #.None + (wrap [no-parent (list) (list)]))) + g!inheritance (: (Meta (List Code)) + (if (no-parent? parent) + (wrap (list)) + (do @ + [newT (macro.find-def-type (product.both id newN parent)) + [depth rawT+] (extract newT) + codeT+ (monad.map @ type-to-code rawT+)] + (wrap (list/map (specialize parent-mappings) codeT+))))) + #let [g!parameters (list/map code.local-symbol parameters) + + g!state (code.local-symbol (stateN instance)) + g!struct (code.local-symbol (structN instance)) + g!class (code.local-symbol instance) + + g!signature (code.symbol (product.both id signatureN interface)) + g!interface (code.symbol interface) + + g!parent-structs (if (no-parent? parent) + (list) + (list/map (|>> (product.both id structN) code.symbol) (list& parent ancestors)))] + g!parent-inits (monad.map @ (function [_] (macro.gensym "parent-init")) + g!parent-structs) + #let [g!full-init (list/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 (newN 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 + (with-class interface parent [module instance]) + csw.annotations)) + (Ex [(~ g!extension)] + (~ (if (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/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux index 6458764ec..9d5fc6359 100644 --- a/stdlib/source/lux/world/console.lux +++ b/stdlib/source/lux/world/console.lux @@ -5,7 +5,7 @@ [text]) (concurrency [promise] [task #+ Task]) - (type object) + (type (object interface)) [io #+ IO Process io] [host])) diff --git a/stdlib/test/test/lux/type/object.lux b/stdlib/test/test/lux/type/object.lux deleted file mode 100644 index 7ca601792..000000000 --- a/stdlib/test/test/lux/type/object.lux +++ /dev/null @@ -1,83 +0,0 @@ -(.module: - lux - (lux (data (coll [list])) - (type object))) - -## No parameters -(interface: Counter - (inc [] @) - (read [] Nat)) - -(class: NatC Counter - Nat - - (def: inc - (update@Counter n/inc)) - - (def: read - get@Counter)) - -(interface: Resettable-Counter - #super Counter - (reset [] @)) - -(class: NatRC Resettable-Counter - #super NatC - Unit - - (def: reset - (set@Counter +0))) - -## With parameters -(interface: (Collection a) - (add [a] @) - (size [] Nat)) - -(class: (ListC a) (Collection a) - (List a) - - (def: (add elem) - (update@Collection (|>> (#.Cons elem)))) - - (def: size - (|>> get@Collection list.size))) - -(interface: (Iterable a) - #super (Collection a) - (enumerate [] (List a))) - -(class: (ListI a) (Iterable a) - #super (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/test/lux/type/object/interface.lux b/stdlib/test/test/lux/type/object/interface.lux new file mode 100644 index 000000000..a296d9558 --- /dev/null +++ b/stdlib/test/test/lux/type/object/interface.lux @@ -0,0 +1,83 @@ +(.module: + lux + (lux (data (coll [list])) + (type (object interface)))) + +## No parameters +(interface: Counter + (inc [] @) + (read [] Nat)) + +(class: NatC Counter + Nat + + (def: inc + (update@Counter n/inc)) + + (def: read + get@Counter)) + +(interface: Resettable-Counter + #super Counter + (reset [] @)) + +(class: NatRC Resettable-Counter + #super NatC + Unit + + (def: reset + (set@Counter +0))) + +## With parameters +(interface: (Collection a) + (add [a] @) + (size [] Nat)) + +(class: (ListC a) (Collection a) + (List a) + + (def: (add elem) + (update@Collection (|>> (#.Cons elem)))) + + (def: size + (|>> get@Collection list.size))) + +(interface: (Iterable a) + #super (Collection a) + (enumerate [] (List a))) + +(class: (ListI a) (Iterable a) + #super (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 98044e7d1..b59e8008a 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -69,7 +69,7 @@ (poly ["poly_." eq] ["poly_." functor])) (type ["_." implicit] - ["_." object] + (object ["_." interface]) ["_." resource]) (lang ["lang/_." syntax] ["_." type] -- cgit v1.2.3