aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/specification/compositor/analysis
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/specification/compositor/analysis')
-rw-r--r--stdlib/source/specification/compositor/analysis/type.lux63
1 files changed, 63 insertions, 0 deletions
diff --git a/stdlib/source/specification/compositor/analysis/type.lux b/stdlib/source/specification/compositor/analysis/type.lux
new file mode 100644
index 000000000..7cbd5884b
--- /dev/null
+++ b/stdlib/source/specification/compositor/analysis/type.lux
@@ -0,0 +1,63 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." io]
+ ["." try]]
+ [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> (#try.Success _)
+ true
+
+ (#try.Failure _)
+ 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 #0 "#Bit" (0 #0)) code.bit]
+ [r.nat (0 #0 "#I64" (0 #1 (0 #0 "#Nat" (0 #0)) (0 #0))) code.nat]
+ [r.int (0 #0 "#I64" (0 #1 (0 #0 "#Int" (0 #0)) (0 #0))) code.int]
+ [r.rev (0 #0 "#I64" (0 #1 (0 #0 "#Rev" (0 #0)) (0 #0))) code.rev]
+ [r.safe-frac (0 #0 "#Frac" (0 #0)) code.frac]
+ [(r.ascii/upper-alpha 5) (0 #0 "#Text" (0 #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))
+ )))