diff options
Diffstat (limited to 'stdlib/source/lux/tool/compiler/phase')
40 files changed, 7083 insertions, 0 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/analysis.lux b/stdlib/source/lux/tool/compiler/phase/analysis.lux new file mode 100644 index 000000000..845346482 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis.lux @@ -0,0 +1,349 @@ +(.module: + [lux (#- nat int rev) + [control + [monad (#+ do)]] + [data + ["." product] + ["." error] + ["." maybe] + ["." text ("#/." equivalence) + format] + [collection + ["." list ("#/." functor fold)]]] + ["." function]] + [// + ["." extension (#+ Extension)] + [// + ["." reference (#+ Register Variable Reference)]]]) + +(type: #export #rec Primitive + #Unit + (#Bit Bit) + (#Nat Nat) + (#Int Int) + (#Rev Rev) + (#Frac Frac) + (#Text Text)) + +(type: #export Tag Nat) + +(type: #export (Variant a) + {#lefts Nat + #right? Bit + #value a}) + +(type: #export (Tuple a) (List a)) + +(type: #export (Composite a) + (#Variant (Variant a)) + (#Tuple (Tuple a))) + +(type: #export #rec Pattern + (#Simple Primitive) + (#Complex (Composite Pattern)) + (#Bind Register)) + +(type: #export (Branch' e) + {#when Pattern + #then e}) + +(type: #export (Match' e) + [(Branch' e) (List (Branch' e))]) + +(type: #export Environment + (List Variable)) + +(type: #export #rec Analysis + (#Primitive Primitive) + (#Structure (Composite Analysis)) + (#Reference Reference) + (#Case Analysis (Match' Analysis)) + (#Function Environment Analysis) + (#Apply Analysis Analysis) + (#Extension (Extension Analysis))) + +(type: #export Branch + (Branch' Analysis)) + +(type: #export Match + (Match' Analysis)) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (<tag> content))] + + [control/case #..Case] + ) + +(do-template [<name> <type> <tag>] + [(def: #export <name> + (-> <type> Analysis) + (|>> <tag> #..Primitive))] + + [bit Bit #..Bit] + [nat Nat #..Nat] + [int Int #..Int] + [rev Rev #..Rev] + [frac Frac #..Frac] + [text Text #..Text] + ) + +(type: #export Arity Nat) + +(type: #export (Abstraction c) [Environment Arity c]) + +(type: #export (Application c) [c (List c)]) + +(def: (last? size tag) + (-> Nat Tag Bit) + (n/= (dec size) tag)) + +(template: #export (no-op value) + (|> 1 #reference.Local #reference.Variable #..Reference + (#..Function (list)) + (#..Apply value))) + +(def: #export (apply [abstraction inputs]) + (-> (Application Analysis) Analysis) + (list/fold (function (_ input abstraction') + (#Apply input abstraction')) + abstraction + inputs)) + +(def: #export (application analysis) + (-> Analysis (Application Analysis)) + (loop [abstraction analysis + inputs (list)] + (case abstraction + (#Apply input next) + (recur next (#.Cons input inputs)) + + _ + [abstraction inputs]))) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Reference + <tag> + content))] + + [variable #reference.Variable] + [constant #reference.Constant] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Complex + <tag> + content))] + + [pattern/variant #..Variant] + [pattern/tuple #..Tuple] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Structure + <tag> + content))] + + [variant #..Variant] + [tuple #..Tuple] + ) + +(template: #export (pattern/unit) + (#..Simple #..Unit)) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (#..Simple (<tag> content)))] + + [pattern/bit #..Bit] + [pattern/nat #..Nat] + [pattern/int #..Int] + [pattern/rev #..Rev] + [pattern/frac #..Frac] + [pattern/text #..Text] + ) + +(template: #export (pattern/bind register) + (#..Bind register)) + +(def: #export (%analysis analysis) + (Format Analysis) + (case analysis + (#Primitive primitive) + (case primitive + #Unit + "[]" + + (^template [<tag> <format>] + (<tag> value) + (<format> value)) + ([#Bit %b] + [#Nat %n] + [#Int %i] + [#Rev %r] + [#Frac %f] + [#Text %t])) + + (#Structure structure) + (case structure + (#Variant [lefts right? value]) + (format "(" (%n lefts) " " (%b right?) " " (%analysis value) ")") + + (#Tuple members) + (|> members + (list/map %analysis) + (text.join-with " ") + (text.enclose ["[" "]"]))) + + (#Reference reference) + (case reference + (#reference.Variable variable) + (reference.%variable variable) + + (#reference.Constant constant) + (%name constant)) + + (#Case analysis match) + "{?}" + + (#Function environment body) + (|> (%analysis body) + (format " ") + (format (|> environment + (list/map reference.%variable) + (text.join-with " ") + (text.enclose ["[" "]"]))) + (text.enclose ["(" ")"])) + + (#Apply _) + (|> analysis + ..application + #.Cons + (list/map %analysis) + (text.join-with " ") + (text.enclose ["(" ")"])) + + (#Extension name parameters) + (|> parameters + (list/map %analysis) + (text.join-with " ") + (format (%t name) " ") + (text.enclose ["(" ")"])))) + +(do-template [<special> <general>] + [(type: #export <special> + (<general> .Lux Code Analysis))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(def: #export (with-source-code source action) + (All [a] (-> Source (Operation a) (Operation a))) + (function (_ [bundle state]) + (let [old-source (get@ #.source state)] + (case (action [bundle (set@ #.source source state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ #.source old-source state')] + output]) + + (#error.Failure error) + (#error.Failure error))))) + +(def: fresh-bindings + (All [k v] (Bindings k v)) + {#.counter 0 + #.mappings (list)}) + +(def: fresh-scope + Scope + {#.name (list) + #.inner 0 + #.locals fresh-bindings + #.captured fresh-bindings}) + +(def: #export (with-scope action) + (All [a] (-> (Operation a) (Operation [Scope a]))) + (function (_ [bundle state]) + (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh-scope)) state)]) + (#error.Success [[bundle' state'] output]) + (case (get@ #.scopes state') + (#.Cons head tail) + (#error.Success [[bundle' (set@ #.scopes tail state')] + [head output]]) + + #.Nil + (#error.Failure "Impossible error: Drained scopes!")) + + (#error.Failure error) + (#error.Failure error)))) + +(def: #export (with-current-module name) + (All [a] (-> Text (Operation a) (Operation a))) + (extension.localized (get@ #.current-module) + (set@ #.current-module) + (function.constant (#.Some name)))) + +(def: #export (with-cursor cursor action) + (All [a] (-> Cursor (Operation a) (Operation a))) + (if (text/= "" (product.left cursor)) + action + (function (_ [bundle state]) + (let [old-cursor (get@ #.cursor state)] + (case (action [bundle (set@ #.cursor cursor state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ #.cursor old-cursor state')] + output]) + + (#error.Failure error) + (#error.Failure (format "@ " (%cursor cursor) text.new-line + error))))))) + +(do-template [<name> <type> <field> <value>] + [(def: #export (<name> value) + (-> <type> (Operation Any)) + (extension.update (set@ <field> <value>)))] + + [set-source-code Source #.source value] + [set-current-module Text #.current-module (#.Some value)] + [set-cursor Cursor #.cursor value] + ) + +(def: #export (cursor file) + (-> Text Cursor) + [file 1 0]) + +(def: #export (source file code) + (-> Text Text Source) + [(cursor file) 0 code]) + +(def: dummy-source + Source + [.dummy-cursor 0 ""]) + +(def: type-context + Type-Context + {#.ex-counter 0 + #.var-counter 0 + #.var-bindings (list)}) + +(def: #export (state info host) + (-> Info Any Lux) + {#.info info + #.source ..dummy-source + #.cursor .dummy-cursor + #.current-module #.None + #.modules (list) + #.scopes (list) + #.type-context ..type-context + #.expected #.None + #.seed 0 + #.scope-type-vars (list) + #.extensions [] + #.host host}) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/case.lux b/stdlib/source/lux/tool/compiler/phase/analysis/case.lux new file mode 100644 index 000000000..37bcfef6e --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/case.lux @@ -0,0 +1,300 @@ +(.module: + [lux (#- case) + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." product] + ["." error] + ["." maybe] + [text + format] + [collection + ["." list ("#/." fold monoid functor)]]] + ["." type + ["." check]] + ["." macro + ["." code]]] + ["." // (#+ Pattern Analysis Operation Phase) + ["." scope] + ["//." type] + ["." structure] + ["/." // + ["." extension]]] + [/ + ["." coverage (#+ Coverage)]]) + +(exception: #export (cannot-match-with-pattern {type Type} {pattern Code}) + (ex.report ["Type" (%type type)] + ["Pattern" (%code pattern)])) + +(exception: #export (sum-has-no-case {case Nat} {type Type}) + (ex.report ["Case" (%n case)] + ["Type" (%type type)])) + +(exception: #export (not-a-pattern {code Code}) + (ex.report ["Code" (%code code)])) + +(exception: #export (cannot-simplify-for-pattern-matching {type Type}) + (ex.report ["Type" (%type type)])) + +(exception: #export (non-exhaustive-pattern-matching {input Code} {branches (List [Code Code])} {coverage Coverage}) + (ex.report ["Input" (%code input)] + ["Branches" (%code (code.record branches))] + ["Coverage" (coverage.%coverage coverage)])) + +(exception: #export (cannot-have-empty-branches {message Text}) + message) + +(def: (re-quantify envs baseT) + (-> (List (List Type)) Type Type) + (.case envs + #.Nil + baseT + + (#.Cons head tail) + (re-quantify tail (#.UnivQ head baseT)))) + +## 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 caseT) + (-> Type (Operation Type)) + (loop [envs (: (List (List Type)) + (list)) + caseT caseT] + (.case caseT + (#.Var id) + (do ///.monad + [?caseT' (//type.with-env + (check.read id))] + (.case ?caseT' + (#.Some caseT') + (recur envs caseT') + + _ + (///.throw cannot-simplify-for-pattern-matching caseT))) + + (#.Named name unnamedT) + (recur envs unnamedT) + + (#.UnivQ env unquantifiedT) + (recur (#.Cons env envs) unquantifiedT) + + (#.ExQ _) + (do ///.monad + [[ex-id exT] (//type.with-env + check.existential)] + (recur envs (maybe.assume (type.apply (list exT) caseT)))) + + (#.Apply inputT funcT) + (.case funcT + (#.Var funcT-id) + (do ///.monad + [funcT' (//type.with-env + (do check.monad + [?funct' (check.read funcT-id)] + (.case ?funct' + (#.Some funct') + (wrap funct') + + _ + (check.throw cannot-simplify-for-pattern-matching caseT))))] + (recur envs (#.Apply inputT funcT'))) + + _ + (.case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur envs outputT) + + #.None + (///.throw cannot-simplify-for-pattern-matching caseT))) + + (#.Product _) + (|> caseT + type.flatten-tuple + (list/map (re-quantify envs)) + type.tuple + (:: ///.monad wrap)) + + _ + (:: ///.monad wrap (re-quantify envs caseT))))) + +(def: (analyse-primitive type inputT cursor output next) + (All [a] (-> Type Type Cursor Pattern (Operation a) (Operation [Pattern a]))) + (//.with-cursor cursor + (do ///.monad + [_ (//type.with-env + (check.check inputT type)) + outputA next] + (wrap [output outputA])))) + +## 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 (Operation a) (Operation [Pattern a]))) + (.case pattern + [cursor (#.Identifier ["" name])] + (//.with-cursor cursor + (do ///.monad + [outputA (scope.with-local [name inputT] + next) + idx scope.next-local] + (wrap [(#//.Bind idx) outputA]))) + + (^template [<type> <input> <output>] + [cursor <input>] + (analyse-primitive <type> inputT cursor (#//.Simple <output>) next)) + ([Bit (#.Bit pattern-value) (#//.Bit pattern-value)] + [Nat (#.Nat pattern-value) (#//.Nat pattern-value)] + [Int (#.Int pattern-value) (#//.Int pattern-value)] + [Rev (#.Rev pattern-value) (#//.Rev pattern-value)] + [Frac (#.Frac pattern-value) (#//.Frac pattern-value)] + [Text (#.Text pattern-value) (#//.Text pattern-value)] + [Any (#.Tuple #.Nil) #//.Unit]) + + (^ [cursor (#.Tuple (list singleton))]) + (analyse-pattern #.None inputT singleton next) + + [cursor (#.Tuple sub-patterns)] + (//.with-cursor cursor + (do ///.monad + [inputT' (simplify-case inputT)] + (.case inputT' + (#.Product _) + (let [subs (type.flatten-tuple inputT') + num-subs (maybe.default (list.size subs) + num-tags) + num-sub-patterns (list.size sub-patterns) + matches (cond (n/< num-subs num-sub-patterns) + (let [[prefix suffix] (list.split (dec num-sub-patterns) subs)] + (list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns)) + + (n/> num-subs num-sub-patterns) + (let [[prefix suffix] (list.split (dec num-subs) sub-patterns)] + (list.zip2 subs (list/compose prefix (list (code.tuple suffix))))) + + ## (n/= num-subs num-sub-patterns) + (list.zip2 subs sub-patterns))] + (do @ + [[memberP+ thenA] (list/fold (: (All [a] + (-> [Type Code] (Operation [(List Pattern) a]) + (Operation [(List Pattern) a]))) + (function (_ [memberT memberC] then) + (do @ + [[memberP [memberP+ thenA]] ((:coerce (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) + analyse-pattern) + #.None memberT memberC then)] + (wrap [(list& memberP memberP+) thenA])))) + (do @ + [nextA next] + (wrap [(list) nextA])) + (list.reverse matches))] + (wrap [(//.pattern/tuple memberP+) + thenA]))) + + _ + (///.throw cannot-match-with-pattern [inputT pattern]) + ))) + + [cursor (#.Record record)] + (do ///.monad + [record (structure.normalize record) + [members recordT] (structure.order record) + _ (//type.with-env + (check.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 ///.monad + [inputT' (simplify-case 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 caseT) + (n/< num-cases idx)) + (do ///.monad + [[testP nextA] (if (and (n/> num-cases size-sum) + (n/= (dec num-cases) idx)) + (analyse-pattern #.None + (type.variant (list.drop (dec num-cases) flat-sum)) + (` [(~+ values)]) + next) + (analyse-pattern #.None caseT (` [(~+ values)]) next)) + #let [right? (n/= (dec num-cases) idx) + lefts (if right? + (dec idx) + idx)]] + (wrap [(//.pattern/variant [lefts right? testP]) + nextA])) + + _ + (///.throw sum-has-no-case [idx inputT]))) + + _ + (///.throw cannot-match-with-pattern [inputT pattern])))) + + (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) + (//.with-cursor cursor + (do ///.monad + [tag (extension.lift (macro.normalize tag)) + [idx group variantT] (extension.lift (macro.resolve-tag tag)) + _ (//type.with-env + (check.check inputT variantT))] + (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) + + _ + (///.throw not-a-pattern pattern) + )) + +(def: #export (case analyse inputC branches) + (-> Phase Code (List [Code Code]) (Operation Analysis)) + (.case branches + (#.Cons [patternH bodyH] branchesT) + (do ///.monad + [[inputT inputA] (//type.with-inference + (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 error.monad coverage.merge outputHC outputTC) + (#error.Success coverage) + (///.assert non-exhaustive-pattern-matching [inputC branches coverage] + (coverage.exhaustive? coverage)) + + (#error.Failure error) + (///.fail error))] + (wrap (#//.Case inputA [outputH outputT]))) + + #.Nil + (///.throw cannot-have-empty-branches ""))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux b/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux new file mode 100644 index 000000000..cd6ccd83d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux @@ -0,0 +1,366 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)] + equivalence] + [data + ["." bit ("#/." equivalence)] + ["." number] + ["." error (#+ Error) ("#/." monad)] + ["." maybe] + ["." text + format] + [collection + ["." list ("#/." functor fold)] + ["." dictionary (#+ Dictionary)]]]] + ["." //// ("#/." monad)] + ["." /// (#+ Pattern Variant Operation)]) + +(exception: #export (invalid-tuple-pattern) + "Tuple size must be >= 2") + +(def: cases + (-> (Maybe Nat) Nat) + (|>> (maybe.default 0))) + +(def: known-cases? + (-> Nat Bit) + (n/> 0)) + +## 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 bits +## and variants. +(type: #export #rec Coverage + #Partial + (#Bit Bit) + (#Variant (Maybe Nat) (Dictionary Nat Coverage)) + (#Seq Coverage Coverage) + (#Alt Coverage Coverage) + #Exhaustive) + +(def: #export (exhaustive? coverage) + (-> Coverage Bit) + (case coverage + (#Exhaustive _) + #1 + + _ + #0)) + +(def: #export (%coverage value) + (Format Coverage) + (case value + #Partial + "#Partial" + + (#Bit value') + (|> value' + %b + (text.enclose ["(#Bit " ")"])) + + (#Variant ?max-cases cases) + (|> cases + dictionary.entries + (list/map (function (_ [idx coverage]) + (format (%n idx) " " (%coverage coverage)))) + (text.join-with " ") + (text.enclose ["{" "}"]) + (format (%n (..cases ?max-cases)) " ") + (text.enclose ["(#Variant " ")"])) + + (#Seq left right) + (format "(#Seq " (%coverage left) " " (%coverage right) ")") + + (#Alt left right) + (format "(#Alt " (%coverage left) " " (%coverage right) ")") + + #Exhaustive + "#Exhaustive")) + +(def: #export (determine pattern) + (-> Pattern (Operation Coverage)) + (case pattern + (^or (#///.Simple #///.Unit) + (#///.Bind _)) + (/////wrap #Exhaustive) + + ## Primitive patterns always have partial coverage because there + ## are too many possibilities as far as values go. + (^template [<tag>] + (#///.Simple (<tag> _)) + (/////wrap #Partial)) + ([#///.Nat] + [#///.Int] + [#///.Rev] + [#///.Frac] + [#///.Text]) + + ## Bits are the exception, since there is only "#1" and + ## "#0", which means it is possible for bit + ## pattern-matching to become exhaustive if complementary parts meet. + (#///.Simple (#///.Bit value)) + (/////wrap (#Bit value)) + + ## Tuple patterns can be exhaustive if there is exhaustiveness for all of + ## their sub-patterns. + (#///.Complex (#///.Tuple membersP+)) + (case (list.reverse membersP+) + (^or #.Nil (#.Cons _ #.Nil)) + (////.throw invalid-tuple-pattern []) + + (#.Cons lastP prevsP+) + (do ////.monad + [lastC (determine lastP)] + (monad.fold ////.monad + (function (_ leftP rightC) + (do ////.monad + [leftC (determine leftP)] + (case rightC + #Exhaustive + (wrap leftC) + + _ + (wrap (#Seq leftC rightC))))) + lastC prevsP+))) + + ## Variant patterns can be shown to be exhaustive if all the possible + ## cases are handled exhaustively. + (#///.Complex (#///.Variant [lefts right? value])) + (do ////.monad + [value-coverage (determine value) + #let [idx (if right? + (inc lefts) + lefts)]] + (wrap (#Variant (if right? + (#.Some idx) + #.None) + (|> (dictionary.new number.hash) + (dictionary.put idx value-coverage))))))) + +(def: (xor left right) + (-> Bit Bit Bit) + (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. +(exception: #export (redundant-pattern {so-far Coverage} {addition Coverage}) + (ex.report ["Coverage so-far" (%coverage so-far)] + ["Coverage addition" (%coverage addition)])) + +(def: (flatten-alt coverage) + (-> Coverage (List Coverage)) + (case coverage + (#Alt left right) + (list& left (flatten-alt right)) + + _ + (list coverage))) + +(structure: _ (Equivalence Coverage) + (def: (= reference sample) + (case [reference sample] + [#Exhaustive #Exhaustive] + #1 + + [(#Bit sideR) (#Bit sideS)] + (bit/= sideR sideS) + + [(#Variant allR casesR) (#Variant allS casesS)] + (and (n/= (cases allR) + (cases allS)) + (:: (dictionary.equivalence =) = 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)))) + + _ + #0))) + +(open: "coverage/." ..equivalence) + +(exception: #export (variants-do-not-match {addition-cases Nat} {so-far-cases Nat}) + (ex.report ["So-far Cases" (%n so-far-cases)] + ["Addition Cases" (%n addition-cases)])) + +## 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 (Error Coverage)) + (case [addition so-far] + [#Partial #Partial] + (error/wrap #Partial) + + ## 2 bit coverages are exhaustive if they complement one another. + (^multi [(#Bit sideA) (#Bit sideSF)] + (xor sideA sideSF)) + (error/wrap #Exhaustive) + + [(#Variant allA casesA) (#Variant allSF casesSF)] + (let [addition-cases (cases allSF) + so-far-cases (cases allA)] + (cond (and (known-cases? addition-cases) + (known-cases? so-far-cases) + (not (n/= addition-cases so-far-cases))) + (ex.throw variants-do-not-match [addition-cases so-far-cases]) + + (:: (dictionary.equivalence ..equivalence) = casesSF casesA) + (ex.throw redundant-pattern [so-far addition]) + + ## else + (do error.monad + [casesM (monad.fold @ + (function (_ [tagA coverageA] casesSF') + (case (dictionary.get tagA casesSF') + (#.Some coverageSF) + (do @ + [coverageM (merge coverageA coverageSF)] + (wrap (dictionary.put tagA coverageM casesSF'))) + + #.None + (wrap (dictionary.put tagA coverageA casesSF')))) + casesSF (dictionary.entries casesA))] + (wrap (if (and (or (known-cases? addition-cases) + (known-cases? so-far-cases)) + (n/= (inc (n/max addition-cases so-far-cases)) + (dictionary.size casesM)) + (list.every? exhaustive? (dictionary.values casesM))) + #Exhaustive + (#Variant (case allSF + (#.Some _) + allSF + + _ + allA) + casesM)))))) + + [(#Seq leftA rightA) (#Seq leftSF rightSF)] + (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)] + ## Same prefix + [#1 #0] + (do error.monad + [rightM (merge rightA rightSF)] + (if (exhaustive? rightM) + ## If all that follows is exhaustive, then it can be safely dropped + ## (since only the "left" part would influence whether the + ## merged coverage is exhaustive or not). + (wrap leftSF) + (wrap (#Seq leftSF rightM)))) + + ## Same suffix + [#0 #1] + (do error.monad + [leftM (merge leftA leftSF)] + (wrap (#Seq leftM rightA))) + + ## The 2 sequences cannot possibly be merged. + [#0 #0] + (error/wrap (#Alt so-far addition)) + + ## There is nothing the addition adds to the coverage. + [#1 #1] + (ex.throw redundant-pattern [so-far addition])) + + ## The addition cannot possibly improve the coverage. + [_ #Exhaustive] + (ex.throw redundant-pattern [so-far addition]) + + ## The addition completes the coverage. + [#Exhaustive _] + (error/wrap #Exhaustive) + + ## The left part will always match, so the addition is redundant. + (^multi [(#Seq left right) single] + (coverage/= left single)) + (ex.throw redundant-pattern [so-far addition]) + + ## The right part is not necessary, since it can always match the left. + (^multi [single (#Seq left right)] + (coverage/= 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 error.monad + [#let [fuse-once (: (-> Coverage (List Coverage) + (Error [(Maybe Coverage) + (List Coverage)])) + (function (_ coverageA possibilitiesSF) + (loop [altsSF possibilitiesSF] + (case altsSF + #.Nil + (wrap [#.None (list coverageA)]) + + (#.Cons altSF altsSF') + (case (merge coverageA altSF) + (#error.Success altMSF) + (case altMSF + (#Alt _) + (do @ + [[success altsSF+] (recur altsSF')] + (wrap [success (#.Cons altSF altsSF+)])) + + _ + (wrap [(#.Some altMSF) altsSF'])) + + (#error.Failure error) + (error.fail error)) + ))))] + [successA possibilitiesSF] (fuse-once addition (flatten-alt so-far))] + (loop [successA successA + possibilitiesSF possibilitiesSF] + (case successA + (#.Some coverageA') + (do @ + [[successA' possibilitiesSF'] (fuse-once coverageA' possibilitiesSF)] + (recur successA' possibilitiesSF')) + + #.None + (case (list.reverse possibilitiesSF) + (#.Cons last prevs) + (wrap (list/fold (function (_ left right) (#Alt left right)) + last + prevs)) + + #.Nil + (undefined))))) + + _ + (if (coverage/= so-far addition) + ## The addition cannot possibly improve the coverage. + (ex.throw redundant-pattern [so-far addition]) + ## There are now 2 alternative paths. + (error/wrap (#Alt so-far addition))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux b/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux new file mode 100644 index 000000000..3ce70fe9b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux @@ -0,0 +1,109 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." error] + [text + format]] + ["." macro]] + ["." // (#+ Analysis Operation Phase) + ["." type] + ["." primitive] + ["." structure] + ["//." reference] + ["." case] + ["." function] + ["//." macro] + ["/." // + ["." extension] + [// + ["." reference]]]]) + +(exception: #export (unrecognized-syntax {code Code}) + (ex.report ["Code" (%code code)])) + +(def: #export (compile code) + Phase + (do ///.monad + [expectedT (extension.lift macro.expected-type)] + (let [[cursor code'] code] + ## The cursor must be set in the state for the sake + ## of having useful error messages. + (//.with-cursor cursor + (case code' + (^template [<tag> <analyser>] + (<tag> value) + (<analyser> value)) + ([#.Bit primitive.bit] + [#.Nat primitive.nat] + [#.Int primitive.int] + [#.Rev primitive.rev] + [#.Frac primitive.frac] + [#.Text primitive.text]) + + (^template [<tag> <analyser>] + (^ (#.Form (list& [_ (<tag> tag)] + values))) + (case values + (#.Cons value #.Nil) + (<analyser> compile tag value) + + _ + (<analyser> compile tag (` [(~+ values)])))) + ([#.Nat structure.sum] + [#.Tag structure.tagged-sum]) + + (#.Tag tag) + (structure.tagged-sum compile tag (' [])) + + (^ (#.Tuple (list))) + primitive.unit + + (^ (#.Tuple (list singleton))) + (compile singleton) + + (^ (#.Tuple elems)) + (structure.product compile elems) + + (^ (#.Record pairs)) + (structure.record compile pairs) + + (#.Identifier reference) + (//reference.reference reference) + + (^ (#.Form (list [_ (#.Record branches)] input))) + (case.case compile input branches) + + (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) + (extension.apply "Analysis" compile [extension-name extension-args]) + + (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function-name])] + [_ (#.Identifier ["" arg-name])]))] + body))) + (function.function compile function-name arg-name body) + + (^ (#.Form (list& functionC argsC+))) + (do @ + [[functionT functionA] (type.with-inference + (compile functionC))] + (case functionA + (#//.Reference (#reference.Constant def-name)) + (do @ + [?macro (extension.lift (macro.find-macro def-name))] + (case ?macro + (#.Some macro) + (do @ + [expansion (extension.lift (//macro.expand-one def-name macro argsC+))] + (compile expansion)) + + _ + (function.apply compile functionT functionA argsC+))) + + _ + (function.apply compile functionT functionA argsC+))) + + _ + (///.throw unrecognized-syntax code) + ))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/function.lux b/stdlib/source/lux/tool/compiler/phase/analysis/function.lux new file mode 100644 index 000000000..cbea165f8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/function.lux @@ -0,0 +1,102 @@ +(.module: + [lux (#- function) + [control + monad + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + ["." text + format] + [collection + ["." list ("#/." fold monoid monad)]]] + ["." type + ["." check]] + ["." macro]] + ["." // (#+ Analysis Operation Phase) + ["." scope] + ["//." type] + ["." inference] + ["/." // + ["." extension]]]) + +(exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code}) + (ex.report ["Type" (%type expected)] + ["Function" function] + ["Argument" argument] + ["Body" (%code body)])) + +(exception: #export (cannot-apply {function Type} {arguments (List Code)}) + (ex.report ["Function" (%type function)] + ["Arguments" (|> arguments + list.enumerate + (list/map (.function (_ [idx argC]) + (format text.new-line " " (%n idx) " " (%code argC)))) + (text.join-with ""))])) + +(def: #export (function analyse function-name arg-name body) + (-> Phase Text Text Code (Operation Analysis)) + (do ///.monad + [functionT (extension.lift macro.expected-type)] + (loop [expectedT functionT] + (///.with-stack cannot-analyse [expectedT function-name arg-name body] + (case expectedT + (#.Named name unnamedT) + (recur unnamedT) + + (#.Apply argT funT) + (case (type.apply (list argT) funT) + (#.Some value) + (recur value) + + #.None + (///.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) + + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[_ instanceT] (//type.with-env <instancer>)] + (recur (maybe.assume (type.apply (list instanceT) expectedT))))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (recur expectedT') + + ## Inference + _ + (do @ + [[input-id inputT] (//type.with-env check.var) + [output-id outputT] (//type.with-env check.var) + #let [functionT (#.Function inputT outputT)] + functionA (recur functionT) + _ (//type.with-env + (check.check expectedT functionT))] + (wrap functionA)) + )) + + (#.Function inputT outputT) + (<| (:: @ map (.function (_ [scope bodyA]) + (#//.Function (scope.environment scope) bodyA))) + //.with-scope + ## Functions have access not only to their argument, but + ## also to themselves, through a local variable. + (scope.with-local [function-name expectedT]) + (scope.with-local [arg-name inputT]) + (//type.with-type outputT) + (analyse body)) + + _ + (///.fail "") + ))))) + +(def: #export (apply analyse functionT functionA argsC+) + (-> Phase Type Analysis (List Code) (Operation Analysis)) + (<| (///.with-stack cannot-apply [functionT argsC+]) + (do ///.monad + [[applyT argsA+] (inference.general analyse functionT argsC+)]) + (wrap (//.apply [functionA argsA+])))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/inference.lux b/stdlib/source/lux/tool/compiler/phase/analysis/inference.lux new file mode 100644 index 000000000..4ce9c6985 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/inference.lux @@ -0,0 +1,259 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + ["." text + format] + [collection + ["." list ("#/." functor)]]] + ["." type + ["." check]] + ["." macro]] + ["." /// ("#/." monad) + ["." extension]] + [// (#+ Tag Analysis Operation Phase)] + ["." //type]) + +(exception: #export (variant-tag-out-of-bounds {size Nat} {tag Tag} {type Type}) + (ex.report ["Tag" (%n tag)] + ["Variant size" (%i (.int size))] + ["Variant type" (%type type)])) + +(exception: #export (cannot-infer {type Type} {args (List Code)}) + (ex.report ["Type" (%type type)] + ["Arguments" (|> args + list.enumerate + (list/map (function (_ [idx argC]) + (format text.new-line " " (%n idx) " " (%code argC)))) + (text.join-with ""))])) + +(exception: #export (cannot-infer-argument {inferred Type} {argument Code}) + (ex.report ["Inferred Type" (%type inferred)] + ["Argument" (%code argument)])) + +(exception: #export (smaller-variant-than-expected {expected Nat} {actual Nat}) + (ex.report ["Expected" (%i (.int expected))] + ["Actual" (%i (.int actual))])) + +(do-template [<name>] + [(exception: #export (<name> {type Type}) + (%type type))] + + [not-a-variant-type] + [not-a-record-type] + [invalid-type-application] + ) + +(def: (replace parameter-idx replacement type) + (-> Nat Type Type Type) + (case type + (#.Primitive name params) + (#.Primitive name (list/map (replace parameter-idx replacement) params)) + + (^template [<tag>] + (<tag> left right) + (<tag> (replace parameter-idx replacement left) + (replace parameter-idx replacement right))) + ([#.Sum] + [#.Product] + [#.Function] + [#.Apply]) + + (#.Parameter idx) + (if (n/= parameter-idx idx) + replacement + type) + + (^template [<tag>] + (<tag> env quantified) + (<tag> (list/map (replace parameter-idx replacement) env) + (replace (n/+ 2 parameter-idx) replacement quantified))) + ([#.UnivQ] + [#.ExQ]) + + _ + type)) + +(def: (named-type cursor id) + (-> Cursor Nat Type) + (let [name (format "{New Type @ " (.cursor-description cursor) " " (%n id) "}")] + (#.Primitive name (list)))) + +(def: new-named-type + (Operation Type) + (do ///.monad + [cursor (extension.lift macro.cursor) + [ex-id _] (//type.with-env check.existential)] + (wrap (named-type cursor ex-id)))) + +## 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 treated +## as a function type, this method of inference should work. +(def: #export (general analyse inferT args) + (-> Phase Type (List Code) (Operation [Type (List Analysis)])) + (case args + #.Nil + (do ///.monad + [_ (//type.infer inferT)] + (wrap [inferT (list)])) + + (#.Cons argC args') + (case inferT + (#.Named name unnamedT) + (general analyse unnamedT args) + + (#.UnivQ _) + (do ///.monad + [[var-id varT] (//type.with-env check.var)] + (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) + + (#.ExQ _) + (do ///.monad + [[var-id varT] (//type.with-env check.var) + output (general analyse + (maybe.assume (type.apply (list varT) inferT)) + args) + bound? (//type.with-env + (check.bound? var-id)) + _ (if bound? + (wrap []) + (do @ + [newT new-named-type] + (//type.with-env + (check.check varT newT))))] + (wrap output)) + + (#.Apply inputT transT) + (case (type.apply (list inputT) transT) + (#.Some outputT) + (general analyse outputT args) + + #.None + (///.throw invalid-type-application inferT)) + + ## Arguments are inferred back-to-front because, by convention, + ## Lux functions take the most important arguments *last*, which + ## means that the most information for doing proper inference is + ## located in the last arguments to a function call. + ## By inferring back-to-front, a lot of type-annotations can be + ## avoided in Lux code, since the inference algorithm can piece + ## things together more easily. + (#.Function inputT outputT) + (do ///.monad + [[outputT' args'A] (general analyse outputT args') + argA (<| (///.with-stack cannot-infer-argument [inputT argC]) + (//type.with-type inputT) + (analyse argC))] + (wrap [outputT' (list& argA args'A)])) + + (#.Var infer-id) + (do ///.monad + [?inferT' (//type.with-env (check.read infer-id))] + (case ?inferT' + (#.Some inferT') + (general analyse inferT' args) + + _ + (///.throw cannot-infer [inferT args]))) + + _ + (///.throw cannot-infer [inferT args])) + )) + +## Turns a record type into the kind of function type suitable for inference. +(def: #export (record inferT) + (-> Type (Operation Type)) + (case inferT + (#.Named name unnamedT) + (record unnamedT) + + (^template [<tag>] + (<tag> env bodyT) + (do ///.monad + [bodyT+ (record bodyT)] + (wrap (<tag> env bodyT+)))) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (record outputT) + + #.None + (///.throw invalid-type-application inferT)) + + (#.Product _) + (////wrap (type.function (type.flatten-tuple inferT) inferT)) + + _ + (///.throw not-a-record-type inferT))) + +## Turns a variant type into the kind of function type suitable for inference. +(def: #export (variant tag expected-size inferT) + (-> Nat Nat Type (Operation Type)) + (loop [depth 0 + currentT inferT] + (case currentT + (#.Named name unnamedT) + (do ///.monad + [unnamedT+ (recur depth unnamedT)] + (wrap unnamedT+)) + + (^template [<tag>] + (<tag> env bodyT) + (do ///.monad + [bodyT+ (recur (inc depth) bodyT)] + (wrap (<tag> env bodyT+)))) + ([#.UnivQ] + [#.ExQ]) + + (#.Sum _) + (let [cases (type.flatten-variant currentT) + actual-size (list.size cases) + boundary (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) + (////wrap (if (n/= 0 depth) + (type.function (list caseT) currentT) + (let [replace' (replace (|> depth dec (n/* 2)) inferT)] + (type.function (list (replace' caseT)) + (replace' currentT))))) + + #.None + (///.throw variant-tag-out-of-bounds [expected-size tag inferT])) + + (n/< expected-size actual-size) + (///.throw smaller-variant-than-expected [expected-size actual-size]) + + (n/= boundary tag) + (let [caseT (type.variant (list.drop boundary cases))] + (////wrap (if (n/= 0 depth) + (type.function (list caseT) currentT) + (let [replace' (replace (|> depth dec (n/* 2)) inferT)] + (type.function (list (replace' caseT)) + (replace' currentT)))))) + + ## else + (///.throw variant-tag-out-of-bounds [expected-size tag inferT]))) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (variant tag expected-size outputT) + + #.None + (///.throw invalid-type-application inferT)) + + _ + (///.throw not-a-variant-type inferT)))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/macro.lux b/stdlib/source/lux/tool/compiler/phase/analysis/macro.lux new file mode 100644 index 000000000..18455b837 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/macro.lux @@ -0,0 +1,79 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." error (#+ Error)] + ["." text + format] + [collection + [array (#+ Array)] + ["." list ("#/." functor)]]] + ["." macro] + ["." host (#+ import:)]] + ["." ///]) + +(exception: #export (expansion-failed {macro Name} {inputs (List Code)} {error Text}) + (ex.report ["Macro" (%name macro)] + ["Inputs" (|> inputs + (list/map (|>> %code (format text.new-line text.tab))) + (text.join-with ""))] + ["Error" error])) + +(exception: #export (must-have-single-expansion {macro Name} {inputs (List Code)}) + (ex.report ["Macro" (%name macro)] + ["Inputs" (|> inputs + (list/map (|>> %code (format text.new-line text.tab))) + (text.join-with ""))])) + +(import: java/lang/reflect/Method + (invoke [Object (Array Object)] #try Object)) + +(import: (java/lang/Class c) + (getMethod [String (Array (Class Object))] #try Method)) + +(import: java/lang/Object + (getClass [] (Class Object))) + +(def: _object-class + (Class Object) + (host.class-for Object)) + +(def: _apply-args + (Array (Class Object)) + (|> (host.array (Class Object) 2) + (host.array-write 0 _object-class) + (host.array-write 1 _object-class))) + +(def: #export (expand name macro inputs) + (-> Name Macro (List Code) (Meta (List Code))) + (function (_ state) + (do error.monad + [apply-method (|> macro + (:coerce Object) + (Object::getClass) + (Class::getMethod "apply" _apply-args)) + output (Method::invoke (:coerce Object macro) + (|> (host.array Object 2) + (host.array-write 0 (:coerce Object inputs)) + (host.array-write 1 (:coerce Object state))) + apply-method)] + (case (:coerce (Error [Lux (List Code)]) + output) + (#error.Success output) + (#error.Success output) + + (#error.Failure error) + ((///.throw expansion-failed [name inputs error]) state))))) + +(def: #export (expand-one name macro inputs) + (-> Name Macro (List Code) (Meta Code)) + (do macro.monad + [expansion (expand name macro inputs)] + (case expansion + (^ (list single)) + (wrap single) + + _ + (///.throw must-have-single-expansion [name inputs])))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/module.lux b/stdlib/source/lux/tool/compiler/phase/analysis/module.lux new file mode 100644 index 000000000..29865f352 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/module.lux @@ -0,0 +1,255 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)] + pipe] + [data + ["." text ("#/." equivalence) + format] + ["." error] + [collection + ["." list ("#/." fold functor)] + [dictionary + ["." plist]]]] + ["." macro]] + ["." // (#+ Operation) + ["/." // + ["." extension]]]) + +(type: #export Tag Text) + +(exception: #export (unknown-module {module Text}) + (ex.report ["Module" module])) + +(exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) + (ex.report ["Module" module] + ["Tag" tag])) + +(do-template [<name>] + [(exception: #export (<name> {tags (List Text)} {owner Type}) + (ex.report ["Tags" (text.join-with " " tags)] + ["Type" (%type owner)]))] + + [cannot-declare-tags-for-unnamed-type] + [cannot-declare-tags-for-foreign-type] + ) + +(exception: #export (cannot-define-more-than-once {name Name}) + (ex.report ["Definition" (%name name)])) + +(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) + (ex.report ["Module" module] + ["Desired state" (case state + #.Active "Active" + #.Compiled "Compiled" + #.Cached "Cached")])) + +(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code}) + (ex.report ["Module" module] + ["Old annotations" (%code old)] + ["New annotations" (%code new)])) + +(def: #export (new hash) + (-> Nat Module) + {#.module-hash hash + #.module-aliases (list) + #.definitions (list) + #.imports (list) + #.tags (list) + #.types (list) + #.module-annotations #.None + #.module-state #.Active}) + +(def: #export (set-annotations annotations) + (-> Code (Operation Any)) + (do ///.monad + [self-name (extension.lift macro.current-module-name) + self (extension.lift macro.current-module)] + (case (get@ #.module-annotations self) + #.None + (extension.lift + (function (_ state) + (#error.Success [(update@ #.modules + (plist.put self-name (set@ #.module-annotations (#.Some annotations) self)) + state) + []]))) + + (#.Some old) + (///.throw cannot-set-module-annotations-more-than-once [self-name old annotations])))) + +(def: #export (import module) + (-> Text (Operation Any)) + (do ///.monad + [self-name (extension.lift macro.current-module-name)] + (extension.lift + (function (_ state) + (#error.Success [(update@ #.modules + (plist.update self-name (update@ #.imports (|>> (#.Cons module)))) + state) + []]))))) + +(def: #export (alias alias module) + (-> Text Text (Operation Any)) + (do ///.monad + [self-name (extension.lift macro.current-module-name)] + (extension.lift + (function (_ state) + (#error.Success [(update@ #.modules + (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text])) + (|>> (#.Cons [alias module]))))) + state) + []]))))) + +(def: #export (exists? module) + (-> Text (Operation Bit)) + (extension.lift + (function (_ state) + (|> state + (get@ #.modules) + (plist.get module) + (case> (#.Some _) #1 #.None #0) + [state] #error.Success)))) + +(def: #export (define name definition) + (-> Text Definition (Operation Any)) + (do ///.monad + [self-name (extension.lift macro.current-module-name) + self (extension.lift macro.current-module)] + (extension.lift + (function (_ state) + (case (plist.get name (get@ #.definitions self)) + #.None + (#error.Success [(update@ #.modules + (plist.put self-name + (update@ #.definitions + (: (-> (List [Text Definition]) (List [Text Definition])) + (|>> (#.Cons [name definition]))) + self)) + state) + []]) + + (#.Some already-existing) + ((///.throw cannot-define-more-than-once [self-name name]) state)))))) + +(def: #export (create hash name) + (-> Nat Text (Operation Any)) + (extension.lift + (function (_ state) + (let [module (new hash)] + (#error.Success [(update@ #.modules + (plist.put name module) + state) + []]))))) + +(def: #export (with-module hash name action) + (All [a] (-> Nat Text (Operation a) (Operation [Module a]))) + (do ///.monad + [_ (create hash name) + output (//.with-current-module name + action) + module (extension.lift (macro.find-module name))] + (wrap [module output]))) + +(do-template [<setter> <asker> <tag>] + [(def: #export (<setter> module-name) + (-> Text (Operation Any)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (let [active? (case (get@ #.module-state module) + #.Active #1 + _ #0)] + (if active? + (#error.Success [(update@ #.modules + (plist.put module-name (set@ #.module-state <tag> module)) + state) + []]) + ((///.throw can-only-change-state-of-active-module [module-name <tag>]) + state))) + + #.None + ((///.throw unknown-module module-name) state))))) + + (def: #export (<asker> module-name) + (-> Text (Operation Bit)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#error.Success [state + (case (get@ #.module-state module) + <tag> #1 + _ #0)]) + + #.None + ((///.throw unknown-module module-name) state)))))] + + [set-active active? #.Active] + [set-compiled compiled? #.Compiled] + [set-cached cached? #.Cached] + ) + +(do-template [<name> <tag> <type>] + [(def: (<name> module-name) + (-> Text (Operation <type>)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#error.Success [state (get@ <tag> module)]) + + #.None + ((///.throw unknown-module module-name) state)))))] + + [tags #.tags (List [Text [Nat (List Name) Bit Type]])] + [types #.types (List [Text [(List Name) Bit Type]])] + [hash #.module-hash Nat] + ) + +(def: (ensure-undeclared-tags module-name tags) + (-> Text (List Tag) (Operation Any)) + (do ///.monad + [bindings (..tags module-name) + _ (monad.map @ + (function (_ tag) + (case (plist.get tag bindings) + #.None + (wrap []) + + (#.Some _) + (///.throw cannot-declare-tag-twice [module-name tag]))) + tags)] + (wrap []))) + +(def: #export (declare-tags tags exported? type) + (-> (List Tag) Bit Type (Operation Any)) + (do ///.monad + [self-name (extension.lift macro.current-module-name) + [type-module type-name] (case type + (#.Named type-name _) + (wrap type-name) + + _ + (///.throw cannot-declare-tags-for-unnamed-type [tags type])) + _ (ensure-undeclared-tags self-name tags) + _ (///.assert cannot-declare-tags-for-foreign-type [tags type] + (text/= self-name type-module))] + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get self-name)) + (#.Some module) + (let [namespaced-tags (list/map (|>> [self-name]) tags)] + (#error.Success [(update@ #.modules + (plist.update self-name + (|>> (update@ #.tags (function (_ tag-bindings) + (list/fold (function (_ [idx tag] table) + (plist.put tag [idx namespaced-tags exported? type] table)) + tag-bindings + (list.enumerate tags)))) + (update@ #.types (plist.put type-name [namespaced-tags exported? type])))) + state) + []])) + #.None + ((///.throw unknown-module self-name) state)))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux b/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux new file mode 100644 index 000000000..b46983293 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux @@ -0,0 +1,29 @@ +(.module: + [lux (#- nat int rev) + [control + monad]] + ["." // (#+ Analysis Operation) + [".A" type] + ["/." //]]) + +## [Analysers] +(do-template [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (Operation Analysis)) + (do ///.monad + [_ (typeA.infer <type>)] + (wrap (#//.Primitive (<tag> value)))))] + + [bit Bit #//.Bit] + [nat Nat #//.Nat] + [int Int #//.Int] + [rev Rev #//.Rev] + [frac Frac #//.Frac] + [text Text #//.Text] + ) + +(def: #export unit + (Operation Analysis) + (do ///.monad + [_ (typeA.infer Any)] + (wrap (#//.Primitive #//.Unit)))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux b/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux new file mode 100644 index 000000000..5969b9f5c --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux @@ -0,0 +1,79 @@ +(.module: + [lux #* + [control + monad + ["ex" exception (#+ exception:)]] + ["." macro] + [data + ["." text ("#/." equivalence) + format]]] + ["." // (#+ Analysis Operation) + ["." scope] + ["." type] + ["/." // + ["." extension] + [// + ["." reference]]]]) + +(exception: #export (foreign-module-has-not-been-imported {current Text} {foreign Text}) + (ex.report ["Current" current] + ["Foreign" foreign])) + +(exception: #export (definition-has-not-been-expored {definition Name}) + (ex.report ["Definition" (%name definition)])) + +## [Analysers] +(def: (definition def-name) + (-> Name (Operation Analysis)) + (with-expansions [<return> (wrap (|> def-name reference.constant #//.Reference))] + (do ///.monad + [[actualT def-anns _] (extension.lift (macro.find-def def-name))] + (case (macro.get-identifier-ann (name-of #.alias) def-anns) + (#.Some real-def-name) + (definition real-def-name) + + _ + (do @ + [_ (type.infer actualT) + (^@ def-name [::module ::name]) (extension.lift (macro.normalize def-name)) + current (extension.lift macro.current-module-name)] + (if (text/= current ::module) + <return> + (if (macro.export? def-anns) + (do @ + [imported! (extension.lift (macro.imported-by? ::module current))] + (if imported! + <return> + (///.throw foreign-module-has-not-been-imported [current ::module]))) + (///.throw definition-has-not-been-expored def-name)))))))) + +(def: (variable var-name) + (-> Text (Operation (Maybe Analysis))) + (do ///.monad + [?var (scope.find var-name)] + (case ?var + (#.Some [actualT ref]) + (do @ + [_ (type.infer actualT)] + (wrap (#.Some (|> ref reference.variable #//.Reference)))) + + #.None + (wrap #.None)))) + +(def: #export (reference reference) + (-> Name (Operation Analysis)) + (case reference + ["" simple-name] + (do ///.monad + [?var (variable simple-name)] + (case ?var + (#.Some varA) + (wrap varA) + + #.None + (do @ + [this-module (extension.lift macro.current-module-name)] + (definition [this-module simple-name])))) + + _ + (definition reference))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/scope.lux b/stdlib/source/lux/tool/compiler/phase/analysis/scope.lux new file mode 100644 index 000000000..69d7c80a9 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/scope.lux @@ -0,0 +1,206 @@ +(.module: + [lux #* + [control + monad + ["ex" exception (#+ exception:)]] + [data + ["." text ("#/." equivalence) + format] + ["." maybe ("#/." monad)] + ["." product] + ["e" error] + [collection + ["." list ("#/." functor fold monoid)] + [dictionary + ["." plist]]]]] + [// (#+ Operation Phase) + ["/." // + ["." extension] + [// + ["." reference (#+ Register Variable)]]]]) + +(type: Local (Bindings Text [Type Register])) +(type: Foreign (Bindings Text [Type Variable])) + +(def: (local? name scope) + (-> Text Scope Bit) + (|> scope + (get@ [#.locals #.mappings]) + (plist.contains? name))) + +(def: (local name scope) + (-> Text Scope (Maybe [Type Variable])) + (|> scope + (get@ [#.locals #.mappings]) + (plist.get name) + (maybe/map (function (_ [type value]) + [type (#reference.Local value)])))) + +(def: (captured? name scope) + (-> Text Scope Bit) + (|> scope + (get@ [#.captured #.mappings]) + (plist.contains? name))) + +(def: (captured name scope) + (-> Text Scope (Maybe [Type Variable])) + (loop [idx 0 + mappings (get@ [#.captured #.mappings] scope)] + (case mappings + (#.Cons [_name [_source-type _source-ref]] mappings') + (if (text/= name _name) + (#.Some [_source-type (#reference.Foreign idx)]) + (recur (inc idx) mappings')) + + #.Nil + #.None))) + +(def: (reference? name scope) + (-> Text Scope Bit) + (or (local? name scope) + (captured? name scope))) + +(def: (reference name scope) + (-> Text Scope (Maybe [Type Variable])) + (case (..local name scope) + (#.Some type) + (#.Some type) + + _ + (..captured name scope))) + +(def: #export (find name) + (-> Text (Operation (Maybe [Type Variable]))) + (extension.lift + (function (_ state) + (let [[inner outer] (|> state + (get@ #.scopes) + (list.split-with (|>> (reference? name) not)))] + (case outer + #.Nil + (#.Right [state #.None]) + + (#.Cons top-outer _) + (let [[ref-type init-ref] (maybe.default (undefined) + (..reference name top-outer)) + [ref inner'] (list/fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)]) + (function (_ scope ref+inner) + [(#reference.Foreign (get@ [#.captured #.counter] scope)) + (#.Cons (update@ #.captured + (: (-> Foreign Foreign) + (|>> (update@ #.counter inc) + (update@ #.mappings (plist.put name [ref-type (product.left ref+inner)])))) + scope) + (product.right ref+inner))])) + [init-ref #.Nil] + (list.reverse inner)) + scopes (list/compose inner' outer)] + (#.Right [(set@ #.scopes scopes state) + (#.Some [ref-type ref])])) + ))))) + +(exception: #export (cannot-create-local-binding-without-a-scope) + "") + +(exception: #export (invalid-scope-alteration) + "") + +(def: #export (with-local [name type] action) + (All [a] (-> [Text Type] (Operation a) (Operation a))) + (function (_ [bundle state]) + (case (get@ #.scopes state) + (#.Cons head tail) + (let [old-mappings (get@ [#.locals #.mappings] head) + new-var-id (get@ [#.locals #.counter] head) + new-head (update@ #.locals + (: (-> Local Local) + (|>> (update@ #.counter inc) + (update@ #.mappings (plist.put name [type new-var-id])))) + head)] + (case (///.run' [bundle (set@ #.scopes (#.Cons new-head tail) state)] + action) + (#e.Success [[bundle' state'] output]) + (case (get@ #.scopes state') + (#.Cons head' tail') + (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head') + tail')] + (#e.Success [[bundle' (set@ #.scopes scopes' state')] + output])) + + _ + (ex.throw invalid-scope-alteration [])) + + (#e.Failure error) + (#e.Failure error))) + + _ + (ex.throw cannot-create-local-binding-without-a-scope [])) + )) + +(do-template [<name> <val-type>] + [(def: <name> + (Bindings Text [Type <val-type>]) + {#.counter 0 + #.mappings (list)})] + + [init-locals Nat] + [init-captured Variable] + ) + +(def: (scope parent-name child-name) + (-> (List Text) Text Scope) + {#.name (list& child-name parent-name) + #.inner 0 + #.locals init-locals + #.captured init-captured}) + +(def: #export (with-scope name action) + (All [a] (-> Text (Operation a) (Operation a))) + (function (_ [bundle state]) + (let [parent-name (case (get@ #.scopes state) + #.Nil + (list) + + (#.Cons top _) + (get@ #.name top))] + (case (action [bundle (update@ #.scopes + (|>> (#.Cons (scope parent-name name))) + state)]) + (#e.Success [[bundle' state'] output]) + (#e.Success [[bundle' (update@ #.scopes + (|>> list.tail (maybe.default (list))) + state')] + output]) + + (#e.Failure error) + (#e.Failure error))) + )) + +(exception: #export (cannot-get-next-reference-when-there-is-no-scope) + "") + +(def: #export next-local + (Operation Register) + (extension.lift + (function (_ state) + (case (get@ #.scopes state) + (#.Cons top _) + (#e.Success [state (get@ [#.locals #.counter] top)]) + + #.Nil + (ex.throw cannot-get-next-reference-when-there-is-no-scope []))))) + +(def: (ref-to-variable ref) + (-> Ref Variable) + (case ref + (#.Local register) + (#reference.Local register) + + (#.Captured register) + (#reference.Foreign register))) + +(def: #export (environment scope) + (-> Scope (List Variable)) + (|> scope + (get@ [#.captured #.mappings]) + (list/map (function (_ [_ [_ ref]]) (ref-to-variable ref))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux b/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux new file mode 100644 index 000000000..6991c67f7 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux @@ -0,0 +1,358 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)] + ["." state]] + [data + ["." name] + ["." number] + ["." product] + ["." maybe] + ["." error] + [text + format] + [collection + ["." list ("#/." functor)] + ["dict" dictionary (#+ Dictionary)]]] + ["." type + ["." check]] + ["." macro + ["." code]]] + ["." // (#+ Tag Analysis Operation Phase) + ["//." type] + ["." primitive] + ["." inference] + ["/." // + ["." extension]]]) + +(exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)])) + +(do-template [<name>] + [(exception: #export (<name> {type Type} {members (List Code)}) + (ex.report ["Type" (%type type)] + ["Expression" (%code (` [(~+ members)]))]))] + + [invalid-tuple-type] + [cannot-analyse-tuple] + ) + +(exception: #export (not-a-quantified-type {type Type}) + (%type type)) + +(do-template [<name>] + [(exception: #export (<name> {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)]))] + + [cannot-analyse-variant] + [cannot-infer-numeric-tag] + ) + +(exception: #export (record-keys-must-be-tags {key Code} {record (List [Code Code])}) + (ex.report ["Key" (%code key)] + ["Record" (%code (code.record record))])) + +(do-template [<name>] + [(exception: #export (<name> {key Name} {record (List [Name Code])}) + (ex.report ["Tag" (%code (code.tag key))] + ["Record" (%code (code.record (list/map (function (_ [keyI valC]) + [(code.tag keyI) valC]) + record)))]))] + + [cannot-repeat-tag] + ) + +(exception: #export (tag-does-not-belong-to-record {key Name} {type Type}) + (ex.report ["Tag" (%code (code.tag key))] + ["Type" (%type type)])) + +(exception: #export (record-size-mismatch {expected Nat} {actual Nat} {type Type} {record (List [Name Code])}) + (ex.report ["Expected" (|> expected .int %i)] + ["Actual" (|> actual .int %i)] + ["Type" (%type type)] + ["Expression" (%code (|> record + (list/map (function (_ [keyI valueC]) + [(code.tag keyI) valueC])) + code.record))])) + +(def: #export (sum analyse tag valueC) + (-> Phase Nat Code (Operation Analysis)) + (do ///.monad + [expectedT (extension.lift macro.expected-type)] + (///.with-stack cannot-analyse-variant [expectedT tag valueC] + (case expectedT + (#.Sum _) + (let [flat (type.flatten-variant expectedT) + type-size (list.size flat) + right? (n/= (dec type-size) + tag) + lefts (if right? + (dec tag) + tag)] + (case (list.nth tag flat) + (#.Some variant-type) + (do @ + [valueA (//type.with-type variant-type + (analyse valueC))] + (wrap (//.variant [lefts right? valueA]))) + + #.None + (///.throw inference.variant-tag-out-of-bounds [type-size tag expectedT]))) + + (#.Named name unnamedT) + (//type.with-type unnamedT + (sum analyse tag valueC)) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with-type expectedT' + (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 [expectedT tag valueC]) + )) + + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[instance-id instanceT] (//type.with-env <instancer>)] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (sum analyse tag valueC)))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (//type.with-env (check.read funT-id))] + (case ?funT' + (#.Some funT') + (//type.with-type (#.Apply inputT funT') + (sum analyse tag valueC)) + + _ + (///.throw invalid-variant-type [expectedT tag valueC]))) + + _ + (case (type.apply (list inputT) funT) + (#.Some outputT) + (//type.with-type outputT + (sum analyse tag valueC)) + + #.None + (///.throw not-a-quantified-type funT))) + + _ + (///.throw invalid-variant-type [expectedT tag valueC]))))) + +(def: (typed-product analyse members) + (-> Phase (List Code) (Operation Analysis)) + (do ///.monad + [expectedT (extension.lift macro.expected-type) + membersA+ (: (Operation (List Analysis)) + (loop [membersT+ (type.flatten-tuple expectedT) + membersC+ members] + (case [membersT+ membersC+] + [(#.Cons memberT #.Nil) _] + (//type.with-type memberT + (:: @ map (|>> list) (analyse (code.tuple membersC+)))) + + [_ (#.Cons memberC #.Nil)] + (//type.with-type (type.tuple membersT+) + (:: @ map (|>> list) (analyse memberC))) + + [(#.Cons memberT membersT+') (#.Cons memberC membersC+')] + (do @ + [memberA (//type.with-type memberT + (analyse memberC)) + memberA+ (recur membersT+' membersC+')] + (wrap (#.Cons memberA memberA+))) + + _ + (///.throw cannot-analyse-tuple [expectedT members]))))] + (wrap (//.tuple membersA+)))) + +(def: #export (product analyse membersC) + (-> Phase (List Code) (Operation Analysis)) + (do ///.monad + [expectedT (extension.lift macro.expected-type)] + (///.with-stack cannot-analyse-tuple [expectedT membersC] + (case expectedT + (#.Product _) + (..typed-product analyse membersC) + + (#.Named name unnamedT) + (//type.with-type unnamedT + (product analyse membersC)) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with-type expectedT' + (product analyse membersC)) + + _ + ## Must do inference... + (do @ + [membersTA (monad.map @ (|>> analyse //type.with-inference) + membersC) + _ (//type.with-env + (check.check expectedT + (type.tuple (list/map product.left membersTA))))] + (wrap (//.tuple (list/map product.right membersTA)))))) + + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[instance-id instanceT] (//type.with-env <instancer>)] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (product analyse membersC)))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (//type.with-env (check.read funT-id))] + (case ?funT' + (#.Some funT') + (//type.with-type (#.Apply inputT funT') + (product analyse membersC)) + + _ + (///.throw invalid-tuple-type [expectedT membersC]))) + + _ + (case (type.apply (list inputT) funT) + (#.Some outputT) + (//type.with-type outputT + (product analyse membersC)) + + #.None + (///.throw not-a-quantified-type funT))) + + _ + (///.throw invalid-tuple-type [expectedT membersC]) + )))) + +(def: #export (tagged-sum analyse tag valueC) + (-> Phase Name Code (Operation Analysis)) + (do ///.monad + [tag (extension.lift (macro.normalize tag)) + [idx group variantT] (extension.lift (macro.resolve-tag tag)) + expectedT (extension.lift macro.expected-type)] + (case expectedT + (#.Var _) + (do @ + [#let [case-size (list.size group)] + inferenceT (inference.variant idx case-size variantT) + [inferredT valueA+] (inference.general analyse inferenceT (list valueC)) + #let [right? (n/= (dec case-size) idx) + lefts (if right? + (dec idx) + idx)]] + (wrap (//.variant [lefts right? (|> valueA+ list.head maybe.assume)]))) + + _ + (..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]) (Operation (List [Name Code]))) + (monad.map ///.monad + (function (_ [key val]) + (case key + [_ (#.Tag key)] + (do ///.monad + [key (extension.lift (macro.normalize key))] + (wrap [key val])) + + _ + (///.throw record-keys-must-be-tags [key record]))) + 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 [Name Code]) (Operation [(List Code) Type])) + (case record + ## empty-record = empty-tuple = unit = [] + #.Nil + (:: ///.monad wrap [(list) Any]) + + (#.Cons [head-k head-v] _) + (do ///.monad + [head-k (extension.lift (macro.normalize head-k)) + [_ tag-set recordT] (extension.lift (macro.resolve-tag head-k)) + #let [size-record (list.size record) + size-ts (list.size tag-set)] + _ (if (n/= size-ts size-record) + (wrap []) + (///.throw record-size-mismatch [size-ts size-record recordT record])) + #let [tuple-range (list.indices size-ts) + tag->idx (dict.from-list name.hash (list.zip2 tag-set tuple-range))] + idx->val (monad.fold @ + (function (_ [key val] idx->val) + (do @ + [key (extension.lift (macro.normalize key))] + (case (dict.get key tag->idx) + (#.Some idx) + (if (dict.contains? idx idx->val) + (///.throw cannot-repeat-tag [key record]) + (wrap (dict.put idx val idx->val))) + + #.None + (///.throw tag-does-not-belong-to-record [key recordT])))) + (: (Dictionary Nat Code) + (dict.new number.hash)) + record) + #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) + tuple-range)]] + (wrap [ordered-tuple recordT])) + )) + +(def: #export (record analyse members) + (-> Phase (List [Code Code]) (Operation Analysis)) + (do ///.monad + [members (normalize members) + [membersC recordT] (order members)] + (case membersC + (^ (list)) + primitive.unit + + (^ (list singletonC)) + (analyse singletonC) + + _ + (do @ + [expectedT (extension.lift macro.expected-type)] + (case expectedT + (#.Var _) + (do @ + [inferenceT (inference.record recordT) + [inferredT membersA] (inference.general analyse inferenceT membersC)] + (wrap (//.tuple membersA))) + + _ + (..product analyse membersC)))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/type.lux b/stdlib/source/lux/tool/compiler/phase/analysis/type.lux new file mode 100644 index 000000000..75d691628 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/type.lux @@ -0,0 +1,52 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + ["." error]] + ["." function] + [type + ["tc" check]] + ["." macro]] + [// (#+ Operation) + ["/." // + ["." extension]]]) + +(def: #export (with-type expected) + (All [a] (-> Type (Operation a) (Operation a))) + (extension.localized (get@ #.expected) (set@ #.expected) + (function.constant (#.Some expected)))) + +(def: #export (with-env action) + (All [a] (-> (tc.Check a) (Operation a))) + (function (_ (^@ stateE [bundle state])) + (case (action (get@ #.type-context state)) + (#error.Success [context' output]) + (#error.Success [[bundle (set@ #.type-context context' state)] + output]) + + (#error.Failure error) + ((///.fail error) stateE)))) + +(def: #export with-fresh-env + (All [a] (-> (Operation a) (Operation a))) + (extension.localized (get@ #.type-context) (set@ #.type-context) + (function.constant tc.fresh-context))) + +(def: #export (infer actualT) + (-> Type (Operation Any)) + (do ///.monad + [expectedT (extension.lift macro.expected-type)] + (with-env + (tc.check expectedT actualT)))) + +(def: #export (with-inference action) + (All [a] (-> (Operation a) (Operation [Type a]))) + (do ///.monad + [[_ varT] (..with-env + tc.var) + output (with-type varT + action) + knownT (..with-env + (tc.clean varT))] + (wrap [knownT output]))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension.lux b/stdlib/source/lux/tool/compiler/phase/extension.lux new file mode 100644 index 000000000..0d58cf37a --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension.lux @@ -0,0 +1,140 @@ +(.module: + [lux (#- Name) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." error (#+ Error)] + ["." text ("#/." order) + format] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]] + ["." function]] + ["." //]) + +(type: #export Name Text) + +(type: #export (Extension i) + [Name (List i)]) + +(with-expansions [<Bundle> (as-is (Dictionary Name (Handler s i o)))] + (type: #export (Handler s i o) + (-> Name + (//.Phase [<Bundle> s] i o) + (//.Phase [<Bundle> s] (List i) o))) + + (type: #export (Bundle s i o) + <Bundle>)) + +(type: #export (State s i o) + {#bundle (Bundle s i o) + #state s}) + +(type: #export (Operation s i o v) + (//.Operation (State s i o) v)) + +(type: #export (Phase s i o) + (//.Phase (State s i o) i o)) + +(do-template [<name>] + [(exception: #export (<name> {name Name}) + (ex.report ["Extension" (%t name)]))] + + [cannot-overwrite] + [invalid-syntax] + ) + +(exception: #export [s i o] (unknown {where Text} {name Name} {bundle (Bundle s i o)}) + (ex.report ["Where" (%t where)] + ["Extension" (%t name)] + ["Available" (|> bundle + dictionary.keys + (list.sort text/<) + (list/map (|>> %t (format text.new-line text.tab))) + (text.join-with ""))])) + +(exception: #export (incorrect-arity {name Name} {arity Nat} {args Nat}) + (ex.report ["Extension" (%t name)] + ["Expected" (%n arity)] + ["Actual" (%n args)])) + +(def: #export (install name handler) + (All [s i o] + (-> Text (Handler s i o) (Operation s i o Any))) + (function (_ [bundle state]) + (case (dictionary.get name bundle) + #.None + (#error.Success [[(dictionary.put name handler bundle) state] + []]) + + _ + (ex.throw cannot-overwrite name)))) + +(def: #export (apply where phase [name parameters]) + (All [s i o] + (-> Text (Phase s i o) (Extension i) (Operation s i o o))) + (function (_ (^@ stateE [bundle state])) + (case (dictionary.get name bundle) + (#.Some handler) + (((handler name phase) parameters) + stateE) + + #.None + (ex.throw unknown [where name bundle])))) + +(def: #export (localized get set transform) + (All [s s' i o v] + (-> (-> s s') (-> s' s s) (-> s' s') + (-> (Operation s i o v) (Operation s i o v)))) + (function (_ operation) + (function (_ [bundle state]) + (let [old (get state)] + (case (operation [bundle (set (transform old) state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set old state')] output]) + + (#error.Failure error) + (#error.Failure error)))))) + +(def: #export (temporary transform) + (All [s i o v] + (-> (-> s s) + (-> (Operation s i o v) (Operation s i o v)))) + (function (_ operation) + (function (_ [bundle state]) + (case (operation [bundle (transform state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' state] output]) + + (#error.Failure error) + (#error.Failure error))))) + +(def: #export (with-state state) + (All [s i o v] + (-> s (-> (Operation s i o v) (Operation s i o v)))) + (..temporary (function.constant state))) + +(def: #export (read get) + (All [s i o v] + (-> (-> s v) (Operation s i o v))) + (function (_ [bundle state]) + (#error.Success [[bundle state] (get state)]))) + +(def: #export (update transform) + (All [s i o] + (-> (-> s s) (Operation s i o Any))) + (function (_ [bundle state]) + (#error.Success [[bundle (transform state)] []]))) + +(def: #export (lift action) + (All [s i o v] + (-> (//.Operation s v) + (//.Operation [(Bundle s i o) s] v))) + (function (_ [bundle state]) + (case (action state) + (#error.Success [state' output]) + (#error.Success [[bundle state'] output]) + + (#error.Failure error) + (#error.Failure error)))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux new file mode 100644 index 000000000..3b31f3d46 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux @@ -0,0 +1,18 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [/// + [analysis (#+ Bundle)] + [// + [default + [evaluation (#+ Eval)]]]] + [/ + ["." common] + ["." host]]) + +(def: #export (bundle eval) + (-> Eval Bundle) + (dictionary.merge host.bundle + (common.bundle eval))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux new file mode 100644 index 000000000..fa9b36270 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux @@ -0,0 +1,219 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)]] + [data + ["." text + format] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]] + [type + ["." check]] + ["." macro] + [io (#+ IO)]] + ["." /// + ["." bundle] + ["//." // + ["." analysis (#+ Analysis Handler Bundle) + [".A" type] + [".A" case] + [".A" function]] + [// + [default + [evaluation (#+ Eval)]]]]]) + +## [Utils] +(def: (simple inputsT+ outputT) + (-> (List Type) Type Handler) + (let [num-expected (list.size inputsT+)] + (function (_ extension-name analyse args) + (let [num-actual (list.size args)] + (if (n/= num-expected num-actual) + (do ////.monad + [_ (typeA.infer outputT) + argsA (monad.map @ + (function (_ [argT argC]) + (typeA.with-type argT + (analyse argC))) + (list.zip2 inputsT+ args))] + (wrap (#analysis.Extension extension-name argsA))) + (////.throw ///.incorrect-arity [extension-name num-expected num-actual])))))) + +(def: #export (nullary valueT) + (-> Type Handler) + (simple (list) valueT)) + +(def: #export (unary inputT outputT) + (-> Type Type Handler) + (simple (list inputT) outputT)) + +(def: #export (binary subjectT paramT outputT) + (-> Type Type Type Handler) + (simple (list subjectT paramT) outputT)) + +(def: #export (trinary subjectT param0T param1T outputT) + (-> Type Type Type Type Handler) + (simple (list subjectT param0T param1T) outputT)) + +## [Analysers] +## "lux is" represents reference/pointer equality. +(def: lux::is + Handler + (function (_ extension-name analyse args) + (do ////.monad + [[var-id varT] (typeA.with-env check.var)] + ((binary varT varT Bit extension-name) + analyse args)))) + +## "lux try" provides a simple way to interact with the host platform's +## error-handling facilities. +(def: lux::try + Handler + (function (_ extension-name analyse args) + (case args + (^ (list opC)) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + _ (typeA.infer (type (Either Text varT))) + opA (typeA.with-type (type (IO varT)) + (analyse opC))] + (wrap (#analysis.Extension extension-name (list opA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: lux::in-module + Handler + (function (_ extension-name analyse argsC+) + (case argsC+ + (^ (list [_ (#.Text module-name)] exprC)) + (analysis.with-current-module module-name + (analyse exprC)) + + _ + (////.throw ///.invalid-syntax [extension-name])))) + +(do-template [<name> <type>] + [(def: (<name> eval) + (-> Eval Handler) + (function (_ extension-name analyse args) + (case args + (^ (list typeC valueC)) + (do ////.monad + [count (///.lift macro.count) + actualT (:: @ map (|>> (:coerce Type)) + (eval count Type typeC)) + _ (typeA.infer actualT)] + (typeA.with-type <type> + (analyse valueC))) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))] + + [lux::check actualT] + [lux::coerce Any] + ) + +(def: lux::check::type + Handler + (function (_ extension-name analyse args) + (case args + (^ (list valueC)) + (do ////.monad + [_ (typeA.infer Type) + valueA (typeA.with-type Type + (analyse valueC))] + (wrap valueA)) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: (bundle::lux eval) + (-> Eval Bundle) + (|> bundle.empty + (bundle.install "is" lux::is) + (bundle.install "try" lux::try) + (bundle.install "check" (lux::check eval)) + (bundle.install "coerce" (lux::coerce eval)) + (bundle.install "check type" lux::check::type) + (bundle.install "in-module" lux::in-module))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary Text Any)) + (bundle.install "error" (unary Text Nothing)) + (bundle.install "exit" (unary Int Nothing)) + (bundle.install "current-time" (nullary Int))))) + +(def: I64* (type (I64 Any))) + +(def: bundle::i64 + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary I64* I64* I64)) + (bundle.install "or" (binary I64* I64* I64)) + (bundle.install "xor" (binary I64* I64* I64)) + (bundle.install "left-shift" (binary Nat I64* I64)) + (bundle.install "logical-right-shift" (binary Nat I64* I64)) + (bundle.install "arithmetic-right-shift" (binary Nat I64* I64)) + (bundle.install "+" (binary I64* I64* I64)) + (bundle.install "-" (binary I64* I64* I64)) + (bundle.install "=" (binary I64* I64* Bit))))) + +(def: bundle::int + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "*" (binary Int Int Int)) + (bundle.install "/" (binary Int Int Int)) + (bundle.install "%" (binary Int Int Int)) + (bundle.install "<" (binary Int Int Bit)) + (bundle.install "frac" (unary Int Frac)) + (bundle.install "char" (unary Int Text))))) + +(def: bundle::frac + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary Frac Frac Frac)) + (bundle.install "-" (binary Frac Frac Frac)) + (bundle.install "*" (binary Frac Frac Frac)) + (bundle.install "/" (binary Frac Frac Frac)) + (bundle.install "%" (binary Frac Frac Frac)) + (bundle.install "=" (binary Frac Frac Bit)) + (bundle.install "<" (binary Frac Frac Bit)) + (bundle.install "smallest" (nullary Frac)) + (bundle.install "min" (nullary Frac)) + (bundle.install "max" (nullary Frac)) + (bundle.install "int" (unary Frac Int)) + (bundle.install "encode" (unary Frac Text)) + (bundle.install "decode" (unary Text (type (Maybe Frac))))))) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary Text Text Bit)) + (bundle.install "<" (binary Text Text Bit)) + (bundle.install "concat" (binary Text Text Text)) + (bundle.install "index" (trinary Text Text Nat (type (Maybe Nat)))) + (bundle.install "size" (unary Text Nat)) + (bundle.install "char" (binary Text Nat Nat)) + (bundle.install "clip" (trinary Text Nat Nat Text)) + ))) + +(def: #export (bundle eval) + (-> Eval Bundle) + (<| (bundle.prefix "lux") + (|> bundle.empty + (dictionary.merge (bundle::lux eval)) + (dictionary.merge bundle::i64) + (dictionary.merge bundle::int) + (dictionary.merge bundle::frac) + (dictionary.merge bundle::text) + (dictionary.merge bundle::io) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux new file mode 100644 index 000000000..0654e79c4 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux @@ -0,0 +1,1271 @@ +(.module: + [lux (#- char int) + [control + ["." monad (#+ do)] + ["p" parser] + ["ex" exception (#+ exception:)] + pipe] + [data + ["." error (#+ Error)] + ["." maybe] + ["." product] + ["." text ("#/." equivalence) + format] + [collection + ["." list ("#/." fold functor monoid)] + ["." array (#+ Array)] + ["." dictionary (#+ Dictionary)]]] + ["." type + ["." check]] + ["." macro + ["s" syntax]] + ["." host (#+ import:)]] + [// + ["." common] + ["/." // + ["." bundle] + ["//." // ("#/." monad) + ["." analysis (#+ Analysis Operation Handler Bundle) + [".A" type] + [".A" inference]]]]] + ) + +(type: Method-Signature + {#method Type + #exceptions (List Type)}) + +(import: #long java/lang/reflect/Type + (getTypeName [] String)) + +(do-template [<name>] + [(exception: #export (<name> {jvm-type java/lang/reflect/Type}) + (ex.report ["JVM Type" (java/lang/reflect/Type::getTypeName jvm-type)]))] + + [jvm-type-is-not-a-class] + [cannot-convert-to-a-class] + [cannot-convert-to-a-parameter] + [cannot-convert-to-a-lux-type] + ) + +(do-template [<name>] + [(exception: #export (<name> {type Type}) + (%type type))] + + [non-object] + [non-array] + [non-jvm-type] + ) + +(do-template [<name>] + [(exception: #export (<name> {name Text}) + name)] + + [non-interface] + [non-throwable] + ) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [unknown-class] + [primitives-cannot-have-type-parameters] + [primitives-are-not-objects] + [invalid-type-for-array-element] + + [unknown-field] + [mistaken-field-owner] + [not-a-virtual-field] + [not-a-static-field] + [cannot-set-a-final-field] + + [cannot-cast] + + [cannot-possibly-be-an-instance] + + [unknown-type-var] + [type-parameter-mismatch] + [cannot-correspond-type-with-a-class] + ) + +(do-template [<name>] + [(exception: #export (<name> {class Text} + {method Text} + {hints (List Method-Signature)}) + (ex.report ["Class" class] + ["Method" method] + ["Hints" (|> hints + (list/map (|>> product.left %type (format text.new-line text.tab))) + (text.join-with ""))]))] + + [no-candidates] + [too-many-candidates] + ) + +(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: bundle::conversion + Bundle + (<| (bundle.prefix "convert") + (|> bundle.empty + (bundle.install "double-to-float" (common.unary Double Float)) + (bundle.install "double-to-int" (common.unary Double Integer)) + (bundle.install "double-to-long" (common.unary Double Long)) + (bundle.install "float-to-double" (common.unary Float Double)) + (bundle.install "float-to-int" (common.unary Float Integer)) + (bundle.install "float-to-long" (common.unary Float Long)) + (bundle.install "int-to-byte" (common.unary Integer Byte)) + (bundle.install "int-to-char" (common.unary Integer Character)) + (bundle.install "int-to-double" (common.unary Integer Double)) + (bundle.install "int-to-float" (common.unary Integer Float)) + (bundle.install "int-to-long" (common.unary Integer Long)) + (bundle.install "int-to-short" (common.unary Integer Short)) + (bundle.install "long-to-double" (common.unary Long Double)) + (bundle.install "long-to-float" (common.unary Long Float)) + (bundle.install "long-to-int" (common.unary Long Integer)) + (bundle.install "long-to-short" (common.unary Long Short)) + (bundle.install "long-to-byte" (common.unary Long Byte)) + (bundle.install "char-to-byte" (common.unary Character Byte)) + (bundle.install "char-to-short" (common.unary Character Short)) + (bundle.install "char-to-int" (common.unary Character Integer)) + (bundle.install "char-to-long" (common.unary Character Long)) + (bundle.install "byte-to-long" (common.unary Byte Long)) + (bundle.install "short-to-long" (common.unary Short Long)) + ))) + +(do-template [<name> <prefix> <type>] + [(def: <name> + Bundle + (<| (bundle.prefix <prefix>) + (|> bundle.empty + (bundle.install "+" (common.binary <type> <type> <type>)) + (bundle.install "-" (common.binary <type> <type> <type>)) + (bundle.install "*" (common.binary <type> <type> <type>)) + (bundle.install "/" (common.binary <type> <type> <type>)) + (bundle.install "%" (common.binary <type> <type> <type>)) + (bundle.install "=" (common.binary <type> <type> Bit)) + (bundle.install "<" (common.binary <type> <type> Bit)) + (bundle.install "and" (common.binary <type> <type> <type>)) + (bundle.install "or" (common.binary <type> <type> <type>)) + (bundle.install "xor" (common.binary <type> <type> <type>)) + (bundle.install "shl" (common.binary <type> Integer <type>)) + (bundle.install "shr" (common.binary <type> Integer <type>)) + (bundle.install "ushr" (common.binary <type> Integer <type>)) + )))] + + [bundle::int "int" Integer] + [bundle::long "long" Long] + ) + +(do-template [<name> <prefix> <type>] + [(def: <name> + Bundle + (<| (bundle.prefix <prefix>) + (|> bundle.empty + (bundle.install "+" (common.binary <type> <type> <type>)) + (bundle.install "-" (common.binary <type> <type> <type>)) + (bundle.install "*" (common.binary <type> <type> <type>)) + (bundle.install "/" (common.binary <type> <type> <type>)) + (bundle.install "%" (common.binary <type> <type> <type>)) + (bundle.install "=" (common.binary <type> <type> Bit)) + (bundle.install "<" (common.binary <type> <type> Bit)) + )))] + + [bundle::float "float" Float] + [bundle::double "double" Double] + ) + +(def: bundle::char + Bundle + (<| (bundle.prefix "char") + (|> bundle.empty + (bundle.install "=" (common.binary Character Character Bit)) + (bundle.install "<" (common.binary Character Character Bit)) + ))) + +(def: #export boxes + (Dictionary 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"]) + (dictionary.from-list text.hash))) + +(def: array::length + Handler + (function (_ extension-name analyse args) + (case args + (^ (list arrayC)) + (do ////.monad + [_ (typeA.infer Nat) + [var-id varT] (typeA.with-env check.var) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC))] + (wrap (#analysis.Extension extension-name (list arrayA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: array::new + Handler + (function (_ extension-name analyse args) + (case args + (^ (list lengthC)) + (do ////.monad + [lengthA (typeA.with-type Nat + (analyse lengthC)) + expectedT (///.lift macro.expected-type) + [level elem-class] (: (Operation [Nat Text]) + (loop [analysisT expectedT + level 0] + (case analysisT + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur outputT level) + + #.None + (////.throw non-array expectedT)) + + (^ (#.Primitive "#Array" (list elemT))) + (recur elemT (inc level)) + + (#.Primitive class _) + (wrap [level class]) + + _ + (////.throw non-array expectedT)))) + _ (if (n/> 0 level) + (wrap []) + (////.throw non-array expectedT))] + (wrap (#analysis.Extension extension-name (list (analysis.nat (dec level)) + (analysis.text elem-class) + lengthA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: (check-jvm objectT) + (-> Type (Operation Text)) + (case objectT + (#.Primitive name _) + (/////wrap name) + + (#.Named name unnamed) + (check-jvm unnamed) + + (#.Var id) + (/////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 non-object objectT)) + + _ + (////.throw non-object objectT))) + +(def: (check-object objectT) + (-> Type (Operation Text)) + (do ////.monad + [name (check-jvm objectT)] + (if (dictionary.contains? name boxes) + (////.throw primitives-are-not-objects name) + (/////wrap name)))) + +(def: (box-array-element-type elemT) + (-> Type (Operation [Type Text])) + (case elemT + (#.Primitive name #.Nil) + (let [boxed-name (|> (dictionary.get name boxes) + (maybe.default name))] + (/////wrap [(#.Primitive boxed-name #.Nil) + boxed-name])) + + (#.Primitive name _) + (if (dictionary.contains? name boxes) + (////.throw primitives-cannot-have-type-parameters name) + (/////wrap [elemT name])) + + _ + (////.throw invalid-type-for-array-element (%type elemT)))) + +(def: array::read + Handler + (function (_ extension-name analyse args) + (case args + (^ (list arrayC idxC)) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + _ (typeA.infer varT) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (check.read var-id)) + [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC))] + (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA arrayA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: array::write + Handler + (function (_ extension-name analyse args) + (case args + (^ (list arrayC idxC valueC)) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + _ (typeA.infer (type (Array varT))) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (check.read var-id)) + [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC)) + valueA (typeA.with-type valueT + (analyse valueC))] + (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA valueA arrayA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "length" array::length) + (bundle.install "new" array::new) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + ))) + +(def: object::null + Handler + (function (_ extension-name analyse args) + (case args + (^ (list)) + (do ////.monad + [expectedT (///.lift macro.expected-type) + _ (check-object expectedT)] + (wrap (#analysis.Extension extension-name (list)))) + + _ + (////.throw ///.incorrect-arity [extension-name 0 (list.size args)])))) + +(def: object::null? + Handler + (function (_ extension-name analyse args) + (case args + (^ (list objectC)) + (do ////.monad + [_ (typeA.infer Bit) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (check-object objectT)] + (wrap (#analysis.Extension extension-name (list objectA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: object::synchronized + Handler + (function (_ extension-name analyse args) + (case args + (^ (list monitorC exprC)) + (do ////.monad + [[monitorT monitorA] (typeA.with-inference + (analyse monitorC)) + _ (check-object monitorT) + exprA (analyse exprC)] + (wrap (#analysis.Extension extension-name (list monitorA exprA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(import: java/lang/Object + (equals [Object] boolean)) + +(import: java/lang/ClassLoader) + +(import: java/lang/reflect/GenericArrayType + (getGenericComponentType [] java/lang/reflect/Type)) + +(import: java/lang/reflect/ParameterizedType + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] (Array java/lang/reflect/Type))) + +(import: (java/lang/reflect/TypeVariable d) + (getName [] String) + (getBounds [] (Array java/lang/reflect/Type))) + +(import: (java/lang/reflect/WildcardType d) + (getLowerBounds [] (Array java/lang/reflect/Type)) + (getUpperBounds [] (Array java/lang/reflect/Type))) + +(import: java/lang/reflect/Modifier + (#static isStatic [int] boolean) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)) + +(import: java/lang/reflect/Field + (getDeclaringClass [] (java/lang/Class Object)) + (getModifiers [] int) + (getGenericType [] java/lang/reflect/Type)) + +(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))) + +(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))) + +(import: (java/lang/Class c) + (getName [] String) + (getModifiers [] int) + (#static forName [String] #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 (Operation (Class Object))) + (do ////.monad + [] + (case (Class::forName name) + (#error.Success [class]) + (wrap class) + + (#error.Failure error) + (////.throw unknown-class name)))) + +(def: (sub-class? super sub) + (-> Text Text (Operation Bit)) + (do ////.monad + [super (load-class super) + sub (load-class sub)] + (wrap (Class::isAssignableFrom sub super)))) + +(def: object::throw + Handler + (function (_ extension-name analyse args) + (case args + (^ (list exceptionC)) + (do ////.monad + [_ (typeA.infer Nothing) + [exceptionT exceptionA] (typeA.with-inference + (analyse exceptionC)) + exception-class (check-object exceptionT) + ? (sub-class? "java.lang.Throwable" exception-class) + _ (: (Operation Any) + (if ? + (wrap []) + (////.throw non-throwable exception-class)))] + (wrap (#analysis.Extension extension-name (list exceptionA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: object::class + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC)) + (case classC + [_ (#.Text class)] + (do ////.monad + [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) + _ (load-class class)] + (wrap (#analysis.Extension extension-name (list (analysis.text class))))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: object::instance? + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC objectC)) + (case classC + [_ (#.Text class)] + (do ////.monad + [_ (typeA.infer Bit) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + object-class (check-object objectT) + ? (sub-class? class object-class)] + (if ? + (wrap (#analysis.Extension extension-name (list (analysis.text class)))) + (////.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: (java-type-to-class jvm-type) + (-> java/lang/reflect/Type (Operation Text)) + (cond (host.instance? Class jvm-type) + (/////wrap (Class::getName (:coerce Class jvm-type))) + + (host.instance? ParameterizedType jvm-type) + (java-type-to-class (ParameterizedType::getRawType (:coerce ParameterizedType jvm-type))) + + ## else + (////.throw cannot-convert-to-a-class jvm-type))) + +(type: Mappings + (Dictionary Text Type)) + +(def: fresh-mappings Mappings (dictionary.new text.hash)) + +(def: (java-type-to-lux-type mappings java-type) + (-> Mappings java/lang/reflect/Type (Operation Type)) + (cond (host.instance? TypeVariable java-type) + (let [var-name (TypeVariable::getName (:coerce TypeVariable java-type))] + (case (dictionary.get var-name mappings) + (#.Some var-type) + (/////wrap var-type) + + #.None + (////.throw unknown-type-var var-name))) + + (host.instance? WildcardType java-type) + (let [java-type (:coerce 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) + + _ + (/////wrap Any))) + + (host.instance? Class java-type) + (let [java-type (:coerce (Class Object) java-type) + class-name (Class::getName java-type)] + (/////wrap (case (array.size (Class::getTypeParameters java-type)) + 0 + (#.Primitive class-name (list)) + + arity + (|> (list.indices arity) + list.reverse + (list/map (|>> (n/* 2) inc #.Parameter)) + (#.Primitive class-name) + (type.univ-q arity))))) + + (host.instance? ParameterizedType java-type) + (let [java-type (:coerce ParameterizedType java-type) + raw (ParameterizedType::getRawType java-type)] + (if (host.instance? Class raw) + (do ////.monad + [paramsT (|> java-type + ParameterizedType::getActualTypeArguments + array.to-list + (monad.map @ (java-type-to-lux-type mappings)))] + (/////wrap (#.Primitive (Class::getName (:coerce (Class Object) raw)) + paramsT))) + (////.throw jvm-type-is-not-a-class raw))) + + (host.instance? GenericArrayType java-type) + (do ////.monad + [innerT (|> (:coerce GenericArrayType java-type) + GenericArrayType::getGenericComponentType + (java-type-to-lux-type mappings))] + (wrap (#.Primitive "#Array" (list innerT)))) + + ## else + (////.throw cannot-convert-to-a-lux-type java-type))) + +(def: (correspond-type-params class type) + (-> (Class Object) Type (Operation Mappings)) + (case type + (#.Primitive name params) + (let [class-name (Class::getName class) + class-params (array.to-list (Class::getTypeParameters class)) + num-class-params (list.size class-params) + num-type-params (list.size params)] + (cond (not (text/= class-name name)) + (////.throw cannot-correspond-type-with-a-class + (format "Class = " class-name text.new-line + "Type = " (%type type))) + + (not (n/= num-class-params num-type-params)) + (////.throw type-parameter-mismatch + (format "Expected: " (%i (.int num-class-params)) text.new-line + " Actual: " (%i (.int num-type-params)) text.new-line + " Class: " class-name text.new-line + " Type: " (%type type))) + + ## else + (/////wrap (|> params + (list.zip2 (list/map (|>> TypeVariable::getName) class-params)) + (dictionary.from-list text.hash))) + )) + + _ + (////.throw non-jvm-type type))) + +(def: object::cast + Handler + (function (_ extension-name analyse args) + (case args + (^ (list valueC)) + (do ////.monad + [toT (///.lift macro.expected-type) + to-name (check-jvm toT) + [valueT valueA] (typeA.with-inference + (analyse valueC)) + from-name (check-jvm valueT) + can-cast? (: (Operation Bit) + (case [from-name to-name] + (^template [<primitive> <object>] + (^or [<primitive> <object>] + [<object> <primitive>]) + (do @ + [_ (typeA.infer (#.Primitive to-name (list)))] + (wrap #1))) + (["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"]) + + _ + (do @ + [_ (////.assert primitives-are-not-objects from-name + (not (dictionary.contains? from-name boxes))) + _ (////.assert primitives-are-not-objects to-name + (not (dictionary.contains? to-name boxes))) + to-class (load-class to-name)] + (loop [[current-name currentT] [from-name valueT]] + (if (text/= to-name current-name) + (do @ + [_ (typeA.infer toT)] + (wrap #1)) + (do @ + [current-class (load-class current-name) + _ (////.assert cannot-cast (format "From class/primitive: " current-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line) + (Class::isAssignableFrom current-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 [[class-name java-type] (Class::isAssignableFrom class to-class)]))) + (list& (Class::getGenericSuperclass current-class) + (array.to-list (Class::getGenericInterfaces current-class))))] + (case (|> candiate-parents + (list.filter product.right) + (list/map product.left)) + (#.Cons [next-name nextJT] _) + (do @ + [mapping (correspond-type-params current-class currentT) + nextT (java-type-to-lux-type mapping nextJT)] + (recur [next-name nextT])) + + #.Nil + (////.throw cannot-cast (format "From class/primitive: " from-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line))) + ))))))] + (if can-cast? + (wrap (#analysis.Extension extension-name (list (analysis.text from-name) + (analysis.text to-name) + valueA))) + (////.throw cannot-cast (format "From class/primitive: " from-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line)))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "null" object::null) + (bundle.install "null?" object::null?) + (bundle.install "synchronized" object::synchronized) + (bundle.install "throw" object::throw) + (bundle.install "class" object::class) + (bundle.install "instance?" object::instance?) + (bundle.install "cast" object::cast) + ))) + +(def: (find-field class-name field-name) + (-> Text Text (Operation [(Class Object) Field])) + (do ////.monad + [class (load-class class-name)] + (case (Class::getDeclaredField field-name class) + (#error.Success field) + (let [owner (Field::getDeclaringClass field)] + (if (is? owner class) + (wrap [class field]) + (////.throw mistaken-field-owner + (format " Field: " field-name text.new-line + " Owner Class: " (Class::getName owner) text.new-line + "Target Class: " class-name text.new-line)))) + + (#error.Failure _) + (////.throw unknown-field (format class-name "#" field-name))))) + +(def: (static-field class-name field-name) + (-> Text Text (Operation [Type Bit])) + (do ////.monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field::getModifiers fieldJ)]] + (if (Modifier::isStatic modifiers) + (let [fieldJT (Field::getGenericType fieldJ)] + (do @ + [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal modifiers)]))) + (////.throw not-a-static-field (format class-name "#" field-name))))) + +(def: (virtual-field class-name field-name objectT) + (-> Text Text Type (Operation [Type Bit])) + (do ////.monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field::getModifiers fieldJ)]] + (if (not (Modifier::isStatic modifiers)) + (do @ + [#let [fieldJT (Field::getGenericType fieldJ) + var-names (|> class + Class::getTypeParameters + array.to-list + (list/map (|>> TypeVariable::getName)))] + mappings (: (Operation Mappings) + (case objectT + (#.Primitive _class-name _class-params) + (do @ + [#let [num-params (list.size _class-params) + num-vars (list.size var-names)] + _ (////.assert type-parameter-mismatch + (format "Expected: " (%i (.int num-params)) text.new-line + " Actual: " (%i (.int num-vars)) text.new-line + " Class: " _class-name text.new-line + " Type: " (%type objectT)) + (n/= num-params num-vars))] + (wrap (|> (list.zip2 var-names _class-params) + (dictionary.from-list text.hash)))) + + _ + (////.throw non-object objectT))) + fieldT (java-type-to-lux-type mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal modifiers)])) + (////.throw not-a-virtual-field (format class-name "#" field-name))))) + +(def: static::get + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [[fieldT final?] (static-field class field)] + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field))))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: static::put + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC valueC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [_ (typeA.infer Any) + [fieldT final?] (static-field class field) + _ (////.assert cannot-set-a-final-field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA)))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + +(def: virtual::get + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + [fieldT final?] (virtual-field class field objectT)] + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) objectA)))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + +(def: virtual::put + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC valueC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (typeA.infer objectT) + [fieldT final?] (virtual-field class field objectT) + _ (////.assert cannot-set-a-final-field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA objectA)))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 4 (list.size args)])))) + +(def: (java-type-to-parameter type) + (-> java/lang/reflect/Type (Operation Text)) + (cond (host.instance? Class type) + (/////wrap (Class::getName (:coerce Class type))) + + (host.instance? ParameterizedType type) + (java-type-to-parameter (ParameterizedType::getRawType (:coerce ParameterizedType type))) + + (or (host.instance? TypeVariable type) + (host.instance? WildcardType type)) + (/////wrap "java.lang.Object") + + (host.instance? GenericArrayType type) + (do ////.monad + [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType (:coerce GenericArrayType type)))] + (wrap (format componentP "[]"))) + + ## else + (////.throw cannot-convert-to-a-parameter type))) + +(type: Method-Style + #Static + #Abstract + #Virtual + #Special + #Interface) + +(def: (check-method class method-name method-style arg-classes method) + (-> (Class Object) Text Method-Style (List Text) Method (Operation Bit)) + (do ////.monad + [parameters (|> (Method::getGenericParameterTypes method) + array.to-list + (monad.map @ java-type-to-parameter)) + #let [modifiers (Method::getModifiers method)]] + (wrap (and (Object::equals class (Method::getDeclaringClass method)) + (text/= method-name (Method::getName method)) + (case #Static + #Special + (Modifier::isStatic modifiers) + + _ + #1) + (case method-style + #Special + (not (or (Modifier::isInterface (Class::getModifiers class)) + (Modifier::isAbstract modifiers))) + + _ + #1) + (n/= (list.size arg-classes) (list.size parameters)) + (list/fold (function (_ [expectedJC actualJC] prev) + (and prev + (text/= expectedJC actualJC))) + #1 + (list.zip2 arg-classes parameters)))))) + +(def: (check-constructor class arg-classes constructor) + (-> (Class Object) (List Text) (Constructor Object) (Operation Bit)) + (do ////.monad + [parameters (|> (Constructor::getGenericParameterTypes constructor) + array.to-list + (monad.map @ java-type-to-parameter))] + (wrap (and (Object::equals class (Constructor::getDeclaringClass constructor)) + (n/= (list.size arg-classes) (list.size parameters)) + (list/fold (function (_ [expectedJC actualJC] prev) + (and prev + (text/= expectedJC actualJC))) + #1 + (list.zip2 arg-classes parameters)))))) + +(def: idx-to-parameter + (-> Nat Type) + (|>> (n/* 2) inc #.Parameter)) + +(def: (type-vars amount offset) + (-> Nat Nat (List Type)) + (if (n/= 0 amount) + (list) + (|> (list.indices amount) + (list/map (|>> (n/+ offset) idx-to-parameter))))) + +(def: (method-signature method-style method) + (-> Method-Style Method (Operation Method-Signature)) + (let [owner (Method::getDeclaringClass method) + owner-name (Class::getName owner) + owner-tvars (case method-style + #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) + (dictionary.from-list text.hash))))] + (do ////.monad + [inputsT (|> (Method::getGenericParameterTypes method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + outputT (java-type-to-lux-type mappings (Method::getGenericReturnType method)) + exceptionsT (|> (Method::getGenericExceptionTypes method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [methodT (<| (type.univ-q num-all-tvars) + (type.function (case method-style + #Static + inputsT + + _ + (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) + inputsT))) + outputT)]] + (wrap [methodT exceptionsT])))) + +(type: Evaluation + (#Pass Method-Signature) + (#Hint Method-Signature) + #Fail) + +(do-template [<name> <tag>] + [(def: <name> + (-> Evaluation (Maybe Method-Signature)) + (|>> (case> (<tag> output) + (#.Some output) + + _ + #.None)))] + + [pass! #Pass] + [hint! #Hint] + ) + +(def: (method-candidate class-name method-name method-style arg-classes) + (-> Text Text Method-Style (List Text) (Operation Method-Signature)) + (do ////.monad + [class (load-class class-name) + candidates (|> class + Class::getDeclaredMethods + array.to-list + (monad.map @ (: (-> Method (Operation Evaluation)) + (function (_ method) + (do @ + [passes? (check-method class method-name method-style arg-classes method)] + (cond passes? + (:: @ map (|>> #Pass) (method-signature method-style method)) + + (text/= method-name (Method::getName method)) + (:: @ map (|>> #Hint) (method-signature method-style method)) + + ## else + (wrap #Fail)))))))] + (case (list.search-all pass! candidates) + (#.Cons method #.Nil) + (wrap method) + + #.Nil + (////.throw no-candidates [class-name method-name (list.search-all hint! candidates)]) + + candidates + (////.throw too-many-candidates [class-name method-name candidates])))) + +(def: (constructor-signature constructor) + (-> (Constructor Object) (Operation Method-Signature)) + (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) + (dictionary.from-list text.hash))))] + (do ////.monad + [inputsT (|> (Constructor::getGenericParameterTypes constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + exceptionsT (|> (Constructor::getGenericExceptionTypes constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) + constructorT (<| (type.univ-q num-all-tvars) + (type.function inputsT) + objectT)]] + (wrap [constructorT exceptionsT])))) + +(def: constructor-method "<init>") + +(def: (constructor-candidate class-name arg-classes) + (-> Text (List Text) (Operation Method-Signature)) + (do ////.monad + [class (load-class class-name) + candidates (|> class + Class::getConstructors + array.to-list + (monad.map @ (function (_ constructor) + (do @ + [passes? (check-constructor class arg-classes constructor)] + (:: @ map + (if passes? (|>> #Pass) (|>> #Hint)) + (constructor-signature constructor))))))] + (case (list.search-all pass! candidates) + (#.Cons constructor #.Nil) + (wrap constructor) + + #.Nil + (////.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)]) + + candidates + (////.throw too-many-candidates [class-name ..constructor-method candidates])))) + +(def: (decorate-inputs typesT inputsA) + (-> (List Text) (List Analysis) (List Analysis)) + (|> inputsA + (list.zip2 (list/map analysis.text typesT)) + (list/map (function (_ [type value]) + (analysis.tuple (list type value)))))) + +(def: invoke::static + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text Text (List [Text Code])]) + (s.run args ($_ p.and s.text s.text (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class method argsTC]) + (do ////.monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Static argsT) + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) + outputJC (check-jvm outputT)] + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: invoke::virtual + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class method objectC argsTC]) + (do ////.monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Virtual argsT) + [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + #let [[objectA argsA] (case allA + (#.Cons objectA argsA) + [objectA argsA] + + _ + (undefined))] + outputJC (check-jvm outputT)] + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) objectA (decorate-inputs argsT argsA))))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: invoke::special + Handler + (function (_ extension-name analyse args) + (case (: (Error [(List Code) [Text Text Code (List [Text Code]) Any]]) + (p.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))) s.end!))) + (#error.Success [_ [class method objectC argsTC _]]) + (do ////.monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Special argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: invoke::interface + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class-name method objectC argsTC]) + (do ////.monad + [#let [argsT (list/map product.left argsTC)] + class (load-class class-name) + _ (////.assert non-interface class-name + (Modifier::isInterface (Class::getModifiers class))) + [methodT exceptionsT] (method-candidate class-name method #Interface argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#analysis.Extension extension-name + (list& (analysis.text class-name) (analysis.text method) (analysis.text outputJC) + (decorate-inputs argsT argsA))))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: invoke::constructor + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text (List [Text Code])]) + (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class argsTC]) + (do ////.monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (constructor-candidate class argsT) + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (decorate-inputs argsT argsA))))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: bundle::member + Bundle + (<| (bundle.prefix "member") + (|> bundle.empty + (dictionary.merge (<| (bundle.prefix "static") + (|> bundle.empty + (bundle.install "get" static::get) + (bundle.install "put" static::put)))) + (dictionary.merge (<| (bundle.prefix "virtual") + (|> bundle.empty + (bundle.install "get" virtual::get) + (bundle.install "put" virtual::put)))) + (dictionary.merge (<| (bundle.prefix "invoke") + (|> bundle.empty + (bundle.install "static" invoke::static) + (bundle.install "virtual" invoke::virtual) + (bundle.install "special" invoke::special) + (bundle.install "interface" invoke::interface) + (bundle.install "constructor" invoke::constructor) + ))) + ))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "jvm") + (|> bundle.empty + (dictionary.merge bundle::conversion) + (dictionary.merge bundle::int) + (dictionary.merge bundle::long) + (dictionary.merge bundle::float) + (dictionary.merge bundle::double) + (dictionary.merge bundle::char) + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + (dictionary.merge bundle::member) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/bundle.lux b/stdlib/source/lux/tool/compiler/phase/extension/bundle.lux new file mode 100644 index 000000000..643e3b38c --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/bundle.lux @@ -0,0 +1,28 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + ["." text + format] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]]] + [// (#+ Handler Bundle)]) + +(def: #export empty + Bundle + (dictionary.new text.hash)) + +(def: #export (install name anonymous) + (All [s i o] + (-> Text (Handler s i o) + (-> (Bundle s i o) (Bundle s i o)))) + (dictionary.put name anonymous)) + +(def: #export (prefix prefix) + (All [s i o] + (-> Text (-> (Bundle s i o) (Bundle s i o)))) + (|>> dictionary.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dictionary.from-list text.hash))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux new file mode 100644 index 000000000..c5ae87050 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux @@ -0,0 +1,199 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + pipe] + [data + [text + format] + [collection + ["." list ("#/." functor)] + ["." dictionary]]] + ["." macro] + [type (#+ :share) + ["." check]]] + ["." // + ["." bundle] + ["/." // + ["." analysis + ["." module] + ["." type]] + ["." synthesis] + ["." translation] + ["." statement (#+ Operation Handler Bundle)]]]) + +(def: (evaluate! type codeC) + (All [anchor expression statement] + (-> Type Code (Operation anchor expression statement [Type expression Any]))) + (do ///.monad + [state (//.lift ///.get-state) + #let [analyse (get@ [#statement.analysis #statement.phase] state) + synthesize (get@ [#statement.synthesis #statement.phase] state) + translate (get@ [#statement.translation #statement.phase] state)] + [_ code//type codeA] (statement.lift-analysis + (analysis.with-scope + (type.with-fresh-env + (type.with-type type + (do @ + [codeA (analyse codeC)] + (wrap [type codeA])))))) + codeS (statement.lift-synthesis + (synthesize codeA))] + (statement.lift-translation + (translation.with-buffer + (do @ + [codeT (translate codeS) + count translation.next + codeV (translation.evaluate! (format "evaluate" (%n count)) codeT)] + (wrap [code//type codeT codeV])))))) + +(def: (define! name ?type codeC) + (All [anchor expression statement] + (-> Name (Maybe Type) Code + (Operation anchor expression statement [Type expression Text Any]))) + (do ///.monad + [state (//.lift ///.get-state) + #let [analyse (get@ [#statement.analysis #statement.phase] state) + synthesize (get@ [#statement.synthesis #statement.phase] state) + translate (get@ [#statement.translation #statement.phase] state)] + [_ code//type codeA] (statement.lift-analysis + (analysis.with-scope + (type.with-fresh-env + (case ?type + (#.Some type) + (type.with-type type + (do @ + [codeA (analyse codeC)] + (wrap [type codeA]))) + + #.None + (do @ + [[code//type codeA] (type.with-inference (analyse codeC)) + code//type (type.with-env + (check.clean code//type))] + (wrap [code//type codeA])))))) + codeS (statement.lift-synthesis + (synthesize codeA))] + (statement.lift-translation + (translation.with-buffer + (do @ + [codeT (translate codeS) + codeN+V (translation.define! name codeT)] + (wrap [code//type codeT codeN+V])))))) + +(def: lux::def + Handler + (function (_ extension-name phase inputsC+) + (case inputsC+ + (^ (list [_ (#.Identifier ["" short-name])] valueC annotationsC)) + (do ///.monad + [current-module (statement.lift-analysis + (//.lift macro.current-module-name)) + #let [full-name [current-module short-name]] + [_ annotationsT annotationsV] (evaluate! Code annotationsC) + #let [annotationsV (:coerce Code annotationsV)] + [value//type valueT valueN valueV] (define! full-name + (if (macro.type? annotationsV) + (#.Some Type) + #.None) + valueC) + _ (statement.lift-analysis + (do @ + [_ (module.define short-name [value//type annotationsV valueV])] + (if (macro.type? annotationsV) + (case (macro.declared-tags annotationsV) + #.Nil + (wrap []) + + tags + (module.declare-tags tags (macro.export? annotationsV) (:coerce Type valueV))) + (wrap [])))) + #let [_ (log! (format "Definition " (%name full-name)))]] + (statement.lift-translation + (translation.learn full-name valueN))) + + _ + (///.throw //.invalid-syntax [extension-name])))) + +(def: (alias! alias def-name) + (-> Text Name (analysis.Operation Any)) + (do ///.monad + [definition (//.lift (macro.find-def def-name))] + (module.define alias definition))) + +(def: def::module + Handler + (function (_ extension-name phase inputsC+) + (case inputsC+ + (^ (list annotationsC)) + (do ///.monad + [[_ annotationsT annotationsV] (evaluate! Code annotationsC) + _ (statement.lift-analysis + (module.set-annotations (:coerce Code annotationsV)))] + (wrap [])) + + _ + (///.throw //.invalid-syntax [extension-name])))) + +(def: def::alias + Handler + (function (_ extension-name phase inputsC+) + (case inputsC+ + (^ (list [_ (#.Identifier ["" alias])] [_ (#.Identifier def-name)])) + (//.lift + (///.sub [(get@ [#statement.analysis #statement.state]) + (set@ [#statement.analysis #statement.state])] + (alias! alias def-name))) + + _ + (///.throw //.invalid-syntax [extension-name])))) + +(do-template [<mame> <type> <scope>] + [(def: <mame> + (All [anchor expression statement] + (Handler anchor expression statement)) + (function (handler extension-name phase inputsC+) + (case inputsC+ + (^ (list [_ (#.Text name)] valueC)) + (do ///.monad + [[_ handlerT handlerV] (evaluate! (:of (:share [anchor expression statement] + {(Handler anchor expression statement) + handler} + {<type> + (:assume [])})) + valueC)] + (<| <scope> + (//.install name) + (:share [anchor expression statement] + {(Handler anchor expression statement) + handler} + {<type> + (:assume handlerV)}))) + + _ + (///.throw //.invalid-syntax [extension-name]))))] + + [def::analysis analysis.Handler statement.lift-analysis] + [def::synthesis synthesis.Handler statement.lift-synthesis] + [def::translation (translation.Handler anchor expression statement) statement.lift-translation] + [def::statement (statement.Handler anchor expression statement) (<|)] + ) + +(def: bundle::def + Bundle + (<| (bundle.prefix "def") + (|> bundle.empty + (dictionary.put "module" def::module) + (dictionary.put "alias" def::alias) + (dictionary.put "analysis" def::analysis) + (dictionary.put "synthesis" def::synthesis) + (dictionary.put "translation" def::translation) + (dictionary.put "statement" def::statement) + ))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle.empty + (dictionary.put "def" lux::def) + (dictionary.merge ..bundle::def)))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/synthesis.lux b/stdlib/source/lux/tool/compiler/phase/extension/synthesis.lux new file mode 100644 index 000000000..1a2e44f6f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/synthesis.lux @@ -0,0 +1,10 @@ +(.module: + [lux #*] + [// + ["." bundle] + [// + [synthesis (#+ Bundle)]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/translation.lux b/stdlib/source/lux/tool/compiler/phase/extension/translation.lux new file mode 100644 index 000000000..232c8c168 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/translation.lux @@ -0,0 +1,10 @@ +(.module: + [lux #*] + [// + ["." bundle] + [// + [translation (#+ Bundle)]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/statement.lux b/stdlib/source/lux/tool/compiler/phase/statement.lux new file mode 100644 index 000000000..c7ff3719f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/statement.lux @@ -0,0 +1,45 @@ +(.module: + [lux #*] + ["." // + ["." analysis] + ["." synthesis] + ["." translation] + ["." extension]]) + +(type: #export (Component state phase) + {#state state + #phase phase}) + +(type: #export (State anchor expression statement) + {#analysis (Component analysis.State+ + analysis.Phase) + #synthesis (Component synthesis.State+ + synthesis.Phase) + #translation (Component (translation.State+ anchor expression statement) + (translation.Phase anchor expression statement))}) + +(do-template [<special> <general>] + [(type: #export (<special> anchor expression statement) + (<general> (..State anchor expression statement) Code Any))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(do-template [<name> <component> <operation>] + [(def: #export (<name> operation) + (All [anchor expression statement output] + (-> (<operation> output) + (Operation anchor expression statement output))) + (extension.lift + (//.sub [(get@ [<component> #..state]) + (set@ [<component> #..state])] + operation)))] + + [lift-analysis #..analysis analysis.Operation] + [lift-synthesis #..synthesis synthesis.Operation] + [lift-translation #..translation (translation.Operation anchor expression statement)] + ) diff --git a/stdlib/source/lux/tool/compiler/phase/statement/total.lux b/stdlib/source/lux/tool/compiler/phase/statement/total.lux new file mode 100644 index 000000000..c494b01c6 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/statement/total.lux @@ -0,0 +1,56 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + [text + format]] + ["." macro]] + ["." // (#+ Phase) + ["/." // + ["." analysis + ["." expression] + ["." type] + ["///." macro]] + ["." extension]]]) + +(exception: #export (not-a-statement {code Code}) + (ex.report ["Statement" (%code code)])) + +(exception: #export (not-a-macro {code Code}) + (ex.report ["Code" (%code code)])) + +(exception: #export (macro-was-not-found {name Name}) + (ex.report ["Name" (%name name)])) + +(def: #export (phase code) + Phase + (case code + (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) + (extension.apply "Statement" phase [name inputs]) + + (^ [_ (#.Form (list& macro inputs))]) + (do ///.monad + [expansion (//.lift-analysis + (do @ + [macroA (type.with-type Macro + (expression.compile macro))] + (case macroA + (^ (analysis.constant macro-name)) + (do @ + [?macro (extension.lift (macro.find-macro macro-name)) + macro (case ?macro + (#.Some macro) + (wrap macro) + + #.None + (///.throw macro-was-not-found macro-name))] + (extension.lift (///macro.expand macro-name macro inputs))) + + _ + (///.throw not-a-macro code))))] + (monad.map @ phase expansion)) + + _ + (///.throw not-a-statement code))) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/phase/synthesis.lux new file mode 100644 index 000000000..4cc9c7336 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/synthesis.lux @@ -0,0 +1,468 @@ +(.module: + [lux (#- i64 Scope) + [control + [monad (#+ do)] + [equivalence (#+ Equivalence)] + ["ex" exception (#+ exception:)]] + [data + ["." bit ("#/." equivalence)] + ["." text ("#/." equivalence) + format] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]]] + ["." // + ["." analysis (#+ Environment Arity Composite Analysis)] + ["." extension (#+ Extension)] + [// + ["." reference (#+ Register Variable Reference)]]]) + +(type: #export Resolver (Dictionary Variable Variable)) + +(type: #export State + {#locals Nat}) + +(def: #export fresh-resolver + Resolver + (dictionary.new reference.hash)) + +(def: #export init + State + {#locals 0}) + +(type: #export Primitive + (#Bit Bit) + (#I64 (I64 Any)) + (#F64 Frac) + (#Text Text)) + +(type: #export Side + (Either Nat Nat)) + +(type: #export Member + (Either Nat Nat)) + +(type: #export Access + (#Side Side) + (#Member Member)) + +(type: #export (Path' s) + #Pop + (#Test Primitive) + (#Access Access) + (#Bind Register) + (#Alt (Path' s) (Path' s)) + (#Seq (Path' s) (Path' s)) + (#Then s)) + +(type: #export (Abstraction' s) + {#environment Environment + #arity Arity + #body s}) + +(type: #export (Apply' s) + {#function s + #arguments (List s)}) + +(type: #export (Branch s) + (#Let s Register s) + (#If s s s) + (#Case s (Path' s))) + +(type: #export (Scope s) + {#start Register + #inits (List s) + #iteration s}) + +(type: #export (Loop s) + (#Scope (Scope s)) + (#Recur (List s))) + +(type: #export (Function s) + (#Abstraction (Abstraction' s)) + (#Apply s (List s))) + +(type: #export (Control s) + (#Branch (Branch s)) + (#Loop (Loop s)) + (#Function (Function s))) + +(type: #export #rec Synthesis + (#Primitive Primitive) + (#Structure (Composite Synthesis)) + (#Reference Reference) + (#Control (Control Synthesis)) + (#Extension (Extension Synthesis))) + +(do-template [<special> <general>] + [(type: #export <special> + (<general> ..State Analysis Synthesis))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(type: #export Path + (Path' Synthesis)) + +(def: #export path/pop + Path + #Pop) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (#..Test (<tag> content)))] + + [path/bit #..Bit] + [path/i64 #..I64] + [path/f64 #..F64] + [path/text #..Text] + ) + +(do-template [<name> <kind>] + [(template: #export (<name> content) + (.<| #..Access + <kind> + content))] + + [path/side #..Side] + [path/member #..Member] + ) + +(do-template [<name> <kind> <side>] + [(template: #export (<name> content) + (.<| #..Access + <kind> + <side> + content))] + + [side/left #..Side #.Left] + [side/right #..Side #.Right] + [member/left #..Member #.Left] + [member/right #..Member #.Right] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (<tag> content))] + + [path/bind #..Bind] + [path/then #..Then] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> left right) + (<tag> [left right]))] + + [path/alt #..Alt] + [path/seq #..Seq] + ) + +(type: #export Abstraction + (Abstraction' Synthesis)) + +(type: #export Apply + (Apply' Synthesis)) + +(def: #export unit Text "") + +(do-template [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (All [a] (-> (Operation a) (Operation a)))) + (extension.temporary (set@ <tag> value)))] + + [with-locals Nat #locals] + ) + +(def: #export (with-abstraction arity resolver) + (-> Arity Resolver + (All [a] (-> (Operation a) (Operation a)))) + (extension.with-state {#locals arity})) + +(do-template [<name> <tag> <type>] + [(def: #export <name> + (Operation <type>) + (extension.read (get@ <tag>)))] + + [locals #locals Nat] + ) + +(def: #export with-new-local + (All [a] (-> (Operation a) (Operation a))) + (<<| (do //.monad + [locals ..locals]) + (..with-locals (inc locals)))) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (#..Primitive (<tag> content)))] + + [bit #..Bit] + [i64 #..I64] + [f64 #..F64] + [text #..Text] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (<| #..Structure + <tag> + content))] + + [variant #analysis.Variant] + [tuple #analysis.Tuple] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Reference + <tag> + content))] + + [variable/local reference.local] + [variable/foreign reference.foreign] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Reference + <tag> + content))] + + [variable reference.variable] + [constant reference.constant] + ) + +(do-template [<name> <family> <tag>] + [(template: #export (<name> content) + (.<| #..Control + <family> + <tag> + content))] + + [branch/case #..Branch #..Case] + [branch/let #..Branch #..Let] + [branch/if #..Branch #..If] + + [loop/recur #..Loop #..Recur] + [loop/scope #..Loop #..Scope] + + [function/abstraction #..Function #..Abstraction] + [function/apply #..Function #..Apply] + ) + +(def: #export (%path' %then value) + (All [a] (-> (Format a) (Format (Path' a)))) + (case value + #Pop + "_" + + (#Test primitive) + (format "(? " + (case primitive + (#Bit value) + (%b value) + + (#I64 value) + (%i (.int value)) + + (#F64 value) + (%f value) + + (#Text value) + (%t value)) + ")") + + (#Access access) + (case access + (#Side side) + (case side + (#.Left lefts) + (format "(" (%n lefts) " #0" ")") + + (#.Right lefts) + (format "(" (%n lefts) " #1" ")")) + + (#Member member) + (case member + (#.Left lefts) + (format "[" (%n lefts) " #0" "]") + + (#.Right lefts) + (format "[" (%n lefts) " #1" "]"))) + + (#Bind register) + (format "(@ " (%n register) ")") + + (#Alt left right) + (format "(| " (%path' %then left) " " (%path' %then right) ")") + + (#Seq left right) + (format "(& " (%path' %then left) " " (%path' %then right) ")") + + (#Then then) + (|> (%then then) + (text.enclose ["(! " ")"])))) + +(def: #export (%synthesis value) + (Format Synthesis) + (case value + (#Primitive primitive) + (case primitive + (^template [<pattern> <format>] + (<pattern> value) + (<format> value)) + ([#Bit %b] + [#F64 %f] + [#Text %t]) + + (#I64 value) + (%i (.int value))) + + (#Structure structure) + (case structure + (#analysis.Variant [lefts right? content]) + (|> (%synthesis content) + (format (%n lefts) " " (%b right?) " ") + (text.enclose ["(" ")"])) + + (#analysis.Tuple members) + (|> members + (list/map %synthesis) + (text.join-with " ") + (text.enclose ["[" "]"]))) + + (#Reference reference) + (|> reference + reference.%reference + (text.enclose ["(#@ " ")"])) + + (#Control control) + (case control + (#Function function) + (case function + (#Abstraction [environment arity body]) + (|> (%synthesis body) + (format (%n arity) " ") + (format (|> environment + (list/map reference.%variable) + (text.join-with " ") + (text.enclose ["[" "]"])) + " ") + (text.enclose ["(" ")"])) + + (#Apply func args) + (|> (list/map %synthesis args) + (text.join-with " ") + (format (%synthesis func) " ") + (text.enclose ["(" ")"]))) + + (#Branch branch) + (case branch + (#Let input register body) + (|> (format (%synthesis input) " " (%n register) " " (%synthesis body)) + (text.enclose ["(#let " ")"])) + + (#If test then else) + (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else)) + (text.enclose ["(#if " ")"])) + + (#Case input path) + (|> (format (%synthesis input) " " (%path' %synthesis path)) + (text.enclose ["(#case " ")"]))) + + ## (#Loop loop) + _ + "???") + + (#Extension [name args]) + (|> (list/map %synthesis args) + (text.join-with " ") + (format (%t name)) + (text.enclose ["(" ")"])))) + +(def: #export %path + (Format Path) + (%path' %synthesis)) + +(structure: #export primitive-equivalence (Equivalence Primitive) + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <eq> <format>] + [(<tag> reference') (<tag> sample')] + (<eq> reference' sample')) + ([#Bit bit/= %b] + [#F64 f/= %f] + [#Text text/= %t]) + + [(#I64 reference') (#I64 sample')] + (i/= (.int reference') (.int sample')) + + _ + false))) + +(structure: #export access-equivalence (Equivalence Access) + (def: (= reference sample) + (case [reference sample] + (^template [<tag>] + [(<tag> reference') (<tag> sample')] + (case [reference' sample'] + (^template [<side>] + [(<side> reference'') (<side> sample'')] + (n/= reference'' sample'')) + ([#.Left] + [#.Right]) + + _ + false)) + ([#Side] + [#Member]) + + _ + false))) + +(structure: #export (path'-equivalence Equivalence<a>) + (All [a] (-> (Equivalence a) (Equivalence (Path' a)))) + + (def: (= reference sample) + (case [reference sample] + [#Pop #Pop] + true + + (^template [<tag> <equivalence>] + [(<tag> reference') (<tag> sample')] + (:: <equivalence> = reference' sample')) + ([#Test primitive-equivalence] + [#Access access-equivalence] + [#Then Equivalence<a>]) + + [(#Bind reference') (#Bind sample')] + (n/= reference' sample') + + (^template [<tag>] + [(<tag> leftR rightR) (<tag> leftS rightS)] + (and (= leftR leftS) + (= rightR rightS))) + ([#Alt] + [#Seq]) + + _ + false))) + +(structure: #export equivalence (Equivalence Synthesis) + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <equivalence>] + [(<tag> reference') (<tag> sample')] + (:: <equivalence> = reference' sample')) + ([#Primitive primitive-equivalence]) + + _ + false))) + +(def: #export path-equivalence + (Equivalence Path) + (path'-equivalence equivalence)) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux new file mode 100644 index 000000000..b1890688d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux @@ -0,0 +1,170 @@ +(.module: + [lux #* + [control + [equivalence (#+ Equivalence)] + pipe + ["." monad (#+ do)]] + [data + ["." product] + ["." bit ("#/." equivalence)] + ["." text ("#/." equivalence) + format] + [number + ["." frac ("#/." equivalence)]] + [collection + ["." list ("#/." fold monoid)]]]] + ["." // (#+ Path Synthesis Operation Phase) + ["." function] + ["/." // ("#/." monad) + ["." analysis (#+ Pattern Match Analysis)] + [// + ["." reference]]]]) + +(def: clean-up + (-> Path Path) + (|>> (#//.Seq #//.Pop))) + +(def: (path' pattern end? thenC) + (-> Pattern Bit (Operation Path) (Operation Path)) + (case pattern + (#analysis.Simple simple) + (case simple + #analysis.Unit + thenC + + (^template [<from> <to>] + (<from> value) + (///map (|>> (#//.Seq (#//.Test (|> value <to>)))) + thenC)) + ([#analysis.Bit #//.Bit] + [#analysis.Nat (<| #//.I64 .i64)] + [#analysis.Int (<| #//.I64 .i64)] + [#analysis.Rev (<| #//.I64 .i64)] + [#analysis.Frac #//.F64] + [#analysis.Text #//.Text])) + + (#analysis.Bind register) + (<| (:: ///.monad map (|>> (#//.Seq (#//.Bind register)))) + //.with-new-local + thenC) + + (#analysis.Complex (#analysis.Variant [lefts right? value-pattern])) + (<| (///map (|>> (#//.Seq (#//.Access (#//.Side (if right? + (#.Right lefts) + (#.Left lefts))))))) + (path' value-pattern end?) + (when (not end?) (///map ..clean-up)) + thenC) + + (#analysis.Complex (#analysis.Tuple tuple)) + (let [tuple::last (dec (list.size tuple))] + (list/fold (function (_ [tuple::lefts tuple::member] nextC) + (let [right? (n/= tuple::last tuple::lefts) + end?' (and end? right?)] + (<| (///map (|>> (#//.Seq (#//.Access (#//.Member (if right? + (#.Right (dec tuple::lefts)) + (#.Left tuple::lefts))))))) + (path' tuple::member end?') + (when (not end?') (///map ..clean-up)) + nextC))) + thenC + (list.reverse (list.enumerate tuple)))))) + +(def: #export (path synthesize pattern bodyA) + (-> Phase Pattern Analysis (Operation Path)) + (path' pattern true (///map (|>> #//.Then) (synthesize bodyA)))) + +(def: #export (weave leftP rightP) + (-> Path Path Path) + (with-expansions [<default> (as-is (#//.Alt leftP rightP))] + (case [leftP rightP] + [(#//.Seq preL postL) + (#//.Seq preR postR)] + (case (weave preL preR) + (#//.Alt _) + <default> + + weavedP + (#//.Seq weavedP (weave postL postR))) + + [#//.Pop #//.Pop] + rightP + + (^template [<tag> <eq>] + [(#//.Test (<tag> leftV)) + (#//.Test (<tag> rightV))] + (if (<eq> leftV rightV) + rightP + <default>)) + ([#//.Bit bit/=] + [#//.I64 "lux i64 ="] + [#//.F64 frac/=] + [#//.Text text/=]) + + (^template [<access> <side>] + [(#//.Access (<access> (<side> leftL))) + (#//.Access (<access> (<side> rightL)))] + (if (n/= leftL rightL) + rightP + <default>)) + ([#//.Side #.Left] + [#//.Side #.Right] + [#//.Member #.Left] + [#//.Member #.Right]) + + [(#//.Bind leftR) (#//.Bind rightR)] + (if (n/= leftR rightR) + rightP + <default>) + + _ + <default>))) + +(def: #export (synthesize synthesize^ inputA [headB tailB+]) + (-> Phase Analysis Match (Operation Synthesis)) + (do ///.monad + [inputS (synthesize^ inputA)] + (with-expansions [<unnecesary-let> + (as-is (^multi (^ (#analysis.Reference (reference.local outputR))) + (n/= inputR outputR)) + (wrap inputS)) + + <let> + (as-is [[(#analysis.Bind inputR) headB/bodyA] + #.Nil] + (case headB/bodyA + <unnecesary-let> + + _ + (do @ + [headB/bodyS (//.with-new-local + (synthesize^ headB/bodyA))] + (wrap (//.branch/let [inputS inputR headB/bodyS]))))) + + <if> + (as-is (^or (^ [[(analysis.pattern/bit #1) thenA] + (list [(analysis.pattern/bit #0) elseA])]) + (^ [[(analysis.pattern/bit #0) elseA] + (list [(analysis.pattern/bit #1) thenA])])) + (do @ + [thenS (synthesize^ thenA) + elseS (synthesize^ elseA)] + (wrap (//.branch/if [inputS thenS elseS])))) + + <case> + (as-is _ + (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) + list.reverse + (case> (#.Cons [lastP lastA] prevsPA) + [[lastP lastA] prevsPA] + + _ + (undefined)))] + (do @ + [lastSP (path synthesize^ lastP lastA) + prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] + (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))))] + (case [headB tailB+] + <let> + <if> + <case>)))) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux new file mode 100644 index 000000000..ac6a82ab8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux @@ -0,0 +1,86 @@ +(.module: + [lux (#- primitive) + [control + ["." monad (#+ do)] + pipe] + [data + ["." maybe] + ["." error] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]]] + ["." // (#+ Synthesis Phase) + ["." function] + ["." case] + ["/." // ("#/." monad) + ["." analysis (#+ Analysis)] + ["." extension] + [// + ["." reference]]]]) + +(def: (primitive analysis) + (-> analysis.Primitive //.Primitive) + (case analysis + #analysis.Unit + (#//.Text //.unit) + + (^template [<analysis> <synthesis>] + (<analysis> value) + (<synthesis> value)) + ([#analysis.Bit #//.Bit] + [#analysis.Frac #//.F64] + [#analysis.Text #//.Text]) + + (^template [<analysis> <synthesis>] + (<analysis> value) + (<synthesis> (.i64 value))) + ([#analysis.Nat #//.I64] + [#analysis.Int #//.I64] + [#analysis.Rev #//.I64]))) + +(def: #export (phase analysis) + Phase + (case analysis + (#analysis.Primitive analysis') + (///wrap (#//.Primitive (..primitive analysis'))) + + (#analysis.Structure structure) + (case structure + (#analysis.Variant variant) + (do ///.monad + [valueS (phase (get@ #analysis.value variant))] + (wrap (//.variant (set@ #analysis.value valueS variant)))) + + (#analysis.Tuple tuple) + (|> tuple + (monad.map ///.monad phase) + (:: ///.monad map (|>> //.tuple)))) + + (#analysis.Reference reference) + (///wrap (#//.Reference reference)) + + (#analysis.Case inputA branchesAB+) + (case.synthesize phase inputA branchesAB+) + + (^ (analysis.no-op value)) + (phase value) + + (#analysis.Apply _) + (function.apply phase analysis) + + (#analysis.Function environmentA bodyA) + (function.abstraction phase environmentA bodyA) + + (#analysis.Extension name args) + (function (_ state) + (|> (extension.apply "Synthesis" phase [name args]) + (///.run' state) + (case> (#error.Success output) + (#error.Success output) + + (#error.Failure error) + (<| (///.run' state) + (do ///.monad + [argsS+ (monad.map @ phase args)] + (wrap (#//.Extension [name argsS+]))))))) + )) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux new file mode 100644 index 000000000..ce9efe59b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux @@ -0,0 +1,211 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + ["." text + format] + [collection + ["." list ("#/." functor monoid fold)] + ["dict" dictionary (#+ Dictionary)]]]] + ["." // (#+ Path Synthesis Operation Phase) + ["." loop (#+ Transform)] + ["/." // ("#/." monad) + ["." analysis (#+ Environment Arity Analysis)] + [// + ["." reference (#+ Register Variable)]]]]) + +(exception: #export (cannot-find-foreign-variable-in-environment {foreign Register} {environment Environment}) + (ex.report ["Foreign" (%n foreign)] + ["Environment" (|> environment + (list/map reference.%variable) + (text.join-with " "))])) + +(def: arity-arguments + (-> Arity (List Synthesis)) + (|>> dec + (list.n/range 1) + (list/map (|>> //.variable/local)))) + +(template: #export (self-reference) + (//.variable/local 0)) + +(def: (expanded-nested-self-reference arity) + (-> Arity Synthesis) + (//.function/apply [(..self-reference) (arity-arguments arity)])) + +(def: #export (apply phase) + (-> Phase Phase) + (function (_ exprA) + (let [[funcA argsA] (analysis.application exprA)] + (do ///.monad + [funcS (phase funcA) + argsS (monad.map @ phase argsA) + ## locals //.locals + ] + (with-expansions [<apply> (as-is (//.function/apply [funcS argsS]))] + (case funcS + ## (^ (//.function/abstraction functionS)) + ## (wrap (|> functionS + ## (loop.loop (get@ #//.environment functionS) locals argsS) + ## (maybe.default <apply>))) + + (^ (//.function/apply [funcS' argsS'])) + (wrap (//.function/apply [funcS' (list/compose argsS' argsS)])) + + _ + (wrap <apply>))))))) + +(def: (find-foreign environment register) + (-> Environment Register (Operation Variable)) + (case (list.nth register environment) + (#.Some aliased) + (///wrap aliased) + + #.None + (///.throw cannot-find-foreign-variable-in-environment [register environment]))) + +(def: (grow-path grow path) + (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path)) + (case path + (#//.Bind register) + (///wrap (#//.Bind (inc register))) + + (^template [<tag>] + (<tag> left right) + (do ///.monad + [left' (grow-path grow left) + right' (grow-path grow right)] + (wrap (<tag> left' right')))) + ([#//.Alt] [#//.Seq]) + + (#//.Then thenS) + (|> thenS + grow + (///map (|>> #//.Then))) + + _ + (///wrap path))) + +(def: (grow-sub-environment super sub) + (-> Environment Environment (Operation Environment)) + (monad.map ///.monad + (function (_ variable) + (case variable + (#reference.Local register) + (///wrap (#reference.Local (inc register))) + + (#reference.Foreign register) + (find-foreign super register))) + sub)) + +(def: (grow environment expression) + (-> Environment Synthesis (Operation Synthesis)) + (case expression + (#//.Structure structure) + (case structure + (#analysis.Variant [lefts right? subS]) + (|> subS + (grow environment) + (///map (|>> [lefts right?] //.variant))) + + (#analysis.Tuple membersS+) + (|> membersS+ + (monad.map ///.monad (grow environment)) + (///map (|>> //.tuple)))) + + (^ (..self-reference)) + (///wrap (//.function/apply [expression (list (//.variable/local 1))])) + + (#//.Reference reference) + (case reference + (#reference.Variable variable) + (case variable + (#reference.Local register) + (///wrap (//.variable/local (inc register))) + + (#reference.Foreign register) + (|> register + (find-foreign environment) + (///map (|>> //.variable)))) + + (#reference.Constant constant) + (///wrap expression)) + + (#//.Control control) + (case control + (#//.Branch branch) + (case branch + (#//.Let [inputS register bodyS]) + (do ///.monad + [inputS' (grow environment inputS) + bodyS' (grow environment bodyS)] + (wrap (//.branch/let [inputS' (inc register) bodyS']))) + + (#//.If [testS thenS elseS]) + (do ///.monad + [testS' (grow environment testS) + thenS' (grow environment thenS) + elseS' (grow environment elseS)] + (wrap (//.branch/if [testS' thenS' elseS']))) + + (#//.Case [inputS pathS]) + (do ///.monad + [inputS' (grow environment inputS) + pathS' (grow-path (grow environment) pathS)] + (wrap (//.branch/case [inputS' pathS'])))) + + (#//.Loop loop) + (case loop + (#//.Scope [start initsS+ iterationS]) + (do ///.monad + [initsS+' (monad.map @ (grow environment) initsS+) + iterationS' (grow environment iterationS)] + (wrap (//.loop/scope [start initsS+' iterationS']))) + + (#//.Recur argumentsS+) + (|> argumentsS+ + (monad.map ///.monad (grow environment)) + (///map (|>> //.loop/recur)))) + + (#//.Function function) + (case function + (#//.Abstraction [_env _arity _body]) + (do ///.monad + [_env' (grow-sub-environment environment _env)] + (wrap (//.function/abstraction [_env' _arity _body]))) + + (#//.Apply funcS argsS+) + (case funcS + (^ (//.function/apply [(..self-reference) pre-argsS+])) + (///wrap (//.function/apply [(..self-reference) + (list/compose pre-argsS+ argsS+)])) + + _ + (do ///.monad + [funcS' (grow environment funcS) + argsS+' (monad.map @ (grow environment) argsS+)] + (wrap (//.function/apply [funcS' argsS+'])))))) + + (#//.Extension name argumentsS+) + (|> argumentsS+ + (monad.map ///.monad (grow environment)) + (///map (|>> (#//.Extension name)))) + + _ + (///wrap expression))) + +(def: #export (abstraction phase environment bodyA) + (-> Phase Environment Analysis (Operation Synthesis)) + (do ///.monad + [bodyS (phase bodyA)] + (case bodyS + (^ (//.function/abstraction [env' down-arity' bodyS'])) + (|> bodyS' + (grow env') + (:: @ map (|>> [environment (inc down-arity')] //.function/abstraction))) + + _ + (wrap (//.function/abstraction [environment 1 bodyS]))))) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/loop.lux new file mode 100644 index 000000000..28517bd42 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/loop.lux @@ -0,0 +1,291 @@ +(.module: + [lux (#- loop) + [control + ["." monad (#+ do)] + ["p" parser]] + [data + ["." maybe ("#/." monad)] + [collection + ["." list ("#/." functor)]]] + [macro + ["." code] + ["." syntax]]] + ["." // (#+ Path Abstraction Synthesis) + [// + ["." analysis (#+ Environment)] + ["." extension] + [// + ["." reference (#+ Register Variable)]]]]) + +(type: #export (Transform a) + (-> a (Maybe a))) + +(def: (some? maybe) + (All [a] (-> (Maybe a) Bit)) + (case maybe + (#.Some _) #1 + #.None #0)) + +(template: #export (self) + (#//.Reference (reference.local 0))) + +(template: (recursive-apply args) + (#//.Apply (self) args)) + +(def: improper #0) +(def: proper #1) + +(def: (proper? exprS) + (-> Synthesis Bit) + (case exprS + (^ (self)) + improper + + (#//.Structure structure) + (case structure + (#analysis.Variant variantS) + (proper? (get@ #analysis.value variantS)) + + (#analysis.Tuple membersS+) + (list.every? proper? membersS+)) + + (#//.Control controlS) + (case controlS + (#//.Branch branchS) + (case branchS + (#//.Case inputS pathS) + (and (proper? inputS) + (.loop [pathS pathS] + (case pathS + (^or (#//.Alt leftS rightS) (#//.Seq leftS rightS)) + (and (recur leftS) (recur rightS)) + + (#//.Then bodyS) + (proper? bodyS) + + _ + proper))) + + (#//.Let inputS register bodyS) + (and (proper? inputS) + (proper? bodyS)) + + (#//.If inputS thenS elseS) + (and (proper? inputS) + (proper? thenS) + (proper? elseS))) + + (#//.Loop loopS) + (case loopS + (#//.Scope scopeS) + (and (list.every? proper? (get@ #//.inits scopeS)) + (proper? (get@ #//.iteration scopeS))) + + (#//.Recur argsS) + (list.every? proper? argsS)) + + (#//.Function functionS) + (case functionS + (#//.Abstraction environment arity bodyS) + (list.every? reference.self? environment) + + (#//.Apply funcS argsS) + (and (proper? funcS) + (list.every? proper? argsS)))) + + (#//.Extension [name argsS]) + (list.every? proper? argsS) + + _ + proper)) + +(def: (path-recursion synthesis-recursion) + (-> (Transform Synthesis) (Transform Path)) + (function (recur pathS) + (case pathS + (#//.Alt leftS rightS) + (let [leftS' (recur leftS) + rightS' (recur rightS)] + (if (or (some? leftS') + (some? rightS')) + (#.Some (#//.Alt (maybe.default leftS leftS') + (maybe.default rightS rightS'))) + #.None)) + + (#//.Seq leftS rightS) + (maybe/map (|>> (#//.Seq leftS)) (recur rightS)) + + (#//.Then bodyS) + (maybe/map (|>> #//.Then) (synthesis-recursion bodyS)) + + _ + #.None))) + +(def: #export (recursion arity) + (-> Nat (Transform Synthesis)) + (function (recur exprS) + (case exprS + (#//.Control controlS) + (case controlS + (#//.Branch branchS) + (case branchS + (#//.Case inputS pathS) + (|> pathS + (path-recursion recur) + (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control))) + + (#//.Let inputS register bodyS) + (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control) + (recur bodyS)) + + (#//.If inputS thenS elseS) + (let [thenS' (recur thenS) + elseS' (recur elseS)] + (if (or (some? thenS') + (some? elseS')) + (#.Some (|> (#//.If inputS + (maybe.default thenS thenS') + (maybe.default elseS elseS')) + #//.Branch #//.Control)) + #.None))) + + (^ (#//.Function (recursive-apply argsS))) + (if (n/= arity (list.size argsS)) + (#.Some (|> argsS #//.Recur #//.Loop #//.Control)) + #.None) + + _ + #.None) + + _ + #.None))) + +(def: (resolve environment) + (-> Environment (Transform Variable)) + (function (_ variable) + (case variable + (#reference.Foreign register) + (list.nth register environment) + + _ + (#.Some variable)))) + +(def: (adjust-path adjust-synthesis offset) + (-> (Transform Synthesis) Register (Transform Path)) + (function (recur pathS) + (case pathS + (#//.Bind register) + (#.Some (#//.Bind (n/+ offset register))) + + (^template [<tag>] + (<tag> leftS rightS) + (do maybe.monad + [leftS' (recur leftS) + rightS' (recur rightS)] + (wrap (<tag> leftS' rightS')))) + ([#//.Alt] [#//.Seq]) + + (#//.Then bodyS) + (|> bodyS adjust-synthesis (maybe/map (|>> #//.Then))) + + _ + (#.Some pathS)))) + +(def: (adjust scope-environment offset) + (-> Environment Register (Transform Synthesis)) + (function (recur exprS) + (case exprS + (#//.Structure structureS) + (case structureS + (#analysis.Variant variantS) + (do maybe.monad + [valueS' (|> variantS (get@ #analysis.value) recur)] + (wrap (|> variantS + (set@ #analysis.value valueS') + #analysis.Variant + #//.Structure))) + + (#analysis.Tuple membersS+) + (|> membersS+ + (monad.map maybe.monad recur) + (maybe/map (|>> #analysis.Tuple #//.Structure)))) + + (#//.Reference reference) + (case reference + (^ (reference.constant constant)) + (#.Some exprS) + + (^ (reference.local register)) + (#.Some (#//.Reference (reference.local (n/+ offset register)))) + + (^ (reference.foreign register)) + (|> scope-environment + (list.nth register) + (maybe/map (|>> #reference.Variable #//.Reference)))) + + (^ (//.branch/case [inputS pathS])) + (do maybe.monad + [inputS' (recur inputS) + pathS' (adjust-path recur offset pathS)] + (wrap (|> pathS' [inputS'] //.branch/case))) + + (^ (//.branch/let [inputS register bodyS])) + (do maybe.monad + [inputS' (recur inputS) + bodyS' (recur bodyS)] + (wrap (//.branch/let [inputS' register bodyS']))) + + (^ (//.branch/if [inputS thenS elseS])) + (do maybe.monad + [inputS' (recur inputS) + thenS' (recur thenS) + elseS' (recur elseS)] + (wrap (//.branch/if [inputS' thenS' elseS']))) + + (^ (//.loop/scope scopeS)) + (do maybe.monad + [inits' (|> scopeS + (get@ #//.inits) + (monad.map maybe.monad recur)) + iteration' (recur (get@ #//.iteration scopeS))] + (wrap (//.loop/scope {#//.start (|> scopeS (get@ #//.start) (n/+ offset)) + #//.inits inits' + #//.iteration iteration'}))) + + (^ (//.loop/recur argsS)) + (|> argsS + (monad.map maybe.monad recur) + (maybe/map (|>> //.loop/recur))) + + + (^ (//.function/abstraction [environment arity bodyS])) + (do maybe.monad + [environment' (monad.map maybe.monad + (resolve scope-environment) + environment)] + (wrap (//.function/abstraction [environment' arity bodyS]))) + + (^ (//.function/apply [function arguments])) + (do maybe.monad + [function' (recur function) + arguments' (monad.map maybe.monad recur arguments)] + (wrap (//.function/apply [function' arguments']))) + + (#//.Extension [name argsS]) + (|> argsS + (monad.map maybe.monad recur) + (maybe/map (|>> [name] #//.Extension))) + + _ + (#.Some exprS)))) + +(def: #export (loop environment num-locals inits functionS) + (-> Environment Nat (List Synthesis) Abstraction (Maybe Synthesis)) + (let [bodyS (get@ #//.body functionS)] + (if (and (n/= (list.size inits) + (get@ #//.arity functionS)) + (proper? bodyS)) + (|> bodyS + (adjust environment num-locals) + (maybe/map (|>> [(inc num-locals) inits] //.loop/scope))) + #.None))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation.lux b/stdlib/source/lux/tool/compiler/phase/translation.lux new file mode 100644 index 000000000..d8522adcd --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation.lux @@ -0,0 +1,250 @@ +(.module: + [lux #* + [control + ["ex" exception (#+ exception:)] + [monad (#+ do)]] + [data + ["." product] + ["." error (#+ Error)] + ["." name ("#/." equivalence)] + ["." text + format] + [collection + ["." row (#+ Row)] + ["." dictionary (#+ Dictionary)]]] + [world + [file (#+ File)]]] + ["." // + ["." extension]] + [//synthesis (#+ Synthesis)]) + +(do-template [<name>] + [(exception: #export (<name>) + "")] + + [no-active-buffer] + [no-anchor] + ) + +(exception: #export (cannot-interpret {error Text}) + (ex.report ["Error" error])) + +(exception: #export (unknown-lux-name {name Name}) + (ex.report ["Name" (%name name)])) + +(exception: #export (cannot-overwrite-lux-name {lux-name Name} + {old-host-name Text} + {new-host-name Text}) + (ex.report ["Lux Name" (%name lux-name)] + ["Old Host Name" old-host-name] + ["New Host Name" new-host-name])) + +(do-template [<name>] + [(exception: #export (<name> {name Name}) + (ex.report ["Output" (%name name)]))] + + [cannot-overwrite-output] + [no-buffer-for-saving-code] + ) + +(type: #export Context + {#scope-name Text + #inner-functions Nat}) + +(signature: #export (Host expression statement) + (: (-> Text expression (Error Any)) + evaluate!) + (: (-> Text statement (Error Any)) + execute!) + (: (-> Name expression (Error [Text Any])) + define!)) + +(type: #export (Buffer statement) (Row [Name statement])) + +(type: #export (Outputs statement) (Dictionary File (Buffer statement))) + +(type: #export (State anchor expression statement) + {#context Context + #anchor (Maybe anchor) + #host (Host expression statement) + #buffer (Maybe (Buffer statement)) + #outputs (Outputs statement) + #counter Nat + #name-cache (Dictionary Name Text)}) + +(do-template [<special> <general>] + [(type: #export (<special> anchor expression statement) + (<general> (State anchor expression statement) Synthesis expression))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(def: #export (state host) + (All [anchor expression statement] + (-> (Host expression statement) + (..State anchor expression statement))) + {#context {#scope-name "" + #inner-functions 0} + #anchor #.None + #host host + #buffer #.None + #outputs (dictionary.new text.hash) + #counter 0 + #name-cache (dictionary.new name.hash)}) + +(def: #export (with-context expr) + (All [anchor expression statement output] + (-> (Operation anchor expression statement output) + (Operation anchor expression statement [Text output]))) + (function (_ [bundle state]) + (let [[old-scope old-inner] (get@ #context state) + new-scope (format old-scope "c" (%n old-inner))] + (case (expr [bundle (set@ #context [new-scope 0] state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ #context [old-scope (inc old-inner)] state')] + [new-scope output]]) + + (#error.Failure error) + (#error.Failure error))))) + +(def: #export context + (All [anchor expression statement] + (Operation anchor expression statement Text)) + (extension.read (|>> (get@ #context) + (get@ #scope-name)))) + +(do-template [<tag> + <with-declaration> <with-type> <with-value> + <get> <get-type> <exception>] + [(def: #export <with-declaration> + (All [anchor expression statement output] <with-type>) + (function (_ body) + (function (_ [bundle state]) + (case (body [bundle (set@ <tag> (#.Some <with-value>) state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ <tag> (get@ <tag> state) state')] + output]) + + (#error.Failure error) + (#error.Failure error))))) + + (def: #export <get> + (All [anchor expression statement] + (Operation anchor expression statement <get-type>)) + (function (_ (^@ stateE [bundle state])) + (case (get@ <tag> state) + (#.Some output) + (#error.Success [stateE output]) + + #.None + (ex.throw <exception> []))))] + + [#anchor + (with-anchor anchor) + (-> anchor (Operation anchor expression statement output) + (Operation anchor expression statement output)) + anchor + anchor anchor no-anchor] + + [#buffer + with-buffer + (-> (Operation anchor expression statement output) + (Operation anchor expression statement output)) + row.empty + buffer (Buffer statement) no-active-buffer] + ) + +(def: #export outputs + (All [anchor expression statement] + (Operation anchor expression statement (Outputs statement))) + (extension.read (get@ #outputs))) + +(def: #export next + (All [anchor expression statement] + (Operation anchor expression statement Nat)) + (do //.monad + [count (extension.read (get@ #counter)) + _ (extension.update (update@ #counter inc))] + (wrap count))) + +(do-template [<name> <inputT>] + [(def: #export (<name> label code) + (All [anchor expression statement] + (-> Text <inputT> (Operation anchor expression statement Any))) + (function (_ (^@ state+ [bundle state])) + (case (:: (get@ #host state) <name> label code) + (#error.Success output) + (#error.Success [state+ output]) + + (#error.Failure error) + (ex.throw cannot-interpret error))))] + + [evaluate! expression] + [execute! statement] + ) + +(def: #export (define! name code) + (All [anchor expression statement] + (-> Name expression (Operation anchor expression statement [Text Any]))) + (function (_ (^@ stateE [bundle state])) + (case (:: (get@ #host state) define! name code) + (#error.Success output) + (#error.Success [stateE output]) + + (#error.Failure error) + (ex.throw cannot-interpret error)))) + +(def: #export (save! name code) + (All [anchor expression statement] + (-> Name statement (Operation anchor expression statement Any))) + (do //.monad + [count ..next + _ (execute! (format "save" (%n count)) code) + ?buffer (extension.read (get@ #buffer))] + (case ?buffer + (#.Some buffer) + (if (row.any? (|>> product.left (name/= name)) buffer) + (//.throw cannot-overwrite-output name) + (extension.update (set@ #buffer (#.Some (row.add [name code] buffer))))) + + #.None + (//.throw no-buffer-for-saving-code name)))) + +(def: #export (save-buffer! target) + (All [anchor expression statement] + (-> File (Operation anchor expression statement Any))) + (do //.monad + [buffer ..buffer] + (extension.update (update@ #outputs (dictionary.put target buffer))))) + +(def: #export (remember lux-name) + (All [anchor expression statement] + (-> Name (Operation anchor expression statement Text))) + (function (_ (^@ stateE [_ state])) + (let [cache (get@ #name-cache state)] + (case (dictionary.get lux-name cache) + (#.Some host-name) + (#error.Success [stateE host-name]) + + #.None + (ex.throw unknown-lux-name lux-name))))) + +(def: #export (learn lux-name host-name) + (All [anchor expression statement] + (-> Name Text (Operation anchor expression statement Any))) + (function (_ [bundle state]) + (let [cache (get@ #name-cache state)] + (case (dictionary.get lux-name cache) + #.None + (#error.Success [[bundle + (update@ #name-cache + (dictionary.put lux-name host-name) + state)] + []]) + + (#.Some old-host-name) + (ex.throw cannot-overwrite-lux-name [lux-name old-host-name host-name]))))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux new file mode 100644 index 000000000..92b55cb80 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux @@ -0,0 +1,177 @@ +(.module: + [lux (#- case let if) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." number] + ["." text + format] + [collection + ["." list ("#/." functor fold)] + [set (#+ Set)]]]] + [// + ["." runtime (#+ Operation Phase)] + ["." reference] + ["/." /// ("#/." monad) + ["." synthesis (#+ Synthesis Path)] + [// + [reference (#+ Register)] + [// + [host + ["_" scheme (#+ Expression Computation Var)]]]]]]) + +(def: #export (let translate [valueS register bodyS]) + (-> Phase [Synthesis Register Synthesis] + (Operation Computation)) + (do ////.monad + [valueO (translate valueS) + bodyO (translate bodyS)] + (wrap (_.let (list [(reference.local' register) valueO]) + bodyO)))) + +(def: #export (record-get translate valueS pathP) + (-> Phase Synthesis (List [Nat Bit]) + (Operation Expression)) + (do ////.monad + [valueO (translate valueS)] + (wrap (list/fold (function (_ [idx tail?] source) + (.let [method (.if tail? + runtime.product//right + runtime.product//left)] + (method source (_.int (:coerce Int idx))))) + valueO + pathP)))) + +(def: #export (if translate [testS thenS elseS]) + (-> Phase [Synthesis Synthesis Synthesis] + (Operation Computation)) + (do ////.monad + [testO (translate testS) + thenO (translate thenS) + elseO (translate elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) + +(def: @cursor (_.var "lux_pm_cursor")) + +(def: top _.length/1) + +(def: (push! value var) + (-> Expression Var Computation) + (_.set! var (_.cons/2 value var))) + +(def: (pop! var) + (-> Var Computation) + (_.set! var var)) + +(def: (push-cursor! value) + (-> Expression Computation) + (push! value @cursor)) + +(def: save-cursor! + Computation + (push! @cursor @savepoint)) + +(def: restore-cursor! + Computation + (_.set! @cursor (_.car/1 @savepoint))) + +(def: cursor-top + Computation + (_.car/1 @cursor)) + +(def: pop-cursor! + Computation + (pop! @cursor)) + +(def: pm-error (_.string "PM-ERROR")) + +(def: fail-pm! (_.raise/1 pm-error)) + +(def: @temp (_.var "lux_pm_temp")) + +(exception: #export (unrecognized-path) + "") + +(def: $alt_error (_.var "alt_error")) + +(def: (pm-catch handler) + (-> Expression Computation) + (_.lambda [(list $alt_error) #.None] + (_.if (|> $alt_error (_.eqv?/2 pm-error)) + handler + (_.raise/1 $alt_error)))) + +(def: (pattern-matching' translate pathP) + (-> Phase Path (Operation Expression)) + (.case pathP + (^ (synthesis.path/then bodyS)) + (translate bodyS) + + #synthesis.Pop + (/////wrap pop-cursor!) + + (#synthesis.Bind register) + (/////wrap (_.define (reference.local' register) [(list) #.None] + cursor-top)) + + (^template [<tag> <format> <=>] + (^ (<tag> value)) + (/////wrap (_.when (|> value <format> (<=> cursor-top) _.not/1) + fail-pm!))) + ([synthesis.path/bit _.bool _.eqv?/2] + [synthesis.path/i64 (<| _.int .int) _.=/2] + [synthesis.path/f64 _.float _.=/2] + [synthesis.path/text _.string _.eqv?/2]) + + (^template [<pm> <flag> <prep>] + (^ (<pm> idx)) + (/////wrap (_.let (list [@temp (|> idx <prep> .int _.int (runtime.sum//get cursor-top <flag>))]) + (_.if (_.null?/1 @temp) + fail-pm! + (push-cursor! @temp))))) + ([synthesis.side/left _.nil (<|)] + [synthesis.side/right (_.string "") inc]) + + (^template [<pm> <getter> <prep>] + (^ (<pm> idx)) + (/////wrap (|> idx <prep> .int _.int (<getter> cursor-top) push-cursor!))) + ([synthesis.member/left runtime.product//left (<|)] + [synthesis.member/right runtime.product//right inc]) + + (^template [<tag> <computation>] + (^ (<tag> leftP rightP)) + (do ////.monad + [leftO (pattern-matching' translate leftP) + rightO (pattern-matching' translate rightP)] + (wrap <computation>))) + ([synthesis.path/seq (_.begin (list leftO + rightO))] + [synthesis.path/alt (_.with-exception-handler + (pm-catch (_.begin (list restore-cursor! + rightO))) + (_.lambda [(list) #.None] + (_.begin (list save-cursor! + leftO))))]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching translate pathP) + (-> Phase Path (Operation Computation)) + (do ////.monad + [pattern-matching! (pattern-matching' translate pathP)] + (wrap (_.with-exception-handler + (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (_.lambda [(list) #.None] + pattern-matching!))))) + +(def: #export (case translate [valueS pathP]) + (-> Phase [Synthesis Path] (Operation Computation)) + (do ////.monad + [valueO (translate valueS)] + (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] + [@savepoint (_.list/* (list))]))) + (pattern-matching translate pathP)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux new file mode 100644 index 000000000..53d7bbbcb --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux @@ -0,0 +1,59 @@ +(.module: + [lux #* + [control + [monad (#+ do)]]] + [// + [runtime (#+ Phase)] + ["." primitive] + ["." structure] + ["." reference] + ["." function] + ["." case] + ["." loop] + ["." /// + ["." synthesis] + ["." extension]]]) + +(def: #export (translate synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + (^ (<tag> value)) + (<generator> value)) + ([synthesis.bit primitive.bit] + [synthesis.i64 primitive.i64] + [synthesis.f64 primitive.f64] + [synthesis.text primitive.text]) + + (^ (synthesis.variant variantS)) + (structure.variant translate variantS) + + (^ (synthesis.tuple members)) + (structure.tuple translate members) + + (#synthesis.Reference reference) + (reference.reference reference) + + (^ (synthesis.branch/case case)) + (case.case translate case) + + (^ (synthesis.branch/let let)) + (case.let translate let) + + (^ (synthesis.branch/if if)) + (case.if translate if) + + (^ (synthesis.loop/scope scope)) + (loop.scope translate scope) + + (^ (synthesis.loop/recur updates)) + (loop.recur translate updates) + + (^ (synthesis.function/abstraction abstraction)) + (function.function translate abstraction) + + (^ (synthesis.function/apply application)) + (function.apply translate application) + + (#synthesis.Extension extension) + (extension.apply translate extension))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux new file mode 100644 index 000000000..a40b4953f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux @@ -0,0 +1,15 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common] + ["." host]]) + +(def: #export bundle + Bundle + (|> common.bundle + (dictionary.merge host.bundle))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux new file mode 100644 index 000000000..1c55abf83 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux @@ -0,0 +1,245 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["e" error] + ["." product] + ["." text + format] + [number (#+ hex)] + [collection + ["." list ("#/." functor)] + ["dict" dictionary (#+ Dictionary)]]] + ["." macro (#+ with-gensyms) + ["." code] + ["s" syntax (#+ syntax:)]] + [host (#+ import:)]] + [/// + ["." runtime (#+ Operation Phase Handler Bundle)] + ["//." /// + ["." synthesis (#+ Synthesis)] + ["." extension + ["." bundle]] + [/// + [host + ["_" scheme (#+ Expression Computation)]]]]]) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector 0 Expression) Computation)) +(type: #export Unary (-> (Vector 1 Expression) Computation)) +(type: #export Binary (-> (Vector 2 Expression) Computation)) +(type: #export Trinary (-> (Vector 3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +(syntax: (arity: {name s.local-identifier} {arity s.nat}) + (with-gensyms [g!_ g!extension g!name g!phase g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + Handler) + (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do /////.monad + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!phase) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) + +(arity: nullary 0) +(arity: unary 1) +(arity: binary 2) +(arity: trinary 3) + +(def: #export (variadic extension) + (-> Variadic Handler) + (function (_ extension-name) + (function (_ phase inputsS) + (do /////.monad + [inputsI (monad.map @ phase inputsS)] + (wrap (extension inputsI)))))) + +(def: bundle::lux + Bundle + (|> bundle.empty + (bundle.install "is?" (binary (product.uncurry _.eq?/2))) + (bundle.install "try" (unary runtime.lux//try)))) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [bit::and _.bit-and/2] + [bit::or _.bit-or/2] + [bit::xor _.bit-xor/2] + ) + +(def: (bit::left-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) + subjectO)) + +(def: (bit::arithmetic-right-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) + subjectO)) + +(def: (bit::logical-right-shift [subjectO paramO]) + Binary + (runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) + +(def: bundle::bit + Bundle + (<| (bundle.prefix "bit") + (|> bundle.empty + (bundle.install "and" (binary bit::and)) + (bundle.install "or" (binary bit::or)) + (bundle.install "xor" (binary bit::xor)) + (bundle.install "left-shift" (binary bit::left-shift)) + (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) + ))) + +(import: java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(do-template [<name> <const> <encode>] + [(def: (<name> _) + Nullary + (<encode> <const>))] + + [frac::smallest (Double::MIN_VALUE) _.float] + [frac::min (f/* -1.0 (Double::MAX_VALUE)) _.float] + [frac::max (Double::MAX_VALUE) _.float] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (|> subjectO (<op> paramO)))] + + [int::+ _.+/2] + [int::- _.-/2] + [int::* _.*/2] + [int::/ _.quotient/2] + [int::% _.remainder/2] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [frac::+ _.+/2] + [frac::- _.-/2] + [frac::* _.*/2] + [frac::/ _.//2] + [frac::% _.mod/2] + [frac::= _.=/2] + [frac::< _.</2] + + [text::= _.string=?/2] + [text::< _.string<?/2] + ) + +(do-template [<name> <cmp>] + [(def: (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [int::= _.=/2] + [int::< _.</2] + ) + +(def: int::char (|>> _.integer->char/1 _.string/1)) + +(def: bundle::int + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "+" (binary int::+)) + (bundle.install "-" (binary int::-)) + (bundle.install "*" (binary int::*)) + (bundle.install "/" (binary int::/)) + (bundle.install "%" (binary int::%)) + (bundle.install "=" (binary int::=)) + (bundle.install "<" (binary int::<)) + (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0))))) + (bundle.install "char" (unary int::char))))) + +(def: bundle::frac + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary frac::+)) + (bundle.install "-" (binary frac::-)) + (bundle.install "*" (binary frac::*)) + (bundle.install "/" (binary frac::/)) + (bundle.install "%" (binary frac::%)) + (bundle.install "=" (binary frac::=)) + (bundle.install "<" (binary frac::<)) + (bundle.install "smallest" (nullary frac::smallest)) + (bundle.install "min" (nullary frac::min)) + (bundle.install "max" (nullary frac::max)) + (bundle.install "to-int" (unary _.exact/1)) + (bundle.install "encode" (unary _.number->string/1)) + (bundle.install "decode" (unary runtime.frac//decode))))) + +(def: (text::char [subjectO paramO]) + Binary + (_.string/1 (_.string-ref/2 subjectO paramO))) + +(def: (text::clip [subjectO startO endO]) + Trinary + (_.substring/3 subjectO startO endO)) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary text::=)) + (bundle.install "<" (binary text::<)) + (bundle.install "concat" (binary (product.uncurry _.string-append/2))) + (bundle.install "size" (unary _.string-length/1)) + (bundle.install "char" (binary text::char)) + (bundle.install "clip" (trinary text::clip))))) + +(def: (io::log input) + Unary + (_.begin (list (_.display/1 input) + _.newline/0))) + +(def: (void code) + (-> Expression Computation) + (_.begin (list code (_.string synthesis.unit)))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> io::log ..void))) + (bundle.install "error" (unary _.raise/1)) + (bundle.install "exit" (unary _.exit/1)) + (bundle.install "current-time" (nullary (function (_ _) (runtime.io//current-time (_.string synthesis.unit)))))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle::lux + (dict.merge bundle::bit) + (dict.merge bundle::int) + (dict.merge bundle::frac) + (dict.merge bundle::text) + (dict.merge bundle::io) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux new file mode 100644 index 000000000..b8b2b7612 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux @@ -0,0 +1,11 @@ +(.module: + [lux #*] + [/// + [runtime (#+ Bundle)] + [/// + [extension + ["." bundle]]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux new file mode 100644 index 000000000..fe08b6a50 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux @@ -0,0 +1,92 @@ +(.module: + [lux (#- function) + [control + ["." monad (#+ do)] + pipe] + [data + ["." product] + [text + format] + [collection + ["." list ("#/." functor)]]]] + [// + ["." runtime (#+ Operation Phase)] + ["." reference] + ["/." // + ["//." // ("#/." monad) + [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + [// + [reference (#+ Register Variable)] + ["." name] + [// + [host + ["_" scheme (#+ Expression Computation Var)]]]]]]]) + +(def: #export (apply translate [functionS argsS+]) + (-> Phase (Application Synthesis) (Operation Computation)) + (do ////.monad + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Computation (Operation Computation)) + (let [@closure (_.var (format function-name "___CLOSURE"))] + (/////wrap + (case inits + #.Nil + function-definition + + _ + (_.letrec (list [@closure + (_.lambda [(|> (list.enumerate inits) + (list/map (|>> product.left reference.foreign'))) + #.None] + function-definition)]) + (_.apply/* @closure inits)))))) + +(def: @curried (_.var "curried")) +(def: @missing (_.var "missing")) + +(def: input + (|>> inc reference.local')) + +(def: #export (function translate [environment arity bodyS]) + (-> Phase (Abstraction Synthesis) (Operation Computation)) + (do ////.monad + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (translate bodyS)))) + closureO+ (monad.map @ reference.variable environment) + #let [arityO (|> arity .int _.int) + @num-args (_.var "num_args") + @function (_.var function-name) + apply-poly (.function (_ args func) + (_.apply/2 (_.global "apply") func args))]] + (with-closure function-name closureO+ + (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] + (_.let (list [@num-args (_.length/1 @curried)]) + (<| (_.if (|> @num-args (_.=/2 arityO)) + (<| (_.let (list [(reference.local' 0) @function])) + (_.let-values (list [[(|> (list.indices arity) + (list/map ..input)) + #.None] + (_.apply/2 (_.global "apply") (_.global "values") @curried)])) + bodyO)) + (_.if (|> @num-args (_.>/2 arityO)) + (let [arity-args (runtime.slice (_.int +0) arityO @curried) + output-func-args (runtime.slice arityO + (|> @num-args (_.-/2 arityO)) + @curried)] + (|> @function + (apply-poly arity-args) + (apply-poly output-func-args)))) + ## (|> @num-args (_.</2 arityO)) + (_.lambda [(list) (#.Some @missing)] + (|> @function + (apply-poly (_.append/2 @curried @missing)))))))]) + @function)) + )) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux new file mode 100644 index 000000000..0d85654c1 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux @@ -0,0 +1,41 @@ +(.module: + [lux (#- Scope) + [control + ["." monad (#+ do)]] + [data + ["." product] + ["." text + format] + [collection + ["." list ("#/." functor)]]]] + [// + [runtime (#+ Operation Phase)] + ["." reference] + ["/." // + ["//." // + [synthesis (#+ Scope Synthesis)] + [/// + [host + ["_" scheme (#+ Computation Var)]]]]]]) + +(def: @scope (_.var "scope")) + +(def: #export (scope translate [start initsS+ bodyS]) + (-> Phase (Scope Synthesis) (Operation Computation)) + (do ////.monad + [initsO+ (monad.map @ translate initsS+) + bodyO (///.with-anchor @scope + (translate bodyS))] + (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ + list.enumerate + (list/map (|>> product.left (n/+ start) reference.local'))) + #.None] + bodyO)]) + (_.apply/* @scope initsO+))))) + +(def: #export (recur translate argsS+) + (-> Phase (List Synthesis) (Operation Computation)) + (do ////.monad + [@scope ///.anchor + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux new file mode 100644 index 000000000..dc643bcbc --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux @@ -0,0 +1,25 @@ +(.module: + [lux (#- i64)] + [// + [runtime (#+ Operation)] + [// (#+ State) + ["//." // ("#/." monad) + [/// + [host + ["_" scheme (#+ Expression)]]]]]]) + +(def: #export bit + (-> Bit (Operation Expression)) + (|>> _.bool /////wrap)) + +(def: #export i64 + (-> (I64 Any) (Operation Expression)) + (|>> .int _.int /////wrap)) + +(def: #export f64 + (-> Frac (Operation Expression)) + (|>> _.float /////wrap)) + +(def: #export text + (-> Text (Operation Expression)) + (|>> _.string /////wrap)) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux new file mode 100644 index 000000000..161d2adea --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux @@ -0,0 +1,48 @@ +(.module: + [lux #* + [control + pipe] + [data + [text + format]]] + [// + [runtime (#+ Operation)] + ["/." // + ["//." // ("#/." monad) + [analysis (#+ Variant Tuple)] + [synthesis (#+ Synthesis)] + [// + ["." reference (#+ Register Variable Reference)] + [// + [host + ["_" scheme (#+ Expression Global Var)]]]]]]]) + +(do-template [<name> <prefix>] + [(def: #export <name> + (-> Register Var) + (|>> .int %i (format <prefix>) _.var))] + + [local' "l"] + [foreign' "f"] + ) + +(def: #export variable + (-> Variable (Operation Var)) + (|>> (case> (#reference.Local register) + (local' register) + + (#reference.Foreign register) + (foreign' register)) + /////wrap)) + +(def: #export constant + (-> Name (Operation Global)) + (|>> ///.remember (/////map _.global))) + +(def: #export reference + (-> Reference (Operation Expression)) + (|>> (case> (#reference.Constant value) + (..constant value) + + (#reference.Variable value) + (..variable value)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux new file mode 100644 index 000000000..d254e8c7d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux @@ -0,0 +1,322 @@ +(.module: + [lux #* + [control + ["p" parser ("#/." monad)] + [monad (#+ do)]] + [data + [number (#+ hex)] + [text + format] + [collection + ["." list ("#/." monad)]]] + ["." function] + [macro + ["." code] + ["s" syntax (#+ syntax:)]]] + ["." /// + ["//." // + [analysis (#+ Variant)] + ["." synthesis] + [// + ["." name] + [// + [host + ["_" scheme (#+ Expression Computation Var)]]]]]]) + +(do-template [<name> <base>] + [(type: #export <name> + (<base> Var Expression Expression))] + + [Operation ///.Operation] + [Phase ///.Phase] + [Handler ///.Handler] + [Bundle ///.Bundle] + ) + +(def: prefix Text "LuxRuntime") + +(def: unit (_.string synthesis.unit)) + +(def: #export variant-tag "lux-variant") + +(def: (flag value) + (-> Bit Computation) + (if value + (_.string "") + _.nil)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Computation) + (<| (_.cons/2 (_.symbol ..variant-tag)) + (_.cons/2 tag) + (_.cons/2 last?) + value)) + +(def: #export (variant [lefts right? value]) + (-> (Variant Expression) Computation) + (variant' (_.int (.int lefts)) (flag right?) value)) + +(def: #export none + Computation + (variant [0 #0 ..unit])) + +(def: #export some + (-> Expression Computation) + (|>> [0 #1] ..variant)) + +(def: #export left + (-> Expression Computation) + (|>> [0 #0] ..variant)) + +(def: #export right + (-> Expression Computation) + (|>> [0 #1] ..variant)) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.and s.local-identifier (p/wrap (list))) + (s.form (p.and s.local-identifier (p.some s.local-identifier))))) + +(syntax: (runtime: {[name args] declaration} + definition) + (let [implementation (code.local-identifier (format "@@" name)) + runtime (format prefix "__" (name.normalize name)) + @runtime (` (_.var (~ (code.text runtime)))) + argsC+ (list/map code.local-identifier args) + argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-identifier name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) + _.Computation))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (~ (case argsC+ + #.Nil + @runtime + + _ + (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) + (` (def: (~ implementation) + _.Computation + (~ (case argsC+ + #.Nil + (` (_.define (~ @runtime) [(list) #.None] (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] + (~ definition)))))))))))) + +(runtime: (slice offset length list) + (<| (_.if (_.null?/1 list) + list) + (_.if (|> offset (_.>/2 (_.int +0))) + (slice (|> offset (_.-/2 (_.int +1))) + length + (_.cdr/1 list))) + (_.if (|> length (_.>/2 (_.int +0))) + (_.cons/2 (_.car/1 list) + (slice offset + (|> length (_.-/2 (_.int +1))) + (_.cdr/1 list)))) + _.nil)) + +(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-identifier var) + (` (_.var (~ (code.text (format "LRV__" (name.normalize var))))))))) + list/join))] + (~ body)))))) + +(runtime: (lux//try op) + (with-vars [error] + (_.with-exception-handler + (_.lambda [(list error) #.None] + (..left error)) + (_.lambda [(list) #.None] + (..right (_.apply/* op (list ..unit))))))) + +(runtime: (lux//program-args program-args) + (with-vars [@loop @input @output] + (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] + (_.if (_.eqv?/2 _.nil @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) + +(def: runtime//lux + Computation + (_.begin (list @@lux//try + @@lux//program-args))) + +(def: minimum-index-length + (-> Expression Computation) + (|>> (_.+/2 (_.int +1)))) + +(def: product-element + (-> Expression Expression Computation) + (function.flip _.vector-ref/2)) + +(def: (product-tail product) + (-> Expression Computation) + (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1))))) + +(def: (updated-index min-length product) + (-> Expression Expression Computation) + (|> min-length (_.-/2 (_.length/1 product)))) + +(runtime: (product//left product index) + (let [@index_min_length (_.var "index_min_length")] + (_.begin + (list (_.define @index_min_length [(list) #.None] + (minimum-index-length index)) + (_.if (|> product _.length/1 (_.>/2 @index_min_length)) + ## No need for recursion + (product-element index product) + ## Needs recursion + (product//left (product-tail product) + (updated-index @index_min_length product))))))) + +(runtime: (product//right product index) + (let [@index_min_length (_.var "index_min_length") + @product_length (_.var "product_length") + @slice (_.var "slice") + last-element? (|> @product_length (_.=/2 @index_min_length)) + needs-recursion? (|> @product_length (_.</2 @index_min_length))] + (_.begin + (list + (_.define @index_min_length [(list) #.None] (minimum-index-length index)) + (_.define @product_length [(list) #.None] (_.length/1 product)) + (<| (_.if last-element? + (product-element index product)) + (_.if needs-recursion? + (product//right (product-tail product) + (updated-index @index_min_length product))) + ## Must slice + (_.begin + (list (_.define @slice [(list) #.None] + (_.make-vector/1 (|> @product_length (_.-/2 index)))) + (_.vector-copy!/5 @slice (_.int +0) product index @product_length) + @slice))))))) + +(runtime: (sum//get sum last? wanted-tag) + (with-vars [variant-tag sum-tag sum-flag sum-value] + (let [no-match _.nil + is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) + test-recursion (_.if is-last? + ## Must recurse. + (sum//get sum-value + (|> wanted-tag (_.-/2 sum-tag)) + last?) + no-match)] + (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] + (_.apply/* (_.global "apply") (list (_.global "values") sum))])) + (_.if (|> wanted-tag (_.=/2 sum-tag)) + (_.if (|> sum-flag (_.eqv?/2 last?)) + sum-value + test-recursion)) + (_.if (|> wanted-tag (_.>/2 sum-tag)) + test-recursion) + (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) + (|> wanted-tag (_.</2 sum-tag)))) + (variant' (|> sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) + no-match)))) + +(def: runtime//adt + Computation + (_.begin (list @@product//left + @@product//right + @@sum//get))) + +(runtime: (bit//logical-right-shift shift input) + (_.if (_.=/2 (_.int +0) shift) + input + (|> input + (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) + (_.bit-and/2 (_.int (hex "+7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit + Computation + (_.begin (list @@bit//logical-right-shift))) + +(runtime: (frac//decode input) + (with-vars [@output] + (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) + (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) + (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) + ..none + (..some @output))))) + +(def: runtime//frac + Computation + (_.begin + (list @@frac//decode))) + +(def: (check-index-out-of-bounds array idx body) + (-> Expression Expression Expression Computation) + (_.if (|> idx (_.<=/2 (_.length/1 array))) + body + (_.raise/1 (_.string "Array index out of bounds!")))) + +(runtime: (array//get array idx) + (with-vars [@temp] + (<| (check-index-out-of-bounds array idx) + (_.let (list [@temp (_.vector-ref/2 array idx)]) + (_.if (|> @temp (_.eqv?/2 _.nil)) + ..none + (..some @temp)))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds array idx) + (_.begin + (list (_.vector-set!/3 array idx value) + array)))) + +(def: runtime//array + Computation + (_.begin + (list @@array//get + @@array//put))) + +(runtime: (box//write value box) + (_.begin + (list + (_.vector-set!/3 box (_.int +0) value) + ..unit))) + +(def: runtime//box + Computation + (_.begin (list @@box//write))) + +(runtime: (io//current-time _) + (|> (_.apply/* (_.global "current-second") (list)) + (_.*/2 (_.int +1_000)) + _.exact/1)) + +(def: runtime//io + (_.begin (list @@io//current-time))) + +(def: runtime + Computation + (_.begin (list @@slice + runtime//lux + runtime//bit + runtime//adt + runtime//frac + runtime//array + runtime//box + runtime//io + ))) + +(def: #export translate + (Operation Any) + (///.with-buffer + (do ////.monad + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! "")))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux new file mode 100644 index 000000000..dc1b88591 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux @@ -0,0 +1,33 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)]]] + [// + ["." runtime (#+ Operation Phase)] + ["." primitive] + ["." /// + [analysis (#+ Variant Tuple)] + ["." synthesis (#+ Synthesis)] + [/// + [host + ["_" scheme (#+ Expression)]]]]]) + +(def: #export (tuple translate elemsS+) + (-> Phase (Tuple Synthesis) (Operation Expression)) + (case elemsS+ + #.Nil + (primitive.text synthesis.unit) + + (#.Cons singletonS #.Nil) + (translate singletonS) + + _ + (do ///.monad + [elemsT+ (monad.map @ translate elemsS+)] + (wrap (_.vector/* elemsT+))))) + +(def: #export (variant translate [lefts right? valueS]) + (-> Phase (Variant Synthesis) (Operation Expression)) + (do ///.monad + [valueT (translate valueS)] + (wrap (runtime.variant [lefts right? valueT])))) |