aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/type/object/interface.lux515
-rw-r--r--stdlib/source/lux/type/object/protocol.lux158
-rw-r--r--stdlib/source/lux/world/console.lux133
-rw-r--r--stdlib/test/test/lux/type/object/interface.lux87
-rw-r--r--stdlib/test/test/lux/type/object/protocol.lux133
-rw-r--r--stdlib/test/tests.lux5
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]