- 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.

1 files changed, 0 insertions, 348 deletions

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>]
-             text/format
-             [ident]
-             (coll [list "L/" Fold<List> Monoid<List> Monad<List>]
-                   ["D" dict]
-                   ["S" set])
-             [number]
-             [product])
-       [macro #+ Monad<Lux>]
-       (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<Lux>
-    [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<Lux>
-        (function [[key val]]
-          (case key
-            [_ (#;Tag key)]
-            (do Monad<Lux>
-              [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<Lux>
-      [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<Ident> (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<Nat>))
-                       pairs)
-       #let [ordered-tuple (L/map (function [idx]
-                                    (assume (D;get idx idx->val)))
-                                  tuple-range)]]
-      (wrap [ordered-tuple recordT]))
-
-    _
-    (:: Monad<Lux> 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<Lux>
-    [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<Lux>
-      [unnamedT+ (record-function-type unnamedT)]
-      (wrap (#;Named name unnamedT+)))
-
-    (^template [<tag>]
-      (<tag> env bodyT)
-      (do Monad<Lux>
-        [bodyT+ (record-function-type bodyT)]
-        (wrap (<tag> env bodyT+))))
-    ([#;UnivQ]
-     [#;ExQ])
-
-    (#;Product _)
-    (:: Monad<Lux> 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<Lux>
-      [unnamedT+ (record-function-type unnamedT)]
-      (wrap (#;Named name unnamedT+)))
-
-    (^template [<tag>]
-      (<tag> env bodyT)
-      (do Monad<Lux>
-        [bodyT+ (record-function-type bodyT)]
-        (wrap (<tag> 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<Lux> 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<Lux> 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<Lux>
-    [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 [<name> <side>]
-  [(def: (<name> inner)
-     (-> Analysis Analysis)
-     (#la;Sum (<side> 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<Lux>
-    [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<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)]
-          (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 "")))))