From bf47bd7b3d4f70bc3a481761b8e9ff074313fb44 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 3 May 2017 18:17:00 -0400 Subject: - WIP: Implemented more functionality. - Lots of refactorings. --- new-luxc/source/luxc/analyser/lux.lux | 255 ++++++++++++++++++++++++++++++++++ 1 file changed, 255 insertions(+) create mode 100644 new-luxc/source/luxc/analyser/lux.lux (limited to 'new-luxc/source/luxc/analyser/lux.lux') diff --git a/new-luxc/source/luxc/analyser/lux.lux b/new-luxc/source/luxc/analyser/lux.lux new file mode 100644 index 000000000..24ac1e093 --- /dev/null +++ b/new-luxc/source/luxc/analyser/lux.lux @@ -0,0 +1,255 @@ +(;module: + lux + (lux (control monad + pipe) + [io #- run] + (concurrency ["A" atom]) + (data ["E" error] + [text "T/" Eq] + text/format + (coll [list "L/" Fold Monoid Monad] + ["D" dict]) + [number] + [product]) + [macro #+ Monad] + [type] + (type ["TC" check])) + (luxc ["&" base] + [lang #*] + ["&;" module] + ["&;" env] + (analyser ["&;" common]))) + +(do-template [ ] + [(def: #export ( cursor value) + (-> Cursor (Lux Analysis)) + (do Monad + [expected macro;expected-type + _ (&;within-type-env + (TC;check expected ))] + (wrap [[expected cursor] + (#lang;Primitive ( value))])))] + + [analyse-bool Bool #lang;Bool] + [analyse-nat Nat #lang;Nat] + [analyse-int Int #lang;Int] + [analyse-deg Deg #lang;Deg] + [analyse-real Real #lang;Real] + [analyse-char Char #lang;Char] + [analyse-text Text #lang;Text] + ) + +(def: #export (analyse-unit cursor) + (-> Cursor (Lux Analysis)) + (do Monad + [expected macro;expected-type + _ (&;within-type-env + (TC;check expected Unit))] + (wrap [[expected cursor] + (#lang;Primitive #lang;Unit)]))) + +(def: #export (analyse-definition cursor def-name) + (-> Cursor Ident (Lux Analysis)) + (do Monad + [actual (macro;find-def-type def-name) + expected macro;expected-type + _ (&;within-type-env + (TC;check expected actual))] + (wrap [[expected cursor] + (#lang;Reference (#lang;Absolute def-name))]))) + +(def: #export (analyse-variable cursor var-name) + (-> Cursor Text (Lux (Maybe Analysis))) + (do Monad + [?var (&env;find var-name)] + (case ?var + (#;Some [actual ref]) + (do @ + [expected macro;expected-type + _ (&;within-type-env + (TC;check expected actual)) + #let [analysis [[expected cursor] + (#lang;Reference (#lang;Relative ref))]]] + (wrap (#;Some analysis))) + + #;None + (wrap #;None)))) + +(def: #export (analyse-reference cursor reference) + (-> Cursor Ident (Lux Analysis)) + (case reference + ["" simple-name] + (do Monad + [?var (analyse-variable cursor simple-name)] + (case ?var + (#;Some analysis) + (wrap analysis) + + #;None + (do @ + [this-module macro;current-module-name] + (analyse-definition cursor [this-module simple-name])))) + + _ + (analyse-definition cursor reference))) + +(def: #export (analyse-check analyse eval cursor type value) + (-> Analyser Eval Cursor AST AST (Lux Analysis)) + (do Monad + [actual (eval Type type) + #let [actual (:! Type actual)] + expected macro;expected-type + _ (&;within-type-env + (TC;check expected actual))] + (&;with-expected-type actual + (analyse eval value)))) + +(def: #export (analyse-coerce analyse eval cursor type value) + (-> Analyser Eval Cursor AST AST (Lux Analysis)) + (do Monad + [actual (eval Type type) + #let [actual (:! Type actual)] + expected macro;expected-type + _ (&;within-type-env + (TC;check expected actual)) + =value (&;with-expected-type Top + (analyse eval value))] + (wrap (&common;replace-type actual =value)))) + +(def: (analyse-typed-tuple analyse cursor members) + (-> (-> AST (Lux Analysis)) Cursor + (List AST) + (Lux Analysis)) + (do Monad + [expected macro;expected-type] + (let [member-types (type;flatten-tuple expected) + num-types (list;size member-types) + num-members (list;size members)] + (cond (n.= num-types num-members) + (do @ + [=tuple (: (Lux (List Analysis)) + (mapM @ + (function [[expected member]] + (&;with-expected-type expected + (analyse member))) + (list;zip2 member-types members)))] + (wrap [[expected cursor] + (#lang;Structure (#lang;Tuple =tuple))])) + + (n.< num-types num-members) + (do @ + [#let [[head-ts tail-ts] (list;split (n.- +2 num-members) + member-types)] + =prevs (mapM @ + (function [[expected member]] + (&;with-expected-type expected + (analyse member))) + (list;zip2 head-ts members)) + =last (&;with-expected-type (type;tuple tail-ts) + (analyse (default (undefined) + (list;last members))))] + (wrap [[expected cursor] + (#lang;Structure (#lang;Tuple (L/append =prevs (list =last))))])) + + ## (n.> num-types num-members) + (do @ + [#let [[head-xs tail-xs] (list;split (n.- +2 num-types) + members)] + =prevs (mapM @ + (function [[expected member]] + (&;with-expected-type expected + (analyse member))) + (list;zip2 member-types head-xs)) + =last (&;with-expected-type (default (undefined) + (list;last member-types)) + (analyse-typed-tuple analyse cursor tail-xs))] + (wrap [[expected cursor] + (#lang;Structure (#lang;Tuple (L/append =prevs (list =last))))])) + )))) + +(def: (tuple cursor members) + (-> Cursor (List Analysis) Analysis) + (let [tuple-type (type;tuple (L/map &common;get-type members))] + [[tuple-type cursor] + (#lang;Structure (#lang;Tuple members))])) + +(def: #export (analyse-tuple analyse cursor members) + (-> (-> AST (Lux Analysis)) Cursor + (List AST) + (Lux Analysis)) + (do Monad + [expected macro;expected-type] + (case expected + (#;ProdT _) + (analyse-typed-tuple analyse cursor members) + + (#;VarT id) + (do @ + [bound? (&;within-type-env + (TC;bound? id))] + (if bound? + (do @ + [expected' (&;within-type-env + (TC;read-var id)) + =tuple (&;with-expected-type expected' + (analyse-tuple analyse cursor members))] + (wrap (&common;replace-type expected =tuple))) + (do @ + [=members (mapM @ (<|. &common;with-unknown-type + analyse) + members) + #let [=tuple (tuple cursor =members)] + _ (&;within-type-env + (TC;check expected (&common;get-type =tuple)))] + (wrap (&common;replace-type expected =tuple))))) + + _ + (if (type;quantified? expected) + (do @ + [[bindings expected'] (&;within-type-env + (&common;realize expected)) + =tuple (&;with-expected-type expected' + (analyse-tuple analyse cursor members)) + =tuple (foldM @ &common;clean =tuple bindings) + _ (&;within-type-env + (TC;check expected (&common;get-type =tuple)))] + (wrap (&common;replace-type expected =tuple))) + (&;fail (format "Invalid type for tuple: " (%type expected)))) + ))) + +(def: #export (analyse-variant analyse cursor tag value) + (-> (-> AST (Lux Analysis)) Cursor + Nat AST + (Lux Analysis)) + (do Monad + [expected macro;expected-type] + (case expected + (#;SumT _) + (let [flat (type;flatten-variant expected) + type-size (list;size flat)] + (if (n.< type-size tag) + (do @ + [#let [last? (n.= tag (n.dec type-size)) + variant-type (default (undefined) + (list;nth tag flat))] + =value (&;with-expected-type variant-type + (analyse value))] + (wrap [[expected cursor] + (#lang;Structure (#lang;Variant tag last? =value))])) + (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n" + " Tag: " (%n tag) "\n" + "Type size: " (%n type-size) "\n" + " Type: " (%type expected) "\n")))) + + _ + (if (type;quantified? expected) + (do @ + [[bindings expected'] (&;within-type-env + (&common;realize expected)) + =variant (&;with-expected-type expected' + (analyse-variant analyse cursor tag value)) + =variant (foldM @ &common;clean =variant bindings) + _ (&;within-type-env + (TC;check expected (&common;get-type =variant)))] + (wrap (&common;replace-type expected =variant))) + (&;fail (format "Invalid type for variant: " (%type expected))))))) -- cgit v1.2.3