diff options
Diffstat (limited to '')
20 files changed, 1128 insertions, 684 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index 05a755b08..b220fb433 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -1,14 +1,9 @@ (;module: lux - (lux (control monad - pipe) - [io #- run] - (concurrency ["A" atom]) + (lux (control monad) (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>] @@ -18,48 +13,91 @@ (lang ["la" analysis]) ["&;" module] ["&;" env]) - (. ["&&;" lux])) + (. ["&&;" common] + ["&&;" function] + ["&&;" primitive] + ["&&;" reference] + ["&&;" type] + ["&&;" struct] + ["&&;" proc])) -(def: #export (analyse eval ast) - &;Analyser - (case ast - (^template [<tag> <analyser>] - [cursor (<tag> value)] - (<analyser> cursor value)) - ([#;Bool &&lux;analyse-bool] - [#;Nat &&lux;analyse-nat] - [#;Int &&lux;analyse-int] - [#;Deg &&lux;analyse-deg] - [#;Real &&lux;analyse-real] - [#;Char &&lux;analyse-char] - [#;Text &&lux;analyse-text]) +(def: #export (analyser eval) + (-> &;Eval &;Analyser) + (: (-> Code (Lux la;Analysis)) + (function analyse [ast] + (case ast + (^template [<tag> <analyser>] + [cursor (<tag> value)] + (<analyser> value)) + ([#;Bool &&primitive;analyse-bool] + [#;Nat &&primitive;analyse-nat] + [#;Int &&primitive;analyse-int] + [#;Deg &&primitive;analyse-deg] + [#;Real &&primitive;analyse-real] + [#;Char &&primitive;analyse-char] + [#;Text &&primitive;analyse-text]) - (^ [cursor (#;Tuple (list))]) - (&&lux;analyse-unit cursor) + (^ [cursor (#;Tuple (list))]) + &&primitive;analyse-unit - (^ [cursor (#;Tuple (list singleton))]) - (analyse eval singleton) + (^ [cursor (#;Tuple (list singleton))]) + (analyse singleton) - (^ [cursor (#;Tuple elems)]) - (&&lux;analyse-tuple (analyse eval) cursor elems) + (^ [cursor (#;Tuple elems)]) + (&&struct;analyse-tuple analyse elems) - [cursor (#;Symbol reference)] - (&&lux;analyse-reference cursor reference) + [cursor (#;Symbol reference)] + (&&reference;analyse-reference reference) - (^ [cursor (#;Form (list [_ (#;Symbol ["" "_lux_check"])] - type - value))]) - (&&lux;analyse-check analyse eval cursor type value) + (^ [cursor (#;Form (list [_ (#;Symbol ["" "_lux_check"])] + type + value))]) + (&&type;analyse-check analyse eval type value) - (^ [cursor (#;Form (list [_ (#;Symbol ["" "_lux_coerce"])] - type - value))]) - (&&lux;analyse-coerce analyse eval cursor type value) + (^ [cursor (#;Form (list [_ (#;Symbol ["" "_lux_coerce"])] + type + value))]) + (&&type;analyse-coerce analyse eval type value) - (^ [cursor (#;Form (list [_ (#;Nat tag)] - value))]) - (&&lux;analyse-variant (analyse eval) cursor tag value) + (^ [cursor (#;Form (list [_ (#;Symbol ["" "_lux_proc"])] + [_ (#;Symbol proc)] + [_ (#;Tuple args)]))]) + (&&proc;analyse-proc analyse proc args) - _ - (&;fail (format "Unrecognized syntax: " (%ast ast))) - )) + (^ [cursor (#;Form (list [_ (#;Nat tag)] + value))]) + (&&struct;analyse-variant analyse tag value) + + (^ [cursor (#;Form (list& func args))]) + (do Monad<Lux> + [[funcT =func] (&&common;with-unknown-type + (analyse func))] + (case =func + (#la;Absolute def-name) + (do @ + [[def-type def-anns def-value] (macro;find-def def-name)] + (if (macro;macro? def-anns) + (do @ + [## macro-expansion (function [compiler] + ## (case (macro-caller def-value args compiler) + ## (#E;Success [compiler' output]) + ## (#E;Success [compiler' output]) + + ## (#E;Error error) + ## ((&;fail error) compiler))) + macro-expansion (: (Lux (List Code)) + (undefined))] + (case macro-expansion + (^ (list single-expansion)) + (analyse single-expansion) + + _ + (&;fail (format "Macro expressions must expand to a single expression: " (%code ast))))) + (&&function;analyse-apply analyse funcT =func args))) + + _ + (&&function;analyse-apply analyse funcT =func args))) + + _ + (&;fail (format "Unrecognized syntax: " (%code ast))) + )))) diff --git a/new-luxc/source/luxc/analyser/common.lux b/new-luxc/source/luxc/analyser/common.lux index ed2b6eba7..7a9e5dbf8 100644 --- a/new-luxc/source/luxc/analyser/common.lux +++ b/new-luxc/source/luxc/analyser/common.lux @@ -10,64 +10,23 @@ (luxc ["&" base] (lang analysis))) -(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 - (#;Var id) - (do Monad<Lux> - [=type (&;within-type-env - (TC;clean id type))] - (wrap (replace-type =type analysis))) - - (#;Ex id) - (undefined) - - _ - (&;fail (format "Cannot clean type: " (%type type))))) - (def: #export (with-unknown-type action) - (All [a] (-> (Lux Analysis) (Lux Analysis))) + (All [a] (-> (Lux Analysis) (Lux [Type 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)])) + analysis (&;with-expected-type var-type + action) + analysis-type (&;within-type-env + (TC;clean var-id var-type)) _ (&;within-type-env (TC;delete-var var-id))] - (wrap analysis))) - -(def: #export (realize expected) - (-> Type (TC;Check [(List Type) Type])) - (case expected - (#;Named [module name] _expected) - (realize _expected) + (wrap [analysis-type analysis]))) - (#;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: #export (with-var body) + (All [a] (-> (-> [Nat Type] (Lux a)) (Lux a))) + (do Monad<Lux> + [[id var] (&;within-type-env TC;create-var) + output (body [id var]) + _ (&;within-type-env (TC;delete-var id))] + (wrap output))) diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux new file mode 100644 index 000000000..17441b760 --- /dev/null +++ b/new-luxc/source/luxc/analyser/function.lux @@ -0,0 +1,188 @@ +(;module: + lux + (lux (control monad) + (data ["E" error] + [text] + text/format + (coll [list "L/" Fold<List> Monoid<List> Monad<List>])) + [macro #+ Monad<Lux>] + [type] + (type ["TC" check])) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis]) + ["&;" env] + (analyser ["&;" common]))) + +## [Analysers] +(def: (bind-var var-id bound-idx type) + (-> Nat Nat Type Type) + (case type + (#;Host name params) + (#;Host name (L/map (bind-var var-id bound-idx) params)) + + (^template [<tag>] + (<tag> left right) + (<tag> (bind-var var-id bound-idx left) + (bind-var var-id bound-idx right))) + ([#;Sum] + [#;Product] + [#;Function] + [#;App]) + + (#;Var id) + (if (n.= var-id id) + (#;Bound bound-idx) + type) + + (^template [<tag>] + (<tag> env quantified) + (<tag> (L/map (bind-var var-id bound-idx) env) + (bind-var var-id (n.+ +2 bound-idx) quantified))) + ([#;UnivQ] + [#;ExQ]) + + (#;Named name unnamedT) + (#;Named name + (bind-var var-id bound-idx unnamedT)) + + _ + type)) + +(def: #export (analyse-function analyse func-name arg-name body) + (-> &;Analyser Text Text Code (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type] + (&;with-stacked-errors + (function [_] (format "Functions require function types: " (type;to-text expected))) + (case expected + (#;Named name unnamedT) + (&;with-expected-type unnamedT + (analyse-function analyse func-name arg-name body)) + + (#;App funT argT) + (do @ + [fully-applied (case (type;apply-type funT argT) + (#;Some value) + (wrap value) + + #;None + (&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT))))] + (&;with-expected-type fully-applied + (analyse-function analyse func-name arg-name body))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;within-type-env + TC;existential)] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-function analyse func-name arg-name body))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-function analyse func-name arg-name body)))) + + (#;Var id) + (do @ + [? (&;within-type-env + (TC;bound? id))] + (if ? + (do @ + [expected' (&;within-type-env + (TC;read-var id))] + (&;with-expected-type expected' + (analyse-function analyse func-name arg-name body))) + ## Inference + (&common;with-var + (function [[input-id inputT]] + (&common;with-var + (function [[output-id outputT]] + (do @ + [#let [funT (#;Function inputT outputT)] + =function (&;with-expected-type funT + (analyse-function analyse func-name arg-name body)) + funT' (&;within-type-env + (TC;clean output-id funT)) + concrete-input? (&;within-type-env + (TC;bound? input-id)) + funT'' (if concrete-input? + (&;within-type-env + (TC;clean input-id funT')) + (wrap (#;UnivQ (list) (bind-var input-id +1 funT')))) + _ (&;within-type-env + (TC;check expected funT''))] + (wrap =function)) + )))))) + + (#;Function inputT outputT) + (<| (:: @ map (|>. #la;Function)) + &;with-scope + (&env;with-local [func-name expected]) + (&env;with-local [arg-name inputT]) + (&;with-expected-type outputT) + (analyse body)) + + _ + (&;fail "") + )))) + +(def: (analyse-apply' analyse funcT args) + (-> &;Analyser Type (List Code) (Lux [Type (List Analysis)])) + (case args + #;Nil + (:: Monad<Lux> wrap [funcT (list)]) + + (#;Cons arg args') + (&;with-stacked-errors + (function [_] (format "Cannot apply function " (%type funcT) + " to args: " (|> args (L/map %code) (text;join-with " ")))) + (case funcT + (#;Named name unnamedT) + (analyse-apply' analyse unnamedT args) + + (#;UnivQ _) + (&common;with-var + (function [[var-id varT]] + (do Monad<Lux> + [[outputT argsA] (analyse-apply' analyse (assume (type;apply-type funcT varT)) args)] + (do @ + [? (&;within-type-env + (TC;bound? var-id)) + outputT' (if ? + (&;within-type-env + (TC;clean var-id outputT)) + (wrap (#;UnivQ (list) (bind-var var-id +1 outputT))))] + (wrap [outputT' argsA]))))) + + (#;ExQ _) + (do Monad<Lux> + [[ex-id exT] (&;within-type-env + TC;existential)] + (analyse-apply' analyse (assume (type;apply-type funcT exT)) args)) + + (#;Function inputT outputT) + (do Monad<Lux> + [[outputT' args'A] (analyse-apply' analyse outputT args') + argA (&;with-stacked-errors + (function [_] (format "Expected type: " (%type inputT) "\n" + " For argument: " (%code arg))) + (&;with-expected-type inputT + (analyse arg)))] + (wrap [outputT' (list& argA args'A)])) + + _ + (&;fail (format "Cannot apply a non-function: " (%type funcT))))) + )) + +(def: #export (analyse-apply analyse funcT funcA args) + (-> &;Analyser Type Analysis (List Code) (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type + [applyT argsA] (analyse-apply' analyse funcT args) + _ (&;within-type-env + (TC;check expected applyT))] + (wrap (L/fold (function [arg func] + (#la;Apply arg func)) + funcA + argsA)))) diff --git a/new-luxc/source/luxc/analyser/lux.lux b/new-luxc/source/luxc/analyser/lux.lux deleted file mode 100644 index 7bce8ed8d..000000000 --- a/new-luxc/source/luxc/analyser/lux.lux +++ /dev/null @@ -1,397 +0,0 @@ -(;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 ["la" analysis #+ Analysis]) - ["&;" 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] - (<tag> value)])))] - - [analyse-bool Bool #la;Bool] - [analyse-nat Nat #la;Nat] - [analyse-int Int #la;Int] - [analyse-deg Deg #la;Deg] - [analyse-real Real #la;Real] - [analyse-char Char #la;Char] - [analyse-text Text #la;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] - #la;Unit]))) - -(def: (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] - (#la;Absolute def-name)]))) - -(def: (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] - (#la;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 Code Code (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 Code Code (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 expected =value)))) - -(def: (analyse-typed-tuple analyse cursor members) - (-> (-> Code (Lux Analysis)) Cursor - (List Code) - (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] - (#la;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] - (#la;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] - (#la;Tuple (L/append =prevs (list =last)))])) - )))) - -(def: (tuple cursor members) - (-> Cursor (List Analysis) Analysis) - (let [tuple-type (type;tuple (L/map la;get-type members))] - [[tuple-type cursor] - (#la;Tuple members)])) - -(def: #export (analyse-tuple analyse cursor members) - (-> (-> Code (Lux Analysis)) Cursor - (List Code) - (Lux Analysis)) - (do Monad<Lux> - [expected macro;expected-type] - (case expected - (#;Product _) - (analyse-typed-tuple analyse cursor members) - - (#;Var 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 (la;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 (la;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) - (-> (-> Code (Lux Analysis)) Cursor - Nat Code - (Lux Analysis)) - (do Monad<Lux> - [expected macro;expected-type] - (case expected - (#;Sum _) - (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] - (#la;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 (la;get-type =variant)))] - (wrap (&common;replace-type expected =variant))) - (&;fail (format "Invalid type for variant: " (%type expected))))))) - -## Functions -(def: (maybe-to-lux input) - (All [a] (-> (Maybe a) (Lux a))) - (case input - #;None - (&;fail "") - - (#;Some value) - (:: Monad<Lux> wrap value))) - -(def: (with-var body) - (All [a] (-> (-> [Nat Type] (Lux a)) (Lux a))) - (do Monad<Lux> - [[id var] (&;within-type-env TC;create-var) - output (body [id var]) - _ (&;within-type-env (TC;delete-var id))] - (wrap output))) - -(def: (bind-var var-id bound-idx type) - (-> Nat Nat Type Type) - (case type - (#;Host name params) - (#;Host name (L/map (bind-var var-id bound-idx) params)) - - (^template [<tag>] - (<tag> left right) - (<tag> (bind-var var-id bound-idx left) - (bind-var var-id bound-idx right))) - ([#;Sum] - [#;Product] - [#;Function] - [#;App]) - - (#;Var id) - (if (n.= var-id id) - (#;Bound bound-idx) - type) - - (^template [<tag>] - (<tag> env quantified) - (<tag> (L/map (bind-var var-id bound-idx) env) - (bind-var var-id (n.+ +2 bound-idx) quantified))) - ([#;UnivQ] - [#;ExQ]) - - (#;Named name unnamed) - (#;Named name - (bind-var var-id bound-idx unnamed)) - - _ - type)) - -(def: #export (analyse-function analyse cursor func-name arg-name body) - (-> (-> Code (Lux Analysis)) Cursor - Text Text Code - (Lux Analysis)) - (do Monad<Lux> - [expected macro;expected-type] - (&;with-try - (function [error] - (let [raw (format "Functions require function types: " (type;to-text expected))] - (&;fail (if (T/= "" error) - raw - (format error "\n" raw))))) - (case expected - (#;Named name unnamed) - (do @ - [=function (&;with-expected-type unnamed - (analyse-function analyse cursor func-name arg-name body))] - (wrap (&common;replace-type expected =function))) - - (#;App funT argT) - (do @ - [fully-applied (maybe-to-lux (type;apply-type funT argT)) - =function (&;with-expected-type fully-applied - (analyse-function analyse cursor func-name arg-name body))] - (wrap (&common;replace-type expected =function))) - - (#;UnivQ _) - (do @ - [[var-id var] (&;within-type-env - TC;existential) - expected' (maybe-to-lux (type;apply-type expected var)) - =function (&;with-expected-type expected' - (analyse-function analyse cursor func-name arg-name body))] - (wrap (&common;replace-type expected =function))) - - (#;ExQ _) - (with-var - (function [[var-id var]] - (do @ - [expected' (maybe-to-lux (type;apply-type expected var)) - =function (&;with-expected-type expected' - (analyse-function analyse cursor func-name arg-name body))] - (&common;clean var =function)))) - - (#;Var id) - (do @ - [? (&;within-type-env - (TC;bound? id))] - (if ? - (do @ - [expected' (&;within-type-env - (TC;read-var id))] - (&;with-expected-type expected' - (analyse-function analyse cursor func-name arg-name body))) - ## Inference - (with-var - (function [[input-id inputT]] - (with-var - (function [[output-id outputT]] - (do @ - [#let [funT (#;Function inputT outputT)] - =function (&;with-expected-type funT - (analyse-function analyse cursor func-name arg-name body)) - funT' (&;within-type-env - (TC;clean output-id funT)) - concrete-input? (&;within-type-env - (TC;bound? input-id)) - funT'' (if concrete-input? - (&;within-type-env - (TC;clean input-id funT')) - (wrap (#;UnivQ (list) (bind-var input-id +1 funT')))) - _ (&;within-type-env - (TC;check expected funT''))] - (wrap (&common;replace-type expected =function))) - )))))) - - (#;Function inputT outputT) - (do @ - [[=scope =body] (&;with-scope - (&env;with-local [func-name expected] - (&env;with-local [arg-name inputT] - (&;with-expected-type outputT - (analyse body)))))] - (wrap [[expected cursor] - (#la;Function =scope =body)])) - - _ - (&;fail "") - )))) diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux new file mode 100644 index 000000000..26580a503 --- /dev/null +++ b/new-luxc/source/luxc/analyser/primitive.lux @@ -0,0 +1,34 @@ +(;module: + lux + (lux (control monad) + [macro #+ Monad<Lux>] + (type ["TC" check])) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis]))) + +## [Analysers] +(do-template [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type + _ (&;within-type-env + (TC;check expected <type>))] + (wrap (<tag> value))))] + + [analyse-bool Bool #la;Bool] + [analyse-nat Nat #la;Nat] + [analyse-int Int #la;Int] + [analyse-deg Deg #la;Deg] + [analyse-real Real #la;Real] + [analyse-char Char #la;Char] + [analyse-text Text #la;Text] + ) + +(def: #export analyse-unit + (Lux Analysis) + (do Monad<Lux> + [expected macro;expected-type + _ (&;within-type-env + (TC;check expected Unit))] + (wrap #la;Unit))) diff --git a/new-luxc/source/luxc/analyser/proc.lux b/new-luxc/source/luxc/analyser/proc.lux new file mode 100644 index 000000000..8bd975272 --- /dev/null +++ b/new-luxc/source/luxc/analyser/proc.lux @@ -0,0 +1,20 @@ +(;module: + lux + (lux (control monad) + (data ["E" error] + [text] + text/format + (coll ["D" dict]) + maybe)) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis])) + (. ["&&;" lux])) + +(def: #export (analyse-proc analyse [proc-category proc-name] proc-args) + (-> &;Analyser Ident (List Code) (Lux Analysis)) + (default (let [proc-description (format "[" (%t proc-category) " " (%t proc-name) "]")] + (&;fail (format "Unknown procedure: " proc-description))) + (do Monad<Maybe> + [procs (D;get proc-category &&lux;procs) + proc (D;get proc-name procs)] + (wrap (proc analyse proc-args))))) diff --git a/new-luxc/source/luxc/analyser/proc/lux.lux b/new-luxc/source/luxc/analyser/proc/lux.lux new file mode 100644 index 000000000..8ad88baed --- /dev/null +++ b/new-luxc/source/luxc/analyser/proc/lux.lux @@ -0,0 +1,321 @@ +(;module: + lux + (lux (control monad) + (concurrency ["A" atom]) + (data [text] + text/format + (coll [list] + [array #+ Array] + ["D" dict])) + [macro #+ Monad<Lux>] + (type ["TC" check]) + [io]) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis]) + (analyser ["&;" common]))) + +## [Utils] +(type: Proc-Analyser + (-> &;Analyser (List Code) (Lux Analysis))) + +(type: Proc-Set + (D;Dict Text Proc-Analyser)) + +(def: (wrong-amount-error proc expected actual) + (-> Ident Nat Nat Text) + (let [[proc-category proc-name] proc + proc-description (format "[" (%t proc-category) " " (%t proc-name) "]")] + (format "Wrong number of arguments for " proc-description "\n" + "Expected: " (|> expected nat-to-int %i) "\n" + " Actual: " (|> actual nat-to-int %i)))) + +(def: (simple-proc proc input-types output-type) + (-> Ident (List Type) Type Proc-Analyser) + (let [num-expected (list;size input-types)] + (function [analyse args] + (let [num-actual (list;size args)] + (if (n.= num-expected num-actual) + (do Monad<Lux> + [argsA (mapM @ + (function [[argT argC]] + (&;with-expected-type argT + (analyse argC))) + (list;zip2 input-types args)) + expected macro;expected-type + _ (&;within-type-env + (TC;check expected output-type))] + (wrap (#la;Procedure proc argsA))) + (&;fail (wrong-amount-error proc num-expected num-actual))))))) + +(def: (binary-operation proc subjectT paramT outputT) + (-> Ident Type Type Type Proc-Analyser) + (simple-proc proc (list subjectT paramT) outputT)) + +(def: (trinary-operation proc subjectT param0T param1T outputT) + (-> Ident Type Type Type Type Proc-Analyser) + (simple-proc proc (list subjectT param0T param1T) outputT)) + +(def: (unary-operation proc inputT outputT) + (-> Ident Type Type Proc-Analyser) + (simple-proc proc (list inputT) outputT)) + +(def: (special-value proc valueT) + (-> Ident Type Proc-Analyser) + (simple-proc proc (list) valueT)) + +(def: (converter proc fromT toT) + (-> Ident Type Type Proc-Analyser) + (simple-proc proc (list fromT) toT)) + +## [Analysers] +(def: (analyse-lux-is analyse args) + Proc-Analyser + (&common;with-var + (function [[var-id varT]] + ((binary-operation ["lux" "is"] varT varT Bool) + analyse args)))) + +(def: (analyse-lux-try analyse args) + Proc-Analyser + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list opC)) + (do Monad<Lux> + [opA (&;with-expected-type (type (io;IO varT)) + (analyse opC)) + outputT (&;within-type-env + (TC;clean var-id (type (Either Text varT)))) + expected macro;expected-type + _ (&;within-type-env + (TC;check expected outputT))] + (wrap (#la;Procedure ["lux" "try"] (list opA)))) + + _ + (&;fail (wrong-amount-error ["lux" "try"] +1 (list;size args))))))) + +(def: lux-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "is" analyse-lux-is) + (D;put "try" analyse-lux-try))) + +(def: io-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "log" (converter ["io" "log"] Text Unit)) + (D;put "error" (converter ["io" "error"] Text Bottom)) + (D;put "exit" (converter ["io" "exit"] Nat Bottom)) + (D;put "current-time" (special-value ["io" "current-time"] Int)))) + +(def: bit-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "count" (unary-operation ["bit" "count"] Nat Nat)) + (D;put "and" (binary-operation ["bit" "and"] Nat Nat Nat)) + (D;put "or" (binary-operation ["bit" "or"] Nat Nat Nat)) + (D;put "xor" (binary-operation ["bit" "xor"] Nat Nat Nat)) + (D;put "shift-left" (binary-operation ["bit" "shift-left"] Nat Nat Nat)) + (D;put "unsigned-shift-right" (binary-operation ["bit" "unsigned-shift-right"] Nat Nat Nat)) + (D;put "shift-right" (binary-operation ["bit" "shift-right"] Int Nat Int)) + )) + +(def: nat-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "+" (binary-operation ["nat" "+"] Nat Nat Nat)) + (D;put "-" (binary-operation ["nat" "-"] Nat Nat Nat)) + (D;put "*" (binary-operation ["nat" "*"] Nat Nat Nat)) + (D;put "/" (binary-operation ["nat" "/"] Nat Nat Nat)) + (D;put "%" (binary-operation ["nat" "%"] Nat Nat Nat)) + (D;put "=" (binary-operation ["nat" "="] Nat Nat Bool)) + (D;put "<" (binary-operation ["nat" "<"] Nat Nat Bool)) + (D;put "min-value" (special-value ["nat" "min-value"] Nat)) + (D;put "max-value" (special-value ["nat" "max-value"] Nat)) + (D;put "to-int" (converter ["nat" "to-int"] Nat Int)) + (D;put "to-text" (converter ["nat" "to-text"] Nat Text)))) + +(def: int-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "+" (binary-operation ["int" "+"] Int Int Int)) + (D;put "-" (binary-operation ["int" "-"] Int Int Int)) + (D;put "*" (binary-operation ["int" "*"] Int Int Int)) + (D;put "/" (binary-operation ["int" "/"] Int Int Int)) + (D;put "%" (binary-operation ["int" "%"] Int Int Int)) + (D;put "=" (binary-operation ["int" "="] Int Int Bool)) + (D;put "<" (binary-operation ["int" "<"] Int Int Bool)) + (D;put "min-value" (special-value ["int" "min-value"] Int)) + (D;put "max-value" (special-value ["int" "max-value"] Int)) + (D;put "to-nat" (converter ["int" "to-nat"] Int Nat)) + (D;put "to-real" (converter ["int" "to-real"] Int Real)))) + +(def: deg-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "+" (binary-operation ["deg" "+"] Deg Deg Deg)) + (D;put "-" (binary-operation ["deg" "-"] Deg Deg Deg)) + (D;put "*" (binary-operation ["deg" "*"] Deg Deg Deg)) + (D;put "/" (binary-operation ["deg" "/"] Deg Deg Deg)) + (D;put "%" (binary-operation ["deg" "%"] Deg Deg Deg)) + (D;put "=" (binary-operation ["deg" "="] Deg Deg Bool)) + (D;put "<" (binary-operation ["deg" "<"] Deg Deg Bool)) + (D;put "scale" (binary-operation ["deg" "scale"] Deg Nat Deg)) + (D;put "reciprocal" (binary-operation ["deg" "scale"] Deg Nat Deg)) + (D;put "min-value" (special-value ["deg" "min-value"] Deg)) + (D;put "max-value" (special-value ["deg" "max-value"] Deg)) + (D;put "to-real" (converter ["deg" "to-real"] Deg Real)))) + +(def: real-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "+" (binary-operation ["real" "+"] Real Real Real)) + (D;put "-" (binary-operation ["real" "-"] Real Real Real)) + (D;put "*" (binary-operation ["real" "*"] Real Real Real)) + (D;put "/" (binary-operation ["real" "/"] Real Real Real)) + (D;put "%" (binary-operation ["real" "%"] Real Real Real)) + (D;put "=" (binary-operation ["real" "="] Real Real Bool)) + (D;put "<" (binary-operation ["real" "<"] Real Real Bool)) + (D;put "smallest-value" (special-value ["real" "smallest-value"] Real)) + (D;put "min-value" (special-value ["real" "min-value"] Real)) + (D;put "max-value" (special-value ["real" "max-value"] Real)) + (D;put "not-a-number" (special-value ["real" "not-a-number"] Real)) + (D;put "positive-infinity" (special-value ["real" "positive-infinity"] Real)) + (D;put "negative-infinity" (special-value ["real" "negative-infinity"] Real)) + (D;put "to-deg" (converter ["real" "to-deg"] Real Deg)) + (D;put "to-int" (converter ["real" "to-int"] Real Int)) + (D;put "hash" (unary-operation ["real" "hash"] Real Nat)) + (D;put "encode" (converter ["real" "encode"] Real Text)) + (D;put "decode" (converter ["real" "decode"] Text (type (Maybe Real)))))) + +(def: text-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "=" (binary-operation ["text" "="] Text Text Bool)) + (D;put "<" (binary-operation ["text" "<"] Text Text Bool)) + (D;put "prepend" (binary-operation ["text" "prepend"] Text Text Text)) + (D;put "index" (trinary-operation ["text" "index"] Text Text Nat (type (Maybe Nat)))) + (D;put "size" (unary-operation ["text" "size"] Text Nat)) + (D;put "hash" (unary-operation ["text" "hash"] Text Nat)) + (D;put "replace-once" (binary-operation ["text" "replace-once"] Text Text Text)) + (D;put "replace-all" (binary-operation ["text" "replace-all"] Text Text Text)) + (D;put "char" (binary-operation ["text" "char"] Text Nat Nat)) + (D;put "clip" (trinary-operation ["text" "clip"] Text Nat Nat Text)) + )) + +(def: (analyse-array-get analyse args) + Proc-Analyser + (&common;with-var + (function [[var-id varT]] + ((binary-operation ["lux" "get"] Nat (type (Array varT)) varT) + analyse args)))) + +(def: (analyse-array-put analyse args) + Proc-Analyser + (&common;with-var + (function [[var-id varT]] + ((trinary-operation ["lux" "put"] Nat varT (type (Array varT)) (type (Array varT))) + analyse args)))) + +(def: (analyse-array-remove analyse args) + Proc-Analyser + (&common;with-var + (function [[var-id varT]] + ((binary-operation ["lux" "remove"] Nat (type (Array varT)) (type (Array varT))) + analyse args)))) + +(def: array-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "new" (unary-operation ["array" "hash"] Nat Array)) + (D;put "get" analyse-array-get) + (D;put "put" analyse-array-put) + (D;put "remove" analyse-array-remove) + (D;put "size" (unary-operation ["array" "size"] (type (Ex [a] (Array a))) Nat)) + )) + +(def: math-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "cos" (unary-operation ["math" "cos"] Real Real)) + (D;put "sin" (unary-operation ["math" "sin"] Real Real)) + (D;put "tan" (unary-operation ["math" "tan"] Real Real)) + (D;put "acos" (unary-operation ["math" "acos"] Real Real)) + (D;put "asin" (unary-operation ["math" "asin"] Real Real)) + (D;put "atan" (unary-operation ["math" "atan"] Real Real)) + (D;put "cosh" (unary-operation ["math" "cosh"] Real Real)) + (D;put "sinh" (unary-operation ["math" "sinh"] Real Real)) + (D;put "tanh" (unary-operation ["math" "tanh"] Real Real)) + (D;put "exp" (unary-operation ["math" "exp"] Real Real)) + (D;put "log" (unary-operation ["math" "log"] Real Real)) + (D;put "root2" (unary-operation ["math" "root2"] Real Real)) + (D;put "root3" (unary-operation ["math" "root3"] Real Real)) + (D;put "ceil" (unary-operation ["math" "ceil"] Real Real)) + (D;put "floor" (unary-operation ["math" "floor"] Real Real)) + (D;put "round" (unary-operation ["math" "round"] Real Real)) + (D;put "atan2" (binary-operation ["math" "atan2"] Real Real Real)) + (D;put "pow" (binary-operation ["math" "pow"] Real Real Real)) + )) + +(def: (analyse-atom-new analyse args) + Proc-Analyser + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list initC)) + (do Monad<Lux> + [initA (&;with-expected-type varT + (analyse initC)) + outputT (&;within-type-env + (TC;clean var-id (type (A;Atom varT)))) + expected macro;expected-type + _ (&;within-type-env + (TC;check expected outputT))] + (wrap (#la;Procedure ["atom" "new"] (list initA)))) + + _ + (&;fail (wrong-amount-error ["atom" "new"] +1 (list;size args))))))) + +(def: (analyse-atom-read analyse args) + (&common;with-var + (function [[var-id varT]] + ((unary-operation ["atom" "read"] (type (A;Atom varT)) varT) + analyse args)))) + +(def: (analyse-atom-compare-and-swap analyse args) + (&common;with-var + (function [[var-id varT]] + ((trinary-operation ["atom" "compare-and-swap"] varT varT (type (A;Atom varT)) Bool) + analyse args)))) + +(def: atom-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "new" analyse-atom-new) + (D;put "read" analyse-atom-read) + (D;put "compare-and-swap" analyse-atom-compare-and-swap) + )) + +(def: process-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (D;put "concurrency-level" (special-value ["process" "concurrency-level"] Nat)) + (D;put "future" (unary-operation ["process" "future"] (type (io;IO Top)) Unit)) + (D;put "schedule" (binary-operation ["process" "schedule"] Nat (type (io;IO Top)) Unit)) + )) + +(def: #export procs + (D;Dict Text Proc-Set) + (|> (D;new text;Hash<Text>) + (D;put "lux" lux-procs) + (D;put "bit" bit-procs) + (D;put "nat" nat-procs) + (D;put "int" int-procs) + (D;put "deg" deg-procs) + (D;put "real" real-procs) + (D;put "text" text-procs) + (D;put "array" array-procs) + (D;put "math" math-procs) + (D;put "atom" atom-procs) + (D;put "process" process-procs) + (D;put "io" io-procs))) diff --git a/new-luxc/source/luxc/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux new file mode 100644 index 000000000..ea0505c3b --- /dev/null +++ b/new-luxc/source/luxc/analyser/reference.lux @@ -0,0 +1,51 @@ +(;module: + lux + (lux (control monad) + [macro #+ Monad<Lux>] + (type ["TC" check])) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis]) + ["&;" env])) + +## [Analysers] +(def: (analyse-definition def-name) + (-> 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 (#la;Absolute def-name)))) + +(def: (analyse-variable var-name) + (-> 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))] + (wrap (#;Some (#la;Relative ref)))) + + #;None + (wrap #;None)))) + +(def: #export (analyse-reference reference) + (-> Ident (Lux Analysis)) + (case reference + ["" simple-name] + (do Monad<Lux> + [?var (analyse-variable simple-name)] + (case ?var + (#;Some analysis) + (wrap analysis) + + #;None + (do @ + [this-module macro;current-module-name] + (analyse-definition [this-module simple-name])))) + + _ + (analyse-definition reference))) diff --git a/new-luxc/source/luxc/analyser/struct.lux b/new-luxc/source/luxc/analyser/struct.lux new file mode 100644 index 000000000..a698fb49f --- /dev/null +++ b/new-luxc/source/luxc/analyser/struct.lux @@ -0,0 +1,172 @@ +(;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 ["la" analysis #+ Analysis]) + ["&;" module] + ["&;" env] + (analyser ["&;" common]))) + +## [Analysers] +(def: (analyse-typed-tuple analyse members) + (-> &;Analyser (List Code) (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 (#la;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 (#la;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 tail-xs))] + (wrap (#la;Tuple (L/append =prevs (list =last))))) + )))) + +(def: #export (analyse-tuple analyse members) + (-> &;Analyser (List Code) (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type] + (&;with-stacked-errors + (function [_] (format "Invalid type for tuple: " (%type expected))) + (case expected + (#;Product _) + (analyse-typed-tuple analyse members) + + (#;Named name unnamedT) + (&;with-expected-type unnamedT + (analyse-tuple analyse members)) + + (#;Var id) + (do @ + [bound? (&;within-type-env + (TC;bound? id))] + (if bound? + (do @ + [expected' (&;within-type-env + (TC;read-var id))] + (&;with-expected-type expected' + (analyse-tuple analyse members))) + (do @ + [=members (mapM @ (|>. analyse &common;with-unknown-type) + members) + #let [tuple-type (type;tuple (L/map product;left =members))] + _ (&;within-type-env + (TC;check expected tuple-type))] + (wrap (#la;Tuple (L/map product;right =members)))))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;within-type-env + TC;existential)] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-tuple analyse members))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-tuple analyse members)))) + + _ + (&;fail "") + )))) + +(def: #export (analyse-variant analyse tag value) + (-> &;Analyser Nat Code (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type] + (&;with-stacked-errors + (function [_] (format "Invalid type for variant: " (%type expected))) + (case expected + (#;Sum _) + (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 (#la;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")))) + + (#;Named name unnamedT) + (&;with-expected-type unnamedT + (analyse-variant analyse tag value)) + + (#;Var id) + (do @ + [bound? (&;within-type-env + (TC;bound? id))] + (if bound? + (do @ + [expected' (&;within-type-env + (TC;read-var id))] + (&;with-expected-type expected' + (analyse-variant analyse tag value))) + (&;fail (format "Invalid type for variant: " (%type expected))))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;within-type-env + TC;existential)] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-variant analyse tag value))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-variant analyse tag value)))) + + _ + (&;fail ""))))) diff --git a/new-luxc/source/luxc/analyser/type.lux b/new-luxc/source/luxc/analyser/type.lux new file mode 100644 index 000000000..3b9b83245 --- /dev/null +++ b/new-luxc/source/luxc/analyser/type.lux @@ -0,0 +1,29 @@ +(;module: + lux + (lux (control monad) + [macro #+ Monad<Lux>] + (type ["TC" check])) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis]))) + +## [Analysers] +(def: #export (analyse-check analyse eval type value) + (-> &;Analyser &;Eval Code Code (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 value)))) + +(def: #export (analyse-coerce analyse eval type value) + (-> &;Analyser &;Eval Code Code (Lux Analysis)) + (do Monad<Lux> + [actual (eval Type type) + expected macro;expected-type + _ (&;within-type-env + (TC;check expected (:! Type actual)))] + (&;with-expected-type Top + (analyse value)))) diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux index 74e316b3c..ee2d4464d 100644 --- a/new-luxc/source/luxc/base.lux +++ b/new-luxc/source/luxc/base.lux @@ -12,7 +12,7 @@ (-> Type Code (Lux Top))) (type: #export Analyser - (-> Eval Code (Lux la;Analysis))) + (-> Code (Lux la;Analysis))) (type: #export Path Text) @@ -100,15 +100,17 @@ (#E;Success [(set@ #;source old-source compiler') output]))))) -(def: #export (with-try handler action) - (All [a] (-> (-> Text (Lux a)) (Lux a) (Lux a))) +(def: #export (with-stacked-errors handler action) + (All [a] (-> (-> [] Text) (Lux a) (Lux a))) (function [compiler] (case (action compiler) (#E;Success [compiler' output]) (#E;Success [compiler' output]) (#E;Error error) - ((handler error) compiler)))) + (#E;Error (if (T/= "" error) + (handler []) + (format error "\n-----------------------------------------\n" (handler []))))))) (def: fresh-bindings (All [k v] (Bindings k v)) diff --git a/new-luxc/source/luxc/compiler.lux b/new-luxc/source/luxc/compiler.lux index 2af00b049..92d4bf8ab 100644 --- a/new-luxc/source/luxc/compiler.lux +++ b/new-luxc/source/luxc/compiler.lux @@ -35,7 +35,7 @@ (&&statement;compile-program prog-args prog-body) _ - (&;fail (format "Unrecognized statement: " (%ast ast))))) + (&;fail (format "Unrecognized statement: " (%code ast))))) (def: (exhaust action) (All [a] (-> (Lux a) (Lux Unit))) diff --git a/new-luxc/source/luxc/compiler/expr.jvm.lux b/new-luxc/source/luxc/compiler/expr.jvm.lux index 33a41541b..173293b1c 100644 --- a/new-luxc/source/luxc/compiler/expr.jvm.lux +++ b/new-luxc/source/luxc/compiler/expr.jvm.lux @@ -50,8 +50,12 @@ &;Eval (undefined)) +(def: analyse + &;Analyser + (&analyser;analyser eval)) + (def: #export (compile input) (-> Code (Lux &common;Compiled)) (do Monad<Lux> - [analysis (&analyser;analyse eval input)] + [analysis (analyse input)] (compile-synthesis (&synthesizer;synthesize analysis)))) diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux index 092b561f0..71073f901 100644 --- a/new-luxc/source/luxc/lang/analysis.lux +++ b/new-luxc/source/luxc/lang/analysis.lux @@ -3,7 +3,7 @@ (lux (data [product])) (.. ["lp" pattern])) -(type: #export (Analysis' Analysis) +(type: #export #rec Analysis #Unit (#Bool Bool) (#Nat Nat) @@ -16,15 +16,7 @@ (#Tuple (List Analysis)) (#Case (List [lp;Pattern Analysis])) (#Function Scope Analysis) - (#Call Analysis (List Analysis)) - (#Procedure Text (List Analysis)) + (#Apply Analysis Analysis) + (#Procedure Ident (List Analysis)) (#Relative Ref) (#Absolute Ident)) - -(type: #export #rec Analysis - (Meta [Type Cursor] - (Analysis' Analysis))) - -(def: #export (get-type analysis) - (-> Analysis Type) - (|> analysis product;left product;left)) diff --git a/new-luxc/test/test/luxc/analyser/common.lux b/new-luxc/test/test/luxc/analyser/common.lux new file mode 100644 index 000000000..9e3db3513 --- /dev/null +++ b/new-luxc/test/test/luxc/analyser/common.lux @@ -0,0 +1,53 @@ +(;module: + lux + (lux ["R" math/random "R/" Monad<Random>] + (macro [code]))) + +(def: compiler-version Text "0.6.0") + +(def: init-compiler-info + Compiler-Info + {#;compiler-version compiler-version + #;compiler-mode #;Build}) + +(def: init-type-context + Type-Context + {#;ex-counter +0 + #;var-counter +0 + #;var-bindings (list)}) + +(def: #export init-compiler + Compiler + {#;info init-compiler-info + #;source [dummy-cursor ""] + #;cursor dummy-cursor + #;modules (list) + #;scopes (list) + #;type-context init-type-context + #;expected #;None + #;seed +0 + #;scope-type-vars (list) + #;host (:! Void [])}) + +(def: gen-unit + (R;Random Code) + (R/wrap (' []))) + +(def: #export gen-simple-primitive + (R;Random [Type Code]) + (with-expansions + [<generators> (do-template [<type> <code-wrapper> <value-gen>] + [(R;seq (R/wrap <type>) (R/map <code-wrapper> <value-gen>))] + + [Unit code;tuple (R;list +0 gen-unit)] + [Bool code;bool R;bool] + [Nat code;nat R;nat] + [Int code;int R;int] + [Deg code;deg R;deg] + [Real code;real R;real] + [Char code;char R;char] + [Text code;text (R;text +5)] + )] + ($_ R;either + <generators> + ))) diff --git a/new-luxc/test/test/luxc/analyser/lux.lux b/new-luxc/test/test/luxc/analyser/lux.lux deleted file mode 100644 index beb26513c..000000000 --- a/new-luxc/test/test/luxc/analyser/lux.lux +++ /dev/null @@ -1,173 +0,0 @@ -(;module: - lux - (lux [io] - (control monad - pipe) - (data [bool "B/" Eq<Bool>] - [char "C/" Eq<Char>] - [text "T/" Eq<Text>] - (text format - ["l" lexer]) - [number] - ["E" error] - [product] - (coll [list "L/" Functor<List> Fold<List>])) - ["R" math/random "R/" Monad<Random>] - [type "Type/" Eq<Type>] - [macro #+ Monad<Lux>] - (macro [code]) - test) - (luxc ["&" base] - ["&;" env] - ["&;" module] - (lang ["~" analysis]) - [analyser] - (analyser ["@" lux] - ["@;" common]))) - -(def: init-cursor Cursor ["" +0 +0]) - -(def: compiler-version Text "0.6.0") - -(def: init-compiler-info - Compiler-Info - {#;compiler-version compiler-version - #;compiler-mode #;Build}) - -(def: init-type-context - Type-Context - {#;ex-counter +0 - #;var-counter +0 - #;var-bindings (list)}) - -(def: init-compiler - 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 [])}) - -(test: "Simple primitives" - [%bool% R;bool - %nat% R;nat - %int% R;int - %deg% R;deg - %real% R;real - %char% R;char - %text% (R;text +5)] - (with-expansions - [<primitives> (do-template [<desc> <type> <tag> <value> <analyser>] - [(assert (format "Can analyse " <desc> ".") - (|> (@common;with-unknown-type - (<analyser> init-cursor <value>)) - (macro;run init-compiler) - (case> (#E;Success [[_type _cursor] (<tag> value)]) - (and (Type/= <type> _type) - (is <value> value)) - - _ - false)) - )] - - ["unit" Unit #~;Unit [] (function [cursor value] (@;analyse-unit cursor))] - ["bool" Bool #~;Bool %bool% @;analyse-bool] - ["nat" Nat #~;Nat %nat% @;analyse-nat] - ["int" Int #~;Int %int% @;analyse-int] - ["deg" Deg #~;Deg %deg% @;analyse-deg] - ["real" Real #~;Real %real% @;analyse-real] - ["char" Char #~;Char %char% @;analyse-char] - ["text" Text #~;Text %text% @;analyse-text] - )] - ($_ seq - <primitives>))) - -(def: gen-unit - (R;Random Code) - (R/wrap (' []))) - -(def: gen-simple-primitive - (R;Random [Type Code]) - (with-expansions - [<generators> (do-template [<type> <code-wrapper> <value-gen>] - [(R;seq (R/wrap <type>) (R/map <code-wrapper> <value-gen>))] - - [Unit code;tuple (R;list +0 gen-unit)] - [Bool code;bool R;bool] - [Nat code;nat R;nat] - [Int code;int R;int] - [Deg code;deg R;deg] - [Real code;real R;real] - [Char code;char R;char] - [Text code;text (R;text +5)] - )] - ($_ R;either - <generators> - ))) - -(test: "Tuples" - [size (|> R;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - primitives (R;list size gen-simple-primitive)] - ($_ seq - (let [tuple-type (type;tuple (L/map product;left primitives))] - (assert "Can analyse tuple." - (|> (@common;with-unknown-type - (@;analyse-tuple (analyser;analyse (:!! [])) - init-cursor - (L/map product;right primitives))) - (macro;run init-compiler) - (case> (#E;Success [[_type _cursor] (#~;Tuple elems)]) - (and (Type/= tuple-type _type) - (n.= size (list;size elems)) - (L/fold (function [[pt at] so-far] - (and so-far (Type/= pt at))) - true - (list;zip2 (L/map product;left primitives) - (L/map ~;get-type elems)))) - - _ - false)) - )))) - -(test: "References" - [[ref-type _] gen-simple-primitive - module-name (R;text +5) - scope-name (R;text +5) - var-name (R;text +5)] - ($_ seq - (assert "Can analyse relative reference." - (|> (&env;with-scope scope-name - (&env;with-local [var-name ref-type] - (@common;with-unknown-type - (@;analyse-reference init-cursor ["" var-name])))) - (macro;run init-compiler) - (case> (#E;Success [[_type _cursor] (#~;Relative idx)]) - (Type/= ref-type _type) - - (#E;Error error) - false - - _ - false))) - (assert "Can analyse absolute reference." - (|> (do Monad<Lux> - [_ (&module;create +0 module-name) - _ (&module;define [module-name var-name] - [ref-type (list) (:! Void [])])] - (@common;with-unknown-type - (@;analyse-reference init-cursor [module-name var-name]))) - (macro;run init-compiler) - (case> (#E;Success [[_type _cursor] (#~;Absolute idx)]) - (Type/= ref-type _type) - - (#E;Error error) - false - - _ - false))) - )) diff --git a/new-luxc/test/test/luxc/analyser/primitive.lux b/new-luxc/test/test/luxc/analyser/primitive.lux new file mode 100644 index 000000000..321a51fcb --- /dev/null +++ b/new-luxc/test/test/luxc/analyser/primitive.lux @@ -0,0 +1,61 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data [bool "B/" Eq<Bool>] + [char "C/" Eq<Char>] + [text "T/" Eq<Text>] + (text format + ["l" lexer]) + [number] + ["E" error] + [product] + (coll [list "L/" Functor<List> Fold<List>])) + ["R" math/random "R/" Monad<Random>] + [type "Type/" Eq<Type>] + [macro #+ Monad<Lux>] + (macro [code]) + test) + (luxc ["&" base] + ["&;" env] + ["&;" module] + (lang ["~" analysis]) + [analyser] + (analyser ["@" primitive] + ["@;" common])) + (.. common)) + +(test: "Simple primitives" + [%bool% R;bool + %nat% R;nat + %int% R;int + %deg% R;deg + %real% R;real + %char% R;char + %text% (R;text +5)] + (with-expansions + [<primitives> (do-template [<desc> <type> <tag> <value> <analyser>] + [(assert (format "Can analyse " <desc> ".") + (|> (@common;with-unknown-type + (<analyser> <value>)) + (macro;run init-compiler) + (case> (#E;Success [_type (<tag> value)]) + (and (Type/= <type> _type) + (is <value> value)) + + _ + false)) + )] + + ["unit" Unit #~;Unit [] (function [value] @;analyse-unit)] + ["bool" Bool #~;Bool %bool% @;analyse-bool] + ["nat" Nat #~;Nat %nat% @;analyse-nat] + ["int" Int #~;Int %int% @;analyse-int] + ["deg" Deg #~;Deg %deg% @;analyse-deg] + ["real" Real #~;Real %real% @;analyse-real] + ["char" Char #~;Char %char% @;analyse-char] + ["text" Text #~;Text %text% @;analyse-text] + )] + ($_ seq + <primitives>))) diff --git a/new-luxc/test/test/luxc/analyser/reference.lux b/new-luxc/test/test/luxc/analyser/reference.lux new file mode 100644 index 000000000..4e83a7af8 --- /dev/null +++ b/new-luxc/test/test/luxc/analyser/reference.lux @@ -0,0 +1,49 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data ["E" error]) + ["R" math/random "R/" Monad<Random>] + [type "Type/" Eq<Type>] + [macro #+ Monad<Lux>] + test) + (luxc ["&;" env] + ["&;" module] + (lang ["~" analysis]) + [analyser] + (analyser ["@" reference] + ["@;" common])) + (.. common)) + +(test: "References" + [[ref-type _] gen-simple-primitive + module-name (R;text +5) + scope-name (R;text +5) + var-name (R;text +5)] + ($_ seq + (assert "Can analyse relative reference." + (|> (&env;with-scope scope-name + (&env;with-local [var-name ref-type] + (@common;with-unknown-type + (@;analyse-reference ["" var-name])))) + (macro;run init-compiler) + (case> (#E;Success [_type (#~;Relative idx)]) + (Type/= ref-type _type) + + _ + false))) + (assert "Can analyse absolute reference." + (|> (do Monad<Lux> + [_ (&module;create +0 module-name) + _ (&module;define [module-name var-name] + [ref-type (list) (:! Void [])])] + (@common;with-unknown-type + (@;analyse-reference [module-name var-name]))) + (macro;run init-compiler) + (case> (#E;Success [_type (#~;Absolute idx)]) + (Type/= ref-type _type) + + _ + false))) + )) diff --git a/new-luxc/test/test/luxc/analyser/struct.lux b/new-luxc/test/test/luxc/analyser/struct.lux new file mode 100644 index 000000000..a86f6da9c --- /dev/null +++ b/new-luxc/test/test/luxc/analyser/struct.lux @@ -0,0 +1,39 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data ["E" error] + [product] + (coll [list "L/" Functor<List>])) + ["R" math/random "R/" Monad<Random>] + [type "Type/" Eq<Type>] + [macro #+ Monad<Lux>] + test) + (luxc ["&" base] + (lang ["~" analysis]) + [analyser] + (analyser ["@" struct] + ["@;" common])) + (.. common)) + +(def: analyse + &;Analyser + (analyser;analyser (:!! []))) + +(test: "Tuples" + [size (|> R;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + primitives (R;list size gen-simple-primitive)] + ($_ seq + (assert "Can analyse tuple." + (|> (@common;with-unknown-type + (@;analyse-tuple analyse (L/map product;right primitives))) + (macro;run init-compiler) + (case> (#E;Success [_type (#~;Tuple elems)]) + (and (Type/= (type;tuple (L/map product;left primitives)) + _type) + (n.= size (list;size elems))) + + _ + false)) + ))) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index cbff78c2e..a330560fc 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -6,7 +6,9 @@ [cli #+ program:] [test]) (test (luxc ["_;" parser] - (analyser ["_;" lux])))) + (analyser ["_;" primitive] + ["_;" struct] + ["_;" reference])))) ## [Program] (program: args |