aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2022-02-08 04:08:38 -0400
committerEduardo Julian2022-02-08 04:08:38 -0400
commit0755768bb993cfb3924986eeb0486204a90bfeee (patch)
tree79698c3854c720c4839155454dc1f7fa2abdf256
parent7065801a9ad1724c6a82e9803c218b2981bc59b3 (diff)
Optimizations for the pure-Lux JVM compiler. [Part 1]
-rw-r--r--documentation/bookmark/gpu_programming.md1
-rw-r--r--stdlib/source/library/lux/control/maybe.lux62
-rw-r--r--stdlib/source/library/lux/control/try.lux43
-rw-r--r--stdlib/source/library/lux/target/jvm/bytecode.lux611
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/analysis/module.lux2
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux18
-rw-r--r--stdlib/source/test/lux/target/python.lux42
-rw-r--r--stdlib/source/test/lux/tool.lux4
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux6
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/analysis/module.lux26
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux32
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux293
12 files changed, 670 insertions, 470 deletions
diff --git a/documentation/bookmark/gpu_programming.md b/documentation/bookmark/gpu_programming.md
index 598594568..02444379e 100644
--- a/documentation/bookmark/gpu_programming.md
+++ b/documentation/bookmark/gpu_programming.md
@@ -1,5 +1,6 @@
# Reference
+0. [cudaFlow: Modern C++ Programming Model for GPU Task Graph Parallelism - CppCon 2021](https://www.youtube.com/watch?v=-tIQbIhTAv8)
0. [GPU Accelerated Computing on Cross-Vendor Graphics Cards with Vulkan Kompute - Alejandro Saucedo](https://www.youtube.com/watch?v=DBcXrJtJaIQ)
0. [Generic GPU Kernels](https://mikeinnes.github.io/2017/08/24/cudanative.html)
diff --git a/stdlib/source/library/lux/control/maybe.lux b/stdlib/source/library/lux/control/maybe.lux
index a8d97f232..597953a64 100644
--- a/stdlib/source/library/lux/control/maybe.lux
+++ b/stdlib/source/library/lux/control/maybe.lux
@@ -1,15 +1,15 @@
(.using
- [library
- [lux {"-" list}
- [abstract
- [monoid {"+" Monoid}]
- [equivalence {"+" Equivalence}]
- [hash {"+" Hash}]
- [apply {"+" Apply}]
- ["[0]" functor {"+" Functor}]
- ["[0]" monad {"+" Monad do}]]
- [meta
- ["[0]" location]]]])
+ [library
+ [lux {"-" list}
+ [abstract
+ [monoid {"+" Monoid}]
+ [equivalence {"+" Equivalence}]
+ [hash {"+" Hash}]
+ [apply {"+" Apply}]
+ ["[0]" functor {"+" Functor}]
+ ["[0]" monad {"+" Monad do}]]
+ [meta
+ ["[0]" location]]]])
... (type: (Maybe a)
... {.#None}
@@ -34,8 +34,12 @@
(def: (each f ma)
(case ma
- {.#None} {.#None}
- {.#Some a} {.#Some (f a)})))
+ {.#Some a}
+ {.#Some (f a)}
+
+ ... {.#None}
+ it
+ (:expected it))))
(implementation: .public apply
(Apply Maybe)
@@ -60,11 +64,12 @@
(def: (conjoint mma)
(case mma
- {.#None}
- {.#None}
-
{.#Some mx}
- mx)))
+ mx
+
+ ... {.#None}
+ it
+ (:expected it))))
(implementation: .public (equivalence super)
(All (_ a) (-> (Equivalence a) (Equivalence (Maybe a))))
@@ -89,7 +94,7 @@
(def: (hash value)
(case value
{.#None}
- 0
+ 1
{.#Some value}
(# super hash value))))
@@ -109,11 +114,12 @@
(do monad
[mMma MmMma]
(case mMma
- {.#None}
- (in {.#None})
-
{.#Some Mma}
- Mma))))
+ Mma
+
+ ... {.#None}
+ it
+ (in (:expected it))))))
(def: .public (lifted monad)
(All (_ M a) (-> (Monad M) (-> (M a) (M (Maybe a)))))
@@ -127,7 +133,8 @@
{.#Some (~ g!temp)}
(~ g!temp)
- {.#None}
+ ... {.#None}
+ (~ g!temp)
(~ else))))]})
_
@@ -140,11 +147,12 @@
(def: .public (list value)
(All (_ a) (-> (Maybe a) (List a)))
(case value
- {.#None}
- {.#End}
-
{.#Some value}
- {.#Item value {.#End}}))
+ {.#Item value {.#End}}
+
+ ... {.#None}
+ _
+ {.#End}))
(macro: .public (when tokens state)
(case tokens
diff --git a/stdlib/source/library/lux/control/try.lux b/stdlib/source/library/lux/control/try.lux
index 3e62dda4b..a82b72d33 100644
--- a/stdlib/source/library/lux/control/try.lux
+++ b/stdlib/source/library/lux/control/try.lux
@@ -19,11 +19,12 @@
(def: (each f ma)
(case ma
- {#Failure msg}
- {#Failure msg}
-
{#Success datum}
- {#Success (f datum)})))
+ {#Success (f datum)}
+
+ ... {#Failure msg}
+ it
+ (:expected it))))
(implementation: .public apply
(Apply Try)
@@ -37,11 +38,13 @@
{#Success a}
{#Success (f a)}
- {#Failure msg}
- {#Failure msg})
+ ... {#Failure msg}
+ it
+ (:expected it))
- {#Failure msg}
- {#Failure msg})))
+ ... {#Failure msg}
+ it
+ (:expected it))))
(implementation: .public monad
(Monad Try)
@@ -53,11 +56,12 @@
(def: (conjoint mma)
(case mma
- {#Failure msg}
- {#Failure msg}
-
{#Success ma}
- ma)))
+ ma
+
+ ... {#Failure msg}
+ it
+ (:expected it))))
(implementation: .public (with monad)
... TODO: Replace (All (_ a) (! (Try a))) with (functor.Then ! Try)
@@ -75,11 +79,12 @@
(do monad
[eMea MeMea]
(case eMea
- {#Failure try}
- (in {#Failure try})
-
{#Success Mea}
- Mea))))
+ Mea
+
+ ... {#Failure error}
+ it
+ (in (:expected it))))))
(def: .public (lifted monad)
(All (_ ! a) (-> (Monad !) (-> (! a) (! (Try a)))))
@@ -117,7 +122,8 @@
{#Success value}
{.#Some value}
- {#Failure message}
+ ... {#Failure message}
+ _
{.#None}))
(def: .public (of_maybe maybe)
@@ -138,7 +144,8 @@
{..#Success (~' g!temp)}
(~' g!temp)
- {..#Failure (~ [location.dummy {.#Symbol ["" ""]}])}
+ ... {..#Failure (~' g!temp)}
+ (~' g!temp)
(~ else))))]}
_
diff --git a/stdlib/source/library/lux/target/jvm/bytecode.lux b/stdlib/source/library/lux/target/jvm/bytecode.lux
index 17f2dd229..5c70611bf 100644
--- a/stdlib/source/library/lux/target/jvm/bytecode.lux
+++ b/stdlib/source/library/lux/target/jvm/bytecode.lux
@@ -1,55 +1,55 @@
(.using
- [library
- [lux {"-" Type Label int try}
- ["[0]" ffi {"+" import:}]
- [abstract
- [monoid {"+" Monoid}]
- ["[0]" monad {"+" Monad do}]]
- [control
- ["[0]" writer {"+" Writer}]
- ["[0]" state {"+" +State}]
- ["[0]" function]
- ["[0]" maybe]
- ["[0]" try {"+" Try}]
- ["[0]" exception {"+" exception:}]]
- [data
- ["[0]" product]
- [text
- ["%" format {"+" format}]]
- [collection
- ["[0]" list ("[1]#[0]" functor mix)]
- ["[0]" dictionary {"+" Dictionary}]
- ["[0]" sequence {"+" Sequence}]]]
- [macro
- ["[0]" template]]
- [math
- [number
- ["n" nat]
- ["i" int]
- ["[0]" i32 {"+" I32}]]]]]
- ["[0]" / "_"
- ["[1][0]" address {"+" Address}]
- ["[1][0]" jump {"+" Jump Big_Jump}]
- ["_" instruction {"+" Primitive_Array_Type Instruction Estimator} ("[1]#[0]" monoid)]
- ["[1][0]" environment {"+" Environment}
- [limit
- ["/[0]" registry {"+" Register Registry}]
- ["/[0]" stack {"+" Stack}]]]
- ["/[1]" // "_"
- ["[1][0]" index {"+" Index}]
- [encoding
- ["[1][0]" name]
- ["[1][0]" unsigned {"+" U1 U2}]
- ["[1][0]" signed {"+" S1 S2 S4}]]
- ["[1][0]" constant {"+" UTF8}
- ["[1]/[0]" pool {"+" Pool Resource}]]
- [attribute
- [code
- ["[1][0]" exception {"+" Exception}]]]
- ["[0]" type {"+" Type}
- [category {"+" Class Object Value' Value Return' Return Method}]
- ["[0]" reflection]
- ["[0]" parser]]]])
+ [library
+ [lux {"-" Type Label int try}
+ ["[0]" ffi {"+" import:}]
+ [abstract
+ [monoid {"+" Monoid}]
+ [functor {"+" Functor}]
+ ["[0]" monad {"+" Monad do}]]
+ [control
+ ["[0]" writer {"+" Writer}]
+ ["[0]" state {"+" +State}]
+ ["[0]" maybe]
+ ["[0]" try {"+" Try} ("[1]#[0]" monad)]
+ ["[0]" exception {"+" exception:}]]
+ [data
+ ["[0]" product]
+ [text
+ ["%" format {"+" format}]]
+ [collection
+ ["[0]" list ("[1]#[0]" functor mix)]
+ ["[0]" dictionary {"+" Dictionary}]
+ ["[0]" sequence {"+" Sequence}]]]
+ [macro
+ ["[0]" template]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]
+ ["[0]" i32 {"+" I32}]]]]]
+ ["[0]" / "_"
+ ["[1][0]" address {"+" Address}]
+ ["[1][0]" jump {"+" Jump Big_Jump}]
+ ["_" instruction {"+" Primitive_Array_Type Instruction Estimator} ("[1]#[0]" monoid)]
+ ["[1][0]" environment {"+" Environment}
+ [limit
+ ["/[0]" registry {"+" Register Registry}]
+ ["/[0]" stack {"+" Stack}]]]
+ ["/[1]" // "_"
+ ["[1][0]" index {"+" Index}]
+ [encoding
+ ["[1][0]" name]
+ ["[1][0]" unsigned {"+" U1 U2}]
+ ["[1][0]" signed {"+" S1 S2 S4}]]
+ ["[1][0]" constant {"+" UTF8}
+ ["[1]/[0]" pool {"+" Pool Resource}]]
+ [attribute
+ [code
+ ["[1][0]" exception {"+" Exception}]]]
+ ["[0]" type {"+" Type}
+ [category {"+" Class Object Value' Value Return' Return Method}]
+ ["[0]" reflection]
+ ["[0]" parser]]]])
(type: .public Label
Nat)
@@ -76,29 +76,42 @@
(Sequence Exception)
sequence.empty)
-(def: relative_identity
+(def: relative#identity
Relative
- (function.constant {try.#Success [..no_exceptions _.empty]}))
+ (function (_ _)
+ {try.#Success [..no_exceptions _.empty]}))
-(implementation: relative_monoid
- (Monoid Relative)
+(template: (try|do <binding> <term> <then>)
+ [(.case <term>
+ {try.#Success <binding>}
+ <then>
- (def: identity ..relative_identity)
+ failure
+ (:expected failure))])
- (def: (composite left right)
- (cond (same? ..relative_identity left)
- right
+(template: (try|in <it>)
+ [{try.#Success <it>}])
- (same? ..relative_identity right)
- left
+(def: (relative#composite left right)
+ (-> Relative Relative Relative)
+ (cond (same? ..relative#identity left)
+ right
- ... else
- (function (_ resolver)
- (do try.monad
- [[left_exceptions left_instruction] (left resolver)
- [right_exceptions right_instruction] (right resolver)]
- (in [(# sequence.monoid composite left_exceptions right_exceptions)
- (_#composite left_instruction right_instruction)]))))))
+ (same? ..relative#identity right)
+ left
+
+ ... else
+ (function (_ resolver)
+ (<| (try|do [left_exceptions left_instruction] (left resolver))
+ (try|do [right_exceptions right_instruction] (right resolver))
+ (try|in [(# sequence.monoid composite left_exceptions right_exceptions)
+ (_#composite left_instruction right_instruction)])))))
+
+(implementation: relative_monoid
+ (Monoid Relative)
+
+ (def: identity ..relative#identity)
+ (def: composite ..relative#composite))
(type: .public (Bytecode a)
(+State Try [Pool Environment Tracker] (Writer Relative a)))
@@ -109,7 +122,7 @@
{try.#Success [[pool
environment
(revised@ #next ++ tracker)]
- [..relative_identity
+ [..relative#identity
(value@ #next tracker)]]}))
(exception: .public (label_has_already_been_set [label Label])
@@ -133,7 +146,7 @@
(function (_ state)
(let [[pool environment tracker] state]
{try.#Success [state
- [..relative_identity
+ [..relative#identity
(case (dictionary.value label (value@ #known tracker))
{.#Some [expected {.#Some address}]}
{.#Some [expected address]}
@@ -146,7 +159,7 @@
(function (_ state)
(let [[pool environment tracker] state]
{try.#Success [state
- [..relative_identity
+ [..relative#identity
(case (dictionary.value label (value@ #known tracker))
{.#Some [expected {.#None}]}
{.#Some expected}
@@ -159,16 +172,16 @@
(function (_ state)
(let [[pool environment tracker] state]
{try.#Success [state
- [..relative_identity
+ [..relative#identity
(value@ /environment.#stack environment)]]})))
-(with_expansions [<success> (as_is (in [[pool
- environment
- (revised@ #known
- (dictionary.has label [actual {.#Some @here}])
- tracker)]
- [..relative_identity
- []]]))]
+(with_expansions [<success> (as_is (try|in [[pool
+ environment
+ (revised@ #known
+ (dictionary.has label [actual {.#Some @here}])
+ tracker)]
+ [..relative#identity
+ []]]))]
(def: .public (set_label label)
(-> Label (Bytecode Any))
(function (_ [pool environment tracker])
@@ -178,46 +191,82 @@
(exception.except ..label_has_already_been_set [label])
{.#Some [expected {.#None}]}
- (do try.monad
- [[actual environment] (/environment.continue expected environment)]
- <success>)
-
- {.#None}
- (do try.monad
- [[actual environment] (/environment.continue (|> environment
- (value@ /environment.#stack)
- (maybe.else /stack.empty))
- environment)]
- <success>))))))
-
-(def: .public monad
+ (<| (try|do [actual environment] (/environment.continue expected environment))
+ <success>)
+
+ ... {.#None}
+ _
+ (<| (try|do [actual environment] (/environment.continue (|> environment
+ (value@ /environment.#stack)
+ (maybe.else /stack.empty))
+ environment))
+ <success>))))))
+
+(implementation: .public functor
+ (Functor Bytecode)
+ (def: (each $ it)
+ (function (_ state)
+ (case (it state)
+ {try.#Success [state' [relative it]]}
+ {try.#Success [state' [relative ($ it)]]}
+
+ ... {try.#Failure error}
+ it
+ (:expected it)))))
+
+(implementation: .public monad
(Monad Bytecode)
- (<| (:as (Monad Bytecode))
- (writer.with ..relative_monoid)
- (: (Monad (+State Try [Pool Environment Tracker])))
- state.with
- (: (Monad Try))
- try.monad))
+
+ (def: &functor ..functor)
+
+ (def: (in it)
+ (function (_ state)
+ {try.#Success [state [relative#identity it]]}))
+
+ (def: (conjoint ^^it)
+ (function (_ state)
+ (case (^^it state)
+ {try.#Success [state' [left ^it]]}
+ (case (^it state')
+ {try.#Success [state'' [right it]]}
+ {try.#Success [state'' [(relative#composite left right) it]]}
+
+ ... {try.#Failure error}
+ it
+ (:expected it))
+
+ ... {try.#Failure error}
+ it
+ (:expected it)))))
(def: .public (when_continuous it)
(-> (Bytecode Any) (Bytecode Any))
(do ..monad
[stack ..stack]
(.case stack
- {.#None} (in [])
- {.#Some _} it)))
+ {.#Some _}
+ it
+
+ ... {.#None}
+ _
+ (in []))))
(def: .public (when_acknowledged @ it)
(-> Label (Bytecode Any) (Bytecode Any))
(do ..monad
[?@ (..acknowledged? @)]
(.case ?@
- {.#None} (in [])
- {.#Some _} it)))
+ {.#Some _}
+ it
-(def: .public failure
+ ... {.#None}
+ _
+ (in []))))
+
+(def: .public (failure error)
(-> Text Bytecode)
- (|>> {try.#Failure} function.constant))
+ (function (_ _)
+ {try.#Failure error}))
(def: .public (except exception value)
(All (_ e) (-> (exception.Exception e) e Bytecode))
@@ -226,10 +275,9 @@
(def: .public (resolve environment bytecode)
(All (_ a) (-> Environment (Bytecode a) (Resource [Environment (Sequence Exception) Instruction a])))
(function (_ pool)
- (do try.monad
- [[[pool environment tracker] [relative output]] (bytecode [pool environment ..fresh])
- [exceptions instruction] (relative (value@ #known tracker))]
- (in [pool [environment exceptions instruction output]]))))
+ (<| (try|do [[pool environment tracker] [relative output]] (bytecode [pool environment ..fresh]))
+ (try|do [exceptions instruction] (relative (value@ #known tracker)))
+ (try|in [pool [environment exceptions instruction output]]))))
(def: (step estimator counter)
(-> Estimator Address (Try Address))
@@ -238,17 +286,18 @@
(def: (bytecode consumption production registry [estimator bytecode] input)
(All (_ a) (-> U2 U2 Registry [Estimator (-> [a] Instruction)] a (Bytecode Any)))
(function (_ [pool environment tracker])
- (do [! try.monad]
- [environment' (|> environment
- (/environment.consumes consumption)
- (monad.then ! (/environment.produces production))
- (monad.then ! (/environment.has registry)))
- program_counter' (step estimator (value@ #program_counter tracker))]
- (in [[pool
- environment'
- (with@ #program_counter program_counter' tracker)]
- [(function.constant (in [..no_exceptions (bytecode input)]))
- []]]))))
+ (<| (try|do environment' (|> environment
+ (/environment.consumes consumption)
+ (monad.then try.monad (|>> (/environment.produces production)
+ (try#each (/environment.has registry))
+ try#conjoint))))
+ (try|do program_counter' (step estimator (value@ #program_counter tracker)))
+ (try|in [[pool
+ environment'
+ (with@ #program_counter program_counter' tracker)]
+ [(function (_ _)
+ (try|in [..no_exceptions (bytecode input)]))
+ []]]))))
(template [<name> <frames>]
[(def: <name> U2
@@ -461,13 +510,12 @@
(def: discontinuity!
(Bytecode Any)
(function (_ [pool environment tracker])
- (do try.monad
- [_ (/environment.stack environment)]
- (in [[pool
- (/environment.discontinue environment)
- tracker]
- [..relative_identity
- []]]))))
+ (<| (try|do _ (/environment.stack environment))
+ (try|in [[pool
+ (/environment.discontinue environment)
+ tracker]
+ [..relative#identity
+ []]]))))
(template [<name> <consumption> <instruction>]
[(def: .public <name>
@@ -495,11 +543,10 @@
(-> (Resource a)
(Bytecode a)))
(function (_ [pool environment tracker])
- (do try.monad
- [[pool' output] (resource pool)]
- (in [[pool' environment tracker]
- [..relative_identity
- output]]))))
+ (<| (try|do [pool' output] (resource pool))
+ (try|in [[pool' environment tracker]
+ [..relative#identity
+ output]]))))
(def: .public (string value)
(-> //constant.UTF8 (Bytecode Any))
@@ -747,16 +794,15 @@
(def: (jump @from @to)
(-> Address Address (Try Any_Jump))
- (do [! try.monad]
- [jump (# ! each //signed.value
- (/address.jump @from @to))]
- (let [big? (or (i.> (//signed.value //signed.maximum/2)
- jump)
- (i.< (//signed.value //signed.minimum/2)
- jump))]
+ (<| (try|do jump (try#each //signed.value
+ (/address.jump @from @to)))
+ (let [big? (or (i.> (//signed.value //signed.maximum/2)
+ jump)
+ (i.< (//signed.value //signed.minimum/2)
+ jump))])
(if big?
- (# ! each (|>> {.#Left}) (//signed.s4 jump))
- (# ! each (|>> {.#Right}) (//signed.s2 jump))))))
+ (try#each (|>> {.#Left}) (//signed.s4 jump))
+ (try#each (|>> {.#Right}) (//signed.s2 jump)))))
(exception: .public (unset_label [label Label])
(exception.report
@@ -771,7 +817,8 @@
{.#Some [actual {.#None}]}
(exception.except ..unset_label [label])
- {.#None}
+ ... {.#None}
+ _
(exception.except ..unknown_label [label])))
(def: (acknowledge_label stack label tracker)
@@ -780,7 +827,8 @@
{.#Some _}
tracker
- {.#None}
+ ... {.#None}
+ _
(revised@ #known (dictionary.has label [stack {.#None}]) tracker)))
(template [<consumption> <name> <instruction>]
@@ -788,31 +836,29 @@
(-> Label (Bytecode Any))
(let [[estimator bytecode] <instruction>]
(function (_ [pool environment tracker])
- (let [@here (value@ #program_counter tracker)]
- (do try.monad
- [environment' (|> environment
- (/environment.consumes <consumption>))
- actual (/environment.stack environment')
- program_counter' (step estimator @here)]
- (in (let [@from @here]
- [[pool
- environment'
- (|> tracker
- (..acknowledge_label actual label)
- (with@ #program_counter program_counter'))]
- [(function (_ resolver)
- (do try.monad
- [[expected @to] (..resolve_label label resolver)
- _ (exception.assertion ..mismatched_environments [(symbol <instruction>) label @here expected actual]
- (# /stack.equivalence = expected actual))
- jump (..jump @from @to)]
- (case jump
- {.#Left jump}
- (exception.except ..cannot_do_a_big_jump [label @from jump])
-
- {.#Right jump}
- (in [..no_exceptions (bytecode jump)]))))
- []]])))))))]
+ (<| (let [@here (value@ #program_counter tracker)])
+ (try|do environment' (|> environment
+ (/environment.consumes <consumption>)))
+ (try|do actual (/environment.stack environment'))
+ (try|do program_counter' (step estimator @here))
+ (try|in (let [@from @here]
+ [[pool
+ environment'
+ (|> tracker
+ (..acknowledge_label actual label)
+ (with@ #program_counter program_counter'))]
+ [(function (_ resolver)
+ (<| (try|do [expected @to] (..resolve_label label resolver))
+ (try|do _ (exception.assertion ..mismatched_environments [(symbol <instruction>) label @here expected actual]
+ (# /stack.equivalence = expected actual)))
+ (try|do jump (..jump @from @to))
+ (case jump
+ {.#Left jump}
+ (exception.except ..cannot_do_a_big_jump [label @from jump])
+
+ {.#Right jump}
+ (try|in [..no_exceptions (bytecode jump)]))))
+ []]]))))))]
[$1 ifeq _.ifeq]
[$1 ifne _.ifne]
@@ -840,43 +886,42 @@
(-> Label (Bytecode Any))
(let [[estimator bytecode] <instruction>]
(function (_ [pool environment tracker])
- (do try.monad
- [actual (/environment.stack environment)
- .let [@here (value@ #program_counter tracker)]
- program_counter' (step estimator @here)]
- (in (let [@from @here]
- [[pool
- (/environment.discontinue environment)
- (|> tracker
- (..acknowledge_label actual label)
- (with@ #program_counter program_counter'))]
- [(function (_ resolver)
- (case (dictionary.value label resolver)
- {.#Some [expected {.#Some @to}]}
- (do try.monad
- [_ (exception.assertion ..mismatched_environments [(symbol <instruction>) label @here expected actual]
- (# /stack.equivalence = expected actual))
- jump (..jump @from @to)]
- (case jump
- {.#Left jump}
- <on_long_jump>
-
- {.#Right jump}
- <on_short_jump>))
-
- {.#Some [expected {.#None}]}
- (exception.except ..unset_label [label])
-
- {.#None}
- (exception.except ..unknown_label [label])))
- []]]))))))]
+ (<| (try|do actual (/environment.stack environment))
+ (let [@here (value@ #program_counter tracker)])
+ (try|do program_counter' (step estimator @here))
+ (try|in (let [@from @here]
+ [[pool
+ (/environment.discontinue environment)
+ (|> tracker
+ (..acknowledge_label actual label)
+ (with@ #program_counter program_counter'))]
+ [(function (_ resolver)
+ (case (dictionary.value label resolver)
+ {.#Some [expected {.#Some @to}]}
+ (<| (try|do _ (exception.assertion ..mismatched_environments [(symbol <instruction>) label @here expected actual]
+ (# /stack.equivalence = expected actual)))
+ (try|do jump (..jump @from @to))
+ (case jump
+ {.#Left jump}
+ <on_long_jump>
+
+ {.#Right jump}
+ <on_short_jump>))
+
+ {.#Some [expected {.#None}]}
+ (exception.except ..unset_label [label])
+
+ ... {.#None}
+ _
+ (exception.except ..unknown_label [label])))
+ []]]))))))]
[goto _.goto
(exception.except ..cannot_do_a_big_jump [label @from jump])
- (in [..no_exceptions (bytecode jump)])]
+ (try|in [..no_exceptions (bytecode jump)])]
[goto_w _.goto_w
- (in [..no_exceptions (bytecode jump)])
- (in [..no_exceptions (bytecode (/jump.lifted jump))])]
+ (try|in [..no_exceptions (bytecode jump)])
+ (try|in [..no_exceptions (bytecode (/jump.lifted jump))])]
)
(def: (big_jump jump)
@@ -894,38 +939,37 @@
(-> S4 Label [Label (List Label)] (Bytecode Any))
(let [[estimator bytecode] _.tableswitch]
(function (_ [pool environment tracker])
- (do try.monad
- [environment' (|> environment
- (/environment.consumes $1))
- actual (/environment.stack environment')
- program_counter' (step (estimator (list.size afterwards)) (value@ #program_counter tracker))]
- (in (let [@from (value@ #program_counter tracker)]
- [[pool
- environment'
- (|> (list#mix (..acknowledge_label actual) tracker (list& default at_minimum afterwards))
- (with@ #program_counter program_counter'))]
- [(function (_ resolver)
- (let [get (: (-> Label (Maybe [Stack (Maybe Address)]))
- (function (_ label)
- (dictionary.value label resolver)))]
- (case (do [! maybe.monad]
- [@default (|> default get (monad.then ! product.right))
- @at_minimum (|> at_minimum get (monad.then ! product.right))
- @afterwards (|> afterwards
- (monad.each ! get)
- (monad.then ! (monad.each ! product.right)))]
- (in [@default @at_minimum @afterwards]))
- {.#Some [@default @at_minimum @afterwards]}
- (do [! try.monad]
- [>default (# ! each ..big_jump (..jump @from @default))
- >at_minimum (# ! each ..big_jump (..jump @from @at_minimum))
- >afterwards (monad.each ! (|>> (..jump @from) (# ! each ..big_jump))
- @afterwards)]
- (in [..no_exceptions (bytecode minimum >default [>at_minimum >afterwards])]))
-
- {.#None}
- (exception.except ..invalid_tableswitch []))))
- []]]))))))
+ (<| (try|do environment' (|> environment
+ (/environment.consumes $1)))
+ (try|do actual (/environment.stack environment'))
+ (try|do program_counter' (step (estimator (list.size afterwards)) (value@ #program_counter tracker)))
+ (try|in (let [@from (value@ #program_counter tracker)]
+ [[pool
+ environment'
+ (|> (list#mix (..acknowledge_label actual) tracker (list& default at_minimum afterwards))
+ (with@ #program_counter program_counter'))]
+ [(function (_ resolver)
+ (let [get (: (-> Label (Maybe [Stack (Maybe Address)]))
+ (function (_ label)
+ (dictionary.value label resolver)))]
+ (case (do [! maybe.monad]
+ [@default (|> default get (monad.then ! product.right))
+ @at_minimum (|> at_minimum get (monad.then ! product.right))]
+ (|> afterwards
+ (monad.each ! get)
+ (monad.then ! (monad.each ! product.right))
+ (# ! each (|>> [@default @at_minimum]))))
+ {.#Some [@default @at_minimum @afterwards]}
+ (<| (try|do >default (try#each ..big_jump (..jump @from @default)))
+ (try|do >at_minimum (try#each ..big_jump (..jump @from @at_minimum)))
+ (try|do >afterwards (monad.each try.monad (|>> (..jump @from) (try#each ..big_jump))
+ @afterwards))
+ (try|in [..no_exceptions (bytecode minimum >default [>at_minimum >afterwards])]))
+
+ ... {.#None}
+ _
+ (exception.except ..invalid_tableswitch []))))
+ []]]))))))
(exception: .public invalid_lookupswitch)
@@ -937,37 +981,36 @@
cases)
[estimator bytecode] _.lookupswitch]
(function (_ [pool environment tracker])
- (do try.monad
- [environment' (|> environment
- (/environment.consumes $1))
- actual (/environment.stack environment')
- program_counter' (step (estimator (list.size cases)) (value@ #program_counter tracker))]
- (in (let [@from (value@ #program_counter tracker)]
- [[pool
- environment'
- (|> (list#mix (..acknowledge_label actual) tracker (list& default (list#each product.right cases)))
- (with@ #program_counter program_counter'))]
- [(function (_ resolver)
- (let [get (: (-> Label (Maybe [Stack (Maybe Address)]))
- (function (_ label)
- (dictionary.value label resolver)))]
- (case (do [! maybe.monad]
- [@default (|> default get (monad.then ! product.right))
- @cases (|> cases
- (monad.each ! (|>> product.right get))
- (monad.then ! (monad.each ! product.right)))]
- (in [@default @cases]))
- {.#Some [@default @cases]}
- (do [! try.monad]
- [>default (# ! each ..big_jump (..jump @from @default))
- >cases (|> @cases
- (monad.each ! (|>> (..jump @from) (# ! each ..big_jump)))
- (# ! each (|>> (list.zipped/2 (list#each product.left cases)))))]
- (in [..no_exceptions (bytecode >default >cases)]))
-
- {.#None}
- (exception.except ..invalid_lookupswitch []))))
- []]]))))))
+ (<| (try|do environment' (|> environment
+ (/environment.consumes $1)))
+ (try|do actual (/environment.stack environment'))
+ (try|do program_counter' (step (estimator (list.size cases)) (value@ #program_counter tracker)))
+ (try|in (let [@from (value@ #program_counter tracker)]
+ [[pool
+ environment'
+ (|> (list#mix (..acknowledge_label actual) tracker (list& default (list#each product.right cases)))
+ (with@ #program_counter program_counter'))]
+ [(function (_ resolver)
+ (let [get (: (-> Label (Maybe [Stack (Maybe Address)]))
+ (function (_ label)
+ (dictionary.value label resolver)))]
+ (case (do [! maybe.monad]
+ [@default (|> default get (monad.then ! product.right))]
+ (|> cases
+ (monad.each ! (|>> product.right get))
+ (monad.then ! (monad.each ! product.right))
+ (# ! each (|>> [@default]))))
+ {.#Some [@default @cases]}
+ (<| (try|do >default (try#each ..big_jump (..jump @from @default)))
+ (try|do >cases (|> @cases
+ (monad.each try.monad (|>> (..jump @from) (try#each ..big_jump)))
+ (try#each (|>> (list.zipped/2 (list#each product.left cases))))))
+ (try|in [..no_exceptions (bytecode >default >cases)]))
+
+ ... {.#None}
+ _
+ (exception.except ..invalid_lookupswitch []))))
+ []]]))))))
(def: reflection
(All (_ category)
@@ -1080,24 +1123,34 @@
environment
(..acknowledge_label /stack.catch @handler tracker)]
[(function (_ resolver)
- (do try.monad
- [[_ @start] (..resolve_label @start resolver)
- [_ @end] (..resolve_label @end resolver)
- _ (if (/address.after? @start @end)
- (in [])
- (exception.except ..invalid_range_for_try [@start @end]))
- [_ @handler] (..resolve_label @handler resolver)]
- (in [(sequence.sequence
- [//exception.#start @start
- //exception.#end @end
- //exception.#handler @handler
- //exception.#catch @catch])
- _.empty])))
+ (<| (try|do [_ @start] (..resolve_label @start resolver))
+ (try|do [_ @end] (..resolve_label @end resolver))
+ (try|do _ (if (/address.after? @start @end)
+ (try|in [])
+ (exception.except ..invalid_range_for_try [@start @end])))
+ (try|do [_ @handler] (..resolve_label @handler resolver))
+ (try|in [(sequence.sequence
+ [//exception.#start @start
+ //exception.#end @end
+ //exception.#handler @handler
+ //exception.#catch @catch])
+ _.empty])))
[]]]})))
(def: .public (composite pre post)
(All (_ pre post)
(-> (Bytecode pre) (Bytecode post) (Bytecode post)))
- (do ..monad
- [_ pre]
- post))
+ (function (_ state)
+ (case (pre state)
+ {try.#Success [state' [left _]]}
+ (case (post state')
+ {try.#Success [state'' [right it]]}
+ {try.#Success [state'' [(relative#composite left right) it]]}
+
+ ... {try.#Failure error}
+ it
+ it)
+
+ ... {try.#Failure error}
+ it
+ (:expected it))))
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/module.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/module.lux
index e0798d438..a3084664d 100644
--- a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/module.lux
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/module.lux
@@ -145,7 +145,7 @@
state)
[]]})))
-(def: .public (with_module hash name action)
+(def: .public (with hash name action)
(All (_ a) (-> Nat Text (Operation a) (Operation [Module a])))
(do ///.monad
[_ (..create hash name)
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux
index 5bedbd7bf..7b24ab177 100644
--- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux
@@ -57,8 +57,8 @@
[imported! (///extension.lifted (meta.imported_by? ::module current))]
(if imported!
<return>
- (/.except foreign_module_has_not_been_imported [current ::module def_name])))
- (/.except definition_has_not_been_exported def_name))))
+ (/.except ..foreign_module_has_not_been_imported [current ::module def_name])))
+ (/.except ..definition_has_not_been_exported def_name))))
{.#Type [exported? value labels]}
(do !
@@ -72,14 +72,14 @@
[imported! (///extension.lifted (meta.imported_by? ::module current))]
(if imported!
<return>
- (/.except foreign_module_has_not_been_imported [current ::module def_name])))
- (/.except definition_has_not_been_exported def_name))))
+ (/.except ..foreign_module_has_not_been_imported [current ::module def_name])))
+ (/.except ..definition_has_not_been_exported def_name))))
{.#Tag _}
- (/.except labels_are_not_definitions [def_name])
+ (/.except ..labels_are_not_definitions [def_name])
{.#Slot _}
- (/.except labels_are_not_definitions [def_name])))))
+ (/.except ..labels_are_not_definitions [def_name])))))
(def: (variable var_name)
(-> Text (Operation (Maybe Analysis)))
@@ -94,9 +94,9 @@
{.#None}
(in {.#None}))))
-(def: .public (reference reference)
+(def: .public (reference it)
(-> Symbol (Operation Analysis))
- (case reference
+ (case it
["" simple_name]
(do [! ///.monad]
[?var (variable simple_name)]
@@ -110,4 +110,4 @@
(definition [this_module simple_name]))))
_
- (definition reference)))
+ (definition it)))
diff --git a/stdlib/source/test/lux/target/python.lux b/stdlib/source/test/lux/target/python.lux
index dc4a3871f..39c51b2a7 100644
--- a/stdlib/source/test/lux/target/python.lux
+++ b/stdlib/source/test/lux/target/python.lux
@@ -10,6 +10,7 @@
["$[0]" equivalence]
["$[0]" hash]]]
[control
+ ["[0]" function]
["[0]" maybe ("[1]#[0]" functor)]
["[0]" try {"+" Try} ("[1]#[0]" functor)]]
[data
@@ -180,6 +181,19 @@
(/.str/1 (/.int left))))
))))
+(def: test|text
+ Test
+ (do [! random.monad]
+ [expected_code (# ! each (n.% 128) random.nat)
+ .let [expected_char (text.of_char expected_code)]]
+ ($_ _.and
+ (_.cover [/.chr/1 /.ord/1]
+ (and (expression (|>> (:as Int) .nat (n.= expected_code))
+ (/.ord/1 (/.chr/1 (/.int (.int expected_code)))))
+ (expression (|>> (:as Text) (text#= expected_char))
+ (/.chr/1 (/.ord/1 (/.string expected_char))))))
+ )))
+
(def: test|array
Test
(do [! random.monad]
@@ -195,14 +209,16 @@
to (/.int (.int (n.+ plus from)))
from (/.int (.int from))]]
($_ _.and
- (_.cover [/.list /.item]
- (expression (|>> (:as Frac) (f.= expected))
- (/.item (/.int (.int index))
- (/.list (list#each /.float items)))))
- (_.cover [/.tuple /.item]
- (expression (|>> (:as Frac) (f.= expected))
- (/.item (/.int (.int index))
- (/.tuple (list#each /.float items)))))
+ (_.for [/.item]
+ ($_ _.and
+ (_.cover [/.list]
+ (expression (|>> (:as Frac) (f.= expected))
+ (/.item (/.int (.int index))
+ (/.list (list#each /.float items)))))
+ (_.cover [/.tuple]
+ (expression (|>> (:as Frac) (f.= expected))
+ (/.item (/.int (.int index))
+ (/.tuple (list#each /.float items)))))))
(_.cover [/.slice /.len/1]
(expression (|>> (:as Int) (i.= (.int plus)))
(|> (/.list (list#each /.float items))
@@ -238,7 +254,7 @@
else random.safe_frac
bool random.bit
- float random.frac
+ float (random.only (|>> f.not_a_number? not) random.frac)
string (random.ascii/upper 5)
comment (random.ascii/upper 10)]
@@ -246,6 +262,7 @@
..test|bool
..test|float
..test|int
+ ..test|text
..test|array
..test|dict
(_.cover [/.?]
@@ -258,6 +275,13 @@
(expression (|>> (:as Frac) (f.= then))
(/.comment comment
(/.float then))))
+ (_.cover [/.__import__/1]
+ (expression (function.constant true)
+ (/.__import__/1 (/.string "math"))))
+ (_.cover [/.do]
+ (expression (|>> (:as Frac) (f.= (math.ceil float)))
+ (|> (/.__import__/1 (/.string "math"))
+ (/.do "ceil" (list (/.float float))))))
)))
(def: test|function
diff --git a/stdlib/source/test/lux/tool.lux b/stdlib/source/test/lux/tool.lux
index 2291880ec..9d9d6c3a2 100644
--- a/stdlib/source/test/lux/tool.lux
+++ b/stdlib/source/test/lux/tool.lux
@@ -16,7 +16,8 @@
["[1]/[0]" extension]
["[1]/[0]" analysis "_"
["[1]/[0]" simple]
- ["[1]/[0]" complex]]
+ ["[1]/[0]" complex]
+ ["[1]/[0]" reference]]
... ["[1]/[0]" synthesis]
]]]
["[1][0]" meta "_"
@@ -37,6 +38,7 @@
/phase/extension.test
/phase/analysis/simple.test
/phase/analysis/complex.test
+ /phase/analysis/reference.test
... /syntax.test
... /synthesis.test
))
diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux b/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux
index 1a5ece06a..fa3df9c67 100644
--- a/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux
+++ b/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux
@@ -186,7 +186,7 @@
(type (Ex (_ a) (-> a a)))
(list (` ("lux io error" ""))))
//type.inferring
- (//module.with_module 0 (product.left name))
+ (//module.with 0 (product.left name))
(/phase#each (|>> product.right product.left check.clean //type.check))
/phase#conjoint
(/phase.result state)
@@ -231,7 +231,7 @@
{.#None}
(in true)))
- (//module.with_module 0 (product.left name))
+ (//module.with 0 (product.left name))
(/phase#each product.right)
(/phase.result state)
(try.else false))))
@@ -331,7 +331,7 @@
{.#None}
(in true)))
- (//module.with_module 0 (product.left name))
+ (//module.with 0 (product.left name))
(/phase#each product.right)
(/phase.result state)
(try.else false))))
diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/analysis/module.lux b/stdlib/source/test/lux/tool/compiler/language/lux/analysis/module.lux
index ab07c98b3..d5cc7e0b8 100644
--- a/stdlib/source/test/lux/tool/compiler/language/lux/analysis/module.lux
+++ b/stdlib/source/test/lux/tool/compiler/language/lux/analysis/module.lux
@@ -82,9 +82,9 @@
(in (and (not pre) post)))
(/phase.result state)
(try.else false)))
- (_.cover [/.with_module]
+ (_.cover [/.with]
(|> (do /phase.monad
- [[it _] (/.with_module hash name
+ [[it _] (/.with hash name
(in []))]
(in it))
(/phase.result state)
@@ -94,7 +94,7 @@
(`` (and (~~ (template [<expected>]
[(|> (do [! /phase.monad]
[_ (/.create hash expected_import)
- [it ?] (/.with_module hash name
+ [it ?] (/.with hash name
(do !
[_ (if <expected>
(/.import expected_import)
@@ -111,7 +111,7 @@
(_.cover [/.alias]
(|> (do [! /phase.monad]
[_ (/.create hash expected_import)
- [it _] (/.with_module hash name
+ [it _] (/.with hash name
(do !
[_ (/.import expected_import)]
(/.alias expected_alias expected_import)))]
@@ -139,7 +139,7 @@
(~~ (template [<set> <query> <not/0> <not/1>]
[(_.cover [<set> <query>]
(|> (do [! /phase.monad]
- [[it ?] (/.with_module hash name
+ [[it ?] (/.with hash name
(do !
[_ (<set> name)
? (<query> name)
@@ -156,7 +156,7 @@
))
(_.cover [/.can_only_change_state_of_active_module]
(and (~~ (template [<pre> <post>]
- [(|> (/.with_module hash name
+ [(|> (/.with hash name
(do /phase.monad
[_ (<pre> name)]
(<post> name)))
@@ -215,7 +215,7 @@
($_ _.and
(_.cover [/.define]
(`` (and (~~ (template [<global>]
- [(|> (/.with_module hash module_name
+ [(|> (/.with hash module_name
(/.define def_name <global>))
(/phase.result state)
(case> {try.#Success _} true
@@ -226,7 +226,7 @@
[{.#Type [public? def_type {.#Right [labels|head labels|tail]}]}]
[{.#Tag [public? def_type (list& labels|head labels|tail) index]}]
[{.#Slot [public? def_type (list& labels|head labels|tail) index]}]))
- (|> (/.with_module hash module_name
+ (|> (/.with hash module_name
(do /phase.monad
[_ (/.define def_name definition)]
(/.define alias_name alias)))
@@ -235,7 +235,7 @@
{try.#Failure _} false)))))
(_.cover [/.cannot_define_more_than_once]
(`` (and (~~ (template [<global>]
- [(|> (/.with_module hash module_name
+ [(|> (/.with hash module_name
(do /phase.monad
[_ (/.define def_name <global>)]
(/.define def_name <global>)))
@@ -248,7 +248,7 @@
[{.#Type [public? def_type {.#Right [labels|head labels|tail]}]}]
[{.#Tag [public? def_type (list& labels|head labels|tail) index]}]
[{.#Slot [public? def_type (list& labels|head labels|tail) index]}]))
- (|> (/.with_module hash module_name
+ (|> (/.with hash module_name
(do /phase.monad
[_ (/.define def_name definition)
_ (/.define alias_name alias)]
@@ -280,7 +280,7 @@
($_ _.and
(_.cover [/.declare_labels]
(`` (and (~~ (template [<side> <record?> <query> <on_success>]
- [(|> (/.with_module hash module_name
+ [(|> (/.with hash module_name
(do [! /phase.monad]
[.let [it {.#Named [module_name def_name] def_type}]
_ (/.define def_name {.#Type [public? it {<side> [labels|head labels|tail]}]})
@@ -297,7 +297,7 @@
[.#Right true meta.tag false])))))
(_.cover [/.cannot_declare_labels_for_anonymous_type]
(`` (and (~~ (template [<side> <record?>]
- [(|> (/.with_module hash module_name
+ [(|> (/.with hash module_name
(do [! /phase.monad]
[.let [it def_type]
_ (/.define def_name {.#Type [public? it {<side> [labels|head labels|tail]}]})]
@@ -313,7 +313,7 @@
[.#Right true])))))
(_.cover [/.cannot_declare_labels_for_foreign_type]
(`` (and (~~ (template [<side> <record?>]
- [(|> (/.with_module hash module_name
+ [(|> (/.with hash module_name
(do [! /phase.monad]
[.let [it {.#Named [foreign_module def_name] def_type}]
_ (/.define def_name {.#Type [public? it {<side> [labels|head labels|tail]}]})]
diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux
index fcf0a556e..f559e98c4 100644
--- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux
+++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux
@@ -153,7 +153,7 @@
_
false)))
- (//module.with_module 0 (product.left name))
+ (//module.with 0 (product.left name))
(//phase#each product.right)
(//phase.result state)
(try.else false))))]
@@ -172,7 +172,7 @@
_
false)))
- (//module.with_module 0 (product.left name))
+ (//module.with 0 (product.left name))
(//phase#each product.right)
(//phase.result state)
(try.else false))
@@ -246,7 +246,7 @@
_
false)))
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each product.right)
(//phase.result state)
(try.else false))))
@@ -265,7 +265,7 @@
_
false)))
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each product.right)
(//phase.result state)
(try.else false))))]
@@ -313,7 +313,7 @@
_
false)))
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each product.right)
(//phase.result state)
(try.else false))))]
@@ -338,7 +338,7 @@
_
false)))
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each product.right)
(//phase.result state)
(try.else false))
@@ -357,7 +357,7 @@
_
false)))
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each product.right)
(//phase.result state)
(try.else false))
@@ -380,7 +380,7 @@
_
false)))
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each product.right)
(//phase.result state)
(try.else false))
@@ -398,7 +398,7 @@
_
false)))
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each product.right)
(//phase.result state)
(try.else false)))))
@@ -473,7 +473,7 @@
(|> (do //phase.monad
[_ (//module.declare_labels true slots/0 false :record:)]
(/.normal input))
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each product.right)
(//phase.result state)
(case> {try.#Success {.#Some actual}}
@@ -501,7 +501,7 @@
[_ (//module.declare_labels true slots/0 false :record:)]
(/.order pattern_matching? input))
//scope.with
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each (|>> product.right product.right))
(//phase.result state)
(case> {try.#Success {.#Some [actual_arity actual_tuple actual_type]}}
@@ -541,7 +541,7 @@
(|> (do //phase.monad
[_ (//module.declare_labels true slots/0 false :record:)]
(/.order pattern_matching? (list.repeated arity [[module head_slot/0] head_term/0])))
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each product.right)
(//phase.result state)
(..failure? /.cannot_repeat_slot))))]
@@ -556,7 +556,7 @@
[_ (//module.declare_labels true slots/0 false :record:)]
(/.order pattern_matching? input))
//scope.with
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase.result state)
(..failure? /.record_size_mismatch))))]
(and (mismatched? false (list.first slice local_record))
@@ -576,7 +576,7 @@
_ (//module.declare_labels true slots/1 false :record:)]
(/.order pattern_matching? input))
//scope.with
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase.result state)
(..failure? /.slot_does_not_belong_to_record))))]
(and (mismatched? false local_record)
@@ -591,7 +591,7 @@
(/.record ..analysis archive.empty tuple))
(//type.expecting type)
//scope.with
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each (|>> product.right product.right))
(//phase.result state)
(try#each (analysed? expected))
@@ -603,7 +603,7 @@
(//type.inferring
(/.record ..analysis archive.empty record)))
//scope.with
- (//module.with_module 0 module)
+ (//module.with 0 module)
(//phase#each (|>> product.right product.right))
(//phase.result state)
(try#each (function (_ [actual_type actual_term])
diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux
index 39bd5fd28..c16cbf491 100644
--- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux
+++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux
@@ -1,108 +1,213 @@
(.using
+ [library
[lux "*"
- [abstract
- ["[0]" monad {"+" do}]]
- ["r" math/random {"+" Random}]
["_" test {"+" Test}]
+ [abstract
+ [monad {"+" do}]]
[control
- pipe
- ["[0]" try {"+" Try}]]
+ [pipe {"+" case>}]
+ ["[0]" try ("[1]#[0]" functor)]
+ ["[0]" exception]]
[data
- ["[0]" text ("[1]#[0]" equivalence)]
- [number
- ["n" nat]]]
- ["[0]" type ("[1]#[0]" equivalence)]
- [macro
- ["[0]" code]]
- [meta
- ["[0]" symbol ("[1]#[0]" equivalence)]]]
- [//
- ["_[0]" primitive]]
- [\\
- ["[0]" /
- ["/[1]" //
- ["[1][0]" scope]
- ["[1][0]" module]
- ["[1][0]" type]
- ["/[1]" // "_"
- ["/[1]" //
- ["[1][0]" analysis {"+" Analysis Variant Tag Operation}]
- [///
- ["[1][0]" reference]
- ["[0]" phase]
- [meta
- ["[0]" archive]]]]]]]])
+ ["[0]" product]
+ ["[0]" text]]
+ [math
+ ["[0]" random]]
+ ["[0]" type ("[1]#[0]" equivalence)
+ ["$[1]" \\test]]]]
+ [\\library
+ ["[0]" /
+ ["/[1]" // "_"
+ [//
+ ["[1][0]" extension]
+ [//
+ ["[1][0]" analysis
+ ["[2][0]" scope]
+ ["[2][0]" module]
+ ["[2][0]" type
+ ["$[1]" \\test]]]
+ [///
+ ["[1][0]" phase ("[1]#[0]" monad)]]]]]]])
-(type: Check (-> (Try Any) Bit))
+(def: .public test
+ Test
+ (<| (_.covering /._)
+ (do [! random.monad]
+ [lux $//type.random_state
+ .let [state [//extension.#bundle //extension.empty
+ //extension.#state lux]]
+ expected_name (random.ascii/lower 1)
+ expected_type ($type.random 0)
+ expected_module (random.ascii/lower 2)
+ import (random.ascii/lower 3)
+ expected_label (random.ascii/lower 4)
+ record? random.bit]
+ ($_ _.and
+ (_.cover [/.reference]
+ (let [can_find_local_variable!
+ (|> (/.reference ["" expected_name])
+ (//scope.with_local [expected_name expected_type])
+ //type.inferring
+ //scope.with
+ (//phase.result state)
+ (try#each (|>> product.right
+ (case> (^ [actual_type (//analysis.local 0)])
+ (type#= expected_type actual_type)
-(template [<name> <on_success> <on_failure>]
- [(def: <name>
- Check
- (|>> (case> {try.#Success _}
- <on_success>
+ _
+ false)))
+ (try.else false))
- {try.#Failure _}
- <on_failure>)))]
+ can_find_foreign_variable!
+ (|> (/.reference ["" expected_name])
+ //type.inferring
+ //scope.with
+ (//scope.with_local [expected_name expected_type])
+ //scope.with
+ (//phase.result state)
+ (try#each (|>> product.right
+ product.right
+ (case> (^ [actual_type (//analysis.foreign 0)])
+ (type#= expected_type actual_type)
- [success? true false]
- [failure? false true]
- )
+ _
+ false)))
+ (try.else false))
-(def: (reach_test var_name [export? def_module] [import? dependent_module] check!)
- (-> Text [Bit Text] [Bit Text] Check Bit)
- (|> (do [! phase.monad]
- [_ (//module.with_module 0 def_module
- (//module.define var_name {.#Right [export? Any []]}))]
- (//module.with_module 0 dependent_module
- (do !
- [_ (if import?
- (//module.import def_module)
- (in []))]
- (//type.with_inference
- (_primitive.phase archive.empty (code.symbol [def_module var_name]))))))
- (phase.result _primitive.state)
- check!))
+ can_find_local_definition!
+ (|> (do //phase.monad
+ [_ (//module.define expected_name {.#Definition [#0 expected_type []]})]
+ (/.reference ["" expected_name]))
+ //type.inferring
+ (//module.with 0 expected_module)
+ (//phase.result state)
+ (try#each (|>> product.right
+ (case> (^ [actual_type (//analysis.constant [actual_module actual_name])])
+ (and (type#= expected_type actual_type)
+ (same? expected_module actual_module)
+ (same? expected_name actual_name))
-(def: .public test
- (<| (_.context (symbol.module (symbol /._)))
- (do r.monad
- [[expectedT _] _primitive.primitive
- def_module (r.unicode 5)
- scope_name (r.unicode 5)
- var_name (r.unicode 5)
- dependent_module (|> (r.unicode 5)
- (r.only (|>> (text#= def_module) not)))]
- ($_ _.and
- (_.test "Can analyse variable."
- (|> (//scope.with_scope scope_name
- (//scope.with_local [var_name expectedT]
- (//type.with_inference
- (_primitive.phase archive.empty (code.local_symbol var_name)))))
- (phase.result _primitive.state)
- (case> (^ {try.#Success [inferredT {////analysis.#Reference (////reference.local var)}]})
- (and (type#= expectedT inferredT)
- (n.= 0 var))
+ _
+ false)))
+ (try.else false))
+
+ can_find_foreign_definition!
+ (|> (do //phase.monad
+ [_ (//module.with 0 import
+ (//module.define expected_name {.#Definition [#1 expected_type []]}))
+ _ (//module.import import)]
+ (/.reference [import expected_name]))
+ //type.inferring
+ (//module.with 0 expected_module)
+ (//phase.result state)
+ (try#each (|>> product.right
+ (case> (^ [actual_type (//analysis.constant [actual_module actual_name])])
+ (and (type#= expected_type actual_type)
+ (same? import actual_module)
+ (same? expected_name actual_name))
+
+ _
+ false)))
+ (try.else false))
+
+ can_find_alias!
+ (|> (do //phase.monad
+ [_ (//module.with 0 import
+ (//module.define expected_name {.#Definition [#1 expected_type []]}))
+ _ (//module.import import)
+ _ (//module.define expected_name {.#Alias [import expected_name]})]
+ (/.reference [expected_module expected_name]))
+ //type.inferring
+ (//module.with 0 expected_module)
+ (//phase.result state)
+ (try#each (|>> product.right
+ (case> (^ [actual_type (//analysis.constant [actual_module actual_name])])
+ (and (type#= expected_type actual_type)
+ (same? import actual_module)
+ (same? expected_name actual_name))
+
+ _
+ false)))
+ (try.else false))
+
+ can_find_type!
+ (|> (do //phase.monad
+ [_ (//module.define expected_name {.#Type [#0 expected_type
+ (if record?
+ {.#Right [expected_label (list)]}
+ {.#Left [expected_label (list)]})]})]
+ (/.reference [expected_module expected_name]))
+ //type.inferring
+ (//module.with 0 expected_module)
+ (//phase.result state)
+ (try#each (|>> product.right
+ (case> (^ [actual_type (//analysis.constant [actual_module actual_name])])
+ (and (type#= .Type actual_type)
+ (same? expected_module actual_module)
+ (same? expected_name actual_name))
- _
- false)))
- (_.test "Can analyse definition (in the same module)."
- (let [def_name [def_module var_name]]
- (|> (do phase.monad
- [_ (//module.define var_name {.#Right [false expectedT []]})]
- (//type.with_inference
- (_primitive.phase archive.empty (code.symbol def_name))))
- (//module.with_module 0 def_module)
- (phase.result _primitive.state)
- (case> (^ {try.#Success [_ inferredT {////analysis.#Reference (////reference.constant constant_name)}]})
- (and (type#= expectedT inferredT)
- (symbol#= def_name constant_name))
+ _
+ false)))
+ (try.else false))]
+ (and can_find_local_variable!
+ can_find_foreign_variable!
+
+ can_find_local_definition!
+ can_find_foreign_definition!
- _
- false))))
- (_.test "Can analyse definition (if exported from imported module)."
- (reach_test var_name [true def_module] [true dependent_module] success?))
- (_.test "Cannot analyse definition (if not exported from imported module)."
- (reach_test var_name [false def_module] [true dependent_module] failure?))
- (_.test "Cannot analyse definition (if exported from non-imported module)."
- (reach_test var_name [true def_module] [false dependent_module] failure?))
+ can_find_alias!
+ can_find_type!)))
+ (_.cover [/.foreign_module_has_not_been_imported]
+ (let [scenario (: (-> Type Global Bit)
+ (function (_ expected_type it)
+ (|> (do //phase.monad
+ [_ (//module.with 0 import
+ (//module.define expected_name it))
+ _ (/.reference [import expected_name])]
+ (in false))
+ (//type.expecting expected_type)
+ (//module.with 0 expected_module)
+ (//phase#each product.right)
+ (//phase.result state)
+ (exception.otherwise (text.contains? (value@ exception.#label /.foreign_module_has_not_been_imported)))
+ )))]
+ (and (scenario expected_type {.#Definition [#1 expected_type []]})
+ (scenario .Type {.#Type [#1 expected_type
+ (if record?
+ {.#Right [expected_label (list)]}
+ {.#Left [expected_label (list)]})]}))))
+ (_.cover [/.definition_has_not_been_exported]
+ (let [scenario (: (-> Type Global Bit)
+ (function (_ expected_type it)
+ (|> (do //phase.monad
+ [_ (//module.with 0 import
+ (//module.define expected_name it))
+ _ (/.reference [import expected_name])]
+ (in false))
+ (//type.expecting expected_type)
+ (//module.with 0 expected_module)
+ (//phase#each product.right)
+ (//phase.result state)
+ (exception.otherwise (text.contains? (value@ exception.#label /.definition_has_not_been_exported)))
+ )))]
+ (and (scenario expected_type {.#Definition [#0 expected_type []]})
+ (scenario .Type {.#Type [#0 expected_type
+ (if record?
+ {.#Right [expected_label (list)]}
+ {.#Left [expected_label (list)]})]}))))
+ (_.cover [/.labels_are_not_definitions]
+ (let [scenario (: (-> Type Global Bit)
+ (function (_ expected_type it)
+ (|> (do //phase.monad
+ [_ (//module.with 0 import
+ (//module.define expected_label it))
+ _ (/.reference [import expected_label])]
+ (in false))
+ (//type.expecting expected_type)
+ (//module.with 0 expected_module)
+ (//phase#each product.right)
+ (//phase.result state)
+ (exception.otherwise (text.contains? (value@ exception.#label /.labels_are_not_definitions))))))]
+ (and (scenario expected_type {.#Tag [#1 expected_type (list) 0]})
+ (scenario expected_type {.#Slot [#1 expected_type (list) 0]}))))
))))