diff options
Diffstat (limited to 'new-luxc/source/luxc/analyser')
| -rw-r--r-- | new-luxc/source/luxc/analyser/case.lux | 260 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/case/coverage.lux | 299 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/common.lux | 41 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/function.lux | 111 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/inference.lux | 228 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/primitive.lux | 34 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure.lux | 23 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/common.lux | 418 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 1241 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/reference.lux | 53 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/structure.lux | 311 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/type.lux | 31 |
12 files changed, 0 insertions, 3050 deletions
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux deleted file mode 100644 index 29256865a..000000000 --- a/new-luxc/source/luxc/analyser/case.lux +++ /dev/null @@ -1,260 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - eq) - (data [bool] - [number] - [product] - ["e" error] - [maybe] - [text] - text/format - (coll [list "list/" Fold<List> Monoid<List> Functor<List>])) - [meta] - (meta [code] - [type] - (type ["tc" check]))) - (../.. ["&" base] - (lang ["la" analysis]) - ["&;" scope]) - (.. ["&;" common] - ["&;" structure]) - (. ["&&;" coverage])) - -(exception: #export Cannot-Match-Type-With-Pattern) -(exception: #export Sum-Type-Has-No-Case) -(exception: #export Unrecognized-Pattern-Syntax) -(exception: #export Cannot-Simplify-Type-For-Pattern-Matching) - -(def: (pattern-error type pattern) - (-> Type Code Text) - (Cannot-Match-Type-With-Pattern - (format " Type: " (%type type) "\n" - "Pattern: " (%code pattern)))) - -## Type-checking on the input value is done during the analysis of a -## "case" expression, to ensure that the patterns being used make -## sense for the type of the input value. -## Sometimes, that input value is complex, by depending on -## type-variables or quantifications. -## This function makes it easier for "case" analysis to properly -## type-check the input with respect to the patterns. -(def: (simplify-case-type type) - (-> Type (Meta Type)) - (case type - (#;Var id) - (do meta;Monad<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 (&structure;normalize record) - [members recordT] (&structure;order record) - _ (&;with-type-env - (tc;check inputT recordT))] - (analyse-pattern (#;Some (list;size members)) inputT [cursor (#;Tuple members)] next)) - - [cursor (#;Tag tag)] - (&;with-cursor cursor - (analyse-pattern #;None inputT (` ((~ pattern))) next)) - - (^ [cursor (#;Form (list& [_ (#;Nat idx)] values))]) - (&;with-cursor cursor - (do meta;Monad<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] (&common;with-unknown-type - (analyse inputC)) - outputH (analyse-pattern #;None inputT patternH (analyse bodyH)) - outputT (monad;map @ - (function [[patternT bodyT]] - (analyse-pattern #;None inputT patternT (analyse bodyT))) - branchesT) - outputHC (|> outputH product;left &&coverage;determine) - outputTC (monad;map @ (|>. product;left &&coverage;determine) outputT) - _ (case (monad;fold e;Monad<Error> &&coverage;merge outputHC outputTC) - (#e;Success coverage) - (if (&&coverage;exhaustive? coverage) - (wrap []) - (&;fail "Pattern-matching is not exhaustive.")) - - (#e;Error error) - (&;fail error))] - (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT))))))))) diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux deleted file mode 100644 index 554aea1a8..000000000 --- a/new-luxc/source/luxc/analyser/case/coverage.lux +++ /dev/null @@ -1,299 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - eq) - (data [bool "bool/" Eq<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/analyser/common.lux b/new-luxc/source/luxc/analyser/common.lux deleted file mode 100644 index 4cbf5aedf..000000000 --- a/new-luxc/source/luxc/analyser/common.lux +++ /dev/null @@ -1,41 +0,0 @@ -(;module: - lux - (lux (control monad - pipe) - (data text/format - [product]) - [meta #+ Monad<Meta>] - (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/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux deleted file mode 100644 index 3d2da6326..000000000 --- a/new-luxc/source/luxc/analyser/function.lux +++ /dev/null @@ -1,111 +0,0 @@ -(;module: - lux - (lux (control monad - ["ex" exception #+ exception:]) - (data [maybe] - [text] - text/format - (coll [list "list/" Fold<List> Monoid<List> Monad<List>])) - [meta] - (meta [code] - [type] - (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis] - [";L" variable #+ Variable]) - ["&;" scope] - (analyser ["&;" common] - ["&;" inference]))) - -(exception: #export Invalid-Function-Type) -(exception: #export Cannot-Apply-Function) - -## [Analysers] -(def: #export (analyse-function analyse func-name arg-name body) - (-> &;Analyser Text Text Code (Meta Analysis)) - (do meta;Monad<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/analyser/inference.lux b/new-luxc/source/luxc/analyser/inference.lux deleted file mode 100644 index 049abec28..000000000 --- a/new-luxc/source/luxc/analyser/inference.lux +++ /dev/null @@ -1,228 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [maybe] - [text] - text/format - (coll [list "list/" Functor<List>])) - [meta #+ Monad<Meta>] - (meta [type] - (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis]) - (analyser ["&;" common]))) - -(exception: #export Cannot-Infer) -(exception: #export Cannot-Infer-Argument) -(exception: #export Smaller-Variant-Than-Expected) - -## When doing inference, type-variables often need to be created in -## order to figure out which types are present in the expression being -## inferred. -## If a type-variable never gets bound/resolved to a type, then that -## means the expression can be generalized through universal -## quantification. -## When that happens, the type-variable must be replaced by an -## argument to the universally-quantified type. -(def: #export (replace-var var-id bound-idx type) - (-> Nat Nat Type Type) - (case type - (#;Primitive name params) - (#;Primitive name (list/map (replace-var var-id bound-idx) params)) - - (^template [<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/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux deleted file mode 100644 index c7f7243fd..000000000 --- a/new-luxc/source/luxc/analyser/primitive.lux +++ /dev/null @@ -1,34 +0,0 @@ -(;module: - lux - (lux (control monad) - [meta] - (meta [code] - (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis]))) - -## [Analysers] -(do-template [<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/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux deleted file mode 100644 index 225fb7b23..000000000 --- a/new-luxc/source/luxc/analyser/procedure.lux +++ /dev/null @@ -1,23 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (data [maybe] - [text] - text/format - (coll [dict]))) - (luxc ["&" base] - (lang ["la" analysis])) - (. ["./;" common] - ["./;" host])) - -(def: procedures - ./common;Bundle - (|> ./common;procedures - (dict;merge ./host;procedures))) - -(def: #export (analyse-procedure analyse eval proc-name proc-args) - (-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis)) - (<| (maybe;default (&;fail (format "Unknown procedure: " (%t proc-name)))) - (do maybe;Monad<Maybe> - [proc (dict;get proc-name procedures)] - (wrap (proc analyse eval proc-args))))) diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux deleted file mode 100644 index 0fad41958..000000000 --- a/new-luxc/source/luxc/analyser/procedure/common.lux +++ /dev/null @@ -1,418 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (concurrency ["A" atom]) - (data [text] - text/format - (coll [list "list/" Functor<List>] - [array] - [dict #+ Dict])) - [meta] - (meta [code] - (type ["tc" check])) - [io]) - (luxc ["&" base] - (lang ["la" analysis]) - (analyser ["&;" common] - [";A" function] - [";A" case] - [";A" type]))) - -## [Utils] -(type: #export Proc - (-> &;Analyser &;Eval (List Code) (Meta la;Analysis))) - -(type: #export Bundle - (Dict Text Proc)) - -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict;put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict;entries - (list/map (function [[key val]] [(format prefix " " key) val])) - (dict;from-list text;Hash<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/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux deleted file mode 100644 index 015379a1b..000000000 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ /dev/null @@ -1,1241 +0,0 @@ -(;module: - [lux #- char] - (lux (control [monad #+ do] - ["p" parser] - ["ex" exception #+ exception:]) - (concurrency ["A" atom]) - (data ["e" error] - [maybe] - [product] - [bool "bool/" Eq<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]) - (analyser ["&;" 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/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux deleted file mode 100644 index 5bc1f96c9..000000000 --- a/new-luxc/source/luxc/analyser/reference.lux +++ /dev/null @@ -1,53 +0,0 @@ -(;module: - lux - (lux (control monad) - [meta] - (meta [code] - (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis] - [";L" variable #+ Variable]) - ["&;" scope])) - -## [Analysers] -(def: (analyse-definition def-name) - (-> Ident (Meta Analysis)) - (do meta;Monad<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/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux deleted file mode 100644 index d523065ea..000000000 --- a/new-luxc/source/luxc/analyser/structure.lux +++ /dev/null @@ -1,311 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - pipe) - [function] - (concurrency ["A" atom]) - (data [ident] - [number] - [product] - [maybe] - (coll [list "list/" Functor<List>] - [dict #+ Dict]) - [text] - text/format) - [meta] - (meta [code] - [type] - (type ["tc" check]))) - (luxc ["&" base] - (lang ["la" analysis]) - ["&;" module] - ["&;" scope] - (analyser ["&;" common] - ["&;" inference]))) - -(exception: #export Not-Variant-Type) -(exception: #export Not-Tuple-Type) -(exception: #export Cannot-Infer-Numeric-Tag) - -(type: Type-Error - (-> Type Text)) - -(def: (not-quantified type) - Type-Error - (format "Not a quantified type: " (%type type))) - -(def: #export (analyse-sum analyse tag valueC) - (-> &;Analyser Nat Code (Meta la;Analysis)) - (do meta;Monad<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/analyser/type.lux b/new-luxc/source/luxc/analyser/type.lux deleted file mode 100644 index d0b038d93..000000000 --- a/new-luxc/source/luxc/analyser/type.lux +++ /dev/null @@ -1,31 +0,0 @@ -(;module: - lux - (lux (control monad) - [meta #+ Monad<Meta>] - (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)))) |