aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/spec/compositor
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/spec/compositor')
-rw-r--r--stdlib/source/spec/compositor/analysis/type.lux67
-rw-r--r--stdlib/source/spec/compositor/common.lux17
2 files changed, 77 insertions, 7 deletions
diff --git a/stdlib/source/spec/compositor/analysis/type.lux b/stdlib/source/spec/compositor/analysis/type.lux
new file mode 100644
index 000000000..a6105bbde
--- /dev/null
+++ b/stdlib/source/spec/compositor/analysis/type.lux
@@ -0,0 +1,67 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ ["." type ("#@." equivalence)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." io]]
+ [data
+ ["." error]
+ ["." bit ("#@." equivalence)]
+ ["." text ("#@." equivalence)]]
+ [math
+ ["r" random (#+ Random)]]
+ [macro
+ ["." code]]
+ [tool
+ [compiler
+ [analysis (#+ State+)]
+ ["." phase
+ [macro (#+ Expander)]
+ ["." analysis
+ ["#/." scope]
+ ["#/." type]]]]]])
+
+(def: (check-success+ expander state extension params output-type)
+ (-> Expander State+ Text (List Code) Type Bit)
+ (|> (analysis/scope.with-scope ""
+ (analysis/type.with-type output-type
+ (analysis.phase expander (` ((~ (code.text extension)) (~+ params))))))
+ (phase.run state)
+ (case> (#error.Success _)
+ true
+
+ (#error.Failure error)
+ false)))
+
+(def: check
+ (Random [Code Type Code])
+ (`` ($_ r.either
+ (~~ (template [<random> <type> <code>]
+ [(do r.monad
+ [value <random>]
+ (wrap [(` <type>)
+ <type>
+ (<code> value)]))]
+
+ [r.bit (0 "#Bit" (0)) code.bit]
+ [r.nat (0 "#I64" (1 (0 "#Nat" (0)) (0))) code.nat]
+ [r.int (0 "#I64" (1 (0 "#Int" (0)) (0))) code.int]
+ [r.rev (0 "#I64" (1 (0 "#Rev" (0)) (0))) code.rev]
+ [r.safe-frac (0 "#Frac" (0)) code.frac]
+ [(r.ascii/upper-alpha 5) (0 "#Text" (0)) code.text]
+ )))))
+
+(def: #export (spec expander state)
+ (-> Expander State+ Test)
+ (do r.monad
+ [[typeC exprT exprC] ..check
+ [other-typeC other-exprT other-exprC] ..check]
+ ($_ _.and
+ (_.test "lux check"
+ (check-success+ expander state "lux check" (list typeC exprC) exprT))
+ (_.test "lux coerce"
+ (check-success+ expander state "lux coerce" (list typeC other-exprC) exprT))
+ )))
diff --git a/stdlib/source/spec/compositor/common.lux b/stdlib/source/spec/compositor/common.lux
index 4967c0f8c..df332df57 100644
--- a/stdlib/source/spec/compositor/common.lux
+++ b/stdlib/source/spec/compositor/common.lux
@@ -60,13 +60,16 @@
(Bundle anchor expression statement)
Expander
(-> expression statement)
- (IO (Error [Runner Definer]))))
+ (IO (Error [(statement.State+ anchor expression statement)
+ Runner
+ Definer]))))
(do io.monad
[?state (platform.initialize expander platform bundle program)]
(wrap (do error.monad
- [[bundle' state] ?state
- #let [state (get@ [#statement.generation
- #statement.state]
- state)]]
- (wrap [(..runner platform state)
- (..definer platform state)])))))
+ [[statement-bundle statement-state] ?state
+ #let [generation-state (get@ [#statement.generation
+ #statement.state]
+ statement-state)]]
+ (wrap [[statement-bundle statement-state]
+ (..runner platform generation-state)
+ (..definer platform generation-state)])))))