aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/spec/compositor/analysis
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/spec/compositor/analysis')
-rw-r--r--stdlib/source/spec/compositor/analysis/type.lux67
1 files changed, 67 insertions, 0 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))
+ )))