diff options
-rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/type.lux | 93 | ||||
-rw-r--r-- | stdlib/source/spec/compositor.lux | 31 | ||||
-rw-r--r-- | stdlib/source/spec/compositor/analysis/type.lux | 67 | ||||
-rw-r--r-- | stdlib/source/spec/compositor/common.lux | 17 |
4 files changed, 96 insertions, 112 deletions
diff --git a/new-luxc/test/test/luxc/lang/analysis/type.lux b/new-luxc/test/test/luxc/lang/analysis/type.lux deleted file mode 100644 index dc1a0fea9..000000000 --- a/new-luxc/test/test/luxc/lang/analysis/type.lux +++ /dev/null @@ -1,93 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bit "bit/" Eq<Bit>] - [text "text/" Eq<Text>] - (text format - ["l" lexer]) - [number] - ["e" error] - [product] - (coll [list "list/" Functor<List> Fold<List>])) - ["r" math/random "r/" Monad<Random>] - [macro #+ Monad<Meta>] - (macro [code]) - (lang [type "type/" Eq<Type>]) - test) - (luxc ["&" lang] - (lang ["&." module] - ["~" analysis] - (analysis [".A" expression] - ["@" type] - ["@." common]) - (translation (jvm ["@." runtime])) - [eval])) - (// common) - (test/luxc common)) - -(def: check - (r.Random [Code Type Code]) - (with-expansions [<triples> (template [<random> <type> <code>] - [(do r.Monad<Random> - [value <random>] - (wrap [(` <type>) - <type> - (<code> value)]))] - - [r.bit (+0 "#Bit" (+0)) code.bit] - [r.nat (+0 "#Nat" (+0)) code.nat] - [r.int (+0 "#Int" (+0)) code.int] - [r.rev (+0 "#Rev" (+0)) code.rev] - [r.frac (+0 "#Frac" (+0)) code.frac] - [(r.text +5) (+0 "#Text" (+0)) code.text] - )] - ($_ r.either - <triples>))) - -(context: "Type checking/coercion." - (<| (times +100) - (do @ - [[typeC codeT exprC] check] - ($_ seq - (test (format "Can analyse type-checking.") - (|> (do Monad<Meta> - [runtime-bytecode @runtime.translate] - (&.with-scope - (@common.with-unknown-type - (@.analyse-check analyse eval.eval typeC exprC)))) - (&.with-current-module "") - (macro.run (io.run init-jvm)) - (case> (#e.Success [_ [analysisT analysisA]]) - (and (type/= codeT analysisT) - (case [exprC analysisA] - (^template [<tag> <test>] - [[_ (<tag> expected)] [_ (<tag> actual)]] - (<test> expected actual)) - ([#.Bit bit/=] - [#.Nat n/=] - [#.Int i/=] - [#.Rev r/=] - [#.Frac f/=] - [#.Text text/=]) - - _ - #0)) - - (#e.Error error) - #0))) - (test (format "Can analyse type-coercion.") - (|> (do Monad<Meta> - [runtime-bytecode @runtime.translate] - (&.with-scope - (@common.with-unknown-type - (@.analyse-coerce analyse eval.eval typeC exprC)))) - (&.with-current-module "") - (macro.run (io.run init-jvm)) - (case> (#e.Success [_ [analysisT analysisA]]) - (type/= codeT analysisT) - - (#e.Error error) - #0))) - )))) diff --git a/stdlib/source/spec/compositor.lux b/stdlib/source/spec/compositor.lux index 5f46aad84..75818c3cf 100644 --- a/stdlib/source/spec/compositor.lux +++ b/stdlib/source/spec/compositor.lux @@ -11,6 +11,8 @@ ["r" random]] [tool [compiler + ["." analysis] + ["." statement] [phase [macro (#+ Expander)] [generation (#+ Bundle)]] @@ -18,6 +20,8 @@ [platform (#+ Platform)]]]]] ["." / #_ ["#." common (#+ Runner Definer)] + ["#./" analysis #_ + ["#." type]] ["#./" generation #_ ["#." primitive] ["#." structure] @@ -26,9 +30,10 @@ ["#." function] ["#." common]]]) -(def: (test runner definer) - (-> Runner Definer Test) +(def: (test runner definer state expander) + (-> Runner Definer analysis.State+ Expander Test) ($_ _.and + (/analysis/type.spec expander state) (/generation/primitive.spec runner) (/generation/structure.spec runner) (/generation/reference.spec runner definer) @@ -46,16 +51,18 @@ Test)) (do r.monad [_ (wrap []) - #let [?runner,definer (<| io.run - (do io.monad - [platform platform]) - (/common.executors platform - bundle - expander - program))]] - (case ?runner,definer - (#error.Success [runner definer]) - (..test runner definer) + #let [?state,runner,definer (<| io.run + (do io.monad + [platform platform]) + (/common.executors platform + bundle + expander + program))]] + (case ?state,runner,definer + (#error.Success [[statement-bundle statement-state] runner definer]) + (..test runner definer + (get@ [#statement.analysis #statement.state] statement-state) + expander) (#error.Failure error) (_.fail error)))) 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)]))))) |