From 4242e4d3b18eb532ae18e8b38e85ad1ee1988e02 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 15 May 2018 19:52:04 -0400 Subject: - Migrated primitive analysis to stdlib. --- stdlib/source/lux/lang.lux | 108 ++++++++++++++++++++++ stdlib/source/lux/lang/analysis.lux | 109 +++++++++++++++++++++++ stdlib/source/lux/lang/analysis/primitive.lux | 28 ++++++ stdlib/source/lux/lang/analysis/type.lux | 60 +++++++++++++ stdlib/source/lux/lang/init.lux | 56 ++++++++++++ stdlib/test/test/lux/lang/analysis/primitive.lux | 63 +++++++++++++ 6 files changed, 424 insertions(+) create mode 100644 stdlib/source/lux/lang.lux create mode 100644 stdlib/source/lux/lang/analysis.lux create mode 100644 stdlib/source/lux/lang/analysis/primitive.lux create mode 100644 stdlib/source/lux/lang/analysis/type.lux create mode 100644 stdlib/source/lux/lang/init.lux create mode 100644 stdlib/test/test/lux/lang/analysis/primitive.lux (limited to 'stdlib') 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/format) + [macro] + (macro ["s" syntax #+ syntax:]))) + +(def: #export (fail message) + (All [a] (-> Text (Meta a))) + (do macro.Monad + [[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 (~' 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])))) + +(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 [ ] + [(def: + (-> Analysis Analysis) + (|>> #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 [ ] + [(def: #export ( value) + (-> (Meta Analysis)) + (do macro.Monad + [_ (typeA.infer )] + (wrap (#//.Primitive ( 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 + [_ (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 + [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 + [[_ 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] + [".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 [ ] + [(do @ + [sample ] + (test (format "Can analyse " ".") + (|> (infer-primitive ( sample)) + (case> (#e.Success (#analysis.Primitive ( 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] + )))))) -- cgit v1.2.3