- Migrated structure analysis to stdlib.

- Added an easy way to report information in exceptions.

8 files changed, 1106 insertions, 9 deletions

diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
index b515f6c6b..d866c153e 100644
--- a/stdlib/source/lux/control/exception.lux
+++ b/stdlib/source/lux/control/exception.lux
@@ -4,8 +4,9 @@
                 ["p" parser])
        (data ["e" error]
              [maybe]
+             [product]
              [text "text/" Monoid<Text>]
-             (coll [list "list/" Functor<List>]))
+             (coll [list "list/" Functor<List> Fold<List>]))
        [macro]
        (macro [code]
               ["s" syntax #+ syntax: Syntax]
@@ -99,3 +100,22 @@
                                            ((~! text/compose) (~ g!descriptor)
                                             (~ (maybe.default (' "") body))))})))))
       )))
+
+(def: #export (report' entries)
+  (-> (List [Text Text]) Text)
+  (let [largest-header-size (|> entries
+                                (list/map (|>> product.left text.size))
+                                (list/fold n/max +0))]
+    (|> entries
+        (list/map (function (_ [header message])
+                    (let [padding (|> " "
+                                      (list.repeat (n/- (text.size header)
+                                                        largest-header-size))
+                                      (text.join-with ""))]
+                      ($_ text/compose padding header ": " message))))
+        (text.join-with "\n"))))
+
+(syntax: #export (report {entries (p.many (s.tuple (p.seq s.any s.any)))})
+  (wrap (list (` (report' (list (~+ (|> entries
+                                        (list/map (function (_ [header message])
+                                                    (` [(~ header) (~ message)])))))))))))
diff --git a/stdlib/source/lux/data/coll/dictionary/plist.lux b/stdlib/source/lux/data/coll/dictionary/plist.lux
new file mode 100644
index 000000000..e9e08107a
--- /dev/null
+++ b/stdlib/source/lux/data/coll/dictionary/plist.lux
@@ -0,0 +1,62 @@
+(.module:
+  lux
+  (lux (data [text "text/" Eq<Text>])))
+
+(type: #export (PList a)
+  (List [Text a]))
+
+(def: #export (get key properties)
+  (All [a] (-> Text (PList a) (Maybe a)))
+  (case properties
+    #.Nil
+    #.None
+
+    (#.Cons [k' v'] properties')
+    (if (text/= key k')
+      (#.Some v')
+      (get key properties'))))
+
+(def: #export (contains? key properties)
+  (All [a] (-> Text (PList a) Bool))
+  (case (get key properties)
+    (#.Some _)
+    true
+
+    #.None
+    false))
+
+(def: #export (put key val properties)
+  (All [a] (-> Text a (PList a) (PList a)))
+  (case properties
+    #.Nil
+    (list [key val])
+
+    (#.Cons [k' v'] properties')
+    (if (text/= key k')
+      (#.Cons [key val]
+              properties')
+      (#.Cons [k' v']
+              (put key val properties')))))
+
+(def: #export (update key f properties)
+  (All [a] (-> Text (-> a a) (PList a) (PList a)))
+  (case properties
+    #.Nil
+    #.Nil
+
+    (#.Cons [k' v'] properties')
+    (if (text/= key k')
+      (#.Cons [k' (f v')] properties')
+      (#.Cons [k' v'] (update key f properties')))))
+
+(def: #export (remove key properties)
+  (All [a] (-> Text (PList a) (PList a)))
+  (case properties
+    #.Nil
+    properties
+
+    (#.Cons [k' v'] properties')
+    (if (text/= key k')
+      properties'
+      (#.Cons [k' v']
+              (remove key properties')))))
diff --git a/stdlib/source/lux/lang.lux b/stdlib/source/lux/lang.lux
index c4a4e2db3..9f164b719 100644
--- a/stdlib/source/lux/lang.lux
+++ b/stdlib/source/lux/lang.lux
@@ -9,6 +9,9 @@
        [macro]
        (macro ["s" syntax #+ syntax:])))
 
+(type: #export Eval
+  (-> Type Code (Meta Top)))
+
 (def: #export (fail message)
   (All [a] (-> Text (Meta a)))
   (do macro.Monad<Meta>
diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux
index 46927bae1..6b2ba097d 100644
--- a/stdlib/source/lux/lang/analysis.lux
+++ b/stdlib/source/lux/lang/analysis.lux
@@ -48,10 +48,12 @@
   (#Constant Ident)
   (#Special (Special Text)))
 
-## Variants get analysed as binary sum types for the sake of semantic
-## simplicity.
-## This is because you can encode a variant of any size using just
-## binary sums by nesting them.
+(type: #export Variant
+  {#lefts Nat
+   #right? Bool
+   #value Analysis})
+
+(type: #export Tuple (List Analysis))
 
 (do-template [<name> <tag>]
   [(def: <name>
@@ -71,8 +73,8 @@
   (let [identity (#Function (list) (#Variable (#Local +1)))]
     (#Apply value identity)))
 
-(def: #export (sum tag size temp value)
-  (-> Tag Nat Register Analysis Analysis)
+(def: #export (sum size tag value)
+  (-> Nat Tag Analysis Analysis)
   (if (last? size tag)
     (if (n/= +1 tag)
       (..right value)
@@ -88,8 +90,8 @@
                  value)
                (list.n/range +0 tag))))
 
-(def: #export (tuple members)
-  (-> (List Analysis) Analysis)
+(def: #export (product members)
+  (-> Tuple Analysis)
   (case (list.reverse members)
     #.Nil
     (#Primitive #Unit)
@@ -107,3 +109,35 @@
 
 (type: #export Analyser
   (-> Code (Meta Analysis)))
+
+(def: #export (tuple analysis)
+  (-> Analysis Tuple)
+  (case analysis
+    (#Structure (#Product left right))
+    (#.Cons left (tuple right))
+
+    _
+    (list analysis)))
+
+(def: #export (variant analysis)
+  (-> Analysis (Maybe Variant))
+  (loop [lefts +0
+         variantA analysis]
+    (case variantA
+      (#Structure (#Sum (#.Left valueA)))
+      (case valueA
+        (#Structure (#Sum _))
+        (recur (inc lefts) valueA)
+
+        _
+        (#.Some {#lefts lefts
+                 #right? false
+                 #value valueA}))
+      
+      (#Structure (#Sum (#.Right valueA)))
+      (#.Some {#lefts lefts
+               #right? true
+               #value valueA})
+
+      _
+      #.None)))
diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux
new file mode 100644
index 000000000..a22e3d32b
--- /dev/null
+++ b/stdlib/source/lux/lang/analysis/expression.lux
@@ -0,0 +1,125 @@
+(.module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       (data ["e" error]
+             [product]
+             text/format)
+       [macro]
+       [lang #+ Eval]
+       (lang [type]
+             (type ["tc" check])
+             [".L" analysis #+ Analysis Analyser]
+             (analysis [".A" type]
+                       [".A" primitive]
+                       [".A" structure]
+                       ## [".A" function]
+                       ## [".A" reference]
+                       )
+             ## [".L" macro]
+             ## [".L" extension]
+             )))
+
+(exception: #export (macro-expansion-failed {message Text})
+  message)
+
+(do-template [<name>]
+  [(exception: #export (<name> {code Code})
+     (%code code))]
+
+  [macro-call-must-have-single-expansion]
+  [unrecognized-syntax]
+  )
+
+(def: #export (analyser eval)
+  (-> Eval Analyser)
+  (: (-> Code (Meta Analysis))
+     (function (analyse code)
+       (do macro.Monad<Meta>
+         [expectedT macro.expected-type]
+         (let [[cursor code'] code]
+           ## The cursor must be set in the compiler for the sake
+           ## of having useful error messages.
+           (lang.with-cursor cursor
+             (case code'
+               (^template [<tag> <analyser>]
+                 (<tag> value)
+                 (<analyser> value))
+               ([#.Bool primitiveA.bool]
+                [#.Nat  primitiveA.nat]
+                [#.Int  primitiveA.int]
+                [#.Deg  primitiveA.deg]
+                [#.Frac primitiveA.frac]
+                [#.Text primitiveA.text])
+
+               (^template [<tag> <analyser>]
+                 (^ (#.Form (list& [_ (<tag> tag)]
+                                   values)))
+                 (case values
+                   (#.Cons value #.Nil)
+                   (<analyser> analyse tag value)
+
+                   _
+                   (<analyser> analyse tag (` [(~+ values)]))))
+               ([#.Nat structureA.sum]
+                [#.Tag structureA.tagged-sum])
+
+               (#.Tag tag)
+               (structureA.tagged-sum analyse tag (' []))
+
+               (^ (#.Tuple (list)))
+               primitiveA.unit
+
+               (^ (#.Tuple (list singleton)))
+               (analyse singleton)
+
+               (^ (#.Tuple elems))
+               (structureA.product analyse elems)
+
+               (^ (#.Record pairs))
+               (structureA.record analyse pairs)
+
+               ## (#.Symbol reference)
+               ## (referenceA.analyse-reference reference)
+
+               ## (^ (#.Form (list& [_ (#.Text proc-name)] proc-args)))
+               ## (do macro.Monad<Meta>
+               ##   [procedure (extensionL.find-analysis proc-name)]
+               ##   (procedure analyse eval proc-args))
+
+               ## (^ (#.Form (list& func args)))
+               ## (do macro.Monad<Meta>
+               ##   [[funcT funcA] (typeA.with-inference
+               ##                    (analyse func))]
+               ##   (case funcA
+               ##     [_ (#.Symbol def-name)]
+               ##     (do @
+               ##       [?macro (lang.with-error-tracking
+               ##                 (macro.find-macro def-name))]
+               ##       (case ?macro
+               ##         (#.Some macro)
+               ##         (do @
+               ##           [expansion (: (Meta (List Code))
+               ##                         (function (_ compiler)
+               ##                           (case (macroL.expand macro args compiler)
+               ##                             (#e.Error error)
+               ##                             ((lang.throw macro-expansion-failed error) compiler)
+
+               ##                             output
+               ##                             output)))]
+               ##           (case expansion
+               ##             (^ (list single))
+               ##             (analyse single)
+
+               ##             _
+               ##             (lang.throw macro-call-must-have-single-expansion code)))
+
+               ##         _
+               ##         (functionA.analyse-apply analyse funcT funcA args)))
+
+               ##     _
+               ##     (functionA.analyse-apply analyse funcT funcA args)))
+
+               _
+               (lang.throw unrecognized-syntax code)
+               )))))))
diff --git a/stdlib/source/lux/lang/analysis/inference.lux b/stdlib/source/lux/lang/analysis/inference.lux
new file mode 100644
index 000000000..732a8e6e3
--- /dev/null
+++ b/stdlib/source/lux/lang/analysis/inference.lux
@@ -0,0 +1,256 @@
+(.module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       (data [maybe]
+             [text]
+             text/format
+             (coll [list "list/" Functor<List>]))
+       [macro "macro/" Monad<Meta>]
+       [lang]
+       (lang [type]
+             (type ["tc" check])
+             [analysis #+ Analysis Analyser]
+             (analysis [".A" type]))))
+
+(exception: #export (variant-tag-out-of-bounds {size Nat} {tag analysis.Tag} {type Type})
+  (ex.report ["Tag" (%n tag)]
+             ["Variant size" (%n size)]
+             ["Variant type" (%type type)]))
+
+(exception: #export (cannot-infer {type Type} {args (List Code)})
+  (ex.report ["Type" (%type type)]
+             ["Arguments" (|> args
+                              list.enumerate
+                              (list/map (function (_ [idx argC])
+                                          (format "\n  " (%n idx) " " (%code argC))))
+                              (text.join-with ""))]))
+
+(exception: #export (cannot-infer-argument {inferred Type} {argument Code})
+  (ex.report ["Inferred Type" (%type inferred)]
+             ["Argument" (%code argument)]))
+
+(exception: #export (smaller-variant-than-expected {expected Nat} {actual Nat})
+  (ex.report ["Expected" (%i (.int expected))]
+             ["Actual" (%i (.int actual))]))
+
+(do-template [<name>]
+  [(exception: #export (<name> {type Type})
+     (%type type))]
+
+  [not-a-variant-type]
+  [not-a-record-type]
+  [invalid-type-application]
+  )
+
+(def: (replace-bound bound-idx replacementT type)
+  (-> Nat Type Type Type)
+  (case type
+    (#.Primitive name params)
+    (#.Primitive name (list/map (replace-bound bound-idx replacementT) params))
+
+    (^template [<tag>]
+      (<tag> left right)
+      (<tag> (replace-bound bound-idx replacementT left)
+             (replace-bound bound-idx replacementT right)))
+    ([#.Sum]
+     [#.Product]
+     [#.Function]
+     [#.Apply])
+    
+    (#.Bound idx)
+    (if (n/= bound-idx idx)
+      replacementT
+      type)
+
+    (^template [<tag>]
+      (<tag> env quantified)
+      (<tag> (list/map (replace-bound bound-idx replacementT) env)
+             (replace-bound (n/+ +2 bound-idx) replacementT quantified)))
+    ([#.UnivQ]
+     [#.ExQ])
+    
+    _
+    type))
+
+(def: new-named-type
+  (Meta Type)
+  (do macro.Monad<Meta>
+    [[_module _line _column] macro.cursor
+     [ex-id exT] (typeA.with-env tc.existential)]
+    (wrap (#.Primitive (format "{New Type @ " (%t _module)
+                               "," (%n _line)
+                               "," (%n _column)
+                               "} " (%n ex-id))
+                       (list)))))
+
+## Type-inference works by applying some (potentially quantified) type
+## to a sequence of values.
+## Function types are used for this, although inference is not always
+## done for function application (alternative uses may be records and
+## tagged variants).
+## But, so long as the type being used for the inference can be treated
+## as a function type, this method of inference should work.
+(def: #export (general analyse inferT args)
+  (-> Analyser Type (List Code) (Meta [Type (List Analysis)]))
+  (case args
+    #.Nil
+    (do macro.Monad<Meta>
+      [_ (typeA.infer inferT)]
+      (wrap [inferT (list)]))
+    
+    (#.Cons argC args')
+    (case inferT
+      (#.Named name unnamedT)
+      (general analyse unnamedT args)
+
+      (#.UnivQ _)
+      (do macro.Monad<Meta>
+        [[var-id varT] (typeA.with-env tc.var)]
+        (general analyse (maybe.assume (type.apply (list varT) inferT)) args))
+
+      (#.ExQ _)
+      (do macro.Monad<Meta>
+        [[var-id varT] (typeA.with-env tc.var)
+         output (general analyse
+                         (maybe.assume (type.apply (list varT) inferT))
+                         args)
+         bound? (typeA.with-env
+                  (tc.bound? var-id))
+         _ (if bound?
+             (wrap [])
+             (do @
+               [newT new-named-type]
+               (typeA.with-env
+                 (tc.check varT newT))))]
+        (wrap output))
+
+      (#.Apply inputT transT)
+      (case (type.apply (list inputT) transT)
+        (#.Some outputT)
+        (general analyse outputT args)
+
+        #.None
+        (lang.throw invalid-type-application inferT))
+
+      ## Arguments are inferred back-to-front because, by convention,
+      ## Lux functions take the most important arguments *last*, which
+      ## means that the most information for doing proper inference is
+      ## located in the last arguments to a function call.
+      ## By inferring back-to-front, a lot of type-annotations can be
+      ## avoided in Lux code, since the inference algorithm can piece
+      ## things together more easily.
+      (#.Function inputT outputT)
+      (do macro.Monad<Meta>
+        [[outputT' args'A] (general analyse outputT args')
+         argA (lang.with-stacked-errors
+                (function (_ _)
+                  (ex.construct cannot-infer-argument [inputT argC]))
+                (typeA.with-type inputT
+                  (analyse argC)))]
+        (wrap [outputT' (list& argA args'A)]))
+
+      (#.Var infer-id)
+      (do macro.Monad<Meta>
+        [?inferT' (typeA.with-env (tc.read infer-id))]
+        (case ?inferT'
+          (#.Some inferT')
+          (general analyse inferT' args)
+
+          _
+          (lang.throw cannot-infer [inferT args])))
+
+      _
+      (lang.throw cannot-infer [inferT args]))
+    ))
+
+## Turns a record type into the kind of function type suitable for inference.
+(def: #export (record inferT)
+  (-> Type (Meta Type))
+  (case inferT
+    (#.Named name unnamedT)
+    (record unnamedT)
+
+    (^template [<tag>]
+      (<tag> env bodyT)
+      (do macro.Monad<Meta>
+        [bodyT+ (record bodyT)]
+        (wrap (<tag> env bodyT+))))
+    ([#.UnivQ]
+     [#.ExQ])
+
+    (#.Apply inputT funcT)
+    (case (type.apply (list inputT) funcT)
+      (#.Some outputT)
+      (record outputT)
+
+      #.None
+      (lang.throw invalid-type-application inferT))
+
+    (#.Product _)
+    (macro/wrap (type.function (type.flatten-tuple inferT) inferT))
+
+    _
+    (lang.throw not-a-record-type inferT)))
+
+## Turns a variant type into the kind of function type suitable for inference.
+(def: #export (variant tag expected-size inferT)
+  (-> Nat Nat Type (Meta Type))
+  (loop [depth +0
+         currentT inferT]
+    (case currentT
+      (#.Named name unnamedT)
+      (do macro.Monad<Meta>
+        [unnamedT+ (recur depth unnamedT)]
+        (wrap unnamedT+))
+
+      (^template [<tag>]
+        (<tag> env bodyT)
+        (do macro.Monad<Meta>
+          [bodyT+ (recur (inc depth) bodyT)]
+          (wrap (<tag> env bodyT+))))
+      ([#.UnivQ]
+       [#.ExQ])
+
+      (#.Sum _)
+      (let [cases (type.flatten-variant currentT)
+            actual-size (list.size cases)
+            boundary (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)
+                (macro/wrap (if (n/= +0 depth)
+                              (type.function (list caseT) currentT)
+                              (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)]
+                                (type.function (list (replace! caseT))
+                                  (replace! currentT)))))
+
+                #.None
+                (lang.throw variant-tag-out-of-bounds [expected-size tag inferT]))
+              
+              (n/< expected-size actual-size)
+              (lang.throw smaller-variant-than-expected [expected-size actual-size])
+
+              (n/= boundary tag)
+              (let [caseT (type.variant (list.drop boundary cases))]
+                (macro/wrap (if (n/= +0 depth)
+                              (type.function (list caseT) currentT)
+                              (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)]
+                                (type.function (list (replace! caseT))
+                                  (replace! currentT))))))
+              
+              ## else
+              (lang.throw variant-tag-out-of-bounds [expected-size tag inferT])))
+
+      (#.Apply inputT funcT)
+      (case (type.apply (list inputT) funcT)
+        (#.Some outputT)
+        (variant tag expected-size outputT)
+
+        #.None
+        (lang.throw invalid-type-application inferT))
+
+      _
+      (lang.throw not-a-variant-type inferT))))
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))))))
diff --git a/stdlib/source/lux/lang/module.lux b/stdlib/source/lux/lang/module.lux
new file mode 100644
index 000000000..d5efb1d7e
--- /dev/null
+++ b/stdlib/source/lux/lang/module.lux
@@ -0,0 +1,239 @@
+(.module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:]
+                pipe)
+       (data [text "text/" Eq<Text>]
+             text/format
+             ["e" error]
+             (coll [list "list/" Fold<List> Functor<List>]
+                   (dictionary [plist])))
+       [macro])
+  [//])
+
+(type: #export Tag Text)
+
+(exception: #export (unknown-module {module Text})
+  module)
+
+(exception: #export (cannot-declare-tag-twice {module Text} {tag Text})
+  (format "Module: " module "\n"
+          "   Tag: " tag "\n"))
+
+(do-template [<name>]
+  [(exception: #export (<name> {tags (List Text)} {owner Type})
+     (format "Tags: " (text.join-with " " tags) "\n"
+             "Type: " (%type owner) "\n"))]
+
+  [cannot-declare-tags-for-unnamed-type]
+  [cannot-declare-tags-for-foreign-type]
+  )
+
+(exception: #export (cannot-define-more-than-once {name Ident})
+  (%ident name))
+
+(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State})
+  (format "       Module: " module "\n"
+          "Desired state: " (case state
+                              #.Active   "Active"
+                              #.Compiled "Compiled"
+                              #.Cached   "Cached") "\n"))
+
+(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code})
+  (format "         Module: " module "\n"
+          "Old annotations: " (%code old) "\n"
+          "New annotations: " (%code new) "\n"))
+
+(def: (new hash)
+  (-> Nat Module)
+  {#.module-hash        hash
+   #.module-aliases     (list)
+   #.definitions        (list)
+   #.imports            (list)
+   #.tags               (list)
+   #.types              (list)
+   #.module-annotations #.None
+   #.module-state       #.Active})
+
+(def: #export (set-annotations annotations)
+  (-> Code (Meta Top))
+  (do macro.Monad<Meta>
+    [self-name macro.current-module-name
+     self macro.current-module]
+    (case (get@ #.module-annotations self)
+      #.None
+      (function (_ compiler)
+        (#e.Success [(update@ #.modules
+                              (plist.put self-name (set@ #.module-annotations (#.Some annotations) self))
+                              compiler)
+                     []]))
+      
+      (#.Some old)
+      (//.throw cannot-set-module-annotations-more-than-once [self-name old annotations]))))
+
+(def: #export (import module)
+  (-> Text (Meta Top))
+  (do macro.Monad<Meta>
+    [self-name macro.current-module-name]
+    (function (_ compiler)
+      (#e.Success [(update@ #.modules
+                            (plist.update self-name (update@ #.imports (|>> (#.Cons module))))
+                            compiler)
+                   []]))))
+
+(def: #export (alias alias module)
+  (-> Text Text (Meta Top))
+  (do macro.Monad<Meta>
+    [self-name macro.current-module-name]
+    (function (_ compiler)
+      (#e.Success [(update@ #.modules
+                            (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text]))
+                                                                                 (|>> (#.Cons [alias module])))))
+                            compiler)
+                   []]))))
+
+(def: #export (exists? module)
+  (-> Text (Meta Bool))
+  (function (_ compiler)
+    (|> compiler
+        (get@ #.modules)
+        (plist.get module)
+        (case> (#.Some _) true #.None false)
+        [compiler] #e.Success)))
+
+(def: #export (define name definition)
+  (-> Text Definition (Meta []))
+  (do macro.Monad<Meta>
+    [self-name macro.current-module-name
+     self macro.current-module]
+    (function (_ compiler)
+      (case (plist.get name (get@ #.definitions self))
+        #.None
+        (#e.Success [(update@ #.modules
+                              (plist.put self-name
+                                         (update@ #.definitions
+                                                  (: (-> (List [Text Definition]) (List [Text Definition]))
+                                                     (|>> (#.Cons [name definition])))
+                                                  self))
+                              compiler)
+                     []])
+
+        (#.Some already-existing)
+        ((//.throw cannot-define-more-than-once [self-name name]) compiler)))))
+
+(def: #export (create hash name)
+  (-> Nat Text (Meta []))
+  (function (_ compiler)
+    (let [module (new hash)]
+      (#e.Success [(update@ #.modules
+                            (plist.put name module)
+                            compiler)
+                   []]))))
+
+(def: #export (with-module hash name action)
+  (All [a] (-> Nat Text (Meta a) (Meta [Module a])))
+  (do macro.Monad<Meta>
+    [_ (create hash name)
+     output (//.with-current-module name
+              action)
+     module (macro.find-module name)]
+    (wrap [module output])))
+
+(do-template [<setter> <asker> <tag>]
+  [(def: #export (<setter> module-name)
+     (-> Text (Meta Top))
+     (function (_ compiler)
+       (case (|> compiler (get@ #.modules) (plist.get module-name))
+         (#.Some module)
+         (let [active? (case (get@ #.module-state module)
+                         #.Active true
+                         _     false)]
+           (if active?
+             (#e.Success [(update@ #.modules
+                                   (plist.put module-name (set@ #.module-state <tag> module))
+                                   compiler)
+                          []])
+             ((//.throw can-only-change-state-of-active-module [module-name <tag>])
+              compiler)))
+
+         #.None
+         ((//.throw unknown-module module-name) compiler))))
+   
+   (def: #export (<asker> module-name)
+     (-> Text (Meta Bool))
+     (function (_ compiler)
+       (case (|> compiler (get@ #.modules) (plist.get module-name))
+         (#.Some module)
+         (#e.Success [compiler
+                      (case (get@ #.module-state module)
+                        <tag> true
+                        _     false)])
+
+         #.None
+         ((//.throw unknown-module module-name) compiler))))]
+
+  [set-active   active?   #.Active]
+  [set-compiled compiled? #.Compiled]
+  [set-cached   cached?   #.Cached]
+  )
+
+(do-template [<name> <tag> <type>]
+  [(def: (<name> module-name)
+     (-> Text (Meta <type>))
+     (function (_ compiler)
+       (case (|> compiler (get@ #.modules) (plist.get module-name))
+         (#.Some module)
+         (#e.Success [compiler (get@ <tag> module)])
+
+         #.None
+         ((//.throw unknown-module module-name) compiler))))]
+
+  [tags  #.tags        (List [Text [Nat (List Ident) Bool Type]])]
+  [types #.types       (List [Text [(List Ident) Bool Type]])]
+  [hash  #.module-hash Nat]
+  )
+
+(def: (ensure-undeclared-tags module-name tags)
+  (-> Text (List Tag) (Meta Top))
+  (do macro.Monad<Meta>
+    [bindings (..tags module-name)
+     _ (monad.map @
+                  (function (_ tag)
+                    (case (plist.get tag bindings)
+                      #.None
+                      (wrap [])
+
+                      (#.Some _)
+                      (//.throw cannot-declare-tag-twice [module-name tag])))
+                  tags)]
+    (wrap [])))
+
+(def: #export (declare-tags tags exported? type)
+  (-> (List Tag) Bool Type (Meta Top))
+  (do macro.Monad<Meta>
+    [self-name macro.current-module-name
+     [type-module type-name] (case type
+                               (#.Named type-ident _)
+                               (wrap type-ident)
+
+                               _
+                               (//.throw cannot-declare-tags-for-unnamed-type [tags type]))
+     _ (ensure-undeclared-tags self-name tags)
+     _ (//.assert cannot-declare-tags-for-foreign-type [tags type]
+                  (text/= self-name type-module))]
+    (function (_ compiler)
+      (case (|> compiler (get@ #.modules) (plist.get self-name))
+        (#.Some module)
+        (let [namespaced-tags (list/map (|>> [self-name]) tags)]
+          (#e.Success [(update@ #.modules
+                                (plist.update self-name
+                                              (|>> (update@ #.tags (function (_ tag-bindings)
+                                                                     (list/fold (function (_ [idx tag] table)
+                                                                                  (plist.put tag [idx namespaced-tags exported? type] table))
+                                                                                tag-bindings
+                                                                                (list.enumerate tags))))
+                                                   (update@ #.types (plist.put type-name [namespaced-tags exported? type]))))
+                                compiler)
+                       []]))
+        #.None
+        ((//.throw unknown-module self-name) compiler)))))