diff options
| -rw-r--r-- | new-luxc/source/luxc/lang.lux | 145 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/common.lux | 9 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/primitive.lux | 30 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/primitive.lux | 61 | ||||
| -rw-r--r-- | stdlib/source/lux/lang.lux | 108 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis.lux | 109 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/primitive.lux | 28 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/type.lux | 60 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/init.lux | 56 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/analysis/primitive.lux | 63 |
10 files changed, 424 insertions, 245 deletions
diff --git a/new-luxc/source/luxc/lang.lux b/new-luxc/source/luxc/lang.lux index bba58f421..1060eeb8e 100644 --- a/new-luxc/source/luxc/lang.lux +++ b/new-luxc/source/luxc/lang.lux @@ -16,72 +16,6 @@ (type: #export Eval (-> Type Code (Meta Top))) -(type: #export Analyser - (-> Code (Meta la.Analysis))) - -(def: #export version Text "0.6.0") - -(def: #export (fail message) - (All [a] (-> Text (Meta a))) - (do macro.Monad<Meta> - [[file line col] macro.cursor - #let [location (format file - "," (|> line nat-to-int %i) - "," (|> col nat-to-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-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-type-env action) - (All [a] (-> (tc.Check a) (Meta a))) - (function (_ compiler) - (case (action (get@ #.type-context compiler)) - (#e.Error error) - ((fail error) compiler) - - (#e.Success [context' output]) - (#e.Success [(set@ #.type-context context' compiler) - output])))) - -(def: #export (with-fresh-type-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-type-env - (tc.check expectedT actualT)))) - (def: #export (pl-get key table) (All [a] (-> Text (List [Text a]) (Maybe a))) (case table @@ -126,85 +60,6 @@ (#.Cons [k' (f v')] table') (#.Cons [k' v'] (pl-update key f table'))))) -(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)))))) - (def: (normalize-char char) (-> Nat Text) (case char diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux index c4ff4bfde..072616cfa 100644 --- a/new-luxc/source/luxc/lang/analysis/common.lux +++ b/new-luxc/source/luxc/lang/analysis/common.lux @@ -10,15 +10,6 @@ (luxc ["&" lang] (lang analysis))) -(def: #export (with-unknown-type action) - (All [a] (-> (Meta a) (Meta [Type a]))) - (do macro.Monad<Meta> - [[_ varT] (&.with-type-env tc.var) - analysis (&.with-type varT - action) - knownT (&.with-type-env (tc.clean varT))] - (wrap [knownT analysis]))) - (exception: #export (Variant-Tag-Out-Of-Bounds {message Text}) message) diff --git a/new-luxc/source/luxc/lang/analysis/primitive.lux b/new-luxc/source/luxc/lang/analysis/primitive.lux deleted file mode 100644 index ff7908669..000000000 --- a/new-luxc/source/luxc/lang/analysis/primitive.lux +++ /dev/null @@ -1,30 +0,0 @@ -(.module: - lux - (lux (control monad) - [macro] - (macro [code]) - (lang (type ["tc" check]))) - (luxc ["&" lang] - (lang ["la" analysis #+ Analysis]))) - -## [Analysers] -(do-template [<name> <type> <tag>] - [(def: #export (<name> value) - (-> <type> (Meta Analysis)) - (do macro.Monad<Meta> - [_ (&.infer <type>)] - (wrap (<tag> value))))] - - [analyse-bool Bool code.bool] - [analyse-nat Nat code.nat] - [analyse-int Int code.int] - [analyse-deg Deg code.deg] - [analyse-frac Frac code.frac] - [analyse-text Text code.text] - ) - -(def: #export analyse-unit - (Meta Analysis) - (do macro.Monad<Meta> - [_ (&.infer Top)] - (wrap (` [])))) diff --git a/new-luxc/test/test/luxc/lang/analysis/primitive.lux b/new-luxc/test/test/luxc/lang/analysis/primitive.lux deleted file mode 100644 index aa3e30aab..000000000 --- a/new-luxc/test/test/luxc/lang/analysis/primitive.lux +++ /dev/null @@ -1,61 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data (text format) - ["e" error]) - ["r" math/random] - [macro] - (macro [code]) - (lang [type "type/" Eq<Type>]) - test) - (luxc ["&" lang] - (lang ["&." module] - ["~" analysis] - (analysis [".A" expression] - ["@" primitive] - ["@." common]))) - (// common) - (test/luxc common)) - -(context: "Primitives" - (<| (times +100) - (do @ - [%bool% r.bool - %nat% r.nat - %int% r.int - %deg% r.deg - %frac% r.frac - %text% (r.text +5)] - (`` ($_ seq - (test "Can analyse unit." - (|> (@common.with-unknown-type - @.analyse-unit) - (macro.run (io.run init-jvm)) - (case> (^ (#e.Success [_type (^code [])])) - (type/= Top _type) - - _ - false)) - ) - (~~ (do-template [<desc> <type> <tag> <value> <analyser>] - [(test (format "Can analyse " <desc> ".") - (|> (@common.with-unknown-type - (<analyser> <value>)) - (macro.run (io.run init-jvm)) - (case> (#e.Success [_type [_ (<tag> value)]]) - (and (type/= <type> _type) - (is? <value> value)) - - _ - false)) - )] - - ["bool" Bool #.Bool %bool% @.analyse-bool] - ["nat" Nat #.Nat %nat% @.analyse-nat] - ["int" Int #.Int %int% @.analyse-int] - ["deg" Deg #.Deg %deg% @.analyse-deg] - ["frac" Frac #.Frac %frac% @.analyse-frac] - ["text" Text #.Text %text% @.analyse-text] - ))))))) 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] + )))))) |