diff options
Diffstat (limited to 'stdlib/source/lux/lang/compiler/analysis.lux')
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis.lux | 281 |
1 files changed, 281 insertions, 0 deletions
diff --git a/stdlib/source/lux/lang/compiler/analysis.lux b/stdlib/source/lux/lang/compiler/analysis.lux new file mode 100644 index 000000000..235e399fb --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis.lux @@ -0,0 +1,281 @@ +(.module: + [lux #- nat int deg] + (lux (data [product] + [error] + [text "text/" Eq<Text>] + (coll [list "list/" Fold<List>])) + [function]) + [///reference #+ Register Variable Reference] + [//]) + +(type: #export #rec Primitive + #Unit + (#Bool Bool) + (#Nat Nat) + (#Int Int) + (#Deg Deg) + (#Frac Frac) + (#Text Text)) + +(type: #export Tag Nat) + +(type: #export (Composite a) + (#Sum (Either a a)) + (#Product [a 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)) + +(type: #export Operation + (//.Operation .Lux)) + +(type: #export Compiler + (//.Compiler .Lux Code 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))] + + [bool Bool #Bool] + [nat Nat #Nat] + [int Int #Int] + [deg Deg #Deg] + [frac Frac #Frac] + [text Text #Text] + ) + +(type: #export (Variant a) + {#lefts Nat + #right? Bool + #value a}) + +(type: #export (Tuple a) (List a)) + +(type: #export Arity Nat) + +(type: #export (Abstraction c) [Environment Arity c]) + +(type: #export (Application c) [c (List c)]) + +(def: (last? size tag) + (-> Nat Tag Bool) + (n/= (dec size) tag)) + +(template: #export (no-op value) + (|> +1 #///reference.Local #///reference.Variable #..Reference + (#..Function (list)) + (#..Apply value))) + +(do-template [<name> <type> <structure> <prep-value>] + [(def: #export (<name> size tag value) + (-> Nat Tag <type> <type>) + (let [left (function.constant (|>> #.Left #Sum <structure>)) + right (|>> #.Right #Sum <structure>)] + (if (last? size tag) + (if (n/= +1 tag) + (right value) + (list/fold left + (right value) + (list.n/range +0 (n/- +2 tag)))) + (list/fold left + (case value + (<structure> (#Sum _)) + (<prep-value> value) + + _ + value) + (list.n/range +0 tag)))))] + + [sum-analysis Analysis #Structure no-op] + [sum-pattern Pattern #Complex id] + ) + +(do-template [<name> <type> <primitive> <structure>] + [(def: #export (<name> members) + (-> (Tuple <type>) <type>) + (case (list.reverse members) + #.Nil + (<primitive> #Unit) + + (#.Cons singleton #.Nil) + singleton + + (#.Cons last prevs) + (list/fold (function (_ left right) (<structure> (#Product left right))) + last prevs)))] + + [product-analysis Analysis #Primitive #Structure] + [product-pattern Pattern #Simple #Complex] + ) + +(def: #export (apply [func args]) + (-> (Application Analysis) Analysis) + (list/fold (function (_ arg func) (#Apply arg func)) func args)) + +(do-template [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (Tuple <type>)) + (case value + (<tag> (#Product left right)) + (#.Cons left (<name> right)) + + _ + (list value)))] + + [tuple Analysis #Structure] + [tuple-pattern Pattern #Complex] + ) + +(do-template [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (Maybe (Variant <type>))) + (loop [lefts +0 + variantA value] + (case variantA + (<tag> (#Sum (#.Left valueA))) + (case valueA + (<tag> (#Sum _)) + (recur (inc lefts) valueA) + + _ + (#.Some {#lefts lefts + #right? false + #value valueA})) + + (<tag> (#Sum (#.Right valueA))) + (#.Some {#lefts lefts + #right? true + #value valueA}) + + _ + #.None)))] + + [variant Analysis #Structure] + [variant-pattern Pattern #Complex] + ) + +(def: #export (application analysis) + (-> Analysis (Application Analysis)) + (case analysis + (#Apply head func) + (let [[func' tail] (application func)] + [func' (#.Cons head tail)]) + + _ + [analysis (list)])) + +(template: #export (pattern/unit) + (#..Simple #..Unit)) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (#..Simple (<tag> content)))] + + [pattern/bool #..Bool] + [pattern/nat #..Nat] + [pattern/int #..Int] + [pattern/deg #..Deg] + [pattern/frac #..Frac] + [pattern/text #..Text] + ) + +(def: #export (with-source-code source action) + (All [a] (-> Source (Operation a) (Operation a))) + (function (_ compiler) + (let [old-source (get@ #.source compiler)] + (case (action (set@ #.source source compiler)) + (#error.Error error) + (#error.Error error) + + (#error.Success [compiler' output]) + (#error.Success [(set@ #.source old-source compiler') + output]))))) + +(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 (_ compiler) + (case (action (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler)) + (#error.Success [compiler' output]) + (case (get@ #.scopes compiler') + #.Nil + (#error.Error "Impossible error: Drained scopes!") + + (#.Cons head tail) + (#error.Success [(set@ #.scopes tail compiler') + [head output]])) + + (#error.Error error) + (#error.Error error)))) + +(def: #export (with-current-module name action) + (All [a] (-> Text (Operation a) (Operation a))) + (function (_ compiler) + (case (action (set@ #.current-module (#.Some name) compiler)) + (#error.Success [compiler' output]) + (#error.Success [(set@ #.current-module + (get@ #.current-module compiler) + compiler') + output]) + + (#error.Error error) + (#error.Error error)))) + +(def: #export (with-cursor cursor action) + (All [a] (-> Cursor (Operation a) (Operation a))) + (if (text/= "" (product.left cursor)) + action + (function (_ compiler) + (let [old-cursor (get@ #.cursor compiler)] + (case (action (set@ #.cursor cursor compiler)) + (#error.Success [compiler' output]) + (#error.Success [(set@ #.cursor old-cursor compiler') + output]) + + (#error.Error error) + (#error.Error error)))))) |