From 953f49d5a46209f2d75e67b50edea378261108cd Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 29 May 2017 22:05:57 -0400 Subject: - Fixes for pattern-matching (case) analysis. - Small refactorings. - Improved common procedures analysis. - Can now handle tagged structures (variants & records). - Tests for pattern-matching, functions (definition & application), and common procedures. --- new-luxc/source/luxc/analyser/struct.lux | 348 ------------------------------- 1 file changed, 348 deletions(-) delete mode 100644 new-luxc/source/luxc/analyser/struct.lux (limited to 'new-luxc/source/luxc/analyser/struct.lux') diff --git a/new-luxc/source/luxc/analyser/struct.lux b/new-luxc/source/luxc/analyser/struct.lux deleted file mode 100644 index 562e30294..000000000 --- a/new-luxc/source/luxc/analyser/struct.lux +++ /dev/null @@ -1,348 +0,0 @@ -(;module: - lux - (lux (control monad - pipe) - [io #- run] - [function] - (concurrency ["A" atom]) - (data [text "T/" Eq] - text/format - [ident] - (coll [list "L/" Fold Monoid Monad] - ["D" dict] - ["S" set]) - [number] - [product]) - [macro #+ Monad] - (macro [code]) - [type] - (type ["TC" check])) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis] - ["lp" pattern]) - ["&;" module] - ["&;" env] - (analyser ["&;" common] - ["&;" inference]))) - -## [Analysers] -(def: (analyse-typed-product analyse members) - (-> &;Analyser (List Code) (Lux Analysis)) - (do Monad - [expected macro;expected-type] - (loop [expected expected - members members] - (case [expected members] - [(#;Product leftT rightT) (#;Cons leftC rightC)] - (do @ - [leftA (&;with-expected-type leftT - (analyse leftC)) - rightA (recur rightT rightC)] - (wrap (#la;Product leftA rightA))) - - [tailT (#;Cons tailC #;Nil)] - (&;with-expected-type tailT - (analyse tailC)) - - [tailT tailC] - (do @ - [g!tail (macro;gensym "tail")] - (&;with-expected-type tailT - (analyse (` ((~' _lux_case) [(~@ tailC)] - (~ g!tail) - (~ g!tail)))))) - )))) - -(def: #export (normalize-record pairs) - (-> (List [Code Code]) (Lux (List [Ident Code]))) - (mapM Monad - (function [[key val]] - (case key - [_ (#;Tag key)] - (do Monad - [key (macro;normalize key)] - (wrap [key val])) - - _ - (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) - pairs)) - -(def: #export (order-record pairs) - (-> (List [Ident Code]) (Lux [(List Code) Type])) - (case pairs - (#;Cons [head-k head-v] _) - (do Monad - [head-k (macro;normalize head-k) - [_ tag-set recordT] (macro;resolve-tag head-k) - #let [size-record (list;size pairs) - size-ts (list;size tag-set)] - _ (if (n.= size-ts size-record) - (wrap []) - (&;fail (format "Record size does not match tag-set size." "\n" - "Expected: " (|> size-ts nat-to-int %i) "\n" - " Actual: " (|> size-record nat-to-int %i) "\n" - "For type: " (%type recordT)))) - #let [tuple-range (list;n.range +0 size-ts) - tag->idx (D;from-list ident;Hash (list;zip2 tag-set tuple-range))] - idx->val (foldM @ - (function [[key val] idx->val] - (do @ - [key (macro;normalize key)] - (case (D;get key tag->idx) - #;None - (&;fail (format "Tag " (%code (code;tag key)) - " does not belong to tag-set for type " (%type recordT))) - - (#;Some idx) - (if (D;contains? idx idx->val) - (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) - (wrap (D;put idx val idx->val)))))) - (: (D;Dict Nat Code) - (D;new number;Hash)) - pairs) - #let [ordered-tuple (L/map (function [idx] - (assume (D;get idx idx->val))) - tuple-range)]] - (wrap [ordered-tuple recordT])) - - _ - (:: Monad wrap [(list) Unit]))) - -(def: (tuple members) - (-> (List Analysis) Analysis) - (case members - #;Nil - #la;Unit - - (#;Cons singleton #;Nil) - singleton - - (#;Cons left right) - (#la;Product left (tuple right)))) - -(def: #export (analyse-product analyse membersC) - (-> &;Analyser (List Code) (Lux Analysis)) - (do Monad - [expected macro;expected-type] - (&;with-stacked-errors - (function [_] (format "Invalid type for tuple: " (%type expected))) - (case expected - (#;Product _) - (analyse-typed-product analyse membersC) - - (#;Named name unnamedT) - (&;with-expected-type unnamedT - (analyse-product analyse membersC)) - - (#;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-product analyse membersC))) - (do @ - [membersTA (mapM @ (|>. analyse &common;with-unknown-type) - membersC) - _ (&;within-type-env - (TC;check expected - (type;tuple (L/map product;left membersTA))))] - (wrap (tuple (L/map product;right membersTA)))))) - - (#;UnivQ _) - (do @ - [[var-id var] (&;within-type-env - TC;existential)] - (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-product analyse membersC))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-product analyse membersC)))) - - _ - (&;fail "") - )))) - -(def: (record-function-type type) - (-> Type (Lux Type)) - (case type - (#;Named name unnamedT) - (do Monad - [unnamedT+ (record-function-type unnamedT)] - (wrap (#;Named name unnamedT+))) - - (^template [] - ( env bodyT) - (do Monad - [bodyT+ (record-function-type bodyT)] - (wrap ( env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) - - (#;Product _) - (:: Monad wrap (type;function (type;flatten-tuple type) type)) - - _ - (&;fail (format "Not a record type: " (%type type))))) - -(def: (out-of-bounds-error type size tag) - (All [a] (-> Type Nat Nat (Lux a))) - (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n" - " Tag: " (%i (nat-to-int tag)) "\n" - "Size: " (%i (nat-to-int size)) "\n" - "Type: " (%type type)))) - -(def: (variant-function-type tag expected-size type) - (-> Nat Nat Type (Lux Type)) - (case type - (#;Named name unnamedT) - (do Monad - [unnamedT+ (record-function-type unnamedT)] - (wrap (#;Named name unnamedT+))) - - (^template [] - ( env bodyT) - (do Monad - [bodyT+ (record-function-type bodyT)] - (wrap ( env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) - - (#;Sum _) - (let [cases (type;flatten-variant type) - actual-size (list;size cases) - boundary (n.dec expected-size)] - (cond (or (n.= expected-size actual-size) - (and (n.> expected-size actual-size) - (n.< boundary tag))) - (case (list;nth tag cases) - (#;Some caseT) - (:: Monad wrap (type;function (list caseT) type)) - - #;None - (out-of-bounds-error type expected-size tag)) - - (n.< expected-size actual-size) - (&;fail (format "Variant type is smaller than expected." "\n" - "Expected: " (%i (nat-to-int expected-size)) "\n" - " Actual: " (%i (nat-to-int actual-size)))) - - (n.= boundary tag) - (let [caseT (type;variant (list;drop boundary cases))] - (:: Monad wrap (type;function (list caseT) type))) - - ## else - (out-of-bounds-error type expected-size tag))) - - _ - (&;fail (format "Not a variant type: " (%type type))))) - -(def: #export (analyse-record analyse members) - (-> &;Analyser (List [Code Code]) (Lux Analysis)) - (do Monad - [members (normalize-record members) - [members recordT] (order-record members) - expectedT macro;expected-type - functionT (record-function-type recordT) - [inferredT membersA] (&inference;apply-function analyse functionT members) - _ (&;within-type-env - (TC;check expectedT inferredT))] - (wrap (tuple membersA)))) - -(do-template [ ] - [(def: ( inner) - (-> Analysis Analysis) - (#la;Sum ( inner)))] - - [sum-left #;Left] - [sum-right #;Right]) - -(def: (variant tag size temp value) - (-> Nat Nat Nat Analysis Analysis) - (let [last-tag (n.dec size)] - (if (n.= last-tag tag) - (L/fold (function;const sum-left) - (sum-right value) - (list;n.range +0 last-tag)) - (L/fold (function;const sum-left) - (case value - (#la;Sum _) - (#la;Case value (list [(#lp;Bind temp) - (#la;Relative (#;Local temp))])) - - _ - value) - (list;n.range +0 tag))))) - -(def: #export (analyse-tagged-sum analyse tag value) - (-> &;Analyser Ident Code (Lux Analysis)) - (do Monad - [tag (macro;normalize tag) - [idx group variantT] (macro;resolve-tag tag) - #let [case-size (list;size group)] - functionT (variant-function-type idx case-size variantT) - [inferredT valueA+] (&inference;apply-function analyse functionT (list value)) - expectedT macro;expected-type - _ (&;within-type-env - (TC;check expectedT inferredT)) - temp &env;next-local] - (wrap (variant idx case-size temp (|> valueA+ list;head assume))))) - -(def: #export (analyse-sum analyse tag valueC) - (-> &;Analyser Nat Code (Lux Analysis)) - (do Monad - [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)] - (case (list;nth tag flat) - (#;Some variant-type) - (do @ - [valueA (&;with-expected-type variant-type - (analyse valueC)) - temp &env;next-local] - (wrap (variant tag type-size temp valueA))) - - #;None - (out-of-bounds-error expected type-size tag))) - - (#;Named name unnamedT) - (&;with-expected-type unnamedT - (analyse-sum analyse tag valueC)) - - (#;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-sum analyse tag valueC))) - (&;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-sum analyse tag valueC))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-sum analyse tag valueC)))) - - _ - (&;fail ""))))) -- cgit v1.2.3