From 15121222d570f8fe3c5a326208e4f0bad737e63c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 31 Oct 2017 23:39:49 -0400 Subject: - Re-organized analysis. --- new-luxc/source/luxc/analyser.lux | 141 --- new-luxc/source/luxc/analyser/case.lux | 260 ---- new-luxc/source/luxc/analyser/case/coverage.lux | 299 ----- new-luxc/source/luxc/analyser/common.lux | 41 - new-luxc/source/luxc/analyser/function.lux | 111 -- new-luxc/source/luxc/analyser/inference.lux | 228 ---- new-luxc/source/luxc/analyser/primitive.lux | 34 - new-luxc/source/luxc/analyser/procedure.lux | 23 - new-luxc/source/luxc/analyser/procedure/common.lux | 418 ------- .../source/luxc/analyser/procedure/host.jvm.lux | 1241 -------------------- new-luxc/source/luxc/analyser/reference.lux | 53 - new-luxc/source/luxc/analyser/structure.lux | 311 ----- new-luxc/source/luxc/analyser/type.lux | 31 - new-luxc/source/luxc/eval.lux | 6 +- new-luxc/source/luxc/generator.lux | 10 +- new-luxc/source/luxc/generator/eval.jvm.lux | 1 - new-luxc/source/luxc/generator/expression.jvm.lux | 1 - new-luxc/source/luxc/generator/function.jvm.lux | 1 - new-luxc/source/luxc/generator/primitive.jvm.lux | 1 - .../source/luxc/generator/procedure/common.jvm.lux | 1 - .../source/luxc/generator/procedure/host.jvm.lux | 3 +- new-luxc/source/luxc/generator/runtime.jvm.lux | 1 - new-luxc/source/luxc/generator/structure.jvm.lux | 1 - new-luxc/source/luxc/lang/analysis/case.lux | 260 ++++ .../source/luxc/lang/analysis/case/coverage.lux | 299 +++++ new-luxc/source/luxc/lang/analysis/common.lux | 41 + new-luxc/source/luxc/lang/analysis/expression.lux | 141 +++ new-luxc/source/luxc/lang/analysis/function.lux | 111 ++ new-luxc/source/luxc/lang/analysis/inference.lux | 228 ++++ new-luxc/source/luxc/lang/analysis/primitive.lux | 34 + new-luxc/source/luxc/lang/analysis/procedure.lux | 23 + .../source/luxc/lang/analysis/procedure/common.lux | 418 +++++++ .../luxc/lang/analysis/procedure/host.jvm.lux | 1241 ++++++++++++++++++++ new-luxc/source/luxc/lang/analysis/reference.lux | 53 + new-luxc/source/luxc/lang/analysis/structure.lux | 311 +++++ new-luxc/source/luxc/lang/analysis/type.lux | 31 + new-luxc/source/luxc/lang/parser.lux | 610 ++++++++++ new-luxc/source/luxc/parser.lux | 610 ---------- new-luxc/test/test/luxc/analyser/case.lux | 227 ---- new-luxc/test/test/luxc/analyser/common.lux | 52 - new-luxc/test/test/luxc/analyser/function.lux | 154 --- new-luxc/test/test/luxc/analyser/primitive.lux | 67 -- .../test/test/luxc/analyser/procedure/common.lux | 423 ------- .../test/test/luxc/analyser/procedure/host.jvm.lux | 529 --------- new-luxc/test/test/luxc/analyser/reference.lux | 52 - new-luxc/test/test/luxc/analyser/structure.lux | 336 ------ new-luxc/test/test/luxc/analyser/type.lux | 91 -- new-luxc/test/test/luxc/generator/case.lux | 1 - new-luxc/test/test/luxc/generator/function.lux | 1 - new-luxc/test/test/luxc/generator/primitive.lux | 1 - .../test/luxc/generator/procedure/common.jvm.lux | 1 - .../test/luxc/generator/procedure/host.jvm.lux | 1 - new-luxc/test/test/luxc/generator/structure.lux | 1 - new-luxc/test/test/luxc/lang/analysis/case.lux | 227 ++++ new-luxc/test/test/luxc/lang/analysis/common.lux | 52 + new-luxc/test/test/luxc/lang/analysis/function.lux | 154 +++ .../test/test/luxc/lang/analysis/primitive.lux | 67 ++ .../test/luxc/lang/analysis/procedure/common.lux | 423 +++++++ .../test/luxc/lang/analysis/procedure/host.jvm.lux | 529 +++++++++ .../test/test/luxc/lang/analysis/reference.lux | 52 + .../test/test/luxc/lang/analysis/structure.lux | 336 ++++++ new-luxc/test/test/luxc/lang/analysis/type.lux | 91 ++ new-luxc/test/test/luxc/lang/parser.lux | 233 ++++ new-luxc/test/test/luxc/parser.lux | 233 ---- new-luxc/test/test/luxc/synthesizer/primitive.lux | 1 - new-luxc/test/test/luxc/synthesizer/procedure.lux | 1 - new-luxc/test/tests.lux | 18 +- 67 files changed, 5983 insertions(+), 5999 deletions(-) delete mode 100644 new-luxc/source/luxc/analyser.lux delete mode 100644 new-luxc/source/luxc/analyser/case.lux delete mode 100644 new-luxc/source/luxc/analyser/case/coverage.lux delete mode 100644 new-luxc/source/luxc/analyser/common.lux delete mode 100644 new-luxc/source/luxc/analyser/function.lux delete mode 100644 new-luxc/source/luxc/analyser/inference.lux delete mode 100644 new-luxc/source/luxc/analyser/primitive.lux delete mode 100644 new-luxc/source/luxc/analyser/procedure.lux delete mode 100644 new-luxc/source/luxc/analyser/procedure/common.lux delete mode 100644 new-luxc/source/luxc/analyser/procedure/host.jvm.lux delete mode 100644 new-luxc/source/luxc/analyser/reference.lux delete mode 100644 new-luxc/source/luxc/analyser/structure.lux delete mode 100644 new-luxc/source/luxc/analyser/type.lux create mode 100644 new-luxc/source/luxc/lang/analysis/case.lux create mode 100644 new-luxc/source/luxc/lang/analysis/case/coverage.lux create mode 100644 new-luxc/source/luxc/lang/analysis/common.lux create mode 100644 new-luxc/source/luxc/lang/analysis/expression.lux create mode 100644 new-luxc/source/luxc/lang/analysis/function.lux create mode 100644 new-luxc/source/luxc/lang/analysis/inference.lux create mode 100644 new-luxc/source/luxc/lang/analysis/primitive.lux create mode 100644 new-luxc/source/luxc/lang/analysis/procedure.lux create mode 100644 new-luxc/source/luxc/lang/analysis/procedure/common.lux create mode 100644 new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux create mode 100644 new-luxc/source/luxc/lang/analysis/reference.lux create mode 100644 new-luxc/source/luxc/lang/analysis/structure.lux create mode 100644 new-luxc/source/luxc/lang/analysis/type.lux create mode 100644 new-luxc/source/luxc/lang/parser.lux delete mode 100644 new-luxc/source/luxc/parser.lux delete mode 100644 new-luxc/test/test/luxc/analyser/case.lux delete mode 100644 new-luxc/test/test/luxc/analyser/common.lux delete mode 100644 new-luxc/test/test/luxc/analyser/function.lux delete mode 100644 new-luxc/test/test/luxc/analyser/primitive.lux delete mode 100644 new-luxc/test/test/luxc/analyser/procedure/common.lux delete mode 100644 new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux delete mode 100644 new-luxc/test/test/luxc/analyser/reference.lux delete mode 100644 new-luxc/test/test/luxc/analyser/structure.lux delete mode 100644 new-luxc/test/test/luxc/analyser/type.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/case.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/common.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/function.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/primitive.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/procedure/common.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/reference.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/structure.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/type.lux create mode 100644 new-luxc/test/test/luxc/lang/parser.lux delete mode 100644 new-luxc/test/test/luxc/parser.lux diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux deleted file mode 100644 index a7b872de5..000000000 --- a/new-luxc/source/luxc/analyser.lux +++ /dev/null @@ -1,141 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data ["e" error] - [product] - text/format) - [meta] - (meta [type] - (type ["tc" check])) - [host]) - (luxc ["&" base] - [";L" host] - (lang ["la" analysis]) - ["&;" module] - (generator [";G" common])) - (. ["&&;" common] - ["&&;" function] - ["&&;" primitive] - ["&&;" reference] - ["&&;" structure] - ["&&;" procedure])) - -(for {"JVM" (as-is (host;import java.lang.reflect.Method - (invoke [Object (Array Object)] #try Object)) - (host;import (java.lang.Class c) - (getMethod [String (Array (Class Object))] #try Method)) - (host;import java.lang.Object - (getClass [] (Class Object)) - (toString [] String)) - (def: _object-class (Class Object) (host;class-for Object)) - (def: _apply-args - (Array (Class Object)) - (|> (host;array (Class Object) +2) - (host;array-write +0 _object-class) - (host;array-write +1 _object-class))) - (def: (call-macro macro inputs) - (-> Macro (List Code) (Meta (List Code))) - (do meta;Monad - [class (commonG;load-class hostL;function-class)] - (function [compiler] - (do e;Monad - [apply-method (Class.getMethod ["apply" _apply-args] class) - output (Method.invoke [(:! Object macro) - (|> (host;array Object +2) - (host;array-write +0 (:! Object inputs)) - (host;array-write +1 (:! Object compiler)))] - apply-method)] - (:! (e;Error [Compiler (List Code)]) - output)))))) - }) - -(exception: #export Macro-Expression-Must-Have-Single-Expansion) -(exception: #export Unrecognized-Syntax) - -(def: #export (analyser eval) - (-> &;Eval &;Analyser) - (: (-> Code (Meta la;Analysis)) - (function analyse [ast] - (do meta;Monad - [expectedT meta;expected-type] - (let [[cursor ast'] ast] - ## The cursor must be set in the compiler for the sake - ## of having useful error messages. - (&;with-cursor cursor - (case ast' - (^template [ ] - ( value) - ( value)) - ([#;Bool &&primitive;analyse-bool] - [#;Nat &&primitive;analyse-nat] - [#;Int &&primitive;analyse-int] - [#;Deg &&primitive;analyse-deg] - [#;Frac &&primitive;analyse-frac] - [#;Text &&primitive;analyse-text]) - - (^ (#;Tuple (list))) - &&primitive;analyse-unit - - ## Singleton tuples are equivalent to the element they contain. - (^ (#;Tuple (list singleton))) - (analyse singleton) - - (^ (#;Tuple elems)) - (&&structure;analyse-product analyse elems) - - (^ (#;Record pairs)) - (&&structure;analyse-record analyse pairs) - - (#;Symbol reference) - (&&reference;analyse-reference reference) - - (^ (#;Form (list& [_ (#;Text proc-name)] proc-args))) - (&&procedure;analyse-procedure analyse eval proc-name proc-args) - - (^template [ ] - (^ (#;Form (list& [_ ( tag)] - values))) - (case values - (#;Cons value #;Nil) - ( analyse tag value) - - _ - ( analyse tag (` [(~@ values)])))) - ([#;Nat &&structure;analyse-sum] - [#;Tag &&structure;analyse-tagged-sum]) - - (#;Tag tag) - (&&structure;analyse-tagged-sum analyse tag (' [])) - - (^ (#;Form (list& func args))) - (do meta;Monad - [[funcT =func] (&&common;with-unknown-type - (analyse func))] - (case =func - [_ (#;Symbol def-name)] - (do @ - [[def-type def-anns def-value] (meta;find-def def-name)] - (if (meta;macro? def-anns) - (do @ - [expansion (function [compiler] - (case (call-macro (:! Macro def-value) args compiler) - (#e;Success [compiler' output]) - (#e;Success [compiler' output]) - - (#e;Error error) - ((&;fail error) compiler)))] - (case expansion - (^ (list single)) - (analyse single) - - _ - (&;throw Macro-Expression-Must-Have-Single-Expansion (%code ast)))) - (&&function;analyse-apply analyse funcT =func args))) - - _ - (&&function;analyse-apply analyse funcT =func args))) - - _ - (&;throw Unrecognized-Syntax (%code ast)) - ))))))) diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux deleted file mode 100644 index 29256865a..000000000 --- a/new-luxc/source/luxc/analyser/case.lux +++ /dev/null @@ -1,260 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - eq) - (data [bool] - [number] - [product] - ["e" error] - [maybe] - [text] - text/format - (coll [list "list/" Fold Monoid Functor])) - [meta] - (meta [code] - [type] - (type ["tc" check]))) - (../.. ["&" base] - (lang ["la" analysis]) - ["&;" scope]) - (.. ["&;" common] - ["&;" structure]) - (. ["&&;" coverage])) - -(exception: #export Cannot-Match-Type-With-Pattern) -(exception: #export Sum-Type-Has-No-Case) -(exception: #export Unrecognized-Pattern-Syntax) -(exception: #export Cannot-Simplify-Type-For-Pattern-Matching) - -(def: (pattern-error type pattern) - (-> Type Code Text) - (Cannot-Match-Type-With-Pattern - (format " Type: " (%type type) "\n" - "Pattern: " (%code pattern)))) - -## Type-checking on the input value is done during the analysis of a -## "case" expression, to ensure that the patterns being used make -## sense for the type of the input value. -## Sometimes, that input value is complex, by depending on -## type-variables or quantifications. -## This function makes it easier for "case" analysis to properly -## type-check the input with respect to the patterns. -(def: (simplify-case-type type) - (-> Type (Meta Type)) - (case type - (#;Var id) - (do meta;Monad - [? (&;with-type-env - (tc;bound? id))] - (if ? - (do @ - [type' (&;with-type-env - (tc;read id))] - (simplify-case-type type')) - (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type type)))) - - (#;Named name unnamedT) - (simplify-case-type unnamedT) - - (^or (#;UnivQ _) (#;ExQ _)) - (do meta;Monad - [[ex-id exT] (&;with-type-env - tc;existential)] - (simplify-case-type (maybe;assume (type;apply (list exT) type)))) - - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) - (:: meta;Monad wrap outputT) - - #;None - (&;fail (format "Cannot apply type " (%type funcT) " to type " (%type inputT)))) - - _ - (:: meta;Monad wrap type))) - -## This function handles several concerns at once, but it must be that -## way because those concerns are interleaved when doing -## pattern-matching and they cannot be separated. -## The pattern is analysed in order to get a general feel for what is -## expected of the input value. This, in turn, informs the -## type-checking of the input. -## A kind of "continuation" value is passed around which signifies -## what needs to be done _after_ analysing a pattern. -## In general, this is done to analyse the "body" expression -## associated to a particular pattern _in the context of_ said -## pattern. -## The reason why *context* is important is because patterns may bind -## values to local variables, which may in turn be referenced in the -## body expressions. -## That is why the body must be analysed in the context of the -## pattern, and not separately. -(def: (analyse-pattern num-tags inputT pattern next) - (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la;Pattern a]))) - (case pattern - [cursor (#;Symbol ["" name])] - (&;with-cursor cursor - (do meta;Monad - [outputA (&scope;with-local [name inputT] - next) - idx &scope;next-local] - (wrap [(` ("lux case bind" (~ (code;nat idx)))) outputA]))) - - [cursor (#;Symbol ident)] - (&;with-cursor cursor - (&;fail (format "Symbols must be unqualified inside patterns: " (%ident ident)))) - - (^template [ ] - [cursor ( test)] - (&;with-cursor cursor - (do meta;Monad - [_ (&;with-type-env - (tc;check inputT )) - outputA next] - (wrap [pattern outputA])))) - ([Bool #;Bool] - [Nat #;Nat] - [Int #;Int] - [Deg #;Deg] - [Frac #;Frac] - [Text #;Text]) - - (^ [cursor (#;Tuple (list))]) - (&;with-cursor cursor - (do meta;Monad - [_ (&;with-type-env - (tc;check inputT Unit)) - outputA next] - (wrap [(` ("lux case tuple" [])) outputA]))) - - (^ [cursor (#;Tuple (list singleton))]) - (analyse-pattern #;None inputT singleton next) - - [cursor (#;Tuple sub-patterns)] - (&;with-cursor cursor - (do meta;Monad - [inputT' (simplify-case-type inputT)] - (case inputT' - (#;Product _) - (let [sub-types (type;flatten-tuple inputT') - num-sub-types (maybe;default (list;size sub-types) - num-tags) - num-sub-patterns (list;size sub-patterns) - matches (cond (n.< num-sub-types num-sub-patterns) - (let [[prefix suffix] (list;split (n.dec num-sub-patterns) sub-types)] - (list;zip2 (list/compose prefix (list (type;tuple suffix))) sub-patterns)) - - (n.> num-sub-types num-sub-patterns) - (let [[prefix suffix] (list;split (n.dec num-sub-types) sub-patterns)] - (list;zip2 sub-types (list/compose prefix (list (code;tuple suffix))))) - - ## (n.= num-sub-types num-sub-patterns) - (list;zip2 sub-types sub-patterns) - )] - (do @ - [[memberP+ thenA] (list/fold (: (All [a] - (-> [Type Code] (Meta [(List la;Pattern) a]) - (Meta [(List la;Pattern) a]))) - (function [[memberT memberC] then] - (do @ - [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la;Pattern a]))) - analyse-pattern) - #;None memberT memberC then)] - (wrap [(list& memberP memberP+) thenA])))) - (do @ - [nextA next] - (wrap [(list) nextA])) - matches)] - (wrap [(` ("lux case tuple" [(~@ memberP+)])) - thenA]))) - - _ - (&;fail (pattern-error inputT pattern)) - ))) - - [cursor (#;Record record)] - (do meta;Monad - [record (&structure;normalize record) - [members recordT] (&structure;order record) - _ (&;with-type-env - (tc;check inputT recordT))] - (analyse-pattern (#;Some (list;size members)) inputT [cursor (#;Tuple members)] next)) - - [cursor (#;Tag tag)] - (&;with-cursor cursor - (analyse-pattern #;None inputT (` ((~ pattern))) next)) - - (^ [cursor (#;Form (list& [_ (#;Nat idx)] values))]) - (&;with-cursor cursor - (do meta;Monad - [inputT' (simplify-case-type inputT)] - (case inputT' - (#;Sum _) - (let [flat-sum (type;flatten-variant inputT') - size-sum (list;size flat-sum) - num-cases (maybe;default size-sum num-tags)] - (case (list;nth idx flat-sum) - (^multi (#;Some case-type) - (n.< num-cases idx)) - (if (and (n.> num-cases size-sum) - (n.= (n.dec num-cases) idx)) - (do meta;Monad - [[testP nextA] (analyse-pattern #;None - (type;variant (list;drop (n.dec num-cases) flat-sum)) - (` [(~@ values)]) - next)] - (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP))) - nextA])) - (do meta;Monad - [[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)] - (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP))) - nextA]))) - - _ - (&;throw Sum-Type-Has-No-Case - (format "Case: " (%n idx) "\n" - "Type: " (%type inputT))))) - - _ - (&;fail (pattern-error inputT pattern))))) - - (^ [cursor (#;Form (list& [_ (#;Tag tag)] values))]) - (&;with-cursor cursor - (do meta;Monad - [tag (meta;normalize tag) - [idx group variantT] (meta;resolve-tag tag) - _ (&;with-type-env - (tc;check inputT variantT))] - (analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next))) - - _ - (&;throw Unrecognized-Pattern-Syntax (%code pattern)) - )) - -(def: #export (analyse-case analyse inputC branches) - (-> &;Analyser Code (List [Code Code]) (Meta la;Analysis)) - (case branches - #;Nil - (&;fail "Cannot have empty branches in pattern-matching expression.") - - (#;Cons [patternH bodyH] branchesT) - (do meta;Monad - [[inputT inputA] (&common;with-unknown-type - (analyse inputC)) - outputH (analyse-pattern #;None inputT patternH (analyse bodyH)) - outputT (monad;map @ - (function [[patternT bodyT]] - (analyse-pattern #;None inputT patternT (analyse bodyT))) - branchesT) - outputHC (|> outputH product;left &&coverage;determine) - outputTC (monad;map @ (|>. product;left &&coverage;determine) outputT) - _ (case (monad;fold e;Monad &&coverage;merge outputHC outputTC) - (#e;Success coverage) - (if (&&coverage;exhaustive? coverage) - (wrap []) - (&;fail "Pattern-matching is not exhaustive.")) - - (#e;Error error) - (&;fail error))] - (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT))))))))) diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux deleted file mode 100644 index 554aea1a8..000000000 --- a/new-luxc/source/luxc/analyser/case/coverage.lux +++ /dev/null @@ -1,299 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - eq) - (data [bool "bool/" Eq] - [number] - ["e" error "error/" Monad] - text/format - (coll [list "list/" Fold] - [dict #+ Dict])) - [meta "meta/" Monad]) - (luxc ["&" base] - (lang ["la" analysis]))) - -## The coverage of a pattern-matching expression summarizes how well -## all the possible values of an input are being covered by the -## different patterns involved. -## Ideally, the pattern-matching has "exhaustive" coverage, which just -## means that every possible value can be matched by at least 1 -## pattern. -## Every other coverage is considered partial, and it would be valued -## as insuficient (since it could lead to runtime errors due to values -## not being handled by any pattern). -## The #Partial tag covers arbitrary partial coverages in a general -## way, while the other tags cover more specific cases for booleans -## and variants. -(type: #export #rec Coverage - #Partial - (#Bool Bool) - (#Variant Nat (Dict Nat Coverage)) - (#Seq Coverage Coverage) - (#Alt Coverage Coverage) - #Exhaustive) - -(def: #export (exhaustive? coverage) - (-> Coverage Bool) - (case coverage - (#Exhaustive _) - true - - _ - false)) - -(exception: #export Unknown-Pattern) - -(def: #export (determine pattern) - (-> la;Pattern (Meta Coverage)) - (case pattern - ## Binding amounts to exhaustive coverage because any value can be - ## matched that way. - ## Unit [] amounts to exhaustive coverage because there is only one - ## possible value, so matching against it covers all cases. - (^or (^code ("lux case bind" (~ _))) (^code ("lux case tuple" []))) - (meta/wrap #Exhaustive) - - (^code ("lux case tuple" [(~ singleton)])) - (determine singleton) - - ## Primitive patterns always have partial coverage because there - ## are too many possibilities as far as values go. - (^or [_ (#;Nat _)] [_ (#;Int _)] [_ (#;Deg _)] - [_ (#;Frac _)] [_ (#;Text _)]) - (meta/wrap #Partial) - - ## Bools are the exception, since there is only "true" and - ## "false", which means it is possible for boolean - ## pattern-matching to become exhaustive if complementary parts meet. - [_ (#;Bool value)] - (meta/wrap (#Bool value)) - - ## Tuple patterns can be exhaustive if there is exhaustiveness for all of - ## their sub-patterns. - (^code ("lux case tuple" [(~@ subs)])) - (loop [subs subs] - (case subs - #;Nil - (meta/wrap #Exhaustive) - - (#;Cons sub subs') - (do meta;Monad - [pre (determine sub) - post (recur subs')] - (if (exhaustive? post) - (wrap pre) - (wrap (#Seq pre post)))))) - - ## Variant patterns can be shown to be exhaustive if all the possible - ## cases are handled exhaustively. - (^code ("lux case variant" (~ [_ (#;Nat tag-id)]) (~ [_ (#;Nat num-tags)]) (~ sub))) - (do meta;Monad - [=sub (determine sub)] - (wrap (#Variant num-tags - (|> (dict;new number;Hash) - (dict;put tag-id =sub))))) - - _ - (&;throw Unknown-Pattern (%code pattern)))) - -(def: (xor left right) - (-> Bool Bool Bool) - (or (and left (not right)) - (and (not left) right))) - -## The coverage checker not only verifies that pattern-matching is -## exhaustive, but also that there are no redundant patterns. -## Redundant patterns will never be executed, since there will -## always be a pattern prior to them that would match the input. -## Because of that, the presence of redundant patterns is assumed to -## be a bug, likely due to programmer carelessness. -(def: redundant-pattern - (e;Error Coverage) - (e;fail "Redundant pattern.")) - -(def: (flatten-alt coverage) - (-> Coverage (List Coverage)) - (case coverage - (#Alt left right) - (list& left (flatten-alt right)) - - _ - (list coverage))) - -(struct: _ (Eq Coverage) - (def: (= reference sample) - (case [reference sample] - [#Exhaustive #Exhaustive] - true - - [(#Bool sideR) (#Bool sideS)] - (bool/= sideR sideS) - - [(#Variant allR casesR) (#Variant allS casesS)] - (and (n.= allR allS) - (:: (dict;Eq =) = casesR casesS)) - - [(#Seq leftR rightR) (#Seq leftS rightS)] - (and (= leftR leftS) - (= rightR rightS)) - - [(#Alt _) (#Alt _)] - (let [flatR (flatten-alt reference) - flatS (flatten-alt sample)] - (and (n.= (list;size flatR) (list;size flatS)) - (list;every? (function [[coverageR coverageS]] - (= coverageR coverageS)) - (list;zip2 flatR flatS)))) - - _ - false))) - -(open Eq "C/") - -## After determining the coverage of each individual pattern, it is -## necessary to merge them all to figure out if the entire -## pattern-matching expression is exhaustive and whether it contains -## redundant patterns. -(def: #export (merge addition so-far) - (-> Coverage Coverage (e;Error Coverage)) - (case [addition so-far] - ## The addition cannot possibly improve the coverage. - [_ #Exhaustive] - redundant-pattern - - ## The addition completes the coverage. - [#Exhaustive _] - (error/wrap #Exhaustive) - - [#Partial #Partial] - (error/wrap #Partial) - - ## 2 boolean coverages are exhaustive if they compliment one another. - (^multi [(#Bool sideA) (#Bool sideSF)] - (xor sideA sideSF)) - (error/wrap #Exhaustive) - - [(#Variant allA casesA) (#Variant allSF casesSF)] - (cond (not (n.= allSF allA)) - (e;fail "Variants do not match.") - - (:: (dict;Eq Eq) = casesSF casesA) - redundant-pattern - - ## else - (do e;Monad - [casesM (monad;fold @ - (function [[tagA coverageA] casesSF'] - (case (dict;get tagA casesSF') - (#;Some coverageSF) - (do @ - [coverageM (merge coverageA coverageSF)] - (wrap (dict;put tagA coverageM casesSF'))) - - #;None - (wrap (dict;put tagA coverageA casesSF')))) - casesSF (dict;entries casesA))] - (wrap (if (let [case-coverages (dict;values casesM)] - (and (n.= allSF (list;size case-coverages)) - (list;every? exhaustive? case-coverages))) - #Exhaustive - (#Variant allSF casesM))))) - - [(#Seq leftA rightA) (#Seq leftSF rightSF)] - (case [(C/= leftSF leftA) (C/= rightSF rightA)] - ## There is nothing the addition adds to the coverage. - [true true] - redundant-pattern - - ## The 2 sequences cannot possibly be merged. - [false false] - (error/wrap (#Alt so-far addition)) - - ## Same prefix - [true false] - (do e;Monad - [rightM (merge rightA rightSF)] - (if (exhaustive? rightM) - ## If all that follows is exhaustive, then it can be safely dropped - ## (since only the "left" part would influence whether the - ## merged coverage is exhaustive or not). - (wrap leftSF) - (wrap (#Seq leftSF rightM)))) - - ## Same suffix - [false true] - (do e;Monad - [leftM (merge leftA leftSF)] - (wrap (#Seq leftM rightA)))) - - ## The left part will always match, so the addition is redundant. - (^multi [(#Seq left right) single] - (C/= left single)) - redundant-pattern - - ## The right part is not necessary, since it can always match the left. - (^multi [single (#Seq left right)] - (C/= left single)) - (error/wrap single) - - ## When merging a new coverage against one based on Alt, it may be - ## that one of the many coverages in the Alt is complementary to - ## the new one, so effort must be made to fuse carefully, to match - ## the right coverages together. - ## If one of the Alt sub-coverages matches the new one, the cycle - ## must be repeated, in case the resulting coverage can now match - ## other ones in the original Alt. - ## This process must be repeated until no further productive - ## merges can be done. - [_ (#Alt leftS rightS)] - (do e;Monad - [#let [fuse-once (: (-> Coverage (List Coverage) - (e;Error [(Maybe Coverage) - (List Coverage)])) - (function [coverage possibilities] - (loop [alts possibilities] - (case alts - #;Nil - (wrap [#;None (list coverage)]) - - (#;Cons alt alts') - (case (merge coverage alt) - (#e;Success altM) - (case altM - (#Alt _) - (do @ - [[success alts+] (recur alts')] - (wrap [success (#;Cons alt alts+)])) - - _ - (wrap [(#;Some altM) alts'])) - - (#e;Error error) - (e;fail error)) - ))))] - [success possibilities] (fuse-once addition (flatten-alt so-far))] - (loop [success success - possibilities possibilities] - (case success - (#;Some coverage') - (do @ - [[success' possibilities'] (fuse-once coverage' possibilities)] - (recur success' possibilities')) - - #;None - (case (list;reverse possibilities) - (#;Cons last prevs) - (wrap (list/fold (function [left right] (#Alt left right)) - last - prevs)) - - #;Nil - (undefined))))) - - _ - (if (C/= so-far addition) - ## The addition cannot possibly improve the coverage. - redundant-pattern - ## There are now 2 alternative paths. - (error/wrap (#Alt so-far addition))))) diff --git a/new-luxc/source/luxc/analyser/common.lux b/new-luxc/source/luxc/analyser/common.lux deleted file mode 100644 index 4cbf5aedf..000000000 --- a/new-luxc/source/luxc/analyser/common.lux +++ /dev/null @@ -1,41 +0,0 @@ -(;module: - lux - (lux (control monad - pipe) - (data text/format - [product]) - [meta #+ Monad] - (meta [type] - (type ["tc" check]))) - (luxc ["&" base] - (lang analysis))) - -(def: #export (with-unknown-type action) - (All [a] (-> (Meta Analysis) (Meta [Type Analysis]))) - (do Monad - [[var-id var-type] (&;with-type-env - tc;create) - analysis (&;with-expected-type var-type - action) - analysis-type (&;with-type-env - (tc;clean var-id var-type)) - _ (&;with-type-env - (tc;delete var-id))] - (wrap [analysis-type analysis]))) - -(def: #export (with-var body) - (All [a] (-> (-> [Nat Type] (Meta a)) (Meta a))) - (do Monad - [[id var] (&;with-type-env - tc;create) - output (body [id var]) - _ (&;with-type-env - (tc;delete id))] - (wrap output))) - -(def: #export (variant-out-of-bounds-error type size tag) - (All [a] (-> Type Nat Nat (Meta a))) - (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n" - " Tag: " (%i (nat-to-int tag)) "\n" - "Size: " (%i (nat-to-int size)) "\n" - "Type: " (%type type)))) diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux deleted file mode 100644 index 3d2da6326..000000000 --- a/new-luxc/source/luxc/analyser/function.lux +++ /dev/null @@ -1,111 +0,0 @@ -(;module: - lux - (lux (control monad - ["ex" exception #+ exception:]) - (data [maybe] - [text] - text/format - (coll [list "list/" Fold Monoid Monad])) - [meta] - (meta [code] - [type] - (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis] - [";L" variable #+ Variable]) - ["&;" scope] - (analyser ["&;" common] - ["&;" inference]))) - -(exception: #export Invalid-Function-Type) -(exception: #export Cannot-Apply-Function) - -## [Analysers] -(def: #export (analyse-function analyse func-name arg-name body) - (-> &;Analyser Text Text Code (Meta Analysis)) - (do meta;Monad - [functionT meta;expected-type] - (loop [expectedT functionT] - (&;with-stacked-errors - (function [_] (Invalid-Function-Type (%type expectedT))) - (case expectedT - (#;Named name unnamedT) - (recur unnamedT) - - (#;Apply argT funT) - (case (type;apply (list argT) funT) - (#;Some value) - (recur value) - - #;None - (&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT)))) - - (#;UnivQ _) - (do @ - [[var-id var] (&;with-type-env - tc;existential)] - (recur (maybe;assume (type;apply (list var) expectedT)))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (recur (maybe;assume (type;apply (list var) expectedT))))) - - (#;Var id) - (do @ - [? (&;with-type-env - (tc;concrete? id))] - (if ? - (do @ - [expectedT' (&;with-type-env - (tc;read id))] - (recur expectedT')) - ## Inference - (&common;with-var - (function [[input-id inputT]] - (&common;with-var - (function [[output-id outputT]] - (do @ - [#let [funT (#;Function inputT outputT)] - funA (recur funT) - funT' (&;with-type-env - (tc;clean output-id funT)) - concrete-input? (&;with-type-env - (tc;concrete? input-id)) - funT'' (if concrete-input? - (&;with-type-env - (tc;clean input-id funT')) - (wrap (type;univ-q +1 (&inference;replace-var input-id +1 funT')))) - _ (&;with-type-env - (tc;check expectedT funT''))] - (wrap funA)) - )))))) - - (#;Function inputT outputT) - (<| (:: @ map (function [[scope bodyA]] - (` ("lux function" [(~@ (list/map code;int (variableL;environment scope)))] - (~ bodyA))))) - &;with-scope - ## Functions have access not only to their argument, but - ## also to themselves, through a local variable. - (&scope;with-local [func-name expectedT]) - (&scope;with-local [arg-name inputT]) - (&;with-expected-type outputT) - (analyse body)) - - _ - (&;fail "") - ))))) - -(def: #export (analyse-apply analyse funcT funcA args) - (-> &;Analyser Type Analysis (List Code) (Meta Analysis)) - (&;with-stacked-errors - (function [_] - (Cannot-Apply-Function (format " Function: " (%type funcT) "\n" - "Arguments: " (|> args (list/map %code) (text;join-with " "))))) - (do meta;Monad - [expected meta;expected-type - [applyT argsA] (&inference;apply-function analyse funcT args) - _ (&;with-type-env - (tc;check expected applyT))] - (wrap (la;apply argsA funcA))))) diff --git a/new-luxc/source/luxc/analyser/inference.lux b/new-luxc/source/luxc/analyser/inference.lux deleted file mode 100644 index 049abec28..000000000 --- a/new-luxc/source/luxc/analyser/inference.lux +++ /dev/null @@ -1,228 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [maybe] - [text] - text/format - (coll [list "list/" Functor])) - [meta #+ Monad] - (meta [type] - (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis]) - (analyser ["&;" common]))) - -(exception: #export Cannot-Infer) -(exception: #export Cannot-Infer-Argument) -(exception: #export Smaller-Variant-Than-Expected) - -## When doing inference, type-variables often need to be created in -## order to figure out which types are present in the expression being -## inferred. -## If a type-variable never gets bound/resolved to a type, then that -## means the expression can be generalized through universal -## quantification. -## When that happens, the type-variable must be replaced by an -## argument to the universally-quantified type. -(def: #export (replace-var var-id bound-idx type) - (-> Nat Nat Type Type) - (case type - (#;Primitive name params) - (#;Primitive name (list/map (replace-var var-id bound-idx) params)) - - (^template [] - ( left right) - ( (replace-var var-id bound-idx left) - (replace-var var-id bound-idx right))) - ([#;Sum] - [#;Product] - [#;Function] - [#;Apply]) - - (#;Var id) - (if (n.= var-id id) - (#;Bound bound-idx) - type) - - (^template [] - ( env quantified) - ( (list/map (replace-var var-id bound-idx) env) - (replace-var var-id (n.+ +2 bound-idx) quantified))) - ([#;UnivQ] - [#;ExQ]) - - _ - type)) - -(def: (replace-bound bound-idx replacementT type) - (-> Nat Type Type Type) - (case type - (#;Primitive name params) - (#;Primitive name (list/map (replace-bound bound-idx replacementT) params)) - - (^template [] - ( left right) - ( (replace-bound bound-idx replacementT left) - (replace-bound bound-idx replacementT right))) - ([#;Sum] - [#;Product] - [#;Function] - [#;Apply]) - - (#;Bound idx) - (if (n.= bound-idx idx) - replacementT - type) - - (^template [] - ( env quantified) - ( (list/map (replace-bound bound-idx replacementT) env) - (replace-bound (n.+ +2 bound-idx) replacementT quantified))) - ([#;UnivQ] - [#;ExQ]) - - _ - type)) - -## Type-inference works by applying some (potentially quantified) type -## to a sequence of values. -## Function types are used for this, although inference is not always -## done for function application (alternative uses may be records and -## tagged variants). -## But, so long as the type being used for the inference can be trated -## as a function type, this method of inference should work. -(def: #export (apply-function analyse funcT args) - (-> &;Analyser Type (List Code) (Meta [Type (List Analysis)])) - (case args - #;Nil - (:: Monad wrap [funcT (list)]) - - (#;Cons argC args') - (case funcT - (#;Named name unnamedT) - (apply-function analyse unnamedT args) - - (#;UnivQ _) - (&common;with-var - (function [[var-id varT]] - (do Monad - [[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) funcT)) args)] - (do @ - [? (&;with-type-env - (tc;bound? var-id)) - ## Quantify over the type if genericity/parametricity - ## is discovered. - outputT' (if ? - (&;with-type-env - (tc;clean var-id outputT)) - (wrap (type;univ-q +1 (replace-var var-id +1 outputT))))] - (wrap [outputT' argsA]))))) - - (#;ExQ _) - (do Monad - [[ex-id exT] (&;with-type-env - tc;existential)] - (apply-function analyse (maybe;assume (type;apply (list exT) funcT)) args)) - - ## Arguments are inferred back-to-front because, by convention, - ## Lux functions take the most important arguments *last*, which - ## means that the most information for doing proper inference is - ## located in the last arguments to a function call. - ## By inferring back-to-front, a lot of type-annotations can be - ## avoided in Lux code, since the inference algorithm can piece - ## things together more easily. - (#;Function inputT outputT) - (do Monad - [[outputT' args'A] (apply-function analyse outputT args') - argA (&;with-stacked-errors - (function [_] (Cannot-Infer-Argument - (format "Inferred Type: " (%type inputT) "\n" - " Argument: " (%code argC)))) - (&;with-expected-type inputT - (analyse argC)))] - (wrap [outputT' (list& argA args'A)])) - - _ - (&;throw Cannot-Infer (format "Inference Type: " (%type funcT) - " Arguments: " (|> args (list/map %code) (text;join-with " "))))) - )) - -## Turns a record type into the kind of function type suitable for inference. -(def: #export (record type) - (-> Type (Meta Type)) - (case type - (#;Named name unnamedT) - (do Monad - [unnamedT+ (record unnamedT)] - (wrap unnamedT+)) - - (^template [] - ( env bodyT) - (do Monad - [bodyT+ (record bodyT)] - (wrap ( env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) - - (#;Product _) - (:: Monad wrap (type;function (type;flatten-tuple type) type)) - - _ - (&;fail (format "Not a record type: " (%type type))))) - -## Turns a variant type into the kind of function type suitable for inference. -(def: #export (variant tag expected-size type) - (-> Nat Nat Type (Meta Type)) - (loop [depth +0 - currentT type] - (case currentT - (#;Named name unnamedT) - (do Monad - [unnamedT+ (recur depth unnamedT)] - (wrap unnamedT+)) - - (^template [] - ( env bodyT) - (do Monad - [bodyT+ (recur (n.inc depth) bodyT)] - (wrap ( env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) - - (#;Sum _) - (let [cases (type;flatten-variant currentT) - actual-size (list;size cases) - boundary (n.dec expected-size)] - (cond (or (n.= expected-size actual-size) - (and (n.> expected-size actual-size) - (n.< boundary tag))) - (case (list;nth tag cases) - (#;Some caseT) - (:: Monad wrap (if (n.= +0 depth) - (type;function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] - (type;function (list (replace! caseT)) - (replace! currentT))))) - - #;None - (&common;variant-out-of-bounds-error type expected-size tag)) - - (n.< expected-size actual-size) - (&;throw Smaller-Variant-Than-Expected - (format "Expected: " (%i (nat-to-int expected-size)) "\n" - " Actual: " (%i (nat-to-int actual-size)))) - - (n.= boundary tag) - (let [caseT (type;variant (list;drop boundary cases))] - (:: Monad wrap (if (n.= +0 depth) - (type;function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] - (type;function (list (replace! caseT)) - (replace! currentT)))))) - - ## else - (&common;variant-out-of-bounds-error type expected-size tag))) - - _ - (&;fail (format "Not a variant type: " (%type type)))))) diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux deleted file mode 100644 index c7f7243fd..000000000 --- a/new-luxc/source/luxc/analyser/primitive.lux +++ /dev/null @@ -1,34 +0,0 @@ -(;module: - lux - (lux (control monad) - [meta] - (meta [code] - (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis]))) - -## [Analysers] -(do-template [ ] - [(def: #export ( value) - (-> (Meta Analysis)) - (do meta;Monad - [expected meta;expected-type - _ (&;with-type-env - (tc;check expected ))] - (wrap ( value))))] - - [analyse-bool Bool code;bool] - [analyse-nat Nat code;nat] - [analyse-int Int code;int] - [analyse-deg Deg code;deg] - [analyse-frac Frac code;frac] - [analyse-text Text code;text] - ) - -(def: #export analyse-unit - (Meta Analysis) - (do meta;Monad - [expected meta;expected-type - _ (&;with-type-env - (tc;check expected Unit))] - (wrap (` [])))) diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux deleted file mode 100644 index 225fb7b23..000000000 --- a/new-luxc/source/luxc/analyser/procedure.lux +++ /dev/null @@ -1,23 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (data [maybe] - [text] - text/format - (coll [dict]))) - (luxc ["&" base] - (lang ["la" analysis])) - (. ["./;" common] - ["./;" host])) - -(def: procedures - ./common;Bundle - (|> ./common;procedures - (dict;merge ./host;procedures))) - -(def: #export (analyse-procedure analyse eval proc-name proc-args) - (-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis)) - (<| (maybe;default (&;fail (format "Unknown procedure: " (%t proc-name)))) - (do maybe;Monad - [proc (dict;get proc-name procedures)] - (wrap (proc analyse eval proc-args))))) diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux deleted file mode 100644 index 0fad41958..000000000 --- a/new-luxc/source/luxc/analyser/procedure/common.lux +++ /dev/null @@ -1,418 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (concurrency ["A" atom]) - (data [text] - text/format - (coll [list "list/" Functor] - [array] - [dict #+ Dict])) - [meta] - (meta [code] - (type ["tc" check])) - [io]) - (luxc ["&" base] - (lang ["la" analysis]) - (analyser ["&;" common] - [";A" function] - [";A" case] - [";A" type]))) - -## [Utils] -(type: #export Proc - (-> &;Analyser &;Eval (List Code) (Meta la;Analysis))) - -(type: #export Bundle - (Dict Text Proc)) - -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict;put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict;entries - (list/map (function [[key val]] [(format prefix " " key) val])) - (dict;from-list text;Hash))) - -(def: #export (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format "Wrong arity for " (%t proc) "\n" - "Expected: " (|> expected nat-to-int %i) "\n" - " Actual: " (|> actual nat-to-int %i))) - -(def: (simple proc input-types output-type) - (-> Text (List Type) Type Proc) - (let [num-expected (list;size input-types)] - (function [analyse eval args] - (let [num-actual (list;size args)] - (if (n.= num-expected num-actual) - (do meta;Monad - [argsA (monad;map @ - (function [[argT argC]] - (&;with-expected-type argT - (analyse argC))) - (list;zip2 input-types args)) - expected meta;expected-type - _ (&;with-type-env - (tc;check expected output-type))] - (wrap (la;procedure proc argsA))) - (&;fail (wrong-arity proc num-expected num-actual))))))) - -(def: #export (nullary valueT proc) - (-> Type Text Proc) - (simple proc (list) valueT)) - -(def: #export (unary inputT outputT proc) - (-> Type Type Text Proc) - (simple proc (list inputT) outputT)) - -(def: #export (binary subjectT paramT outputT proc) - (-> Type Type Type Text Proc) - (simple proc (list subjectT paramT) outputT)) - -(def: #export (trinary subjectT param0T param1T outputT proc) - (-> Type Type Type Type Text Proc) - (simple proc (list subjectT param0T param1T) outputT)) - -## [Analysers] -## "lux is" represents reference/pointer equality. -(def: (lux-is proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((binary varT varT Bool proc) - analyse eval args))))) - -## "lux try" provides a simple way to interact with the host platform's -## error-handling facilities. -(def: (lux-try proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list opC)) - (do meta;Monad - [opA (&;with-expected-type (type (io;IO varT)) - (analyse opC)) - outputT (&;with-type-env - (tc;clean var-id (type (Either Text varT)))) - expected meta;expected-type - _ (&;with-type-env - (tc;check expected outputT))] - (wrap (la;procedure proc (list opA)))) - - _ - (&;fail (wrong-arity proc +1 (list;size args)))))))) - -(def: (lux//function proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list [_ (#;Symbol ["" func-name])] - [_ (#;Symbol ["" arg-name])] - body)) - (functionA;analyse-function analyse func-name arg-name body) - - _ - (&;fail (wrong-arity proc +3 (list;size args)))))))) - -(def: (lux//case proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list input [_ (#;Record branches)])) - (caseA;analyse-case analyse input branches) - - _ - (&;fail (wrong-arity proc +2 (list;size args)))))))) - -(do-template [ ] - [(def: ( proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list typeC valueC)) - ( analyse eval typeC valueC) - - _ - (&;fail (wrong-arity proc +2 (list;size args))))))))] - - [lux//check typeA;analyse-check] - [lux//coerce typeA;analyse-coerce]) - -(def: (lux//check//type proc) - (-> Text Proc) - (function [analyse eval args] - (case args - (^ (list valueC)) - (do meta;Monad - [valueA (&;with-expected-type Type - (analyse valueC)) - expected meta;expected-type - _ (&;with-type-env - (tc;check expected Type))] - (wrap valueA)) - - _ - (&;fail (wrong-arity proc +1 (list;size args)))))) - -(def: lux-procs - Bundle - (|> (dict;new text;Hash) - (install "is" lux-is) - (install "try" lux-try) - (install "function" lux//function) - (install "case" lux//case) - (install "check" lux//check) - (install "coerce" lux//coerce) - (install "check type" lux//check//type))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict;new text;Hash) - (install "log" (unary Text Unit)) - (install "error" (unary Text Bottom)) - (install "exit" (unary Nat Bottom)) - (install "current-time" (nullary Int))))) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict;new text;Hash) - (install "count" (unary Nat Nat)) - (install "and" (binary Nat Nat Nat)) - (install "or" (binary Nat Nat Nat)) - (install "xor" (binary Nat Nat Nat)) - (install "shift-left" (binary Nat Nat Nat)) - (install "unsigned-shift-right" (binary Nat Nat Nat)) - (install "shift-right" (binary Int Nat Int)) - ))) - -(def: nat-procs - Bundle - (<| (prefix "nat") - (|> (dict;new text;Hash) - (install "+" (binary Nat Nat Nat)) - (install "-" (binary Nat Nat Nat)) - (install "*" (binary Nat Nat Nat)) - (install "/" (binary Nat Nat Nat)) - (install "%" (binary Nat Nat Nat)) - (install "=" (binary Nat Nat Bool)) - (install "<" (binary Nat Nat Bool)) - (install "min" (nullary Nat)) - (install "max" (nullary Nat)) - (install "to-int" (unary Nat Int)) - (install "to-text" (unary Nat Text))))) - -(def: int-procs - Bundle - (<| (prefix "int") - (|> (dict;new text;Hash) - (install "+" (binary Int Int Int)) - (install "-" (binary Int Int Int)) - (install "*" (binary Int Int Int)) - (install "/" (binary Int Int Int)) - (install "%" (binary Int Int Int)) - (install "=" (binary Int Int Bool)) - (install "<" (binary Int Int Bool)) - (install "min" (nullary Int)) - (install "max" (nullary Int)) - (install "to-nat" (unary Int Nat)) - (install "to-frac" (unary Int Frac))))) - -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict;new text;Hash) - (install "+" (binary Deg Deg Deg)) - (install "-" (binary Deg Deg Deg)) - (install "*" (binary Deg Deg Deg)) - (install "/" (binary Deg Deg Deg)) - (install "%" (binary Deg Deg Deg)) - (install "=" (binary Deg Deg Bool)) - (install "<" (binary Deg Deg Bool)) - (install "scale" (binary Deg Nat Deg)) - (install "reciprocal" (binary Deg Nat Deg)) - (install "min" (nullary Deg)) - (install "max" (nullary Deg)) - (install "to-frac" (unary Deg Frac))))) - -(def: frac-procs - Bundle - (<| (prefix "frac") - (|> (dict;new text;Hash) - (install "+" (binary Frac Frac Frac)) - (install "-" (binary Frac Frac Frac)) - (install "*" (binary Frac Frac Frac)) - (install "/" (binary Frac Frac Frac)) - (install "%" (binary Frac Frac Frac)) - (install "=" (binary Frac Frac Bool)) - (install "<" (binary Frac Frac Bool)) - (install "smallest" (nullary Frac)) - (install "min" (nullary Frac)) - (install "max" (nullary Frac)) - (install "not-a-number" (nullary Frac)) - (install "positive-infinity" (nullary Frac)) - (install "negative-infinity" (nullary Frac)) - (install "to-deg" (unary Frac Deg)) - (install "to-int" (unary Frac Int)) - (install "encode" (unary Frac Text)) - (install "decode" (unary Text (type (Maybe Frac))))))) - -(def: text-procs - Bundle - (<| (prefix "text") - (|> (dict;new text;Hash) - (install "=" (binary Text Text Bool)) - (install "<" (binary Text Text Bool)) - (install "prepend" (binary Text Text Text)) - (install "index" (trinary Text Text Nat (type (Maybe Nat)))) - (install "size" (unary Text Nat)) - (install "hash" (unary Text Nat)) - (install "replace-once" (trinary Text Text Text Text)) - (install "replace-all" (trinary Text Text Text Text)) - (install "char" (binary Text Nat Nat)) - (install "clip" (trinary Text Nat Nat Text)) - ))) - -(def: (array-get proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((binary Nat (type (Array varT)) varT proc) - analyse eval args))))) - -(def: (array-put proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc) - analyse eval args))))) - -(def: (array-remove proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((binary Nat (type (Array varT)) (type (Array varT)) proc) - analyse eval args))))) - -(def: array-procs - Bundle - (<| (prefix "array") - (|> (dict;new text;Hash) - (install "new" (unary Nat Array)) - (install "get" array-get) - (install "put" array-put) - (install "remove" array-remove) - (install "size" (unary (type (Ex [a] (Array a))) Nat)) - ))) - -(def: math-procs - Bundle - (<| (prefix "math") - (|> (dict;new text;Hash) - (install "cos" (unary Frac Frac)) - (install "sin" (unary Frac Frac)) - (install "tan" (unary Frac Frac)) - (install "acos" (unary Frac Frac)) - (install "asin" (unary Frac Frac)) - (install "atan" (unary Frac Frac)) - (install "cosh" (unary Frac Frac)) - (install "sinh" (unary Frac Frac)) - (install "tanh" (unary Frac Frac)) - (install "exp" (unary Frac Frac)) - (install "log" (unary Frac Frac)) - (install "root2" (unary Frac Frac)) - (install "root3" (unary Frac Frac)) - (install "ceil" (unary Frac Frac)) - (install "floor" (unary Frac Frac)) - (install "round" (unary Frac Frac)) - (install "atan2" (binary Frac Frac Frac)) - (install "pow" (binary Frac Frac Frac)) - ))) - -(def: (atom-new proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list initC)) - (do meta;Monad - [initA (&;with-expected-type varT - (analyse initC)) - outputT (&;with-type-env - (tc;clean var-id (type (A;Atom varT)))) - expected meta;expected-type - _ (&;with-type-env - (tc;check expected outputT))] - (wrap (la;procedure proc (list initA)))) - - _ - (&;fail (wrong-arity proc +1 (list;size args)))))))) - -(def: (atom-read proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((unary (type (A;Atom varT)) varT proc) - analyse eval args))))) - -(def: (atom-compare-and-swap proc) - (-> Text Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - ((trinary varT varT (type (A;Atom varT)) Bool proc) - analyse eval args))))) - -(def: atom-procs - Bundle - (<| (prefix "atom") - (|> (dict;new text;Hash) - (install "new" atom-new) - (install "read" atom-read) - (install "compare-and-swap" atom-compare-and-swap) - ))) - -(def: process-procs - Bundle - (<| (prefix "process") - (|> (dict;new text;Hash) - (install "concurrency-level" (nullary Nat)) - (install "future" (unary (type (io;IO Top)) Unit)) - (install "schedule" (binary Nat (type (io;IO Top)) Unit)) - ))) - -(def: #export procedures - Bundle - (<| (prefix "lux") - (|> (dict;new text;Hash) - (dict;merge lux-procs) - (dict;merge bit-procs) - (dict;merge nat-procs) - (dict;merge int-procs) - (dict;merge deg-procs) - (dict;merge frac-procs) - (dict;merge text-procs) - (dict;merge array-procs) - (dict;merge math-procs) - (dict;merge atom-procs) - (dict;merge process-procs) - (dict;merge io-procs)))) diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux deleted file mode 100644 index 015379a1b..000000000 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ /dev/null @@ -1,1241 +0,0 @@ -(;module: - [lux #- char] - (lux (control [monad #+ do] - ["p" parser] - ["ex" exception #+ exception:]) - (concurrency ["A" atom]) - (data ["e" error] - [maybe] - [product] - [bool "bool/" Eq] - [text "text/" Eq] - (text format - ["l" lexer]) - (coll [list "list/" Fold Functor Monoid] - [array] - [dict #+ Dict])) - [meta "meta/" Monad] - (meta [code] - ["s" syntax] - [type] - (type ["tc" check])) - [host]) - (luxc ["&" base] - ["&;" host] - (lang ["la" analysis]) - (analyser ["&;" common] - ["&;" inference])) - ["@" ../common] - ) - -(def: #export null-class Text "#Null") - -(do-template [ ] - [(def: #export Type (#;Primitive (list)))] - - ## Boxes - [Boolean "java.lang.Boolean"] - [Byte "java.lang.Byte"] - [Short "java.lang.Short"] - [Integer "java.lang.Integer"] - [Long "java.lang.Long"] - [Float "java.lang.Float"] - [Double "java.lang.Double"] - [Character "java.lang.Character"] - [String "java.lang.String"] - - ## Primitives - [boolean "boolean"] - [byte "byte"] - [short "short"] - [int "int"] - [long "long"] - [float "float"] - [double "double"] - [char "char"] - ) - -(def: conversion-procs - @;Bundle - (<| (@;prefix "convert") - (|> (dict;new text;Hash) - (@;install "double-to-float" (@;unary Double Float)) - (@;install "double-to-int" (@;unary Double Integer)) - (@;install "double-to-long" (@;unary Double Long)) - (@;install "float-to-double" (@;unary Float Double)) - (@;install "float-to-int" (@;unary Float Integer)) - (@;install "float-to-long" (@;unary Float Long)) - (@;install "int-to-byte" (@;unary Integer Byte)) - (@;install "int-to-char" (@;unary Integer Character)) - (@;install "int-to-double" (@;unary Integer Double)) - (@;install "int-to-float" (@;unary Integer Float)) - (@;install "int-to-long" (@;unary Integer Long)) - (@;install "int-to-short" (@;unary Integer Short)) - (@;install "long-to-double" (@;unary Long Double)) - (@;install "long-to-float" (@;unary Long Float)) - (@;install "long-to-int" (@;unary Long Integer)) - (@;install "long-to-short" (@;unary Long Short)) - (@;install "long-to-byte" (@;unary Long Byte)) - (@;install "char-to-byte" (@;unary Character Byte)) - (@;install "char-to-short" (@;unary Character Short)) - (@;install "char-to-int" (@;unary Character Integer)) - (@;install "char-to-long" (@;unary Character Long)) - (@;install "byte-to-long" (@;unary Byte Long)) - (@;install "short-to-long" (@;unary Short Long)) - ))) - -(do-template [ ] - [(def: - @;Bundle - (<| (@;prefix ) - (|> (dict;new text;Hash) - (@;install "+" (@;binary )) - (@;install "-" (@;binary )) - (@;install "*" (@;binary )) - (@;install "/" (@;binary )) - (@;install "%" (@;binary )) - (@;install "=" (@;binary Boolean)) - (@;install "<" (@;binary Boolean)) - (@;install "and" (@;binary )) - (@;install "or" (@;binary )) - (@;install "xor" (@;binary )) - (@;install "shl" (@;binary Integer )) - (@;install "shr" (@;binary Integer )) - (@;install "ushr" (@;binary Integer )) - )))] - - [int-procs "int" Integer] - [long-procs "long" Long] - ) - -(do-template [ ] - [(def: - @;Bundle - (<| (@;prefix ) - (|> (dict;new text;Hash) - (@;install "+" (@;binary )) - (@;install "-" (@;binary )) - (@;install "*" (@;binary )) - (@;install "/" (@;binary )) - (@;install "%" (@;binary )) - (@;install "=" (@;binary Boolean)) - (@;install "<" (@;binary Boolean)) - )))] - - [float-procs "float" Float] - [double-procs "double" Double] - ) - -(def: char-procs - @;Bundle - (<| (@;prefix "char") - (|> (dict;new text;Hash) - (@;install "=" (@;binary Character Character Boolean)) - (@;install "<" (@;binary Character Character Boolean)) - ))) - -(def: #export boxes - (Dict Text Text) - (|> (list ["boolean" "java.lang.Boolean"] - ["byte" "java.lang.Byte"] - ["short" "java.lang.Short"] - ["int" "java.lang.Integer"] - ["long" "java.lang.Long"] - ["float" "java.lang.Float"] - ["double" "java.lang.Double"] - ["char" "java.lang.Character"]) - (dict;from-list text;Hash))) - -(def: (array-length proc) - (-> Text @;Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list arrayC)) - (do meta;Monad - [arrayA (&;with-expected-type (type (Array varT)) - (analyse arrayC)) - _ (&;infer Nat)] - (wrap (la;procedure proc (list arrayA)))) - - _ - (&;fail (@;wrong-arity proc +1 (list;size args)))))))) - -(def: (invalid-array-type arrayT) - (-> Type Text) - (format "Invalid type for array: " (%type arrayT))) - -(def: (array-new proc) - (-> Text @;Proc) - (function [analyse eval args] - (case args - (^ (list lengthC)) - (do meta;Monad - [lengthA (&;with-expected-type Nat - (analyse lengthC)) - expectedT meta;expected-type - [level elem-class] (: (Meta [Nat Text]) - (loop [analysisT expectedT - level +0] - (case analysisT - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) - (recur outputT level) - - #;None - (&;fail (invalid-array-type expectedT))) - - (^ (#;Primitive "#Array" (list elemT))) - (recur elemT (n.inc level)) - - (#;Primitive class _) - (wrap [level class]) - - _ - (&;fail (invalid-array-type expectedT))))) - _ (&;assert "Must have at least 1 level of nesting in array type." - (n.> +0 level))] - (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA)))) - - _ - (&;fail (@;wrong-arity proc +1 (list;size args)))))) - -(exception: #export Not-Object-Type) - -(def: (check-jvm objectT) - (-> Type (Meta Text)) - (case objectT - (#;Primitive name _) - (meta/wrap name) - - (#;Named name unnamed) - (check-jvm unnamed) - - (#;Var id) - (meta/wrap "java.lang.Object") - - (^template [] - ( env unquantified) - (check-jvm unquantified)) - ([#;UnivQ] - [#;ExQ]) - - (#;Apply inputT funcT) - (case (type;apply (list inputT) funcT) - (#;Some outputT) - (check-jvm outputT) - - #;None - (&;throw Not-Object-Type (%type objectT))) - - _ - (&;throw Not-Object-Type (%type objectT)))) - -(def: (check-object objectT) - (-> Type (Meta Text)) - (do meta;Monad - [name (check-jvm objectT)] - (if (dict;contains? name boxes) - (&;fail (format "Primitives are not objects: " name)) - (:: meta;Monad wrap name)))) - -(def: (box-array-element-type elemT) - (-> Type (Meta [Type Text])) - (do meta;Monad - [] - (case elemT - (#;Primitive name #;Nil) - (let [boxed-name (|> (dict;get name boxes) - (maybe;default name))] - (wrap [(#;Primitive boxed-name #;Nil) - boxed-name])) - - (#;Primitive name _) - (if (dict;contains? name boxes) - (&;fail (format "Primitives cannot be parameterized: " name)) - (:: meta;Monad wrap [elemT name])) - - _ - (&;fail (format "Invalid type for array element: " (%type elemT)))))) - -(def: (array-read proc) - (-> Text @;Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list arrayC idxC)) - (do meta;Monad - [arrayA (&;with-expected-type (type (Array varT)) - (analyse arrayC)) - elemT (&;with-type-env - (tc;read var-id)) - [elemT elem-class] (box-array-element-type elemT) - idxA (&;with-expected-type Nat - (analyse idxC)) - _ (&;infer elemT)] - (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA)))) - - _ - (&;fail (@;wrong-arity proc +2 (list;size args)))))))) - -(def: (array-write proc) - (-> Text @;Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list arrayC idxC valueC)) - (do meta;Monad - [arrayA (&;with-expected-type (type (Array varT)) - (analyse arrayC)) - elemT (&;with-type-env - (tc;read var-id)) - [valueT elem-class] (box-array-element-type elemT) - idxA (&;with-expected-type Nat - (analyse idxC)) - valueA (&;with-expected-type valueT - (analyse valueC)) - _ (&;infer (type (Array elemT)))] - (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA)))) - - _ - (&;fail (@;wrong-arity proc +3 (list;size args)))))))) - -(def: array-procs - @;Bundle - (<| (@;prefix "array") - (|> (dict;new text;Hash) - (@;install "length" array-length) - (@;install "new" array-new) - (@;install "read" array-read) - (@;install "write" array-write) - ))) - -(def: (object-null proc) - (-> Text @;Proc) - (function [analyse eval args] - (case args - (^ (list)) - (do meta;Monad - [expectedT meta;expected-type - _ (check-object expectedT)] - (wrap (la;procedure proc (list)))) - - _ - (&;fail (@;wrong-arity proc +0 (list;size args)))))) - -(def: (object-null? proc) - (-> Text @;Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list objectC)) - (do meta;Monad - [objectA (&;with-expected-type varT - (analyse objectC)) - objectT (&;with-type-env - (tc;read var-id)) - _ (check-object objectT) - _ (&;infer Bool)] - (wrap (la;procedure proc (list objectA)))) - - _ - (&;fail (@;wrong-arity proc +1 (list;size args)))))))) - -(def: (object-synchronized proc) - (-> Text @;Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list monitorC exprC)) - (do meta;Monad - [monitorA (&;with-expected-type varT - (analyse monitorC)) - monitorT (&;with-type-env - (tc;read var-id)) - _ (check-object monitorT) - exprA (analyse exprC)] - (wrap (la;procedure proc (list monitorA exprA)))) - - _ - (&;fail (@;wrong-arity proc +2 (list;size args)))))))) - -(host;import java.lang.Object - (equals [Object] boolean)) - -(host;import java.lang.ClassLoader) - -(host;import #long java.lang.reflect.Type - (getTypeName [] String)) - -(host;import java.lang.reflect.GenericArrayType - (getGenericComponentType [] java.lang.reflect.Type)) - -(host;import java.lang.reflect.ParameterizedType - (getRawType [] java.lang.reflect.Type) - (getActualTypeArguments [] (Array java.lang.reflect.Type))) - -(host;import (java.lang.reflect.TypeVariable d) - (getName [] String) - (getBounds [] (Array java.lang.reflect.Type))) - -(host;import (java.lang.reflect.WildcardType d) - (getLowerBounds [] (Array java.lang.reflect.Type)) - (getUpperBounds [] (Array java.lang.reflect.Type))) - -(host;import java.lang.reflect.Modifier - (#static isStatic [int] boolean) - (#static isFinal [int] boolean) - (#static isInterface [int] boolean) - (#static isAbstract [int] boolean)) - -(host;import java.lang.reflect.Field - (getDeclaringClass [] (java.lang.Class Object)) - (getModifiers [] int) - (getGenericType [] java.lang.reflect.Type)) - -(host;import java.lang.reflect.Method - (getName [] String) - (getModifiers [] int) - (getDeclaringClass [] (Class Object)) - (getTypeParameters [] (Array (TypeVariable Method))) - (getGenericParameterTypes [] (Array java.lang.reflect.Type)) - (getGenericReturnType [] java.lang.reflect.Type) - (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) - -(host;import (java.lang.reflect.Constructor c) - (getModifiers [] int) - (getDeclaringClass [] (Class c)) - (getTypeParameters [] (Array (TypeVariable (Constructor c)))) - (getGenericParameterTypes [] (Array java.lang.reflect.Type)) - (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) - -(host;import (java.lang.Class c) - (getName [] String) - (getModifiers [] int) - (#static forName [String boolean ClassLoader] #try (Class Object)) - (isAssignableFrom [(Class Object)] boolean) - (getTypeParameters [] (Array (TypeVariable (Class c)))) - (getGenericInterfaces [] (Array java.lang.reflect.Type)) - (getGenericSuperclass [] java.lang.reflect.Type) - (getDeclaredField [String] #try Field) - (getConstructors [] (Array (Constructor Object))) - (getDeclaredMethods [] (Array Method))) - -(def: (load-class name) - (-> Text (Meta (Class Object))) - (do meta;Monad - [class-loader &host;class-loader] - (case (Class.forName [name false class-loader]) - (#e;Success [class]) - (wrap class) - - (#e;Error error) - (&;fail (format "Unknown class: " name))))) - -(def: (sub-class? super sub) - (-> Text Text (Meta Bool)) - (do meta;Monad - [super (load-class super) - sub (load-class sub)] - (wrap (Class.isAssignableFrom [sub] super)))) - -(exception: #export Not-Throwable) - -(def: (object-throw proc) - (-> Text @;Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list exceptionC)) - (do meta;Monad - [exceptionA (&;with-expected-type varT - (analyse exceptionC)) - exceptionT (&;with-type-env - (tc;read var-id)) - exception-class (check-object exceptionT) - ? (sub-class? "java.lang.Throwable" exception-class) - _ (: (Meta Unit) - (if ? - (wrap []) - (&;throw Not-Throwable exception-class))) - _ (&;infer Bottom)] - (wrap (la;procedure proc (list exceptionA)))) - - _ - (&;fail (@;wrong-arity proc +1 (list;size args)))))))) - -(def: (object-class proc) - (-> Text @;Proc) - (function [analyse eval args] - (case args - (^ (list classC)) - (case classC - [_ (#;Text class)] - (do meta;Monad - [_ (load-class class) - _ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))] - (wrap (la;procedure proc (list (code;text class))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))) - - _ - (&;fail (@;wrong-arity proc +1 (list;size args)))))) - -(exception: #export Cannot-Be-Instance) - -(def: (object-instance? proc) - (-> Text @;Proc) - (function [analyse eval args] - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list classC objectC)) - (case classC - [_ (#;Text class)] - (do meta;Monad - [objectA (&;with-expected-type varT - (analyse objectC)) - objectT (&;with-type-env - (tc;read var-id)) - object-class (check-object objectT) - ? (sub-class? class object-class)] - (if ? - (do @ - [_ (&;infer Bool)] - (wrap (la;procedure proc (list (code;text class))))) - (&;throw Cannot-Be-Instance (format object-class " !<= " class)))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))) - - _ - (&;fail (@;wrong-arity proc +2 (list;size args)))))))) - -(def: object-procs - @;Bundle - (<| (@;prefix "object") - (|> (dict;new text;Hash) - (@;install "null" object-null) - (@;install "null?" object-null?) - (@;install "synchronized" object-synchronized) - (@;install "throw" object-throw) - (@;install "class" object-class) - (@;install "instance?" object-instance?) - ))) - -(exception: #export Final-Field) - -(exception: #export Cannot-Convert-To-Class) -(exception: #export Cannot-Convert-To-Parameter) -(exception: #export Cannot-Convert-To-Lux-Type) -(exception: #export Cannot-Cast-To-Primitive) -(exception: #export JVM-Type-Is-Not-Class) - -(def: type-descriptor - (-> java.lang.reflect.Type Text) - (java.lang.reflect.Type.getTypeName [])) - -(def: (java-type-to-class type) - (-> java.lang.reflect.Type (Meta Text)) - (cond (host;instance? Class type) - (meta/wrap (Class.getName [] (:! Class type))) - - (host;instance? ParameterizedType type) - (java-type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type))) - - ## else - (&;throw Cannot-Convert-To-Class (type-descriptor type)))) - -(exception: #export Unknown-Type-Var) - -(type: Mappings - (Dict Text Type)) - -(def: fresh-mappings Mappings (dict;new text;Hash)) - -(def: (java-type-to-lux-type mappings java-type) - (-> Mappings java.lang.reflect.Type (Meta Type)) - (cond (host;instance? TypeVariable java-type) - (let [var-name (TypeVariable.getName [] (:! TypeVariable java-type))] - (case (dict;get var-name mappings) - (#;Some var-type) - (meta/wrap var-type) - - #;None - (&;throw Unknown-Type-Var var-name))) - - (host;instance? WildcardType java-type) - (let [java-type (:! WildcardType java-type)] - (case [(array;read +0 (WildcardType.getUpperBounds [] java-type)) - (array;read +0 (WildcardType.getLowerBounds [] java-type))] - (^or [(#;Some bound) _] [_ (#;Some bound)]) - (java-type-to-lux-type mappings bound) - - _ - (meta/wrap Top))) - - (host;instance? Class java-type) - (let [java-type (:! (Class Object) java-type) - class-name (Class.getName [] java-type)] - (meta/wrap (case (array;size (Class.getTypeParameters [] java-type)) - +0 - (#;Primitive class-name (list)) - - arity - (|> (list;n.range +0 (n.dec arity)) - list;reverse - (list/map (|>. (n.* +2) n.inc #;Bound)) - (#;Primitive class-name) - (type;univ-q arity))))) - - (host;instance? ParameterizedType java-type) - (let [java-type (:! ParameterizedType java-type) - raw (ParameterizedType.getRawType [] java-type)] - (if (host;instance? Class raw) - (do meta;Monad - [paramsT (|> java-type - (ParameterizedType.getActualTypeArguments []) - array;to-list - (monad;map @ (java-type-to-lux-type mappings)))] - (meta/wrap (#;Primitive (Class.getName [] (:! (Class Object) raw)) - paramsT))) - (&;throw JVM-Type-Is-Not-Class (type-descriptor raw)))) - - (host;instance? GenericArrayType java-type) - (do meta;Monad - [innerT (|> (:! GenericArrayType java-type) - (GenericArrayType.getGenericComponentType []) - (java-type-to-lux-type mappings))] - (wrap (#;Primitive "#Array" (list innerT)))) - - ## else - (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) - -(type: Direction - #In - #Out) - -(def: (choose direction to from) - (-> Direction Text Text Text) - (case direction - #In to - #Out from)) - -(def: (correspond-type-params class type) - (-> (Class Object) Type (Meta Mappings)) - (case type - (#;Primitive name params) - (let [class-name (Class.getName [] class) - class-params (array;to-list (Class.getTypeParameters [] class))] - (if (text/= class-name name) - (if (n.= (list;size class-params) - (list;size params)) - (meta/wrap (|> params - (list;zip2 (list/map (TypeVariable.getName []) class-params)) - (dict;from-list text;Hash))) - (&;fail (format "Class and host-type parameters do not match: " "class = " class-name " | host type = " name))) - (&;fail (format "Class and host-type names do not match: " "class = " class-name " | host type = " name)))) - - _ - (&;fail (format "Not a host type: " (%type type))))) - -(def: (cast direction to from) - (-> Direction Type Type (Meta [Text Type])) - (do meta;Monad - [to-name (check-jvm to) - from-name (check-jvm from)] - (cond (dict;contains? to-name boxes) - (let [box (maybe;assume (dict;get to-name boxes))] - (if (text/= box from-name) - (wrap [(choose direction to-name from-name) (#;Primitive to-name (list))]) - (&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name)))) - - (dict;contains? from-name boxes) - (let [box (maybe;assume (dict;get from-name boxes))] - (do @ - [[_ castT] (cast direction to (#;Primitive box (list)))] - (wrap [(choose direction to-name from-name) castT]))) - - (text/= to-name from-name) - (wrap [(choose direction to-name from-name) from]) - - (text/= null-class from-name) - (wrap [(choose direction to-name from-name) to]) - - ## else - (do @ - [to-class (load-class to-name) - from-class (load-class from-name) - _ (&;assert (format "Class '" from-name "' is not a sub-class of class '" to-name "'.") - (Class.isAssignableFrom [from-class] to-class)) - candiate-parents (monad;map @ - (function [java-type] - (do @ - [class-name (java-type-to-class java-type) - class (load-class class-name)] - (wrap [java-type (Class.isAssignableFrom [class] to-class)]))) - (list& (Class.getGenericSuperclass [] from-class) - (array;to-list (Class.getGenericInterfaces [] from-class))))] - (case (|> candiate-parents - (list;filter product;right) - (list/map product;left)) - (#;Cons parent _) - (do @ - [mapping (correspond-type-params from-class from) - parentT (java-type-to-lux-type mapping parent) - [_ castT] (cast direction to parentT)] - (wrap [(choose direction to-name from-name) castT])) - - #;Nil - (&;fail (format "No valid path between " (%type from) "and " (%type to) "."))))))) - -(def: (infer-out outputT) - (-> Type (Meta [Text Type])) - (do meta;Monad - [expectedT meta;expected-type - [unboxed castT] (cast #Out expectedT outputT) - _ (&;with-type-env - (tc;check expectedT castT))] - (wrap [unboxed castT]))) - -(def: (find-field class-name field-name) - (-> Text Text (Meta [(Class Object) Field])) - (do meta;Monad - [class (load-class class-name)] - (case (Class.getDeclaredField [field-name] class) - (#e;Success field) - (let [owner (Field.getDeclaringClass [] field)] - (if (is owner class) - (wrap [class field]) - (&;fail (format "Field '" field-name "' does not belong to class '" class-name "'.\n" - "Belongs to '" (Class.getName [] owner) "'.")))) - - (#e;Error _) - (&;fail (format "Unknown field '" field-name "' for class '" class-name "'."))))) - -(def: (static-field class-name field-name) - (-> Text Text (Meta [Type Bool])) - (do meta;Monad - [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field.getModifiers [] fieldJ)]] - (if (Modifier.isStatic [modifiers]) - (let [fieldJT (Field.getGenericType [] fieldJ)] - (do @ - [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] - (wrap [fieldT (Modifier.isFinal [modifiers])]))) - (&;fail (format "Field '" field-name "' of class '" class-name "' is not static."))))) - -(exception: #export Non-Object-Type) - -(def: (virtual-field class-name field-name objectT) - (-> Text Text Type (Meta [Type Bool])) - (do meta;Monad - [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field.getModifiers [] fieldJ)]] - (if (not (Modifier.isStatic [modifiers])) - (do @ - [#let [fieldJT (Field.getGenericType [] fieldJ) - var-names (|> class - (Class.getTypeParameters []) - array;to-list - (list/map (TypeVariable.getName [])))] - mappings (: (Meta Mappings) - (case objectT - (#;Primitive _class-name _class-params) - (do @ - [#let [num-params (list;size _class-params) - num-vars (list;size var-names)] - _ (&;assert (format "Number of paremeters in type does not match expected amount (" (%n num-vars) "): " (%type objectT)) - (n.= num-params num-vars))] - (wrap (|> (list;zip2 var-names _class-params) - (dict;from-list text;Hash)))) - - _ - (&;throw Non-Object-Type (%type objectT)))) - fieldT (java-type-to-lux-type mappings fieldJT)] - (wrap [fieldT (Modifier.isFinal [modifiers])])) - (&;fail (format "Field '" field-name "' of class '" class-name "' is static."))))) - -(def: (analyse-object class analyse sourceC) - (-> Text &;Analyser Code (Meta [Type la;Analysis])) - (<| &common;with-var (function [[var-id varT]]) - (do meta;Monad - [target-class (load-class class) - targetT (java-type-to-lux-type fresh-mappings - (:! java.lang.reflect.Type - target-class)) - sourceA (&;with-expected-type varT - (analyse sourceC)) - sourceT (&;with-type-env - (tc;read var-id)) - [unboxed castT] (cast #Out targetT sourceT) - _ (&;assert (format "Object cannot be a primitive: " unboxed) - (not (dict;contains? unboxed boxes)))] - (wrap [castT sourceA])))) - -(def: (analyse-input analyse targetT sourceC) - (-> &;Analyser Type Code (Meta [Type Text la;Analysis])) - (<| &common;with-var (function [[var-id varT]]) - (do meta;Monad - [sourceA (&;with-expected-type varT - (analyse sourceC)) - sourceT (&;with-type-env - (tc;read var-id)) - [unboxed castT] (cast #In targetT sourceT)] - (wrap [castT unboxed sourceA])))) - -(def: (static-get proc) - (-> Text @;Proc) - (function [analyse eval args] - (case args - (^ (list classC fieldC)) - (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do meta;Monad - [[fieldT final?] (static-field class field) - [unboxed castT] (infer-out fieldT)] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))) - - _ - (&;fail (@;wrong-arity proc +2 (list;size args)))))) - -(def: (static-put proc) - (-> Text @;Proc) - (function [analyse eval args] - (case args - (^ (list classC fieldC valueC)) - (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do meta;Monad - [[fieldT final?] (static-field class field) - _ (&;assert (Final-Field (format class "#" field)) - (not final?)) - [valueT unboxed valueA] (analyse-input analyse fieldT valueC) - _ (&;with-type-env - (tc;check fieldT valueT)) - _ (&;infer Unit)] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed) valueA)))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))) - - _ - (&;fail (@;wrong-arity proc +3 (list;size args)))))) - -(def: (virtual-get proc) - (-> Text @;Proc) - (function [analyse eval args] - (case args - (^ (list classC fieldC objectC)) - (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do meta;Monad - [[objectT objectA] (analyse-object class analyse objectC) - [fieldT final?] (virtual-field class field objectT) - [unboxed castT] (infer-out fieldT)] - (wrap (la;procedure proc (list (code;text class) (code;text field) - (code;text unboxed) objectA)))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))) - - _ - (&;fail (@;wrong-arity proc +3 (list;size args)))))) - -(def: (virtual-put proc) - (-> Text @;Proc) - (function [analyse eval args] - (case args - (^ (list classC fieldC valueC objectC)) - (case [classC fieldC] - [[_ (#;Text class)] [_ (#;Text field)]] - (do meta;Monad - [[objectT objectA] (analyse-object class analyse objectC) - [fieldT final?] (virtual-field class field objectT) - _ (&;assert (Final-Field (format class "#" field)) - (not final?)) - [valueT unboxed valueA] (analyse-input analyse fieldT valueC) - _ (&;with-type-env - (tc;check fieldT valueT)) - _ (&;infer objectT)] - (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA)))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))) - - _ - (&;fail (@;wrong-arity proc +4 (list;size args)))))) - -(def: (java-type-to-parameter type) - (-> java.lang.reflect.Type (Meta Text)) - (cond (host;instance? Class type) - (meta/wrap (Class.getName [] (:! Class type))) - - (host;instance? ParameterizedType type) - (java-type-to-parameter (ParameterizedType.getRawType [] (:! ParameterizedType type))) - - (or (host;instance? TypeVariable type) - (host;instance? WildcardType type)) - (meta/wrap "java.lang.Object") - - (host;instance? GenericArrayType type) - (do meta;Monad - [componentP (java-type-to-parameter (GenericArrayType.getGenericComponentType [] (:! GenericArrayType type)))] - (wrap (format componentP "[]"))) - - ## else - (&;throw Cannot-Convert-To-Parameter (type-descriptor type)))) - -(type: Method-Type - #Static - #Abstract - #Virtual - #Special - #Interface) - -(def: (check-method class method-name method-type arg-classes method) - (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool)) - (do meta;Monad - [parameters (|> (Method.getGenericParameterTypes [] method) - array;to-list - (monad;map @ java-type-to-parameter)) - #let [modifiers (Method.getModifiers [] method)]] - (wrap (and (Object.equals [class] (Method.getDeclaringClass [] method)) - (text/= method-name (Method.getName [] method)) - (case #Static - #Special - (Modifier.isStatic [modifiers]) - - _ - true) - (case method-type - #Special - (not (or (Modifier.isInterface [(Class.getModifiers [] class)]) - (Modifier.isAbstract [modifiers]))) - - _ - true) - (n.= (list;size arg-classes) (list;size parameters)) - (list/fold (function [[expectedJC actualJC] prev] - (and prev - (text/= expectedJC actualJC))) - true - (list;zip2 arg-classes parameters)))))) - -(def: (check-constructor class arg-classes constructor) - (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) - (do meta;Monad - [parameters (|> (Constructor.getGenericParameterTypes [] constructor) - array;to-list - (monad;map @ java-type-to-parameter))] - (wrap (and (Object.equals [class] (Constructor.getDeclaringClass [] constructor)) - (n.= (list;size arg-classes) (list;size parameters)) - (list/fold (function [[expectedJC actualJC] prev] - (and prev - (text/= expectedJC actualJC))) - true - (list;zip2 arg-classes parameters)))))) - -(def: idx-to-bound - (-> Nat Type) - (|>. (n.* +2) n.inc #;Bound)) - -(def: (type-vars amount offset) - (-> Nat Nat (List Type)) - (if (n.= +0 amount) - (list) - (|> (list;n.range offset (|> amount n.dec (n.+ offset))) - (list/map idx-to-bound)))) - -(def: (method-to-type method-type method) - (-> Method-Type Method (Meta [Type (List Type)])) - (let [owner (Method.getDeclaringClass [] method) - owner-name (Class.getName [] owner) - owner-tvars (case method-type - #Static - (list) - - _ - (|> (Class.getTypeParameters [] owner) - array;to-list - (list/map (TypeVariable.getName [])))) - method-tvars (|> (Method.getTypeParameters [] method) - array;to-list - (list/map (TypeVariable.getName []))) - num-owner-tvars (list;size owner-tvars) - num-method-tvars (list;size method-tvars) - all-tvars (list/compose owner-tvars method-tvars) - num-all-tvars (list;size all-tvars) - owner-tvarsT (type-vars num-owner-tvars +0) - method-tvarsT (type-vars num-method-tvars num-owner-tvars) - mappings (: Mappings - (if (list;empty? all-tvars) - fresh-mappings - (|> (list/compose owner-tvarsT method-tvarsT) - list;reverse - (list;zip2 all-tvars) - (dict;from-list text;Hash))))] - (do meta;Monad - [inputsT (|> (Method.getGenericParameterTypes [] method) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - outputT (java-type-to-lux-type mappings (Method.getGenericReturnType [] method)) - exceptionsT (|> (Method.getGenericExceptionTypes [] method) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - #let [methodT (<| (type;univ-q num-all-tvars) - (type;function (case method-type - #Static - inputsT - - _ - (list& (#;Primitive owner-name (list;reverse owner-tvarsT)) - inputsT))) - outputT)]] - (wrap [methodT exceptionsT])))) - -(exception: #export No-Candidate-Method) -(exception: #export Too-Many-Candidate-Methods) - -(def: (methods class-name method-name method-type arg-classes) - (-> Text Text Method-Type (List Text) (Meta [Type (List Type)])) - (do meta;Monad - [class (load-class class-name) - candidates (|> class - (Class.getDeclaredMethods []) - array;to-list - (monad;map @ (function [method] - (do @ - [passes? (check-method class method-name method-type arg-classes method)] - (wrap [passes? method])))))] - (case (list;filter product;left candidates) - #;Nil - (&;throw No-Candidate-Method (format class-name "#" method-name)) - - (#;Cons candidate #;Nil) - (|> candidate product;right (method-to-type method-type)) - - _ - (&;throw Too-Many-Candidate-Methods (format class-name "#" method-name))))) - -(def: (constructor-to-type constructor) - (-> (Constructor Object) (Meta [Type (List Type)])) - (let [owner (Constructor.getDeclaringClass [] constructor) - owner-name (Class.getName [] owner) - owner-tvars (|> (Class.getTypeParameters [] owner) - array;to-list - (list/map (TypeVariable.getName []))) - constructor-tvars (|> (Constructor.getTypeParameters [] constructor) - array;to-list - (list/map (TypeVariable.getName []))) - num-owner-tvars (list;size owner-tvars) - all-tvars (list/compose owner-tvars constructor-tvars) - num-all-tvars (list;size all-tvars) - owner-tvarsT (type-vars num-owner-tvars +0) - constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) - mappings (: Mappings - (if (list;empty? all-tvars) - fresh-mappings - (|> (list/compose owner-tvarsT constructor-tvarsT) - list;reverse - (list;zip2 all-tvars) - (dict;from-list text;Hash))))] - (do meta;Monad - [inputsT (|> (Constructor.getGenericParameterTypes [] constructor) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - exceptionsT (|> (Constructor.getGenericExceptionTypes [] constructor) - array;to-list - (monad;map @ (java-type-to-lux-type mappings))) - #let [objectT (#;Primitive owner-name (list;reverse owner-tvarsT)) - constructorT (<| (type;univ-q num-all-tvars) - (type;function inputsT) - objectT)]] - (wrap [constructorT exceptionsT])))) - -(exception: #export No-Candidate-Constructor) -(exception: #export Too-Many-Candidate-Constructors) - -(def: (constructor-methods class-name arg-classes) - (-> Text (List Text) (Meta [Type (List Type)])) - (do meta;Monad - [class (load-class class-name) - candidates (|> class - (Class.getConstructors []) - array;to-list - (monad;map @ (function [constructor] - (do @ - [passes? (check-constructor class arg-classes constructor)] - (wrap [passes? constructor])))))] - (case (list;filter product;left candidates) - #;Nil - (&;throw No-Candidate-Constructor (format class-name "(" (text;join-with ", " arg-classes) ")")) - - (#;Cons candidate #;Nil) - (|> candidate product;right constructor-to-type) - - _ - (&;throw Too-Many-Candidate-Constructors class-name)))) - -(def: (decorate-inputs typesT inputsA) - (-> (List Text) (List la;Analysis) (List la;Analysis)) - (|> inputsA - (list;zip2 (list/map code;text typesT)) - (list/map (function [[type value]] - (la;product (list type value)))))) - -(def: (sub-type-analyser analyse) - (-> &;Analyser &;Analyser) - (function [argC] - (do meta;Monad - [[argT argA] (&common;with-unknown-type - (analyse argC)) - expectedT meta;expected-type - [unboxed castT] (cast #In expectedT argT)] - (wrap argA)))) - -(def: (invoke//static proc) - (-> Text @;Proc) - (function [analyse eval args] - (case (: (e;Error [Text Text (List [Text Code])]) - (s;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any)))))) - (#e;Success [class method argsTC]) - (do meta;Monad - [#let [argsT (list/map product;left argsTC)] - [methodT exceptionsT] (methods class method #Static argsT) - [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC)) - [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) (decorate-inputs argsT argsA))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))))) - -(def: (invoke//virtual proc) - (-> Text @;Proc) - (function [analyse eval args] - (case (: (e;Error [Text Text Code (List [Text Code])]) - (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any)))))) - (#e;Success [class method objectC argsTC]) - (do meta;Monad - [#let [argsT (list/map product;left argsTC)] - [methodT exceptionsT] (methods class method #Virtual argsT) - [outputT allA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) - #let [[objectA argsA] (case allA - (#;Cons objectA argsA) - [objectA argsA] - - _ - (undefined))] - [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) objectA (decorate-inputs argsT argsA))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))))) - -(def: (invoke//special proc) - (-> Text @;Proc) - (function [analyse eval args] - (case (: (e;Error [(List Code) [Text Text Code (List [Text Code]) Unit]]) - (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!))) - (#e;Success [_ [class method objectC argsTC _]]) - (do meta;Monad - [#let [argsT (list/map product;left argsTC)] - [methodT exceptionsT] (methods class method #Special argsT) - [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) - [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (code;text method) - (code;text unboxed) (decorate-inputs argsT argsA))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))))) - -(exception: #export Not-Interface) - -(def: (invoke//interface proc) - (-> Text @;Proc) - (function [analyse eval args] - (case (: (e;Error [Text Text Code (List [Text Code])]) - (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any)))))) - (#e;Success [class-name method objectC argsTC]) - (do meta;Monad - [#let [argsT (list/map product;left argsTC)] - class (load-class class-name) - _ (&;assert (Not-Interface class-name) - (Modifier.isInterface [(Class.getModifiers [] class)])) - [methodT exceptionsT] (methods class-name method #Interface argsT) - [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) - [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc - (list& (code;text class-name) (code;text method) (code;text unboxed) - (decorate-inputs argsT argsA))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))))) - -(def: (invoke//constructor proc) - (-> Text @;Proc) - (function [analyse eval args] - (case (: (e;Error [Text (List [Text Code])]) - (s;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any)))))) - (#e;Success [class argsTC]) - (do meta;Monad - [#let [argsT (list/map product;left argsTC)] - [methodT exceptionsT] (constructor-methods class argsT) - [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC)) - [unboxed castT] (infer-out outputT)] - (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))))) - -(def: member-procs - @;Bundle - (<| (@;prefix "member") - (|> (dict;new text;Hash) - (dict;merge (<| (@;prefix "static") - (|> (dict;new text;Hash) - (@;install "get" static-get) - (@;install "put" static-put)))) - (dict;merge (<| (@;prefix "virtual") - (|> (dict;new text;Hash) - (@;install "get" virtual-get) - (@;install "put" virtual-put)))) - (dict;merge (<| (@;prefix "invoke") - (|> (dict;new text;Hash) - (@;install "static" invoke//static) - (@;install "virtual" invoke//virtual) - (@;install "special" invoke//special) - (@;install "interface" invoke//interface) - (@;install "constructor" invoke//constructor) - ))) - ))) - -(def: #export procedures - @;Bundle - (<| (@;prefix "jvm") - (|> (dict;new text;Hash) - (dict;merge conversion-procs) - (dict;merge int-procs) - (dict;merge long-procs) - (dict;merge float-procs) - (dict;merge double-procs) - (dict;merge char-procs) - (dict;merge array-procs) - (dict;merge object-procs) - (dict;merge member-procs) - ))) diff --git a/new-luxc/source/luxc/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux deleted file mode 100644 index 5bc1f96c9..000000000 --- a/new-luxc/source/luxc/analyser/reference.lux +++ /dev/null @@ -1,53 +0,0 @@ -(;module: - lux - (lux (control monad) - [meta] - (meta [code] - (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis] - [";L" variable #+ Variable]) - ["&;" scope])) - -## [Analysers] -(def: (analyse-definition def-name) - (-> Ident (Meta Analysis)) - (do meta;Monad - [actualT (meta;find-def-type def-name) - expectedT meta;expected-type - _ (&;with-type-env - (tc;check expectedT actualT))] - (wrap (code;symbol def-name)))) - -(def: (analyse-variable var-name) - (-> Text (Meta (Maybe Analysis))) - (do meta;Monad - [?var (&scope;find var-name)] - (case ?var - (#;Some [actualT ref]) - (do @ - [expectedT meta;expected-type - _ (&;with-type-env - (tc;check expectedT actualT))] - (wrap (#;Some (` ((~ (code;int (variableL;from-ref ref)))))))) - - #;None - (wrap #;None)))) - -(def: #export (analyse-reference reference) - (-> Ident (Meta Analysis)) - (case reference - ["" simple-name] - (do meta;Monad - [?var (analyse-variable simple-name)] - (case ?var - (#;Some analysis) - (wrap analysis) - - #;None - (do @ - [this-module meta;current-module-name] - (analyse-definition [this-module simple-name])))) - - _ - (analyse-definition reference))) diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux deleted file mode 100644 index d523065ea..000000000 --- a/new-luxc/source/luxc/analyser/structure.lux +++ /dev/null @@ -1,311 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - pipe) - [function] - (concurrency ["A" atom]) - (data [ident] - [number] - [product] - [maybe] - (coll [list "list/" Functor] - [dict #+ Dict]) - [text] - text/format) - [meta] - (meta [code] - [type] - (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis]) - ["&;" module] - ["&;" scope] - (analyser ["&;" common] - ["&;" inference]))) - -(exception: #export Not-Variant-Type) -(exception: #export Not-Tuple-Type) -(exception: #export Cannot-Infer-Numeric-Tag) - -(type: Type-Error - (-> Type Text)) - -(def: (not-quantified type) - Type-Error - (format "Not a quantified type: " (%type type))) - -(def: #export (analyse-sum analyse tag valueC) - (-> &;Analyser Nat Code (Meta la;Analysis)) - (do meta;Monad - [expectedT meta;expected-type] - (&;with-stacked-errors - (function [_] (Not-Variant-Type (format " Tag: " (%n tag) "\n" - "Value: " (%code valueC) "\n" - " Type: " (%type expectedT)))) - (case expectedT - (#;Sum _) - (let [flat (type;flatten-variant expectedT) - type-size (list;size flat)] - (case (list;nth tag flat) - (#;Some variant-type) - (do @ - [valueA (&;with-expected-type variant-type - (analyse valueC)) - temp &scope;next-local] - (wrap (la;sum tag type-size temp valueA))) - - #;None - (&common;variant-out-of-bounds-error expectedT type-size tag))) - - (#;Named name unnamedT) - (&;with-expected-type unnamedT - (analyse-sum analyse tag valueC)) - - (#;Var id) - (do @ - [bound? (&;with-type-env - (tc;bound? id))] - (if bound? - (do @ - [expectedT' (&;with-type-env - (tc;read id))] - (&;with-expected-type expectedT' - (analyse-sum analyse tag valueC))) - ## Cannot do inference when the tag is numeric. - ## This is because there is no way of knowing how many - ## cases the inferred sum type would have. - (&;throw Cannot-Infer-Numeric-Tag (format " Tag: " (%n tag) "\n" - "Value: " (%code valueC) "\n" - " Type: " (%type expectedT))))) - - (#;UnivQ _) - (do @ - [[var-id var] (&;with-type-env - tc;existential)] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) - (analyse-sum analyse tag valueC))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) - (analyse-sum analyse tag valueC)))) - - (#;Apply inputT funT) - (case (type;apply (list inputT) funT) - #;None - (&;fail (not-quantified funT)) - - (#;Some outputT) - (&;with-expected-type outputT - (analyse-sum analyse tag valueC))) - - _ - (&;throw Not-Variant-Type (format " Tag: " (%n tag) "\n" - "Value: " (%code valueC) "\n" - " Type: " (%type expectedT))))))) - -(def: (analyse-typed-product analyse members) - (-> &;Analyser (List Code) (Meta la;Analysis)) - (do meta;Monad - [expectedT meta;expected-type] - (loop [expectedT expectedT - members members] - (case [expectedT members] - ## If the type and the code are still ongoing, match each - ## sub-expression to its corresponding type. - [(#;Product leftT rightT) (#;Cons leftC rightC)] - (do @ - [leftA (&;with-expected-type leftT - (analyse leftC)) - rightA (recur rightT rightC)] - (wrap (` [(~ leftA) (~ rightA)]))) - - ## If the tuple runs out, whatever expression is the last gets - ## matched to the remaining type. - [tailT (#;Cons tailC #;Nil)] - (&;with-expected-type tailT - (analyse tailC)) - - ## If, however, the type runs out but there is still enough - ## tail, the remaining elements get packaged into another - ## tuple, and analysed through the intermediation of a - ## temporary local variable. - ## The reason for this is that it is assumed that the type of - ## the tuple represents the expectations of the user. - ## If the type is for a 3-tuple, but a 5-tuple is provided, it - ## is assumed that the user intended the following layout: - ## [0, 1, [2, 3, 4]] - ## but that, for whatever reason, it was written in a flat - ## way. - ## The reason why an intermediate variable is used is that if - ## the code was just re-written with just tuple nesting, the - ## resulting analysis would have undone the explicity nesting, - ## since Product nodes rely on nesting inherently, thereby - ## blurring the line between what was wanted (the separation) - ## and what was analysed. - [tailT tailC] - (do @ - [g!tail (meta;gensym "tail")] - (&;with-expected-type tailT - (analyse (` ((~' _lux_case) [(~@ tailC)] - (~ g!tail) - (~ g!tail)))))) - )))) - -(def: #export (analyse-product analyse membersC) - (-> &;Analyser (List Code) (Meta la;Analysis)) - (do meta;Monad - [expectedT meta;expected-type] - (&;with-stacked-errors - (function [_] (Not-Tuple-Type (format " Type: " (%type expectedT) "\n" - "Value: " (%code (` [(~@ membersC)]))))) - (case expectedT - (#;Product _) - (analyse-typed-product analyse membersC) - - (#;Named name unnamedT) - (&;with-expected-type unnamedT - (analyse-product analyse membersC)) - - (#;Var id) - (do @ - [bound? (&;with-type-env - (tc;bound? id))] - (if bound? - (do @ - [expectedT' (&;with-type-env - (tc;read id))] - (&;with-expected-type expectedT' - (analyse-product analyse membersC))) - ## Must do inference... - (do @ - [membersTA (monad;map @ (|>. analyse &common;with-unknown-type) - membersC) - _ (&;with-type-env - (tc;check expectedT - (type;tuple (list/map product;left membersTA))))] - (wrap (la;product (list/map product;right membersTA)))))) - - (#;UnivQ _) - (do @ - [[var-id var] (&;with-type-env - tc;existential)] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) - (analyse-product analyse membersC))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) - (analyse-product analyse membersC)))) - - (#;Apply inputT funT) - (case (type;apply (list inputT) funT) - #;None - (&;fail (not-quantified funT)) - - (#;Some outputT) - (&;with-expected-type outputT - (analyse-product analyse membersC))) - - _ - (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n" - "Value: " (%code (` [(~@ membersC)])))) - )))) - -(def: #export (analyse-tagged-sum analyse tag valueC) - (-> &;Analyser Ident Code (Meta la;Analysis)) - (do meta;Monad - [tag (meta;normalize tag) - [idx group variantT] (meta;resolve-tag tag) - expectedT meta;expected-type] - (case expectedT - (#;Var _) - (do @ - [#let [case-size (list;size group)] - inferenceT (&inference;variant idx case-size variantT) - [inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC)) - _ (&;with-type-env - (tc;check expectedT inferredT)) - temp &scope;next-local] - (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume)))) - - _ - (analyse-sum analyse idx valueC)))) - -## There cannot be any ambiguity or improper syntax when analysing -## records, so they must be normalized for further analysis. -## Normalization just means that all the tags get resolved to their -## canonical form (with their corresponding module identified). -(def: #export (normalize record) - (-> (List [Code Code]) (Meta (List [Ident Code]))) - (monad;map meta;Monad - (function [[key val]] - (case key - [_ (#;Tag key)] - (do meta;Monad - [key (meta;normalize key)] - (wrap [key val])) - - _ - (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) - record)) - -## Lux already possesses the means to analyse tuples, so -## re-implementing the same functionality for records makes no sense. -## Records, thus, get transformed into tuples by ordering the elements. -(def: #export (order record) - (-> (List [Ident Code]) (Meta [(List Code) Type])) - (case record - ## empty-record = empty-tuple = unit = [] - #;Nil - (:: meta;Monad wrap [(list) Unit]) - - (#;Cons [head-k head-v] _) - (do meta;Monad - [head-k (meta;normalize head-k) - [_ tag-set recordT] (meta;resolve-tag head-k) - #let [size-record (list;size record) - size-ts (list;size tag-set)] - _ (if (n.= size-ts size-record) - (wrap []) - (&;fail (format "Record size does not match tag-set size." "\n" - "Expected: " (|> size-ts nat-to-int %i) "\n" - " Actual: " (|> size-record nat-to-int %i) "\n" - "For type: " (%type recordT)))) - #let [tuple-range (list;n.range +0 (n.dec size-ts)) - tag->idx (dict;from-list ident;Hash (list;zip2 tag-set tuple-range))] - idx->val (monad;fold @ - (function [[key val] idx->val] - (do @ - [key (meta;normalize key)] - (case (dict;get key tag->idx) - #;None - (&;fail (format "Tag " (%code (code;tag key)) - " does not belong to tag-set for type " (%type recordT))) - - (#;Some idx) - (if (dict;contains? idx idx->val) - (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) - (wrap (dict;put idx val idx->val)))))) - (: (Dict Nat Code) - (dict;new number;Hash)) - record) - #let [ordered-tuple (list/map (function [idx] (maybe;assume (dict;get idx idx->val))) - tuple-range)]] - (wrap [ordered-tuple recordT])) - )) - -(def: #export (analyse-record analyse members) - (-> &;Analyser (List [Code Code]) (Meta la;Analysis)) - (do meta;Monad - [members (normalize members) - [members recordT] (order members) - expectedT meta;expected-type - inferenceT (&inference;record recordT) - [inferredT membersA] (&inference;apply-function analyse inferenceT members) - _ (&;with-type-env - (tc;check expectedT inferredT))] - (wrap (la;product membersA)))) diff --git a/new-luxc/source/luxc/analyser/type.lux b/new-luxc/source/luxc/analyser/type.lux deleted file mode 100644 index d0b038d93..000000000 --- a/new-luxc/source/luxc/analyser/type.lux +++ /dev/null @@ -1,31 +0,0 @@ -(;module: - lux - (lux (control monad) - [meta #+ Monad] - (meta (type ["TC" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis]))) - -## These 2 analysers are somewhat special, since they require the -## means of evaluating Lux expressions at compile-time for the sake of -## computing Lux type values. -(def: #export (analyse-check analyse eval type value) - (-> &;Analyser &;Eval Code Code (Meta Analysis)) - (do Monad - [actual (eval Type type) - #let [actual (:! Type actual)] - expected meta;expected-type - _ (&;with-type-env - (TC;check expected actual))] - (&;with-expected-type actual - (analyse value)))) - -(def: #export (analyse-coerce analyse eval type value) - (-> &;Analyser &;Eval Code Code (Meta Analysis)) - (do Monad - [actual (eval Type type) - expected meta;expected-type - _ (&;with-type-env - (TC;check expected (:! Type actual)))] - (&;with-expected-type Top - (analyse value)))) diff --git a/new-luxc/source/luxc/eval.lux b/new-luxc/source/luxc/eval.lux index 91195fbfd..fdbf8e781 100644 --- a/new-luxc/source/luxc/eval.lux +++ b/new-luxc/source/luxc/eval.lux @@ -2,9 +2,9 @@ lux (lux (control [monad #+ do]) [meta]) + (luxc (lang (analysis [";A" expression]))) [../base] - (.. [analyser] - [synthesizer] + (.. [synthesizer] (generator [";G" expression] [eval]))) @@ -12,7 +12,7 @@ ../base;Eval (do meta;Monad [exprA (../base;with-expected-type type - (analyser;analyser eval exprC)) + (expressionA;analyser eval exprC)) #let [exprS (synthesizer;synthesize exprA)] exprI (expressionG;generate exprS)] (eval;eval exprI))) diff --git a/new-luxc/source/luxc/generator.lux b/new-luxc/source/luxc/generator.lux index 90e0ca4cf..b1068c257 100644 --- a/new-luxc/source/luxc/generator.lux +++ b/new-luxc/source/luxc/generator.lux @@ -14,11 +14,11 @@ [";L" host] ["&;" io] ["&;" module] - ["&;" parser] - ["&;" analyser] - ["&;" analyser/common] ["&;" synthesizer] ["&;" eval] + (lang ["&;" parser] + (analysis [";A" expression] + [";A" common])) (generator ["&&;" runtime] ["&&;" statement] ["&&;" common] @@ -28,7 +28,7 @@ (def: analyse (&;Analyser) - (&analyser;analyser &eval;eval)) + (expressionA;analyser &eval;eval)) (def: (generate code) (-> Code (Meta Unit)) @@ -49,7 +49,7 @@ (do @ [valueA (analyse valueC)] (wrap [Type valueA]))) - (&analyser/common;with-unknown-type + (commonA;with-unknown-type (analyse valueC)))) valueI (expressionG;generate (&synthesizer;synthesize valueA)) _ (&;with-scope diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux index 3cf5fb189..86bede8cd 100644 --- a/new-luxc/source/luxc/generator/eval.jvm.lux +++ b/new-luxc/source/luxc/generator/eval.jvm.lux @@ -12,7 +12,6 @@ ["$i" inst])) (lang ["la" analysis] ["ls" synthesis]) - ["&;" analyser] ["&;" synthesizer] (generator ["&;" common]) )) diff --git a/new-luxc/source/luxc/generator/expression.jvm.lux b/new-luxc/source/luxc/generator/expression.jvm.lux index 5eb8d7c47..e0f95b48b 100644 --- a/new-luxc/source/luxc/generator/expression.jvm.lux +++ b/new-luxc/source/luxc/generator/expression.jvm.lux @@ -11,7 +11,6 @@ (host ["$" jvm]) (lang ["ls" synthesis] [";L" variable #+ Variable Register]) - ["&;" analyser] ["&;" synthesizer] (generator ["&;" common] ["&;" primitive] diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux index ed90d3aa2..70b892d41 100644 --- a/new-luxc/source/luxc/generator/function.jvm.lux +++ b/new-luxc/source/luxc/generator/function.jvm.lux @@ -13,7 +13,6 @@ (lang ["la" analysis] ["ls" synthesis] [";L" variable #+ Variable]) - ["&;" analyser] ["&;" synthesizer] (generator ["&;" common] ["&;" runtime]))) diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux index 2e4eb7ccf..f772383d1 100644 --- a/new-luxc/source/luxc/generator/primitive.jvm.lux +++ b/new-luxc/source/luxc/generator/primitive.jvm.lux @@ -10,7 +10,6 @@ ["$t" type])) (lang ["la" analysis] ["ls" synthesis]) - ["&;" analyser] ["&;" synthesizer] (generator ["&;" common])) [../runtime]) diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux index a61b7f0fe..a8fa81f81 100644 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux @@ -17,7 +17,6 @@ ["$i" inst])) (lang ["la" analysis] ["ls" synthesis]) - ["&;" analyser] ["&;" synthesizer] (generator ["&;" common] ["&;" runtime]))) diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux index bc57d6a2b..97c8fb87e 100644 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux @@ -21,9 +21,8 @@ ["$d" def] ["$i" inst])) (lang ["la" analysis] + (analysis (procedure ["&;" host])) ["ls" synthesis]) - ["&;" analyser] - (analyser (procedure ["&;" host])) ["&;" synthesizer] (generator ["&;" common] ["&;" runtime])) diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index c5777b4af..fd8fbf74a 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -14,7 +14,6 @@ ["$i" inst])) (lang ["la" analysis] ["ls" synthesis]) - ["&;" analyser] ["&;" synthesizer] (generator ["&;" common]))) diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux index 33cc7936c..b9dced077 100644 --- a/new-luxc/source/luxc/generator/structure.jvm.lux +++ b/new-luxc/source/luxc/generator/structure.jvm.lux @@ -13,7 +13,6 @@ ["$i" inst])) (lang ["la" analysis] ["ls" synthesis]) - ["&;" analyser] ["&;" synthesizer] (generator ["&;" common])) [../runtime]) diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux new file mode 100644 index 000000000..1e40e38f1 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/case.lux @@ -0,0 +1,260 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + eq) + (data [bool] + [number] + [product] + ["e" error] + [maybe] + [text] + text/format + (coll [list "list/" Fold Monoid Functor])) + [meta] + (meta [code] + [type] + (type ["tc" check]))) + (luxc ["&" base] + (lang ["la" analysis] + (analysis [";A" common] + [";A" structure] + (case [";A" coverage]))) + ["&;" scope])) + +(exception: #export Cannot-Match-Type-With-Pattern) +(exception: #export Sum-Type-Has-No-Case) +(exception: #export Unrecognized-Pattern-Syntax) +(exception: #export Cannot-Simplify-Type-For-Pattern-Matching) + +(def: (pattern-error type pattern) + (-> Type Code Text) + (Cannot-Match-Type-With-Pattern + (format " Type: " (%type type) "\n" + "Pattern: " (%code pattern)))) + +## Type-checking on the input value is done during the analysis of a +## "case" expression, to ensure that the patterns being used make +## sense for the type of the input value. +## Sometimes, that input value is complex, by depending on +## type-variables or quantifications. +## This function makes it easier for "case" analysis to properly +## type-check the input with respect to the patterns. +(def: (simplify-case-type type) + (-> Type (Meta Type)) + (case type + (#;Var id) + (do meta;Monad + [? (&;with-type-env + (tc;bound? id))] + (if ? + (do @ + [type' (&;with-type-env + (tc;read id))] + (simplify-case-type type')) + (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type type)))) + + (#;Named name unnamedT) + (simplify-case-type unnamedT) + + (^or (#;UnivQ _) (#;ExQ _)) + (do meta;Monad + [[ex-id exT] (&;with-type-env + tc;existential)] + (simplify-case-type (maybe;assume (type;apply (list exT) type)))) + + (#;Apply inputT funcT) + (case (type;apply (list inputT) funcT) + (#;Some outputT) + (:: meta;Monad wrap outputT) + + #;None + (&;fail (format "Cannot apply type " (%type funcT) " to type " (%type inputT)))) + + _ + (:: meta;Monad wrap type))) + +## This function handles several concerns at once, but it must be that +## way because those concerns are interleaved when doing +## pattern-matching and they cannot be separated. +## The pattern is analysed in order to get a general feel for what is +## expected of the input value. This, in turn, informs the +## type-checking of the input. +## A kind of "continuation" value is passed around which signifies +## what needs to be done _after_ analysing a pattern. +## In general, this is done to analyse the "body" expression +## associated to a particular pattern _in the context of_ said +## pattern. +## The reason why *context* is important is because patterns may bind +## values to local variables, which may in turn be referenced in the +## body expressions. +## That is why the body must be analysed in the context of the +## pattern, and not separately. +(def: (analyse-pattern num-tags inputT pattern next) + (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la;Pattern a]))) + (case pattern + [cursor (#;Symbol ["" name])] + (&;with-cursor cursor + (do meta;Monad + [outputA (&scope;with-local [name inputT] + next) + idx &scope;next-local] + (wrap [(` ("lux case bind" (~ (code;nat idx)))) outputA]))) + + [cursor (#;Symbol ident)] + (&;with-cursor cursor + (&;fail (format "Symbols must be unqualified inside patterns: " (%ident ident)))) + + (^template [ ] + [cursor ( test)] + (&;with-cursor cursor + (do meta;Monad + [_ (&;with-type-env + (tc;check inputT )) + outputA next] + (wrap [pattern outputA])))) + ([Bool #;Bool] + [Nat #;Nat] + [Int #;Int] + [Deg #;Deg] + [Frac #;Frac] + [Text #;Text]) + + (^ [cursor (#;Tuple (list))]) + (&;with-cursor cursor + (do meta;Monad + [_ (&;with-type-env + (tc;check inputT Unit)) + outputA next] + (wrap [(` ("lux case tuple" [])) outputA]))) + + (^ [cursor (#;Tuple (list singleton))]) + (analyse-pattern #;None inputT singleton next) + + [cursor (#;Tuple sub-patterns)] + (&;with-cursor cursor + (do meta;Monad + [inputT' (simplify-case-type inputT)] + (case inputT' + (#;Product _) + (let [sub-types (type;flatten-tuple inputT') + num-sub-types (maybe;default (list;size sub-types) + num-tags) + num-sub-patterns (list;size sub-patterns) + matches (cond (n.< num-sub-types num-sub-patterns) + (let [[prefix suffix] (list;split (n.dec num-sub-patterns) sub-types)] + (list;zip2 (list/compose prefix (list (type;tuple suffix))) sub-patterns)) + + (n.> num-sub-types num-sub-patterns) + (let [[prefix suffix] (list;split (n.dec num-sub-types) sub-patterns)] + (list;zip2 sub-types (list/compose prefix (list (code;tuple suffix))))) + + ## (n.= num-sub-types num-sub-patterns) + (list;zip2 sub-types sub-patterns) + )] + (do @ + [[memberP+ thenA] (list/fold (: (All [a] + (-> [Type Code] (Meta [(List la;Pattern) a]) + (Meta [(List la;Pattern) a]))) + (function [[memberT memberC] then] + (do @ + [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la;Pattern a]))) + analyse-pattern) + #;None memberT memberC then)] + (wrap [(list& memberP memberP+) thenA])))) + (do @ + [nextA next] + (wrap [(list) nextA])) + matches)] + (wrap [(` ("lux case tuple" [(~@ memberP+)])) + thenA]))) + + _ + (&;fail (pattern-error inputT pattern)) + ))) + + [cursor (#;Record record)] + (do meta;Monad + [record (structureA;normalize record) + [members recordT] (structureA;order record) + _ (&;with-type-env + (tc;check inputT recordT))] + (analyse-pattern (#;Some (list;size members)) inputT [cursor (#;Tuple members)] next)) + + [cursor (#;Tag tag)] + (&;with-cursor cursor + (analyse-pattern #;None inputT (` ((~ pattern))) next)) + + (^ [cursor (#;Form (list& [_ (#;Nat idx)] values))]) + (&;with-cursor cursor + (do meta;Monad + [inputT' (simplify-case-type inputT)] + (case inputT' + (#;Sum _) + (let [flat-sum (type;flatten-variant inputT') + size-sum (list;size flat-sum) + num-cases (maybe;default size-sum num-tags)] + (case (list;nth idx flat-sum) + (^multi (#;Some case-type) + (n.< num-cases idx)) + (if (and (n.> num-cases size-sum) + (n.= (n.dec num-cases) idx)) + (do meta;Monad + [[testP nextA] (analyse-pattern #;None + (type;variant (list;drop (n.dec num-cases) flat-sum)) + (` [(~@ values)]) + next)] + (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP))) + nextA])) + (do meta;Monad + [[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)] + (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP))) + nextA]))) + + _ + (&;throw Sum-Type-Has-No-Case + (format "Case: " (%n idx) "\n" + "Type: " (%type inputT))))) + + _ + (&;fail (pattern-error inputT pattern))))) + + (^ [cursor (#;Form (list& [_ (#;Tag tag)] values))]) + (&;with-cursor cursor + (do meta;Monad + [tag (meta;normalize tag) + [idx group variantT] (meta;resolve-tag tag) + _ (&;with-type-env + (tc;check inputT variantT))] + (analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next))) + + _ + (&;throw Unrecognized-Pattern-Syntax (%code pattern)) + )) + +(def: #export (analyse-case analyse inputC branches) + (-> &;Analyser Code (List [Code Code]) (Meta la;Analysis)) + (case branches + #;Nil + (&;fail "Cannot have empty branches in pattern-matching expression.") + + (#;Cons [patternH bodyH] branchesT) + (do meta;Monad + [[inputT inputA] (commonA;with-unknown-type + (analyse inputC)) + outputH (analyse-pattern #;None inputT patternH (analyse bodyH)) + outputT (monad;map @ + (function [[patternT bodyT]] + (analyse-pattern #;None inputT patternT (analyse bodyT))) + branchesT) + outputHC (|> outputH product;left coverageA;determine) + outputTC (monad;map @ (|>. product;left coverageA;determine) outputT) + _ (case (monad;fold e;Monad coverageA;merge outputHC outputTC) + (#e;Success coverage) + (if (coverageA;exhaustive? coverage) + (wrap []) + (&;fail "Pattern-matching is not exhaustive.")) + + (#e;Error error) + (&;fail error))] + (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT))))))))) diff --git a/new-luxc/source/luxc/lang/analysis/case/coverage.lux b/new-luxc/source/luxc/lang/analysis/case/coverage.lux new file mode 100644 index 000000000..554aea1a8 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/case/coverage.lux @@ -0,0 +1,299 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + eq) + (data [bool "bool/" Eq] + [number] + ["e" error "error/" Monad] + text/format + (coll [list "list/" Fold] + [dict #+ Dict])) + [meta "meta/" Monad]) + (luxc ["&" base] + (lang ["la" analysis]))) + +## The coverage of a pattern-matching expression summarizes how well +## all the possible values of an input are being covered by the +## different patterns involved. +## Ideally, the pattern-matching has "exhaustive" coverage, which just +## means that every possible value can be matched by at least 1 +## pattern. +## Every other coverage is considered partial, and it would be valued +## as insuficient (since it could lead to runtime errors due to values +## not being handled by any pattern). +## The #Partial tag covers arbitrary partial coverages in a general +## way, while the other tags cover more specific cases for booleans +## and variants. +(type: #export #rec Coverage + #Partial + (#Bool Bool) + (#Variant Nat (Dict Nat Coverage)) + (#Seq Coverage Coverage) + (#Alt Coverage Coverage) + #Exhaustive) + +(def: #export (exhaustive? coverage) + (-> Coverage Bool) + (case coverage + (#Exhaustive _) + true + + _ + false)) + +(exception: #export Unknown-Pattern) + +(def: #export (determine pattern) + (-> la;Pattern (Meta Coverage)) + (case pattern + ## Binding amounts to exhaustive coverage because any value can be + ## matched that way. + ## Unit [] amounts to exhaustive coverage because there is only one + ## possible value, so matching against it covers all cases. + (^or (^code ("lux case bind" (~ _))) (^code ("lux case tuple" []))) + (meta/wrap #Exhaustive) + + (^code ("lux case tuple" [(~ singleton)])) + (determine singleton) + + ## Primitive patterns always have partial coverage because there + ## are too many possibilities as far as values go. + (^or [_ (#;Nat _)] [_ (#;Int _)] [_ (#;Deg _)] + [_ (#;Frac _)] [_ (#;Text _)]) + (meta/wrap #Partial) + + ## Bools are the exception, since there is only "true" and + ## "false", which means it is possible for boolean + ## pattern-matching to become exhaustive if complementary parts meet. + [_ (#;Bool value)] + (meta/wrap (#Bool value)) + + ## Tuple patterns can be exhaustive if there is exhaustiveness for all of + ## their sub-patterns. + (^code ("lux case tuple" [(~@ subs)])) + (loop [subs subs] + (case subs + #;Nil + (meta/wrap #Exhaustive) + + (#;Cons sub subs') + (do meta;Monad + [pre (determine sub) + post (recur subs')] + (if (exhaustive? post) + (wrap pre) + (wrap (#Seq pre post)))))) + + ## Variant patterns can be shown to be exhaustive if all the possible + ## cases are handled exhaustively. + (^code ("lux case variant" (~ [_ (#;Nat tag-id)]) (~ [_ (#;Nat num-tags)]) (~ sub))) + (do meta;Monad + [=sub (determine sub)] + (wrap (#Variant num-tags + (|> (dict;new number;Hash) + (dict;put tag-id =sub))))) + + _ + (&;throw Unknown-Pattern (%code pattern)))) + +(def: (xor left right) + (-> Bool Bool Bool) + (or (and left (not right)) + (and (not left) right))) + +## The coverage checker not only verifies that pattern-matching is +## exhaustive, but also that there are no redundant patterns. +## Redundant patterns will never be executed, since there will +## always be a pattern prior to them that would match the input. +## Because of that, the presence of redundant patterns is assumed to +## be a bug, likely due to programmer carelessness. +(def: redundant-pattern + (e;Error Coverage) + (e;fail "Redundant pattern.")) + +(def: (flatten-alt coverage) + (-> Coverage (List Coverage)) + (case coverage + (#Alt left right) + (list& left (flatten-alt right)) + + _ + (list coverage))) + +(struct: _ (Eq Coverage) + (def: (= reference sample) + (case [reference sample] + [#Exhaustive #Exhaustive] + true + + [(#Bool sideR) (#Bool sideS)] + (bool/= sideR sideS) + + [(#Variant allR casesR) (#Variant allS casesS)] + (and (n.= allR allS) + (:: (dict;Eq =) = casesR casesS)) + + [(#Seq leftR rightR) (#Seq leftS rightS)] + (and (= leftR leftS) + (= rightR rightS)) + + [(#Alt _) (#Alt _)] + (let [flatR (flatten-alt reference) + flatS (flatten-alt sample)] + (and (n.= (list;size flatR) (list;size flatS)) + (list;every? (function [[coverageR coverageS]] + (= coverageR coverageS)) + (list;zip2 flatR flatS)))) + + _ + false))) + +(open Eq "C/") + +## After determining the coverage of each individual pattern, it is +## necessary to merge them all to figure out if the entire +## pattern-matching expression is exhaustive and whether it contains +## redundant patterns. +(def: #export (merge addition so-far) + (-> Coverage Coverage (e;Error Coverage)) + (case [addition so-far] + ## The addition cannot possibly improve the coverage. + [_ #Exhaustive] + redundant-pattern + + ## The addition completes the coverage. + [#Exhaustive _] + (error/wrap #Exhaustive) + + [#Partial #Partial] + (error/wrap #Partial) + + ## 2 boolean coverages are exhaustive if they compliment one another. + (^multi [(#Bool sideA) (#Bool sideSF)] + (xor sideA sideSF)) + (error/wrap #Exhaustive) + + [(#Variant allA casesA) (#Variant allSF casesSF)] + (cond (not (n.= allSF allA)) + (e;fail "Variants do not match.") + + (:: (dict;Eq Eq) = casesSF casesA) + redundant-pattern + + ## else + (do e;Monad + [casesM (monad;fold @ + (function [[tagA coverageA] casesSF'] + (case (dict;get tagA casesSF') + (#;Some coverageSF) + (do @ + [coverageM (merge coverageA coverageSF)] + (wrap (dict;put tagA coverageM casesSF'))) + + #;None + (wrap (dict;put tagA coverageA casesSF')))) + casesSF (dict;entries casesA))] + (wrap (if (let [case-coverages (dict;values casesM)] + (and (n.= allSF (list;size case-coverages)) + (list;every? exhaustive? case-coverages))) + #Exhaustive + (#Variant allSF casesM))))) + + [(#Seq leftA rightA) (#Seq leftSF rightSF)] + (case [(C/= leftSF leftA) (C/= rightSF rightA)] + ## There is nothing the addition adds to the coverage. + [true true] + redundant-pattern + + ## The 2 sequences cannot possibly be merged. + [false false] + (error/wrap (#Alt so-far addition)) + + ## Same prefix + [true false] + (do e;Monad + [rightM (merge rightA rightSF)] + (if (exhaustive? rightM) + ## If all that follows is exhaustive, then it can be safely dropped + ## (since only the "left" part would influence whether the + ## merged coverage is exhaustive or not). + (wrap leftSF) + (wrap (#Seq leftSF rightM)))) + + ## Same suffix + [false true] + (do e;Monad + [leftM (merge leftA leftSF)] + (wrap (#Seq leftM rightA)))) + + ## The left part will always match, so the addition is redundant. + (^multi [(#Seq left right) single] + (C/= left single)) + redundant-pattern + + ## The right part is not necessary, since it can always match the left. + (^multi [single (#Seq left right)] + (C/= left single)) + (error/wrap single) + + ## When merging a new coverage against one based on Alt, it may be + ## that one of the many coverages in the Alt is complementary to + ## the new one, so effort must be made to fuse carefully, to match + ## the right coverages together. + ## If one of the Alt sub-coverages matches the new one, the cycle + ## must be repeated, in case the resulting coverage can now match + ## other ones in the original Alt. + ## This process must be repeated until no further productive + ## merges can be done. + [_ (#Alt leftS rightS)] + (do e;Monad + [#let [fuse-once (: (-> Coverage (List Coverage) + (e;Error [(Maybe Coverage) + (List Coverage)])) + (function [coverage possibilities] + (loop [alts possibilities] + (case alts + #;Nil + (wrap [#;None (list coverage)]) + + (#;Cons alt alts') + (case (merge coverage alt) + (#e;Success altM) + (case altM + (#Alt _) + (do @ + [[success alts+] (recur alts')] + (wrap [success (#;Cons alt alts+)])) + + _ + (wrap [(#;Some altM) alts'])) + + (#e;Error error) + (e;fail error)) + ))))] + [success possibilities] (fuse-once addition (flatten-alt so-far))] + (loop [success success + possibilities possibilities] + (case success + (#;Some coverage') + (do @ + [[success' possibilities'] (fuse-once coverage' possibilities)] + (recur success' possibilities')) + + #;None + (case (list;reverse possibilities) + (#;Cons last prevs) + (wrap (list/fold (function [left right] (#Alt left right)) + last + prevs)) + + #;Nil + (undefined))))) + + _ + (if (C/= so-far addition) + ## The addition cannot possibly improve the coverage. + redundant-pattern + ## There are now 2 alternative paths. + (error/wrap (#Alt so-far addition))))) diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux new file mode 100644 index 000000000..4cbf5aedf --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/common.lux @@ -0,0 +1,41 @@ +(;module: + lux + (lux (control monad + pipe) + (data text/format + [product]) + [meta #+ Monad] + (meta [type] + (type ["tc" check]))) + (luxc ["&" base] + (lang analysis))) + +(def: #export (with-unknown-type action) + (All [a] (-> (Meta Analysis) (Meta [Type Analysis]))) + (do Monad + [[var-id var-type] (&;with-type-env + tc;create) + analysis (&;with-expected-type var-type + action) + analysis-type (&;with-type-env + (tc;clean var-id var-type)) + _ (&;with-type-env + (tc;delete var-id))] + (wrap [analysis-type analysis]))) + +(def: #export (with-var body) + (All [a] (-> (-> [Nat Type] (Meta a)) (Meta a))) + (do Monad + [[id var] (&;with-type-env + tc;create) + output (body [id var]) + _ (&;with-type-env + (tc;delete id))] + (wrap output))) + +(def: #export (variant-out-of-bounds-error type size tag) + (All [a] (-> Type Nat Nat (Meta a))) + (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n" + " Tag: " (%i (nat-to-int tag)) "\n" + "Size: " (%i (nat-to-int size)) "\n" + "Type: " (%type type)))) diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux new file mode 100644 index 000000000..e3a623089 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/expression.lux @@ -0,0 +1,141 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data ["e" error] + [product] + text/format) + [meta] + (meta [type] + (type ["tc" check])) + [host]) + (luxc ["&" base] + [";L" host] + (lang ["la" analysis]) + ["&;" module] + (generator [";G" common])) + (.. [";A" common] + [";A" function] + [";A" primitive] + [";A" reference] + [";A" structure] + [";A" procedure])) + +(for {"JVM" (as-is (host;import java.lang.reflect.Method + (invoke [Object (Array Object)] #try Object)) + (host;import (java.lang.Class c) + (getMethod [String (Array (Class Object))] #try Method)) + (host;import java.lang.Object + (getClass [] (Class Object)) + (toString [] String)) + (def: _object-class (Class Object) (host;class-for Object)) + (def: _apply-args + (Array (Class Object)) + (|> (host;array (Class Object) +2) + (host;array-write +0 _object-class) + (host;array-write +1 _object-class))) + (def: (call-macro macro inputs) + (-> Macro (List Code) (Meta (List Code))) + (do meta;Monad + [class (commonG;load-class hostL;function-class)] + (function [compiler] + (do e;Monad + [apply-method (Class.getMethod ["apply" _apply-args] class) + output (Method.invoke [(:! Object macro) + (|> (host;array Object +2) + (host;array-write +0 (:! Object inputs)) + (host;array-write +1 (:! Object compiler)))] + apply-method)] + (:! (e;Error [Compiler (List Code)]) + output)))))) + }) + +(exception: #export Macro-Expression-Must-Have-Single-Expansion) +(exception: #export Unrecognized-Syntax) + +(def: #export (analyser eval) + (-> &;Eval &;Analyser) + (: (-> Code (Meta la;Analysis)) + (function analyse [ast] + (do meta;Monad + [expectedT meta;expected-type] + (let [[cursor ast'] ast] + ## The cursor must be set in the compiler for the sake + ## of having useful error messages. + (&;with-cursor cursor + (case ast' + (^template [ ] + ( value) + ( value)) + ([#;Bool primitiveA;analyse-bool] + [#;Nat primitiveA;analyse-nat] + [#;Int primitiveA;analyse-int] + [#;Deg primitiveA;analyse-deg] + [#;Frac primitiveA;analyse-frac] + [#;Text primitiveA;analyse-text]) + + (^ (#;Tuple (list))) + primitiveA;analyse-unit + + ## Singleton tuples are equivalent to the element they contain. + (^ (#;Tuple (list singleton))) + (analyse singleton) + + (^ (#;Tuple elems)) + (structureA;analyse-product analyse elems) + + (^ (#;Record pairs)) + (structureA;analyse-record analyse pairs) + + (#;Symbol reference) + (referenceA;analyse-reference reference) + + (^ (#;Form (list& [_ (#;Text proc-name)] proc-args))) + (procedureA;analyse-procedure analyse eval proc-name proc-args) + + (^template [ ] + (^ (#;Form (list& [_ ( tag)] + values))) + (case values + (#;Cons value #;Nil) + ( analyse tag value) + + _ + ( analyse tag (` [(~@ values)])))) + ([#;Nat structureA;analyse-sum] + [#;Tag structureA;analyse-tagged-sum]) + + (#;Tag tag) + (structureA;analyse-tagged-sum analyse tag (' [])) + + (^ (#;Form (list& func args))) + (do meta;Monad + [[funcT =func] (commonA;with-unknown-type + (analyse func))] + (case =func + [_ (#;Symbol def-name)] + (do @ + [[def-type def-anns def-value] (meta;find-def def-name)] + (if (meta;macro? def-anns) + (do @ + [expansion (function [compiler] + (case (call-macro (:! Macro def-value) args compiler) + (#e;Success [compiler' output]) + (#e;Success [compiler' output]) + + (#e;Error error) + ((&;fail error) compiler)))] + (case expansion + (^ (list single)) + (analyse single) + + _ + (&;throw Macro-Expression-Must-Have-Single-Expansion (%code ast)))) + (functionA;analyse-apply analyse funcT =func args))) + + _ + (functionA;analyse-apply analyse funcT =func args))) + + _ + (&;throw Unrecognized-Syntax (%code ast)) + ))))))) diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux new file mode 100644 index 000000000..627fb7c0a --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/function.lux @@ -0,0 +1,111 @@ +(;module: + lux + (lux (control monad + ["ex" exception #+ exception:]) + (data [maybe] + [text] + text/format + (coll [list "list/" Fold Monoid Monad])) + [meta] + (meta [code] + [type] + (type ["tc" check]))) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis] + (analysis ["&;" common] + ["&;" inference]) + [";L" variable #+ Variable]) + ["&;" scope])) + +(exception: #export Invalid-Function-Type) +(exception: #export Cannot-Apply-Function) + +## [Analysers] +(def: #export (analyse-function analyse func-name arg-name body) + (-> &;Analyser Text Text Code (Meta Analysis)) + (do meta;Monad + [functionT meta;expected-type] + (loop [expectedT functionT] + (&;with-stacked-errors + (function [_] (Invalid-Function-Type (%type expectedT))) + (case expectedT + (#;Named name unnamedT) + (recur unnamedT) + + (#;Apply argT funT) + (case (type;apply (list argT) funT) + (#;Some value) + (recur value) + + #;None + (&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT)))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;with-type-env + tc;existential)] + (recur (maybe;assume (type;apply (list var) expectedT)))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (recur (maybe;assume (type;apply (list var) expectedT))))) + + (#;Var id) + (do @ + [? (&;with-type-env + (tc;concrete? id))] + (if ? + (do @ + [expectedT' (&;with-type-env + (tc;read id))] + (recur expectedT')) + ## Inference + (&common;with-var + (function [[input-id inputT]] + (&common;with-var + (function [[output-id outputT]] + (do @ + [#let [funT (#;Function inputT outputT)] + funA (recur funT) + funT' (&;with-type-env + (tc;clean output-id funT)) + concrete-input? (&;with-type-env + (tc;concrete? input-id)) + funT'' (if concrete-input? + (&;with-type-env + (tc;clean input-id funT')) + (wrap (type;univ-q +1 (&inference;replace-var input-id +1 funT')))) + _ (&;with-type-env + (tc;check expectedT funT''))] + (wrap funA)) + )))))) + + (#;Function inputT outputT) + (<| (:: @ map (function [[scope bodyA]] + (` ("lux function" [(~@ (list/map code;int (variableL;environment scope)))] + (~ bodyA))))) + &;with-scope + ## Functions have access not only to their argument, but + ## also to themselves, through a local variable. + (&scope;with-local [func-name expectedT]) + (&scope;with-local [arg-name inputT]) + (&;with-expected-type outputT) + (analyse body)) + + _ + (&;fail "") + ))))) + +(def: #export (analyse-apply analyse funcT funcA args) + (-> &;Analyser Type Analysis (List Code) (Meta Analysis)) + (&;with-stacked-errors + (function [_] + (Cannot-Apply-Function (format " Function: " (%type funcT) "\n" + "Arguments: " (|> args (list/map %code) (text;join-with " "))))) + (do meta;Monad + [expected meta;expected-type + [applyT argsA] (&inference;apply-function analyse funcT args) + _ (&;with-type-env + (tc;check expected applyT))] + (wrap (la;apply argsA funcA))))) diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux new file mode 100644 index 000000000..cd484a623 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/inference.lux @@ -0,0 +1,228 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + [text] + text/format + (coll [list "list/" Functor])) + [meta #+ Monad] + (meta [type] + (type ["tc" check]))) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis] + (analysis ["&;" common])))) + +(exception: #export Cannot-Infer) +(exception: #export Cannot-Infer-Argument) +(exception: #export Smaller-Variant-Than-Expected) + +## When doing inference, type-variables often need to be created in +## order to figure out which types are present in the expression being +## inferred. +## If a type-variable never gets bound/resolved to a type, then that +## means the expression can be generalized through universal +## quantification. +## When that happens, the type-variable must be replaced by an +## argument to the universally-quantified type. +(def: #export (replace-var var-id bound-idx type) + (-> Nat Nat Type Type) + (case type + (#;Primitive name params) + (#;Primitive name (list/map (replace-var var-id bound-idx) params)) + + (^template [] + ( left right) + ( (replace-var var-id bound-idx left) + (replace-var var-id bound-idx right))) + ([#;Sum] + [#;Product] + [#;Function] + [#;Apply]) + + (#;Var id) + (if (n.= var-id id) + (#;Bound bound-idx) + type) + + (^template [] + ( env quantified) + ( (list/map (replace-var var-id bound-idx) env) + (replace-var var-id (n.+ +2 bound-idx) quantified))) + ([#;UnivQ] + [#;ExQ]) + + _ + type)) + +(def: (replace-bound bound-idx replacementT type) + (-> Nat Type Type Type) + (case type + (#;Primitive name params) + (#;Primitive name (list/map (replace-bound bound-idx replacementT) params)) + + (^template [] + ( left right) + ( (replace-bound bound-idx replacementT left) + (replace-bound bound-idx replacementT right))) + ([#;Sum] + [#;Product] + [#;Function] + [#;Apply]) + + (#;Bound idx) + (if (n.= bound-idx idx) + replacementT + type) + + (^template [] + ( env quantified) + ( (list/map (replace-bound bound-idx replacementT) env) + (replace-bound (n.+ +2 bound-idx) replacementT quantified))) + ([#;UnivQ] + [#;ExQ]) + + _ + type)) + +## Type-inference works by applying some (potentially quantified) type +## to a sequence of values. +## Function types are used for this, although inference is not always +## done for function application (alternative uses may be records and +## tagged variants). +## But, so long as the type being used for the inference can be trated +## as a function type, this method of inference should work. +(def: #export (apply-function analyse funcT args) + (-> &;Analyser Type (List Code) (Meta [Type (List Analysis)])) + (case args + #;Nil + (:: Monad wrap [funcT (list)]) + + (#;Cons argC args') + (case funcT + (#;Named name unnamedT) + (apply-function analyse unnamedT args) + + (#;UnivQ _) + (&common;with-var + (function [[var-id varT]] + (do Monad + [[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) funcT)) args)] + (do @ + [? (&;with-type-env + (tc;bound? var-id)) + ## Quantify over the type if genericity/parametricity + ## is discovered. + outputT' (if ? + (&;with-type-env + (tc;clean var-id outputT)) + (wrap (type;univ-q +1 (replace-var var-id +1 outputT))))] + (wrap [outputT' argsA]))))) + + (#;ExQ _) + (do Monad + [[ex-id exT] (&;with-type-env + tc;existential)] + (apply-function analyse (maybe;assume (type;apply (list exT) funcT)) args)) + + ## Arguments are inferred back-to-front because, by convention, + ## Lux functions take the most important arguments *last*, which + ## means that the most information for doing proper inference is + ## located in the last arguments to a function call. + ## By inferring back-to-front, a lot of type-annotations can be + ## avoided in Lux code, since the inference algorithm can piece + ## things together more easily. + (#;Function inputT outputT) + (do Monad + [[outputT' args'A] (apply-function analyse outputT args') + argA (&;with-stacked-errors + (function [_] (Cannot-Infer-Argument + (format "Inferred Type: " (%type inputT) "\n" + " Argument: " (%code argC)))) + (&;with-expected-type inputT + (analyse argC)))] + (wrap [outputT' (list& argA args'A)])) + + _ + (&;throw Cannot-Infer (format "Inference Type: " (%type funcT) + " Arguments: " (|> args (list/map %code) (text;join-with " "))))) + )) + +## Turns a record type into the kind of function type suitable for inference. +(def: #export (record type) + (-> Type (Meta Type)) + (case type + (#;Named name unnamedT) + (do Monad + [unnamedT+ (record unnamedT)] + (wrap unnamedT+)) + + (^template [] + ( env bodyT) + (do Monad + [bodyT+ (record bodyT)] + (wrap ( env bodyT+)))) + ([#;UnivQ] + [#;ExQ]) + + (#;Product _) + (:: Monad wrap (type;function (type;flatten-tuple type) type)) + + _ + (&;fail (format "Not a record type: " (%type type))))) + +## Turns a variant type into the kind of function type suitable for inference. +(def: #export (variant tag expected-size type) + (-> Nat Nat Type (Meta Type)) + (loop [depth +0 + currentT type] + (case currentT + (#;Named name unnamedT) + (do Monad + [unnamedT+ (recur depth unnamedT)] + (wrap unnamedT+)) + + (^template [] + ( env bodyT) + (do Monad + [bodyT+ (recur (n.inc depth) bodyT)] + (wrap ( env bodyT+)))) + ([#;UnivQ] + [#;ExQ]) + + (#;Sum _) + (let [cases (type;flatten-variant currentT) + actual-size (list;size cases) + boundary (n.dec expected-size)] + (cond (or (n.= expected-size actual-size) + (and (n.> expected-size actual-size) + (n.< boundary tag))) + (case (list;nth tag cases) + (#;Some caseT) + (:: Monad wrap (if (n.= +0 depth) + (type;function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] + (type;function (list (replace! caseT)) + (replace! currentT))))) + + #;None + (&common;variant-out-of-bounds-error type expected-size tag)) + + (n.< expected-size actual-size) + (&;throw Smaller-Variant-Than-Expected + (format "Expected: " (%i (nat-to-int expected-size)) "\n" + " Actual: " (%i (nat-to-int actual-size)))) + + (n.= boundary tag) + (let [caseT (type;variant (list;drop boundary cases))] + (:: Monad wrap (if (n.= +0 depth) + (type;function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] + (type;function (list (replace! caseT)) + (replace! currentT)))))) + + ## else + (&common;variant-out-of-bounds-error type expected-size tag))) + + _ + (&;fail (format "Not a variant type: " (%type type)))))) diff --git a/new-luxc/source/luxc/lang/analysis/primitive.lux b/new-luxc/source/luxc/lang/analysis/primitive.lux new file mode 100644 index 000000000..c7f7243fd --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/primitive.lux @@ -0,0 +1,34 @@ +(;module: + lux + (lux (control monad) + [meta] + (meta [code] + (type ["tc" check]))) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis]))) + +## [Analysers] +(do-template [ ] + [(def: #export ( value) + (-> (Meta Analysis)) + (do meta;Monad + [expected meta;expected-type + _ (&;with-type-env + (tc;check expected ))] + (wrap ( value))))] + + [analyse-bool Bool code;bool] + [analyse-nat Nat code;nat] + [analyse-int Int code;int] + [analyse-deg Deg code;deg] + [analyse-frac Frac code;frac] + [analyse-text Text code;text] + ) + +(def: #export analyse-unit + (Meta Analysis) + (do meta;Monad + [expected meta;expected-type + _ (&;with-type-env + (tc;check expected Unit))] + (wrap (` [])))) diff --git a/new-luxc/source/luxc/lang/analysis/procedure.lux b/new-luxc/source/luxc/lang/analysis/procedure.lux new file mode 100644 index 000000000..225fb7b23 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/procedure.lux @@ -0,0 +1,23 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data [maybe] + [text] + text/format + (coll [dict]))) + (luxc ["&" base] + (lang ["la" analysis])) + (. ["./;" common] + ["./;" host])) + +(def: procedures + ./common;Bundle + (|> ./common;procedures + (dict;merge ./host;procedures))) + +(def: #export (analyse-procedure analyse eval proc-name proc-args) + (-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis)) + (<| (maybe;default (&;fail (format "Unknown procedure: " (%t proc-name)))) + (do maybe;Monad + [proc (dict;get proc-name procedures)] + (wrap (proc analyse eval proc-args))))) diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux new file mode 100644 index 000000000..e06a3d2b4 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux @@ -0,0 +1,418 @@ +(;module: + lux + (lux (control [monad #+ do]) + (concurrency ["A" atom]) + (data [text] + text/format + (coll [list "list/" Functor] + [array] + [dict #+ Dict])) + [meta] + (meta [code] + (type ["tc" check])) + [io]) + (luxc ["&" base] + (lang ["la" analysis] + (analysis ["&;" common] + [";A" function] + [";A" case] + [";A" type])))) + +## [Utils] +(type: #export Proc + (-> &;Analyser &;Eval (List Code) (Meta la;Analysis))) + +(type: #export Bundle + (Dict Text Proc)) + +(def: #export (install name unnamed) + (-> Text (-> Text Proc) + (-> Bundle Bundle)) + (dict;put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict;entries + (list/map (function [[key val]] [(format prefix " " key) val])) + (dict;from-list text;Hash))) + +(def: #export (wrong-arity proc expected actual) + (-> Text Nat Nat Text) + (format "Wrong arity for " (%t proc) "\n" + "Expected: " (|> expected nat-to-int %i) "\n" + " Actual: " (|> actual nat-to-int %i))) + +(def: (simple proc input-types output-type) + (-> Text (List Type) Type Proc) + (let [num-expected (list;size input-types)] + (function [analyse eval args] + (let [num-actual (list;size args)] + (if (n.= num-expected num-actual) + (do meta;Monad + [argsA (monad;map @ + (function [[argT argC]] + (&;with-expected-type argT + (analyse argC))) + (list;zip2 input-types args)) + expected meta;expected-type + _ (&;with-type-env + (tc;check expected output-type))] + (wrap (la;procedure proc argsA))) + (&;fail (wrong-arity proc num-expected num-actual))))))) + +(def: #export (nullary valueT proc) + (-> Type Text Proc) + (simple proc (list) valueT)) + +(def: #export (unary inputT outputT proc) + (-> Type Type Text Proc) + (simple proc (list inputT) outputT)) + +(def: #export (binary subjectT paramT outputT proc) + (-> Type Type Type Text Proc) + (simple proc (list subjectT paramT) outputT)) + +(def: #export (trinary subjectT param0T param1T outputT proc) + (-> Type Type Type Type Text Proc) + (simple proc (list subjectT param0T param1T) outputT)) + +## [Analysers] +## "lux is" represents reference/pointer equality. +(def: (lux-is proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + ((binary varT varT Bool proc) + analyse eval args))))) + +## "lux try" provides a simple way to interact with the host platform's +## error-handling facilities. +(def: (lux-try proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list opC)) + (do meta;Monad + [opA (&;with-expected-type (type (io;IO varT)) + (analyse opC)) + outputT (&;with-type-env + (tc;clean var-id (type (Either Text varT)))) + expected meta;expected-type + _ (&;with-type-env + (tc;check expected outputT))] + (wrap (la;procedure proc (list opA)))) + + _ + (&;fail (wrong-arity proc +1 (list;size args)))))))) + +(def: (lux//function proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list [_ (#;Symbol ["" func-name])] + [_ (#;Symbol ["" arg-name])] + body)) + (functionA;analyse-function analyse func-name arg-name body) + + _ + (&;fail (wrong-arity proc +3 (list;size args)))))))) + +(def: (lux//case proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list input [_ (#;Record branches)])) + (caseA;analyse-case analyse input branches) + + _ + (&;fail (wrong-arity proc +2 (list;size args)))))))) + +(do-template [ ] + [(def: ( proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list typeC valueC)) + ( analyse eval typeC valueC) + + _ + (&;fail (wrong-arity proc +2 (list;size args))))))))] + + [lux//check typeA;analyse-check] + [lux//coerce typeA;analyse-coerce]) + +(def: (lux//check//type proc) + (-> Text Proc) + (function [analyse eval args] + (case args + (^ (list valueC)) + (do meta;Monad + [valueA (&;with-expected-type Type + (analyse valueC)) + expected meta;expected-type + _ (&;with-type-env + (tc;check expected Type))] + (wrap valueA)) + + _ + (&;fail (wrong-arity proc +1 (list;size args)))))) + +(def: lux-procs + Bundle + (|> (dict;new text;Hash) + (install "is" lux-is) + (install "try" lux-try) + (install "function" lux//function) + (install "case" lux//case) + (install "check" lux//check) + (install "coerce" lux//coerce) + (install "check type" lux//check//type))) + +(def: io-procs + Bundle + (<| (prefix "io") + (|> (dict;new text;Hash) + (install "log" (unary Text Unit)) + (install "error" (unary Text Bottom)) + (install "exit" (unary Nat Bottom)) + (install "current-time" (nullary Int))))) + +(def: bit-procs + Bundle + (<| (prefix "bit") + (|> (dict;new text;Hash) + (install "count" (unary Nat Nat)) + (install "and" (binary Nat Nat Nat)) + (install "or" (binary Nat Nat Nat)) + (install "xor" (binary Nat Nat Nat)) + (install "shift-left" (binary Nat Nat Nat)) + (install "unsigned-shift-right" (binary Nat Nat Nat)) + (install "shift-right" (binary Int Nat Int)) + ))) + +(def: nat-procs + Bundle + (<| (prefix "nat") + (|> (dict;new text;Hash) + (install "+" (binary Nat Nat Nat)) + (install "-" (binary Nat Nat Nat)) + (install "*" (binary Nat Nat Nat)) + (install "/" (binary Nat Nat Nat)) + (install "%" (binary Nat Nat Nat)) + (install "=" (binary Nat Nat Bool)) + (install "<" (binary Nat Nat Bool)) + (install "min" (nullary Nat)) + (install "max" (nullary Nat)) + (install "to-int" (unary Nat Int)) + (install "to-text" (unary Nat Text))))) + +(def: int-procs + Bundle + (<| (prefix "int") + (|> (dict;new text;Hash) + (install "+" (binary Int Int Int)) + (install "-" (binary Int Int Int)) + (install "*" (binary Int Int Int)) + (install "/" (binary Int Int Int)) + (install "%" (binary Int Int Int)) + (install "=" (binary Int Int Bool)) + (install "<" (binary Int Int Bool)) + (install "min" (nullary Int)) + (install "max" (nullary Int)) + (install "to-nat" (unary Int Nat)) + (install "to-frac" (unary Int Frac))))) + +(def: deg-procs + Bundle + (<| (prefix "deg") + (|> (dict;new text;Hash) + (install "+" (binary Deg Deg Deg)) + (install "-" (binary Deg Deg Deg)) + (install "*" (binary Deg Deg Deg)) + (install "/" (binary Deg Deg Deg)) + (install "%" (binary Deg Deg Deg)) + (install "=" (binary Deg Deg Bool)) + (install "<" (binary Deg Deg Bool)) + (install "scale" (binary Deg Nat Deg)) + (install "reciprocal" (binary Deg Nat Deg)) + (install "min" (nullary Deg)) + (install "max" (nullary Deg)) + (install "to-frac" (unary Deg Frac))))) + +(def: frac-procs + Bundle + (<| (prefix "frac") + (|> (dict;new text;Hash) + (install "+" (binary Frac Frac Frac)) + (install "-" (binary Frac Frac Frac)) + (install "*" (binary Frac Frac Frac)) + (install "/" (binary Frac Frac Frac)) + (install "%" (binary Frac Frac Frac)) + (install "=" (binary Frac Frac Bool)) + (install "<" (binary Frac Frac Bool)) + (install "smallest" (nullary Frac)) + (install "min" (nullary Frac)) + (install "max" (nullary Frac)) + (install "not-a-number" (nullary Frac)) + (install "positive-infinity" (nullary Frac)) + (install "negative-infinity" (nullary Frac)) + (install "to-deg" (unary Frac Deg)) + (install "to-int" (unary Frac Int)) + (install "encode" (unary Frac Text)) + (install "decode" (unary Text (type (Maybe Frac))))))) + +(def: text-procs + Bundle + (<| (prefix "text") + (|> (dict;new text;Hash) + (install "=" (binary Text Text Bool)) + (install "<" (binary Text Text Bool)) + (install "prepend" (binary Text Text Text)) + (install "index" (trinary Text Text Nat (type (Maybe Nat)))) + (install "size" (unary Text Nat)) + (install "hash" (unary Text Nat)) + (install "replace-once" (trinary Text Text Text Text)) + (install "replace-all" (trinary Text Text Text Text)) + (install "char" (binary Text Nat Nat)) + (install "clip" (trinary Text Nat Nat Text)) + ))) + +(def: (array-get proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + ((binary Nat (type (Array varT)) varT proc) + analyse eval args))))) + +(def: (array-put proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc) + analyse eval args))))) + +(def: (array-remove proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + ((binary Nat (type (Array varT)) (type (Array varT)) proc) + analyse eval args))))) + +(def: array-procs + Bundle + (<| (prefix "array") + (|> (dict;new text;Hash) + (install "new" (unary Nat Array)) + (install "get" array-get) + (install "put" array-put) + (install "remove" array-remove) + (install "size" (unary (type (Ex [a] (Array a))) Nat)) + ))) + +(def: math-procs + Bundle + (<| (prefix "math") + (|> (dict;new text;Hash) + (install "cos" (unary Frac Frac)) + (install "sin" (unary Frac Frac)) + (install "tan" (unary Frac Frac)) + (install "acos" (unary Frac Frac)) + (install "asin" (unary Frac Frac)) + (install "atan" (unary Frac Frac)) + (install "cosh" (unary Frac Frac)) + (install "sinh" (unary Frac Frac)) + (install "tanh" (unary Frac Frac)) + (install "exp" (unary Frac Frac)) + (install "log" (unary Frac Frac)) + (install "root2" (unary Frac Frac)) + (install "root3" (unary Frac Frac)) + (install "ceil" (unary Frac Frac)) + (install "floor" (unary Frac Frac)) + (install "round" (unary Frac Frac)) + (install "atan2" (binary Frac Frac Frac)) + (install "pow" (binary Frac Frac Frac)) + ))) + +(def: (atom-new proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list initC)) + (do meta;Monad + [initA (&;with-expected-type varT + (analyse initC)) + outputT (&;with-type-env + (tc;clean var-id (type (A;Atom varT)))) + expected meta;expected-type + _ (&;with-type-env + (tc;check expected outputT))] + (wrap (la;procedure proc (list initA)))) + + _ + (&;fail (wrong-arity proc +1 (list;size args)))))))) + +(def: (atom-read proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + ((unary (type (A;Atom varT)) varT proc) + analyse eval args))))) + +(def: (atom-compare-and-swap proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + ((trinary varT varT (type (A;Atom varT)) Bool proc) + analyse eval args))))) + +(def: atom-procs + Bundle + (<| (prefix "atom") + (|> (dict;new text;Hash) + (install "new" atom-new) + (install "read" atom-read) + (install "compare-and-swap" atom-compare-and-swap) + ))) + +(def: process-procs + Bundle + (<| (prefix "process") + (|> (dict;new text;Hash) + (install "concurrency-level" (nullary Nat)) + (install "future" (unary (type (io;IO Top)) Unit)) + (install "schedule" (binary Nat (type (io;IO Top)) Unit)) + ))) + +(def: #export procedures + Bundle + (<| (prefix "lux") + (|> (dict;new text;Hash) + (dict;merge lux-procs) + (dict;merge bit-procs) + (dict;merge nat-procs) + (dict;merge int-procs) + (dict;merge deg-procs) + (dict;merge frac-procs) + (dict;merge text-procs) + (dict;merge array-procs) + (dict;merge math-procs) + (dict;merge atom-procs) + (dict;merge process-procs) + (dict;merge io-procs)))) diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux new file mode 100644 index 000000000..3ba7713ac --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux @@ -0,0 +1,1241 @@ +(;module: + [lux #- char] + (lux (control [monad #+ do] + ["p" parser] + ["ex" exception #+ exception:]) + (concurrency ["A" atom]) + (data ["e" error] + [maybe] + [product] + [bool "bool/" Eq] + [text "text/" Eq] + (text format + ["l" lexer]) + (coll [list "list/" Fold Functor Monoid] + [array] + [dict #+ Dict])) + [meta "meta/" Monad] + (meta [code] + ["s" syntax] + [type] + (type ["tc" check])) + [host]) + (luxc ["&" base] + ["&;" host] + (lang ["la" analysis] + (analysis ["&;" common] + ["&;" inference]))) + ["@" ../common] + ) + +(def: #export null-class Text "#Null") + +(do-template [ ] + [(def: #export Type (#;Primitive (list)))] + + ## Boxes + [Boolean "java.lang.Boolean"] + [Byte "java.lang.Byte"] + [Short "java.lang.Short"] + [Integer "java.lang.Integer"] + [Long "java.lang.Long"] + [Float "java.lang.Float"] + [Double "java.lang.Double"] + [Character "java.lang.Character"] + [String "java.lang.String"] + + ## Primitives + [boolean "boolean"] + [byte "byte"] + [short "short"] + [int "int"] + [long "long"] + [float "float"] + [double "double"] + [char "char"] + ) + +(def: conversion-procs + @;Bundle + (<| (@;prefix "convert") + (|> (dict;new text;Hash) + (@;install "double-to-float" (@;unary Double Float)) + (@;install "double-to-int" (@;unary Double Integer)) + (@;install "double-to-long" (@;unary Double Long)) + (@;install "float-to-double" (@;unary Float Double)) + (@;install "float-to-int" (@;unary Float Integer)) + (@;install "float-to-long" (@;unary Float Long)) + (@;install "int-to-byte" (@;unary Integer Byte)) + (@;install "int-to-char" (@;unary Integer Character)) + (@;install "int-to-double" (@;unary Integer Double)) + (@;install "int-to-float" (@;unary Integer Float)) + (@;install "int-to-long" (@;unary Integer Long)) + (@;install "int-to-short" (@;unary Integer Short)) + (@;install "long-to-double" (@;unary Long Double)) + (@;install "long-to-float" (@;unary Long Float)) + (@;install "long-to-int" (@;unary Long Integer)) + (@;install "long-to-short" (@;unary Long Short)) + (@;install "long-to-byte" (@;unary Long Byte)) + (@;install "char-to-byte" (@;unary Character Byte)) + (@;install "char-to-short" (@;unary Character Short)) + (@;install "char-to-int" (@;unary Character Integer)) + (@;install "char-to-long" (@;unary Character Long)) + (@;install "byte-to-long" (@;unary Byte Long)) + (@;install "short-to-long" (@;unary Short Long)) + ))) + +(do-template [ ] + [(def: + @;Bundle + (<| (@;prefix ) + (|> (dict;new text;Hash) + (@;install "+" (@;binary )) + (@;install "-" (@;binary )) + (@;install "*" (@;binary )) + (@;install "/" (@;binary )) + (@;install "%" (@;binary )) + (@;install "=" (@;binary Boolean)) + (@;install "<" (@;binary Boolean)) + (@;install "and" (@;binary )) + (@;install "or" (@;binary )) + (@;install "xor" (@;binary )) + (@;install "shl" (@;binary Integer )) + (@;install "shr" (@;binary Integer )) + (@;install "ushr" (@;binary Integer )) + )))] + + [int-procs "int" Integer] + [long-procs "long" Long] + ) + +(do-template [ ] + [(def: + @;Bundle + (<| (@;prefix ) + (|> (dict;new text;Hash) + (@;install "+" (@;binary )) + (@;install "-" (@;binary )) + (@;install "*" (@;binary )) + (@;install "/" (@;binary )) + (@;install "%" (@;binary )) + (@;install "=" (@;binary Boolean)) + (@;install "<" (@;binary Boolean)) + )))] + + [float-procs "float" Float] + [double-procs "double" Double] + ) + +(def: char-procs + @;Bundle + (<| (@;prefix "char") + (|> (dict;new text;Hash) + (@;install "=" (@;binary Character Character Boolean)) + (@;install "<" (@;binary Character Character Boolean)) + ))) + +(def: #export boxes + (Dict Text Text) + (|> (list ["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + (dict;from-list text;Hash))) + +(def: (array-length proc) + (-> Text @;Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list arrayC)) + (do meta;Monad + [arrayA (&;with-expected-type (type (Array varT)) + (analyse arrayC)) + _ (&;infer Nat)] + (wrap (la;procedure proc (list arrayA)))) + + _ + (&;fail (@;wrong-arity proc +1 (list;size args)))))))) + +(def: (invalid-array-type arrayT) + (-> Type Text) + (format "Invalid type for array: " (%type arrayT))) + +(def: (array-new proc) + (-> Text @;Proc) + (function [analyse eval args] + (case args + (^ (list lengthC)) + (do meta;Monad + [lengthA (&;with-expected-type Nat + (analyse lengthC)) + expectedT meta;expected-type + [level elem-class] (: (Meta [Nat Text]) + (loop [analysisT expectedT + level +0] + (case analysisT + (#;Apply inputT funcT) + (case (type;apply (list inputT) funcT) + (#;Some outputT) + (recur outputT level) + + #;None + (&;fail (invalid-array-type expectedT))) + + (^ (#;Primitive "#Array" (list elemT))) + (recur elemT (n.inc level)) + + (#;Primitive class _) + (wrap [level class]) + + _ + (&;fail (invalid-array-type expectedT))))) + _ (&;assert "Must have at least 1 level of nesting in array type." + (n.> +0 level))] + (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA)))) + + _ + (&;fail (@;wrong-arity proc +1 (list;size args)))))) + +(exception: #export Not-Object-Type) + +(def: (check-jvm objectT) + (-> Type (Meta Text)) + (case objectT + (#;Primitive name _) + (meta/wrap name) + + (#;Named name unnamed) + (check-jvm unnamed) + + (#;Var id) + (meta/wrap "java.lang.Object") + + (^template [] + ( env unquantified) + (check-jvm unquantified)) + ([#;UnivQ] + [#;ExQ]) + + (#;Apply inputT funcT) + (case (type;apply (list inputT) funcT) + (#;Some outputT) + (check-jvm outputT) + + #;None + (&;throw Not-Object-Type (%type objectT))) + + _ + (&;throw Not-Object-Type (%type objectT)))) + +(def: (check-object objectT) + (-> Type (Meta Text)) + (do meta;Monad + [name (check-jvm objectT)] + (if (dict;contains? name boxes) + (&;fail (format "Primitives are not objects: " name)) + (:: meta;Monad wrap name)))) + +(def: (box-array-element-type elemT) + (-> Type (Meta [Type Text])) + (do meta;Monad + [] + (case elemT + (#;Primitive name #;Nil) + (let [boxed-name (|> (dict;get name boxes) + (maybe;default name))] + (wrap [(#;Primitive boxed-name #;Nil) + boxed-name])) + + (#;Primitive name _) + (if (dict;contains? name boxes) + (&;fail (format "Primitives cannot be parameterized: " name)) + (:: meta;Monad wrap [elemT name])) + + _ + (&;fail (format "Invalid type for array element: " (%type elemT)))))) + +(def: (array-read proc) + (-> Text @;Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list arrayC idxC)) + (do meta;Monad + [arrayA (&;with-expected-type (type (Array varT)) + (analyse arrayC)) + elemT (&;with-type-env + (tc;read var-id)) + [elemT elem-class] (box-array-element-type elemT) + idxA (&;with-expected-type Nat + (analyse idxC)) + _ (&;infer elemT)] + (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA)))) + + _ + (&;fail (@;wrong-arity proc +2 (list;size args)))))))) + +(def: (array-write proc) + (-> Text @;Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list arrayC idxC valueC)) + (do meta;Monad + [arrayA (&;with-expected-type (type (Array varT)) + (analyse arrayC)) + elemT (&;with-type-env + (tc;read var-id)) + [valueT elem-class] (box-array-element-type elemT) + idxA (&;with-expected-type Nat + (analyse idxC)) + valueA (&;with-expected-type valueT + (analyse valueC)) + _ (&;infer (type (Array elemT)))] + (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA)))) + + _ + (&;fail (@;wrong-arity proc +3 (list;size args)))))))) + +(def: array-procs + @;Bundle + (<| (@;prefix "array") + (|> (dict;new text;Hash) + (@;install "length" array-length) + (@;install "new" array-new) + (@;install "read" array-read) + (@;install "write" array-write) + ))) + +(def: (object-null proc) + (-> Text @;Proc) + (function [analyse eval args] + (case args + (^ (list)) + (do meta;Monad + [expectedT meta;expected-type + _ (check-object expectedT)] + (wrap (la;procedure proc (list)))) + + _ + (&;fail (@;wrong-arity proc +0 (list;size args)))))) + +(def: (object-null? proc) + (-> Text @;Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list objectC)) + (do meta;Monad + [objectA (&;with-expected-type varT + (analyse objectC)) + objectT (&;with-type-env + (tc;read var-id)) + _ (check-object objectT) + _ (&;infer Bool)] + (wrap (la;procedure proc (list objectA)))) + + _ + (&;fail (@;wrong-arity proc +1 (list;size args)))))))) + +(def: (object-synchronized proc) + (-> Text @;Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list monitorC exprC)) + (do meta;Monad + [monitorA (&;with-expected-type varT + (analyse monitorC)) + monitorT (&;with-type-env + (tc;read var-id)) + _ (check-object monitorT) + exprA (analyse exprC)] + (wrap (la;procedure proc (list monitorA exprA)))) + + _ + (&;fail (@;wrong-arity proc +2 (list;size args)))))))) + +(host;import java.lang.Object + (equals [Object] boolean)) + +(host;import java.lang.ClassLoader) + +(host;import #long java.lang.reflect.Type + (getTypeName [] String)) + +(host;import java.lang.reflect.GenericArrayType + (getGenericComponentType [] java.lang.reflect.Type)) + +(host;import java.lang.reflect.ParameterizedType + (getRawType [] java.lang.reflect.Type) + (getActualTypeArguments [] (Array java.lang.reflect.Type))) + +(host;import (java.lang.reflect.TypeVariable d) + (getName [] String) + (getBounds [] (Array java.lang.reflect.Type))) + +(host;import (java.lang.reflect.WildcardType d) + (getLowerBounds [] (Array java.lang.reflect.Type)) + (getUpperBounds [] (Array java.lang.reflect.Type))) + +(host;import java.lang.reflect.Modifier + (#static isStatic [int] boolean) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)) + +(host;import java.lang.reflect.Field + (getDeclaringClass [] (java.lang.Class Object)) + (getModifiers [] int) + (getGenericType [] java.lang.reflect.Type)) + +(host;import java.lang.reflect.Method + (getName [] String) + (getModifiers [] int) + (getDeclaringClass [] (Class Object)) + (getTypeParameters [] (Array (TypeVariable Method))) + (getGenericParameterTypes [] (Array java.lang.reflect.Type)) + (getGenericReturnType [] java.lang.reflect.Type) + (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) + +(host;import (java.lang.reflect.Constructor c) + (getModifiers [] int) + (getDeclaringClass [] (Class c)) + (getTypeParameters [] (Array (TypeVariable (Constructor c)))) + (getGenericParameterTypes [] (Array java.lang.reflect.Type)) + (getGenericExceptionTypes [] (Array java.lang.reflect.Type))) + +(host;import (java.lang.Class c) + (getName [] String) + (getModifiers [] int) + (#static forName [String boolean ClassLoader] #try (Class Object)) + (isAssignableFrom [(Class Object)] boolean) + (getTypeParameters [] (Array (TypeVariable (Class c)))) + (getGenericInterfaces [] (Array java.lang.reflect.Type)) + (getGenericSuperclass [] java.lang.reflect.Type) + (getDeclaredField [String] #try Field) + (getConstructors [] (Array (Constructor Object))) + (getDeclaredMethods [] (Array Method))) + +(def: (load-class name) + (-> Text (Meta (Class Object))) + (do meta;Monad + [class-loader &host;class-loader] + (case (Class.forName [name false class-loader]) + (#e;Success [class]) + (wrap class) + + (#e;Error error) + (&;fail (format "Unknown class: " name))))) + +(def: (sub-class? super sub) + (-> Text Text (Meta Bool)) + (do meta;Monad + [super (load-class super) + sub (load-class sub)] + (wrap (Class.isAssignableFrom [sub] super)))) + +(exception: #export Not-Throwable) + +(def: (object-throw proc) + (-> Text @;Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list exceptionC)) + (do meta;Monad + [exceptionA (&;with-expected-type varT + (analyse exceptionC)) + exceptionT (&;with-type-env + (tc;read var-id)) + exception-class (check-object exceptionT) + ? (sub-class? "java.lang.Throwable" exception-class) + _ (: (Meta Unit) + (if ? + (wrap []) + (&;throw Not-Throwable exception-class))) + _ (&;infer Bottom)] + (wrap (la;procedure proc (list exceptionA)))) + + _ + (&;fail (@;wrong-arity proc +1 (list;size args)))))))) + +(def: (object-class proc) + (-> Text @;Proc) + (function [analyse eval args] + (case args + (^ (list classC)) + (case classC + [_ (#;Text class)] + (do meta;Monad + [_ (load-class class) + _ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))] + (wrap (la;procedure proc (list (code;text class))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))) + + _ + (&;fail (@;wrong-arity proc +1 (list;size args)))))) + +(exception: #export Cannot-Be-Instance) + +(def: (object-instance? proc) + (-> Text @;Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list classC objectC)) + (case classC + [_ (#;Text class)] + (do meta;Monad + [objectA (&;with-expected-type varT + (analyse objectC)) + objectT (&;with-type-env + (tc;read var-id)) + object-class (check-object objectT) + ? (sub-class? class object-class)] + (if ? + (do @ + [_ (&;infer Bool)] + (wrap (la;procedure proc (list (code;text class))))) + (&;throw Cannot-Be-Instance (format object-class " !<= " class)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))) + + _ + (&;fail (@;wrong-arity proc +2 (list;size args)))))))) + +(def: object-procs + @;Bundle + (<| (@;prefix "object") + (|> (dict;new text;Hash) + (@;install "null" object-null) + (@;install "null?" object-null?) + (@;install "synchronized" object-synchronized) + (@;install "throw" object-throw) + (@;install "class" object-class) + (@;install "instance?" object-instance?) + ))) + +(exception: #export Final-Field) + +(exception: #export Cannot-Convert-To-Class) +(exception: #export Cannot-Convert-To-Parameter) +(exception: #export Cannot-Convert-To-Lux-Type) +(exception: #export Cannot-Cast-To-Primitive) +(exception: #export JVM-Type-Is-Not-Class) + +(def: type-descriptor + (-> java.lang.reflect.Type Text) + (java.lang.reflect.Type.getTypeName [])) + +(def: (java-type-to-class type) + (-> java.lang.reflect.Type (Meta Text)) + (cond (host;instance? Class type) + (meta/wrap (Class.getName [] (:! Class type))) + + (host;instance? ParameterizedType type) + (java-type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type))) + + ## else + (&;throw Cannot-Convert-To-Class (type-descriptor type)))) + +(exception: #export Unknown-Type-Var) + +(type: Mappings + (Dict Text Type)) + +(def: fresh-mappings Mappings (dict;new text;Hash)) + +(def: (java-type-to-lux-type mappings java-type) + (-> Mappings java.lang.reflect.Type (Meta Type)) + (cond (host;instance? TypeVariable java-type) + (let [var-name (TypeVariable.getName [] (:! TypeVariable java-type))] + (case (dict;get var-name mappings) + (#;Some var-type) + (meta/wrap var-type) + + #;None + (&;throw Unknown-Type-Var var-name))) + + (host;instance? WildcardType java-type) + (let [java-type (:! WildcardType java-type)] + (case [(array;read +0 (WildcardType.getUpperBounds [] java-type)) + (array;read +0 (WildcardType.getLowerBounds [] java-type))] + (^or [(#;Some bound) _] [_ (#;Some bound)]) + (java-type-to-lux-type mappings bound) + + _ + (meta/wrap Top))) + + (host;instance? Class java-type) + (let [java-type (:! (Class Object) java-type) + class-name (Class.getName [] java-type)] + (meta/wrap (case (array;size (Class.getTypeParameters [] java-type)) + +0 + (#;Primitive class-name (list)) + + arity + (|> (list;n.range +0 (n.dec arity)) + list;reverse + (list/map (|>. (n.* +2) n.inc #;Bound)) + (#;Primitive class-name) + (type;univ-q arity))))) + + (host;instance? ParameterizedType java-type) + (let [java-type (:! ParameterizedType java-type) + raw (ParameterizedType.getRawType [] java-type)] + (if (host;instance? Class raw) + (do meta;Monad + [paramsT (|> java-type + (ParameterizedType.getActualTypeArguments []) + array;to-list + (monad;map @ (java-type-to-lux-type mappings)))] + (meta/wrap (#;Primitive (Class.getName [] (:! (Class Object) raw)) + paramsT))) + (&;throw JVM-Type-Is-Not-Class (type-descriptor raw)))) + + (host;instance? GenericArrayType java-type) + (do meta;Monad + [innerT (|> (:! GenericArrayType java-type) + (GenericArrayType.getGenericComponentType []) + (java-type-to-lux-type mappings))] + (wrap (#;Primitive "#Array" (list innerT)))) + + ## else + (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) + +(type: Direction + #In + #Out) + +(def: (choose direction to from) + (-> Direction Text Text Text) + (case direction + #In to + #Out from)) + +(def: (correspond-type-params class type) + (-> (Class Object) Type (Meta Mappings)) + (case type + (#;Primitive name params) + (let [class-name (Class.getName [] class) + class-params (array;to-list (Class.getTypeParameters [] class))] + (if (text/= class-name name) + (if (n.= (list;size class-params) + (list;size params)) + (meta/wrap (|> params + (list;zip2 (list/map (TypeVariable.getName []) class-params)) + (dict;from-list text;Hash))) + (&;fail (format "Class and host-type parameters do not match: " "class = " class-name " | host type = " name))) + (&;fail (format "Class and host-type names do not match: " "class = " class-name " | host type = " name)))) + + _ + (&;fail (format "Not a host type: " (%type type))))) + +(def: (cast direction to from) + (-> Direction Type Type (Meta [Text Type])) + (do meta;Monad + [to-name (check-jvm to) + from-name (check-jvm from)] + (cond (dict;contains? to-name boxes) + (let [box (maybe;assume (dict;get to-name boxes))] + (if (text/= box from-name) + (wrap [(choose direction to-name from-name) (#;Primitive to-name (list))]) + (&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name)))) + + (dict;contains? from-name boxes) + (let [box (maybe;assume (dict;get from-name boxes))] + (do @ + [[_ castT] (cast direction to (#;Primitive box (list)))] + (wrap [(choose direction to-name from-name) castT]))) + + (text/= to-name from-name) + (wrap [(choose direction to-name from-name) from]) + + (text/= null-class from-name) + (wrap [(choose direction to-name from-name) to]) + + ## else + (do @ + [to-class (load-class to-name) + from-class (load-class from-name) + _ (&;assert (format "Class '" from-name "' is not a sub-class of class '" to-name "'.") + (Class.isAssignableFrom [from-class] to-class)) + candiate-parents (monad;map @ + (function [java-type] + (do @ + [class-name (java-type-to-class java-type) + class (load-class class-name)] + (wrap [java-type (Class.isAssignableFrom [class] to-class)]))) + (list& (Class.getGenericSuperclass [] from-class) + (array;to-list (Class.getGenericInterfaces [] from-class))))] + (case (|> candiate-parents + (list;filter product;right) + (list/map product;left)) + (#;Cons parent _) + (do @ + [mapping (correspond-type-params from-class from) + parentT (java-type-to-lux-type mapping parent) + [_ castT] (cast direction to parentT)] + (wrap [(choose direction to-name from-name) castT])) + + #;Nil + (&;fail (format "No valid path between " (%type from) "and " (%type to) "."))))))) + +(def: (infer-out outputT) + (-> Type (Meta [Text Type])) + (do meta;Monad + [expectedT meta;expected-type + [unboxed castT] (cast #Out expectedT outputT) + _ (&;with-type-env + (tc;check expectedT castT))] + (wrap [unboxed castT]))) + +(def: (find-field class-name field-name) + (-> Text Text (Meta [(Class Object) Field])) + (do meta;Monad + [class (load-class class-name)] + (case (Class.getDeclaredField [field-name] class) + (#e;Success field) + (let [owner (Field.getDeclaringClass [] field)] + (if (is owner class) + (wrap [class field]) + (&;fail (format "Field '" field-name "' does not belong to class '" class-name "'.\n" + "Belongs to '" (Class.getName [] owner) "'.")))) + + (#e;Error _) + (&;fail (format "Unknown field '" field-name "' for class '" class-name "'."))))) + +(def: (static-field class-name field-name) + (-> Text Text (Meta [Type Bool])) + (do meta;Monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field.getModifiers [] fieldJ)]] + (if (Modifier.isStatic [modifiers]) + (let [fieldJT (Field.getGenericType [] fieldJ)] + (do @ + [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] + (wrap [fieldT (Modifier.isFinal [modifiers])]))) + (&;fail (format "Field '" field-name "' of class '" class-name "' is not static."))))) + +(exception: #export Non-Object-Type) + +(def: (virtual-field class-name field-name objectT) + (-> Text Text Type (Meta [Type Bool])) + (do meta;Monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field.getModifiers [] fieldJ)]] + (if (not (Modifier.isStatic [modifiers])) + (do @ + [#let [fieldJT (Field.getGenericType [] fieldJ) + var-names (|> class + (Class.getTypeParameters []) + array;to-list + (list/map (TypeVariable.getName [])))] + mappings (: (Meta Mappings) + (case objectT + (#;Primitive _class-name _class-params) + (do @ + [#let [num-params (list;size _class-params) + num-vars (list;size var-names)] + _ (&;assert (format "Number of paremeters in type does not match expected amount (" (%n num-vars) "): " (%type objectT)) + (n.= num-params num-vars))] + (wrap (|> (list;zip2 var-names _class-params) + (dict;from-list text;Hash)))) + + _ + (&;throw Non-Object-Type (%type objectT)))) + fieldT (java-type-to-lux-type mappings fieldJT)] + (wrap [fieldT (Modifier.isFinal [modifiers])])) + (&;fail (format "Field '" field-name "' of class '" class-name "' is static."))))) + +(def: (analyse-object class analyse sourceC) + (-> Text &;Analyser Code (Meta [Type la;Analysis])) + (<| &common;with-var (function [[var-id varT]]) + (do meta;Monad + [target-class (load-class class) + targetT (java-type-to-lux-type fresh-mappings + (:! java.lang.reflect.Type + target-class)) + sourceA (&;with-expected-type varT + (analyse sourceC)) + sourceT (&;with-type-env + (tc;read var-id)) + [unboxed castT] (cast #Out targetT sourceT) + _ (&;assert (format "Object cannot be a primitive: " unboxed) + (not (dict;contains? unboxed boxes)))] + (wrap [castT sourceA])))) + +(def: (analyse-input analyse targetT sourceC) + (-> &;Analyser Type Code (Meta [Type Text la;Analysis])) + (<| &common;with-var (function [[var-id varT]]) + (do meta;Monad + [sourceA (&;with-expected-type varT + (analyse sourceC)) + sourceT (&;with-type-env + (tc;read var-id)) + [unboxed castT] (cast #In targetT sourceT)] + (wrap [castT unboxed sourceA])))) + +(def: (static-get proc) + (-> Text @;Proc) + (function [analyse eval args] + (case args + (^ (list classC fieldC)) + (case [classC fieldC] + [[_ (#;Text class)] [_ (#;Text field)]] + (do meta;Monad + [[fieldT final?] (static-field class field) + [unboxed castT] (infer-out fieldT)] + (wrap (la;procedure proc (list (code;text class) (code;text field) + (code;text unboxed))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))) + + _ + (&;fail (@;wrong-arity proc +2 (list;size args)))))) + +(def: (static-put proc) + (-> Text @;Proc) + (function [analyse eval args] + (case args + (^ (list classC fieldC valueC)) + (case [classC fieldC] + [[_ (#;Text class)] [_ (#;Text field)]] + (do meta;Monad + [[fieldT final?] (static-field class field) + _ (&;assert (Final-Field (format class "#" field)) + (not final?)) + [valueT unboxed valueA] (analyse-input analyse fieldT valueC) + _ (&;with-type-env + (tc;check fieldT valueT)) + _ (&;infer Unit)] + (wrap (la;procedure proc (list (code;text class) (code;text field) + (code;text unboxed) valueA)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))) + + _ + (&;fail (@;wrong-arity proc +3 (list;size args)))))) + +(def: (virtual-get proc) + (-> Text @;Proc) + (function [analyse eval args] + (case args + (^ (list classC fieldC objectC)) + (case [classC fieldC] + [[_ (#;Text class)] [_ (#;Text field)]] + (do meta;Monad + [[objectT objectA] (analyse-object class analyse objectC) + [fieldT final?] (virtual-field class field objectT) + [unboxed castT] (infer-out fieldT)] + (wrap (la;procedure proc (list (code;text class) (code;text field) + (code;text unboxed) objectA)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))) + + _ + (&;fail (@;wrong-arity proc +3 (list;size args)))))) + +(def: (virtual-put proc) + (-> Text @;Proc) + (function [analyse eval args] + (case args + (^ (list classC fieldC valueC objectC)) + (case [classC fieldC] + [[_ (#;Text class)] [_ (#;Text field)]] + (do meta;Monad + [[objectT objectA] (analyse-object class analyse objectC) + [fieldT final?] (virtual-field class field objectT) + _ (&;assert (Final-Field (format class "#" field)) + (not final?)) + [valueT unboxed valueA] (analyse-input analyse fieldT valueC) + _ (&;with-type-env + (tc;check fieldT valueT)) + _ (&;infer objectT)] + (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))) + + _ + (&;fail (@;wrong-arity proc +4 (list;size args)))))) + +(def: (java-type-to-parameter type) + (-> java.lang.reflect.Type (Meta Text)) + (cond (host;instance? Class type) + (meta/wrap (Class.getName [] (:! Class type))) + + (host;instance? ParameterizedType type) + (java-type-to-parameter (ParameterizedType.getRawType [] (:! ParameterizedType type))) + + (or (host;instance? TypeVariable type) + (host;instance? WildcardType type)) + (meta/wrap "java.lang.Object") + + (host;instance? GenericArrayType type) + (do meta;Monad + [componentP (java-type-to-parameter (GenericArrayType.getGenericComponentType [] (:! GenericArrayType type)))] + (wrap (format componentP "[]"))) + + ## else + (&;throw Cannot-Convert-To-Parameter (type-descriptor type)))) + +(type: Method-Type + #Static + #Abstract + #Virtual + #Special + #Interface) + +(def: (check-method class method-name method-type arg-classes method) + (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool)) + (do meta;Monad + [parameters (|> (Method.getGenericParameterTypes [] method) + array;to-list + (monad;map @ java-type-to-parameter)) + #let [modifiers (Method.getModifiers [] method)]] + (wrap (and (Object.equals [class] (Method.getDeclaringClass [] method)) + (text/= method-name (Method.getName [] method)) + (case #Static + #Special + (Modifier.isStatic [modifiers]) + + _ + true) + (case method-type + #Special + (not (or (Modifier.isInterface [(Class.getModifiers [] class)]) + (Modifier.isAbstract [modifiers]))) + + _ + true) + (n.= (list;size arg-classes) (list;size parameters)) + (list/fold (function [[expectedJC actualJC] prev] + (and prev + (text/= expectedJC actualJC))) + true + (list;zip2 arg-classes parameters)))))) + +(def: (check-constructor class arg-classes constructor) + (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) + (do meta;Monad + [parameters (|> (Constructor.getGenericParameterTypes [] constructor) + array;to-list + (monad;map @ java-type-to-parameter))] + (wrap (and (Object.equals [class] (Constructor.getDeclaringClass [] constructor)) + (n.= (list;size arg-classes) (list;size parameters)) + (list/fold (function [[expectedJC actualJC] prev] + (and prev + (text/= expectedJC actualJC))) + true + (list;zip2 arg-classes parameters)))))) + +(def: idx-to-bound + (-> Nat Type) + (|>. (n.* +2) n.inc #;Bound)) + +(def: (type-vars amount offset) + (-> Nat Nat (List Type)) + (if (n.= +0 amount) + (list) + (|> (list;n.range offset (|> amount n.dec (n.+ offset))) + (list/map idx-to-bound)))) + +(def: (method-to-type method-type method) + (-> Method-Type Method (Meta [Type (List Type)])) + (let [owner (Method.getDeclaringClass [] method) + owner-name (Class.getName [] owner) + owner-tvars (case method-type + #Static + (list) + + _ + (|> (Class.getTypeParameters [] owner) + array;to-list + (list/map (TypeVariable.getName [])))) + method-tvars (|> (Method.getTypeParameters [] method) + array;to-list + (list/map (TypeVariable.getName []))) + num-owner-tvars (list;size owner-tvars) + num-method-tvars (list;size method-tvars) + all-tvars (list/compose owner-tvars method-tvars) + num-all-tvars (list;size all-tvars) + owner-tvarsT (type-vars num-owner-tvars +0) + method-tvarsT (type-vars num-method-tvars num-owner-tvars) + mappings (: Mappings + (if (list;empty? all-tvars) + fresh-mappings + (|> (list/compose owner-tvarsT method-tvarsT) + list;reverse + (list;zip2 all-tvars) + (dict;from-list text;Hash))))] + (do meta;Monad + [inputsT (|> (Method.getGenericParameterTypes [] method) + array;to-list + (monad;map @ (java-type-to-lux-type mappings))) + outputT (java-type-to-lux-type mappings (Method.getGenericReturnType [] method)) + exceptionsT (|> (Method.getGenericExceptionTypes [] method) + array;to-list + (monad;map @ (java-type-to-lux-type mappings))) + #let [methodT (<| (type;univ-q num-all-tvars) + (type;function (case method-type + #Static + inputsT + + _ + (list& (#;Primitive owner-name (list;reverse owner-tvarsT)) + inputsT))) + outputT)]] + (wrap [methodT exceptionsT])))) + +(exception: #export No-Candidate-Method) +(exception: #export Too-Many-Candidate-Methods) + +(def: (methods class-name method-name method-type arg-classes) + (-> Text Text Method-Type (List Text) (Meta [Type (List Type)])) + (do meta;Monad + [class (load-class class-name) + candidates (|> class + (Class.getDeclaredMethods []) + array;to-list + (monad;map @ (function [method] + (do @ + [passes? (check-method class method-name method-type arg-classes method)] + (wrap [passes? method])))))] + (case (list;filter product;left candidates) + #;Nil + (&;throw No-Candidate-Method (format class-name "#" method-name)) + + (#;Cons candidate #;Nil) + (|> candidate product;right (method-to-type method-type)) + + _ + (&;throw Too-Many-Candidate-Methods (format class-name "#" method-name))))) + +(def: (constructor-to-type constructor) + (-> (Constructor Object) (Meta [Type (List Type)])) + (let [owner (Constructor.getDeclaringClass [] constructor) + owner-name (Class.getName [] owner) + owner-tvars (|> (Class.getTypeParameters [] owner) + array;to-list + (list/map (TypeVariable.getName []))) + constructor-tvars (|> (Constructor.getTypeParameters [] constructor) + array;to-list + (list/map (TypeVariable.getName []))) + num-owner-tvars (list;size owner-tvars) + all-tvars (list/compose owner-tvars constructor-tvars) + num-all-tvars (list;size all-tvars) + owner-tvarsT (type-vars num-owner-tvars +0) + constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) + mappings (: Mappings + (if (list;empty? all-tvars) + fresh-mappings + (|> (list/compose owner-tvarsT constructor-tvarsT) + list;reverse + (list;zip2 all-tvars) + (dict;from-list text;Hash))))] + (do meta;Monad + [inputsT (|> (Constructor.getGenericParameterTypes [] constructor) + array;to-list + (monad;map @ (java-type-to-lux-type mappings))) + exceptionsT (|> (Constructor.getGenericExceptionTypes [] constructor) + array;to-list + (monad;map @ (java-type-to-lux-type mappings))) + #let [objectT (#;Primitive owner-name (list;reverse owner-tvarsT)) + constructorT (<| (type;univ-q num-all-tvars) + (type;function inputsT) + objectT)]] + (wrap [constructorT exceptionsT])))) + +(exception: #export No-Candidate-Constructor) +(exception: #export Too-Many-Candidate-Constructors) + +(def: (constructor-methods class-name arg-classes) + (-> Text (List Text) (Meta [Type (List Type)])) + (do meta;Monad + [class (load-class class-name) + candidates (|> class + (Class.getConstructors []) + array;to-list + (monad;map @ (function [constructor] + (do @ + [passes? (check-constructor class arg-classes constructor)] + (wrap [passes? constructor])))))] + (case (list;filter product;left candidates) + #;Nil + (&;throw No-Candidate-Constructor (format class-name "(" (text;join-with ", " arg-classes) ")")) + + (#;Cons candidate #;Nil) + (|> candidate product;right constructor-to-type) + + _ + (&;throw Too-Many-Candidate-Constructors class-name)))) + +(def: (decorate-inputs typesT inputsA) + (-> (List Text) (List la;Analysis) (List la;Analysis)) + (|> inputsA + (list;zip2 (list/map code;text typesT)) + (list/map (function [[type value]] + (la;product (list type value)))))) + +(def: (sub-type-analyser analyse) + (-> &;Analyser &;Analyser) + (function [argC] + (do meta;Monad + [[argT argA] (&common;with-unknown-type + (analyse argC)) + expectedT meta;expected-type + [unboxed castT] (cast #In expectedT argT)] + (wrap argA)))) + +(def: (invoke//static proc) + (-> Text @;Proc) + (function [analyse eval args] + (case (: (e;Error [Text Text (List [Text Code])]) + (s;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any)))))) + (#e;Success [class method argsTC]) + (do meta;Monad + [#let [argsT (list/map product;left argsTC)] + [methodT exceptionsT] (methods class method #Static argsT) + [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC)) + [unboxed castT] (infer-out outputT)] + (wrap (la;procedure proc (list& (code;text class) (code;text method) + (code;text unboxed) (decorate-inputs argsT argsA))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))) + +(def: (invoke//virtual proc) + (-> Text @;Proc) + (function [analyse eval args] + (case (: (e;Error [Text Text Code (List [Text Code])]) + (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any)))))) + (#e;Success [class method objectC argsTC]) + (do meta;Monad + [#let [argsT (list/map product;left argsTC)] + [methodT exceptionsT] (methods class method #Virtual argsT) + [outputT allA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + #let [[objectA argsA] (case allA + (#;Cons objectA argsA) + [objectA argsA] + + _ + (undefined))] + [unboxed castT] (infer-out outputT)] + (wrap (la;procedure proc (list& (code;text class) (code;text method) + (code;text unboxed) objectA (decorate-inputs argsT argsA))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))) + +(def: (invoke//special proc) + (-> Text @;Proc) + (function [analyse eval args] + (case (: (e;Error [(List Code) [Text Text Code (List [Text Code]) Unit]]) + (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!))) + (#e;Success [_ [class method objectC argsTC _]]) + (do meta;Monad + [#let [argsT (list/map product;left argsTC)] + [methodT exceptionsT] (methods class method #Special argsT) + [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [unboxed castT] (infer-out outputT)] + (wrap (la;procedure proc (list& (code;text class) (code;text method) + (code;text unboxed) (decorate-inputs argsT argsA))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))) + +(exception: #export Not-Interface) + +(def: (invoke//interface proc) + (-> Text @;Proc) + (function [analyse eval args] + (case (: (e;Error [Text Text Code (List [Text Code])]) + (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any)))))) + (#e;Success [class-name method objectC argsTC]) + (do meta;Monad + [#let [argsT (list/map product;left argsTC)] + class (load-class class-name) + _ (&;assert (Not-Interface class-name) + (Modifier.isInterface [(Class.getModifiers [] class)])) + [methodT exceptionsT] (methods class-name method #Interface argsT) + [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [unboxed castT] (infer-out outputT)] + (wrap (la;procedure proc + (list& (code;text class-name) (code;text method) (code;text unboxed) + (decorate-inputs argsT argsA))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))) + +(def: (invoke//constructor proc) + (-> Text @;Proc) + (function [analyse eval args] + (case (: (e;Error [Text (List [Text Code])]) + (s;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any)))))) + (#e;Success [class argsTC]) + (do meta;Monad + [#let [argsT (list/map product;left argsTC)] + [methodT exceptionsT] (constructor-methods class argsT) + [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC)) + [unboxed castT] (infer-out outputT)] + (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))) + +(def: member-procs + @;Bundle + (<| (@;prefix "member") + (|> (dict;new text;Hash) + (dict;merge (<| (@;prefix "static") + (|> (dict;new text;Hash) + (@;install "get" static-get) + (@;install "put" static-put)))) + (dict;merge (<| (@;prefix "virtual") + (|> (dict;new text;Hash) + (@;install "get" virtual-get) + (@;install "put" virtual-put)))) + (dict;merge (<| (@;prefix "invoke") + (|> (dict;new text;Hash) + (@;install "static" invoke//static) + (@;install "virtual" invoke//virtual) + (@;install "special" invoke//special) + (@;install "interface" invoke//interface) + (@;install "constructor" invoke//constructor) + ))) + ))) + +(def: #export procedures + @;Bundle + (<| (@;prefix "jvm") + (|> (dict;new text;Hash) + (dict;merge conversion-procs) + (dict;merge int-procs) + (dict;merge long-procs) + (dict;merge float-procs) + (dict;merge double-procs) + (dict;merge char-procs) + (dict;merge array-procs) + (dict;merge object-procs) + (dict;merge member-procs) + ))) diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux new file mode 100644 index 000000000..5bc1f96c9 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/reference.lux @@ -0,0 +1,53 @@ +(;module: + lux + (lux (control monad) + [meta] + (meta [code] + (type ["tc" check]))) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis] + [";L" variable #+ Variable]) + ["&;" scope])) + +## [Analysers] +(def: (analyse-definition def-name) + (-> Ident (Meta Analysis)) + (do meta;Monad + [actualT (meta;find-def-type def-name) + expectedT meta;expected-type + _ (&;with-type-env + (tc;check expectedT actualT))] + (wrap (code;symbol def-name)))) + +(def: (analyse-variable var-name) + (-> Text (Meta (Maybe Analysis))) + (do meta;Monad + [?var (&scope;find var-name)] + (case ?var + (#;Some [actualT ref]) + (do @ + [expectedT meta;expected-type + _ (&;with-type-env + (tc;check expectedT actualT))] + (wrap (#;Some (` ((~ (code;int (variableL;from-ref ref)))))))) + + #;None + (wrap #;None)))) + +(def: #export (analyse-reference reference) + (-> Ident (Meta Analysis)) + (case reference + ["" simple-name] + (do meta;Monad + [?var (analyse-variable simple-name)] + (case ?var + (#;Some analysis) + (wrap analysis) + + #;None + (do @ + [this-module meta;current-module-name] + (analyse-definition [this-module simple-name])))) + + _ + (analyse-definition reference))) diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux new file mode 100644 index 000000000..0284245e1 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -0,0 +1,311 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + pipe) + [function] + (concurrency ["A" atom]) + (data [ident] + [number] + [product] + [maybe] + (coll [list "list/" Functor] + [dict #+ Dict]) + [text] + text/format) + [meta] + (meta [code] + [type] + (type ["tc" check]))) + (luxc ["&" base] + (lang ["la" analysis] + (analysis ["&;" common] + ["&;" inference])) + ["&;" module] + ["&;" scope])) + +(exception: #export Not-Variant-Type) +(exception: #export Not-Tuple-Type) +(exception: #export Cannot-Infer-Numeric-Tag) + +(type: Type-Error + (-> Type Text)) + +(def: (not-quantified type) + Type-Error + (format "Not a quantified type: " (%type type))) + +(def: #export (analyse-sum analyse tag valueC) + (-> &;Analyser Nat Code (Meta la;Analysis)) + (do meta;Monad + [expectedT meta;expected-type] + (&;with-stacked-errors + (function [_] (Not-Variant-Type (format " Tag: " (%n tag) "\n" + "Value: " (%code valueC) "\n" + " Type: " (%type expectedT)))) + (case expectedT + (#;Sum _) + (let [flat (type;flatten-variant expectedT) + type-size (list;size flat)] + (case (list;nth tag flat) + (#;Some variant-type) + (do @ + [valueA (&;with-expected-type variant-type + (analyse valueC)) + temp &scope;next-local] + (wrap (la;sum tag type-size temp valueA))) + + #;None + (&common;variant-out-of-bounds-error expectedT type-size tag))) + + (#;Named name unnamedT) + (&;with-expected-type unnamedT + (analyse-sum analyse tag valueC)) + + (#;Var id) + (do @ + [bound? (&;with-type-env + (tc;bound? id))] + (if bound? + (do @ + [expectedT' (&;with-type-env + (tc;read id))] + (&;with-expected-type expectedT' + (analyse-sum analyse tag valueC))) + ## Cannot do inference when the tag is numeric. + ## This is because there is no way of knowing how many + ## cases the inferred sum type would have. + (&;throw Cannot-Infer-Numeric-Tag (format " Tag: " (%n tag) "\n" + "Value: " (%code valueC) "\n" + " Type: " (%type expectedT))))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;with-type-env + tc;existential)] + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (analyse-sum analyse tag valueC))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (analyse-sum analyse tag valueC)))) + + (#;Apply inputT funT) + (case (type;apply (list inputT) funT) + #;None + (&;fail (not-quantified funT)) + + (#;Some outputT) + (&;with-expected-type outputT + (analyse-sum analyse tag valueC))) + + _ + (&;throw Not-Variant-Type (format " Tag: " (%n tag) "\n" + "Value: " (%code valueC) "\n" + " Type: " (%type expectedT))))))) + +(def: (analyse-typed-product analyse members) + (-> &;Analyser (List Code) (Meta la;Analysis)) + (do meta;Monad + [expectedT meta;expected-type] + (loop [expectedT expectedT + members members] + (case [expectedT members] + ## If the type and the code are still ongoing, match each + ## sub-expression to its corresponding type. + [(#;Product leftT rightT) (#;Cons leftC rightC)] + (do @ + [leftA (&;with-expected-type leftT + (analyse leftC)) + rightA (recur rightT rightC)] + (wrap (` [(~ leftA) (~ rightA)]))) + + ## If the tuple runs out, whatever expression is the last gets + ## matched to the remaining type. + [tailT (#;Cons tailC #;Nil)] + (&;with-expected-type tailT + (analyse tailC)) + + ## If, however, the type runs out but there is still enough + ## tail, the remaining elements get packaged into another + ## tuple, and analysed through the intermediation of a + ## temporary local variable. + ## The reason for this is that it is assumed that the type of + ## the tuple represents the expectations of the user. + ## If the type is for a 3-tuple, but a 5-tuple is provided, it + ## is assumed that the user intended the following layout: + ## [0, 1, [2, 3, 4]] + ## but that, for whatever reason, it was written in a flat + ## way. + ## The reason why an intermediate variable is used is that if + ## the code was just re-written with just tuple nesting, the + ## resulting analysis would have undone the explicity nesting, + ## since Product nodes rely on nesting inherently, thereby + ## blurring the line between what was wanted (the separation) + ## and what was analysed. + [tailT tailC] + (do @ + [g!tail (meta;gensym "tail")] + (&;with-expected-type tailT + (analyse (` ((~' _lux_case) [(~@ tailC)] + (~ g!tail) + (~ g!tail)))))) + )))) + +(def: #export (analyse-product analyse membersC) + (-> &;Analyser (List Code) (Meta la;Analysis)) + (do meta;Monad + [expectedT meta;expected-type] + (&;with-stacked-errors + (function [_] (Not-Tuple-Type (format " Type: " (%type expectedT) "\n" + "Value: " (%code (` [(~@ membersC)]))))) + (case expectedT + (#;Product _) + (analyse-typed-product analyse membersC) + + (#;Named name unnamedT) + (&;with-expected-type unnamedT + (analyse-product analyse membersC)) + + (#;Var id) + (do @ + [bound? (&;with-type-env + (tc;bound? id))] + (if bound? + (do @ + [expectedT' (&;with-type-env + (tc;read id))] + (&;with-expected-type expectedT' + (analyse-product analyse membersC))) + ## Must do inference... + (do @ + [membersTA (monad;map @ (|>. analyse &common;with-unknown-type) + membersC) + _ (&;with-type-env + (tc;check expectedT + (type;tuple (list/map product;left membersTA))))] + (wrap (la;product (list/map product;right membersTA)))))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;with-type-env + tc;existential)] + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (analyse-product analyse membersC))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (analyse-product analyse membersC)))) + + (#;Apply inputT funT) + (case (type;apply (list inputT) funT) + #;None + (&;fail (not-quantified funT)) + + (#;Some outputT) + (&;with-expected-type outputT + (analyse-product analyse membersC))) + + _ + (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n" + "Value: " (%code (` [(~@ membersC)])))) + )))) + +(def: #export (analyse-tagged-sum analyse tag valueC) + (-> &;Analyser Ident Code (Meta la;Analysis)) + (do meta;Monad + [tag (meta;normalize tag) + [idx group variantT] (meta;resolve-tag tag) + expectedT meta;expected-type] + (case expectedT + (#;Var _) + (do @ + [#let [case-size (list;size group)] + inferenceT (&inference;variant idx case-size variantT) + [inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC)) + _ (&;with-type-env + (tc;check expectedT inferredT)) + temp &scope;next-local] + (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume)))) + + _ + (analyse-sum analyse idx valueC)))) + +## There cannot be any ambiguity or improper syntax when analysing +## records, so they must be normalized for further analysis. +## Normalization just means that all the tags get resolved to their +## canonical form (with their corresponding module identified). +(def: #export (normalize record) + (-> (List [Code Code]) (Meta (List [Ident Code]))) + (monad;map meta;Monad + (function [[key val]] + (case key + [_ (#;Tag key)] + (do meta;Monad + [key (meta;normalize key)] + (wrap [key val])) + + _ + (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) + record)) + +## Lux already possesses the means to analyse tuples, so +## re-implementing the same functionality for records makes no sense. +## Records, thus, get transformed into tuples by ordering the elements. +(def: #export (order record) + (-> (List [Ident Code]) (Meta [(List Code) Type])) + (case record + ## empty-record = empty-tuple = unit = [] + #;Nil + (:: meta;Monad wrap [(list) Unit]) + + (#;Cons [head-k head-v] _) + (do meta;Monad + [head-k (meta;normalize head-k) + [_ tag-set recordT] (meta;resolve-tag head-k) + #let [size-record (list;size record) + size-ts (list;size tag-set)] + _ (if (n.= size-ts size-record) + (wrap []) + (&;fail (format "Record size does not match tag-set size." "\n" + "Expected: " (|> size-ts nat-to-int %i) "\n" + " Actual: " (|> size-record nat-to-int %i) "\n" + "For type: " (%type recordT)))) + #let [tuple-range (list;n.range +0 (n.dec size-ts)) + tag->idx (dict;from-list ident;Hash (list;zip2 tag-set tuple-range))] + idx->val (monad;fold @ + (function [[key val] idx->val] + (do @ + [key (meta;normalize key)] + (case (dict;get key tag->idx) + #;None + (&;fail (format "Tag " (%code (code;tag key)) + " does not belong to tag-set for type " (%type recordT))) + + (#;Some idx) + (if (dict;contains? idx idx->val) + (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) + (wrap (dict;put idx val idx->val)))))) + (: (Dict Nat Code) + (dict;new number;Hash)) + record) + #let [ordered-tuple (list/map (function [idx] (maybe;assume (dict;get idx idx->val))) + tuple-range)]] + (wrap [ordered-tuple recordT])) + )) + +(def: #export (analyse-record analyse members) + (-> &;Analyser (List [Code Code]) (Meta la;Analysis)) + (do meta;Monad + [members (normalize members) + [members recordT] (order members) + expectedT meta;expected-type + inferenceT (&inference;record recordT) + [inferredT membersA] (&inference;apply-function analyse inferenceT members) + _ (&;with-type-env + (tc;check expectedT inferredT))] + (wrap (la;product membersA)))) diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux new file mode 100644 index 000000000..d0b038d93 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/type.lux @@ -0,0 +1,31 @@ +(;module: + lux + (lux (control monad) + [meta #+ Monad] + (meta (type ["TC" check]))) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis]))) + +## These 2 analysers are somewhat special, since they require the +## means of evaluating Lux expressions at compile-time for the sake of +## computing Lux type values. +(def: #export (analyse-check analyse eval type value) + (-> &;Analyser &;Eval Code Code (Meta Analysis)) + (do Monad + [actual (eval Type type) + #let [actual (:! Type actual)] + expected meta;expected-type + _ (&;with-type-env + (TC;check expected actual))] + (&;with-expected-type actual + (analyse value)))) + +(def: #export (analyse-coerce analyse eval type value) + (-> &;Analyser &;Eval Code Code (Meta Analysis)) + (do Monad + [actual (eval Type type) + expected meta;expected-type + _ (&;with-type-env + (TC;check expected (:! Type actual)))] + (&;with-expected-type Top + (analyse value)))) diff --git a/new-luxc/source/luxc/lang/parser.lux b/new-luxc/source/luxc/lang/parser.lux new file mode 100644 index 000000000..93800c1b7 --- /dev/null +++ b/new-luxc/source/luxc/lang/parser.lux @@ -0,0 +1,610 @@ +## This is the LuxC's parser. +## It takes the source code of a Lux file in raw text form and +## extracts the syntactic structure of the code from it. +## It only produces Lux Code nodes, and thus removes any white-space +## and comments while processing its inputs. + +## Another important aspect of the parser is that it keeps track of +## its position within the input data. +## That is, the parser takes into account the line and column +## information in the input text (it doesn't really touch the +## file-name aspect of the cursor, leaving it intact in whatever +## base-line cursor it is given). + +## This particular piece of functionality is not located in one +## function, but it is instead scattered throughout several parsers, +## since the logic for how to update the cursor varies, depending on +## what is being parsed, and the rules involved. + +## You will notice that several parsers have a "where" parameter, that +## tells them the cursor position prior to the parser being run. +## They are supposed to produce some parsed output, alongside an +## updated cursor pointing to the end position, after the parser was run. + +## Lux Code nodes/tokens are annotated with cursor meta-data +## (file-name, line, column) to keep track of their provenance and +## location, which is helpful for documentation and debugging. +(;module: + lux + (lux (control monad + ["p" parser "p/" Monad]) + (data [bool] + [text] + ["e" error] + [number] + [product] + [maybe] + (text ["l" lexer] + format) + (coll [sequence #+ Sequence])))) + +(def: white-space Text "\t\v \r\f") +(def: new-line Text "\n") + +## This is the parser for white-space. +## Whenever a new-line is encountered, the column gets reset to 0, and +## the line gets incremented. +## It operates recursively in order to produce the longest continuous +## chunk of white-space. +(def: (space^ where) + (-> Cursor (l;Lexer [Cursor Text])) + (p;either (do p;Monad + [content (l;many (l;one-of white-space))] + (wrap [(update@ #;column (n.+ (text;size content)) where) + content])) + ## New-lines must be handled as a separate case to ensure line + ## information is handled properly. + (do p;Monad + [content (l;many (l;one-of new-line))] + (wrap [(|> where + (update@ #;line (n.+ (text;size content))) + (set@ #;column +0)) + content])) + )) + +## Single-line comments can start anywhere, but only go up to the +## next new-line. +(def: (single-line-comment^ where) + (-> Cursor (l;Lexer [Cursor Text])) + (do p;Monad + [_ (l;this "##") + comment (l;some (l;none-of new-line)) + _ (l;this new-line)] + (wrap [(|> where + (update@ #;line n.inc) + (set@ #;column +0)) + comment]))) + +## This is just a helper parser to find text which doesn't run into +## any special character sequences for multi-line comments. +(def: comment-bound^ + (l;Lexer Unit) + ($_ p;either + (l;this new-line) + (l;this ")#") + (l;this "#("))) + +## Multi-line comments are bounded by #( these delimiters, #(and, they may +## also be nested)# )#. +## Multi-line comment syntax must be balanced. +## That is, any nested comment must have matched delimiters. +## Unbalanced comments ought to be rejected as invalid code. +(def: (multi-line-comment^ where) + (-> Cursor (l;Lexer [Cursor Text])) + (do p;Monad + [_ (l;this "#(")] + (loop [comment "" + where (update@ #;column (n.+ +2) where)] + ($_ p;either + ## These are normal chunks of commented text. + (do @ + [chunk (l;many (l;not comment-bound^))] + (recur (format comment chunk) + (|> where + (update@ #;column (n.+ (text;size chunk)))))) + ## This is a special rule to handle new-lines within + ## comments properly. + (do @ + [_ (l;this new-line)] + (recur (format comment new-line) + (|> where + (update@ #;line n.inc) + (set@ #;column +0)))) + ## This is the rule for handling nested sub-comments. + ## Ultimately, the whole comment is just treated as text + ## (the comment must respect the syntax structure, but the + ## output produced is just a block of text). + ## That is why the sub-comment is covered in delimiters + ## and then appended to the rest of the comment text. + (do @ + [[sub-where sub-comment] (multi-line-comment^ where)] + (recur (format comment "#(" sub-comment ")#") + sub-where)) + ## Finally, this is the rule for closing the comment. + (do @ + [_ (l;this ")#")] + (wrap [(update@ #;column (n.+ +2) where) + comment])) + )))) + +## This is the only parser that should be used directly by other +## parsers, since all comments must be treated as either being +## single-line or multi-line. +## That is, there is no syntactic rule prohibiting one type of comment +## from being used in any situation (alternatively, forcing one type +## of comment to be the only usable one). +(def: (comment^ where) + (-> Cursor (l;Lexer [Cursor Text])) + (p;either (single-line-comment^ where) + (multi-line-comment^ where))) + +## To simplify parsing, I remove any left-padding that an Code token +## may have prior to parsing the token itself. +## Left-padding is assumed to be either white-space or a comment. +## The cursor gets updated, but the padding gets ignored. +(def: (left-padding^ where) + (-> Cursor (l;Lexer Cursor)) + ($_ p;either + (do p;Monad + [[where comment] (comment^ where)] + (left-padding^ where)) + (do p;Monad + [[where white-space] (space^ where)] + (left-padding^ where)) + (:: p;Monad wrap where))) + +## Escaped character sequences follow the usual syntax of +## back-slash followed by a letter (e.g. \n). +## Unicode escapes are possible, with hexadecimal sequences between 1 +## and 4 characters long (e.g. \u12aB). +## Escaped characters may show up in Char and Text literals. +(def: escaped-char^ + (l;Lexer [Nat Text]) + (p;after (l;this "\\") + (do p;Monad + [code l;any] + (case code + ## Handle special cases. + "t" (wrap [+2 "\t"]) + "v" (wrap [+2 "\v"]) + "b" (wrap [+2 "\b"]) + "n" (wrap [+2 "\n"]) + "r" (wrap [+2 "\r"]) + "f" (wrap [+2 "\f"]) + "\"" (wrap [+2 "\""]) + "\\" (wrap [+2 "\\"]) + + ## Handle unicode escapes. + "u" + (do p;Monad + [code (l;between +1 +4 l;hexadecimal)] + (wrap (case (|> code (format "+") (:: number;Hex@Codec decode)) + (#;Right value) + [(n.+ +2 (text;size code)) (text;from-code value)] + + _ + (undefined)))) + + _ + (p;fail (format "Invalid escaping syntax: " (%t code))))))) + +## These are very simple parsers that just cut chunks of text in +## specific shapes and then use decoders already present in the +## standard library to actually produce the values from the literals. +(def: rich-digit + (l;Lexer Text) + (p;either l;decimal + (p;after (l;this "_") (p/wrap "")))) + +(def: rich-digits^ + (l;Lexer Text) + (l;seq l;decimal + (l;some rich-digit))) + +(def: (marker^ token) + (-> Text (l;Lexer Text)) + (p;after (l;this token) (p/wrap token))) + +(do-template [ ] + [(def: #export ( where) + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad + [chunk ] + (case (:: decode chunk) + (#;Left error) + (p;fail error) + + (#;Right value) + (wrap [(update@ #;column (n.+ (text;size chunk)) where) + [where ( value)]]))))] + + [bool #;Bool + (p;either (marker^ "true") (marker^ "false")) + bool;Codec] + + [int #;Int + (l;seq (p;default "" (l;one-of "-")) + rich-digits^) + number;Codec] + + [deg #;Deg + (l;seq (l;one-of ".") + rich-digits^) + number;Codec] + ) + +(def: (nat-char where) + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad + [_ (l;this "#\"") + [where' char] (: (l;Lexer [Cursor Text]) + ($_ p;either + ## Normal text characters. + (do @ + [normal (l;none-of "\\\"\n")] + (wrap [(|> where + (update@ #;column n.inc)) + normal])) + ## Must handle escaped + ## chars separately. + (do @ + [[chars-consumed char] escaped-char^] + (wrap [(|> where + (update@ #;column (n.+ chars-consumed))) + char])))) + _ (l;this "\"") + #let [char (maybe;assume (text;nth +0 char))]] + (wrap [(|> where' + (update@ #;column n.inc)) + [where (#;Nat char)]]))) + +(def: (normal-nat where) + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad + [chunk (l;seq (l;one-of "+") + rich-digits^)] + (case (:: number;Codec decode chunk) + (#;Left error) + (p;fail error) + + (#;Right value) + (wrap [(update@ #;column (n.+ (text;size chunk)) where) + [where (#;Nat value)]])))) + +(def: #export (nat where) + (-> Cursor (l;Lexer [Cursor Code])) + (p;either (normal-nat where) + (nat-char where))) + +(def: (normal-frac where) + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad + [chunk ($_ l;seq + (p;default "" (l;one-of "-")) + rich-digits^ + (l;one-of ".") + rich-digits^ + (p;default "" + ($_ l;seq + (l;one-of "eE") + (p;default "" (l;one-of "+-")) + rich-digits^)))] + (case (:: number;Codec decode chunk) + (#;Left error) + (p;fail error) + + (#;Right value) + (wrap [(update@ #;column (n.+ (text;size chunk)) where) + [where (#;Frac value)]])))) + +(def: frac-ratio-fragment + (l;Lexer Frac) + (<| (p;codec number;Codec) + (:: p;Monad map (function [digits] + (format digits ".0"))) + rich-digits^)) + +(def: (ratio-frac where) + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad + [chunk ($_ l;seq + (p;default "" (l;one-of "-")) + rich-digits^ + (l;one-of "/") + rich-digits^) + value (l;local chunk + (do @ + [signed? (l;this? "-") + numerator frac-ratio-fragment + _ (l;this? "/") + denominator frac-ratio-fragment + _ (p;assert "Denominator cannot be 0." + (not (f.= 0.0 denominator)))] + (wrap (|> numerator + (f.* (if signed? -1.0 1.0)) + (f./ denominator)))))] + (wrap [(update@ #;column (n.+ (text;size chunk)) where) + [where (#;Frac value)]]))) + +(def: #export (frac where) + (-> Cursor (l;Lexer [Cursor Code])) + (p;either (normal-frac where) + (ratio-frac where))) + +## This parser looks so complex because text in Lux can be multi-line +## and there are rules regarding how this is handled. +(def: #export (text where) + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad + [## Lux text "is delimited by double-quotes", as usual in most + ## programming languages. + _ (l;this "\"") + ## I must know what column the text body starts at (which is + ## always 1 column after the left-delimiting quote). + ## This is important because, when procesing subsequent lines, + ## they must all start at the same column, being left-padded with + ## as many spaces as necessary to be column-aligned. + ## This helps ensure that the formatting on the text in the + ## source-code matches the formatting of the Text value. + #let [offset-column (n.inc (get@ #;column where))] + [where' text-read] (: (l;Lexer [Cursor Text]) + ## I must keep track of how much of the + ## text body has been read, how far the + ## cursor has progressed, and whether I'm + ## processing a subsequent line, or just + ## processing normal text body. + (loop [text-read "" + where (|> where + (update@ #;column n.inc)) + must-have-offset? false] + (p;either (if must-have-offset? + ## If I'm at the start of a + ## new line, I must ensure the + ## space-offset is at least + ## as great as the column of + ## the text's body's column, + ## to ensure they are aligned. + (do @ + [offset (l;many (l;one-of " ")) + #let [offset-size (text;size offset)]] + (if (n.>= offset-column offset-size) + ## Any extra offset + ## becomes part of the + ## text's body. + (recur (|> offset + (text;split offset-column) + (maybe;default (undefined)) + product;right + (format text-read)) + (|> where + (update@ #;column (n.+ offset-size))) + false) + (p;fail (format "Each line of a multi-line text must have an appropriate offset!\n" + "Expected: " (%i (nat-to-int offset-column)) " columns.\n" + " Actual: " (%i (nat-to-int offset-size)) " columns.\n")))) + ($_ p;either + ## Normal text characters. + (do @ + [normal (l;many (l;none-of "\\\"\n"))] + (recur (format text-read normal) + (|> where + (update@ #;column (n.+ (text;size normal)))) + false)) + ## Must handle escaped + ## chars separately. + (do @ + [[chars-consumed char] escaped-char^] + (recur (format text-read char) + (|> where + (update@ #;column (n.+ chars-consumed))) + false)) + ## The text ends when it + ## reaches the right-delimiter. + (do @ + [_ (l;this "\"")] + (wrap [(update@ #;column n.inc where) + text-read])))) + ## If a new-line is + ## encountered, it gets + ## appended to the value and + ## the loop is alerted that the + ## next line must have an offset. + (do @ + [_ (l;this new-line)] + (recur (format text-read new-line) + (|> where + (update@ #;line n.inc) + (set@ #;column +0)) + true)))))] + (wrap [where' + [where (#;Text text-read)]]))) + +## Form and tuple syntax is mostly the same, differing only in the +## delimiters involved. +## They may have an arbitrary number of arbitrary Code nodes as elements. +(do-template [ ] + [(def: ( where ast) + (-> Cursor + (-> Cursor (l;Lexer [Cursor Code])) + (l;Lexer [Cursor Code])) + (do p;Monad + [_ (l;this ) + [where' elems] (loop [elems (: (Sequence Code) + sequence;empty) + where where] + (p;either (do @ + [## Must update the cursor as I + ## go along, to keep things accurate. + [where' elem] (ast where)] + (recur (sequence;add elem elems) + where')) + (do @ + [## Must take into account any + ## padding present before the + ## end-delimiter. + where' (left-padding^ where) + _ (l;this )] + (wrap [(update@ #;column n.inc where') + (sequence;to-list elems)]))))] + (wrap [where' + [where ( elems)]])))] + + [form #;Form "(" ")"] + [tuple #;Tuple "[" "]"] + ) + +## Records are almost (syntactically) the same as forms and tuples, +## with the exception that their elements must come in pairs (as in +## key-value pairs). +## Semantically, though, records and tuples are just 2 different +## representations for the same thing (a tuple). +## In normal Lux syntax, the key position in the pair will be a tag +## Code node, however, record Code nodes allow any Code node to occupy +## this position, since it may be useful when processing Code syntax in +## macros. +(def: (record where ast) + (-> Cursor + (-> Cursor (l;Lexer [Cursor Code])) + (l;Lexer [Cursor Code])) + (do p;Monad + [_ (l;this "{") + [where' elems] (loop [elems (: (Sequence [Code Code]) + sequence;empty) + where where] + (p;either (do @ + [[where' key] (ast where) + [where' val] (ast where')] + (recur (sequence;add [key val] elems) + where')) + (do @ + [where' (left-padding^ where) + _ (l;this "}")] + (wrap [(update@ #;column n.inc where') + (sequence;to-list elems)]))))] + (wrap [where' + [where (#;Record elems)]]))) + +## The parts of an identifier are separated by a single mark. +## E.g. module;name. +## Only one such mark may be used in an identifier, since there +## can only be 2 parts to an identifier (the module [before the +## mark], and the name [after the mark]). +## There are also some extra rules regarding identifier syntax, +## encoded on the parser. +(def: identifier-separator Text ";") + +## A Lux identifier is a pair of chunks of text, where the first-part +## refers to the module that gives context to the identifier, and the +## second part corresponds to the name of the identifier itself. +## The module part may be absent (by being the empty text ""), but the +## name part must always be present. +## The rules for which characters you may use are specified in terms +## of which characters you must avoid (to keep things as open-ended as +## possible). +## In particular, no white-space can be used, and neither can other +## characters which are already used by Lux as delimiters for other +## Code nodes (thereby reducing ambiguity while parsing). +## Additionally, the first character in an identifier's part cannot be +## a digit, to avoid confusion with regards to numbers. +(def: ident-part^ + (l;Lexer Text) + (do p;Monad + [#let [digits "0123456789" + delimiters (format "()[]{}#\"" identifier-separator) + space (format white-space new-line) + head-lexer (l;none-of (format digits delimiters space)) + tail-lexer (l;some (l;none-of (format delimiters space)))] + head head-lexer + tail tail-lexer] + (wrap (format head tail)))) + +(def: ident^ + (l;Lexer [Ident Nat]) + ($_ p;either + ## When an identifier starts with 2 marks, it's module is + ## taken to be the current-module being compiled at the moment. + ## This can be useful when mentioning identifiers and tags + ## inside quoted/templated code in macros. + (do p;Monad + [#let [current-module-mark (format identifier-separator identifier-separator)] + _ (l;this current-module-mark) + def-name ident-part^] + (p;fail (format "Cannot handle " current-module-mark " syntax for identifiers."))) + ## If the identifier is prefixed by the mark, but no module + ## part, the module is assumed to be "lux" (otherwise known as + ## the 'prelude'). + ## This makes it easy to refer to definitions in that module, + ## since it is the most fundamental module in the entire + ## standard library. + (do p;Monad + [_ (l;this identifier-separator) + def-name ident-part^] + (wrap [["lux" def-name] + (n.inc (text;size def-name))])) + ## Not all identifiers must be specified with a module part. + ## If that part is not provided, the identifier will be created + ## with the empty "" text as the module. + ## During program analysis, such identifiers tend to be treated + ## as if their context is the current-module, but this only + ## applies to identifiers for tags and module definitions. + ## Function arguments and local-variables may not be referred-to + ## using identifiers with module parts, so being able to specify + ## identifiers with empty modules helps with those use-cases. + (do p;Monad + [first-part ident-part^] + (p;either (do @ + [_ (l;this identifier-separator) + second-part ident-part^] + (wrap [[first-part second-part] + ($_ n.+ + (text;size first-part) + +1 + (text;size second-part))])) + (wrap [["" first-part] + (text;size first-part)]))))) + +## The only (syntactic) difference between a symbol and a tag (both +## being identifiers), is that tags must be prefixed with a hash-sign +## (i.e. #). +## Semantically, though, they are very different, with symbols being +## used to refer to module definitions and local variables, while tags +## provide the compiler with information related to data-structure +## construction and de-structuring (during pattern-matching). +(do-template [ ] + [(def: #export ( where) + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad + [[value length] ] + (wrap [(update@ #;column (|>. ($_ n.+ length)) where) + [where ( value)]])))] + + [symbol #;Symbol ident^ +0] + [tag #;Tag (p;after (l;this "#") ident^) +1] + ) + +(def: (ast where) + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad + [where (left-padding^ where)] + ($_ p;either + (form where ast) + (tuple where ast) + (record where ast) + (bool where) + (nat where) + (frac where) + (int where) + (deg where) + (symbol where) + (tag where) + (text where) + ))) + +(def: #export (parse [where offset source]) + (-> Source (e;Error [Source Code])) + (case (p;run [offset source] (ast where)) + (#e;Error error) + (#e;Error error) + + (#e;Success [[offset' remaining] [where' output]]) + (#e;Success [[where' offset' remaining] output]))) diff --git a/new-luxc/source/luxc/parser.lux b/new-luxc/source/luxc/parser.lux deleted file mode 100644 index 93800c1b7..000000000 --- a/new-luxc/source/luxc/parser.lux +++ /dev/null @@ -1,610 +0,0 @@ -## This is the LuxC's parser. -## It takes the source code of a Lux file in raw text form and -## extracts the syntactic structure of the code from it. -## It only produces Lux Code nodes, and thus removes any white-space -## and comments while processing its inputs. - -## Another important aspect of the parser is that it keeps track of -## its position within the input data. -## That is, the parser takes into account the line and column -## information in the input text (it doesn't really touch the -## file-name aspect of the cursor, leaving it intact in whatever -## base-line cursor it is given). - -## This particular piece of functionality is not located in one -## function, but it is instead scattered throughout several parsers, -## since the logic for how to update the cursor varies, depending on -## what is being parsed, and the rules involved. - -## You will notice that several parsers have a "where" parameter, that -## tells them the cursor position prior to the parser being run. -## They are supposed to produce some parsed output, alongside an -## updated cursor pointing to the end position, after the parser was run. - -## Lux Code nodes/tokens are annotated with cursor meta-data -## (file-name, line, column) to keep track of their provenance and -## location, which is helpful for documentation and debugging. -(;module: - lux - (lux (control monad - ["p" parser "p/" Monad]) - (data [bool] - [text] - ["e" error] - [number] - [product] - [maybe] - (text ["l" lexer] - format) - (coll [sequence #+ Sequence])))) - -(def: white-space Text "\t\v \r\f") -(def: new-line Text "\n") - -## This is the parser for white-space. -## Whenever a new-line is encountered, the column gets reset to 0, and -## the line gets incremented. -## It operates recursively in order to produce the longest continuous -## chunk of white-space. -(def: (space^ where) - (-> Cursor (l;Lexer [Cursor Text])) - (p;either (do p;Monad - [content (l;many (l;one-of white-space))] - (wrap [(update@ #;column (n.+ (text;size content)) where) - content])) - ## New-lines must be handled as a separate case to ensure line - ## information is handled properly. - (do p;Monad - [content (l;many (l;one-of new-line))] - (wrap [(|> where - (update@ #;line (n.+ (text;size content))) - (set@ #;column +0)) - content])) - )) - -## Single-line comments can start anywhere, but only go up to the -## next new-line. -(def: (single-line-comment^ where) - (-> Cursor (l;Lexer [Cursor Text])) - (do p;Monad - [_ (l;this "##") - comment (l;some (l;none-of new-line)) - _ (l;this new-line)] - (wrap [(|> where - (update@ #;line n.inc) - (set@ #;column +0)) - comment]))) - -## This is just a helper parser to find text which doesn't run into -## any special character sequences for multi-line comments. -(def: comment-bound^ - (l;Lexer Unit) - ($_ p;either - (l;this new-line) - (l;this ")#") - (l;this "#("))) - -## Multi-line comments are bounded by #( these delimiters, #(and, they may -## also be nested)# )#. -## Multi-line comment syntax must be balanced. -## That is, any nested comment must have matched delimiters. -## Unbalanced comments ought to be rejected as invalid code. -(def: (multi-line-comment^ where) - (-> Cursor (l;Lexer [Cursor Text])) - (do p;Monad - [_ (l;this "#(")] - (loop [comment "" - where (update@ #;column (n.+ +2) where)] - ($_ p;either - ## These are normal chunks of commented text. - (do @ - [chunk (l;many (l;not comment-bound^))] - (recur (format comment chunk) - (|> where - (update@ #;column (n.+ (text;size chunk)))))) - ## This is a special rule to handle new-lines within - ## comments properly. - (do @ - [_ (l;this new-line)] - (recur (format comment new-line) - (|> where - (update@ #;line n.inc) - (set@ #;column +0)))) - ## This is the rule for handling nested sub-comments. - ## Ultimately, the whole comment is just treated as text - ## (the comment must respect the syntax structure, but the - ## output produced is just a block of text). - ## That is why the sub-comment is covered in delimiters - ## and then appended to the rest of the comment text. - (do @ - [[sub-where sub-comment] (multi-line-comment^ where)] - (recur (format comment "#(" sub-comment ")#") - sub-where)) - ## Finally, this is the rule for closing the comment. - (do @ - [_ (l;this ")#")] - (wrap [(update@ #;column (n.+ +2) where) - comment])) - )))) - -## This is the only parser that should be used directly by other -## parsers, since all comments must be treated as either being -## single-line or multi-line. -## That is, there is no syntactic rule prohibiting one type of comment -## from being used in any situation (alternatively, forcing one type -## of comment to be the only usable one). -(def: (comment^ where) - (-> Cursor (l;Lexer [Cursor Text])) - (p;either (single-line-comment^ where) - (multi-line-comment^ where))) - -## To simplify parsing, I remove any left-padding that an Code token -## may have prior to parsing the token itself. -## Left-padding is assumed to be either white-space or a comment. -## The cursor gets updated, but the padding gets ignored. -(def: (left-padding^ where) - (-> Cursor (l;Lexer Cursor)) - ($_ p;either - (do p;Monad - [[where comment] (comment^ where)] - (left-padding^ where)) - (do p;Monad - [[where white-space] (space^ where)] - (left-padding^ where)) - (:: p;Monad wrap where))) - -## Escaped character sequences follow the usual syntax of -## back-slash followed by a letter (e.g. \n). -## Unicode escapes are possible, with hexadecimal sequences between 1 -## and 4 characters long (e.g. \u12aB). -## Escaped characters may show up in Char and Text literals. -(def: escaped-char^ - (l;Lexer [Nat Text]) - (p;after (l;this "\\") - (do p;Monad - [code l;any] - (case code - ## Handle special cases. - "t" (wrap [+2 "\t"]) - "v" (wrap [+2 "\v"]) - "b" (wrap [+2 "\b"]) - "n" (wrap [+2 "\n"]) - "r" (wrap [+2 "\r"]) - "f" (wrap [+2 "\f"]) - "\"" (wrap [+2 "\""]) - "\\" (wrap [+2 "\\"]) - - ## Handle unicode escapes. - "u" - (do p;Monad - [code (l;between +1 +4 l;hexadecimal)] - (wrap (case (|> code (format "+") (:: number;Hex@Codec decode)) - (#;Right value) - [(n.+ +2 (text;size code)) (text;from-code value)] - - _ - (undefined)))) - - _ - (p;fail (format "Invalid escaping syntax: " (%t code))))))) - -## These are very simple parsers that just cut chunks of text in -## specific shapes and then use decoders already present in the -## standard library to actually produce the values from the literals. -(def: rich-digit - (l;Lexer Text) - (p;either l;decimal - (p;after (l;this "_") (p/wrap "")))) - -(def: rich-digits^ - (l;Lexer Text) - (l;seq l;decimal - (l;some rich-digit))) - -(def: (marker^ token) - (-> Text (l;Lexer Text)) - (p;after (l;this token) (p/wrap token))) - -(do-template [ ] - [(def: #export ( where) - (-> Cursor (l;Lexer [Cursor Code])) - (do p;Monad - [chunk ] - (case (:: decode chunk) - (#;Left error) - (p;fail error) - - (#;Right value) - (wrap [(update@ #;column (n.+ (text;size chunk)) where) - [where ( value)]]))))] - - [bool #;Bool - (p;either (marker^ "true") (marker^ "false")) - bool;Codec] - - [int #;Int - (l;seq (p;default "" (l;one-of "-")) - rich-digits^) - number;Codec] - - [deg #;Deg - (l;seq (l;one-of ".") - rich-digits^) - number;Codec] - ) - -(def: (nat-char where) - (-> Cursor (l;Lexer [Cursor Code])) - (do p;Monad - [_ (l;this "#\"") - [where' char] (: (l;Lexer [Cursor Text]) - ($_ p;either - ## Normal text characters. - (do @ - [normal (l;none-of "\\\"\n")] - (wrap [(|> where - (update@ #;column n.inc)) - normal])) - ## Must handle escaped - ## chars separately. - (do @ - [[chars-consumed char] escaped-char^] - (wrap [(|> where - (update@ #;column (n.+ chars-consumed))) - char])))) - _ (l;this "\"") - #let [char (maybe;assume (text;nth +0 char))]] - (wrap [(|> where' - (update@ #;column n.inc)) - [where (#;Nat char)]]))) - -(def: (normal-nat where) - (-> Cursor (l;Lexer [Cursor Code])) - (do p;Monad - [chunk (l;seq (l;one-of "+") - rich-digits^)] - (case (:: number;Codec decode chunk) - (#;Left error) - (p;fail error) - - (#;Right value) - (wrap [(update@ #;column (n.+ (text;size chunk)) where) - [where (#;Nat value)]])))) - -(def: #export (nat where) - (-> Cursor (l;Lexer [Cursor Code])) - (p;either (normal-nat where) - (nat-char where))) - -(def: (normal-frac where) - (-> Cursor (l;Lexer [Cursor Code])) - (do p;Monad - [chunk ($_ l;seq - (p;default "" (l;one-of "-")) - rich-digits^ - (l;one-of ".") - rich-digits^ - (p;default "" - ($_ l;seq - (l;one-of "eE") - (p;default "" (l;one-of "+-")) - rich-digits^)))] - (case (:: number;Codec decode chunk) - (#;Left error) - (p;fail error) - - (#;Right value) - (wrap [(update@ #;column (n.+ (text;size chunk)) where) - [where (#;Frac value)]])))) - -(def: frac-ratio-fragment - (l;Lexer Frac) - (<| (p;codec number;Codec) - (:: p;Monad map (function [digits] - (format digits ".0"))) - rich-digits^)) - -(def: (ratio-frac where) - (-> Cursor (l;Lexer [Cursor Code])) - (do p;Monad - [chunk ($_ l;seq - (p;default "" (l;one-of "-")) - rich-digits^ - (l;one-of "/") - rich-digits^) - value (l;local chunk - (do @ - [signed? (l;this? "-") - numerator frac-ratio-fragment - _ (l;this? "/") - denominator frac-ratio-fragment - _ (p;assert "Denominator cannot be 0." - (not (f.= 0.0 denominator)))] - (wrap (|> numerator - (f.* (if signed? -1.0 1.0)) - (f./ denominator)))))] - (wrap [(update@ #;column (n.+ (text;size chunk)) where) - [where (#;Frac value)]]))) - -(def: #export (frac where) - (-> Cursor (l;Lexer [Cursor Code])) - (p;either (normal-frac where) - (ratio-frac where))) - -## This parser looks so complex because text in Lux can be multi-line -## and there are rules regarding how this is handled. -(def: #export (text where) - (-> Cursor (l;Lexer [Cursor Code])) - (do p;Monad - [## Lux text "is delimited by double-quotes", as usual in most - ## programming languages. - _ (l;this "\"") - ## I must know what column the text body starts at (which is - ## always 1 column after the left-delimiting quote). - ## This is important because, when procesing subsequent lines, - ## they must all start at the same column, being left-padded with - ## as many spaces as necessary to be column-aligned. - ## This helps ensure that the formatting on the text in the - ## source-code matches the formatting of the Text value. - #let [offset-column (n.inc (get@ #;column where))] - [where' text-read] (: (l;Lexer [Cursor Text]) - ## I must keep track of how much of the - ## text body has been read, how far the - ## cursor has progressed, and whether I'm - ## processing a subsequent line, or just - ## processing normal text body. - (loop [text-read "" - where (|> where - (update@ #;column n.inc)) - must-have-offset? false] - (p;either (if must-have-offset? - ## If I'm at the start of a - ## new line, I must ensure the - ## space-offset is at least - ## as great as the column of - ## the text's body's column, - ## to ensure they are aligned. - (do @ - [offset (l;many (l;one-of " ")) - #let [offset-size (text;size offset)]] - (if (n.>= offset-column offset-size) - ## Any extra offset - ## becomes part of the - ## text's body. - (recur (|> offset - (text;split offset-column) - (maybe;default (undefined)) - product;right - (format text-read)) - (|> where - (update@ #;column (n.+ offset-size))) - false) - (p;fail (format "Each line of a multi-line text must have an appropriate offset!\n" - "Expected: " (%i (nat-to-int offset-column)) " columns.\n" - " Actual: " (%i (nat-to-int offset-size)) " columns.\n")))) - ($_ p;either - ## Normal text characters. - (do @ - [normal (l;many (l;none-of "\\\"\n"))] - (recur (format text-read normal) - (|> where - (update@ #;column (n.+ (text;size normal)))) - false)) - ## Must handle escaped - ## chars separately. - (do @ - [[chars-consumed char] escaped-char^] - (recur (format text-read char) - (|> where - (update@ #;column (n.+ chars-consumed))) - false)) - ## The text ends when it - ## reaches the right-delimiter. - (do @ - [_ (l;this "\"")] - (wrap [(update@ #;column n.inc where) - text-read])))) - ## If a new-line is - ## encountered, it gets - ## appended to the value and - ## the loop is alerted that the - ## next line must have an offset. - (do @ - [_ (l;this new-line)] - (recur (format text-read new-line) - (|> where - (update@ #;line n.inc) - (set@ #;column +0)) - true)))))] - (wrap [where' - [where (#;Text text-read)]]))) - -## Form and tuple syntax is mostly the same, differing only in the -## delimiters involved. -## They may have an arbitrary number of arbitrary Code nodes as elements. -(do-template [ ] - [(def: ( where ast) - (-> Cursor - (-> Cursor (l;Lexer [Cursor Code])) - (l;Lexer [Cursor Code])) - (do p;Monad - [_ (l;this ) - [where' elems] (loop [elems (: (Sequence Code) - sequence;empty) - where where] - (p;either (do @ - [## Must update the cursor as I - ## go along, to keep things accurate. - [where' elem] (ast where)] - (recur (sequence;add elem elems) - where')) - (do @ - [## Must take into account any - ## padding present before the - ## end-delimiter. - where' (left-padding^ where) - _ (l;this )] - (wrap [(update@ #;column n.inc where') - (sequence;to-list elems)]))))] - (wrap [where' - [where ( elems)]])))] - - [form #;Form "(" ")"] - [tuple #;Tuple "[" "]"] - ) - -## Records are almost (syntactically) the same as forms and tuples, -## with the exception that their elements must come in pairs (as in -## key-value pairs). -## Semantically, though, records and tuples are just 2 different -## representations for the same thing (a tuple). -## In normal Lux syntax, the key position in the pair will be a tag -## Code node, however, record Code nodes allow any Code node to occupy -## this position, since it may be useful when processing Code syntax in -## macros. -(def: (record where ast) - (-> Cursor - (-> Cursor (l;Lexer [Cursor Code])) - (l;Lexer [Cursor Code])) - (do p;Monad - [_ (l;this "{") - [where' elems] (loop [elems (: (Sequence [Code Code]) - sequence;empty) - where where] - (p;either (do @ - [[where' key] (ast where) - [where' val] (ast where')] - (recur (sequence;add [key val] elems) - where')) - (do @ - [where' (left-padding^ where) - _ (l;this "}")] - (wrap [(update@ #;column n.inc where') - (sequence;to-list elems)]))))] - (wrap [where' - [where (#;Record elems)]]))) - -## The parts of an identifier are separated by a single mark. -## E.g. module;name. -## Only one such mark may be used in an identifier, since there -## can only be 2 parts to an identifier (the module [before the -## mark], and the name [after the mark]). -## There are also some extra rules regarding identifier syntax, -## encoded on the parser. -(def: identifier-separator Text ";") - -## A Lux identifier is a pair of chunks of text, where the first-part -## refers to the module that gives context to the identifier, and the -## second part corresponds to the name of the identifier itself. -## The module part may be absent (by being the empty text ""), but the -## name part must always be present. -## The rules for which characters you may use are specified in terms -## of which characters you must avoid (to keep things as open-ended as -## possible). -## In particular, no white-space can be used, and neither can other -## characters which are already used by Lux as delimiters for other -## Code nodes (thereby reducing ambiguity while parsing). -## Additionally, the first character in an identifier's part cannot be -## a digit, to avoid confusion with regards to numbers. -(def: ident-part^ - (l;Lexer Text) - (do p;Monad - [#let [digits "0123456789" - delimiters (format "()[]{}#\"" identifier-separator) - space (format white-space new-line) - head-lexer (l;none-of (format digits delimiters space)) - tail-lexer (l;some (l;none-of (format delimiters space)))] - head head-lexer - tail tail-lexer] - (wrap (format head tail)))) - -(def: ident^ - (l;Lexer [Ident Nat]) - ($_ p;either - ## When an identifier starts with 2 marks, it's module is - ## taken to be the current-module being compiled at the moment. - ## This can be useful when mentioning identifiers and tags - ## inside quoted/templated code in macros. - (do p;Monad - [#let [current-module-mark (format identifier-separator identifier-separator)] - _ (l;this current-module-mark) - def-name ident-part^] - (p;fail (format "Cannot handle " current-module-mark " syntax for identifiers."))) - ## If the identifier is prefixed by the mark, but no module - ## part, the module is assumed to be "lux" (otherwise known as - ## the 'prelude'). - ## This makes it easy to refer to definitions in that module, - ## since it is the most fundamental module in the entire - ## standard library. - (do p;Monad - [_ (l;this identifier-separator) - def-name ident-part^] - (wrap [["lux" def-name] - (n.inc (text;size def-name))])) - ## Not all identifiers must be specified with a module part. - ## If that part is not provided, the identifier will be created - ## with the empty "" text as the module. - ## During program analysis, such identifiers tend to be treated - ## as if their context is the current-module, but this only - ## applies to identifiers for tags and module definitions. - ## Function arguments and local-variables may not be referred-to - ## using identifiers with module parts, so being able to specify - ## identifiers with empty modules helps with those use-cases. - (do p;Monad - [first-part ident-part^] - (p;either (do @ - [_ (l;this identifier-separator) - second-part ident-part^] - (wrap [[first-part second-part] - ($_ n.+ - (text;size first-part) - +1 - (text;size second-part))])) - (wrap [["" first-part] - (text;size first-part)]))))) - -## The only (syntactic) difference between a symbol and a tag (both -## being identifiers), is that tags must be prefixed with a hash-sign -## (i.e. #). -## Semantically, though, they are very different, with symbols being -## used to refer to module definitions and local variables, while tags -## provide the compiler with information related to data-structure -## construction and de-structuring (during pattern-matching). -(do-template [ ] - [(def: #export ( where) - (-> Cursor (l;Lexer [Cursor Code])) - (do p;Monad - [[value length] ] - (wrap [(update@ #;column (|>. ($_ n.+ length)) where) - [where ( value)]])))] - - [symbol #;Symbol ident^ +0] - [tag #;Tag (p;after (l;this "#") ident^) +1] - ) - -(def: (ast where) - (-> Cursor (l;Lexer [Cursor Code])) - (do p;Monad - [where (left-padding^ where)] - ($_ p;either - (form where ast) - (tuple where ast) - (record where ast) - (bool where) - (nat where) - (frac where) - (int where) - (deg where) - (symbol where) - (tag where) - (text where) - ))) - -(def: #export (parse [where offset source]) - (-> Source (e;Error [Source Code])) - (case (p;run [offset source] (ast where)) - (#e;Error error) - (#e;Error error) - - (#e;Success [[offset' remaining] [where' output]]) - (#e;Success [[where' offset' remaining] output]))) diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux deleted file mode 100644 index 27cc9f6ae..000000000 --- a/new-luxc/test/test/luxc/analyser/case.lux +++ /dev/null @@ -1,227 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "B/" Eq] - ["R" error] - [product] - [maybe] - [text "T/" Eq] - text/format - (coll [list "L/" Monad] - ["S" set])) - ["r" math/random "r/" Monad] - [meta #+ Monad] - (meta [code] - [type "type/" Eq] - (type ["tc" check])) - test) - (luxc ["&" base] - (lang ["la" analysis]) - [analyser] - (analyser ["@" case] - ["@;" common]) - ["@;" module]) - (.. common) - (test/luxc common)) - -(def: (exhaustive-weaving branchings) - (-> (List (List Code)) (List (List Code))) - (case branchings - #;Nil - #;Nil - - (#;Cons head+ #;Nil) - (L/map (|>. list) head+) - - (#;Cons head+ tail++) - (do list;Monad - [tail+ (exhaustive-weaving tail++) - head head+] - (wrap (#;Cons head tail+))))) - -(def: #export (exhaustive-branches allow-literals? variantTC inputC) - (-> Bool (List [Code Code]) Code (r;Random (List Code))) - (case inputC - [_ (#;Bool _)] - (r/wrap (list (' true) (' false))) - - (^template [ ] - [_ ( _)] - (if allow-literals? - (do r;Monad - [?sample (r;maybe )] - (case ?sample - (#;Some sample) - (do @ - [else (exhaustive-branches allow-literals? variantTC inputC)] - (wrap (list& ( sample) else))) - - #;None - (wrap (list (' _))))) - (r/wrap (list (' _))))) - ([#;Nat r;nat code;nat] - [#;Int r;int code;int] - [#;Deg r;deg code;deg] - [#;Frac r;frac code;frac] - [#;Text (r;text +5) code;text]) - - (^ [_ (#;Tuple (list))]) - (r/wrap (list (' []))) - - (^ [_ (#;Record (list))]) - (r/wrap (list (' {}))) - - [_ (#;Tuple members)] - (do r;Monad - [member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) members)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (L/map code;tuple)))) - - [_ (#;Record kvs)] - (do r;Monad - [#let [ks (L/map product;left kvs) - vs (L/map product;right kvs)] - member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) vs)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (L/map (|>. (list;zip2 ks) code;record))))) - - (^ [_ (#;Form (list [_ (#;Tag _)] _))]) - (do r;Monad - [bundles (monad;map @ - (function [[_tag _code]] - (do @ - [v-branches (exhaustive-branches allow-literals? variantTC _code)] - (wrap (L/map (function [pattern] (` ((~ _tag) (~ pattern)))) - v-branches)))) - variantTC)] - (wrap (L/join bundles))) - - _ - (r/wrap (list)) - )) - -(def: #export (input variant-tags record-tags primitivesC) - (-> (List Code) (List Code) (List Code) (r;Random Code)) - (r;rec - (function [input] - ($_ r;either - (r/map product;right gen-primitive) - (do r;Monad - [choice (|> r;nat (:: @ map (n.% (list;size variant-tags)))) - #let [choiceT (maybe;assume (list;nth choice variant-tags)) - choiceC (maybe;assume (list;nth choice primitivesC))]] - (wrap (` ((~ choiceT) (~ choiceC))))) - (do r;Monad - [size (|> r;nat (:: @ map (n.% +3))) - elems (r;list size input)] - (wrap (code;tuple elems))) - (r/wrap (code;record (list;zip2 record-tags primitivesC))) - )))) - -(def: (branch body pattern) - (-> Code Code [Code Code]) - [pattern body]) - -(context: "Pattern-matching." - ## #seed +9253409297339902486 - ## #seed +3793366152923578600 - (<| (seed +5004137551292836565) - ## (times +100) - (do @ - [module-name (r;text +5) - variant-name (r;text +5) - record-name (|> (r;text +5) (r;filter (|>. (T/= variant-name) not))) - size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - variant-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - record-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - primitivesTC (r;list size gen-primitive) - #let [primitivesT (L/map product;left primitivesTC) - primitivesC (L/map product;right primitivesTC) - variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags) - record-tags+ (L/map (|>. [module-name] code;tag) record-tags) - variantTC (list;zip2 variant-tags+ primitivesC)] - inputC (input variant-tags+ record-tags+ primitivesC) - [outputT outputC] gen-primitive - [heterogeneousT heterogeneousC] (|> gen-primitive - (r;filter (|>. product;left (tc;checks? outputT) not))) - exhaustive-patterns (exhaustive-branches true variantTC inputC) - redundant-patterns (exhaustive-branches false variantTC inputC) - redundancy-idx (|> r;nat (:: @ map (n.% (list;size redundant-patterns)))) - heterogeneous-idx (|> r;nat (:: @ map (n.% (list;size exhaustive-patterns)))) - #let [exhaustive-branchesC (L/map (branch outputC) - exhaustive-patterns) - non-exhaustive-branchesC (list;take (n.dec (list;size exhaustive-branchesC)) - exhaustive-branchesC) - redundant-branchesC (<| (L/map (branch outputC)) - list;concat - (list (list;take redundancy-idx redundant-patterns) - (list (maybe;assume (list;nth redundancy-idx redundant-patterns))) - (list;drop redundancy-idx redundant-patterns))) - heterogeneous-branchesC (list;concat (list (list;take heterogeneous-idx exhaustive-branchesC) - (list (let [[_pattern _body] (maybe;assume (list;nth heterogeneous-idx exhaustive-branchesC))] - [_pattern heterogeneousC])) - (list;drop (n.inc heterogeneous-idx) exhaustive-branchesC))) - ]] - ($_ seq - (test "Will reject empty pattern-matching (no branches)." - (|> (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC (list)))) - check-failure)) - (test "Can analyse exhaustive pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC exhaustive-branchesC))))) - check-success)) - (test "Will reject non-exhaustive pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC non-exhaustive-branchesC))))) - check-failure)) - (test "Will reject redundant pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC redundant-branchesC))))) - check-failure)) - (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC heterogeneous-branchesC))))) - check-failure)) - )))) diff --git a/new-luxc/test/test/luxc/analyser/common.lux b/new-luxc/test/test/luxc/analyser/common.lux deleted file mode 100644 index 99090777b..000000000 --- a/new-luxc/test/test/luxc/analyser/common.lux +++ /dev/null @@ -1,52 +0,0 @@ -(;module: - lux - (lux (control pipe) - ["r" math/random "r/" Monad] - (data ["e" error]) - [meta] - (meta [code])) - (luxc ["&" base] - [analyser] - [eval]) - (test/luxc common)) - -(def: gen-unit - (r;Random Code) - (r/wrap (' []))) - -(def: #export gen-primitive - (r;Random [Type Code]) - (with-expansions - [ (do-template [ ] - [(r;seq (r/wrap ) (r/map ))] - - [Unit code;tuple (r;list +0 gen-unit)] - [Bool code;bool r;bool] - [Nat code;nat r;nat] - [Int code;int r;int] - [Deg code;deg r;deg] - [Frac code;frac r;frac] - [Text code;text (r;text +5)] - )] - ($_ r;either - - ))) - -(def: #export analyse - &;Analyser - (analyser;analyser eval;eval)) - -(do-template [ ] - [(def: #export ( analysis) - (All [a] (-> (Meta a) Bool)) - (|> analysis - (meta;run (init-compiler [])) - (case> (#e;Success _) - - - (#e;Error error) - )))] - - [check-success true false] - [check-failure false true] - ) diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux deleted file mode 100644 index 379c4acf4..000000000 --- a/new-luxc/test/test/luxc/analyser/function.lux +++ /dev/null @@ -1,154 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error] - [maybe] - [product] - [text "text/" Eq] - text/format - (coll [list "list/" Functor])) - ["r" math/random "r/" Monad] - [meta] - (meta [code] - [type "type/" Eq]) - test) - (luxc ["&" base] - (lang ["la" analysis]) - [analyser] - (analyser ["@" function] - ["@;" common]) - ["@;" module]) - (.. common) - (test/luxc common)) - -(def: (check-type expectedT error) - (-> Type (e;Error [Type la;Analysis]) Bool) - (case error - (#e;Success [exprT exprA]) - (type/= expectedT exprT) - - _ - false)) - -(def: (succeeds? error) - (All [a] (-> (e;Error a) Bool)) - (case error - (#e;Success _) - true - - (#e;Error _) - false)) - -(def: (flatten-apply analysis) - (-> la;Analysis [la;Analysis (List la;Analysis)]) - (case analysis - (^code ("lux apply" (~ head) (~ func))) - (let [[func' tail] (flatten-apply func)] - [func' (#;Cons head tail)]) - - _ - [analysis (list)])) - -(def: (check-apply expectedT num-args analysis) - (-> Type Nat (Meta [Type la;Analysis]) Bool) - (|> analysis - (meta;run (init-compiler [])) - (case> (#e;Success [applyT applyA]) - (let [[funcA argsA] (flatten-apply applyA)] - (and (type/= expectedT applyT) - (n.= num-args (list;size argsA)))) - - (#e;Error error) - false))) - -(context: "Function definition." - (<| (times +100) - (do @ - [func-name (r;text +5) - arg-name (|> (r;text +5) (r;filter (|>. (text/= func-name) not))) - [outputT outputC] gen-primitive - [inputT _] gen-primitive] - ($_ seq - (test "Can analyse function." - (|> (&;with-expected-type (type (All [a] (-> a outputT))) - (@;analyse-function analyse func-name arg-name outputC)) - (meta;run (init-compiler [])) - succeeds?)) - (test "Generic functions can always be specialized." - (and (|> (&;with-expected-type (-> inputT outputT) - (@;analyse-function analyse func-name arg-name outputC)) - (meta;run (init-compiler [])) - succeeds?) - (|> (&;with-expected-type (-> inputT inputT) - (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) - (meta;run (init-compiler [])) - succeeds?))) - (test "Can infer function (constant output and unused input)." - (|> (@common;with-unknown-type - (@;analyse-function analyse func-name arg-name outputC)) - (meta;run (init-compiler [])) - (check-type (type (All [a] (-> a outputT)))))) - (test "Can infer function (output = input)." - (|> (@common;with-unknown-type - (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) - (meta;run (init-compiler [])) - (check-type (type (All [a] (-> a a)))))) - (test "The function's name is bound to the function's type." - (|> (&;with-expected-type (type (Rec self (-> inputT self))) - (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) - (meta;run (init-compiler [])) - succeeds?)) - )))) - -(context: "Function application." - (<| (times +100) - (do @ - [full-args (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - partial-args (|> r;nat (:: @ map (n.% full-args))) - var-idx (|> r;nat (:: @ map (|>. (n.% full-args) (n.max +1)))) - inputsTC (r;list full-args gen-primitive) - #let [inputsT (list/map product;left inputsTC) - inputsC (list/map product;right inputsTC)] - [outputT outputC] gen-primitive - #let [funcT (type;function inputsT outputT) - partialT (type;function (list;drop partial-args inputsT) outputT) - varT (#;Bound +1) - polyT (<| (type;univ-q +1) - (type;function (list;concat (list (list;take var-idx inputsT) - (list varT) - (list;drop (n.inc var-idx) inputsT)))) - varT) - poly-inputT (maybe;assume (list;nth var-idx inputsT)) - partial-poly-inputsT (list;drop (n.inc var-idx) inputsT) - partial-polyT1 (<| (type;function partial-poly-inputsT) - poly-inputT) - partial-polyT2 (<| (type;univ-q +1) - (type;function (#;Cons varT partial-poly-inputsT)) - varT)]] - ($_ seq - (test "Can analyse monomorphic type application." - (|> (@common;with-unknown-type - (@;analyse-apply analyse funcT (' []) inputsC)) - (check-apply outputT full-args))) - (test "Can partially apply functions." - (|> (@common;with-unknown-type - (@;analyse-apply analyse funcT (' []) - (list;take partial-args inputsC))) - (check-apply partialT partial-args))) - (test "Can apply polymorphic functions." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (' []) inputsC)) - (check-apply poly-inputT full-args))) - (test "Polymorphic partial application propagates found type-vars." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (' []) - (list;take (n.inc var-idx) inputsC))) - (check-apply partial-polyT1 (n.inc var-idx)))) - (test "Polymorphic partial application preserves quantification for type-vars." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (' []) - (list;take var-idx inputsC))) - (check-apply partial-polyT2 var-idx))) - )))) diff --git a/new-luxc/test/test/luxc/analyser/primitive.lux b/new-luxc/test/test/luxc/analyser/primitive.lux deleted file mode 100644 index 8c483428b..000000000 --- a/new-luxc/test/test/luxc/analyser/primitive.lux +++ /dev/null @@ -1,67 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "B/" Eq] - [text "T/" Eq] - (text format - ["l" lexer]) - [number] - ["e" error] - [product] - (coll [list "L/" Functor Fold])) - ["r" math/random] - [meta #+ Monad] - (meta [code] - [type "type/" Eq]) - test) - (luxc ["&" base] - ["&;" module] - (lang ["~" analysis]) - [analyser] - (analyser ["@" primitive] - ["@;" common])) - (.. common) - (test/luxc common)) - -(context: "Primitives" - (<| (times +100) - (do @ - [%bool% r;bool - %nat% r;nat - %int% r;int - %deg% r;deg - %frac% r;frac - %text% (r;text +5)] - (`` ($_ seq - (test "Can analyse unit." - (|> (@common;with-unknown-type - @;analyse-unit) - (meta;run (init-compiler [])) - (case> (^ (#e;Success [_type (^code [])])) - (type/= Unit _type) - - _ - false)) - ) - (~~ (do-template [ ] - [(test (format "Can analyse " ".") - (|> (@common;with-unknown-type - ( )) - (meta;run (init-compiler [])) - (case> (#e;Success [_type [_ ( value)]]) - (and (type/= _type) - (is value)) - - _ - false)) - )] - - ["bool" Bool #;Bool %bool% @;analyse-bool] - ["nat" Nat #;Nat %nat% @;analyse-nat] - ["int" Int #;Int %int% @;analyse-int] - ["deg" Deg #;Deg %deg% @;analyse-deg] - ["frac" Frac #;Frac %frac% @;analyse-frac] - ["text" Text #;Text %text% @;analyse-text] - ))))))) diff --git a/new-luxc/test/test/luxc/analyser/procedure/common.lux b/new-luxc/test/test/luxc/analyser/procedure/common.lux deleted file mode 100644 index 5e1619d38..000000000 --- a/new-luxc/test/test/luxc/analyser/procedure/common.lux +++ /dev/null @@ -1,423 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data text/format - ["e" error] - [product] - (coll [array])) - ["r" math/random "r/" Monad] - [meta #+ Monad] - (meta [code] - [type "type/" Eq]) - test) - (luxc ["&" base] - ["&;" scope] - ["&;" module] - [";L" eval] - (lang ["~" analysis]) - [analyser] - (analyser ["@" procedure] - ["@;" common])) - (../.. common) - (test/luxc common)) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (&;with-scope - (&;with-expected-type output-type - (@;analyse-procedure analyse evalL;eval procedure params))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - - - (#e;Error error) - )))] - - [check-success+ true false] - [check-failure+ false true] - ) - -(context: "Lux procedures" - (<| (times +100) - (do @ - [[primT primC] gen-primitive - [antiT antiC] (|> gen-primitive - (r;filter (|>. product;left (type/= primT) not)))] - ($_ seq - (test "Can test for reference equality." - (check-success+ "lux is" (list primC primC) Bool)) - (test "Reference equality must be done with elements of the same type." - (check-failure+ "lux is" (list primC antiC) Bool)) - (test "Can 'try' risky IO computations." - (check-success+ "lux try" - (list (` ("lux function" (~' _) (~' _) (~ primC)))) - (type (Either Text primT)))) - )))) - -(context: "Bit procedures" - (<| (times +100) - (do @ - [subjectC (|> r;nat (:: @ map code;nat)) - signedC (|> r;int (:: @ map code;int)) - paramC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can count the number of 1 bits in a bit pattern." - (check-success+ "lux bit count" (list subjectC) Nat)) - (test "Can perform bit 'and'." - (check-success+ "lux bit and" (list subjectC paramC) Nat)) - (test "Can perform bit 'or'." - (check-success+ "lux bit or" (list subjectC paramC) Nat)) - (test "Can perform bit 'xor'." - (check-success+ "lux bit xor" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the left." - (check-success+ "lux bit shift-left" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the right." - (check-success+ "lux bit unsigned-shift-right" (list subjectC paramC) Nat)) - (test "Can shift signed bit pattern to the right." - (check-success+ "lux bit shift-right" (list signedC paramC) Int)) - )))) - -(context: "Nat procedures" - (<| (times +100) - (do @ - [subjectC (|> r;nat (:: @ map code;nat)) - paramC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can add natural numbers." - (check-success+ "lux nat +" (list subjectC paramC) Nat)) - (test "Can subtract natural numbers." - (check-success+ "lux nat -" (list subjectC paramC) Nat)) - (test "Can multiply natural numbers." - (check-success+ "lux nat *" (list subjectC paramC) Nat)) - (test "Can divide natural numbers." - (check-success+ "lux nat /" (list subjectC paramC) Nat)) - (test "Can calculate remainder of natural numbers." - (check-success+ "lux nat %" (list subjectC paramC) Nat)) - (test "Can test equality of natural numbers." - (check-success+ "lux nat =" (list subjectC paramC) Bool)) - (test "Can compare natural numbers." - (check-success+ "lux nat <" (list subjectC paramC) Bool)) - (test "Can obtain minimum natural number." - (check-success+ "lux nat min" (list) Nat)) - (test "Can obtain maximum natural number." - (check-success+ "lux nat max" (list) Nat)) - (test "Can convert natural number to integer." - (check-success+ "lux nat to-int" (list subjectC) Int)) - (test "Can convert natural number to text." - (check-success+ "lux nat to-text" (list subjectC) Text)) - )))) - -(context: "Int procedures" - (<| (times +100) - (do @ - [subjectC (|> r;int (:: @ map code;int)) - paramC (|> r;int (:: @ map code;int))] - ($_ seq - (test "Can add integers." - (check-success+ "lux int +" (list subjectC paramC) Int)) - (test "Can subtract integers." - (check-success+ "lux int -" (list subjectC paramC) Int)) - (test "Can multiply integers." - (check-success+ "lux int *" (list subjectC paramC) Int)) - (test "Can divide integers." - (check-success+ "lux int /" (list subjectC paramC) Int)) - (test "Can calculate remainder of integers." - (check-success+ "lux int %" (list subjectC paramC) Int)) - (test "Can test equality of integers." - (check-success+ "lux int =" (list subjectC paramC) Bool)) - (test "Can compare integers." - (check-success+ "lux int <" (list subjectC paramC) Bool)) - (test "Can obtain minimum integer." - (check-success+ "lux int min" (list) Int)) - (test "Can obtain maximum integer." - (check-success+ "lux int max" (list) Int)) - (test "Can convert integer to natural number." - (check-success+ "lux int to-nat" (list subjectC) Nat)) - (test "Can convert integer to frac number." - (check-success+ "lux int to-frac" (list subjectC) Frac)) - )))) - -(context: "Deg procedures" - (<| (times +100) - (do @ - [subjectC (|> r;deg (:: @ map code;deg)) - paramC (|> r;deg (:: @ map code;deg)) - natC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can add degrees." - (check-success+ "lux deg +" (list subjectC paramC) Deg)) - (test "Can subtract degrees." - (check-success+ "lux deg -" (list subjectC paramC) Deg)) - (test "Can multiply degrees." - (check-success+ "lux deg *" (list subjectC paramC) Deg)) - (test "Can divide degrees." - (check-success+ "lux deg /" (list subjectC paramC) Deg)) - (test "Can calculate remainder of degrees." - (check-success+ "lux deg %" (list subjectC paramC) Deg)) - (test "Can test equality of degrees." - (check-success+ "lux deg =" (list subjectC paramC) Bool)) - (test "Can compare degrees." - (check-success+ "lux deg <" (list subjectC paramC) Bool)) - (test "Can obtain minimum degree." - (check-success+ "lux deg min" (list) Deg)) - (test "Can obtain maximum degree." - (check-success+ "lux deg max" (list) Deg)) - (test "Can convert degree to frac number." - (check-success+ "lux deg to-frac" (list subjectC) Frac)) - (test "Can scale degree." - (check-success+ "lux deg scale" (list subjectC natC) Deg)) - (test "Can calculate the reciprocal of a natural number." - (check-success+ "lux deg reciprocal" (list subjectC natC) Deg)) - )))) - -(context: "Frac procedures" - (<| (times +100) - (do @ - [subjectC (|> r;frac (:: @ map code;frac)) - paramC (|> r;frac (:: @ map code;frac)) - encodedC (|> (r;text +5) (:: @ map code;text))] - ($_ seq - (test "Can add frac numbers." - (check-success+ "lux frac +" (list subjectC paramC) Frac)) - (test "Can subtract frac numbers." - (check-success+ "lux frac -" (list subjectC paramC) Frac)) - (test "Can multiply frac numbers." - (check-success+ "lux frac *" (list subjectC paramC) Frac)) - (test "Can divide frac numbers." - (check-success+ "lux frac /" (list subjectC paramC) Frac)) - (test "Can calculate remainder of frac numbers." - (check-success+ "lux frac %" (list subjectC paramC) Frac)) - (test "Can test equality of frac numbers." - (check-success+ "lux frac =" (list subjectC paramC) Bool)) - (test "Can compare frac numbers." - (check-success+ "lux frac <" (list subjectC paramC) Bool)) - (test "Can obtain minimum frac number." - (check-success+ "lux frac min" (list) Frac)) - (test "Can obtain maximum frac number." - (check-success+ "lux frac max" (list) Frac)) - (test "Can obtain smallest frac number." - (check-success+ "lux frac smallest" (list) Frac)) - (test "Can obtain not-a-number." - (check-success+ "lux frac not-a-number" (list) Frac)) - (test "Can obtain positive infinity." - (check-success+ "lux frac positive-infinity" (list) Frac)) - (test "Can obtain negative infinity." - (check-success+ "lux frac negative-infinity" (list) Frac)) - (test "Can convert frac number to integer." - (check-success+ "lux frac to-int" (list subjectC) Int)) - (test "Can convert frac number to degree." - (check-success+ "lux frac to-deg" (list subjectC) Deg)) - (test "Can convert frac number to text." - (check-success+ "lux frac encode" (list subjectC) Text)) - (test "Can convert text to frac number." - (check-success+ "lux frac decode" (list encodedC) (type (Maybe Frac)))) - )))) - -(context: "Text procedures" - (<| (times +100) - (do @ - [subjectC (|> (r;text +5) (:: @ map code;text)) - paramC (|> (r;text +5) (:: @ map code;text)) - replacementC (|> (r;text +5) (:: @ map code;text)) - fromC (|> r;nat (:: @ map code;nat)) - toC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can test text equality." - (check-success+ "lux text =" (list subjectC paramC) Bool)) - (test "Compare texts in lexicographical order." - (check-success+ "lux text <" (list subjectC paramC) Bool)) - (test "Can prepend one text to another." - (check-success+ "lux text prepend" (list subjectC paramC) Text)) - (test "Can find the index of a piece of text inside a larger one that (may) contain it." - (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) - (test "Can query the size/length of a text." - (check-success+ "lux text size" (list subjectC) Nat)) - (test "Can calculate a hash code for text." - (check-success+ "lux text hash" (list subjectC) Nat)) - (test "Can replace a text inside of a larger one (once)." - (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) - (test "Can replace a text inside of a larger one (all times)." - (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) - (test "Can obtain the character code of a text at a given index." - (check-success+ "lux text char" (list subjectC fromC) Nat)) - (test "Can clip a piece of text between 2 indices." - (check-success+ "lux text clip" (list subjectC fromC toC) Text)) - )))) - -(context: "Array procedures" - (<| (times +100) - (do @ - [[elemT elemC] gen-primitive - sizeC (|> r;nat (:: @ map code;nat)) - idxC (|> r;nat (:: @ map code;nat)) - var-name (r;text +5) - #let [arrayT (type (Array elemT))]] - ($_ seq - (test "Can create arrays." - (check-success+ "lux array new" (list sizeC) arrayT)) - (test "Can get a value inside an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-expected-type elemT - (@;analyse-procedure analyse evalL;eval "lux array get" - (list idxC - (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true - - (#e;Error _) - false))) - (test "Can put a value inside an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-expected-type arrayT - (@;analyse-procedure analyse evalL;eval "lux array put" - (list idxC - elemC - (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true - - (#e;Error _) - false))) - (test "Can remove a value from an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-expected-type arrayT - (@;analyse-procedure analyse evalL;eval "lux array remove" - (list idxC - (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true - - (#e;Error _) - false))) - (test "Can query the size of an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-expected-type Nat - (@;analyse-procedure analyse evalL;eval "lux array size" - (list (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true - - (#e;Error _) - false))) - )))) - -(context: "Math procedures" - (<| (times +100) - (do @ - [subjectC (|> r;frac (:: @ map code;frac)) - paramC (|> r;frac (:: @ map code;frac))] - (with-expansions [ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC) Frac))] - - ["lux math cos" "cosine"] - ["lux math sin" "sine"] - ["lux math tan" "tangent"] - ["lux math acos" "inverse/arc cosine"] - ["lux math asin" "inverse/arc sine"] - ["lux math atan" "inverse/arc tangent"] - ["lux math cosh" "hyperbolic cosine"] - ["lux math sinh" "hyperbolic sine"] - ["lux math tanh" "hyperbolic tangent"] - ["lux math exp" "exponentiation"] - ["lux math log" "logarithm"] - ["lux math root2" "square root"] - ["lux math root3" "cubic root"] - ["lux math ceil" "ceiling"] - ["lux math floor" "floor"] - ["lux math round" "rounding"]) - (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC paramC) Frac))] - - ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] - ["lux math pow" "power"])] - ($_ seq - - ))))) - -(context: "Atom procedures" - (<| (times +100) - (do @ - [[elemT elemC] gen-primitive - sizeC (|> r;nat (:: @ map code;nat)) - idxC (|> r;nat (:: @ map code;nat)) - var-name (r;text +5) - #let [atomT (type (atom;Atom elemT))]] - ($_ seq - (test "Can create atomic reference." - (check-success+ "lux atom new" (list elemC) atomT)) - (test "Can read the value of an atomic reference." - (|> (&scope;with-scope "" - (&scope;with-local [var-name atomT] - (&;with-expected-type elemT - (@;analyse-procedure analyse evalL;eval "lux atom read" - (list (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true - - (#e;Error _) - false))) - (test "Can swap the value of an atomic reference." - (|> (&scope;with-scope "" - (&scope;with-local [var-name atomT] - (&;with-expected-type Bool - (@;analyse-procedure analyse evalL;eval "lux atom compare-and-swap" - (list elemC - elemC - (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true - - (#e;Error _) - false))) - )))) - -(context: "Process procedures" - (<| (times +100) - (do @ - [[primT primC] gen-primitive - timeC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can query the level of concurrency." - (check-success+ "lux process concurrency-level" (list) Nat)) - (test "Can run an IO computation concurrently." - (check-success+ "lux process future" - (list (` ("lux function" (~' _) (~' _) (~ primC)))) - Unit)) - (test "Can schedule an IO computation to run concurrently at some future time." - (check-success+ "lux process schedule" - (list timeC - (` ("lux function" (~' _) (~' _) (~ primC)))) - Unit)) - )))) - -(context: "IO procedures" - (<| (times +100) - (do @ - [logC (|> (r;text +5) (:: @ map code;text)) - exitC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can log messages to standard output." - (check-success+ "lux io log" (list logC) Unit)) - (test "Can log messages to standard output." - (check-success+ "lux io error" (list logC) Bottom)) - (test "Can log messages to standard output." - (check-success+ "lux io exit" (list exitC) Bottom)) - (test "Can query the current time (as milliseconds since epoch)." - (check-success+ "lux io current-time" (list) Int)) - )))) diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux deleted file mode 100644 index 3cee1b160..000000000 --- a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux +++ /dev/null @@ -1,529 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data ["e" error] - [product] - [maybe] - [text "text/" Eq] - text/format - (coll [array] - [list "list/" Fold] - [dict])) - ["r" math/random "r/" Monad] - [meta #+ Monad] - (meta [code] - [type]) - test) - (luxc ["&" base] - ["&;" scope] - ["&;" module] - [";L" eval] - (lang ["~" analysis]) - [analyser] - (analyser ["@" procedure] - ["@;" common] - (procedure ["@;" host])) - (generator ["@;" runtime])) - (../.. common) - (test/luxc common)) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (do Monad - [runtime-bytecode @runtime;generate] - (&;with-scope - (&;with-expected-type output-type - (@;analyse-procedure analyse evalL;eval procedure params)))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - - - (#e;Error error) - )))] - - [success true false] - [failure false true] - ) - -(context: "Conversions [double + float]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert double-to-float" "java.lang.Double" @host;Float] - ["jvm convert double-to-int" "java.lang.Double" @host;Integer] - ["jvm convert double-to-long" "java.lang.Double" @host;Long] - ["jvm convert float-to-double" "java.lang.Float" @host;Double] - ["jvm convert float-to-int" "java.lang.Float" @host;Integer] - ["jvm convert float-to-long" "java.lang.Float" @host;Long] - )] - ($_ seq - - ))) - -(context: "Conversions [int]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert int-to-byte" "java.lang.Integer" @host;Byte] - ["jvm convert int-to-char" "java.lang.Integer" @host;Character] - ["jvm convert int-to-double" "java.lang.Integer" @host;Double] - ["jvm convert int-to-float" "java.lang.Integer" @host;Float] - ["jvm convert int-to-long" "java.lang.Integer" @host;Long] - ["jvm convert int-to-short" "java.lang.Integer" @host;Short] - )] - ($_ seq - - ))) - -(context: "Conversions [long]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert long-to-double" "java.lang.Long" @host;Double] - ["jvm convert long-to-float" "java.lang.Long" @host;Float] - ["jvm convert long-to-int" "java.lang.Long" @host;Integer] - ["jvm convert long-to-short" "java.lang.Long" @host;Short] - ["jvm convert long-to-byte" "java.lang.Long" @host;Byte] - )] - ($_ seq - - ))) - -(context: "Conversions [char + byte + short]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert char-to-byte" "java.lang.Character" @host;Byte] - ["jvm convert char-to-short" "java.lang.Character" @host;Short] - ["jvm convert char-to-int" "java.lang.Character" @host;Integer] - ["jvm convert char-to-long" "java.lang.Character" @host;Long] - ["jvm convert byte-to-long" "java.lang.Byte" @host;Long] - ["jvm convert short-to-long" "java.lang.Short" @host;Long] - )] - ($_ seq - - ))) - -(do-template [ ] - [(context: (format "Arithmetic " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " +") ] - [(format "jvm " " -") ] - [(format "jvm " " *") ] - [(format "jvm " " /") ] - [(format "jvm " " %") ] - )] - ($_ seq - - ))) - - (context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") @host;Boolean] - [(format "jvm " " <") @host;Boolean] - )] - ($_ seq - - ))) - - (context: (format "Bitwise " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " and") ] - [(format "jvm " " or") ] - [(format "jvm " " xor") ] - [(format "jvm " " shl") "java.lang.Integer" ] - [(format "jvm " " shr") "java.lang.Integer" ] - [(format "jvm " " ushr") "java.lang.Integer" ] - )] - ($_ seq - - )))] - - - ["int" "java.lang.Integer" @host;Integer] - ["long" "java.lang.Long" @host;Long] - ) - -(do-template [ ] - [(context: (format "Arithmetic " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " +") ] - [(format "jvm " " -") ] - [(format "jvm " " *") ] - [(format "jvm " " /") ] - [(format "jvm " " %") ] - )] - ($_ seq - - ))) - - (context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") @host;Boolean] - [(format "jvm " " <") @host;Boolean] - )] - ($_ seq - - )))] - - - ["float" "java.lang.Float" @host;Float] - ["double" "java.lang.Double" @host;Double] - ) - -(do-template [ ] - [(context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") @host;Boolean] - [(format "jvm " " <") @host;Boolean] - )] - ($_ seq - - )))] - - - ["char" "java.lang.Character" @host;Character] - ) - -(def: array-type - (r;Random [Text Text]) - (let [entries (dict;entries @host;boxes) - num-entries (list;size entries)] - (do r;Monad - [choice (|> r;nat (:: @ map (n.% (n.inc num-entries)))) - #let [[unboxed boxed] (: [Text Text] - (|> entries - (list;nth choice) - (maybe;default ["java.lang.Object" "java.lang.Object"])))]] - (wrap [unboxed boxed])))) - -(context: "Array." - (<| (times +100) - (do @ - [#let [cap (|>. (n.% +10) (n.max +1))] - [unboxed boxed] array-type - size (|> r;nat (:: @ map cap)) - idx (|> r;nat (:: @ map (n.% size))) - level (|> r;nat (:: @ map cap)) - #let [unboxedT (#;Primitive unboxed (list)) - arrayT (#;Primitive "#Array" (list unboxedT)) - arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code;text unboxed)) (+0)) (+0))) - ("jvm array new" (~ (code;nat size))))) - boxedT (#;Primitive boxed (list)) - boxedTC (` (+0 (~ (code;text boxed)) (+0))) - multi-arrayT (list/fold (function [_ innerT] - (|> innerT (list) (#;Primitive "#Array"))) - boxedT - (list;n.range +1 level))]] - ($_ seq - (test "jvm array new" - (success "jvm array new" - (list (code;nat size)) - arrayT)) - (test "jvm array new (no nesting)" - (failure "jvm array new" - (list (code;nat size)) - unboxedT)) - (test "jvm array new (nested/multi-level)" - (success "jvm array new" - (list (code;nat size)) - multi-arrayT)) - (test "jvm array length" - (success "jvm array length" - (list arrayC) - Nat)) - (test "jvm array read" - (success "jvm array read" - (list arrayC (code;nat idx)) - boxedT)) - (test "jvm array write" - (success "jvm array write" - (list arrayC (code;nat idx) (`' ("lux coerce" (~ boxedTC) []))) - arrayT)) - )))) - -(def: throwables - (List Text) - (list "java.lang.Throwable" - "java.lang.Error" - "java.io.IOError" - "java.lang.VirtualMachineError" - "java.lang.Exception" - "java.io.IOException" - "java.lang.RuntimeException")) - -(context: "Object." - (<| (times +100) - (do @ - [[unboxed boxed] array-type - [!unboxed !boxed] (|> array-type - (r;filter (function [[!unboxed !boxed]] - (not (text/= boxed !boxed))))) - #let [boxedT (#;Primitive boxed (list)) - boxedC (`' ("lux check" (+0 (~ (code;text boxed)) (+0)) - ("jvm object null"))) - !boxedC (`' ("lux check" (+0 (~ (code;text !boxed)) (+0)) - ("jvm object null"))) - unboxedC (`' ("lux check" (+0 (~ (code;text unboxed)) (+0)) - ("jvm object null")))] - throwable (|> r;nat - (:: @ map (n.% (n.inc (list;size throwables)))) - (:: @ map (function [idx] - (|> throwables - (list;nth idx) - (maybe;default "java.lang.Object"))))) - #let [throwableC (`' ("lux check" (+0 (~ (code;text throwable)) (+0)) - ("jvm object null")))]] - ($_ seq - (test "jvm object null" - (success "jvm object null" - (list) - (#;Primitive boxed (list)))) - (test "jvm object null (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object null" - (list) - (#;Primitive unboxed (list))))) - (test "jvm object null?" - (success "jvm object null?" - (list boxedC) - Bool)) - (test "jvm object synchronized" - (success "jvm object synchronized" - (list boxedC boxedC) - boxedT)) - (test "jvm object synchronized (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object synchronized" - (list unboxedC boxedC) - boxedT))) - (test "jvm object throw" - (or (text/= "java.lang.Object" throwable) - (success "jvm object throw" - (list throwableC) - Bottom))) - (test "jvm object class" - (success "jvm object class" - (list (code;text boxed)) - (#;Primitive "java.lang.Class" (list boxedT)))) - (test "jvm object instance?" - (success "jvm object instance?" - (list (code;text boxed) - boxedC) - Bool)) - (test "jvm object instance? (lineage)" - (success "jvm object instance?" - (list (' "java.lang.Object") - boxedC) - Bool)) - (test "jvm object instance? (no lineage)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object instance?" - (list (code;text boxed) - !boxedC) - Bool))) - )))) - -(context: "Member [Static Field]." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code;text "java.lang.System") - (code;text "out")) - (#;Primitive "java.io.PrintStream" (list)))) - (test "jvm member static get (inheritance out)" - (success "jvm member static get" - (list (code;text "java.lang.System") - (code;text "out")) - (#;Primitive "java.lang.Object" (list)))) - (test "jvm member static put" - (success "jvm member static put" - (list (code;text "java.awt.datatransfer.DataFlavor") - (code;text "allHtmlFlavor") - (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) - ("jvm object null")))) - Unit)) - (test "jvm member static put (final)" - (failure "jvm member static put" - (list (code;text "java.lang.System") - (code;text "out") - (`' ("lux check" (+0 "java.io.PrintStream" (+0)) - ("jvm object null")))) - Unit)) - (test "jvm member static put (inheritance in)" - (success "jvm member static put" - (list (code;text "java.awt.datatransfer.DataFlavor") - (code;text "allHtmlFlavor") - (`' ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) - ("jvm object null")))) - Unit)) - )) - -(context: "Member [Virtual Field]." - ($_ seq - (test "jvm member virtual get" - (success "jvm member virtual get" - (list (code;text "org.omg.CORBA.ValueMember") - (code;text "id") - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (#;Primitive "java.lang.String" (list)))) - (test "jvm member virtual get (inheritance out)" - (success "jvm member virtual get" - (list (code;text "org.omg.CORBA.ValueMember") - (code;text "id") - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (#;Primitive "java.lang.Object" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code;text "org.omg.CORBA.ValueMember") - (code;text "id") - (`' ("lux check" (+0 "java.lang.String" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (primitive org.omg.CORBA.ValueMember))) - (test "jvm member virtual put (final)" - (failure "jvm member virtual put" - (list (code;text "javax.swing.text.html.parser.DTD") - (code;text "applet") - (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) - ("jvm object null")))) - (primitive javax.swing.text.html.parser.DTD))) - (test "jvm member virtual put (inheritance in)" - (success "jvm member virtual put" - (list (code;text "java.awt.GridBagConstraints") - (code;text "insets") - (`' ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) - ("jvm object null")))) - (primitive java.awt.GridBagConstraints))) - )) - -(context: "Boxing/Unboxing." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code;text "java.util.GregorianCalendar") - (code;text "AD")) - (#;Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual get" - (success "jvm member virtual get" - (list (code;text "javax.accessibility.AccessibleAttributeSequence") - (code;text "startIndex") - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (#;Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code;text "javax.accessibility.AccessibleAttributeSequence") - (code;text "startIndex") - (`' ("lux check" (+0 "java.lang.Integer" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (primitive javax.accessibility.AccessibleAttributeSequence))) - )) - -(context: "Member [Method]." - (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) - +123)) - intC (`' ("jvm convert long-to-int" (~ longC))) - objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) - ("jvm member invoke constructor" "java.util.ArrayList" - ["int" (~ intC)])))] - ($_ seq - (test "jvm member invoke static" - (success "jvm member invoke static" - (list (code;text "java.lang.Long") - (code;text "decode") - (code;tuple (list (' "java.lang.String") - (' ("lux coerce" (+0 "java.lang.String" (+0)) - "YOLO"))))) - (#;Primitive "java.lang.Long" (list)))) - (test "jvm member invoke virtual" - (success "jvm member invoke virtual" - (list (code;text "java.lang.Object") - (code;text "equals") - longC - (code;tuple (list (' "java.lang.Object") - longC))) - (#;Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke special" - (success "jvm member invoke special" - (list (code;text "java.lang.Long") - (code;text "equals") - longC - (code;tuple (list (' "java.lang.Object") - longC))) - (#;Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke interface" - (success "jvm member invoke interface" - (list (code;text "java.util.Collection") - (code;text "add") - objectC - (code;tuple (list (' "java.lang.Object") - longC))) - (#;Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke constructor" - (success "jvm member invoke constructor" - (list (code;text "java.util.ArrayList") - (code;tuple (list (' "int") intC))) - (All [a] (#;Primitive "java.util.ArrayList" (list a))))) - ))) diff --git a/new-luxc/test/test/luxc/analyser/reference.lux b/new-luxc/test/test/luxc/analyser/reference.lux deleted file mode 100644 index e9d66838a..000000000 --- a/new-luxc/test/test/luxc/analyser/reference.lux +++ /dev/null @@ -1,52 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error]) - ["r" math/random] - [meta #+ Monad] - (meta [type "type/" Eq]) - test) - (luxc ["&;" scope] - ["&;" module] - (lang ["~" analysis]) - [analyser] - (analyser ["@" reference] - ["@;" common])) - (.. common) - (test/luxc common)) - -(context: "References" - (<| (times +100) - (do @ - [[ref-type _] gen-primitive - module-name (r;text +5) - scope-name (r;text +5) - var-name (r;text +5)] - ($_ seq - (test "Can analyse variable." - (|> (&scope;with-scope scope-name - (&scope;with-local [var-name ref-type] - (@common;with-unknown-type - (@;analyse-reference ["" var-name])))) - (meta;run (init-compiler [])) - (case> (^ (#e;Success [_type (^code ((~ [_ (#;Int var)])))])) - (type/= ref-type _type) - - _ - false))) - (test "Can analyse definition." - (|> (do Monad - [_ (&module;create +0 module-name) - _ (&module;define [module-name var-name] - [ref-type (' {}) (:! Void [])])] - (@common;with-unknown-type - (@;analyse-reference [module-name var-name]))) - (meta;run (init-compiler [])) - (case> (#e;Success [_type [_ (#;Symbol def-name)]]) - (type/= ref-type _type) - - _ - false))) - )))) diff --git a/new-luxc/test/test/luxc/analyser/structure.lux b/new-luxc/test/test/luxc/analyser/structure.lux deleted file mode 100644 index 5f88aea37..000000000 --- a/new-luxc/test/test/luxc/analyser/structure.lux +++ /dev/null @@ -1,336 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "bool/" Eq] - ["e" error] - [product] - [maybe] - [text] - text/format - (coll [list "list/" Functor] - ["S" set])) - ["r" math/random "r/" Monad] - [meta] - (meta [code] - [type "type/" Eq] - (type ["tc" check])) - test) - (luxc ["&" base] - (lang ["la" analysis]) - [analyser] - (analyser ["@" structure] - ["@;" common]) - ["@;" module]) - (.. common) - (test/luxc common)) - -(context: "Sums" - (<| (times +100) - (do @ - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - choice (|> r;nat (:: @ map (n.% size))) - primitives (r;list size gen-primitive) - +choice (|> r;nat (:: @ map (n.% (n.inc size)))) - [_ +valueC] gen-primitive - #let [variantT (type;variant (list/map product;left primitives)) - [valueT valueC] (maybe;assume (list;nth choice primitives)) - +size (n.inc size) - +primitives (list;concat (list (list;take choice primitives) - (list [(#;Bound +1) +valueC]) - (list;drop choice primitives))) - [+valueT +valueC] (maybe;assume (list;nth +choice +primitives)) - +variantT (type;variant (list/map product;left +primitives))]] - ($_ seq - (test "Can analyse sum." - (|> (&;with-scope - (&;with-expected-type variantT - (@;analyse-sum analyse choice valueC))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ sumA]) - [(la;unfold-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag choice) - (bool/= last? (n.= (n.dec size) choice))) - - _ - false))) - (test "Can analyse sum through bound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] - (do meta;Monad - [_ (&;with-type-env - (tc;check varT variantT))] - (&;with-expected-type varT - (@;analyse-sum analyse choice valueC)))))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ sumA]) - [(la;unfold-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag choice) - (bool/= last? (n.= (n.dec size) choice))) - - _ - false))) - (test "Cannot analyse sum through unbound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] - (&;with-expected-type varT - (@;analyse-sum analyse choice valueC))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - false - - _ - true))) - (test "Can analyse sum through existential quantification." - (|> (&;with-scope - (&;with-expected-type (type;ex-q +1 +variantT) - (@;analyse-sum analyse +choice +valueC))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true - - (#e;Error error) - false))) - (test "Can analyse sum through universal quantification." - (|> (&;with-scope - (&;with-expected-type (type;univ-q +1 +variantT) - (@;analyse-sum analyse +choice +valueC))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - (not (n.= choice +choice)) - - (#e;Error error) - (n.= choice +choice)))) - )))) - -(context: "Products" - (<| (times +100) - (do @ - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - primitives (r;list size gen-primitive) - choice (|> r;nat (:: @ map (n.% size))) - [_ +valueC] gen-primitive - #let [[singletonT singletonC] (|> primitives (list;nth choice) maybe;assume) - +primitives (list;concat (list (list;take choice primitives) - (list [(#;Bound +1) +valueC]) - (list;drop choice primitives))) - +tupleT (type;tuple (list/map product;left +primitives))]] - ($_ seq - (test "Can analyse product." - (|> (&;with-expected-type (type;tuple (list/map product;left primitives)) - (@;analyse-product analyse (list/map product;right primitives))) - (meta;run (init-compiler [])) - (case> (#e;Success tupleA) - (n.= size (list;size (la;unfold-tuple tupleA))) - - _ - false))) - (test "Can infer product." - (|> (@common;with-unknown-type - (@;analyse-product analyse (list/map product;right primitives))) - (meta;run (init-compiler [])) - (case> (#e;Success [_type tupleA]) - (and (type/= (type;tuple (list/map product;left primitives)) - _type) - (n.= size (list;size (la;unfold-tuple tupleA)))) - - _ - false))) - (test "Can analyse pseudo-product (singleton tuple)" - (|> (&;with-expected-type singletonT - (analyse (` [(~ singletonC)]))) - (meta;run (init-compiler [])) - (case> (#e;Success singletonA) - true - - (#e;Error error) - false))) - (test "Can analyse product through bound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] - (do meta;Monad - [_ (&;with-type-env - (tc;check varT (type;tuple (list/map product;left primitives))))] - (&;with-expected-type varT - (@;analyse-product analyse (list/map product;right primitives))))))) - (meta;run (init-compiler [])) - (case> (#e;Success [_ tupleA]) - (n.= size (list;size (la;unfold-tuple tupleA))) - - _ - false))) - (test "Can analyse product through existential quantification." - (|> (&;with-scope - (&;with-expected-type (type;ex-q +1 +tupleT) - (@;analyse-product analyse (list/map product;right +primitives)))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true - - (#e;Error error) - false))) - (test "Cannot analyse product through universal quantification." - (|> (&;with-scope - (&;with-expected-type (type;univ-q +1 +tupleT) - (@;analyse-product analyse (list/map product;right +primitives)))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - false - - (#e;Error error) - true))) - )))) - -(def: (check-variant-inference variantT choice size analysis) - (-> Type Nat Nat (Meta [Module Scope Type la;Analysis]) Bool) - (|> analysis - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ sumT sumA]) - [(la;unfold-variant sumA) - (#;Some [tag last? valueA])]) - (and (type/= variantT sumT) - (n.= tag choice) - (bool/= last? (n.= (n.dec size) choice))) - - _ - false))) - -(def: (check-record-inference tupleT size analysis) - (-> Type Nat (Meta [Module Scope Type la;Analysis]) Bool) - (|> analysis - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ productT productA]) - [(la;unfold-tuple productA) - membersA]) - (and (type/= tupleT productT) - (n.= size (list;size membersA))) - - _ - false))) - -(context: "Tagged Sums" - (<| (times +100) - (do @ - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - choice (|> r;nat (:: @ map (n.% size))) - other-choice (|> r;nat (:: @ map (n.% size)) (r;filter (|>. (n.= choice) not))) - primitives (r;list size gen-primitive) - module-name (r;text +5) - type-name (r;text +5) - #let [varT (#;Bound +1) - primitivesT (list/map product;left primitives) - [choiceT choiceC] (maybe;assume (list;nth choice primitives)) - [other-choiceT other-choiceC] (maybe;assume (list;nth other-choice primitives)) - variantT (type;variant primitivesT) - namedT (#;Named [module-name type-name] variantT) - polyT (|> (type;variant (list;concat (list (list;take choice primitivesT) - (list varT) - (list;drop (n.inc choice) primitivesT)))) - (type;univ-q +1)) - named-polyT (#;Named [module-name type-name] polyT) - choice-tag (maybe;assume (list;nth choice tags)) - other-choice-tag (maybe;assume (list;nth other-choice tags))]] - ($_ seq - (test "Can infer tagged sum." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false namedT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) - (check-variant-inference variantT choice size))) - (test "Tagged sums specialize when type-vars get bound." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) - (check-variant-inference variantT choice size))) - (test "Tagged sum inference retains universal quantification when type-vars are not bound." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) - (check-variant-inference polyT other-choice size))) - (test "Can specialize generic tagged sums." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (&;with-expected-type variantT - (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ sumA]) - [(la;unfold-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag other-choice) - (bool/= last? (n.= (n.dec size) other-choice))) - - _ - false))) - )))) - -(context: "Records" - (<| (times +100) - (do @ - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - primitives (r;list size gen-primitive) - module-name (r;text +5) - type-name (r;text +5) - choice (|> r;nat (:: @ map (n.% size))) - #let [varT (#;Bound +1) - tagsC (list/map (|>. [module-name] code;tag) tags) - primitivesT (list/map product;left primitives) - primitivesC (list/map product;right primitives) - tupleT (type;tuple primitivesT) - namedT (#;Named [module-name type-name] tupleT) - recordC (list;zip2 tagsC primitivesC) - polyT (|> (type;tuple (list;concat (list (list;take choice primitivesT) - (list varT) - (list;drop (n.inc choice) primitivesT)))) - (type;univ-q +1)) - named-polyT (#;Named [module-name type-name] polyT)]] - ($_ seq - (test "Can infer record." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false namedT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-record analyse recordC))))) - (check-record-inference tupleT size))) - (test "Records specialize when type-vars get bound." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-record analyse recordC))))) - (check-record-inference tupleT size))) - (test "Can specialize generic records." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (&;with-expected-type tupleT - (@;analyse-record analyse recordC))))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ productA]) - [(la;unfold-tuple productA) - membersA]) - (n.= size (list;size membersA)) - - _ - false))) - )))) diff --git a/new-luxc/test/test/luxc/analyser/type.lux b/new-luxc/test/test/luxc/analyser/type.lux deleted file mode 100644 index 978e450b6..000000000 --- a/new-luxc/test/test/luxc/analyser/type.lux +++ /dev/null @@ -1,91 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "bool/" Eq] - [text "text/" Eq] - (text format - ["l" lexer]) - [number] - ["e" error] - [product] - (coll [list "list/" Functor Fold])) - ["r" math/random "r/" Monad] - [meta #+ Monad] - (meta [code] - [type "type/" Eq]) - test) - (luxc ["&" base] - ["&;" module] - (lang ["~" analysis]) - [analyser] - (analyser ["@" type] - ["@;" common]) - (generator ["@;" runtime]) - [eval]) - (.. common) - (test/luxc common)) - -(def: check - (r;Random [Code Type Code]) - (with-expansions [ (do-template [ ] - [(do r;Monad - [value ] - (wrap [(` ) - - ( value)]))] - - [r;bool (+0 "#Bool" (+0)) code;bool] - [r;nat (+0 "#Nat" (+0)) code;nat] - [r;int (+0 "#Int" (+0)) code;int] - [r;deg (+0 "#Deg" (+0)) code;deg] - [r;frac (+0 "#Frac" (+0)) code;frac] - [(r;text +5) (+0 "#Text" (+0)) code;text] - )] - ($_ r;either - ))) - -(context: "Type checking/coercion." - (<| (times +100) - (do @ - [[typeC codeT exprC] check] - ($_ seq - (test (format "Can analyse type-checking.") - (|> (do Monad - [runtime-bytecode @runtime;generate] - (&;with-scope - (@common;with-unknown-type - (@;analyse-check analyse eval;eval typeC exprC)))) - (meta;run (init-compiler [])) - (case> (#e;Success [_ [analysisT analysisA]]) - (and (type/= codeT analysisT) - (case [exprC analysisA] - (^template [ ] - [[_ ( expected)] [_ ( actual)]] - ( expected actual)) - ([#;Bool bool/=] - [#;Nat n.=] - [#;Int i.=] - [#;Deg d.=] - [#;Frac f.=] - [#;Text text/=]) - - _ - false)) - - (#e;Error error) - false))) - (test (format "Can analyse type-coercion.") - (|> (do Monad - [runtime-bytecode @runtime;generate] - (&;with-scope - (@common;with-unknown-type - (@;analyse-coerce analyse eval;eval typeC exprC)))) - (meta;run (init-compiler [])) - (case> (#e;Success [_ [analysisT analysisA]]) - (type/= codeT analysisT) - - (#e;Error error) - false))) - )))) diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux index cfbe31de8..7763cd852 100644 --- a/new-luxc/test/test/luxc/generator/case.lux +++ b/new-luxc/test/test/luxc/generator/case.lux @@ -11,7 +11,6 @@ (meta [code]) test) (luxc (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator ["@" case] [";G" expression] diff --git a/new-luxc/test/test/luxc/generator/function.lux b/new-luxc/test/test/luxc/generator/function.lux index 5620996b5..e7a0e7d61 100644 --- a/new-luxc/test/test/luxc/generator/function.lux +++ b/new-luxc/test/test/luxc/generator/function.lux @@ -14,7 +14,6 @@ [host] test) (luxc (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator [";G" expression] ["@;" eval] diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux index 84f47f146..6de14d0e5 100644 --- a/new-luxc/test/test/luxc/generator/primitive.lux +++ b/new-luxc/test/test/luxc/generator/primitive.lux @@ -13,7 +13,6 @@ test) (luxc [";L" host] (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator [";G" expression] ["@;" runtime] diff --git a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux index 79829672d..5e3c07bea 100644 --- a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux @@ -17,7 +17,6 @@ [host] test) (luxc (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator [";G" expression] ["@;" eval] diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux index 8db98ed37..d571c578b 100644 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux @@ -18,7 +18,6 @@ test) (luxc [";L" host] (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator [";G" expression] ["@;" eval] diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux index 9143ba5c8..37320fa99 100644 --- a/new-luxc/test/test/luxc/generator/structure.lux +++ b/new-luxc/test/test/luxc/generator/structure.lux @@ -17,7 +17,6 @@ test) (luxc [";L" host] (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator [";G" expression] ["@;" eval] diff --git a/new-luxc/test/test/luxc/lang/analysis/case.lux b/new-luxc/test/test/luxc/lang/analysis/case.lux new file mode 100644 index 000000000..66646754e --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/case.lux @@ -0,0 +1,227 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "B/" Eq] + ["R" error] + [product] + [maybe] + [text "T/" Eq] + text/format + (coll [list "L/" Monad] + ["S" set])) + ["r" math/random "r/" Monad] + [meta #+ Monad] + (meta [code] + [type "type/" Eq] + (type ["tc" check])) + test) + (luxc ["&" base] + (lang ["la" analysis] + (analysis [";A" expression] + ["@" case] + ["@;" common])) + ["@;" module]) + (.. common) + (test/luxc common)) + +(def: (exhaustive-weaving branchings) + (-> (List (List Code)) (List (List Code))) + (case branchings + #;Nil + #;Nil + + (#;Cons head+ #;Nil) + (L/map (|>. list) head+) + + (#;Cons head+ tail++) + (do list;Monad + [tail+ (exhaustive-weaving tail++) + head head+] + (wrap (#;Cons head tail+))))) + +(def: #export (exhaustive-branches allow-literals? variantTC inputC) + (-> Bool (List [Code Code]) Code (r;Random (List Code))) + (case inputC + [_ (#;Bool _)] + (r/wrap (list (' true) (' false))) + + (^template [ ] + [_ ( _)] + (if allow-literals? + (do r;Monad + [?sample (r;maybe )] + (case ?sample + (#;Some sample) + (do @ + [else (exhaustive-branches allow-literals? variantTC inputC)] + (wrap (list& ( sample) else))) + + #;None + (wrap (list (' _))))) + (r/wrap (list (' _))))) + ([#;Nat r;nat code;nat] + [#;Int r;int code;int] + [#;Deg r;deg code;deg] + [#;Frac r;frac code;frac] + [#;Text (r;text +5) code;text]) + + (^ [_ (#;Tuple (list))]) + (r/wrap (list (' []))) + + (^ [_ (#;Record (list))]) + (r/wrap (list (' {}))) + + [_ (#;Tuple members)] + (do r;Monad + [member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) members)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (L/map code;tuple)))) + + [_ (#;Record kvs)] + (do r;Monad + [#let [ks (L/map product;left kvs) + vs (L/map product;right kvs)] + member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) vs)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (L/map (|>. (list;zip2 ks) code;record))))) + + (^ [_ (#;Form (list [_ (#;Tag _)] _))]) + (do r;Monad + [bundles (monad;map @ + (function [[_tag _code]] + (do @ + [v-branches (exhaustive-branches allow-literals? variantTC _code)] + (wrap (L/map (function [pattern] (` ((~ _tag) (~ pattern)))) + v-branches)))) + variantTC)] + (wrap (L/join bundles))) + + _ + (r/wrap (list)) + )) + +(def: #export (input variant-tags record-tags primitivesC) + (-> (List Code) (List Code) (List Code) (r;Random Code)) + (r;rec + (function [input] + ($_ r;either + (r/map product;right gen-primitive) + (do r;Monad + [choice (|> r;nat (:: @ map (n.% (list;size variant-tags)))) + #let [choiceT (maybe;assume (list;nth choice variant-tags)) + choiceC (maybe;assume (list;nth choice primitivesC))]] + (wrap (` ((~ choiceT) (~ choiceC))))) + (do r;Monad + [size (|> r;nat (:: @ map (n.% +3))) + elems (r;list size input)] + (wrap (code;tuple elems))) + (r/wrap (code;record (list;zip2 record-tags primitivesC))) + )))) + +(def: (branch body pattern) + (-> Code Code [Code Code]) + [pattern body]) + +(context: "Pattern-matching." + ## #seed +9253409297339902486 + ## #seed +3793366152923578600 + (<| (seed +5004137551292836565) + ## (times +100) + (do @ + [module-name (r;text +5) + variant-name (r;text +5) + record-name (|> (r;text +5) (r;filter (|>. (T/= variant-name) not))) + size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + variant-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + record-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + primitivesTC (r;list size gen-primitive) + #let [primitivesT (L/map product;left primitivesTC) + primitivesC (L/map product;right primitivesTC) + variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags) + record-tags+ (L/map (|>. [module-name] code;tag) record-tags) + variantTC (list;zip2 variant-tags+ primitivesC)] + inputC (input variant-tags+ record-tags+ primitivesC) + [outputT outputC] gen-primitive + [heterogeneousT heterogeneousC] (|> gen-primitive + (r;filter (|>. product;left (tc;checks? outputT) not))) + exhaustive-patterns (exhaustive-branches true variantTC inputC) + redundant-patterns (exhaustive-branches false variantTC inputC) + redundancy-idx (|> r;nat (:: @ map (n.% (list;size redundant-patterns)))) + heterogeneous-idx (|> r;nat (:: @ map (n.% (list;size exhaustive-patterns)))) + #let [exhaustive-branchesC (L/map (branch outputC) + exhaustive-patterns) + non-exhaustive-branchesC (list;take (n.dec (list;size exhaustive-branchesC)) + exhaustive-branchesC) + redundant-branchesC (<| (L/map (branch outputC)) + list;concat + (list (list;take redundancy-idx redundant-patterns) + (list (maybe;assume (list;nth redundancy-idx redundant-patterns))) + (list;drop redundancy-idx redundant-patterns))) + heterogeneous-branchesC (list;concat (list (list;take heterogeneous-idx exhaustive-branchesC) + (list (let [[_pattern _body] (maybe;assume (list;nth heterogeneous-idx exhaustive-branchesC))] + [_pattern heterogeneousC])) + (list;drop (n.inc heterogeneous-idx) exhaustive-branchesC))) + ]] + ($_ seq + (test "Will reject empty pattern-matching (no branches)." + (|> (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC (list)))) + check-failure)) + (test "Can analyse exhaustive pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC exhaustive-branchesC))))) + check-success)) + (test "Will reject non-exhaustive pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC non-exhaustive-branchesC))))) + check-failure)) + (test "Will reject redundant pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC redundant-branchesC))))) + check-failure)) + (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC heterogeneous-branchesC))))) + check-failure)) + )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/common.lux b/new-luxc/test/test/luxc/lang/analysis/common.lux new file mode 100644 index 000000000..937ed4cda --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/common.lux @@ -0,0 +1,52 @@ +(;module: + lux + (lux (control pipe) + ["r" math/random "r/" Monad] + (data ["e" error]) + [meta] + (meta [code])) + (luxc ["&" base] + (lang (analysis [";A" expression])) + [eval]) + (test/luxc common)) + +(def: gen-unit + (r;Random Code) + (r/wrap (' []))) + +(def: #export gen-primitive + (r;Random [Type Code]) + (with-expansions + [ (do-template [ ] + [(r;seq (r/wrap ) (r/map ))] + + [Unit code;tuple (r;list +0 gen-unit)] + [Bool code;bool r;bool] + [Nat code;nat r;nat] + [Int code;int r;int] + [Deg code;deg r;deg] + [Frac code;frac r;frac] + [Text code;text (r;text +5)] + )] + ($_ r;either + + ))) + +(def: #export analyse + &;Analyser + (expressionA;analyser eval;eval)) + +(do-template [ ] + [(def: #export ( analysis) + (All [a] (-> (Meta a) Bool)) + (|> analysis + (meta;run (init-compiler [])) + (case> (#e;Success _) + + + (#e;Error error) + )))] + + [check-success true false] + [check-failure false true] + ) diff --git a/new-luxc/test/test/luxc/lang/analysis/function.lux b/new-luxc/test/test/luxc/lang/analysis/function.lux new file mode 100644 index 000000000..1a2f13458 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/function.lux @@ -0,0 +1,154 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [maybe] + [product] + [text "text/" Eq] + text/format + (coll [list "list/" Functor])) + ["r" math/random "r/" Monad] + [meta] + (meta [code] + [type "type/" Eq]) + test) + (luxc ["&" base] + (lang ["la" analysis] + (analysis [";A" expression] + ["@" function] + ["@;" common])) + ["@;" module]) + (.. common) + (test/luxc common)) + +(def: (check-type expectedT error) + (-> Type (e;Error [Type la;Analysis]) Bool) + (case error + (#e;Success [exprT exprA]) + (type/= expectedT exprT) + + _ + false)) + +(def: (succeeds? error) + (All [a] (-> (e;Error a) Bool)) + (case error + (#e;Success _) + true + + (#e;Error _) + false)) + +(def: (flatten-apply analysis) + (-> la;Analysis [la;Analysis (List la;Analysis)]) + (case analysis + (^code ("lux apply" (~ head) (~ func))) + (let [[func' tail] (flatten-apply func)] + [func' (#;Cons head tail)]) + + _ + [analysis (list)])) + +(def: (check-apply expectedT num-args analysis) + (-> Type Nat (Meta [Type la;Analysis]) Bool) + (|> analysis + (meta;run (init-compiler [])) + (case> (#e;Success [applyT applyA]) + (let [[funcA argsA] (flatten-apply applyA)] + (and (type/= expectedT applyT) + (n.= num-args (list;size argsA)))) + + (#e;Error error) + false))) + +(context: "Function definition." + (<| (times +100) + (do @ + [func-name (r;text +5) + arg-name (|> (r;text +5) (r;filter (|>. (text/= func-name) not))) + [outputT outputC] gen-primitive + [inputT _] gen-primitive] + ($_ seq + (test "Can analyse function." + (|> (&;with-expected-type (type (All [a] (-> a outputT))) + (@;analyse-function analyse func-name arg-name outputC)) + (meta;run (init-compiler [])) + succeeds?)) + (test "Generic functions can always be specialized." + (and (|> (&;with-expected-type (-> inputT outputT) + (@;analyse-function analyse func-name arg-name outputC)) + (meta;run (init-compiler [])) + succeeds?) + (|> (&;with-expected-type (-> inputT inputT) + (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) + (meta;run (init-compiler [])) + succeeds?))) + (test "Can infer function (constant output and unused input)." + (|> (@common;with-unknown-type + (@;analyse-function analyse func-name arg-name outputC)) + (meta;run (init-compiler [])) + (check-type (type (All [a] (-> a outputT)))))) + (test "Can infer function (output = input)." + (|> (@common;with-unknown-type + (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) + (meta;run (init-compiler [])) + (check-type (type (All [a] (-> a a)))))) + (test "The function's name is bound to the function's type." + (|> (&;with-expected-type (type (Rec self (-> inputT self))) + (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) + (meta;run (init-compiler [])) + succeeds?)) + )))) + +(context: "Function application." + (<| (times +100) + (do @ + [full-args (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + partial-args (|> r;nat (:: @ map (n.% full-args))) + var-idx (|> r;nat (:: @ map (|>. (n.% full-args) (n.max +1)))) + inputsTC (r;list full-args gen-primitive) + #let [inputsT (list/map product;left inputsTC) + inputsC (list/map product;right inputsTC)] + [outputT outputC] gen-primitive + #let [funcT (type;function inputsT outputT) + partialT (type;function (list;drop partial-args inputsT) outputT) + varT (#;Bound +1) + polyT (<| (type;univ-q +1) + (type;function (list;concat (list (list;take var-idx inputsT) + (list varT) + (list;drop (n.inc var-idx) inputsT)))) + varT) + poly-inputT (maybe;assume (list;nth var-idx inputsT)) + partial-poly-inputsT (list;drop (n.inc var-idx) inputsT) + partial-polyT1 (<| (type;function partial-poly-inputsT) + poly-inputT) + partial-polyT2 (<| (type;univ-q +1) + (type;function (#;Cons varT partial-poly-inputsT)) + varT)]] + ($_ seq + (test "Can analyse monomorphic type application." + (|> (@common;with-unknown-type + (@;analyse-apply analyse funcT (' []) inputsC)) + (check-apply outputT full-args))) + (test "Can partially apply functions." + (|> (@common;with-unknown-type + (@;analyse-apply analyse funcT (' []) + (list;take partial-args inputsC))) + (check-apply partialT partial-args))) + (test "Can apply polymorphic functions." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (' []) inputsC)) + (check-apply poly-inputT full-args))) + (test "Polymorphic partial application propagates found type-vars." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (' []) + (list;take (n.inc var-idx) inputsC))) + (check-apply partial-polyT1 (n.inc var-idx)))) + (test "Polymorphic partial application preserves quantification for type-vars." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (' []) + (list;take var-idx inputsC))) + (check-apply partial-polyT2 var-idx))) + )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/primitive.lux b/new-luxc/test/test/luxc/lang/analysis/primitive.lux new file mode 100644 index 000000000..41dc9fada --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/primitive.lux @@ -0,0 +1,67 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "B/" Eq] + [text "T/" Eq] + (text format + ["l" lexer]) + [number] + ["e" error] + [product] + (coll [list "L/" Functor Fold])) + ["r" math/random] + [meta #+ Monad] + (meta [code] + [type "type/" Eq]) + test) + (luxc ["&" base] + ["&;" module] + (lang ["~" analysis] + (analysis [";A" expression] + ["@" primitive] + ["@;" common]))) + (.. common) + (test/luxc common)) + +(context: "Primitives" + (<| (times +100) + (do @ + [%bool% r;bool + %nat% r;nat + %int% r;int + %deg% r;deg + %frac% r;frac + %text% (r;text +5)] + (`` ($_ seq + (test "Can analyse unit." + (|> (@common;with-unknown-type + @;analyse-unit) + (meta;run (init-compiler [])) + (case> (^ (#e;Success [_type (^code [])])) + (type/= Unit _type) + + _ + false)) + ) + (~~ (do-template [ ] + [(test (format "Can analyse " ".") + (|> (@common;with-unknown-type + ( )) + (meta;run (init-compiler [])) + (case> (#e;Success [_type [_ ( value)]]) + (and (type/= _type) + (is value)) + + _ + false)) + )] + + ["bool" Bool #;Bool %bool% @;analyse-bool] + ["nat" Nat #;Nat %nat% @;analyse-nat] + ["int" Int #;Int %int% @;analyse-int] + ["deg" Deg #;Deg %deg% @;analyse-deg] + ["frac" Frac #;Frac %frac% @;analyse-frac] + ["text" Text #;Text %text% @;analyse-text] + ))))))) diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux new file mode 100644 index 000000000..134421732 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux @@ -0,0 +1,423 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data text/format + ["e" error] + [product] + (coll [array])) + ["r" math/random "r/" Monad] + [meta #+ Monad] + (meta [code] + [type "type/" Eq]) + test) + (luxc ["&" base] + ["&;" scope] + ["&;" module] + [";L" eval] + (lang ["~" analysis] + (analysis [";A" expression] + ["@" procedure] + ["@;" common]))) + (../.. common) + (test/luxc common)) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (&;with-scope + (&;with-expected-type output-type + (@;analyse-procedure analyse evalL;eval procedure params))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + + + (#e;Error error) + )))] + + [check-success+ true false] + [check-failure+ false true] + ) + +(context: "Lux procedures" + (<| (times +100) + (do @ + [[primT primC] gen-primitive + [antiT antiC] (|> gen-primitive + (r;filter (|>. product;left (type/= primT) not)))] + ($_ seq + (test "Can test for reference equality." + (check-success+ "lux is" (list primC primC) Bool)) + (test "Reference equality must be done with elements of the same type." + (check-failure+ "lux is" (list primC antiC) Bool)) + (test "Can 'try' risky IO computations." + (check-success+ "lux try" + (list (` ("lux function" (~' _) (~' _) (~ primC)))) + (type (Either Text primT)))) + )))) + +(context: "Bit procedures" + (<| (times +100) + (do @ + [subjectC (|> r;nat (:: @ map code;nat)) + signedC (|> r;int (:: @ map code;int)) + paramC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can count the number of 1 bits in a bit pattern." + (check-success+ "lux bit count" (list subjectC) Nat)) + (test "Can perform bit 'and'." + (check-success+ "lux bit and" (list subjectC paramC) Nat)) + (test "Can perform bit 'or'." + (check-success+ "lux bit or" (list subjectC paramC) Nat)) + (test "Can perform bit 'xor'." + (check-success+ "lux bit xor" (list subjectC paramC) Nat)) + (test "Can shift bit pattern to the left." + (check-success+ "lux bit shift-left" (list subjectC paramC) Nat)) + (test "Can shift bit pattern to the right." + (check-success+ "lux bit unsigned-shift-right" (list subjectC paramC) Nat)) + (test "Can shift signed bit pattern to the right." + (check-success+ "lux bit shift-right" (list signedC paramC) Int)) + )))) + +(context: "Nat procedures" + (<| (times +100) + (do @ + [subjectC (|> r;nat (:: @ map code;nat)) + paramC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can add natural numbers." + (check-success+ "lux nat +" (list subjectC paramC) Nat)) + (test "Can subtract natural numbers." + (check-success+ "lux nat -" (list subjectC paramC) Nat)) + (test "Can multiply natural numbers." + (check-success+ "lux nat *" (list subjectC paramC) Nat)) + (test "Can divide natural numbers." + (check-success+ "lux nat /" (list subjectC paramC) Nat)) + (test "Can calculate remainder of natural numbers." + (check-success+ "lux nat %" (list subjectC paramC) Nat)) + (test "Can test equality of natural numbers." + (check-success+ "lux nat =" (list subjectC paramC) Bool)) + (test "Can compare natural numbers." + (check-success+ "lux nat <" (list subjectC paramC) Bool)) + (test "Can obtain minimum natural number." + (check-success+ "lux nat min" (list) Nat)) + (test "Can obtain maximum natural number." + (check-success+ "lux nat max" (list) Nat)) + (test "Can convert natural number to integer." + (check-success+ "lux nat to-int" (list subjectC) Int)) + (test "Can convert natural number to text." + (check-success+ "lux nat to-text" (list subjectC) Text)) + )))) + +(context: "Int procedures" + (<| (times +100) + (do @ + [subjectC (|> r;int (:: @ map code;int)) + paramC (|> r;int (:: @ map code;int))] + ($_ seq + (test "Can add integers." + (check-success+ "lux int +" (list subjectC paramC) Int)) + (test "Can subtract integers." + (check-success+ "lux int -" (list subjectC paramC) Int)) + (test "Can multiply integers." + (check-success+ "lux int *" (list subjectC paramC) Int)) + (test "Can divide integers." + (check-success+ "lux int /" (list subjectC paramC) Int)) + (test "Can calculate remainder of integers." + (check-success+ "lux int %" (list subjectC paramC) Int)) + (test "Can test equality of integers." + (check-success+ "lux int =" (list subjectC paramC) Bool)) + (test "Can compare integers." + (check-success+ "lux int <" (list subjectC paramC) Bool)) + (test "Can obtain minimum integer." + (check-success+ "lux int min" (list) Int)) + (test "Can obtain maximum integer." + (check-success+ "lux int max" (list) Int)) + (test "Can convert integer to natural number." + (check-success+ "lux int to-nat" (list subjectC) Nat)) + (test "Can convert integer to frac number." + (check-success+ "lux int to-frac" (list subjectC) Frac)) + )))) + +(context: "Deg procedures" + (<| (times +100) + (do @ + [subjectC (|> r;deg (:: @ map code;deg)) + paramC (|> r;deg (:: @ map code;deg)) + natC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can add degrees." + (check-success+ "lux deg +" (list subjectC paramC) Deg)) + (test "Can subtract degrees." + (check-success+ "lux deg -" (list subjectC paramC) Deg)) + (test "Can multiply degrees." + (check-success+ "lux deg *" (list subjectC paramC) Deg)) + (test "Can divide degrees." + (check-success+ "lux deg /" (list subjectC paramC) Deg)) + (test "Can calculate remainder of degrees." + (check-success+ "lux deg %" (list subjectC paramC) Deg)) + (test "Can test equality of degrees." + (check-success+ "lux deg =" (list subjectC paramC) Bool)) + (test "Can compare degrees." + (check-success+ "lux deg <" (list subjectC paramC) Bool)) + (test "Can obtain minimum degree." + (check-success+ "lux deg min" (list) Deg)) + (test "Can obtain maximum degree." + (check-success+ "lux deg max" (list) Deg)) + (test "Can convert degree to frac number." + (check-success+ "lux deg to-frac" (list subjectC) Frac)) + (test "Can scale degree." + (check-success+ "lux deg scale" (list subjectC natC) Deg)) + (test "Can calculate the reciprocal of a natural number." + (check-success+ "lux deg reciprocal" (list subjectC natC) Deg)) + )))) + +(context: "Frac procedures" + (<| (times +100) + (do @ + [subjectC (|> r;frac (:: @ map code;frac)) + paramC (|> r;frac (:: @ map code;frac)) + encodedC (|> (r;text +5) (:: @ map code;text))] + ($_ seq + (test "Can add frac numbers." + (check-success+ "lux frac +" (list subjectC paramC) Frac)) + (test "Can subtract frac numbers." + (check-success+ "lux frac -" (list subjectC paramC) Frac)) + (test "Can multiply frac numbers." + (check-success+ "lux frac *" (list subjectC paramC) Frac)) + (test "Can divide frac numbers." + (check-success+ "lux frac /" (list subjectC paramC) Frac)) + (test "Can calculate remainder of frac numbers." + (check-success+ "lux frac %" (list subjectC paramC) Frac)) + (test "Can test equality of frac numbers." + (check-success+ "lux frac =" (list subjectC paramC) Bool)) + (test "Can compare frac numbers." + (check-success+ "lux frac <" (list subjectC paramC) Bool)) + (test "Can obtain minimum frac number." + (check-success+ "lux frac min" (list) Frac)) + (test "Can obtain maximum frac number." + (check-success+ "lux frac max" (list) Frac)) + (test "Can obtain smallest frac number." + (check-success+ "lux frac smallest" (list) Frac)) + (test "Can obtain not-a-number." + (check-success+ "lux frac not-a-number" (list) Frac)) + (test "Can obtain positive infinity." + (check-success+ "lux frac positive-infinity" (list) Frac)) + (test "Can obtain negative infinity." + (check-success+ "lux frac negative-infinity" (list) Frac)) + (test "Can convert frac number to integer." + (check-success+ "lux frac to-int" (list subjectC) Int)) + (test "Can convert frac number to degree." + (check-success+ "lux frac to-deg" (list subjectC) Deg)) + (test "Can convert frac number to text." + (check-success+ "lux frac encode" (list subjectC) Text)) + (test "Can convert text to frac number." + (check-success+ "lux frac decode" (list encodedC) (type (Maybe Frac)))) + )))) + +(context: "Text procedures" + (<| (times +100) + (do @ + [subjectC (|> (r;text +5) (:: @ map code;text)) + paramC (|> (r;text +5) (:: @ map code;text)) + replacementC (|> (r;text +5) (:: @ map code;text)) + fromC (|> r;nat (:: @ map code;nat)) + toC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can test text equality." + (check-success+ "lux text =" (list subjectC paramC) Bool)) + (test "Compare texts in lexicographical order." + (check-success+ "lux text <" (list subjectC paramC) Bool)) + (test "Can prepend one text to another." + (check-success+ "lux text prepend" (list subjectC paramC) Text)) + (test "Can find the index of a piece of text inside a larger one that (may) contain it." + (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) + (test "Can query the size/length of a text." + (check-success+ "lux text size" (list subjectC) Nat)) + (test "Can calculate a hash code for text." + (check-success+ "lux text hash" (list subjectC) Nat)) + (test "Can replace a text inside of a larger one (once)." + (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) + (test "Can replace a text inside of a larger one (all times)." + (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) + (test "Can obtain the character code of a text at a given index." + (check-success+ "lux text char" (list subjectC fromC) Nat)) + (test "Can clip a piece of text between 2 indices." + (check-success+ "lux text clip" (list subjectC fromC toC) Text)) + )))) + +(context: "Array procedures" + (<| (times +100) + (do @ + [[elemT elemC] gen-primitive + sizeC (|> r;nat (:: @ map code;nat)) + idxC (|> r;nat (:: @ map code;nat)) + var-name (r;text +5) + #let [arrayT (type (Array elemT))]] + ($_ seq + (test "Can create arrays." + (check-success+ "lux array new" (list sizeC) arrayT)) + (test "Can get a value inside an array." + (|> (&scope;with-scope "" + (&scope;with-local [var-name arrayT] + (&;with-expected-type elemT + (@;analyse-procedure analyse evalL;eval "lux array get" + (list idxC + (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true + + (#e;Error _) + false))) + (test "Can put a value inside an array." + (|> (&scope;with-scope "" + (&scope;with-local [var-name arrayT] + (&;with-expected-type arrayT + (@;analyse-procedure analyse evalL;eval "lux array put" + (list idxC + elemC + (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true + + (#e;Error _) + false))) + (test "Can remove a value from an array." + (|> (&scope;with-scope "" + (&scope;with-local [var-name arrayT] + (&;with-expected-type arrayT + (@;analyse-procedure analyse evalL;eval "lux array remove" + (list idxC + (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true + + (#e;Error _) + false))) + (test "Can query the size of an array." + (|> (&scope;with-scope "" + (&scope;with-local [var-name arrayT] + (&;with-expected-type Nat + (@;analyse-procedure analyse evalL;eval "lux array size" + (list (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true + + (#e;Error _) + false))) + )))) + +(context: "Math procedures" + (<| (times +100) + (do @ + [subjectC (|> r;frac (:: @ map code;frac)) + paramC (|> r;frac (:: @ map code;frac))] + (with-expansions [ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC) Frac))] + + ["lux math cos" "cosine"] + ["lux math sin" "sine"] + ["lux math tan" "tangent"] + ["lux math acos" "inverse/arc cosine"] + ["lux math asin" "inverse/arc sine"] + ["lux math atan" "inverse/arc tangent"] + ["lux math cosh" "hyperbolic cosine"] + ["lux math sinh" "hyperbolic sine"] + ["lux math tanh" "hyperbolic tangent"] + ["lux math exp" "exponentiation"] + ["lux math log" "logarithm"] + ["lux math root2" "square root"] + ["lux math root3" "cubic root"] + ["lux math ceil" "ceiling"] + ["lux math floor" "floor"] + ["lux math round" "rounding"]) + (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC paramC) Frac))] + + ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] + ["lux math pow" "power"])] + ($_ seq + + ))))) + +(context: "Atom procedures" + (<| (times +100) + (do @ + [[elemT elemC] gen-primitive + sizeC (|> r;nat (:: @ map code;nat)) + idxC (|> r;nat (:: @ map code;nat)) + var-name (r;text +5) + #let [atomT (type (atom;Atom elemT))]] + ($_ seq + (test "Can create atomic reference." + (check-success+ "lux atom new" (list elemC) atomT)) + (test "Can read the value of an atomic reference." + (|> (&scope;with-scope "" + (&scope;with-local [var-name atomT] + (&;with-expected-type elemT + (@;analyse-procedure analyse evalL;eval "lux atom read" + (list (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true + + (#e;Error _) + false))) + (test "Can swap the value of an atomic reference." + (|> (&scope;with-scope "" + (&scope;with-local [var-name atomT] + (&;with-expected-type Bool + (@;analyse-procedure analyse evalL;eval "lux atom compare-and-swap" + (list elemC + elemC + (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true + + (#e;Error _) + false))) + )))) + +(context: "Process procedures" + (<| (times +100) + (do @ + [[primT primC] gen-primitive + timeC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can query the level of concurrency." + (check-success+ "lux process concurrency-level" (list) Nat)) + (test "Can run an IO computation concurrently." + (check-success+ "lux process future" + (list (` ("lux function" (~' _) (~' _) (~ primC)))) + Unit)) + (test "Can schedule an IO computation to run concurrently at some future time." + (check-success+ "lux process schedule" + (list timeC + (` ("lux function" (~' _) (~' _) (~ primC)))) + Unit)) + )))) + +(context: "IO procedures" + (<| (times +100) + (do @ + [logC (|> (r;text +5) (:: @ map code;text)) + exitC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can log messages to standard output." + (check-success+ "lux io log" (list logC) Unit)) + (test "Can log messages to standard output." + (check-success+ "lux io error" (list logC) Bottom)) + (test "Can log messages to standard output." + (check-success+ "lux io exit" (list exitC) Bottom)) + (test "Can query the current time (as milliseconds since epoch)." + (check-success+ "lux io current-time" (list) Int)) + )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux new file mode 100644 index 000000000..333a60353 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux @@ -0,0 +1,529 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data ["e" error] + [product] + [maybe] + [text "text/" Eq] + text/format + (coll [array] + [list "list/" Fold] + [dict])) + ["r" math/random "r/" Monad] + [meta #+ Monad] + (meta [code] + [type]) + test) + (luxc ["&" base] + ["&;" scope] + ["&;" module] + [";L" eval] + (lang ["~" analysis] + (analysis [";A" expression] + ["@;" common] + ["@" procedure] + (procedure ["@;" host]))) + (generator ["@;" runtime])) + (../.. common) + (test/luxc common)) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (do Monad + [runtime-bytecode @runtime;generate] + (&;with-scope + (&;with-expected-type output-type + (@;analyse-procedure analyse evalL;eval procedure params)))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + + + (#e;Error error) + )))] + + [success true false] + [failure false true] + ) + +(context: "Conversions [double + float]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert double-to-float" "java.lang.Double" @host;Float] + ["jvm convert double-to-int" "java.lang.Double" @host;Integer] + ["jvm convert double-to-long" "java.lang.Double" @host;Long] + ["jvm convert float-to-double" "java.lang.Float" @host;Double] + ["jvm convert float-to-int" "java.lang.Float" @host;Integer] + ["jvm convert float-to-long" "java.lang.Float" @host;Long] + )] + ($_ seq + + ))) + +(context: "Conversions [int]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert int-to-byte" "java.lang.Integer" @host;Byte] + ["jvm convert int-to-char" "java.lang.Integer" @host;Character] + ["jvm convert int-to-double" "java.lang.Integer" @host;Double] + ["jvm convert int-to-float" "java.lang.Integer" @host;Float] + ["jvm convert int-to-long" "java.lang.Integer" @host;Long] + ["jvm convert int-to-short" "java.lang.Integer" @host;Short] + )] + ($_ seq + + ))) + +(context: "Conversions [long]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert long-to-double" "java.lang.Long" @host;Double] + ["jvm convert long-to-float" "java.lang.Long" @host;Float] + ["jvm convert long-to-int" "java.lang.Long" @host;Integer] + ["jvm convert long-to-short" "java.lang.Long" @host;Short] + ["jvm convert long-to-byte" "java.lang.Long" @host;Byte] + )] + ($_ seq + + ))) + +(context: "Conversions [char + byte + short]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert char-to-byte" "java.lang.Character" @host;Byte] + ["jvm convert char-to-short" "java.lang.Character" @host;Short] + ["jvm convert char-to-int" "java.lang.Character" @host;Integer] + ["jvm convert char-to-long" "java.lang.Character" @host;Long] + ["jvm convert byte-to-long" "java.lang.Byte" @host;Long] + ["jvm convert short-to-long" "java.lang.Short" @host;Long] + )] + ($_ seq + + ))) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") @host;Boolean] + [(format "jvm " " <") @host;Boolean] + )] + ($_ seq + + ))) + + (context: (format "Bitwise " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " and") ] + [(format "jvm " " or") ] + [(format "jvm " " xor") ] + [(format "jvm " " shl") "java.lang.Integer" ] + [(format "jvm " " shr") "java.lang.Integer" ] + [(format "jvm " " ushr") "java.lang.Integer" ] + )] + ($_ seq + + )))] + + + ["int" "java.lang.Integer" @host;Integer] + ["long" "java.lang.Long" @host;Long] + ) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") @host;Boolean] + [(format "jvm " " <") @host;Boolean] + )] + ($_ seq + + )))] + + + ["float" "java.lang.Float" @host;Float] + ["double" "java.lang.Double" @host;Double] + ) + +(do-template [ ] + [(context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") @host;Boolean] + [(format "jvm " " <") @host;Boolean] + )] + ($_ seq + + )))] + + + ["char" "java.lang.Character" @host;Character] + ) + +(def: array-type + (r;Random [Text Text]) + (let [entries (dict;entries @host;boxes) + num-entries (list;size entries)] + (do r;Monad + [choice (|> r;nat (:: @ map (n.% (n.inc num-entries)))) + #let [[unboxed boxed] (: [Text Text] + (|> entries + (list;nth choice) + (maybe;default ["java.lang.Object" "java.lang.Object"])))]] + (wrap [unboxed boxed])))) + +(context: "Array." + (<| (times +100) + (do @ + [#let [cap (|>. (n.% +10) (n.max +1))] + [unboxed boxed] array-type + size (|> r;nat (:: @ map cap)) + idx (|> r;nat (:: @ map (n.% size))) + level (|> r;nat (:: @ map cap)) + #let [unboxedT (#;Primitive unboxed (list)) + arrayT (#;Primitive "#Array" (list unboxedT)) + arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code;text unboxed)) (+0)) (+0))) + ("jvm array new" (~ (code;nat size))))) + boxedT (#;Primitive boxed (list)) + boxedTC (` (+0 (~ (code;text boxed)) (+0))) + multi-arrayT (list/fold (function [_ innerT] + (|> innerT (list) (#;Primitive "#Array"))) + boxedT + (list;n.range +1 level))]] + ($_ seq + (test "jvm array new" + (success "jvm array new" + (list (code;nat size)) + arrayT)) + (test "jvm array new (no nesting)" + (failure "jvm array new" + (list (code;nat size)) + unboxedT)) + (test "jvm array new (nested/multi-level)" + (success "jvm array new" + (list (code;nat size)) + multi-arrayT)) + (test "jvm array length" + (success "jvm array length" + (list arrayC) + Nat)) + (test "jvm array read" + (success "jvm array read" + (list arrayC (code;nat idx)) + boxedT)) + (test "jvm array write" + (success "jvm array write" + (list arrayC (code;nat idx) (`' ("lux coerce" (~ boxedTC) []))) + arrayT)) + )))) + +(def: throwables + (List Text) + (list "java.lang.Throwable" + "java.lang.Error" + "java.io.IOError" + "java.lang.VirtualMachineError" + "java.lang.Exception" + "java.io.IOException" + "java.lang.RuntimeException")) + +(context: "Object." + (<| (times +100) + (do @ + [[unboxed boxed] array-type + [!unboxed !boxed] (|> array-type + (r;filter (function [[!unboxed !boxed]] + (not (text/= boxed !boxed))))) + #let [boxedT (#;Primitive boxed (list)) + boxedC (`' ("lux check" (+0 (~ (code;text boxed)) (+0)) + ("jvm object null"))) + !boxedC (`' ("lux check" (+0 (~ (code;text !boxed)) (+0)) + ("jvm object null"))) + unboxedC (`' ("lux check" (+0 (~ (code;text unboxed)) (+0)) + ("jvm object null")))] + throwable (|> r;nat + (:: @ map (n.% (n.inc (list;size throwables)))) + (:: @ map (function [idx] + (|> throwables + (list;nth idx) + (maybe;default "java.lang.Object"))))) + #let [throwableC (`' ("lux check" (+0 (~ (code;text throwable)) (+0)) + ("jvm object null")))]] + ($_ seq + (test "jvm object null" + (success "jvm object null" + (list) + (#;Primitive boxed (list)))) + (test "jvm object null (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object null" + (list) + (#;Primitive unboxed (list))))) + (test "jvm object null?" + (success "jvm object null?" + (list boxedC) + Bool)) + (test "jvm object synchronized" + (success "jvm object synchronized" + (list boxedC boxedC) + boxedT)) + (test "jvm object synchronized (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object synchronized" + (list unboxedC boxedC) + boxedT))) + (test "jvm object throw" + (or (text/= "java.lang.Object" throwable) + (success "jvm object throw" + (list throwableC) + Bottom))) + (test "jvm object class" + (success "jvm object class" + (list (code;text boxed)) + (#;Primitive "java.lang.Class" (list boxedT)))) + (test "jvm object instance?" + (success "jvm object instance?" + (list (code;text boxed) + boxedC) + Bool)) + (test "jvm object instance? (lineage)" + (success "jvm object instance?" + (list (' "java.lang.Object") + boxedC) + Bool)) + (test "jvm object instance? (no lineage)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object instance?" + (list (code;text boxed) + !boxedC) + Bool))) + )))) + +(context: "Member [Static Field]." + ($_ seq + (test "jvm member static get" + (success "jvm member static get" + (list (code;text "java.lang.System") + (code;text "out")) + (#;Primitive "java.io.PrintStream" (list)))) + (test "jvm member static get (inheritance out)" + (success "jvm member static get" + (list (code;text "java.lang.System") + (code;text "out")) + (#;Primitive "java.lang.Object" (list)))) + (test "jvm member static put" + (success "jvm member static put" + (list (code;text "java.awt.datatransfer.DataFlavor") + (code;text "allHtmlFlavor") + (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) + ("jvm object null")))) + Unit)) + (test "jvm member static put (final)" + (failure "jvm member static put" + (list (code;text "java.lang.System") + (code;text "out") + (`' ("lux check" (+0 "java.io.PrintStream" (+0)) + ("jvm object null")))) + Unit)) + (test "jvm member static put (inheritance in)" + (success "jvm member static put" + (list (code;text "java.awt.datatransfer.DataFlavor") + (code;text "allHtmlFlavor") + (`' ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) + ("jvm object null")))) + Unit)) + )) + +(context: "Member [Virtual Field]." + ($_ seq + (test "jvm member virtual get" + (success "jvm member virtual get" + (list (code;text "org.omg.CORBA.ValueMember") + (code;text "id") + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (#;Primitive "java.lang.String" (list)))) + (test "jvm member virtual get (inheritance out)" + (success "jvm member virtual get" + (list (code;text "org.omg.CORBA.ValueMember") + (code;text "id") + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (#;Primitive "java.lang.Object" (list)))) + (test "jvm member virtual put" + (success "jvm member virtual put" + (list (code;text "org.omg.CORBA.ValueMember") + (code;text "id") + (`' ("lux check" (+0 "java.lang.String" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (primitive org.omg.CORBA.ValueMember))) + (test "jvm member virtual put (final)" + (failure "jvm member virtual put" + (list (code;text "javax.swing.text.html.parser.DTD") + (code;text "applet") + (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) + ("jvm object null")))) + (primitive javax.swing.text.html.parser.DTD))) + (test "jvm member virtual put (inheritance in)" + (success "jvm member virtual put" + (list (code;text "java.awt.GridBagConstraints") + (code;text "insets") + (`' ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) + ("jvm object null")))) + (primitive java.awt.GridBagConstraints))) + )) + +(context: "Boxing/Unboxing." + ($_ seq + (test "jvm member static get" + (success "jvm member static get" + (list (code;text "java.util.GregorianCalendar") + (code;text "AD")) + (#;Primitive "java.lang.Integer" (list)))) + (test "jvm member virtual get" + (success "jvm member virtual get" + (list (code;text "javax.accessibility.AccessibleAttributeSequence") + (code;text "startIndex") + (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) + ("jvm object null")))) + (#;Primitive "java.lang.Integer" (list)))) + (test "jvm member virtual put" + (success "jvm member virtual put" + (list (code;text "javax.accessibility.AccessibleAttributeSequence") + (code;text "startIndex") + (`' ("lux check" (+0 "java.lang.Integer" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) + ("jvm object null")))) + (primitive javax.accessibility.AccessibleAttributeSequence))) + )) + +(context: "Member [Method]." + (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) + +123)) + intC (`' ("jvm convert long-to-int" (~ longC))) + objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) + ("jvm member invoke constructor" "java.util.ArrayList" + ["int" (~ intC)])))] + ($_ seq + (test "jvm member invoke static" + (success "jvm member invoke static" + (list (code;text "java.lang.Long") + (code;text "decode") + (code;tuple (list (' "java.lang.String") + (' ("lux coerce" (+0 "java.lang.String" (+0)) + "YOLO"))))) + (#;Primitive "java.lang.Long" (list)))) + (test "jvm member invoke virtual" + (success "jvm member invoke virtual" + (list (code;text "java.lang.Object") + (code;text "equals") + longC + (code;tuple (list (' "java.lang.Object") + longC))) + (#;Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke special" + (success "jvm member invoke special" + (list (code;text "java.lang.Long") + (code;text "equals") + longC + (code;tuple (list (' "java.lang.Object") + longC))) + (#;Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke interface" + (success "jvm member invoke interface" + (list (code;text "java.util.Collection") + (code;text "add") + objectC + (code;tuple (list (' "java.lang.Object") + longC))) + (#;Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke constructor" + (success "jvm member invoke constructor" + (list (code;text "java.util.ArrayList") + (code;tuple (list (' "int") intC))) + (All [a] (#;Primitive "java.util.ArrayList" (list a))))) + ))) diff --git a/new-luxc/test/test/luxc/lang/analysis/reference.lux b/new-luxc/test/test/luxc/lang/analysis/reference.lux new file mode 100644 index 000000000..f6021e184 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/reference.lux @@ -0,0 +1,52 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error]) + ["r" math/random] + [meta #+ Monad] + (meta [type "type/" Eq]) + test) + (luxc ["&;" scope] + ["&;" module] + (lang ["~" analysis] + (analysis [";A" expression] + ["@" reference] + ["@;" common]))) + (.. common) + (test/luxc common)) + +(context: "References" + (<| (times +100) + (do @ + [[ref-type _] gen-primitive + module-name (r;text +5) + scope-name (r;text +5) + var-name (r;text +5)] + ($_ seq + (test "Can analyse variable." + (|> (&scope;with-scope scope-name + (&scope;with-local [var-name ref-type] + (@common;with-unknown-type + (@;analyse-reference ["" var-name])))) + (meta;run (init-compiler [])) + (case> (^ (#e;Success [_type (^code ((~ [_ (#;Int var)])))])) + (type/= ref-type _type) + + _ + false))) + (test "Can analyse definition." + (|> (do Monad + [_ (&module;create +0 module-name) + _ (&module;define [module-name var-name] + [ref-type (' {}) (:! Void [])])] + (@common;with-unknown-type + (@;analyse-reference [module-name var-name]))) + (meta;run (init-compiler [])) + (case> (#e;Success [_type [_ (#;Symbol def-name)]]) + (type/= ref-type _type) + + _ + false))) + )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/structure.lux b/new-luxc/test/test/luxc/lang/analysis/structure.lux new file mode 100644 index 000000000..507b61995 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/structure.lux @@ -0,0 +1,336 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Eq] + ["e" error] + [product] + [maybe] + [text] + text/format + (coll [list "list/" Functor] + ["S" set])) + ["r" math/random "r/" Monad] + [meta] + (meta [code] + [type "type/" Eq] + (type ["tc" check])) + test) + (luxc ["&" base] + (lang ["la" analysis] + (analysis [";A" expression] + ["@" structure] + ["@;" common])) + ["@;" module]) + (.. common) + (test/luxc common)) + +(context: "Sums" + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + choice (|> r;nat (:: @ map (n.% size))) + primitives (r;list size gen-primitive) + +choice (|> r;nat (:: @ map (n.% (n.inc size)))) + [_ +valueC] gen-primitive + #let [variantT (type;variant (list/map product;left primitives)) + [valueT valueC] (maybe;assume (list;nth choice primitives)) + +size (n.inc size) + +primitives (list;concat (list (list;take choice primitives) + (list [(#;Bound +1) +valueC]) + (list;drop choice primitives))) + [+valueT +valueC] (maybe;assume (list;nth +choice +primitives)) + +variantT (type;variant (list/map product;left +primitives))]] + ($_ seq + (test "Can analyse sum." + (|> (&;with-scope + (&;with-expected-type variantT + (@;analyse-sum analyse choice valueC))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ sumA]) + [(la;unfold-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag choice) + (bool/= last? (n.= (n.dec size) choice))) + + _ + false))) + (test "Can analyse sum through bound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (do meta;Monad + [_ (&;with-type-env + (tc;check varT variantT))] + (&;with-expected-type varT + (@;analyse-sum analyse choice valueC)))))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ sumA]) + [(la;unfold-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag choice) + (bool/= last? (n.= (n.dec size) choice))) + + _ + false))) + (test "Cannot analyse sum through unbound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (&;with-expected-type varT + (@;analyse-sum analyse choice valueC))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + false + + _ + true))) + (test "Can analyse sum through existential quantification." + (|> (&;with-scope + (&;with-expected-type (type;ex-q +1 +variantT) + (@;analyse-sum analyse +choice +valueC))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true + + (#e;Error error) + false))) + (test "Can analyse sum through universal quantification." + (|> (&;with-scope + (&;with-expected-type (type;univ-q +1 +variantT) + (@;analyse-sum analyse +choice +valueC))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + (not (n.= choice +choice)) + + (#e;Error error) + (n.= choice +choice)))) + )))) + +(context: "Products" + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + primitives (r;list size gen-primitive) + choice (|> r;nat (:: @ map (n.% size))) + [_ +valueC] gen-primitive + #let [[singletonT singletonC] (|> primitives (list;nth choice) maybe;assume) + +primitives (list;concat (list (list;take choice primitives) + (list [(#;Bound +1) +valueC]) + (list;drop choice primitives))) + +tupleT (type;tuple (list/map product;left +primitives))]] + ($_ seq + (test "Can analyse product." + (|> (&;with-expected-type (type;tuple (list/map product;left primitives)) + (@;analyse-product analyse (list/map product;right primitives))) + (meta;run (init-compiler [])) + (case> (#e;Success tupleA) + (n.= size (list;size (la;unfold-tuple tupleA))) + + _ + false))) + (test "Can infer product." + (|> (@common;with-unknown-type + (@;analyse-product analyse (list/map product;right primitives))) + (meta;run (init-compiler [])) + (case> (#e;Success [_type tupleA]) + (and (type/= (type;tuple (list/map product;left primitives)) + _type) + (n.= size (list;size (la;unfold-tuple tupleA)))) + + _ + false))) + (test "Can analyse pseudo-product (singleton tuple)" + (|> (&;with-expected-type singletonT + (analyse (` [(~ singletonC)]))) + (meta;run (init-compiler [])) + (case> (#e;Success singletonA) + true + + (#e;Error error) + false))) + (test "Can analyse product through bound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (do meta;Monad + [_ (&;with-type-env + (tc;check varT (type;tuple (list/map product;left primitives))))] + (&;with-expected-type varT + (@;analyse-product analyse (list/map product;right primitives))))))) + (meta;run (init-compiler [])) + (case> (#e;Success [_ tupleA]) + (n.= size (list;size (la;unfold-tuple tupleA))) + + _ + false))) + (test "Can analyse product through existential quantification." + (|> (&;with-scope + (&;with-expected-type (type;ex-q +1 +tupleT) + (@;analyse-product analyse (list/map product;right +primitives)))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true + + (#e;Error error) + false))) + (test "Cannot analyse product through universal quantification." + (|> (&;with-scope + (&;with-expected-type (type;univ-q +1 +tupleT) + (@;analyse-product analyse (list/map product;right +primitives)))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + false + + (#e;Error error) + true))) + )))) + +(def: (check-variant-inference variantT choice size analysis) + (-> Type Nat Nat (Meta [Module Scope Type la;Analysis]) Bool) + (|> analysis + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ _ sumT sumA]) + [(la;unfold-variant sumA) + (#;Some [tag last? valueA])]) + (and (type/= variantT sumT) + (n.= tag choice) + (bool/= last? (n.= (n.dec size) choice))) + + _ + false))) + +(def: (check-record-inference tupleT size analysis) + (-> Type Nat (Meta [Module Scope Type la;Analysis]) Bool) + (|> analysis + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ _ productT productA]) + [(la;unfold-tuple productA) + membersA]) + (and (type/= tupleT productT) + (n.= size (list;size membersA))) + + _ + false))) + +(context: "Tagged Sums" + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + choice (|> r;nat (:: @ map (n.% size))) + other-choice (|> r;nat (:: @ map (n.% size)) (r;filter (|>. (n.= choice) not))) + primitives (r;list size gen-primitive) + module-name (r;text +5) + type-name (r;text +5) + #let [varT (#;Bound +1) + primitivesT (list/map product;left primitives) + [choiceT choiceC] (maybe;assume (list;nth choice primitives)) + [other-choiceT other-choiceC] (maybe;assume (list;nth other-choice primitives)) + variantT (type;variant primitivesT) + namedT (#;Named [module-name type-name] variantT) + polyT (|> (type;variant (list;concat (list (list;take choice primitivesT) + (list varT) + (list;drop (n.inc choice) primitivesT)))) + (type;univ-q +1)) + named-polyT (#;Named [module-name type-name] polyT) + choice-tag (maybe;assume (list;nth choice tags)) + other-choice-tag (maybe;assume (list;nth other-choice tags))]] + ($_ seq + (test "Can infer tagged sum." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false namedT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) + (check-variant-inference variantT choice size))) + (test "Tagged sums specialize when type-vars get bound." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) + (check-variant-inference variantT choice size))) + (test "Tagged sum inference retains universal quantification when type-vars are not bound." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (check-variant-inference polyT other-choice size))) + (test "Can specialize generic tagged sums." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (&;with-expected-type variantT + (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ _ sumA]) + [(la;unfold-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag other-choice) + (bool/= last? (n.= (n.dec size) other-choice))) + + _ + false))) + )))) + +(context: "Records" + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + primitives (r;list size gen-primitive) + module-name (r;text +5) + type-name (r;text +5) + choice (|> r;nat (:: @ map (n.% size))) + #let [varT (#;Bound +1) + tagsC (list/map (|>. [module-name] code;tag) tags) + primitivesT (list/map product;left primitives) + primitivesC (list/map product;right primitives) + tupleT (type;tuple primitivesT) + namedT (#;Named [module-name type-name] tupleT) + recordC (list;zip2 tagsC primitivesC) + polyT (|> (type;tuple (list;concat (list (list;take choice primitivesT) + (list varT) + (list;drop (n.inc choice) primitivesT)))) + (type;univ-q +1)) + named-polyT (#;Named [module-name type-name] polyT)]] + ($_ seq + (test "Can infer record." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false namedT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-record analyse recordC))))) + (check-record-inference tupleT size))) + (test "Records specialize when type-vars get bound." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-record analyse recordC))))) + (check-record-inference tupleT size))) + (test "Can specialize generic records." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (&;with-expected-type tupleT + (@;analyse-record analyse recordC))))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ _ productA]) + [(la;unfold-tuple productA) + membersA]) + (n.= size (list;size membersA)) + + _ + false))) + )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/type.lux b/new-luxc/test/test/luxc/lang/analysis/type.lux new file mode 100644 index 000000000..649c33fef --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/type.lux @@ -0,0 +1,91 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Eq] + [text "text/" Eq] + (text format + ["l" lexer]) + [number] + ["e" error] + [product] + (coll [list "list/" Functor Fold])) + ["r" math/random "r/" Monad] + [meta #+ Monad] + (meta [code] + [type "type/" Eq]) + test) + (luxc ["&" base] + ["&;" module] + (lang ["~" analysis] + (analysis [";A" expression] + ["@" type] + ["@;" common])) + (generator ["@;" runtime]) + [eval]) + (.. common) + (test/luxc common)) + +(def: check + (r;Random [Code Type Code]) + (with-expansions [ (do-template [ ] + [(do r;Monad + [value ] + (wrap [(` ) + + ( value)]))] + + [r;bool (+0 "#Bool" (+0)) code;bool] + [r;nat (+0 "#Nat" (+0)) code;nat] + [r;int (+0 "#Int" (+0)) code;int] + [r;deg (+0 "#Deg" (+0)) code;deg] + [r;frac (+0 "#Frac" (+0)) code;frac] + [(r;text +5) (+0 "#Text" (+0)) code;text] + )] + ($_ r;either + ))) + +(context: "Type checking/coercion." + (<| (times +100) + (do @ + [[typeC codeT exprC] check] + ($_ seq + (test (format "Can analyse type-checking.") + (|> (do Monad + [runtime-bytecode @runtime;generate] + (&;with-scope + (@common;with-unknown-type + (@;analyse-check analyse eval;eval typeC exprC)))) + (meta;run (init-compiler [])) + (case> (#e;Success [_ [analysisT analysisA]]) + (and (type/= codeT analysisT) + (case [exprC analysisA] + (^template [ ] + [[_ ( expected)] [_ ( actual)]] + ( expected actual)) + ([#;Bool bool/=] + [#;Nat n.=] + [#;Int i.=] + [#;Deg d.=] + [#;Frac f.=] + [#;Text text/=]) + + _ + false)) + + (#e;Error error) + false))) + (test (format "Can analyse type-coercion.") + (|> (do Monad + [runtime-bytecode @runtime;generate] + (&;with-scope + (@common;with-unknown-type + (@;analyse-coerce analyse eval;eval typeC exprC)))) + (meta;run (init-compiler [])) + (case> (#e;Success [_ [analysisT analysisA]]) + (type/= codeT analysisT) + + (#e;Error error) + false))) + )))) diff --git a/new-luxc/test/test/luxc/lang/parser.lux b/new-luxc/test/test/luxc/lang/parser.lux new file mode 100644 index 000000000..c70bdaece --- /dev/null +++ b/new-luxc/test/test/luxc/lang/parser.lux @@ -0,0 +1,233 @@ +(;module: + lux + (lux [io] + (control [monad #+ do]) + (data [number] + ["e" error] + [text] + (text format + ["l" lexer]) + (coll [list])) + ["r" math/random "r/" Monad] + (meta [code]) + test) + (luxc (lang ["&" parser]))) + +(def: default-cursor + Cursor + {#;module "" + #;line +0 + #;column +0}) + +(def: ident-part^ + (r;Random Text) + (do r;Monad + [#let [digits "0123456789" + delimiters "()[]{}#;\"" + space "\t\v \n\r\f" + invalid-range (format digits delimiters space) + char-gen (|> r;nat + (r;filter (function [sample] + (not (text;contains? (text;from-code sample) + invalid-range)))))] + size (|> r;nat (:: @ map (|>. (n.% +20) (n.max +1))))] + (r;text' char-gen size))) + +(def: ident^ + (r;Random Ident) + (r;seq ident-part^ ident-part^)) + +(def: code^ + (r;Random Code) + (let [numeric^ (: (r;Random Code) + ($_ r;either + (|> r;bool (r/map (|>. #;Bool [default-cursor]))) + (|> r;nat (r/map (|>. #;Nat [default-cursor]))) + (|> r;int (r/map (|>. #;Int [default-cursor]))) + (|> r;deg (r/map (|>. #;Deg [default-cursor]))) + (|> r;frac (r/map (|>. #;Frac [default-cursor]))))) + textual^ (: (r;Random Code) + ($_ r;either + (do r;Monad + [size (|> r;nat (r/map (n.% +20)))] + (|> (r;text size) (r/map (|>. #;Text [default-cursor])))) + (|> ident^ (r/map (|>. #;Symbol [default-cursor]))) + (|> ident^ (r/map (|>. #;Tag [default-cursor]))))) + simple^ (: (r;Random Code) + ($_ r;either + numeric^ + textual^))] + (r;rec + (function [code^] + (let [multi^ (do r;Monad + [size (|> r;nat (r/map (n.% +3)))] + (r;list size code^)) + composite^ (: (r;Random Code) + ($_ r;either + (|> multi^ (r/map (|>. #;Form [default-cursor]))) + (|> multi^ (r/map (|>. #;Tuple [default-cursor]))) + (do r;Monad + [size (|> r;nat (r/map (n.% +3)))] + (|> (r;list size (r;seq code^ code^)) + (r/map (|>. #;Record [default-cursor]))))))] + (r;either simple^ + composite^)))))) + +(context: "Lux code parser." + (<| (times +100) + (do @ + [sample code^ + other code^] + ($_ seq + (test "Can parse Lux code." + (case (&;parse [default-cursor +0 (code;to-text sample)]) + (#e;Error error) + false + + (#e;Success [_ parsed]) + (:: code;Eq = parsed sample))) + (test "Can parse Lux multiple code nodes." + (case (&;parse [default-cursor +0 (format (code;to-text sample) " " + (code;to-text other))]) + (#e;Error error) + false + + (#e;Success [remaining =sample]) + (case (&;parse remaining) + (#e;Error error) + false + + (#e;Success [_ =other]) + (and (:: code;Eq = sample =sample) + (:: code;Eq = other =other))))) + )))) + +(def: nat-to-frac + (-> Nat Frac) + (|>. nat-to-int int-to-frac)) + +(context: "Frac special syntax." + (<| (times +100) + (do @ + [numerator (|> r;nat (:: @ map (|>. (n.% +100) nat-to-frac))) + denominator (|> r;nat (:: @ map (|>. (n.% +100) (n.max +1) nat-to-frac))) + signed? r;bool + #let [expected (|> numerator (f./ denominator) (f.* (if signed? -1.0 1.0)))]] + (test "Can parse frac ratio syntax." + (case (&;parse [default-cursor +0 + (format (if signed? "-" "") + (%i (frac-to-int numerator)) + "/" + (%i (frac-to-int denominator)))]) + (#e;Success [_ [_ (#;Frac actual)]]) + (f.= expected actual) + + _ + false) + )))) + +(context: "Nat special syntax." + (<| (times +100) + (do @ + [expected (|> r;nat (:: @ map (n.% +1_000)))] + (test "Can parse nat char syntax." + (case (&;parse [default-cursor +0 + (format "#" (%t (text;from-code expected)) "")]) + (#e;Success [_ [_ (#;Nat actual)]]) + (n.= expected actual) + + _ + false) + )))) + +(def: comment-text^ + (r;Random Text) + (let [char-gen (|> r;nat (r;filter (function [value] + (not (or (text;space? value) + (n.= (char "#") value) + (n.= (char "(") value) + (n.= (char ")") value))))))] + (do r;Monad + [size (|> r;nat (r/map (n.% +20)))] + (r;text' char-gen size)))) + +(def: comment^ + (r;Random Text) + (r;either (do r;Monad + [comment comment-text^] + (wrap (format "## " comment "\n"))) + (r;rec (function [nested^] + (do r;Monad + [comment (r;either comment-text^ + nested^)] + (wrap (format "#( " comment " )#"))))))) + +(context: "Multi-line text & comments." + (<| (times +100) + (do @ + [#let [char-gen (|> r;nat (r;filter (function [value] + (not (or (text;space? value) + (n.= (char "\"") value))))))] + x char-gen + y char-gen + z char-gen + offset-size (|> r;nat (r/map (|>. (n.% +10) (n.max +1)))) + #let [offset (text;join-with "" (list;repeat offset-size " "))] + sample code^ + comment comment^ + unbalanced-comment comment-text^] + ($_ seq + (test "Will reject invalid multi-line text." + (let [bad-match (format (text;from-code x) "\n" + (text;from-code y) "\n" + (text;from-code z))] + (case (&;parse [default-cursor +0 + (format "\"" bad-match "\"")]) + (#e;Error error) + true + + (#e;Success [_ parsed]) + false))) + (test "Will accept valid multi-line text" + (let [good-input (format (text;from-code x) "\n" + offset (text;from-code y) "\n" + offset (text;from-code z)) + good-output (format (text;from-code x) "\n" + (text;from-code y) "\n" + (text;from-code z))] + (case (&;parse [(|> default-cursor (update@ #;column (n.+ (n.dec offset-size)))) + +0 + (format "\"" good-input "\"")]) + (#e;Error error) + false + + (#e;Success [_ parsed]) + (:: code;Eq = + parsed + (code;text good-output))))) + (test "Can handle comments." + (case (&;parse [default-cursor +0 + (format comment (code;to-text sample))]) + (#e;Error error) + false + + (#e;Success [_ parsed]) + (:: code;Eq = parsed sample))) + (test "Will reject unbalanced multi-line comments." + (and (case (&;parse [default-cursor +0 + (format "#(" "#(" unbalanced-comment ")#" + (code;to-text sample))]) + (#e;Error error) + true + + (#e;Success [_ parsed]) + false) + (case (&;parse [default-cursor +0 + (format "#(" unbalanced-comment ")#" ")#" + (code;to-text sample))]) + (#e;Error error) + true + + (#e;Success [_ parsed]) + false))) + )))) diff --git a/new-luxc/test/test/luxc/parser.lux b/new-luxc/test/test/luxc/parser.lux deleted file mode 100644 index 33a0bc154..000000000 --- a/new-luxc/test/test/luxc/parser.lux +++ /dev/null @@ -1,233 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do]) - (data [number] - ["e" error] - [text] - (text format - ["l" lexer]) - (coll [list])) - ["r" math/random "r/" Monad] - (meta [code]) - test) - (luxc ["&" parser])) - -(def: default-cursor - Cursor - {#;module "" - #;line +0 - #;column +0}) - -(def: ident-part^ - (r;Random Text) - (do r;Monad - [#let [digits "0123456789" - delimiters "()[]{}#;\"" - space "\t\v \n\r\f" - invalid-range (format digits delimiters space) - char-gen (|> r;nat - (r;filter (function [sample] - (not (text;contains? (text;from-code sample) - invalid-range)))))] - size (|> r;nat (:: @ map (|>. (n.% +20) (n.max +1))))] - (r;text' char-gen size))) - -(def: ident^ - (r;Random Ident) - (r;seq ident-part^ ident-part^)) - -(def: code^ - (r;Random Code) - (let [numeric^ (: (r;Random Code) - ($_ r;either - (|> r;bool (r/map (|>. #;Bool [default-cursor]))) - (|> r;nat (r/map (|>. #;Nat [default-cursor]))) - (|> r;int (r/map (|>. #;Int [default-cursor]))) - (|> r;deg (r/map (|>. #;Deg [default-cursor]))) - (|> r;frac (r/map (|>. #;Frac [default-cursor]))))) - textual^ (: (r;Random Code) - ($_ r;either - (do r;Monad - [size (|> r;nat (r/map (n.% +20)))] - (|> (r;text size) (r/map (|>. #;Text [default-cursor])))) - (|> ident^ (r/map (|>. #;Symbol [default-cursor]))) - (|> ident^ (r/map (|>. #;Tag [default-cursor]))))) - simple^ (: (r;Random Code) - ($_ r;either - numeric^ - textual^))] - (r;rec - (function [code^] - (let [multi^ (do r;Monad - [size (|> r;nat (r/map (n.% +3)))] - (r;list size code^)) - composite^ (: (r;Random Code) - ($_ r;either - (|> multi^ (r/map (|>. #;Form [default-cursor]))) - (|> multi^ (r/map (|>. #;Tuple [default-cursor]))) - (do r;Monad - [size (|> r;nat (r/map (n.% +3)))] - (|> (r;list size (r;seq code^ code^)) - (r/map (|>. #;Record [default-cursor]))))))] - (r;either simple^ - composite^)))))) - -(context: "Lux code parser." - (<| (times +100) - (do @ - [sample code^ - other code^] - ($_ seq - (test "Can parse Lux code." - (case (&;parse [default-cursor +0 (code;to-text sample)]) - (#e;Error error) - false - - (#e;Success [_ parsed]) - (:: code;Eq = parsed sample))) - (test "Can parse Lux multiple code nodes." - (case (&;parse [default-cursor +0 (format (code;to-text sample) " " - (code;to-text other))]) - (#e;Error error) - false - - (#e;Success [remaining =sample]) - (case (&;parse remaining) - (#e;Error error) - false - - (#e;Success [_ =other]) - (and (:: code;Eq = sample =sample) - (:: code;Eq = other =other))))) - )))) - -(def: nat-to-frac - (-> Nat Frac) - (|>. nat-to-int int-to-frac)) - -(context: "Frac special syntax." - (<| (times +100) - (do @ - [numerator (|> r;nat (:: @ map (|>. (n.% +100) nat-to-frac))) - denominator (|> r;nat (:: @ map (|>. (n.% +100) (n.max +1) nat-to-frac))) - signed? r;bool - #let [expected (|> numerator (f./ denominator) (f.* (if signed? -1.0 1.0)))]] - (test "Can parse frac ratio syntax." - (case (&;parse [default-cursor +0 - (format (if signed? "-" "") - (%i (frac-to-int numerator)) - "/" - (%i (frac-to-int denominator)))]) - (#e;Success [_ [_ (#;Frac actual)]]) - (f.= expected actual) - - _ - false) - )))) - -(context: "Nat special syntax." - (<| (times +100) - (do @ - [expected (|> r;nat (:: @ map (n.% +1_000)))] - (test "Can parse nat char syntax." - (case (&;parse [default-cursor +0 - (format "#" (%t (text;from-code expected)) "")]) - (#e;Success [_ [_ (#;Nat actual)]]) - (n.= expected actual) - - _ - false) - )))) - -(def: comment-text^ - (r;Random Text) - (let [char-gen (|> r;nat (r;filter (function [value] - (not (or (text;space? value) - (n.= (char "#") value) - (n.= (char "(") value) - (n.= (char ")") value))))))] - (do r;Monad - [size (|> r;nat (r/map (n.% +20)))] - (r;text' char-gen size)))) - -(def: comment^ - (r;Random Text) - (r;either (do r;Monad - [comment comment-text^] - (wrap (format "## " comment "\n"))) - (r;rec (function [nested^] - (do r;Monad - [comment (r;either comment-text^ - nested^)] - (wrap (format "#( " comment " )#"))))))) - -(context: "Multi-line text & comments." - (<| (times +100) - (do @ - [#let [char-gen (|> r;nat (r;filter (function [value] - (not (or (text;space? value) - (n.= (char "\"") value))))))] - x char-gen - y char-gen - z char-gen - offset-size (|> r;nat (r/map (|>. (n.% +10) (n.max +1)))) - #let [offset (text;join-with "" (list;repeat offset-size " "))] - sample code^ - comment comment^ - unbalanced-comment comment-text^] - ($_ seq - (test "Will reject invalid multi-line text." - (let [bad-match (format (text;from-code x) "\n" - (text;from-code y) "\n" - (text;from-code z))] - (case (&;parse [default-cursor +0 - (format "\"" bad-match "\"")]) - (#e;Error error) - true - - (#e;Success [_ parsed]) - false))) - (test "Will accept valid multi-line text" - (let [good-input (format (text;from-code x) "\n" - offset (text;from-code y) "\n" - offset (text;from-code z)) - good-output (format (text;from-code x) "\n" - (text;from-code y) "\n" - (text;from-code z))] - (case (&;parse [(|> default-cursor (update@ #;column (n.+ (n.dec offset-size)))) - +0 - (format "\"" good-input "\"")]) - (#e;Error error) - false - - (#e;Success [_ parsed]) - (:: code;Eq = - parsed - (code;text good-output))))) - (test "Can handle comments." - (case (&;parse [default-cursor +0 - (format comment (code;to-text sample))]) - (#e;Error error) - false - - (#e;Success [_ parsed]) - (:: code;Eq = parsed sample))) - (test "Will reject unbalanced multi-line comments." - (and (case (&;parse [default-cursor +0 - (format "#(" "#(" unbalanced-comment ")#" - (code;to-text sample))]) - (#e;Error error) - true - - (#e;Success [_ parsed]) - false) - (case (&;parse [default-cursor +0 - (format "#(" unbalanced-comment ")#" ")#" - (code;to-text sample))]) - (#e;Error error) - true - - (#e;Success [_ parsed]) - false))) - )))) diff --git a/new-luxc/test/test/luxc/synthesizer/primitive.lux b/new-luxc/test/test/luxc/synthesizer/primitive.lux index fb37f6104..2a1490193 100644 --- a/new-luxc/test/test/luxc/synthesizer/primitive.lux +++ b/new-luxc/test/test/luxc/synthesizer/primitive.lux @@ -9,7 +9,6 @@ test) (luxc (lang ["la" analysis] ["ls" synthesis]) - [analyser] [synthesizer])) (context: "Primitives" diff --git a/new-luxc/test/test/luxc/synthesizer/procedure.lux b/new-luxc/test/test/luxc/synthesizer/procedure.lux index 68010adeb..c659c5e34 100644 --- a/new-luxc/test/test/luxc/synthesizer/procedure.lux +++ b/new-luxc/test/test/luxc/synthesizer/procedure.lux @@ -10,7 +10,6 @@ test) (luxc (lang ["la" analysis] ["ls" synthesis]) - (analyser [";A" structure]) [synthesizer]) (.. common)) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index 13eb44402..c112e4076 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -5,15 +5,15 @@ (concurrency [promise]) [cli #+ program:] [test]) - (test (luxc ["_;P" parser] - (analyser ["_;A" primitive] - ["_;A" structure] - ["_;A" reference] - ["_;A" case] - ["_;A" function] - ["_;A" type] - (procedure ["_;A" common] - ["_;A" host])) + (test (luxc (lang ["_;P" parser] + (analysis ["_;A" primitive] + ["_;A" structure] + ["_;A" reference] + ["_;A" case] + ["_;A" function] + ["_;A" type] + (procedure ["_;A" common] + ["_;A" host]))) (synthesizer ["_;S" primitive] ["_;S" structure] (case ["_;S" special]) -- cgit v1.2.3