- Migrated primitive analysis to stdlib.

6 files changed, 424 insertions, 0 deletions

diff --git a/stdlib/source/lux/lang.lux b/stdlib/source/lux/lang.lux
new file mode 100644
index 000000000..c4a4e2db3
--- /dev/null
+++ b/stdlib/source/lux/lang.lux
@@ -0,0 +1,108 @@
+(.module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       (data [product]
+             ["e" error]
+             [text "text/" Eq<Text>]
+             text/format)
+       [macro]
+       (macro ["s" syntax #+ syntax:])))
+
+(def: #export (fail message)
+  (All [a] (-> Text (Meta a)))
+  (do macro.Monad<Meta>
+    [[file line col] macro.cursor
+     #let [location (format file
+                            "," (|> line .int %i)
+                            "," (|> col .int %i))]]
+    (macro.fail (format message "\n\n"
+                        "@ " location))))
+
+(def: #export (throw exception message)
+  (All [e a] (-> (ex.Exception e) e (Meta a)))
+  (fail (ex.construct exception message)))
+
+(syntax: #export (assert exception message test)
+  (wrap (list (` (if (~ test)
+                   (:: macro.Monad<Meta> (~' wrap) [])
+                   (..throw (~ exception) (~ message)))))))
+
+(def: #export (with-source-code source action)
+  (All [a] (-> Source (Meta a) (Meta a)))
+  (function (_ compiler)
+    (let [old-source (get@ #.source compiler)]
+      (case (action (set@ #.source source compiler))
+        (#e.Error error)
+        (#e.Error error)
+
+        (#e.Success [compiler' output])
+        (#e.Success [(set@ #.source old-source compiler')
+                     output])))))
+
+(def: #export (with-stacked-errors handler action)
+  (All [a] (-> (-> [] Text) (Meta a) (Meta a)))
+  (function (_ compiler)
+    (case (action compiler)
+      (#e.Success [compiler' output])
+      (#e.Success [compiler' output])
+
+      (#e.Error error)
+      (#e.Error (if (text/= "" error)
+                  (handler [])
+                  (format (handler []) "\n\n-----------------------------------------\n\n" error))))))
+
+(def: fresh-bindings
+  (All [k v] (Bindings k v))
+  {#.counter +0
+   #.mappings (list)})
+
+(def: fresh-scope
+  Scope
+  {#.name     (list)
+   #.inner    +0
+   #.locals   fresh-bindings
+   #.captured fresh-bindings})
+
+(def: #export (with-scope action)
+  (All [a] (-> (Meta a) (Meta [Scope a])))
+  (function (_ compiler)
+    (case (action (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler))
+      (#e.Success [compiler' output])
+      (case (get@ #.scopes compiler')
+        #.Nil
+        (#e.Error "Impossible error: Drained scopes!")
+
+        (#.Cons head tail)
+        (#e.Success [(set@ #.scopes tail compiler')
+                     [head output]]))
+
+      (#e.Error error)
+      (#e.Error error))))
+
+(def: #export (with-current-module name action)
+  (All [a] (-> Text (Meta a) (Meta a)))
+  (function (_ compiler)
+    (case (action (set@ #.current-module (#.Some name) compiler))
+      (#e.Success [compiler' output])
+      (#e.Success [(set@ #.current-module
+                         (get@ #.current-module compiler)
+                         compiler')
+                   output])
+
+      (#e.Error error)
+      (#e.Error error))))
+
+(def: #export (with-cursor cursor action)
+  (All [a] (-> Cursor (Meta a) (Meta a)))
+  (if (text/= "" (product.left cursor))
+    action
+    (function (_ compiler)
+      (let [old-cursor (get@ #.cursor compiler)]
+        (case (action (set@ #.cursor cursor compiler))
+          (#e.Success [compiler' output])
+          (#e.Success [(set@ #.cursor old-cursor compiler')
+                       output])
+
+          (#e.Error error)
+          (#e.Error error))))))
diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux
new file mode 100644
index 000000000..46927bae1
--- /dev/null
+++ b/stdlib/source/lux/lang/analysis.lux
@@ -0,0 +1,109 @@
+(.module:
+  lux
+  (lux [function]
+       (data (coll [list "list/" Fold<List>]))))
+
+(type: #export #rec Primitive
+  #Unit
+  (#Bool Bool)
+  (#Nat Nat)
+  (#Int Int)
+  (#Deg Deg)
+  (#Frac Frac)
+  (#Text Text))
+
+(type: #export Tag Nat)
+
+(type: #export (Composite a)
+  (#Sum (Either a a))
+  (#Product [a a]))
+
+(type: #export Register Nat)
+
+(type: #export #rec Pattern
+  (#Simple Primitive)
+  (#Complex (Composite Pattern))
+  (#Bind Register))
+
+(type: #export Variable
+  (#Local Register)
+  (#Foreign Register))
+
+(type: #export (Match p e)
+  [[p e] (List [p e])])
+
+(type: #export Environment
+  (List Variable))
+
+(type: #export (Special e)
+  [Text (List e)])
+
+(type: #export #rec Analysis
+  (#Primitive Primitive)
+  (#Structure (Composite Analysis))
+  (#Case Analysis (Match Pattern Analysis))
+  (#Function Environment Analysis)
+  (#Apply Analysis Analysis)
+  (#Variable Variable)
+  (#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.
+
+(do-template [<name> <tag>]
+  [(def: <name>
+     (-> Analysis Analysis)
+     (|>> <tag> #Sum #Structure))]
+
+  [left #.Left]
+  [right #.Right]
+  )
+
+(def: (last? size tag)
+  (-> Nat Tag Bool)
+  (n/= (dec size) tag))
+
+(def: #export (no-op value)
+  (-> Analysis Analysis)
+  (let [identity (#Function (list) (#Variable (#Local +1)))]
+    (#Apply value identity)))
+
+(def: #export (sum tag size temp value)
+  (-> Tag Nat Register Analysis Analysis)
+  (if (last? size tag)
+    (if (n/= +1 tag)
+      (..right value)
+      (list/fold (function.const ..left)
+                 (..right value)
+                 (list.n/range +0 (n/- +2 tag))))
+    (list/fold (function.const ..left)
+               (case value
+                 (#Structure (#Sum _))
+                 (no-op value)
+
+                 _
+                 value)
+               (list.n/range +0 tag))))
+
+(def: #export (tuple members)
+  (-> (List Analysis) Analysis)
+  (case (list.reverse members)
+    #.Nil
+    (#Primitive #Unit)
+
+    (#.Cons singleton #.Nil)
+    singleton
+
+    (#.Cons last prevs)
+    (list/fold (function (_ left right) (#Structure (#Product left right)))
+               last prevs)))
+
+(def: #export (apply args func)
+  (-> (List Analysis) Analysis Analysis)
+  (list/fold (function (_ arg func) (#Apply arg func)) func args))
+
+(type: #export Analyser
+  (-> Code (Meta Analysis)))
diff --git a/stdlib/source/lux/lang/analysis/primitive.lux b/stdlib/source/lux/lang/analysis/primitive.lux
new file mode 100644
index 000000000..f154932e6
--- /dev/null
+++ b/stdlib/source/lux/lang/analysis/primitive.lux
@@ -0,0 +1,28 @@
+(.module:
+  [lux #- nat int deg]
+  (lux (control monad)
+       [macro])
+  [// #+ Analysis]
+  (// [".A" type]))
+
+## [Analysers]
+(do-template [<name> <type> <tag>]
+  [(def: #export (<name> value)
+     (-> <type> (Meta Analysis))
+     (do macro.Monad<Meta>
+       [_ (typeA.infer <type>)]
+       (wrap (#//.Primitive (<tag> value)))))]
+
+  [bool Bool #//.Bool]
+  [nat  Nat  #//.Nat]
+  [int  Int  #//.Int]
+  [deg  Deg  #//.Deg]
+  [frac Frac #//.Frac]
+  [text Text #//.Text]
+  )
+
+(def: #export unit
+  (Meta Analysis)
+  (do macro.Monad<Meta>
+    [_ (typeA.infer Top)]
+    (wrap (#//.Primitive #//.Unit))))
diff --git a/stdlib/source/lux/lang/analysis/type.lux b/stdlib/source/lux/lang/analysis/type.lux
new file mode 100644
index 000000000..6d06d5cff
--- /dev/null
+++ b/stdlib/source/lux/lang/analysis/type.lux
@@ -0,0 +1,60 @@
+(.module:
+  lux
+  (lux (control [monad #+ do])
+       (data ["e" error])
+       [macro]
+       [lang]
+       (lang (type ["tc" check]))))
+
+(def: #export (with-type expected action)
+  (All [a] (-> Type (Meta a) (Meta a)))
+  (function (_ compiler)
+    (case (action (set@ #.expected (#.Some expected) compiler))
+      (#e.Success [compiler' output])
+      (let [old-expected (get@ #.expected compiler)]
+        (#e.Success [(set@ #.expected old-expected compiler')
+                     output]))
+
+      (#e.Error error)
+      (#e.Error error))))
+
+(def: #export (with-env action)
+  (All [a] (-> (tc.Check a) (Meta a)))
+  (function (_ compiler)
+    (case (action (get@ #.type-context compiler))
+      (#e.Error error)
+      ((lang.fail error) compiler)
+
+      (#e.Success [context' output])
+      (#e.Success [(set@ #.type-context context' compiler)
+                   output]))))
+
+(def: #export (with-fresh-env action)
+  (All [a] (-> (Meta a) (Meta a)))
+  (function (_ compiler)
+    (let [old (get@ #.type-context compiler)]
+      (case (action (set@ #.type-context tc.fresh-context compiler))
+        (#e.Success [compiler' output])
+        (#e.Success [(set@ #.type-context old compiler')
+                     output])
+
+        output
+        output))))
+
+(def: #export (infer actualT)
+  (-> Type (Meta Top))
+  (do macro.Monad<Meta>
+    [expectedT macro.expected-type]
+    (with-env
+      (tc.check expectedT actualT))))
+
+(def: #export (with-inference action)
+  (All [a] (-> (Meta a) (Meta [Type a])))
+  (do macro.Monad<Meta>
+    [[_ varT] (..with-env
+                tc.var)
+     output (with-type varT
+              action)
+     knownT (..with-env
+              (tc.clean varT))]
+    (wrap [knownT output])))
diff --git a/stdlib/source/lux/lang/init.lux b/stdlib/source/lux/lang/init.lux
new file mode 100644
index 000000000..a1ef4ffb8
--- /dev/null
+++ b/stdlib/source/lux/lang/init.lux
@@ -0,0 +1,56 @@
+(.module:
+  lux
+  ## (// [".L" extension]
+  ##     (extension [".E" analysis]
+  ##                [".E" synthesis]
+  ##                [".E" translation]
+  ##                [".E" statement]))
+  )
+
+(def: #export (cursor file)
+  (-> Text Cursor)
+  [file +1 +0])
+
+(def: #export (source file code)
+  (-> Text Text Source)
+  [(cursor file) +0 code])
+
+(def: dummy-source
+  Source
+  [.dummy-cursor +0 ""])
+
+(def: #export type-context
+  Type-Context
+  {#.ex-counter +0
+   #.var-counter +0
+   #.var-bindings (list)})
+
+(def: #export version Text "0.6.0")
+
+(def: #export info
+  Info
+  {#.target  (for {"JVM" "JVM"
+                   "JS" "JS"})
+   #.version ..version
+   #.mode    #.Build})
+
+(def: #export (compiler host)
+  (-> Top Lux)
+  {#.info            ..info
+   #.source          dummy-source
+   #.cursor          .dummy-cursor
+   #.current-module  #.None
+   #.modules         (list)
+   #.scopes          (list)
+   #.type-context    ..type-context
+   #.expected        #.None
+   #.seed            +0
+   #.scope-type-vars (list)
+   #.extensions      (:! Bottom
+                         []
+                         ## {#extensionL.analysis analysisE.defaults
+                         ##  #extensionL.synthesis synthesisE.defaults
+                         ##  #extensionL.translation translationE.defaults
+                         ##  #extensionL.statement statementE.defaults}
+                         )
+   #.host            (:! Bottom host)})
diff --git a/stdlib/test/test/lux/lang/analysis/primitive.lux b/stdlib/test/test/lux/lang/analysis/primitive.lux
new file mode 100644
index 000000000..2e7c2057a
--- /dev/null
+++ b/stdlib/test/test/lux/lang/analysis/primitive.lux
@@ -0,0 +1,63 @@
+(.module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe
+                ["ex" exception #+ exception:])
+       (data (text format)
+             ["e" error])
+       ["r" math/random]
+       [macro]
+       (macro [code])
+       (lang [".L" type "type/" Eq<Type>]
+             [".L" init]
+             [analysis #+ Analysis]
+             (analysis [".A" type]
+                       ["/" primitive]))
+       test))
+
+(exception: (wrong-inference {expected Type} {inferred Type})
+  (format "Expected: " (%type expected) "\n"
+          "Inferred: " (%type inferred) "\n"))
+
+(def: (infer-primitive expected-type analysis)
+  (-> Type (Meta Analysis) (e.Error Analysis))
+  (|> (typeA.with-inference
+        analysis)
+      (macro.run (initL.compiler []))
+      (case> (#e.Success [inferred-type output])
+             (if (is? expected-type inferred-type)
+               (#e.Success output)
+               (ex.throw wrong-inference [expected-type inferred-type]))
+
+             (#e.Error error)
+             (#e.Error error))))
+
+(context: "Primitives"
+  (<| (times +100)
+      (`` ($_ seq
+              (test "Can analyse unit."
+                    (|> (infer-primitive Top /.unit)
+                        (case> (^ (#e.Success (#analysis.Primitive (#analysis.Unit output))))
+                               (is? [] output)
+
+                               _
+                               false)))
+              (~~ (do-template [<desc> <type> <tag> <random> <analyser>]
+                    [(do @
+                       [sample <random>]
+                       (test (format "Can analyse " <desc> ".")
+                             (|> (infer-primitive <type> (<analyser> sample))
+                                 (case> (#e.Success (#analysis.Primitive (<tag> output)))
+                                        (is? sample output)
+
+                                        _
+                                        false))))]
+
+                    ["bool" Bool #analysis.Bool r.bool /.bool]
+                    ["nat"  Nat  #analysis.Nat  r.nat  /.nat]
+                    ["int"  Int  #analysis.Int  r.int  /.int]
+                    ["deg"  Deg  #analysis.Deg  r.deg  /.deg]
+                    ["frac" Frac #analysis.Frac r.frac /.frac]
+                    ["text" Text #analysis.Text (r.unicode +5) /.text]
+                    ))))))