From dd5220e13b03c8f85972feac535a34ef64525222 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 9 May 2017 17:48:27 -0400 Subject: - Added tests for some kinds of analysis. - WIP: Porting more code. --- new-luxc/source/luxc/analyser.lux | 4 +- new-luxc/source/luxc/analyser/common.lux | 7 +-- new-luxc/source/luxc/analyser/lux.lux | 52 ++++++++-------- new-luxc/source/luxc/analyser/pattern.lux | 3 + new-luxc/source/luxc/base.lux | 27 +++++++-- new-luxc/source/luxc/compiler.lux | 87 ++++++++++++++++++++++++--- new-luxc/source/luxc/compiler/common.jvm.lux | 65 ++++++++++++++++++++ new-luxc/source/luxc/compiler/expr.jvm.lux | 57 +++++++++++++----- new-luxc/source/luxc/compiler/runtime.jvm.lux | 6 +- new-luxc/source/luxc/env.lux | 81 +++++++++++++------------ new-luxc/source/luxc/lang.lux | 44 -------------- new-luxc/source/luxc/lang/analysis.lux | 30 +++++++++ new-luxc/source/luxc/lang/pattern.lux | 15 +++++ new-luxc/source/luxc/lang/synthesis.lux | 21 +++++++ new-luxc/source/luxc/module.lux | 42 ++++++++++--- new-luxc/source/luxc/synthesizer.lux | 39 +++++++++++- 16 files changed, 422 insertions(+), 158 deletions(-) create mode 100644 new-luxc/source/luxc/analyser/pattern.lux create mode 100644 new-luxc/source/luxc/compiler/common.jvm.lux delete mode 100644 new-luxc/source/luxc/lang.lux create mode 100644 new-luxc/source/luxc/lang/analysis.lux create mode 100644 new-luxc/source/luxc/lang/pattern.lux create mode 100644 new-luxc/source/luxc/lang/synthesis.lux (limited to 'new-luxc/source/luxc') diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index 7de7bab57..05a755b08 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -15,13 +15,13 @@ [type] (type ["TC" check])) (luxc ["&" base] - [lang #*] + (lang ["la" analysis]) ["&;" module] ["&;" env]) (. ["&&;" lux])) (def: #export (analyse eval ast) - Analyser + &;Analyser (case ast (^template [ ] [cursor ( value)] diff --git a/new-luxc/source/luxc/analyser/common.lux b/new-luxc/source/luxc/analyser/common.lux index e77819779..ed2b6eba7 100644 --- a/new-luxc/source/luxc/analyser/common.lux +++ b/new-luxc/source/luxc/analyser/common.lux @@ -8,12 +8,7 @@ [type] (type ["TC" check])) (luxc ["&" base] - lang)) - -(def: #export get-type - (-> Analysis Type) - (|>. product;left - product;left)) + (lang analysis))) (def: #export (replace-type replacement analysis) (-> Type Analysis Analysis) diff --git a/new-luxc/source/luxc/analyser/lux.lux b/new-luxc/source/luxc/analyser/lux.lux index f0e9a3538..e215412c6 100644 --- a/new-luxc/source/luxc/analyser/lux.lux +++ b/new-luxc/source/luxc/analyser/lux.lux @@ -15,7 +15,7 @@ [type] (type ["TC" check])) (luxc ["&" base] - [lang #*] + (lang ["la" analysis #+ Analysis]) ["&;" module] ["&;" env] (analyser ["&;" common]))) @@ -28,15 +28,15 @@ _ (&;within-type-env (TC;check expected ))] (wrap [[expected cursor] - (#lang;Primitive ( value))])))] - - [analyse-bool Bool #lang;Bool] - [analyse-nat Nat #lang;Nat] - [analyse-int Int #lang;Int] - [analyse-deg Deg #lang;Deg] - [analyse-real Real #lang;Real] - [analyse-char Char #lang;Char] - [analyse-text Text #lang;Text] + ( value)])))] + + [analyse-bool Bool #la;Bool] + [analyse-nat Nat #la;Nat] + [analyse-int Int #la;Int] + [analyse-deg Deg #la;Deg] + [analyse-real Real #la;Real] + [analyse-char Char #la;Char] + [analyse-text Text #la;Text] ) (def: #export (analyse-unit cursor) @@ -46,9 +46,9 @@ _ (&;within-type-env (TC;check expected Unit))] (wrap [[expected cursor] - (#lang;Primitive #lang;Unit)]))) + #la;Unit]))) -(def: #export (analyse-definition cursor def-name) +(def: (analyse-definition cursor def-name) (-> Cursor Ident (Lux Analysis)) (do Monad [actual (macro;find-def-type def-name) @@ -56,9 +56,9 @@ _ (&;within-type-env (TC;check expected actual))] (wrap [[expected cursor] - (#lang;Reference (#lang;Absolute def-name))]))) + (#la;Absolute def-name)]))) -(def: #export (analyse-variable cursor var-name) +(def: (analyse-variable cursor var-name) (-> Cursor Text (Lux (Maybe Analysis))) (do Monad [?var (&env;find var-name)] @@ -69,7 +69,7 @@ _ (&;within-type-env (TC;check expected actual)) #let [analysis [[expected cursor] - (#lang;Reference (#lang;Relative ref))]]] + (#la;Relative ref)]]] (wrap (#;Some analysis))) #;None @@ -94,7 +94,7 @@ (analyse-definition cursor reference))) (def: #export (analyse-check analyse eval cursor type value) - (-> Analyser Eval Cursor Code Code (Lux Analysis)) + (-> &;Analyser &;Eval Cursor Code Code (Lux Analysis)) (do Monad [actual (eval Type type) #let [actual (:! Type actual)] @@ -105,7 +105,7 @@ (analyse eval value)))) (def: #export (analyse-coerce analyse eval cursor type value) - (-> Analyser Eval Cursor Code Code (Lux Analysis)) + (-> &;Analyser &;Eval Cursor Code Code (Lux Analysis)) (do Monad [actual (eval Type type) #let [actual (:! Type actual)] @@ -134,7 +134,7 @@ (analyse member))) (list;zip2 member-types members)))] (wrap [[expected cursor] - (#lang;Structure (#lang;Tuple =tuple))])) + (#la;Tuple =tuple)])) (n.< num-types num-members) (do @ @@ -149,7 +149,7 @@ (analyse (default (undefined) (list;last members))))] (wrap [[expected cursor] - (#lang;Structure (#lang;Tuple (L/append =prevs (list =last))))])) + (#la;Tuple (L/append =prevs (list =last)))])) ## (n.> num-types num-members) (do @ @@ -164,14 +164,14 @@ (list;last member-types)) (analyse-typed-tuple analyse cursor tail-xs))] (wrap [[expected cursor] - (#lang;Structure (#lang;Tuple (L/append =prevs (list =last))))])) + (#la;Tuple (L/append =prevs (list =last)))])) )))) (def: (tuple cursor members) (-> Cursor (List Analysis) Analysis) - (let [tuple-type (type;tuple (L/map &common;get-type members))] + (let [tuple-type (type;tuple (L/map la;get-type members))] [[tuple-type cursor] - (#lang;Structure (#lang;Tuple members))])) + (#la;Tuple members)])) (def: #export (analyse-tuple analyse cursor members) (-> (-> Code (Lux Analysis)) Cursor @@ -200,7 +200,7 @@ members) #let [=tuple (tuple cursor =members)] _ (&;within-type-env - (TC;check expected (&common;get-type =tuple)))] + (TC;check expected (la;get-type =tuple)))] (wrap (&common;replace-type expected =tuple))))) _ @@ -212,7 +212,7 @@ (analyse-tuple analyse cursor members)) =tuple (foldM @ &common;clean =tuple bindings) _ (&;within-type-env - (TC;check expected (&common;get-type =tuple)))] + (TC;check expected (la;get-type =tuple)))] (wrap (&common;replace-type expected =tuple))) (&;fail (format "Invalid type for tuple: " (%type expected)))) ))) @@ -235,7 +235,7 @@ =value (&;with-expected-type variant-type (analyse value))] (wrap [[expected cursor] - (#lang;Structure (#lang;Variant tag last? =value))])) + (#la;Variant tag last? =value)])) (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n" " Tag: " (%n tag) "\n" "Type size: " (%n type-size) "\n" @@ -250,6 +250,6 @@ (analyse-variant analyse cursor tag value)) =variant (foldM @ &common;clean =variant bindings) _ (&;within-type-env - (TC;check expected (&common;get-type =variant)))] + (TC;check expected (la;get-type =variant)))] (wrap (&common;replace-type expected =variant))) (&;fail (format "Invalid type for variant: " (%type expected))))))) diff --git a/new-luxc/source/luxc/analyser/pattern.lux b/new-luxc/source/luxc/analyser/pattern.lux new file mode 100644 index 000000000..f4a14d855 --- /dev/null +++ b/new-luxc/source/luxc/analyser/pattern.lux @@ -0,0 +1,3 @@ +(;module: + lux) + diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux index bc05afea4..3a085e07e 100644 --- a/new-luxc/source/luxc/base.lux +++ b/new-luxc/source/luxc/base.lux @@ -5,7 +5,14 @@ text/format ["E" error]) [macro #+ Monad] - (type ["TC" check]))) + (type ["TC" check])) + (luxc (lang ["la" analysis]))) + +(type: #export Eval + (-> Type Code (Lux Top))) + +(type: #export Analyser + (-> Eval Code (Lux la;Analysis))) (type: #export Path Text) @@ -47,7 +54,17 @@ (#E;Success [(set@ #;type-context context' compiler) output])))) -(def: #export (pl::put key val table) +(def: #export (pl-contains? key mappings) + (All [a] (-> Text (List [Text a]) Bool)) + (case mappings + #;Nil + false + + (#;Cons [k v] mappings') + (or (T/= key k) + (pl-contains? key mappings')))) + +(def: #export (pl-put key val table) (All [a] (-> Text a (List [Text a]) (List [Text a]))) (case table #;Nil @@ -58,9 +75,9 @@ (#;Cons [key val] table') (#;Cons [k' v'] - (pl::put key val table'))))) + (pl-put key val table'))))) -(def: #export (pl::get key table) +(def: #export (pl-get key table) (All [a] (-> Text (List [Text a]) (Maybe a))) (case table #;Nil @@ -69,7 +86,7 @@ (#;Cons [k' v'] table') (if (T/= key k') (#;Some v') - (pl::get key table')))) + (pl-get key table')))) (def: #export (with-source-code source action) (All [a] (-> [Cursor Text] (Lux a) (Lux a))) diff --git a/new-luxc/source/luxc/compiler.lux b/new-luxc/source/luxc/compiler.lux index 8d0ea8a2f..2af00b049 100644 --- a/new-luxc/source/luxc/compiler.lux +++ b/new-luxc/source/luxc/compiler.lux @@ -1,17 +1,23 @@ (;module: lux (lux (control monad) - (concurrency ["P" promise]) + (concurrency ["A" atom] + ["P" promise]) (data ["E" error] [text "T/" Hash] - text/format) - [macro #+ Monad]) + text/format + (coll ["D" dict] + [array #+ Array])) + [macro #+ Monad] + host + [io]) (luxc ["&" base] ["&;" io] ["&;" module] ["&;" parser] (compiler ["&&;" runtime] - ["&&;" statement]) + ["&&;" statement] + ["&&;" common]) )) (def: (compile ast) @@ -101,9 +107,70 @@ (#E;Error error) (wrap (#E;Error error))))) -(type: Host Unit) - -(def: init-host Host []) +(jvm-import org.objectweb.asm.MethodVisitor) + +(jvm-import java.lang.reflect.AccessibleObject + (setAccessible [boolean] void)) + +(jvm-import java.lang.reflect.Method + (invoke [Object (Array Object)] #try Object)) + +(jvm-import (java.lang.Class a) + (getDeclaredMethod [String (Array (Class Object))] #try Method)) + +(jvm-import java.lang.Object + (getClass [] (Class Object))) + +(jvm-import java.lang.Integer + (#static TYPE (Class Integer))) + +(jvm-import java.lang.ClassLoader) + +(def: ClassLoader::defineClass + Method + (case (Class.getDeclaredMethod ["defineClass" + (|> (array (Class Object) +4) + (array-store +0 (:! (Class Object) (class-for String))) + (array-store +1 (Object.getClass [] (array byte +0))) + (array-store +2 (:! (Class Object) Integer.TYPE)) + (array-store +3 (:! (Class Object) Integer.TYPE)))] + (class-for java.lang.ClassLoader)) + (#E;Success method) + (do-to method + (AccessibleObject.setAccessible [true])) + + (#E;Error error) + (error! error))) + +(def: (memory-class-loader store) + (-> &&common;Class-Store ClassLoader) + (object ClassLoader [] + [] + (ClassLoader (findClass [class-name String]) void + (case (|> store A;get io;run (D;get class-name)) + (#;Some bytecode) + (case (Method.invoke [(:! Object _jvm_this) + (array;from-list (list (:! Object class-name) + (:! Object bytecode) + (:! Object (l2i 0)) + (:! Object (l2i (nat-to-int (array-length bytecode))))))] + ClassLoader::defineClass) + (#E;Success output) + [] + + (#E;Error error) + (error! error)) + + _ + (error! (format "Unknown class: " class-name)))))) + +(def: (init-host _) + (-> Top &&common;Host) + (let [store (: &&common;Class-Store + (A;atom (D;new text;Hash)))] + {#&&common;visitor #;None + #&&common;loader (memory-class-loader store) + #&&common;store store})) (def: init-cursor Cursor ["" +0 +0]) @@ -121,7 +188,7 @@ #;compiler-mode #;Build}) (def: (init-compiler host) - (-> Host Compiler) + (-> &&common;Host Compiler) {#;info init-compiler-info #;source [init-cursor ""] #;cursor init-cursor @@ -147,8 +214,8 @@ (def: #export (compile-program program target sources) (-> &;Path &;Path (List &;Path) (P;Promise Unit)) (do P;Monad - [#let [compiler (init-compiler init-host)] - _ (or-crash! (&&runtime;compile-runtime [])) + [#let [compiler (init-compiler (init-host []))] + compiler (or-crash! (&&runtime;compile-runtime compiler)) compiler (or-crash! (compile-module sources prelude compiler)) compiler (or-crash! (compile-module sources program compiler)) #let [_ (log! "Compilation complete!")]] diff --git a/new-luxc/source/luxc/compiler/common.jvm.lux b/new-luxc/source/luxc/compiler/common.jvm.lux new file mode 100644 index 000000000..d7abc1ff1 --- /dev/null +++ b/new-luxc/source/luxc/compiler/common.jvm.lux @@ -0,0 +1,65 @@ +(;module: + lux + (lux (concurrency ["A" atom]) + (data ["E" error] + (coll ["D" dict])) + [macro] + [host #+ jvm-import])) + +## [Host] +(jvm-import org.objectweb.asm.MethodVisitor + (visitLdcInsn [Object] void)) + +(jvm-import java.lang.ClassLoader) + +## [Types] +(type: #export Compiled + Unit) + +(type: #export Blob host;Byte-Array) + +(type: #export Class-Store (A;Atom (D;Dict Text Blob))) + +(type: #export Host + {#visitor (Maybe MethodVisitor) + #loader ClassLoader + #store Class-Store}) + +(def: #export unit-value Text "\u0000unit\u0000") + +(def: (visitor::get compiler) + (-> Compiler (Maybe MethodVisitor)) + (|> (get@ #;host compiler) + (:! Host) + (get@ #visitor))) + +(def: (visitor::put visitor compiler) + (-> MethodVisitor Compiler Compiler) + (update@ #;host + (function [host] + (|> host + (:! Host) + (set@ #visitor (#;Some visitor)) + (:! Void))) + compiler)) + +(def: #export get-visitor + (Lux MethodVisitor) + (function [compiler] + (case (visitor::get compiler) + #;None + (#E;Error "No visitor has been set.") + + (#;Some visitor) + (#E;Success [compiler visitor])))) + +(def: #export (with-visitor visitor body) + (All [a] (-> MethodVisitor (Lux a) (Lux a))) + (function [compiler] + (case (macro;run' (visitor::put visitor compiler) body) + (#E;Error error) + (#E;Error error) + + (#E;Success [compiler' output]) + (#E;Success [(visitor::put (visitor::get compiler) compiler') + output])))) diff --git a/new-luxc/source/luxc/compiler/expr.jvm.lux b/new-luxc/source/luxc/compiler/expr.jvm.lux index f0508c0d2..33a41541b 100644 --- a/new-luxc/source/luxc/compiler/expr.jvm.lux +++ b/new-luxc/source/luxc/compiler/expr.jvm.lux @@ -2,29 +2,56 @@ lux (lux (control monad) (data text/format) - [macro #+ Monad "Lux/" Monad]) + [macro #+ Monad "Lux/" Monad] + [host #+ jvm-import]) (luxc ["&" base] - lang + (lang ["ls" synthesis]) ["&;" analyser] - ["&;" synthesizer])) + ["&;" synthesizer] + (compiler ["&;" common]))) -(type: #export JVM-Bytecode - Void) +(jvm-import #long java.lang.Object) -(type: #export Compiled - JVM-Bytecode) +(jvm-import org.objectweb.asm.Opcodes) + +(jvm-import org.objectweb.asm.MethodVisitor + (visitLdcInsn [Object] void)) + +(def: unit-value Text "\u0000unit\u0000") + +(def: (compiler-literal value) + (-> Top (Lux &common;Compiled)) + (do Monad + [visitor &common;get-visitor + #let [_ (MethodVisitor.visitLdcInsn [(:! java.lang.Object value)])]] + (wrap []))) (def: (compile-synthesis synthesis) - (-> Synthesis Compiled) - (undefined)) + (-> ls;Synthesis (Lux &common;Compiled)) + (case synthesis + #ls;Unit + (compiler-literal &common;unit-value) + + (^template [] + ( value) + (compiler-literal value)) + ([#ls;Bool] + [#ls;Nat] + [#ls;Int] + [#ls;Deg] + [#ls;Real] + [#ls;Char] + [#ls;Text]) + + _ + (macro;fail "Unrecognized synthesis."))) (def: (eval type code) - Eval + &;Eval (undefined)) (def: #export (compile input) - (-> Code (Lux Compiled)) - (|> input - (&analyser;analyse eval) - (Lux/map &synthesizer;synthesize) - (Lux/map compile-synthesis))) + (-> Code (Lux &common;Compiled)) + (do Monad + [analysis (&analyser;analyse eval input)] + (compile-synthesis (&synthesizer;synthesize analysis)))) diff --git a/new-luxc/source/luxc/compiler/runtime.jvm.lux b/new-luxc/source/luxc/compiler/runtime.jvm.lux index b6cebb193..4a5e44785 100644 --- a/new-luxc/source/luxc/compiler/runtime.jvm.lux +++ b/new-luxc/source/luxc/compiler/runtime.jvm.lux @@ -6,6 +6,6 @@ ["E" error])) (luxc ["&" base])) -(def: #export (compile-runtime _) - (-> Top (P;Promise (E;Error Unit))) - (P/wrap (#E;Success []))) +(def: #export (compile-runtime compiler) + (-> Compiler (P;Promise (E;Error Compiler))) + (P/wrap (#E;Success compiler))) diff --git a/new-luxc/source/luxc/env.lux b/new-luxc/source/luxc/env.lux index 338375a29..8c056f1c3 100644 --- a/new-luxc/source/luxc/env.lux +++ b/new-luxc/source/luxc/env.lux @@ -13,51 +13,18 @@ (type: Locals (Bindings Text [Type Nat])) (type: Captured (Bindings Text [Type Ref])) -(def: (pl::contains? key mappings) - (All [a] (-> Text (List [Text a]) Bool)) - (case mappings - #;Nil - false - - (#;Cons [k v] mappings') - (or (T/= key k) - (pl::contains? key mappings')))) - -(def: (pl::get key mappings) - (All [a] (-> Text (List [Text a]) (Maybe a))) - (case mappings - #;Nil - #;None - - (#;Cons [k v] mappings') - (if (T/= key k) - (#;Some v) - (pl::get key mappings')))) - -(def: (pl::put key value mappings) - (All [a] (-> Text a (List [Text a]) (List [Text a]))) - (case mappings - #;Nil - (list [key value]) - - (#;Cons [k v] mappings') - (if (T/= key k) - (#;Cons [key value] mappings') - (#;Cons [k v] - (pl::put key value mappings'))))) - (do-template [ ] [(def: ( name scope) (-> Text Scope Bool) (|> scope (get@ [ #;mappings]) - (pl::contains? name))) + (&;pl-contains? name))) (def: ( name scope) (-> Text Scope (Maybe [Type Ref])) (|> scope (get@ [ #;mappings]) - (pl::get name) + (&;pl-get name) (Maybe/map (function [[type value]] [type ( value)]))))] @@ -98,7 +65,7 @@ (#;Cons (update@ #;captured (: (-> Captured Captured) (|>. (update@ #;counter n.inc) - (update@ #;mappings (pl::put name [ref-type ref])))) + (update@ #;mappings (&;pl-put name [ref-type ref])))) scope) inner)])) [init-ref #;Nil] @@ -118,7 +85,7 @@ new-head (update@ #;locals (: (-> Locals Locals) (|>. (update@ #;counter n.inc) - (update@ #;mappings (pl::put name [type new-var-id])))) + (update@ #;mappings (&;pl-put name [type new-var-id])))) head)] (case (macro;run' (set@ #;scopes (#;Cons new-head tail) compiler) action) @@ -139,3 +106,43 @@ _ (#E;Error "Cannot create local binding without a scope.")) )) + +(do-template [ ] + [(def: + (Bindings Text [Type ]) + {#;counter +0 + #;mappings (list)})] + + [init-locals Nat] + [init-captured Ref] + ) + +(def: (scope parent-name child-name) + (-> (List Text) Text Scope) + {#;name (list& child-name parent-name) + #;inner +0 + #;locals init-locals + #;captured init-captured}) + +(def: #export (with-scope name action) + (All [a] (-> Text (Lux a) (Lux a))) + (function [compiler] + (let [parent-name (case (get@ #;scopes compiler) + #;Nil + (list) + + (#;Cons top _) + (get@ #;name top))] + (case (action (update@ #;scopes + (|>. (#;Cons (scope parent-name name))) + compiler)) + (#E;Error error) + (#E;Error error) + + (#E;Success [compiler' output]) + (#E;Success [(update@ #;scopes + (|>. list;tail (default (list))) + compiler') + output]) + )) + )) diff --git a/new-luxc/source/luxc/lang.lux b/new-luxc/source/luxc/lang.lux deleted file mode 100644 index 787895466..000000000 --- a/new-luxc/source/luxc/lang.lux +++ /dev/null @@ -1,44 +0,0 @@ -(;module: - lux) - -(type: #export (Pattern a) Void) - -(type: #export Primitive - #Unit - (#Bool Bool) - (#Nat Nat) - (#Int Int) - (#Deg Deg) - (#Real Real) - (#Char Char) - (#Text Text)) - -(type: #export Reference - (#Relative Ref) - (#Absolute Ident)) - -(type: #export (Structure a) - (#Variant Nat Bool a) - (#Tuple (List a)) - (#Case (Pattern a)) - (#Function Scope a) - (#Call a (List a)) - (#Procedure Text (List a))) - -(type: #export (Analysis' Analysis) - (#Primitive Primitive) - (#Structure (Structure Analysis)) - (#Reference Reference)) - -(type: #export #rec Analysis - (Meta [Type Cursor] - (Analysis' Analysis))) - -(type: #export Synthesis - Unit) - -(type: #export Eval - (-> Type Code (Lux Top))) - -(type: #export Analyser - (-> Eval Code (Lux Analysis))) diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux new file mode 100644 index 000000000..092b561f0 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis.lux @@ -0,0 +1,30 @@ +(;module: + lux + (lux (data [product])) + (.. ["lp" pattern])) + +(type: #export (Analysis' Analysis) + #Unit + (#Bool Bool) + (#Nat Nat) + (#Int Int) + (#Deg Deg) + (#Real Real) + (#Char Char) + (#Text Text) + (#Variant Nat Bool Analysis) + (#Tuple (List Analysis)) + (#Case (List [lp;Pattern Analysis])) + (#Function Scope Analysis) + (#Call Analysis (List Analysis)) + (#Procedure Text (List Analysis)) + (#Relative Ref) + (#Absolute Ident)) + +(type: #export #rec Analysis + (Meta [Type Cursor] + (Analysis' Analysis))) + +(def: #export (get-type analysis) + (-> Analysis Type) + (|> analysis product;left product;left)) diff --git a/new-luxc/source/luxc/lang/pattern.lux b/new-luxc/source/luxc/lang/pattern.lux new file mode 100644 index 000000000..a0077133b --- /dev/null +++ b/new-luxc/source/luxc/lang/pattern.lux @@ -0,0 +1,15 @@ +(;module: + lux) + +(type: #export #rec Pattern + (#Ref Nat) + #Unit + (#Bool Bool) + (#Nat Nat) + (#Int Int) + (#Deg Deg) + (#Real Real) + (#Char Char) + (#Text Text) + (#Tuple (List Pattern)) + (#Variant [Nat Nat] Pattern)) diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux new file mode 100644 index 000000000..00cccfbe6 --- /dev/null +++ b/new-luxc/source/luxc/lang/synthesis.lux @@ -0,0 +1,21 @@ +(;module: + lux + (.. ["lp" pattern])) + +(type: #export #rec Synthesis + #Unit + (#Bool Bool) + (#Nat Nat) + (#Int Int) + (#Deg Deg) + (#Real Real) + (#Char Char) + (#Text Text) + (#Variant Nat Bool Synthesis) + (#Tuple (List Synthesis)) + (#Case (lp;Pattern Synthesis)) + (#Function Scope Synthesis) + (#Call Synthesis (List Synthesis)) + (#Procedure Text (List Synthesis)) + (#Relative Ref) + (#Absolute Ident)) diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux index e5848fccb..1e6174143 100644 --- a/new-luxc/source/luxc/module.lux +++ b/new-luxc/source/luxc/module.lux @@ -17,12 +17,35 @@ #;module-anns (list) #;module-state #;Active}) +(def: #export (define (^@ full-name [module-name def-name]) + definition) + (-> Ident Def (Lux Unit)) + (function [compiler] + (case (&;pl-get module-name (get@ #;modules compiler)) + (#;Some module) + (case (&;pl-get def-name (get@ #;defs module)) + #;None + (#E;Success [(update@ #;modules + (&;pl-put module-name + (update@ #;defs + (: (-> (List [Text Def]) (List [Text Def])) + (|>. (#;Cons [def-name definition]))) + module)) + compiler) + []]) + + (#;Some already-existing) + (#E;Error (format "Cannot re-define definiton: " (%ident full-name)))) + + #;None + (#E;Error (format "Cannot define in unknown module: " module-name))))) + (def: #export (create hash name) (-> Nat Text (Lux Module)) (function [compiler] (let [module (new-module hash)] (#E;Success [(update@ #;modules - (&;pl::put name module) + (&;pl-put name module) compiler) module])))) @@ -30,19 +53,24 @@ [(def: #export ( module-name) (-> Text (Lux Unit)) (function [compiler] - (case (|> compiler (get@ #;modules) (&;pl::get module-name)) + (case (|> compiler (get@ #;modules) (&;pl-get module-name)) (#;Some module) - (#E;Success [(update@ #;modules - (&;pl::put module-name (set@ #;module-state module)) - compiler) - []]) + (let [active? (case (get@ #;module-state module) + #;Active true + _ false)] + (if active? + (#E;Success [(update@ #;modules + (&;pl-put module-name (set@ #;module-state module)) + compiler) + []]) + (#E;Error "Can only change the state of a currently-active module."))) #;None (#E;Error (format "Module does not exist: " module-name))))) (def: #export ( module-name) (-> Text (Lux Bool)) (function [compiler] - (case (|> compiler (get@ #;modules) (&;pl::get module-name)) + (case (|> compiler (get@ #;modules) (&;pl-get module-name)) (#;Some module) (#E;Success [compiler (case (get@ #;module-state module) diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index 900c16e05..c0aaec6ad 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -1,12 +1,45 @@ (;module: lux (lux (control monad) - (data text/format) + (data text/format + (coll [list "L/" Functor])) [macro #+ Monad]) (luxc ["&" base] - lang + (lang ["la" analysis #+ Analysis] + ["ls" synthesis #+ Synthesis]) ["&;" analyser])) (def: #export (synthesize analysis) (-> Analysis Synthesis) - (undefined)) + (case analysis + (^template [ ] + [meta ( value)] + ( value)) + ([#la;Unit #ls;Unit] + [#la;Bool #ls;Bool] + [#la;Nat #ls;Nat] + [#la;Int #ls;Int] + [#la;Deg #ls;Deg] + [#la;Real #ls;Real] + [#la;Char #ls;Char] + [#la;Text #ls;Text] + [#la;Relative #ls;Relative] + [#la;Absolute #ls;Absolute]) + + [meta (#la;Tuple values)] + (#ls;Tuple (L/map synthesize values)) + + [meta (#la;Variant tag last? value)] + (#ls;Variant tag last? (synthesize value)) + + [meta (#la;Function scope body)] + (#ls;Function scope (synthesize body)) + + [meta (#la;Call func args)] + (#ls;Call (synthesize func) (L/map synthesize args)) + + [meta (#la;Procedure name args)] + (#ls;Procedure name (L/map synthesize args)) + + [meta (#la;Case pattern)] + (undefined))) -- cgit v1.2.3