diff options
author | Eduardo Julian | 2017-05-15 22:19:14 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-05-15 22:19:14 -0400 |
commit | 824482b2e8b13e42a524a5e4945ea3e172395c9e (patch) | |
tree | 959bb7684461318b1026cd773ae29ac76d426054 /new-luxc/source/luxc/analyser/lux.lux | |
parent | 04c0a8d2fceae628099673e62527fc48e2afd7e7 (diff) |
WIP
- Simplified the Analysis type, by removing all meta-data.
- Added analysis of function calls.
- Added analysis of common Lux procedures.
- Lots of refactoring.
Diffstat (limited to 'new-luxc/source/luxc/analyser/lux.lux')
-rw-r--r-- | new-luxc/source/luxc/analyser/lux.lux | 397 |
1 files changed, 0 insertions, 397 deletions
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 "") - )))) |