diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/type/object/interface.lux | 515 | ||||
| -rw-r--r-- | stdlib/source/lux/type/object/protocol.lux | 158 | ||||
| -rw-r--r-- | stdlib/source/lux/world/console.lux | 133 | ||||
| -rw-r--r-- | stdlib/test/test/lux/type/object/interface.lux | 87 | ||||
| -rw-r--r-- | stdlib/test/test/lux/type/object/protocol.lux | 133 | ||||
| -rw-r--r-- | stdlib/test/tests.lux | 5 |
6 files changed, 51 insertions, 980 deletions
diff --git a/stdlib/source/lux/type/object/interface.lux b/stdlib/source/lux/type/object/interface.lux deleted file mode 100644 index fb2579d55..000000000 --- a/stdlib/source/lux/type/object/interface.lux +++ /dev/null @@ -1,515 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do Monad)] - ["p" parser ("parser/." Monad<Parser>)]] - [data - ["." product] - ["." maybe] - [name ("name/." Equivalence<Name>)] - ["." text - format] - [collection - ["." list ("list/." Functor<List> Fold<List> Monoid<List>)] - ["." set (#+ Set)]]] - ["." type] - ["." macro (#+ Monad<Meta>) ("meta/." Monad<Meta>) - ["." code] - ["s" syntax (#+ syntax:)] - [syntax - ["cs" common] - [common - ["csr" reader] - ["csw" writer]]]]]) - -## [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<Text> vars)) - -(def: (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/= (set.size (var-set raw)) - (list.size raw)))] - (wrap raw))) - -(def: (safe-type-vars exclusions) - (-> (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 (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 - (parser/wrap (list))))) - -(def: aliasS - (s.Syntax Alias) - (|> s.local-symbol - (p.after (s.this (' #as))) - (p.default default-alias))) - -(def: (ancestor-inputs ancestors) - (-> (List Name) (List Code)) - (if (list.empty? ancestors) - (list) - (|> (list.size ancestors) - 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)))) - (parser/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 ".")) - (-> Bit 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 .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 - [Name (List Code)]) - -(def: no-parent Name ["" ""]) - -(def: (no-parent? parent) - (-> Name Bit) - (name/= no-parent parent)) - -(def: (with-interface parent interface) - (-> Name Name cs.Annotations cs.Annotations) - (|>> (#.Cons [(name-for #..interface-name) - (code.tag interface)]) - (#.Cons [(name-for #..interface-parent) - (code.tag parent)]))) - -(def: (with-class interface parent class) - (-> Name Name Name cs.Annotations cs.Annotations) - (|>> (#.Cons [(name-for #..class-interface) - (code.tag interface)]) - (#.Cons [(name-for #..class-parent) - (code.tag parent)]) - (#.Cons [(name-for #..class-name) - (code.tag class)]))) - -(do-template [<name> <name-tag> <parent-tag> <desc>] - [(def: (<name> name) - (-> Name (Meta [Name (List Name)])) - (do Monad<Meta> - [[_ annotations _] (macro.find-def name)] - (case [(macro.get-tag-ann (name-for <name-tag>) annotations) - (macro.get-tag-ann (name-for <parent-tag>) annotations)] - [(#.Some real-name) (#.Some parent)] - (if (name/= 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.")))))] - - [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 (inc depth) bodyT) - - (#.Function inputT outputT) - (let [[stateT+ objectT] (type.flatten-function currentT)] - (meta/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 - (|> (dec size) - (list.n/range +0) - (list/map (|>> (n/* +2) inc code.nat (~) #.Parameter (`))) - (list.zip2 (list.reverse mappings)) - (list/fold (function (_ [mappingC parameterC] genericC) - (code.replace parameterC mappingC genericC)) - typeC)))) - -(def: referenceS - (s.Syntax Reference) - (p.either (s.form (p.seq s.symbol - (p.some s.any))) - (p.seq s.symbol - (parser/wrap (list))))) - -(do-template [<name> <keyword>] - [(def: <name> - (s.Syntax Reference) - (|> referenceS - (p.after (s.this (' <keyword>)))))] - - [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 [<name> <category>] - [(def: (<name> base) - (-> Text Text) - (|> base (format <category> "@")))] - - [newN "new"] - [getN "get"] - [setN "set"] - [updateN "update"] - ) - -(do-template [<name> <category>] - [(def: (<name> raw) - (-> Text Text) - (let [[module kind] (name-for <category>)] - (format "{" kind "@" module "}" raw)))] - - [signatureN #..Signature] - [stateN #..State] - [structN #..Struct] - ) - -(def: (getterN export interface g!parameters g!ext g!child ancestors) - (-> Bit Text (List Code) Code Code (List Name) - 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) - (-> Bit Text (List Code) Code Code (List Name) - 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) - (-> Bit Text (List Code) Code Code (List Name) - 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<Meta> - [paramsC+ (monad.map @ type-to-code params)] - (wrap (` (.primitive (~ (code.symbol ["" name])) - (~+ paramsC+))))) - - (^template [<tag> <macro> <flatten>] - (<tag> _) - (do Monad<Meta> - [partsC+ (monad.map @ type-to-code (<flatten> type))] - (wrap (` (<macro> (~+ partsC+)))))) - ([#.Sum .| type.flatten-variant] - [#.Product .& type.flatten-tuple]) - - (#.Function input output) - (do Monad<Meta> - [#let [[insT+ outT] (type.flatten-function type)] - insC+ (monad.map @ type-to-code insT+) - outC (type-to-code outT)] - (wrap (` (.-> (~+ insC+) (~ outC))))) - - (^template [<tag>] - (<tag> idx) - (meta/wrap (` (<tag> (~ (code.nat idx)))))) - ([#.Parameter] - [#.Var] - [#.Ex]) - - (#.Apply param fun) - (do Monad<Meta> - [#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) - (meta/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 [Name (List Name) (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& (` (signature: (~+ (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 [Name (List Name) (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)])))))))) - - (` (structure: (~+ (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/protocol.lux b/stdlib/source/lux/type/object/protocol.lux deleted file mode 100644 index 26045f50f..000000000 --- a/stdlib/source/lux/type/object/protocol.lux +++ /dev/null @@ -1,158 +0,0 @@ -(.module: - [lux #* - [control - ["p" parser] - ["." monad (#+ do)]] - [data - ["." sum] - [collection - [list ("list/." Functor<List>)]]] - ["." macro ("meta/." Monad<Meta>) - ["." code] - ["s" syntax (#+ syntax:)] - [syntax - ["cs" common] - [common - ["csr" reader] - ["csw" writer]]]]]) - -(type: #export (Method i o) - (All [r] [i (-> o r)])) - -(type: #export (Message i o) - (Method i o o)) - -(def: #export (message input) - (All [i o] (-> i (Message i o))) - [input id]) - -(type: #export (Class s p) - (All [r] (-> (p r) s [r s]))) - -(type: #export (Alt lp rp) - (All [r] (| (lp r) (rp r)))) - -(def: #export (alt left right) - (All [s lp rp] - (-> (Class s lp) - (Class s rp) - (Class s (Alt lp rp)))) - (function (_ input state) - (case input - (#.Left input) - (left input state) - - (#.Right input) - (right input state)))) - -(type: #export (Object p) - (All [r] (-> (p r) [r (Object p)]))) - -(def: #export (object class init) - (All [s p] (-> (Class s p) s (Object p))) - (loop [state init] - (function (_ input) - (let [[output state'] (class input state)] - [output (recur state')])))) - -(type: Method-Syntax - {#method-variables (List Text) - #method-name Text - #method-input Code - #method-output Code}) - -(def: method|r - (s.Syntax Method-Syntax) - (s.form ($_ p.seq - (p.default (list) csr.type-variables) - s.local-symbol - s.any - s.any))) - -(def: (method|w g!return method) - (-> Code Method-Syntax Code) - (let [tagC (code.local-tag (get@ #method-name method)) - varsC+ (csw.type-variables (get@ #method-variables method)) - inputC (get@ #method-input method) - outputC (get@ #method-output method)] - (` ((~ tagC) (All [(~+ varsC+)] - (Method (~ inputC) (~ outputC) (~ g!return))))))) - -(def: (method|c export protocol method) - (-> Bit cs.Declaration Method-Syntax (Meta Code)) - (let [methodC (code.local-symbol (get@ #method-name method)) - tagC (code.local-tag (get@ #method-name method)) - protocolC (code.local-symbol (get@ #cs.declaration-name protocol)) - protocol-varsC+ (csw.type-variables (get@ #cs.declaration-args protocol)) - method-varsC+ (csw.type-variables (get@ #method-variables method)) - method-inputC (get@ #method-input method) - method-outputC (get@ #method-output method)] - (macro.with-gensyms [g!input g!return] - (meta/wrap (` (def: (~+ (csw.export export)) ((~ methodC) (~ g!input)) - (All [(~+ protocol-varsC+) (~+ method-varsC+)] - (-> (~ method-inputC) - ((~ protocolC) (~+ protocol-varsC+) (~ method-outputC)))) - ((~ tagC) [(~ g!input) .id]))))))) - -(type: Class-Syntax - {#class-name Text - #class-protocol Code}) - -(def: class|r - (s.Syntax Class-Syntax) - (s.form ($_ p.seq - s.local-symbol - s.any))) - -(def: (class|w g!return class) - (-> Code Class-Syntax Code) - (let [tagC (code.local-tag (get@ #class-name class)) - protocolC (get@ #class-protocol class)] - (` ((~ tagC) ((~ protocolC) (~ g!return)))))) - -(def: (class|c export protocol class) - (-> Bit cs.Declaration Class-Syntax (Meta Code)) - (let [classC (code.local-symbol (get@ #class-name class)) - tagC (code.local-tag (get@ #class-name class)) - protocolC (code.local-symbol (get@ #cs.declaration-name protocol)) - protocol-varsC+ (csw.type-variables (get@ #cs.declaration-args protocol)) - class-protocolC (get@ #class-protocol class)] - (macro.with-gensyms [g!sub g!return] - (meta/wrap (` (def: (~+ (csw.export export)) ((~ classC) (~ g!sub)) - (All [(~+ protocol-varsC+)] - (-> (~ class-protocolC) - ((~ protocolC) (~+ protocol-varsC+)))) - ((~ tagC) (~ g!sub)))))))) - -(type: Super-Syntax - (#Method Method-Syntax) - (#Class Class-Syntax)) - -(def: super|r - (s.Syntax Super-Syntax) - (p.alt method|r - class|r)) - -(def: (super|w g!return) - (-> Code Super-Syntax Code) - (sum.either (method|w g!return) - (class|w g!return))) - -(def: (super|c export protocol) - (-> Bit cs.Declaration (| Method-Syntax Class-Syntax) (Meta Code)) - (sum.either (method|c export protocol) - (class|c export protocol))) - -(syntax: #export (protocol: - {export csr.export} - {declaration csr.declaration} - {supers (p.many super|r)}) - (macro.with-gensyms [g!return] - (do @ - [constructors (monad.map @ (super|c export declaration) supers) - #let [protocolC (code.local-symbol (get@ #cs.declaration-name declaration)) - varsC+ (csw.type-variables (get@ #cs.declaration-args declaration))]] - (wrap (list& (` (type: (~+ (csw.export export)) - ((~ protocolC) (~+ varsC+) (~ g!return)) - (~+ (list/map (super|w g!return) supers)))) - constructors))))) diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux index 2aafa9571..93365f61e 100644 --- a/stdlib/source/lux/world/console.lux +++ b/stdlib/source/lux/world/console.lux @@ -1,105 +1,72 @@ (.module: [lux #* - [control [monad (#+ do)]] + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] [data - ["e" error] - ["." text]] + ["." error] + ["." text + format]] [concurrency ["." promise] ["." task (#+ Task)]] - [type - [object - interface]] ["." io (#+ IO Process io)] [host (#+ import:)]]) -(interface: #export Console - (read-char [] (Task Text)) - (read-line [] (Task Text)) - (write [Text] (Task Any)) - (close [] (Task Any))) +(exception: #export (cannot-close) + "") + +(signature: #export (Console m) + (: (-> [] (m Nat)) + read) + (: (-> [] (m Text)) + read-line) + (: (-> [Text] (m Any)) + write) + (: (-> [] (m Any)) + close)) (for {"JVM" - (as-is (import: java/io/InputStream - (read [] #io #try int) - (available [] #io #try int) - (mark [int] #io #try void) - (reset [] #io #try void)) + (as-is (import: java/lang/String) + + (import: #long java/io/Console + (readLine [] #io #try String)) - (import: java/io/Reader) + (import: java/io/InputStream + (read [] #io #try int)) (import: java/io/PrintStream (print [String] #io #try void)) (import: java/lang/System + (#static console [] #io #try java/io/Console) (#static in java/io/InputStream) (#static out java/io/PrintStream)) - (import: java/lang/Appendable - (append [CharSequence] Appendable)) - - (import: java/lang/String) - - (import: java/lang/StringBuffer - (new [String]) - (toString [] String)) - - (class: JVM-Console Console - {#input InputStream - #output PrintStream} - - (def: read-char - (|>> get@Console - (get@ #input) - (InputStream::read []) - (:: io.Functor<Process> map (|>> .nat text.from-code)) - promise.future)) - - (def: (read-line console) - (let [input (|> console get@Console (get@ #input)) - buffer (StringBuffer::new [""])] - (promise.future - (loop [_ []] - (do io.Monad<Process> - [char (<| (:: @ map (|>> .nat text.from-code)) - (InputStream::read [] input))] - (case char - "\n" - (wrap (StringBuffer::toString [] buffer)) - - "\r" - (do @ - [available (InputStream::available [] input)] - (if (i/> 0 available) - (do @ - [_ (InputStream::mark [10] input) - next (<| (:: @ map (|>> .nat text.from-code)) - (InputStream::read [] input))] - (case next - "\n" - (wrap (StringBuffer::toString [] buffer)) - - _ - (do @ - [_ (InputStream::reset [] input)] - (wrap (StringBuffer::toString [] buffer))))) - (wrap (StringBuffer::toString [] buffer)))) - - _ - (exec (Appendable::append [(:coerce String char)] buffer) - (recur [])))))))) - - (def: (write message) - (|>> get@Console - (get@ #output) - (PrintStream::print [message]) - promise.future)) - - (def: (close self) - (task.return []))) - (def: #export open - (Process Console) - (io (#e.Success (new@JVM-Console {#input System::in - #output System::out}))))) + (Process (Console Task)) + (do io.Monad<Process> + [jvm-console (System::console []) + #let [jvm-input System::in + jvm-output System::out]] + (wrap (: (Console Task) + (structure + (def: (read _) + (|> jvm-input + (InputStream::read []) + (:: io.Functor<Process> map .nat) + promise.future)) + + (def: (read-line _) + (|> jvm-console (java/io/Console::readLine []) promise.future)) + + (def: (write message) + (|> jvm-output (PrintStream::print [message]) promise.future)) + + (def: close + (|>> (ex.construct cannot-close) task.fail)))))))) }) + +(def: #export (write-line message console) + (All [m] (-> Text (Console m) (m Any))) + (:: console write (format message ""))) diff --git a/stdlib/test/test/lux/type/object/interface.lux b/stdlib/test/test/lux/type/object/interface.lux deleted file mode 100644 index 9f1c25ad2..000000000 --- a/stdlib/test/test/lux/type/object/interface.lux +++ /dev/null @@ -1,87 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." list]]] - [type - [object - interface]]]) - -## No parameters -(interface: Counter - (inc! [] @) - (read! [] Nat)) - -(class: NatC Counter - Nat - - (def: inc! - (update@Counter inc)) - - (def: read! - get@Counter)) - -(interface: Resettable-Counter - #super Counter - (reset [] @)) - -(class: NatRC Resettable-Counter - #super NatC - Any - - (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) - Any - - (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/protocol.lux b/stdlib/test/test/lux/type/object/protocol.lux deleted file mode 100644 index fe463205d..000000000 --- a/stdlib/test/test/lux/type/object/protocol.lux +++ /dev/null @@ -1,133 +0,0 @@ -(.module: - [lux #* - [data - [text - format]] - [type - [object - protocol]]]) - -(type: Counter (Object (Method Any Nat))) - -(def: (count [tick return] state) - (Class Nat (Method Any Nat)) - (let [state' (inc state)] - [(return state') state'])) - -(def: counter - (-> Nat Counter) - (object count)) - -(def: _test0 - [Nat Counter] - ((counter +0) (message []))) - -(protocol: Protocol0 - (method0 [Bit Nat Text] Bit) - (method1 [Nat Text Bit] Nat) - (method2 [Text Bit Nat] Text)) - -(type: Object0 (Object Protocol0)) - -(def: object0 - Object0 - (loop [num-calls +0] - (function (_ message) - [(case message - (#method0 [arg0 arg1 arg2] output) - (output (n/= +0 (n/% +2 num-calls))) - - (#method1 [arg0 arg1 arg2] output) - (output num-calls) - - (#method2 [arg0 arg1 arg2] output) - (output (%n num-calls))) - (recur (inc num-calls))]))) - -(def: _test1 - [Nat Object0] - (object0 (method1 [+0 "0" #0]))) - -(protocol: (Read a) - (read [] a)) - -(def: (readM [tick return] state) - (All [s] (Class s (Method Any s))) - [(return state) state]) - -(protocol: (Add n) - (+ n Any) - (- n Any)) - -(protocol: (Mul n) - (* n Any) - (/ n Any)) - -(do-template [<name> <op>] - [(def: (<name> [diff return] state) - (Class Nat (Method Nat Any)) - [(return []) (<op> diff state)])] - - [+M n/+] - [-M n/-] - [*M n/*] - [/M n//] - ) - -(def: addM - (Class Nat (Add Nat)) - (alt +M -M)) - -(def: mulM - (Class Nat (Mul Nat)) - (alt *M /M)) - -(type: (Number n) - ($_ Alt - (Read n) - (Add n) - (Mul n))) - -## TODO: Fix when new-luxc is the official compiler. -## (protocol: (Number n) -## (^read (Read n)) -## (^add (Add n)) -## (^mul (Mul n))) - -(def: numberM - (Class Nat (Number Nat)) - ($_ alt - readM - addM - mulM)) - -(type: NatO (Object (Number Nat))) - -(def: numberO - NatO - (object numberM +1)) - -(def: _test2 - [Nat NatO] - (numberO (+0 (read [])))) - -(def: _test3 - [Any NatO] - (numberO (+1 (+0 (+ +123))))) - -(def: _test4 - [Any NatO] - (numberO (+1 (+1 (* +123))))) - -## TODO: Fix when new-luxc is the official compiler. -## (def: _test2 -## [Nat NatO] -## (numberO (^read (read [])))) - -## (def: _test3 -## [Any NatO] -## (numberO (^add (+ +123)))) - -## (def: _test4 -## [Any NatO] -## (numberO (^mul (* +123)))) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index db2687876..2380365bf 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -145,10 +145,7 @@ ["_." type ["_." check] ## ["_." implicit] ## TODO: Specially troublesome... - ["_." resource] - [object - ["_." interface] - ["_." protocol]]] + ["_." resource]] [compiler [default ["_default/." syntax] |