aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc')
-rw-r--r--new-luxc/source/luxc/analyser.lux4
-rw-r--r--new-luxc/source/luxc/analyser/common.lux7
-rw-r--r--new-luxc/source/luxc/analyser/lux.lux52
-rw-r--r--new-luxc/source/luxc/analyser/pattern.lux3
-rw-r--r--new-luxc/source/luxc/base.lux27
-rw-r--r--new-luxc/source/luxc/compiler.lux87
-rw-r--r--new-luxc/source/luxc/compiler/common.jvm.lux65
-rw-r--r--new-luxc/source/luxc/compiler/expr.jvm.lux57
-rw-r--r--new-luxc/source/luxc/compiler/runtime.jvm.lux6
-rw-r--r--new-luxc/source/luxc/env.lux81
-rw-r--r--new-luxc/source/luxc/lang.lux44
-rw-r--r--new-luxc/source/luxc/lang/analysis.lux30
-rw-r--r--new-luxc/source/luxc/lang/pattern.lux15
-rw-r--r--new-luxc/source/luxc/lang/synthesis.lux21
-rw-r--r--new-luxc/source/luxc/module.lux42
-rw-r--r--new-luxc/source/luxc/synthesizer.lux39
16 files changed, 422 insertions, 158 deletions
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 [<tag> <analyser>]
[cursor (<tag> 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 <type>))]
(wrap [[expected cursor]
- (#lang;Primitive (<tag> 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]
+ (<tag> 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<Lux>
[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<Lux>
[?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<Lux>
[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<Lux>
[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<Lux>]
- (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>]
- text/format)
- [macro #+ Monad<Lux>])
+ text/format
+ (coll ["D" dict]
+ [array #+ Array]))
+ [macro #+ Monad<Lux>]
+ 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<Text>)))]
+ {#&&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<Promise>
- [#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> "Lux/" Monad<Lux>])
+ [macro #+ Monad<Lux> "Lux/" Monad<Lux>]
+ [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<Lux>
+ [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 [<tag>]
+ (<tag> 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<Lux>
+ [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 [<slot> <is> <get> <then>]
[(def: (<is> name scope)
(-> Text Scope Bool)
(|> scope
(get@ [<slot> #;mappings])
- (pl::contains? name)))
+ (&;pl-contains? name)))
(def: (<get> name scope)
(-> Text Scope (Maybe [Type Ref]))
(|> scope
(get@ [<slot> #;mappings])
- (pl::get name)
+ (&;pl-get name)
(Maybe/map (function [[type value]]
[type (<then> 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 [<name> <val-type>]
+ [(def: <name>
+ (Bindings Text [Type <val-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 (<flagger> 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 <tag> 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 <tag> 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 (<asker> 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<List>]))
[macro #+ Monad<Lux>])
(luxc ["&" base]
- lang
+ (lang ["la" analysis #+ Analysis]
+ ["ls" synthesis #+ Synthesis])
["&;" analyser]))
(def: #export (synthesize analysis)
(-> Analysis Synthesis)
- (undefined))
+ (case analysis
+ (^template [<from> <to>]
+ [meta (<from> value)]
+ (<to> 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)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 03:52:17 +0000