1 files changed, 358 insertions, 0 deletions
diff --git a/stdlib/source/lux/lang/analysis/structure.lux b/stdlib/source/lux/lang/analysis/structure.lux
new file mode 100644
index 000000000..cc185ebe9
--- /dev/null
+++ b/stdlib/source/lux/lang/analysis/structure.lux
@@ -0,0 +1,358 @@
+(.module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       (data [ident]
+             [number]
+             [product]
+             [maybe]
+             (coll [list "list/" Functor<List>]
+                   (dictionary ["dict" unordered #+ Dict]))
+             text/format)
+       [macro]
+       (macro [code])
+       [lang]
+       (lang [type]
+             (type ["tc" check])
+             [analysis #+ Analysis Analyser]
+             (analysis [".A" type]
+                       [".A" primitive]
+                       [".A" inference]))))
+
+(exception: #export (invalid-variant-type {type Type} {tag analysis.Tag} {code Code})
+  (ex.report ["Type" (%type type)]
+             ["Tag" (%n tag)]
+             ["Expression" (%code code)]))
+
+(do-template [<name>]
+  [(exception: #export (<name> {type Type} {members (List Code)})
+     (ex.report ["Type" (%type type)]
+                ["Expression" (%code (` [(~+ members)]))]))]
+
+  [invalid-tuple-type]
+  [cannot-analyse-tuple]
+  )
+
+(exception: #export (not-a-quantified-type {type Type})
+  (%type type))
+
+(do-template [<name>]
+  [(exception: #export (<name> {type Type} {tag analysis.Tag} {code Code})
+     (ex.report ["Type" (%type type)]
+                ["Tag" (%n tag)]
+                ["Expression" (%code code)]))]
+
+  [cannot-analyse-variant]
+  [cannot-infer-numeric-tag]
+  )
+
+(exception: #export (record-keys-must-be-tags {key Code} {record (List [Code Code])})
+  (ex.report ["Key" (%code key)]
+             ["Record" (%code (code.record record))]))
+
+(do-template [<name>]
+  [(exception: #export (<name> {key Ident} {record (List [Ident Code])})
+     (ex.report ["Tag" (%code (code.tag key))]
+                ["Record" (%code (code.record (list/map (function (_ [keyI valC])
+                                                          [(code.tag keyI) valC])
+                                                        record)))]))]
+
+  [cannot-repeat-tag]
+  )
+
+(exception: #export (tag-does-not-belong-to-record {key Ident} {type Type})
+  (ex.report ["Tag" (%code (code.tag key))]
+             ["Type" (%type type)]))
+
+(exception: #export (record-size-mismatch {expected Nat} {actual Nat} {type Type} {record (List [Ident Code])})
+  (ex.report ["Expected" (|> expected .int %i)]
+             ["Actual" (|> actual .int %i)]
+             ["Type" (%type type)]
+             ["Expression" (%code (|> record
+                                      (list/map (function (_ [keyI valueC])
+                                                  [(code.tag keyI) valueC]))
+                                      code.record))]))
+
+(def: #export (sum analyse tag valueC)
+  (-> Analyser Nat Code (Meta Analysis))
+  (do macro.Monad<Meta>
+    [expectedT macro.expected-type]
+    (lang.with-stacked-errors
+      (function (_ _)
+        (ex.construct cannot-analyse-variant [expectedT tag valueC]))
+      (case expectedT
+        (#.Sum _)
+        (let [flat (type.flatten-variant expectedT)
+              type-size (list.size flat)]
+          (case (list.nth tag flat)
+            (#.Some variant-type)
+            (do @
+              [valueA (typeA.with-type variant-type
+                        (analyse valueC))]
+              (wrap (analysis.sum type-size tag valueA)))
+
+            #.None
+            (lang.throw inferenceA.variant-tag-out-of-bounds [type-size tag expectedT])))
+
+        (#.Named name unnamedT)
+        (typeA.with-type unnamedT
+          (sum analyse tag valueC))
+
+        (#.Var id)
+        (do @
+          [?expectedT' (typeA.with-env
+                         (tc.read id))]
+          (case ?expectedT'
+            (#.Some expectedT')
+            (typeA.with-type expectedT'
+              (sum analyse tag valueC))
+
+            _
+            ## Cannot do inference when the tag is numeric.
+            ## This is because there is no way of knowing how many
+            ## cases the inferred sum type would have.
+            (lang.throw cannot-infer-numeric-tag [expectedT tag valueC])
+            ))
+
+        (^template [<tag> <instancer>]
+          (<tag> _)
+          (do @
+            [[instance-id instanceT] (typeA.with-env <instancer>)]
+            (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT))
+              (sum analyse tag valueC))))
+        ([#.UnivQ tc.existential]
+         [#.ExQ tc.var])
+
+        (#.Apply inputT funT)
+        (case funT
+          (#.Var funT-id)
+          (do @
+            [?funT' (typeA.with-env (tc.read funT-id))]
+            (case ?funT'
+              (#.Some funT')
+              (typeA.with-type (#.Apply inputT funT')
+                (sum analyse tag valueC))
+
+              _
+              (lang.throw invalid-variant-type [expectedT tag valueC])))
+
+          _
+          (case (type.apply (list inputT) funT)
+            #.None
+            (lang.throw not-a-quantified-type funT)
+            
+            (#.Some outputT)
+            (typeA.with-type outputT
+              (sum analyse tag valueC))))
+        
+        _
+        (lang.throw invalid-variant-type [expectedT tag valueC])))))
+
+(def: (typed-product analyse membersC+)
+  (-> Analyser (List Code) (Meta Analysis))
+  (do macro.Monad<Meta>
+    [expectedT macro.expected-type]
+    (loop [expectedT expectedT
+           membersC+ membersC+]
+      (case [expectedT membersC+]
+        ## If the tuple runs out, whatever expression is the last gets
+        ## matched to the remaining type.
+        [tailT (#.Cons tailC #.Nil)]
+        (typeA.with-type tailT
+          (analyse tailC))
+
+        ## If the type and the code are still ongoing, match each
+        ## sub-expression to its corresponding type.
+        [(#.Product leftT rightT) (#.Cons leftC rightC)]
+        (do @
+          [leftA (typeA.with-type leftT
+                   (analyse leftC))
+           rightA (recur rightT rightC)]
+          (wrap (#analysis.Structure (#analysis.Product leftA rightA))))
+
+        ## If, however, the type runs out but there is still enough
+        ## tail, the remaining elements get packaged into another
+        ## tuple.
+        ## The reason for this is that it is assumed that the type of
+        ## the tuple represents the expectations of the user.
+        ## If the type is for a 3-tuple, but a 5-tuple is provided, it
+        ## is assumed that the user intended the following layout:
+        ## [0, 1, [2, 3, 4]]
+        ## but that, for whatever reason, it was written in a flat
+        ## way.
+        [tailT tailC]
+        (|> tailC
+            code.tuple
+            analyse
+            (typeA.with-type tailT)
+            (:: @ map analysis.no-op))))))
+
+(def: #export (product analyse membersC)
+  (-> Analyser (List Code) (Meta Analysis))
+  (do macro.Monad<Meta>
+    [expectedT macro.expected-type]
+    (lang.with-stacked-errors
+      (function (_ _)
+        (ex.construct cannot-analyse-tuple [expectedT membersC]))
+      (case expectedT
+        (#.Product _)
+        (..typed-product analyse membersC)
+
+        (#.Named name unnamedT)
+        (typeA.with-type unnamedT
+          (product analyse membersC))
+
+        (#.Var id)
+        (do @
+          [?expectedT' (typeA.with-env
+                         (tc.read id))]
+          (case ?expectedT'
+            (#.Some expectedT')
+            (typeA.with-type expectedT'
+              (product analyse membersC))
+
+            _
+            ## Must do inference...
+            (do @
+              [membersTA (monad.map @ (|>> analyse typeA.with-inference)
+                                    membersC)
+               _ (typeA.with-env
+                   (tc.check expectedT
+                             (type.tuple (list/map product.left membersTA))))]
+              (wrap (analysis.product (list/map product.right membersTA))))))
+
+        (^template [<tag> <instancer>]
+          (<tag> _)
+          (do @
+            [[instance-id instanceT] (typeA.with-env <instancer>)]
+            (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT))
+              (product analyse membersC))))
+        ([#.UnivQ tc.existential]
+         [#.ExQ tc.var])
+
+        (#.Apply inputT funT)
+        (case funT
+          (#.Var funT-id)
+          (do @
+            [?funT' (typeA.with-env (tc.read funT-id))]
+            (case ?funT'
+              (#.Some funT')
+              (typeA.with-type (#.Apply inputT funT')
+                (product analyse membersC))
+
+              _
+              (lang.throw invalid-tuple-type [expectedT membersC])))
+
+          _
+          (case (type.apply (list inputT) funT)
+            #.None
+            (lang.throw not-a-quantified-type funT)
+            
+            (#.Some outputT)
+            (typeA.with-type outputT
+              (product analyse membersC))))
+        
+        _
+        (lang.throw invalid-tuple-type [expectedT membersC])
+        ))))
+
+(def: #export (tagged-sum analyse tag valueC)
+  (-> Analyser Ident Code (Meta Analysis))
+  (do macro.Monad<Meta>
+    [tag (macro.normalize tag)
+     [idx group variantT] (macro.resolve-tag tag)
+     expectedT macro.expected-type]
+    (case expectedT
+      (#.Var _)
+      (do @
+        [#let [case-size (list.size group)]
+         inferenceT (inferenceA.variant idx case-size variantT)
+         [inferredT valueA+] (inferenceA.general analyse inferenceT (list valueC))]
+        (wrap (analysis.sum case-size idx (|> valueA+ list.head maybe.assume))))
+
+      _
+      (..sum analyse idx valueC))))
+
+## There cannot be any ambiguity or improper syntax when analysing
+## records, so they must be normalized for further analysis.
+## Normalization just means that all the tags get resolved to their
+## canonical form (with their corresponding module identified).
+(def: #export (normalize record)
+  (-> (List [Code Code]) (Meta (List [Ident Code])))
+  (monad.map macro.Monad<Meta>
+             (function (_ [key val])
+               (case key
+                 [_ (#.Tag key)]
+                 (do macro.Monad<Meta>
+                   [key (macro.normalize key)]
+                   (wrap [key val]))
+
+                 _
+                 (lang.throw record-keys-must-be-tags [key record])))
+             record))
+
+## Lux already possesses the means to analyse tuples, so
+## re-implementing the same functionality for records makes no sense.
+## Records, thus, get transformed into tuples by ordering the elements.
+(def: #export (order record)
+  (-> (List [Ident Code]) (Meta [(List Code) Type]))
+  (case record
+    ## empty-record = empty-tuple = unit = []
+    #.Nil
+    (:: macro.Monad<Meta> wrap [(list) Top])
+
+    (#.Cons [head-k head-v] _)
+    (do macro.Monad<Meta>
+      [head-k (macro.normalize head-k)
+       [_ tag-set recordT] (macro.resolve-tag head-k)
+       #let [size-record (list.size record)
+             size-ts (list.size tag-set)]
+       _ (if (n/= size-ts size-record)
+           (wrap [])
+           (lang.throw record-size-mismatch [size-ts size-record recordT record]))
+       #let [tuple-range (list.n/range +0 (dec size-ts))
+             tag->idx (dict.from-list ident.Hash<Ident> (list.zip2 tag-set tuple-range))]
+       idx->val (monad.fold @
+                            (function (_ [key val] idx->val)
+                              (do @
+                                [key (macro.normalize key)]
+                                (case (dict.get key tag->idx)
+                                  #.None
+                                  (lang.throw tag-does-not-belong-to-record [key recordT])
+
+                                  (#.Some idx)
+                                  (if (dict.contains? idx idx->val)
+                                    (lang.throw cannot-repeat-tag [key record])
+                                    (wrap (dict.put idx val idx->val))))))
+                            (: (Dict Nat Code)
+                               (dict.new number.Hash<Nat>))
+                            record)
+       #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val)))
+                                     tuple-range)]]
+      (wrap [ordered-tuple recordT]))
+    ))
+
+(def: #export (record analyse members)
+  (-> Analyser (List [Code Code]) (Meta Analysis))
+  (do macro.Monad<Meta>
+    [members (normalize members)
+     [membersC recordT] (order members)]
+    (case membersC
+      (^ (list))
+      primitiveA.unit
+      
+      (^ (list singletonC))
+      (analyse singletonC)
+
+      _
+      (do @
+        [expectedT macro.expected-type]
+        (case expectedT
+          (#.Var _)
+          (do @
+            [inferenceT (inferenceA.record recordT)
+             [inferredT membersA] (inferenceA.general analyse inferenceT membersC)]
+            (wrap (analysis.product membersA)))
+
+          _
+          (..product analyse membersC))))))