From 8d5b71001f0600909d11909acaffa4c2d6f98131 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sun, 11 Feb 2018 20:16:22 -0400
Subject: - Added initial implementation of protocol-based object-oriented
programming.
---
stdlib/source/lux/control/exception.lux | 2 +-
stdlib/source/lux/macro.lux | 2 +-
stdlib/source/lux/macro/syntax/common/writer.lux | 16 +++--
stdlib/source/lux/type/object/protocol.lux | 84 ++++++++++++++++++++++++
4 files changed, 96 insertions(+), 8 deletions(-)
create mode 100644 stdlib/source/lux/type/object/protocol.lux
(limited to 'stdlib/source')
diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
index c37b759a2..8a959b6c8 100644
--- a/stdlib/source/lux/control/exception.lux
+++ b/stdlib/source/lux/control/exception.lux
@@ -91,7 +91,7 @@
g!self (code.local-symbol name)]]
(wrap (list (` (def: (~+ (csw.export export))
(~ g!self)
- (All (~ (csw.type-variables t-vars))
+ (All [(~+ (csw.type-variables t-vars))]
(..Exception [(~+ (list/map (get@ #cs.input-type) inputs))]))
(let [(~ g!descriptor) (~ (code.text descriptor))]
{#..label (~ g!descriptor)
diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux
index 27329e55c..01f1806c4 100644
--- a/stdlib/source/lux/macro.lux
+++ b/stdlib/source/lux/macro.lux
@@ -392,7 +392,7 @@
#let [symbol-defs (list/join (list/map (: (-> Text (List Code))
(function [name] (list (code.symbol ["" name]) (` (gensym (~ (code.text name)))))))
symbol-names))]]
- (wrap (list (` (do Monad
+ (wrap (list (` ((~! do) (~! Monad)
[(~+ symbol-defs)]
(~ body))))))
diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux
index e9f899f1d..9c304223e 100644
--- a/stdlib/source/lux/macro/syntax/common/writer.lux
+++ b/stdlib/source/lux/macro/syntax/common/writer.lux
@@ -1,23 +1,27 @@
-(.module: {#.doc "Commons syntax writers."}
+(.module:
+ {#.doc "Commons syntax writers."}
lux
(lux (data (coll [list "list/" Functor])
[product])
(macro [code]))
[//])
-## Exports
(def: #export (export exported?)
(-> Bool (List Code))
(if exported?
(list (' #export))
(list)))
-## Annotations
+(def: #export (declaration declaration)
+ (-> //.Declaration Code)
+ (` ((~ (code.local-symbol (get@ #//.declaration-name declaration)))
+ (~+ (list/map code.local-symbol
+ (get@ #//.declaration-args declaration))))))
+
(def: #export (annotations anns)
(-> //.Annotations Code)
(|> anns (list/map (product.both code.tag id)) code.record))
-## Type-Variables
(def: #export (type-variables vars)
- (-> (List Text) Code)
- (code.tuple (list/map code.local-symbol vars)))
+ (-> (List Text) (List Code))
+ (list/map code.local-symbol vars))
diff --git a/stdlib/source/lux/type/object/protocol.lux b/stdlib/source/lux/type/object/protocol.lux
new file mode 100644
index 000000000..73bc9226f
--- /dev/null
+++ b/stdlib/source/lux/type/object/protocol.lux
@@ -0,0 +1,84 @@
+(.module:
+ lux
+ (lux (control ["p" parser]
+ [monad #+ do])
+ (data (coll [list "list/" Functor]))
+ [macro "meta/" Monad]
+ (macro [code]
+ ["s" syntax #+ syntax:]
+ (syntax ["cs" common]
+ (common ["csr" reader]
+ ["csw" writer])))))
+
+(type: #export (Simple i o)
+ (All [r] [i (-> o r)]))
+
+(type: #export (Message i o)
+ (Simple i o o))
+
+(def: #export (message input)
+ (All [i o] (-> i (Message i o)))
+ [input id])
+
+(type: #export (Method s p)
+ (All [r] (-> (p r) s [r s])))
+
+(type: #export (Object p)
+ (All [r] (-> (p r) [r (Object p)])))
+
+(def: #export (object method init)
+ (All [s p] (-> (Method s p) s (Object p)))
+ (loop [state init]
+ (function [input]
+ (let [[output state'] (method input state)]
+ [output (recur state')]))))
+
+(type: Method-Syntax
+ {#type-variables (List Text)
+ #name Text
+ #input Code
+ #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)
+ (` ((~ (code.local-tag (get@ #name method)))
+ (All [(~+ (csw.type-variables (get@ #type-variables method)))]
+ [(~ (get@ #input method))
+ (-> (~ (get@ #output method)) (~ g!return))]))))
+
+(def: (method-constructor export protocol method)
+ (-> Bool cs.Declaration Method-Syntax (Meta Code))
+ (let [methodC (code.local-symbol (get@ #name method))
+ tagC (code.local-tag (get@ #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@ #type-variables method))
+ method-inputC (get@ #input method)
+ method-outputC (get@ #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])))))))
+
+(syntax: #export (protocol: [export csr.export]
+ [declaration csr.declaration]
+ [methods (p.many method|r)])
+ (macro.with-gensyms [g!return]
+ (do @
+ [constructors (monad.map @ (method-constructor export declaration) methods)
+ #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 (method|w g!return) methods))))
+ constructors)))))
--
cgit v1.2.3