diff options
Diffstat (limited to 'new-luxc/source/luxc/analyser')
| -rw-r--r-- | new-luxc/source/luxc/analyser/common.lux | 67 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/function.lux | 188 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/lux.lux | 397 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/primitive.lux | 34 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/proc.lux | 20 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/proc/lux.lux | 321 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/reference.lux | 51 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/struct.lux | 172 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/type.lux | 29 |
9 files changed, 828 insertions, 451 deletions
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)))) |