aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/library/lux/macro/context.lux159
-rw-r--r--stdlib/source/library/lux/meta.lux56
-rw-r--r--stdlib/source/library/lux/type/primitive.lux235
-rw-r--r--stdlib/source/test/lux/macro.lux4
-rw-r--r--stdlib/source/test/lux/macro/context.lux12
-rw-r--r--stdlib/source/test/lux/type/primitive.lux118
6 files changed, 289 insertions, 295 deletions
diff --git a/stdlib/source/library/lux/macro/context.lux b/stdlib/source/library/lux/macro/context.lux
new file mode 100644
index 000000000..4fe898ee4
--- /dev/null
+++ b/stdlib/source/library/lux/macro/context.lux
@@ -0,0 +1,159 @@
+(.require
+ [library
+ [lux (.except def global)
+ [abstract
+ [monad (.only do)]
+ ["[0]" predicate (.only Predicate)]]
+ [control
+ ["[0]" exception (.only exception:)]
+ ["[0]" maybe]
+ ["?" parser (.only)
+ ["?[0]" code]]]
+ [data
+ ["[0]" text (.use "[1]#[0]" equivalence monoid)]
+ [collection
+ ["[0]" list]
+ [dictionary
+ ["[0]" plist (.only PList)]]]]
+ ["[0]" meta (.only)
+ ["[0]" symbol (.use "[1]#[0]" codec)]]]]
+ ["[0]" // (.only)
+ [syntax (.only syntax)]
+ ["^" pattern]
+ ["[0]" code]])
+
+(type: .public Stack
+ List)
+
+(exception: .public (no_definition [it Symbol])
+ (exception.report
+ "Definition" (symbol#encoded it)))
+
+(.def (global it)
+ (-> Symbol (Meta Any))
+ (do meta.monad
+ [.let [[@ expected_name] it]
+ defs (meta.definitions @)]
+ (case (list.one (function (_ [actual_name [exported? type value]])
+ (if (text#= expected_name actual_name)
+ {.#Some value}
+ {.#None}))
+ defs)
+ {.#Some it}
+ (in it)
+
+ {.#None}
+ (meta.failure (exception.error ..no_definition [it])))))
+
+(exception: .public no_active_context)
+
+(.def (peek' _ context)
+ (All (_ a) (-> (Stack a) Symbol (Meta a)))
+ (do meta.monad
+ [stack (..global context)]
+ (case (|> stack
+ (as (Stack Any))
+ list.head)
+ {.#Some top}
+ (in (as_expected top))
+
+ {.#None}
+ (meta.failure (exception.error ..no_active_context [])))))
+
+(.def .public peek
+ (syntax (_ [g!it (at ?.monad each code.symbol ?code.global)])
+ (in (list (` ((~! ..peek') (~ g!it) (.symbol (~ g!it))))))))
+
+(exception: .public no_example)
+
+(.def (search' _ ? context)
+ (All (_ a) (-> (Stack a) (Predicate a) Symbol (Meta a)))
+ (do meta.monad
+ [stack (..global context)]
+ (case (|> stack
+ (as (Stack Any))
+ (list.example (as (Predicate Any) ?)))
+ {.#Some it}
+ (in (as_expected it))
+
+ {.#None}
+ (meta.failure (exception.error ..no_example [])))))
+
+(.def .public search
+ (syntax (_ [g!context (at ?.monad each code.symbol ?code.global)
+ g!? ?code.any])
+ (in (list (` ((~! ..search') (~ g!context) (~ g!?) (.symbol (~ g!context))))))))
+
+(.def (alter on_definition [@ context])
+ (-> (-> Definition Definition) Symbol (Meta Any))
+ (function (_ lux)
+ (let [on_global (is (-> Global Global)
+ (function (_ it)
+ (case it
+ {.#Definition it}
+ {.#Definition (on_definition it)}
+
+ _
+ it)))
+ on_globals (is (-> (PList Global) (PList Global))
+ (plist.revised context on_global))
+ on_module (is (-> Module Module)
+ (revised .#definitions on_globals))]
+ {.#Right [(revised .#modules (plist.revised @ on_module) lux)
+ []]})))
+
+(.def (push' _ top)
+ (All (_ a) (-> (Stack a) a Symbol (Meta Any)))
+ (alter (function (_ [exported? type stack])
+ (|> stack
+ (as (Stack Any))
+ {.#Item top}
+ (is (Stack Any))
+ [exported? type]))))
+
+(.def .public push
+ (syntax (_ [g!context (at ?.monad each code.symbol ?code.global)
+ g!it ?code.any])
+ (in (list (` ((~! ..push') (~ g!context) (~ g!it) (.symbol (~ g!context))))))))
+
+(.def pop'
+ (-> Symbol (Meta Any))
+ (alter (function (_ [exported? type value])
+ [exported? type (let [value (as (Stack Any) value)]
+ (maybe.else value (list.tail value)))])))
+
+(.def .public pop
+ (syntax (_ [expression? ?code.bit
+ context ?code.global])
+ (do meta.monad
+ [_ (..pop' context)]
+ (in (if expression?
+ (list (' []))
+ (list))))))
+
+(.def .public def
+ (syntax (_ [.let [! ?.monad
+ ?local (at ! each code.local ?code.local)]
+ [$ g!expression g!declaration] (?code.tuple (all ?.and ?code.local ?local ?local))
+ context_type ?code.any])
+ (do [! meta.monad]
+ [@ meta.current_module_name
+ .let [g!context (code.symbol [@ $])]]
+ (//.with_symbols [g!it g!body g!_]
+ (in (list (` (.def (~ (code.local $))
+ (..Stack (~ context_type))
+ (list)))
+ (` (.def ((~ g!expression) (~ g!it) (~ g!body))
+ (-> (~ context_type) Code (Meta Code))
+ ((~! do) (~! meta.monad)
+ [(~ g!_) ((~! ..push) (~ g!context) (~ g!it))]
+ ((~' in) (` (let [((~' ~') (~ g!body)) ((~' ~) (~ g!body))
+ ((~' ~') (~ g!_)) ((~! ..pop) #1 (~ g!context))]
+ ((~' ~') (~ g!body))))))))
+ (` (.def ((~ g!declaration) (~ g!it) (~ g!body))
+ (-> (~ context_type) Code (Meta (List Code)))
+ ((~! do) (~! meta.monad)
+ [(~ g!_) ((~! ..push) (~ g!context) (~ g!it))]
+ ((~' in) (list (~ g!body)
+ (` ((~! ..pop) #0 (~ g!context))))))))
+ ))))))
diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux
index 6987ae558..cc3aa9036 100644
--- a/stdlib/source/library/lux/meta.lux
+++ b/stdlib/source/library/lux/meta.lux
@@ -36,11 +36,11 @@
(def (each f fa)
(function (_ lux)
(case (fa lux)
- {try.#Failure msg}
- {try.#Failure msg}
-
{try.#Success [lux' a]}
- {try.#Success [lux' (f a)]})))))
+ {try.#Success [lux' (f a)]}
+
+ {try.#Failure msg}
+ {try.#Failure msg})))))
(def .public apply
(Apply Meta)
@@ -73,11 +73,11 @@
(def (conjoint mma)
(function (_ lux)
(case (mma lux)
- {try.#Failure msg}
- {try.#Failure msg}
-
{try.#Success [lux' ma]}
- (ma lux'))))))
+ (ma lux')
+
+ {try.#Failure msg}
+ {try.#Failure msg})))))
(def .public (result' lux action)
(All (_ a) (-> Lux (Meta a) (Try [Lux a])))
@@ -86,21 +86,21 @@
(def .public (result lux action)
(All (_ a) (-> Lux (Meta a) (Try a)))
(case (action lux)
- {try.#Failure error}
- {try.#Failure error}
-
{try.#Success [_ output]}
- {try.#Success output}))
+ {try.#Success output}
+
+ {try.#Failure error}
+ {try.#Failure error}))
(def .public (either left right)
(All (_ a) (-> (Meta a) (Meta a) (Meta a)))
(function (_ lux)
(case (left lux)
- {try.#Failure error}
- (right lux)
-
{try.#Success [lux' output]}
- {try.#Success [lux' output]})))
+ {try.#Success [lux' output]}
+
+ {try.#Failure error}
+ (right lux))))
(def .public (assertion message test)
(-> Text Bit (Meta Any))
@@ -170,9 +170,6 @@
(function (_ lux)
{try.#Success [lux
(case (..current_module_name lux)
- {try.#Failure error}
- {.#None}
-
{try.#Success [_ this_module]}
(let [modules (the .#modules lux)]
(loop (again [module module
@@ -200,7 +197,10 @@
{.#None}
{.#Slot _}
- {.#None})))))]}))))
+ {.#None}))))
+
+ {try.#Failure error}
+ {.#None})]}))))
(def .public seed
(Meta Nat)
@@ -456,11 +456,11 @@
(-> Text (Meta (List [Text Global])))
(function (_ lux)
(case (plist.value module (the .#modules lux))
- {.#None}
- {try.#Failure (all text#composite "Unknown module: " module)}
-
{.#Some module}
- {try.#Success [lux (the .#definitions module)]})))
+ {try.#Success [lux (the .#definitions module)]}
+
+ {.#None}
+ {try.#Failure (all text#composite "Unknown module: " module)})))
(def .public (definitions module)
(-> Text (Meta (List [Text Definition])))
@@ -600,15 +600,15 @@
(Meta (List (List [Text Type])))
(function (_ lux)
(case (list.inits (the .#scopes lux))
- {.#None}
- {try.#Failure "No local environment"}
-
{.#Some scopes}
{try.#Success [lux
(list#each (|>> (the [.#locals .#mappings])
(list#each (function (_ [name [type _]])
[name type])))
- scopes)]})))
+ scopes)]}
+
+ {.#None}
+ {try.#Failure "No local environment"})))
(def .public (de_aliased def_name)
(-> Symbol (Meta Symbol))
diff --git a/stdlib/source/library/lux/type/primitive.lux b/stdlib/source/library/lux/type/primitive.lux
index 52655b950..0bddb9c84 100644
--- a/stdlib/source/library/lux/type/primitive.lux
+++ b/stdlib/source/library/lux/type/primitive.lux
@@ -3,39 +3,25 @@
[lux (.except)
["[0]" meta]
[abstract
- [monad (.only Monad do)]]
+ [monad (.only do)]]
[control
["[0]" exception (.only exception:)]
["<>" parser (.use "[1]#[0]" monad)
["<[0]>" code (.only Parser)]]]
[data
- ["[0]" text (.use "[1]#[0]" equivalence monoid)]
+ ["[0]" text (.use "[1]#[0]" equivalence)]
[collection
- ["[0]" list (.use "[1]#[0]" functor monoid)]]]
- [macro
+ ["[0]" list (.use "[1]#[0]" functor)]]]
+ ["[0]" macro (.only)
["^" pattern]
["[0]" code]
+ ["[0]" context]
[syntax (.only syntax)
["|[0]|" export]]]
[meta
["[0]" symbol (.use "[1]#[0]" codec)]]]]
["[0]" //])
-(type: Stack
- List)
-
-(def peek
- (All (_ a) (-> (Stack a) (Maybe a)))
- list.head)
-
-(def (push value stack)
- (All (_ a) (-> a (Stack a) (Stack a)))
- {.#Item value stack})
-
-(def pop
- (All (_ a) (-> (Stack a) (Maybe (Stack a))))
- list.tail)
-
(type: .public Frame
(Record
[#name Text
@@ -43,144 +29,15 @@
#abstraction Code
#representation Code]))
-(def frames
- (Stack Frame)
- {.#End})
-
-(def !peek
- (template (_ <source> <reference> <then>)
- [(loop (again [entries <source>])
- (case entries
- {.#Item [head_name head] tail}
- (if (text#= <reference> head_name)
- <then>
- (again tail))
-
- {.#End}
- (undefined)))]))
-
-(def (peek_frames_definition reference source)
- (-> Text (List [Text Global]) (Stack Frame))
- (!peek source reference
- (case head
- {.#Definition [exported? frame_type frame_value]}
- (as (Stack Frame) frame_value)
+(context.def [frames expression declaration] Frame)
- (^.or {.#Type _}
- {.#Alias _}
- {.#Tag _}
- {.#Slot _})
- (undefined))))
-
-(def (peek_frames reference definition_reference source)
- (-> Text Text (List [Text Module]) (Stack Frame))
- (!peek source reference
- (peek_frames_definition definition_reference (the .#definitions head))))
-
-(exception: .public no_active_frames)
-
-(def (peek! frame)
- (-> (Maybe Text) (Meta Frame))
- (function (_ compiler)
- (let [[reference definition_reference] (symbol ..frames)
- current_frames (peek_frames reference definition_reference (the .#modules compiler))]
- (case (case frame
- {.#Some frame}
- (list.example (function (_ [actual _])
- (text#= frame actual))
- current_frames)
-
- {.#None}
- (..peek current_frames))
- {.#Some frame}
- {.#Right [compiler frame]}
-
- {.#None}
- (exception.except ..no_active_frames [])))))
-
-(def .public current
+(.def .public current
(Meta Frame)
- (..peek! {.#None}))
+ (context.peek ..frames))
-(def .public (specific name)
+(.def .public (specific name)
(-> Text (Meta Frame))
- (..peek! {.#Some name}))
-
-(def !push
- (template (_ <source> <reference> <then>)
- [(loop (again [entries <source>])
- (case entries
- {.#Item [head_name head] tail}
- (if (text#= <reference> head_name)
- {.#Item [head_name <then>]
- tail}
- {.#Item [head_name head]
- (again tail)})
-
- {.#End}
- (undefined)))]))
-
-(def (push_frame_definition reference frame source)
- (-> Text Frame (List [Text Global]) (List [Text Global]))
- (!push source reference
- (case head
- {.#Definition [exported? frames_type frames_value]}
- {.#Definition [exported?
- frames_type
- (..push frame (as (Stack Frame) frames_value))]}
-
- (^.or {.#Type _}
- {.#Alias _}
- {.#Tag _}
- {.#Slot _})
- (undefined))))
-
-(def (push_frame [module_reference definition_reference] frame source)
- (-> Symbol Frame (List [Text Module]) (List [Text Module]))
- (!push source module_reference
- (revised .#definitions (push_frame_definition definition_reference frame) head)))
-
-(def (push! frame)
- (-> Frame (Meta Any))
- (function (_ compiler)
- {.#Right [(revised .#modules
- (..push_frame (symbol ..frames) frame)
- compiler)
- []]}))
-
-(def (pop_frame_definition reference source)
- (-> Text (List [Text Global]) (List [Text Global]))
- (!push source reference
- (case head
- {.#Definition [exported? frames_type frames_value]}
- {.#Definition [exported?
- frames_type
- (let [current_frames (as (Stack Frame) frames_value)]
- (case (..pop current_frames)
- {.#Some current_frames'}
- current_frames'
-
- {.#None}
- current_frames))]}
-
- (^.or {.#Type _}
- {.#Alias _}
- {.#Tag _}
- {.#Slot _})
- (undefined))))
-
-(def (pop_frame [module_reference definition_reference] source)
- (-> Symbol (List [Text Module]) (List [Text Module]))
- (!push source module_reference
- (|> head (revised .#definitions (pop_frame_definition definition_reference)))))
-
-(def pop!
- (syntax (_ [])
- (function (_ compiler)
- {.#Right [(revised .#modules
- (..pop_frame (symbol ..frames))
- compiler)
- (list)]})))
+ (context.search ..frames (|>> (the #name) (text#= name))))
(def cast
(Parser [(Maybe Text) Code])
@@ -191,7 +48,12 @@
[(def .public <name>
(syntax (_ [[frame value] ..cast])
(do meta.monad
- [[name type_vars abstraction representation] (peek! frame)]
+ [[name type_vars abstraction representation] (case frame
+ {.#Some frame}
+ (..specific frame)
+
+ {.#None}
+ ..current)]
(in (list (` ((~! //.as) [(~+ type_vars)] (~ <from>) (~ <to>)
(~ value))))))))]
@@ -199,17 +61,7 @@
[representation abstraction representation]
)
-(def abstraction_type_name
- (-> Symbol Text)
- symbol#encoded)
-
-(def representation_definition_name
- (-> Text Text)
- (|>> (all text#composite
- (symbol#encoded (symbol ..#Representation))
- " ")))
-
-(def declaration
+(def declarationP
(Parser [Text (List Text)])
(<>.either (<code>.form (<>.and <code>.local (<>.some <code>.local)))
(<>.and <code>.local (at <>.monad in (list)))))
@@ -218,7 +70,7 @@
(Parser [Code [Text (List Text)] Code (List Code)])
(|export|.parser
(all <>.and
- ..declaration
+ ..declarationP
<code>.any
(<>.some <code>.any)
)))
@@ -230,40 +82,25 @@
..abstract])
(do meta.monad
[current_module meta.current_module_name
+ g!Representation (macro.symbol "Representation")
.let [type_varsC (list#each code.local type_vars)
abstraction_declaration (` ((~ (code.local name)) (~+ type_varsC)))
- representation_declaration (` ((~ (code.local (representation_definition_name name)))
- (~+ type_varsC)))]
- _ (..push! [name
- type_varsC
- abstraction_declaration
- representation_declaration])]
- (in (list.partial (` (type: (~ export_policy) (~ abstraction_declaration)
- (Primitive (~ (code.text (abstraction_type_name [current_module name])))
- [(~+ type_varsC)])))
- (` (type: (~ representation_declaration)
- (~ representation_type)))
- (all list#composite
- primitives
- (list (` ((~! ..pop!))))))))))
-
-(type: (Selection a)
- (Variant
- {#Specific Code a}
- {#Current a}))
-
-(def (selection parser)
- (All (_ a) (-> (Parser a) (Parser (Selection a))))
- (<>.or (<>.and <code>.any parser)
- parser))
+ representation_declaration (` ((~ g!Representation) (~+ type_varsC)))]]
+ (..declaration [name type_varsC abstraction_declaration representation_declaration]
+ (` (.these (type: (~ export_policy) (~ abstraction_declaration)
+ (Primitive (~ (code.text (symbol#encoded [current_module name])))
+ [(~+ type_varsC)]))
+ (type: (~ representation_declaration)
+ (~ representation_type))
+ (~+ primitives)))))))
+
+(def selection
+ (Parser [(List Code) Code])
+ (<>.either (<>.and (<>#each (|>> list) <code>.any) <code>.any)
+ (<>.and (<>#in (list)) <code>.any)))
(def .public transmutation
- (syntax (_ [selection (..selection <code>.any)])
- (case selection
- {#Specific specific value}
- (in (list (` (.|> (~ value)
- (..representation (~ specific))
- (..abstraction (~ specific))))))
-
- {#Current value}
- (in (list (` (.|> (~ value) ..representation ..abstraction)))))))
+ (syntax (_ [[specific value] ..selection])
+ (in (list (` (.|> (~ value)
+ (..representation (~+ specific))
+ (..abstraction (~+ specific))))))))
diff --git a/stdlib/source/test/lux/macro.lux b/stdlib/source/test/lux/macro.lux
index 445792fb6..9368e2a0f 100644
--- a/stdlib/source/test/lux/macro.lux
+++ b/stdlib/source/test/lux/macro.lux
@@ -34,7 +34,8 @@
["[1][0]" local]
["[1][0]" syntax]
["[1][0]" template]
- ["[1][0]" pattern]])
+ ["[1][0]" pattern]
+ ["[1][0]" context]])
(def !expect
(template (_ <pattern> <value>)
@@ -248,4 +249,5 @@
/syntax.test
/template.test
/pattern.test
+ /context.test
)))
diff --git a/stdlib/source/test/lux/macro/context.lux b/stdlib/source/test/lux/macro/context.lux
new file mode 100644
index 000000000..52df97710
--- /dev/null
+++ b/stdlib/source/test/lux/macro/context.lux
@@ -0,0 +1,12 @@
+(.require
+ [library
+ [lux (.except)
+ ["_" test (.only Test)]]]
+ [\\library
+ ["[0]" /]])
+
+(def .public test
+ Test
+ (<| (_.covering /._)
+ (_.property "TBD" false)
+ ))
diff --git a/stdlib/source/test/lux/type/primitive.lux b/stdlib/source/test/lux/type/primitive.lux
index dfd3aa939..619b2b3f9 100644
--- a/stdlib/source/test/lux/type/primitive.lux
+++ b/stdlib/source/test/lux/type/primitive.lux
@@ -35,72 +35,56 @@
[specific (/.specific (template.text [g!Foo]))]
)
- (def with_no_active_frames
- (syntax (_ [macro <code>.any])
- (function (_ compiler)
- (let [verdict (case ((macro.expansion macro) compiler)
- {try.#Failure error}
- (exception.match? /.no_active_frames error)
-
- {try.#Success _}
- false)]
- {try.#Success [compiler (list (code.bit verdict))]}))))
+ (/.primitive (g!Foo a)
+ Text
- (with_expansions [no_current! (..with_no_active_frames (..current))
- no_specific! (..with_no_active_frames (..specific))]
- (/.primitive (g!Foo a)
- Text
+ (/.primitive (g!Bar a)
+ Nat
- (/.primitive (g!Bar a)
- Nat
-
- (def .public test
- Test
- (<| (_.covering /._)
- (_.for [/.primitive])
- (do random.monad
- [expected_foo (random.lower_case 5)
- expected_bar random.nat]
- (all _.and
- (_.coverage [/.abstraction]
- (and (exec (is (g!Foo Text)
- (/.abstraction g!Foo expected_foo))
- true)
- (exec (is (g!Bar Text)
- (/.abstraction expected_bar))
- true)))
- (_.coverage [/.representation]
- (and (|> expected_foo
- (/.abstraction g!Foo)
- (is (g!Foo Bit))
- (/.representation g!Foo)
- (text#= expected_foo))
- (|> (/.abstraction expected_bar)
- (is (g!Bar Bit))
- /.representation
- (n.= expected_bar))))
- (_.coverage [/.transmutation]
- (and (exec (|> expected_foo
- (/.abstraction g!Foo)
- (is (g!Foo .Macro))
- (/.transmutation g!Foo)
- (is (g!Foo .Lux)))
- true)
- (exec (|> (/.abstraction expected_bar)
- (is (g!Bar .Macro))
- /.transmutation
- (is (g!Bar .Lux)))
- true)))
- (_.for [/.Frame]
- (all _.and
- (_.coverage [/.current]
- (text#= (template.text [g!Bar])
- (..current)))
- (_.coverage [/.specific]
- (text#= (template.text [g!Foo])
- (..specific)))
- (_.coverage [/.no_active_frames]
- (and no_current!
- no_specific!))
- ))
- )))))))))
+ (def .public test
+ Test
+ (<| (_.covering /._)
+ (_.for [/.primitive])
+ (do random.monad
+ [expected_foo (random.lower_case 5)
+ expected_bar random.nat]
+ (all _.and
+ (_.coverage [/.abstraction]
+ (and (exec (is (g!Foo Text)
+ (/.abstraction g!Foo expected_foo))
+ true)
+ (exec (is (g!Bar Text)
+ (/.abstraction expected_bar))
+ true)))
+ (_.coverage [/.representation]
+ (and (|> expected_foo
+ (/.abstraction g!Foo)
+ (is (g!Foo Bit))
+ (/.representation g!Foo)
+ (text#= expected_foo))
+ (|> (/.abstraction expected_bar)
+ (is (g!Bar Bit))
+ /.representation
+ (n.= expected_bar))))
+ (_.coverage [/.transmutation]
+ (and (exec (|> expected_foo
+ (/.abstraction g!Foo)
+ (is (g!Foo .Macro))
+ (/.transmutation g!Foo)
+ (is (g!Foo .Lux)))
+ true)
+ (exec (|> (/.abstraction expected_bar)
+ (is (g!Bar .Macro))
+ /.transmutation
+ (is (g!Bar .Lux)))
+ true)))
+ (_.for [/.Frame]
+ (all _.and
+ (_.coverage [/.current]
+ (text#= (template.text [g!Bar])
+ (..current)))
+ (_.coverage [/.specific]
+ (text#= (template.text [g!Foo])
+ (..specific)))
+ ))
+ ))))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 05:22:04 +0000