diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/case.lux | 260 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/case/coverage.lux | 299 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/common.lux | 41 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/expression.lux | 141 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/function.lux | 111 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/inference.lux | 228 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/primitive.lux | 34 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure.lux | 23 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure/common.lux | 418 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux | 1241 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/reference.lux | 53 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 311 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/type.lux | 31 |
13 files changed, 3191 insertions, 0 deletions
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<List> Monoid<List> Functor<List>])) + [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<Meta> + [? (&;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<Meta> + [[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<Meta> wrap outputT) + + #;None + (&;fail (format "Cannot apply type " (%type funcT) " to type " (%type inputT)))) + + _ + (:: meta;Monad<Meta> 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<Meta> + [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 [<type> <code-tag>] + [cursor (<code-tag> test)] + (&;with-cursor cursor + (do meta;Monad<Meta> + [_ (&;with-type-env + (tc;check inputT <type>)) + 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<Meta> + [_ (&;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<Meta> + [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<Meta> + [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<Meta> + [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<Meta> + [[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<Meta> + [[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<Meta> + [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<Meta> + [[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<Error> 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<Bool>] + [number] + ["e" error "error/" Monad<Error>] + text/format + (coll [list "list/" Fold<List>] + [dict #+ Dict])) + [meta "meta/" Monad<Meta>]) + (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<Meta> + [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<Meta> + [=sub (determine sub)] + (wrap (#Variant num-tags + (|> (dict;new number;Hash<Nat>) + (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<Dict> =) = 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<Coverage> "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<Dict> Eq<Coverage>) = casesSF casesA) + redundant-pattern + + ## else + (do e;Monad<Error> + [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<Error> + [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<Error> + [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<Error> + [#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>] + (meta [type] + (type ["tc" check]))) + (luxc ["&" base] + (lang analysis))) + +(def: #export (with-unknown-type action) + (All [a] (-> (Meta Analysis) (Meta [Type Analysis]))) + (do Monad<Meta> + [[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<Meta> + [[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<Meta> + [class (commonG;load-class hostL;function-class)] + (function [compiler] + (do e;Monad<Error> + [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<Meta> + [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 [<tag> <analyser>] + (<tag> value) + (<analyser> 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 [<tag> <analyser>] + (^ (#;Form (list& [_ (<tag> tag)] + values))) + (case values + (#;Cons value #;Nil) + (<analyser> analyse tag value) + + _ + (<analyser> 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<Meta> + [[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<List> Monoid<List> Monad<List>])) + [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<Meta> + [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<Meta> + [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<List>])) + [meta #+ Monad<Meta>] + (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 [<tag>] + (<tag> left right) + (<tag> (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 [<tag>] + (<tag> env quantified) + (<tag> (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 [<tag>] + (<tag> left right) + (<tag> (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 [<tag>] + (<tag> env quantified) + (<tag> (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<Meta> 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<Meta> + [[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<Meta> + [[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<Meta> + [[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<Meta> + [unnamedT+ (record unnamedT)] + (wrap unnamedT+)) + + (^template [<tag>] + (<tag> env bodyT) + (do Monad<Meta> + [bodyT+ (record bodyT)] + (wrap (<tag> env bodyT+)))) + ([#;UnivQ] + [#;ExQ]) + + (#;Product _) + (:: Monad<Meta> 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<Meta> + [unnamedT+ (recur depth unnamedT)] + (wrap unnamedT+)) + + (^template [<tag>] + (<tag> env bodyT) + (do Monad<Meta> + [bodyT+ (recur (n.inc depth) bodyT)] + (wrap (<tag> 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<Meta> 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<Meta> 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 [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (Meta Analysis)) + (do meta;Monad<Meta> + [expected meta;expected-type + _ (&;with-type-env + (tc;check expected <type>))] + (wrap (<tag> 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<Meta> + [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<Maybe> + [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<List>] + [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<Text>))) + +(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<Meta> + [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<Meta> + [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 [<name> <analyser>] + [(def: (<name> proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list typeC valueC)) + (<analyser> 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<Meta> + [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<Text>) + (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<Text>) + (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<Text>) + (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<Text>) + (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<Text>) + (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<Text>) + (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<Text>) + (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<Text>) + (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<Text>) + (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<Text>) + (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<Meta> + [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<Text>) + (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<Text>) + (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<Text>) + (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<Bool>] + [text "text/" Eq<Text>] + (text format + ["l" lexer]) + (coll [list "list/" Fold<List> Functor<List> Monoid<List>] + [array] + [dict #+ Dict])) + [meta "meta/" Monad<Meta>] + (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 [<name> <class>] + [(def: #export <name> Type (#;Primitive <class> (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<Text>) + (@;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 [<name> <prefix> <type>] + [(def: <name> + @;Bundle + (<| (@;prefix <prefix>) + (|> (dict;new text;Hash<Text>) + (@;install "+" (@;binary <type> <type> <type>)) + (@;install "-" (@;binary <type> <type> <type>)) + (@;install "*" (@;binary <type> <type> <type>)) + (@;install "/" (@;binary <type> <type> <type>)) + (@;install "%" (@;binary <type> <type> <type>)) + (@;install "=" (@;binary <type> <type> Boolean)) + (@;install "<" (@;binary <type> <type> Boolean)) + (@;install "and" (@;binary <type> <type> <type>)) + (@;install "or" (@;binary <type> <type> <type>)) + (@;install "xor" (@;binary <type> <type> <type>)) + (@;install "shl" (@;binary <type> Integer <type>)) + (@;install "shr" (@;binary <type> Integer <type>)) + (@;install "ushr" (@;binary <type> Integer <type>)) + )))] + + [int-procs "int" Integer] + [long-procs "long" Long] + ) + +(do-template [<name> <prefix> <type>] + [(def: <name> + @;Bundle + (<| (@;prefix <prefix>) + (|> (dict;new text;Hash<Text>) + (@;install "+" (@;binary <type> <type> <type>)) + (@;install "-" (@;binary <type> <type> <type>)) + (@;install "*" (@;binary <type> <type> <type>)) + (@;install "/" (@;binary <type> <type> <type>)) + (@;install "%" (@;binary <type> <type> <type>)) + (@;install "=" (@;binary <type> <type> Boolean)) + (@;install "<" (@;binary <type> <type> Boolean)) + )))] + + [float-procs "float" Float] + [double-procs "double" Double] + ) + +(def: char-procs + @;Bundle + (<| (@;prefix "char") + (|> (dict;new text;Hash<Text>) + (@;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<Text>))) + +(def: (array-length proc) + (-> Text @;Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list arrayC)) + (do meta;Monad<Meta> + [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<Meta> + [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 [<tag>] + (<tag> 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<Meta> + [name (check-jvm objectT)] + (if (dict;contains? name boxes) + (&;fail (format "Primitives are not objects: " name)) + (:: meta;Monad<Meta> wrap name)))) + +(def: (box-array-element-type elemT) + (-> Type (Meta [Type Text])) + (do meta;Monad<Meta> + [] + (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<Meta> 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<Meta> + [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<Meta> + [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<Text>) + (@;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<Meta> + [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<Meta> + [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<Meta> + [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<Meta> + [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<Meta> + [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<Meta> + [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<Meta> + [_ (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<Meta> + [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<Text>) + (@;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<Text>)) + +(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<Meta> + [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<Meta> + [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<Text>))) + (&;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<Meta> + [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<Meta> + [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<Meta> + [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<Meta> + [[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<Meta> + [[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<Text>)))) + + _ + (&;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<Meta> + [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<Meta> + [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<Meta> + [[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<Meta> + [[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<Meta> + [[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<Meta> + [[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<Meta> + [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<Meta> + [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<Meta> + [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<Text>))))] + (do meta;Monad<Meta> + [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<Meta> + [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<Text>))))] + (do meta;Monad<Meta> + [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<Meta> + [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<Meta> + [[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<Meta> + [#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<Meta> + [#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<Meta> + [#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<Meta> + [#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<Meta> + [#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<Text>) + (dict;merge (<| (@;prefix "static") + (|> (dict;new text;Hash<Text>) + (@;install "get" static-get) + (@;install "put" static-put)))) + (dict;merge (<| (@;prefix "virtual") + (|> (dict;new text;Hash<Text>) + (@;install "get" virtual-get) + (@;install "put" virtual-put)))) + (dict;merge (<| (@;prefix "invoke") + (|> (dict;new text;Hash<Text>) + (@;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<Text>) + (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<Meta> + [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<Meta> + [?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<Meta> + [?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<List>] + [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<Meta> + [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<Meta> + [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<Meta> + [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<Meta> + [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<Meta> + (function [[key val]] + (case key + [_ (#;Tag key)] + (do meta;Monad<Meta> + [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<Meta> wrap [(list) Unit]) + + (#;Cons [head-k head-v] _) + (do meta;Monad<Meta> + [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<Ident> (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<Nat>)) + 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<Meta> + [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>] + (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<Meta> + [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<Meta> + [actual (eval Type type) + expected meta;expected-type + _ (&;with-type-env + (TC;check expected (:! Type actual)))] + (&;with-expected-type Top + (analyse value)))) |