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 +++++++++++++ 5 files changed, 361 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 (limited to 'stdlib/source') 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)}) -- cgit v1.2.3