From 3f010de748ffccf304c4be09863f77d4020d610d Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Thu, 25 Aug 2022 21:31:54 -0400
Subject: Added support for type-based polymorphism.
---
.../lux/control/function/polymorphism/type.lux | 72 ++++++++++++++++++++++
stdlib/source/library/lux/meta/type/poly.lux | 11 ++--
stdlib/source/test/lux/control/function.lux | 5 +-
.../lux/control/function/polymorphism/type.lux | 41 ++++++++++++
stdlib/source/test/lux/meta/type.lux | 4 +-
stdlib/source/test/lux/meta/type/poly.lux | 48 +++++++++++++++
6 files changed, 175 insertions(+), 6 deletions(-)
create mode 100644 stdlib/source/library/lux/control/function/polymorphism/type.lux
create mode 100644 stdlib/source/test/lux/control/function/polymorphism/type.lux
create mode 100644 stdlib/source/test/lux/meta/type/poly.lux
(limited to 'stdlib/source')
diff --git a/stdlib/source/library/lux/control/function/polymorphism/type.lux b/stdlib/source/library/lux/control/function/polymorphism/type.lux
new file mode 100644
index 000000000..1159bc488
--- /dev/null
+++ b/stdlib/source/library/lux/control/function/polymorphism/type.lux
@@ -0,0 +1,72 @@
+(.require
+ [library
+ [lux (.except def)
+ [abstract
+ [monad (.only do)]]
+ [control
+ ["?" parser (.use "[1]#[0]" monad)]]
+ [data
+ ["[0]" text (.use "[1]#[0]" equivalence)]
+ [collection
+ ["[0]" list (.use "[1]#[0]" functor)]]]
+ ["[0]" meta (.only)
+ ["[0]" code (.only)
+ ["?[1]" \\parser (.only Parser)]]
+ [macro (.only with_symbols)
+ ["[0]" context]
+ [syntax (.only syntax)
+ ["[0]" export]]]
+ [type
+ [implicit (.only a/an)]]]]])
+
+(type Polymorphism
+ (Record
+ [#name Text
+ #interface Code
+ #method Code]))
+
+(context.def [stack expression declaration] Polymorphism)
+
+(.def .public def
+ (syntax (_ [[export_policy name parameters type methods]
+ (export.parser
+ (all ?.and
+ ?code.local
+ (?code.tuple (?.many ?code.local))
+ ?code.any
+ (?.many ?code.any)))])
+ (<| (with_symbols [g!_ g!interface g!method g!inputs])
+ (..declaration [#name name #interface g!interface #method g!method])
+ (let [name (code.local name)
+ parameters (list#each code.local parameters)])
+ (` (these (type (, export_policy) (, g!interface)
+ (Interface
+ (is (All ((, g!_) (,* parameters))
+ (, type))
+ (, g!method))))
+ (.def (, export_policy) (, name)
+ (syntax ((, g!_) [(, g!inputs) (?.many ?code.any)])
+ (at meta.monad (,' in)
+ (list (` (a/an (, g!method) ((,' .,*) (, g!inputs))))))))
+ (,* methods))))))
+
+(.def method_declaration
+ (Parser [Text (List Code)])
+ (?.either (?code.form (?.and ?code.local (?.some ?code.any)))
+ (?.and ?code.local (?#in (list)))))
+
+(.def .public method
+ (syntax (_ [[[name inputs] specialization body]
+ (all ?.and
+ ..method_declaration
+ (?code.tuple (?.many ?code.any))
+ ?code.any)])
+ (do meta.monad
+ [it (context.search (|>> (the #name) (text#= name)) ..stack)
+ .let [name (code.local name)]]
+ (with_symbols [g!self]
+ (in (list (` (.def .public (, g!self)
+ ((, (the #interface it)) (,* specialization))
+ (implementation
+ (.def ((, (the #method it)) (,* inputs))
+ (, body)))))))))))
diff --git a/stdlib/source/library/lux/meta/type/poly.lux b/stdlib/source/library/lux/meta/type/poly.lux
index cccc9e518..a98fd211c 100644
--- a/stdlib/source/library/lux/meta/type/poly.lux
+++ b/stdlib/source/library/lux/meta/type/poly.lux
@@ -39,7 +39,7 @@
(, body)))
(.as .Type (, g!type))))
{.#Right (, g!output)}
- ((,' in) (.list (, g!output)))
+ (at ///.monad (,' in) (.list (, g!output)))
{.#Left (, g!output)}
(///.failure (, g!output))))))))))))
@@ -54,7 +54,8 @@
(^.with_template [<tag>]
[{<tag> idx}
(` {<tag> (, (code.nat idx))})])
- ([.#Var] [.#Ex])
+ ([.#Var]
+ [.#Ex])
{.#Parameter idx}
(let [idx (<//>.argument env idx)]
@@ -72,7 +73,8 @@
[{<tag> left right}
(` {<tag> (, (code env left))
(, (code env right))})])
- ([.#Function] [.#Apply])
+ ([.#Function]
+ [.#Apply])
(^.with_template [<macro> <tag> <flattener>]
[{<tag> left right}
@@ -87,4 +89,5 @@
[{<tag> scope body}
(` {<tag> (.list (,* (list#each (code env) scope)))
(, (code env body))})])
- ([.#UnivQ] [.#ExQ])))
+ ([.#UnivQ]
+ [.#ExQ])))
diff --git a/stdlib/source/test/lux/control/function.lux b/stdlib/source/test/lux/control/function.lux
index aad5f2ebf..d87f6f3cd 100644
--- a/stdlib/source/test/lux/control/function.lux
+++ b/stdlib/source/test/lux/control/function.lux
@@ -23,7 +23,9 @@
["[1][0]" predicate]
["[1][0]" variadic]
["[1][0]" named]
- ["[1][0]" trampoline]])
+ ["[1][0]" trampoline]
+ ["[1][0]" polymorphism
+ ["[1]/[0]" type]]])
(def .public test
Test
@@ -73,4 +75,5 @@
/variadic.test
/named.test
/trampoline.test
+ /polymorphism/type.test
))))
diff --git a/stdlib/source/test/lux/control/function/polymorphism/type.lux b/stdlib/source/test/lux/control/function/polymorphism/type.lux
new file mode 100644
index 000000000..a5ed74cca
--- /dev/null
+++ b/stdlib/source/test/lux/control/function/polymorphism/type.lux
@@ -0,0 +1,41 @@
+(.require
+ [library
+ [lux (.except)
+ [abstract
+ [monad (.only do)]]
+ [data
+ ["[0]" text (.use "[1]#[0]" equivalence)
+ ["%" \\format]]]
+ [math
+ ["[0]" random]]
+ [test
+ ["_" property (.only Test)]]]]
+ [\\library
+ ["[0]" /]])
+
+(/.def .public format
+ [a]
+ (-> a Text)
+
+ (/.method format
+ [Bit]
+ %.bit)
+
+ (/.method (format it)
+ [Nat]
+ (%.nat it))
+ )
+
+(def .public test
+ Test
+ (<| (_.covering /._)
+ (do [! random.monad]
+ [bit random.bit
+ nat random.nat])
+ (all _.and
+ (_.coverage [/.def /.method]
+ (and (text#= (%.bit bit)
+ (format bit))
+ (text#= (%.nat nat)
+ (format nat))))
+ )))
diff --git a/stdlib/source/test/lux/meta/type.lux b/stdlib/source/test/lux/meta/type.lux
index 3c6872d26..67119dd60 100644
--- a/stdlib/source/test/lux/meta/type.lux
+++ b/stdlib/source/test/lux/meta/type.lux
@@ -41,7 +41,8 @@
["[1][0]" refinement]
["[1][0]" resource]
["[1][0]" unit]
- ["[1][0]" variance]])
+ ["[1][0]" variance]
+ ["[1][0]" poly]])
(def !expect
(template (_ <pattern> <value>)
@@ -570,4 +571,5 @@
/resource.test
/unit.test
/variance.test
+ /poly.test
)))
diff --git a/stdlib/source/test/lux/meta/type/poly.lux b/stdlib/source/test/lux/meta/type/poly.lux
new file mode 100644
index 000000000..e2aa7d03e
--- /dev/null
+++ b/stdlib/source/test/lux/meta/type/poly.lux
@@ -0,0 +1,48 @@
+(.require
+ [library
+ [lux (.except)
+ [abstract
+ [monad (.only do)]]
+ [control
+ ["?" parser]]
+ [data
+ ["[0]" bit (.use "[1]#[0]" equivalence)]]
+ [math
+ ["[0]" random]
+ [number
+ ["[0]" nat (.use "[1]#[0]" equivalence)]]]
+ [meta
+ ["[0]" static]
+ ["[0]" type
+ ["?[1]" \\parser]]]
+ [test
+ ["_" property (.only Test)]]]]
+ [\\library
+ ["[0]" /]])
+
+(with_expansions [<bit> (static.random_bit)
+ <nat> (static.random_nat)]
+ (def constant
+ (/.polytypic constant
+ (`` (all ?.either
+ (,, (with_template [<type> <constant>]
+ [(do ?.monad
+ [_ (?type.sub <type>)]
+ (in (` (is <type>
+ <constant>))))]
+
+ [Bit <bit>]
+ [Nat <nat>]))
+ ))))
+
+ (def .public test
+ Test
+ (<| (_.covering /._)
+ (do [! random.monad]
+ [])
+ (all _.and
+ (_.coverage [/.polytypic]
+ (and (bit#= <bit> (constant Bit))
+ (nat#= <nat> (constant Nat))))
+ )))
+ )
--
cgit v1.2.3