diff options
| -rw-r--r-- | new-luxc/source/luxc/analyser.lux | 393 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/common.lux | 78 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/lux.lux | 255 | ||||
| -rw-r--r-- | new-luxc/source/luxc/base.lux | 66 | ||||
| -rw-r--r-- | new-luxc/source/luxc/compiler.lux | 154 | ||||
| -rw-r--r-- | new-luxc/source/luxc/compiler/expr.jvm.lux | 15 | ||||
| -rw-r--r-- | new-luxc/source/luxc/compiler/runtime.jvm.lux | 7 | ||||
| -rw-r--r-- | new-luxc/source/luxc/compiler/statement.jvm.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/env.lux | 37 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang.lux | 44 | ||||
| -rw-r--r-- | new-luxc/source/luxc/module.lux | 55 | ||||
| -rw-r--r-- | new-luxc/source/luxc/module/def.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/synthesizer.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/program.lux | 5 |
14 files changed, 706 insertions, 421 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index 84719738e..2a77d8bb5 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -15,354 +15,51 @@ [type] (type ["TC" check])) (luxc ["&" base] + [lang #*] ["&;" module] - ["&;" env] - (module ["&;" def]))) + ["&;" env]) + (. ["&&;" lux])) + +(def: #export (analyse eval ast) + Analyser + (case ast + (^template [<tag> <analyser>] + [cursor (<tag> value)] + (<analyser> cursor value)) + ([#;BoolS &&lux;analyse-bool] + [#;NatS &&lux;analyse-nat] + [#;IntS &&lux;analyse-int] + [#;DegS &&lux;analyse-deg] + [#;RealS &&lux;analyse-real] + [#;CharS &&lux;analyse-char] + [#;TextS &&lux;analyse-text]) + + (^ [cursor (#;TupleS (list))]) + (&&lux;analyse-unit cursor) + + (^ [cursor (#;TupleS (list singleton))]) + (analyse eval singleton) + + (^ [cursor (#;TupleS elems)]) + (&&lux;analyse-tuple (analyse eval) cursor elems) + + [cursor (#;SymbolS reference)] + (&&lux;analyse-reference cursor reference) + + (^ [cursor (#;FormS (list [_ (#;SymbolS ["" "_lux_check"])] + type + value))]) + (&&lux;analyse-check analyse eval cursor type value) + + (^ [cursor (#;FormS (list [_ (#;SymbolS ["" "_lux_coerce"])] + type + value))]) + (&&lux;analyse-coerce analyse eval cursor type value) + + (^ [cursor (#;FormS (list [_ (#;NatS tag)] + value))]) + (&&lux;analyse-variant (analyse eval) cursor tag value) -(type: #export Pattern Void) - -(type: #export (Analysis' Analysis) - (#Bool Bool) - (#Nat Nat) - (#Int Int) - (#Deg Deg) - (#Real Real) - (#Char Char) - (#Text Text) - (#Variant Nat Bool Analysis) - #Unit - (#Tuple (List Analysis)) - (#Call Analysis (List Analysis)) - (#Case (List [Pattern Analysis])) - (#Function Scope Analysis) - (#Var Ref) - (#Def Ident) - (#Procedure Text (List Analysis)) - ) - -(type: #export #rec Analysis - (Meta [Type Cursor] - (Analysis' Analysis))) - -(def: (with-expected-type expected action) - (All [a] (-> Type (Lux a) (Lux a))) - (function [compiler] - (case (action (set@ #;expected (#;Some expected) compiler)) - (#E;Success [compiler' output]) - (let [old-expected (get@ #;expected compiler)] - (#E;Success [(set@ #;expected old-expected compiler') - output])) - - (#E;Error error) - (#E;Error error)))) - -(def: (analyse-typed-tuple analyse cursor members) - (-> (-> AST (Lux Analysis)) Cursor - (List AST) - (Lux Analysis)) - (do Monad<Lux> - [expected macro;expected-type] - (let [member-types (type;flatten-tuple expected) - num-types (list;size member-types) - num-members (list;size members)] - (cond (n.= num-types num-members) - (do @ - [=tuple (: (Lux (List Analysis)) - (mapM @ - (function [[expected member]] - (with-expected-type expected - (analyse member))) - (list;zip2 member-types members)))] - (wrap [[expected cursor] - (#Tuple =tuple)])) - - (n.< num-types num-members) - (do @ - [#let [[head-ts tail-ts] (list;split (n.- +2 num-members) - member-types)] - =prevs (mapM @ - (function [[expected member]] - (with-expected-type expected - (analyse member))) - (list;zip2 head-ts members)) - =last (with-expected-type (type;tuple tail-ts) - (analyse (default (undefined) - (list;last members))))] - (wrap [[expected cursor] - (#Tuple (L/append =prevs (list =last)))])) - - ## (n.> num-types num-members) - (do @ - [#let [[head-xs tail-xs] (list;split (n.- +2 num-types) - members)] - =prevs (mapM @ - (function [[expected member]] - (with-expected-type expected - (analyse member))) - (list;zip2 member-types head-xs)) - =last (with-expected-type (default (undefined) - (list;last member-types)) - (analyse-typed-tuple analyse cursor tail-xs))] - (wrap [[expected cursor] - (#Tuple (L/append =prevs (list =last)))])) - )))) - -(def: (within-type-env action) - (All [a] (-> (TC;Check a) (Lux a))) - (function [compiler] - (case (action (get@ #;type-context compiler)) - (#E;Error error) - (#E;Error error) - - (#E;Success [context' output]) - (#E;Success [(set@ #;type-context context' compiler) - output])))) - -(def: get-type - (-> Analysis Type) - (|>. product;left - product;left)) - -(def: (replace-type replacement analysis) - (-> Type Analysis Analysis) - (let [[[_type _cursor] _analysis] analysis] - (: Analysis - [[(: Type replacement) - (: Cursor _cursor)] - (: (Analysis' Analysis) - _analysis)]))) - -(def: (clean-analysis type analysis) - (-> Type Analysis (Lux Analysis)) - (case type - (#;VarT id) - (do Monad<Lux> - [=type (within-type-env - (TC;clean id type))] - (wrap (replace-type =type analysis))) - - (#;ExT id) - (undefined) - _ - (&;fail (format "Cannot clean type: " (%type type))))) - -(def: (with-unknown-type action) - (All [a] (-> (Lux Analysis) (Lux Analysis))) - (do Monad<Lux> - [[var-id var-type] (within-type-env - TC;create-var) - analysis (|> (wrap action) - (%> @ - [(with-expected-type var-type)] - [(clean-analysis var-type)])) - _ (within-type-env - (TC;delete-var var-id))] - (wrap analysis))) - -(def: (tuple cursor members) - (-> Cursor (List Analysis) Analysis) - (let [tuple-type (type;tuple (L/map get-type members))] - [[tuple-type cursor] - (#Tuple members)])) - -(def: (realize expected) - (-> Type (TC;Check [(List Type) Type])) - (case expected - (#;NamedT [module name] _expected) - (realize _expected) - - (#;UnivQ env body) - (do TC;Monad<Check> - [[var-id var-type] TC;create-var - [tail =expected] (realize (default (undefined) - (type;apply-type expected var-type)))] - (wrap [(list& var-type tail) - =expected])) - - (#;ExQ env body) - (do TC;Monad<Check> - [[ex-id ex-type] TC;existential - [tail =expected] (realize (default (undefined) - (type;apply-type expected ex-type)))] - (wrap [(list& ex-type tail) - =expected])) - - _ - (:: TC;Monad<Check> wrap [(list) expected]))) - -(def: (analyse-tuple analyse cursor members) - (-> (-> AST (Lux Analysis)) Cursor - (List AST) - (Lux Analysis)) - (do Monad<Lux> - [expected macro;expected-type] - (case expected - (#;ProdT _) - (analyse-typed-tuple analyse cursor members) - - (#;VarT id) - (do @ - [bound? (within-type-env - (TC;bound? id))] - (if bound? - (do @ - [expected' (within-type-env - (TC;read-var id)) - =tuple (with-expected-type expected' - (analyse-tuple analyse cursor members))] - (wrap (replace-type expected =tuple))) - (do @ - [=members (mapM @ (<|. with-unknown-type - analyse) - members) - #let [=tuple (tuple cursor =members)] - _ (within-type-env - (TC;check expected (get-type =tuple)))] - (wrap (replace-type expected =tuple))))) - - _ - (if (type;quantified? expected) - (do @ - [[bindings expected'] (within-type-env - (realize expected)) - =tuple (with-expected-type expected' - (analyse-tuple analyse cursor members)) - =tuple (foldM @ clean-analysis =tuple bindings) - _ (within-type-env - (TC;check expected (get-type =tuple)))] - (wrap (replace-type expected =tuple))) - (&;fail (format "Invalid type for tuple: " (%type expected)))) - ))) - -(def: (analyse-variant analyse cursor tag value) - (-> (-> AST (Lux Analysis)) Cursor - Nat AST - (Lux Analysis)) - (do Monad<Lux> - [expected macro;expected-type] - (case expected - (#;SumT _) - (let [flat (type;flatten-variant expected) - type-size (list;size flat)] - (if (n.< type-size tag) - (do @ - [#let [last? (n.= tag (n.dec type-size)) - variant-type (default (undefined) - (list;nth tag flat))] - =value (with-expected-type variant-type - (analyse value))] - (wrap [[expected cursor] - (#Variant tag last? =value)])) - (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n" - "Tag: " (%n tag) "\n" - "Type size: " (%n type-size) "\n" - "Type: " (%type expected) "\n")))) - - _ - (if (type;quantified? expected) - (do @ - [[bindings expected'] (within-type-env - (realize expected)) - =variant (with-expected-type expected' - (analyse-variant analyse cursor tag value)) - =variant (foldM @ clean-analysis =variant bindings) - _ (within-type-env - (TC;check expected (get-type =variant)))] - (wrap (replace-type expected =variant))) - (&;fail (format "Invalid type for variant: " (%type expected))))))) - -(def: (analyse eval ast) - (-> (-> Type AST (Lux Top)) AST (Lux Analysis)) - (do Monad<Lux> - [] - (case ast - (^template [<ast-tag> <analysis-tag> <type>] - [cursor (<ast-tag> value)] - (do @ - [expected macro;expected-type - _ (within-type-env - (TC;check expected <type>))] - (wrap [[<type> cursor] - (<analysis-tag> value)]))) - ([#;BoolS #Bool Bool] - [#;NatS #Nat Nat] - [#;IntS #Int Int] - [#;DegS #Deg Deg] - [#;RealS #Real Real] - [#;CharS #Char Char] - [#;TextS #Text Text]) - - (^ [cursor (#;TupleS (list))]) - (do @ - [expected macro;expected-type - _ (within-type-env - (TC;check expected Unit))] - (wrap [[Unit cursor] - #Unit])) - - (^ [cursor (#;TupleS (list singleton))]) - (analyse eval singleton) - - (^ [cursor (#;TupleS elems)]) - (do @ - [expected macro;expected-type] - (with-expected-type expected - (analyse-tuple (analyse eval) cursor elems))) - - [cursor (#;SymbolS ["" local-name])] - (do @ - [?local (&env;find local-name)] - (case ?local - (#;Some [actual index]) - (do @ - [expected macro;expected-type - _ (within-type-env - (TC;check expected actual))] - (wrap [[expected cursor] - (#Var index)])) - - #;None - (do @ - [this-module macro;current-module-name] - (analyse eval [cursor (#;SymbolS [this-module local-name])])))) - - [cursor (#;SymbolS def-name)] - (do @ - [expected macro;expected-type - actual (&def;find def-name) - _ (within-type-env - (TC;check expected actual))] - (wrap [[expected cursor] - (#Def def-name)])) - - (^ [cursor (#;FormS (list [_ (#;SymbolS ["" "_lux_check"])] - type - value))]) - (do @ - [expected macro;expected-type - actual (eval Type type) - _ (within-type-env - (TC;check expected actual))] - (with-expected-type actual - (analyse eval value))) - - (^ [cursor (#;FormS (list [_ (#;SymbolS ["" "_lux_coerce"])] - type - value))]) - (do @ - [expected macro;expected-type - actual (eval Type type) - _ (within-type-env - (TC;check expected actual)) - =value (with-expected-type Top - (analyse eval value))] - (wrap (replace-type actual =value))) - - (^ [cursor (#;FormS (list [_ (#;NatS tag)] - value))]) - (analyse-variant (analyse eval) cursor tag value) - - _ - (&;fail (format "Unrecognized syntax: " (%ast ast))) - ))) + (&;fail (format "Unrecognized syntax: " (%ast ast))) + )) diff --git a/new-luxc/source/luxc/analyser/common.lux b/new-luxc/source/luxc/analyser/common.lux new file mode 100644 index 000000000..0deceaa39 --- /dev/null +++ b/new-luxc/source/luxc/analyser/common.lux @@ -0,0 +1,78 @@ +(;module: + lux + (lux (control monad + pipe) + (data text/format + [product]) + [macro #+ Monad<Lux>] + [type] + (type ["TC" check])) + (luxc ["&" base] + lang)) + +(def: #export get-type + (-> Analysis Type) + (|>. product;left + product;left)) + +(def: #export (replace-type replacement analysis) + (-> Type Analysis Analysis) + (let [[[_type _cursor] _analysis] analysis] + (: Analysis + [[(: Type replacement) + (: Cursor _cursor)] + (: (Analysis' Analysis) + _analysis)]))) + +(def: #export (clean type analysis) + (-> Type Analysis (Lux Analysis)) + (case type + (#;VarT id) + (do Monad<Lux> + [=type (&;within-type-env + (TC;clean id type))] + (wrap (replace-type =type analysis))) + + (#;ExT id) + (undefined) + + _ + (&;fail (format "Cannot clean type: " (%type type))))) + +(def: #export (with-unknown-type action) + (All [a] (-> (Lux Analysis) (Lux Analysis))) + (do Monad<Lux> + [[var-id var-type] (&;within-type-env + TC;create-var) + analysis (|> (wrap action) + (%> @ + [(&;with-expected-type var-type)] + [(clean var-type)])) + _ (&;within-type-env + (TC;delete-var var-id))] + (wrap analysis))) + +(def: #export (realize expected) + (-> Type (TC;Check [(List Type) Type])) + (case expected + (#;NamedT [module name] _expected) + (realize _expected) + + (#;UnivQ env body) + (do TC;Monad<Check> + [[var-id var-type] TC;create-var + [tail =expected] (realize (default (undefined) + (type;apply-type expected var-type)))] + (wrap [(list& var-type tail) + =expected])) + + (#;ExQ env body) + (do TC;Monad<Check> + [[ex-id ex-type] TC;existential + [tail =expected] (realize (default (undefined) + (type;apply-type expected ex-type)))] + (wrap [(list& ex-type tail) + =expected])) + + _ + (:: TC;Monad<Check> wrap [(list) expected]))) diff --git a/new-luxc/source/luxc/analyser/lux.lux b/new-luxc/source/luxc/analyser/lux.lux new file mode 100644 index 000000000..24ac1e093 --- /dev/null +++ b/new-luxc/source/luxc/analyser/lux.lux @@ -0,0 +1,255 @@ +(;module: + lux + (lux (control monad + pipe) + [io #- run] + (concurrency ["A" atom]) + (data ["E" error] + [text "T/" Eq<Text>] + text/format + (coll [list "L/" Fold<List> Monoid<List> Monad<List>] + ["D" dict]) + [number] + [product]) + [macro #+ Monad<Lux>] + [type] + (type ["TC" check])) + (luxc ["&" base] + [lang #*] + ["&;" module] + ["&;" env] + (analyser ["&;" common]))) + +(do-template [<name> <type> <tag>] + [(def: #export (<name> cursor value) + (-> Cursor <type> (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type + _ (&;within-type-env + (TC;check expected <type>))] + (wrap [[expected cursor] + (#lang;Primitive (<tag> value))])))] + + [analyse-bool Bool #lang;Bool] + [analyse-nat Nat #lang;Nat] + [analyse-int Int #lang;Int] + [analyse-deg Deg #lang;Deg] + [analyse-real Real #lang;Real] + [analyse-char Char #lang;Char] + [analyse-text Text #lang;Text] + ) + +(def: #export (analyse-unit cursor) + (-> Cursor (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type + _ (&;within-type-env + (TC;check expected Unit))] + (wrap [[expected cursor] + (#lang;Primitive #lang;Unit)]))) + +(def: #export (analyse-definition cursor def-name) + (-> Cursor Ident (Lux Analysis)) + (do Monad<Lux> + [actual (macro;find-def-type def-name) + expected macro;expected-type + _ (&;within-type-env + (TC;check expected actual))] + (wrap [[expected cursor] + (#lang;Reference (#lang;Absolute def-name))]))) + +(def: #export (analyse-variable cursor var-name) + (-> Cursor Text (Lux (Maybe Analysis))) + (do Monad<Lux> + [?var (&env;find var-name)] + (case ?var + (#;Some [actual ref]) + (do @ + [expected macro;expected-type + _ (&;within-type-env + (TC;check expected actual)) + #let [analysis [[expected cursor] + (#lang;Reference (#lang;Relative ref))]]] + (wrap (#;Some analysis))) + + #;None + (wrap #;None)))) + +(def: #export (analyse-reference cursor reference) + (-> Cursor Ident (Lux Analysis)) + (case reference + ["" simple-name] + (do Monad<Lux> + [?var (analyse-variable cursor simple-name)] + (case ?var + (#;Some analysis) + (wrap analysis) + + #;None + (do @ + [this-module macro;current-module-name] + (analyse-definition cursor [this-module simple-name])))) + + _ + (analyse-definition cursor reference))) + +(def: #export (analyse-check analyse eval cursor type value) + (-> Analyser Eval Cursor AST AST (Lux Analysis)) + (do Monad<Lux> + [actual (eval Type type) + #let [actual (:! Type actual)] + expected macro;expected-type + _ (&;within-type-env + (TC;check expected actual))] + (&;with-expected-type actual + (analyse eval value)))) + +(def: #export (analyse-coerce analyse eval cursor type value) + (-> Analyser Eval Cursor AST AST (Lux Analysis)) + (do Monad<Lux> + [actual (eval Type type) + #let [actual (:! Type actual)] + expected macro;expected-type + _ (&;within-type-env + (TC;check expected actual)) + =value (&;with-expected-type Top + (analyse eval value))] + (wrap (&common;replace-type actual =value)))) + +(def: (analyse-typed-tuple analyse cursor members) + (-> (-> AST (Lux Analysis)) Cursor + (List AST) + (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type] + (let [member-types (type;flatten-tuple expected) + num-types (list;size member-types) + num-members (list;size members)] + (cond (n.= num-types num-members) + (do @ + [=tuple (: (Lux (List Analysis)) + (mapM @ + (function [[expected member]] + (&;with-expected-type expected + (analyse member))) + (list;zip2 member-types members)))] + (wrap [[expected cursor] + (#lang;Structure (#lang;Tuple =tuple))])) + + (n.< num-types num-members) + (do @ + [#let [[head-ts tail-ts] (list;split (n.- +2 num-members) + member-types)] + =prevs (mapM @ + (function [[expected member]] + (&;with-expected-type expected + (analyse member))) + (list;zip2 head-ts members)) + =last (&;with-expected-type (type;tuple tail-ts) + (analyse (default (undefined) + (list;last members))))] + (wrap [[expected cursor] + (#lang;Structure (#lang;Tuple (L/append =prevs (list =last))))])) + + ## (n.> num-types num-members) + (do @ + [#let [[head-xs tail-xs] (list;split (n.- +2 num-types) + members)] + =prevs (mapM @ + (function [[expected member]] + (&;with-expected-type expected + (analyse member))) + (list;zip2 member-types head-xs)) + =last (&;with-expected-type (default (undefined) + (list;last member-types)) + (analyse-typed-tuple analyse cursor tail-xs))] + (wrap [[expected cursor] + (#lang;Structure (#lang;Tuple (L/append =prevs (list =last))))])) + )))) + +(def: (tuple cursor members) + (-> Cursor (List Analysis) Analysis) + (let [tuple-type (type;tuple (L/map &common;get-type members))] + [[tuple-type cursor] + (#lang;Structure (#lang;Tuple members))])) + +(def: #export (analyse-tuple analyse cursor members) + (-> (-> AST (Lux Analysis)) Cursor + (List AST) + (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type] + (case expected + (#;ProdT _) + (analyse-typed-tuple analyse cursor members) + + (#;VarT id) + (do @ + [bound? (&;within-type-env + (TC;bound? id))] + (if bound? + (do @ + [expected' (&;within-type-env + (TC;read-var id)) + =tuple (&;with-expected-type expected' + (analyse-tuple analyse cursor members))] + (wrap (&common;replace-type expected =tuple))) + (do @ + [=members (mapM @ (<|. &common;with-unknown-type + analyse) + members) + #let [=tuple (tuple cursor =members)] + _ (&;within-type-env + (TC;check expected (&common;get-type =tuple)))] + (wrap (&common;replace-type expected =tuple))))) + + _ + (if (type;quantified? expected) + (do @ + [[bindings expected'] (&;within-type-env + (&common;realize expected)) + =tuple (&;with-expected-type expected' + (analyse-tuple analyse cursor members)) + =tuple (foldM @ &common;clean =tuple bindings) + _ (&;within-type-env + (TC;check expected (&common;get-type =tuple)))] + (wrap (&common;replace-type expected =tuple))) + (&;fail (format "Invalid type for tuple: " (%type expected)))) + ))) + +(def: #export (analyse-variant analyse cursor tag value) + (-> (-> AST (Lux Analysis)) Cursor + Nat AST + (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type] + (case expected + (#;SumT _) + (let [flat (type;flatten-variant expected) + type-size (list;size flat)] + (if (n.< type-size tag) + (do @ + [#let [last? (n.= tag (n.dec type-size)) + variant-type (default (undefined) + (list;nth tag flat))] + =value (&;with-expected-type variant-type + (analyse value))] + (wrap [[expected cursor] + (#lang;Structure (#lang;Variant tag last? =value))])) + (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n" + " Tag: " (%n tag) "\n" + "Type size: " (%n type-size) "\n" + " Type: " (%type expected) "\n")))) + + _ + (if (type;quantified? expected) + (do @ + [[bindings expected'] (&;within-type-env + (&common;realize expected)) + =variant (&;with-expected-type expected' + (analyse-variant analyse cursor tag value)) + =variant (foldM @ &common;clean =variant bindings) + _ (&;within-type-env + (TC;check expected (&common;get-type =variant)))] + (wrap (&common;replace-type expected =variant))) + (&;fail (format "Invalid type for variant: " (%type expected))))))) diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux index ce872e9da..8660d7ccf 100644 --- a/new-luxc/source/luxc/base.lux +++ b/new-luxc/source/luxc/base.lux @@ -1,8 +1,11 @@ (;module: lux (lux (control monad) - (data text/format) - [macro #+ Monad<Lux>])) + (data [text "T/" Eq<Text>] + text/format + ["E" error]) + [macro #+ Monad<Lux>] + (type ["TC" check]))) (type: #export Path Text) @@ -19,3 +22,62 @@ "," (|> col nat-to-int %i))]] (macro;fail (format "@ " location "\n" message)))) + +(def: #export (with-expected-type expected action) + (All [a] (-> Type (Lux a) (Lux a))) + (function [compiler] + (case (action (set@ #;expected (#;Some expected) compiler)) + (#E;Success [compiler' output]) + (let [old-expected (get@ #;expected compiler)] + (#E;Success [(set@ #;expected old-expected compiler') + output])) + + (#E;Error error) + (#E;Error error)))) + +(def: #export (within-type-env action) + (All [a] (-> (TC;Check a) (Lux a))) + (function [compiler] + (case (action (get@ #;type-context compiler)) + (#E;Error error) + (#E;Error error) + + (#E;Success [context' output]) + (#E;Success [(set@ #;type-context context' compiler) + output])))) + +(def: #export (pl::put key val table) + (All [a] (-> Text a (List [Text a]) (List [Text a]))) + (case table + #;Nil + (list [key val]) + + (#;Cons [k' v'] table') + (if (T/= key k') + (#;Cons [key val] + table') + (#;Cons [k' v'] + (pl::put key val table'))))) + +(def: #export (pl::get key table) + (All [a] (-> Text (List [Text a]) (Maybe a))) + (case table + #;Nil + #;None + + (#;Cons [k' v'] table') + (if (T/= key k') + (#;Some v') + (pl::get key table')))) + +(def: #export (with-source-code source action) + (All [a] (-> [Cursor Text] (Lux a) (Lux a))) + (function [compiler] + (let [old-source (get@ #;source compiler)] + (case (action (set@ #;source source compiler)) + (#E;Error error) + (#E;Error error) + + (#E;Success [compiler' output]) + (#E;Success [(set@ #;source old-source compiler') + output]))))) diff --git a/new-luxc/source/luxc/compiler.lux b/new-luxc/source/luxc/compiler.lux index 205c62df0..4ac865786 100644 --- a/new-luxc/source/luxc/compiler.lux +++ b/new-luxc/source/luxc/compiler.lux @@ -1,14 +1,15 @@ (;module: lux (lux (control monad) - [io #- run] + (concurrency ["P" promise]) (data ["E" error] - [text "T/" Eq<Text>] + [text "T/" Hash<Text>] text/format) [macro #+ Monad<Lux>]) (luxc ["&" base] ["&;" io] ["&;" module] + ["&;" parser] (compiler ["&&;" runtime] ["&&;" statement]) )) @@ -36,60 +37,119 @@ [result action] (exhaust action))) -(def: (compile-module source-dirs module-name compiler-state) - (-> (List &;Path) Text Compiler (IO (Error Compiler))) - (do Monad<IO> - [[file-name file-content] (&io;read-module source-dirs module-name) - #let [file-hash (T/hash file-content)] - #let [result (macro;run compiler-state - (do Monad<Lux> - [module-exists? (&module;exists? module-name)] - (if module-exists? - (&;fail (format "Cannot re-define a module: " module-name)) - (wrap []))))]] - (case result - (#E;Success [compiler-state _]) - (let [result (macro;run compiler-state - (do Monad<Lux> - [_ (&module;create module-name file-hash) - _ (&module;flag-active module-name) - _ (if (T/= "lux" module-name) - &&runtime;compile-runtime - (wrap [])) - _ (exhaust - (do @ - [ast parse] - (compile ast))) - _ (&module;flag-compiled module-name)] - (&module;generate-module file-hash module-name)))] - (case result - (#E;Success [compiler-state module-descriptor]) - (do @ - [_ (&io;write-module module-name module-descriptor)] - (wrap (#E;Success compiler-state))) +(def: (ensure-new-module! file-hash module-name) + (-> Nat Text (Lux Unit)) + (do Monad<Lux> + [module-exists? (macro;module-exists? module-name) + _ (: (Lux Unit) + (if module-exists? + (&;fail (format "Cannot re-define a module: " module-name)) + (wrap []))) + _ (&module;create file-hash module-name)] + (wrap []))) + +(def: prelude Text "lux") + +(def: (with-active-compilation [module-name file-name source-code] action) + (All [a] (-> [Text Text Text] (Lux a) (Lux a))) + (do Monad<Lux> + [_ (ensure-new-module! (T/hash source-code) module-name) + #let [init-cursor [file-name +0 +0]] + output (&;with-source-code [init-cursor source-code] + action) + _ (&module;flag-compiled! module-name)] + (wrap output))) +(def: parse + (Lux AST) + (function [compiler] + (case (&parser;parse (get@ #;source compiler)) + (#E;Error error) + (#E;Error error) + + (#E;Success [source' output]) + (#E;Success [(set@ #;source source' compiler) + output])))) + +(def: (compile-module source-dirs module-name compiler) + (-> (List &;Path) Text Compiler (P;Promise (E;Error Compiler))) + (do P;Monad<Promise> + [?input (&io;read-module source-dirs module-name)] + (case ?input + (#E;Success [file-name file-content]) + (let [compilation (do Monad<Lux> + [_ (with-active-compilation [module-name + file-name + file-content] + (exhaust + (do @ + [ast parse] + (compile ast))))] + (wrap []) + ## (&module;generate-descriptor module-name) + )] + (case (macro;run' compiler compilation) + (#E;Success [compiler module-descriptor]) + (do @ + [## _ (&io;write-module module-name module-descriptor) + ] + (wrap (#E;Success compiler))) + (#E;Error error) (wrap (#E;Error error)))) - + (#E;Error error) (wrap (#E;Error error))))) -(def: (or-crash! action) - (All [a] (-> (IO (E;Error a)) (IO a))) - (do Monad<IO> - [result action] - (case result - (#E;Success output) - (wrap output) +(type: Host Unit) + +(def: init-host Host []) + +(def: init-cursor Cursor ["" +0 +0]) + +(def: init-type-context + Type-Context + {#;ex-counter +0 + #;var-counter +0 + #;var-bindings (list)}) +(def: compiler-version Text "0.6.0") + +(def: init-compiler-info + Compiler-Info + {#;compiler-version compiler-version + #;compiler-mode #;Release}) + +(def: (init-compiler host) + (-> Host Compiler) + {#;info init-compiler-info + #;source [init-cursor ""] + #;cursor init-cursor + #;modules (list) + #;scopes (list) + #;type-context init-type-context + #;expected #;None + #;seed +0 + #;scope-type-vars (list) + #;host (:! Void host)}) + +(def: (or-crash! action) + (All [a] (-> (P;Promise (E;Error a)) (P;Promise a))) + (do P;Monad<Promise> + [?output action] + (case ?output (#E;Error error) - (error! (format "Compilation failed:\n" error))))) + (error! error) + + (#E;Success output) + (wrap output)))) (def: #export (compile-program mode program target sources) - (-> &;Mode &;Path &;Path (List &;Path) (IO Unit)) - (do Monad<IO> - [#let [compiler-state (init-compiler-state mode host-state)] - compiler-state (or-crash! (compile-module source-dirs "lux" compiler-state)) - compiler-state (or-crash! (compile-module source-dirs program compiler-state)) + (-> &;Mode &;Path &;Path (List &;Path) (P;Promise Unit)) + (do P;Monad<Promise> + [#let [compiler (init-compiler init-host)] + _ (or-crash! (&&runtime;compile-runtime [])) + compiler (or-crash! (compile-module sources prelude compiler)) + compiler (or-crash! (compile-module sources program compiler)) #let [_ (log! "Compilation complete!")]] (wrap []))) diff --git a/new-luxc/source/luxc/compiler/expr.jvm.lux b/new-luxc/source/luxc/compiler/expr.jvm.lux index 6655abd5f..138d0d540 100644 --- a/new-luxc/source/luxc/compiler/expr.jvm.lux +++ b/new-luxc/source/luxc/compiler/expr.jvm.lux @@ -2,26 +2,29 @@ lux (lux (control monad) (data text/format) - [macro #+ Monad<Lux>]) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>]) (luxc ["&" base] - ["&;" module] - ["&;" env] + lang ["&;" analyser] - ["&;" synthesizer #+ Synthesis])) + ["&;" synthesizer])) (type: #export JVM-Bytecode Void) -(type: Compiled +(type: #export Compiled JVM-Bytecode) (def: (compile-synthesis synthesis) (-> Synthesis Compiled) (undefined)) +(def: (eval type code) + Eval + (undefined)) + (def: #export (compile input) (-> AST (Lux Compiled)) (|> input - &analyser;analyse + (&analyser;analyse eval) (Lux/map &synthesizer;synthesize) (Lux/map compile-synthesis))) diff --git a/new-luxc/source/luxc/compiler/runtime.jvm.lux b/new-luxc/source/luxc/compiler/runtime.jvm.lux index 2d48b3617..b6cebb193 100644 --- a/new-luxc/source/luxc/compiler/runtime.jvm.lux +++ b/new-luxc/source/luxc/compiler/runtime.jvm.lux @@ -1,6 +1,11 @@ (;module: lux (lux (control monad) - (data text/format)) + (concurrency ["P" promise "P/" Monad<Promise>]) + (data text/format + ["E" error])) (luxc ["&" base])) +(def: #export (compile-runtime _) + (-> Top (P;Promise (E;Error Unit))) + (P/wrap (#E;Success []))) diff --git a/new-luxc/source/luxc/compiler/statement.jvm.lux b/new-luxc/source/luxc/compiler/statement.jvm.lux index c4c23746e..0e53ba37d 100644 --- a/new-luxc/source/luxc/compiler/statement.jvm.lux +++ b/new-luxc/source/luxc/compiler/statement.jvm.lux @@ -11,16 +11,16 @@ ["&;" env] (compiler ["&;" expr]))) -(def: (compile-def def-name def-value def-meta) +(def: #export (compile-def def-name def-value def-meta) (-> Text AST AST (Lux Unit)) (do Monad<Lux> [=def-value (&expr;compile def-value) =def-meta (&expr;compile def-meta)] (undefined))) -(def: (compile-program prog-args prog-body) +(def: #export (compile-program prog-args prog-body) (-> Text AST (Lux Unit)) (do Monad<Lux> [=prog-body (&env;with-local [prog-args (type (List Text))] - (&expr;compile prog-body))] + (&expr;compile prog-body))] (undefined))) diff --git a/new-luxc/source/luxc/env.lux b/new-luxc/source/luxc/env.lux index be68f84e9..338375a29 100644 --- a/new-luxc/source/luxc/env.lux +++ b/new-luxc/source/luxc/env.lux @@ -5,9 +5,12 @@ text/format [maybe #+ Monad<Maybe> "Maybe/" Monad<Maybe>] [product] - (coll [list "L/" Fold<List> Monoid<List>]))) + ["E" error] + (coll [list "L/" Fold<List> Monoid<List>])) + [macro]) (luxc ["&" base])) +(type: Locals (Bindings Text [Type Nat])) (type: Captured (Bindings Text [Type Ref])) (def: (pl::contains? key mappings) @@ -104,3 +107,35 @@ (#;Right [(set@ #;scopes scopes compiler) (#;Some [ref-type ref])])) )))) + +(def: #export (with-local [name type] action) + (All [a] (-> [Text Type] (Lux a) (Lux a))) + (function [compiler] + (case (get@ #;scopes compiler) + (#;Cons head tail) + (let [old-mappings (get@ [#;locals #;mappings] head) + new-var-id (get@ [#;locals #;counter] head) + new-head (update@ #;locals + (: (-> Locals Locals) + (|>. (update@ #;counter n.inc) + (update@ #;mappings (pl::put name [type new-var-id])))) + head)] + (case (macro;run' (set@ #;scopes (#;Cons new-head tail) compiler) + action) + (#E;Success [compiler' output]) + (case (get@ #;scopes compiler') + (#;Cons head' tail') + (let [scopes' (#;Cons (set@ #;locals (get@ #;locals head) head') + tail')] + (#E;Success [(set@ #;scopes scopes' compiler') + output])) + + _ + (error! "Invalid scope alteration.")) + + (#E;Error error) + (#E;Error error))) + + _ + (#E;Error "Cannot create local binding without a scope.")) + )) diff --git a/new-luxc/source/luxc/lang.lux b/new-luxc/source/luxc/lang.lux new file mode 100644 index 000000000..0c5c97192 --- /dev/null +++ b/new-luxc/source/luxc/lang.lux @@ -0,0 +1,44 @@ +(;module: + lux) + +(type: #export (Pattern a) Void) + +(type: #export Primitive + #Unit + (#Bool Bool) + (#Nat Nat) + (#Int Int) + (#Deg Deg) + (#Real Real) + (#Char Char) + (#Text Text)) + +(type: #export Reference + (#Relative Ref) + (#Absolute Ident)) + +(type: #export (Structure a) + (#Variant Nat Bool a) + (#Tuple (List a)) + (#Case (Pattern a)) + (#Function Scope a) + (#Call a (List a)) + (#Procedure Text (List a))) + +(type: #export (Analysis' Analysis) + (#Primitive Primitive) + (#Structure (Structure Analysis)) + (#Reference Reference)) + +(type: #export #rec Analysis + (Meta [Type Cursor] + (Analysis' Analysis))) + +(type: #export Synthesis + Unit) + +(type: #export Eval + (-> Type AST (Lux Top))) + +(type: #export Analyser + (-> Eval AST (Lux Analysis))) diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux index 2d48b3617..e5848fccb 100644 --- a/new-luxc/source/luxc/module.lux +++ b/new-luxc/source/luxc/module.lux @@ -1,6 +1,59 @@ (;module: lux (lux (control monad) - (data text/format)) + (data [text "T/" Eq<Text>] + text/format + ["E" error])) (luxc ["&" base])) +(def: (new-module hash) + (-> Nat Module) + {#;module-hash hash + #;module-aliases (list) + #;defs (list) + #;imports (list) + #;tags (list) + #;types (list) + #;module-anns (list) + #;module-state #;Active}) + +(def: #export (create hash name) + (-> Nat Text (Lux Module)) + (function [compiler] + (let [module (new-module hash)] + (#E;Success [(update@ #;modules + (&;pl::put name module) + compiler) + module])))) + +(do-template [<flagger> <asker> <tag>] + [(def: #export (<flagger> module-name) + (-> Text (Lux Unit)) + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl::get module-name)) + (#;Some module) + (#E;Success [(update@ #;modules + (&;pl::put module-name (set@ #;module-state <tag> module)) + compiler) + []]) + + #;None + (#E;Error (format "Module does not exist: " module-name))))) + (def: #export (<asker> module-name) + (-> Text (Lux Bool)) + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl::get module-name)) + (#;Some module) + (#E;Success [compiler + (case (get@ #;module-state module) + <tag> true + _ false)]) + + #;None + (#E;Error (format "Module does not exist: " module-name))) + ))] + + [flag-active! active? #;Active] + [flag-compiled! compiled? #;Compiled] + [flag-cached! cached? #;Cached] + ) diff --git a/new-luxc/source/luxc/module/def.lux b/new-luxc/source/luxc/module/def.lux deleted file mode 100644 index 2d48b3617..000000000 --- a/new-luxc/source/luxc/module/def.lux +++ /dev/null @@ -1,6 +0,0 @@ -(;module: - lux - (lux (control monad) - (data text/format)) - (luxc ["&" base])) - diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index 682bbe3ec..900c16e05 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -4,10 +4,8 @@ (data text/format) [macro #+ Monad<Lux>]) (luxc ["&" base] - ["&;" analyser #+ Analysis])) - -(type: #export Synthesis - Unit) + lang + ["&;" analyser])) (def: #export (synthesize analysis) (-> Analysis Synthesis) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index 07f21962b..e7fa95c2d 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -41,7 +41,8 @@ [sources (cli;some (tagged (list "-s" "--source")))]) (case command #;None - (io (log! "Hello, REPL!")) + (io (log! "No REPL for you!")) (#;Some [mode program target]) - (&compiler;compile-program mode program target sources))) + (exec (&compiler;compile-program mode program target sources) + (io [])))) |