aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser.lux393
-rw-r--r--new-luxc/source/luxc/analyser/common.lux78
-rw-r--r--new-luxc/source/luxc/analyser/lux.lux255
-rw-r--r--new-luxc/source/luxc/base.lux66
-rw-r--r--new-luxc/source/luxc/compiler.lux154
-rw-r--r--new-luxc/source/luxc/compiler/expr.jvm.lux15
-rw-r--r--new-luxc/source/luxc/compiler/runtime.jvm.lux7
-rw-r--r--new-luxc/source/luxc/compiler/statement.jvm.lux6
-rw-r--r--new-luxc/source/luxc/env.lux37
-rw-r--r--new-luxc/source/luxc/lang.lux44
-rw-r--r--new-luxc/source/luxc/module.lux55
-rw-r--r--new-luxc/source/luxc/module/def.lux6
-rw-r--r--new-luxc/source/luxc/synthesizer.lux6
-rw-r--r--new-luxc/source/program.lux5
14 files changed, 706 insertions, 421 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index 84719738e..2a77d8bb5 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -15,354 +15,51 @@
[type]
(type ["TC" check]))
(luxc ["&" base]
+ [lang #*]
["&;" module]
- ["&;" env]
- (module ["&;" def])))
+ ["&;" env])
+ (. ["&&;" lux]))
+
+(def: #export (analyse eval ast)
+ Analyser
+ (case ast
+ (^template [<tag> <analyser>]
+ [cursor (<tag> value)]
+ (<analyser> cursor value))
+ ([#;BoolS &&lux;analyse-bool]
+ [#;NatS &&lux;analyse-nat]
+ [#;IntS &&lux;analyse-int]
+ [#;DegS &&lux;analyse-deg]
+ [#;RealS &&lux;analyse-real]
+ [#;CharS &&lux;analyse-char]
+ [#;TextS &&lux;analyse-text])
+
+ (^ [cursor (#;TupleS (list))])
+ (&&lux;analyse-unit cursor)
+
+ (^ [cursor (#;TupleS (list singleton))])
+ (analyse eval singleton)
+
+ (^ [cursor (#;TupleS elems)])
+ (&&lux;analyse-tuple (analyse eval) cursor elems)
+
+ [cursor (#;SymbolS reference)]
+ (&&lux;analyse-reference cursor reference)
+
+ (^ [cursor (#;FormS (list [_ (#;SymbolS ["" "_lux_check"])]
+ type
+ value))])
+ (&&lux;analyse-check analyse eval cursor type value)
+
+ (^ [cursor (#;FormS (list [_ (#;SymbolS ["" "_lux_coerce"])]
+ type
+ value))])
+ (&&lux;analyse-coerce analyse eval cursor type value)
+
+ (^ [cursor (#;FormS (list [_ (#;NatS tag)]
+ value))])
+ (&&lux;analyse-variant (analyse eval) cursor tag value)
-(type: #export Pattern Void)
-
-(type: #export (Analysis' Analysis)
- (#Bool Bool)
- (#Nat Nat)
- (#Int Int)
- (#Deg Deg)
- (#Real Real)
- (#Char Char)
- (#Text Text)
- (#Variant Nat Bool Analysis)
- #Unit
- (#Tuple (List Analysis))
- (#Call Analysis (List Analysis))
- (#Case (List [Pattern Analysis]))
- (#Function Scope Analysis)
- (#Var Ref)
- (#Def Ident)
- (#Procedure Text (List Analysis))
- )
-
-(type: #export #rec Analysis
- (Meta [Type Cursor]
- (Analysis' Analysis)))
-
-(def: (with-expected-type expected action)
- (All [a] (-> Type (Lux a) (Lux 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: (analyse-typed-tuple analyse cursor members)
- (-> (-> AST (Lux Analysis)) Cursor
- (List AST)
- (Lux Analysis))
- (do Monad<Lux>
- [expected macro;expected-type]
- (let [member-types (type;flatten-tuple expected)
- num-types (list;size member-types)
- num-members (list;size members)]
- (cond (n.= num-types num-members)
- (do @
- [=tuple (: (Lux (List Analysis))
- (mapM @
- (function [[expected member]]
- (with-expected-type expected
- (analyse member)))
- (list;zip2 member-types members)))]
- (wrap [[expected cursor]
- (#Tuple =tuple)]))
-
- (n.< num-types num-members)
- (do @
- [#let [[head-ts tail-ts] (list;split (n.- +2 num-members)
- member-types)]
- =prevs (mapM @
- (function [[expected member]]
- (with-expected-type expected
- (analyse member)))
- (list;zip2 head-ts members))
- =last (with-expected-type (type;tuple tail-ts)
- (analyse (default (undefined)
- (list;last members))))]
- (wrap [[expected cursor]
- (#Tuple (L/append =prevs (list =last)))]))
-
- ## (n.> num-types num-members)
- (do @
- [#let [[head-xs tail-xs] (list;split (n.- +2 num-types)
- members)]
- =prevs (mapM @
- (function [[expected member]]
- (with-expected-type expected
- (analyse member)))
- (list;zip2 member-types head-xs))
- =last (with-expected-type (default (undefined)
- (list;last member-types))
- (analyse-typed-tuple analyse cursor tail-xs))]
- (wrap [[expected cursor]
- (#Tuple (L/append =prevs (list =last)))]))
- ))))
-
-(def: (within-type-env action)
- (All [a] (-> (TC;Check a) (Lux a)))
- (function [compiler]
- (case (action (get@ #;type-context compiler))
- (#E;Error error)
- (#E;Error error)
-
- (#E;Success [context' output])
- (#E;Success [(set@ #;type-context context' compiler)
- output]))))
-
-(def: get-type
- (-> Analysis Type)
- (|>. product;left
- product;left))
-
-(def: (replace-type replacement analysis)
- (-> Type Analysis Analysis)
- (let [[[_type _cursor] _analysis] analysis]
- (: Analysis
- [[(: Type replacement)
- (: Cursor _cursor)]
- (: (Analysis' Analysis)
- _analysis)])))
-
-(def: (clean-analysis type analysis)
- (-> Type Analysis (Lux Analysis))
- (case type
- (#;VarT id)
- (do Monad<Lux>
- [=type (within-type-env
- (TC;clean id type))]
- (wrap (replace-type =type analysis)))
-
- (#;ExT id)
- (undefined)
-
_
- (&;fail (format "Cannot clean type: " (%type type)))))
-
-(def: (with-unknown-type action)
- (All [a] (-> (Lux Analysis) (Lux Analysis)))
- (do Monad<Lux>
- [[var-id var-type] (within-type-env
- TC;create-var)
- analysis (|> (wrap action)
- (%> @
- [(with-expected-type var-type)]
- [(clean-analysis var-type)]))
- _ (within-type-env
- (TC;delete-var var-id))]
- (wrap analysis)))
-
-(def: (tuple cursor members)
- (-> Cursor (List Analysis) Analysis)
- (let [tuple-type (type;tuple (L/map get-type members))]
- [[tuple-type cursor]
- (#Tuple members)]))
-
-(def: (realize expected)
- (-> Type (TC;Check [(List Type) Type]))
- (case expected
- (#;NamedT [module name] _expected)
- (realize _expected)
-
- (#;UnivQ env body)
- (do TC;Monad<Check>
- [[var-id var-type] TC;create-var
- [tail =expected] (realize (default (undefined)
- (type;apply-type expected var-type)))]
- (wrap [(list& var-type tail)
- =expected]))
-
- (#;ExQ env body)
- (do TC;Monad<Check>
- [[ex-id ex-type] TC;existential
- [tail =expected] (realize (default (undefined)
- (type;apply-type expected ex-type)))]
- (wrap [(list& ex-type tail)
- =expected]))
-
- _
- (:: TC;Monad<Check> wrap [(list) expected])))
-
-(def: (analyse-tuple analyse cursor members)
- (-> (-> AST (Lux Analysis)) Cursor
- (List AST)
- (Lux Analysis))
- (do Monad<Lux>
- [expected macro;expected-type]
- (case expected
- (#;ProdT _)
- (analyse-typed-tuple analyse cursor members)
-
- (#;VarT id)
- (do @
- [bound? (within-type-env
- (TC;bound? id))]
- (if bound?
- (do @
- [expected' (within-type-env
- (TC;read-var id))
- =tuple (with-expected-type expected'
- (analyse-tuple analyse cursor members))]
- (wrap (replace-type expected =tuple)))
- (do @
- [=members (mapM @ (<|. with-unknown-type
- analyse)
- members)
- #let [=tuple (tuple cursor =members)]
- _ (within-type-env
- (TC;check expected (get-type =tuple)))]
- (wrap (replace-type expected =tuple)))))
-
- _
- (if (type;quantified? expected)
- (do @
- [[bindings expected'] (within-type-env
- (realize expected))
- =tuple (with-expected-type expected'
- (analyse-tuple analyse cursor members))
- =tuple (foldM @ clean-analysis =tuple bindings)
- _ (within-type-env
- (TC;check expected (get-type =tuple)))]
- (wrap (replace-type expected =tuple)))
- (&;fail (format "Invalid type for tuple: " (%type expected))))
- )))
-
-(def: (analyse-variant analyse cursor tag value)
- (-> (-> AST (Lux Analysis)) Cursor
- Nat AST
- (Lux Analysis))
- (do Monad<Lux>
- [expected macro;expected-type]
- (case expected
- (#;SumT _)
- (let [flat (type;flatten-variant expected)
- type-size (list;size flat)]
- (if (n.< type-size tag)
- (do @
- [#let [last? (n.= tag (n.dec type-size))
- variant-type (default (undefined)
- (list;nth tag flat))]
- =value (with-expected-type variant-type
- (analyse value))]
- (wrap [[expected cursor]
- (#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"
- "Type: " (%type expected) "\n"))))
-
- _
- (if (type;quantified? expected)
- (do @
- [[bindings expected'] (within-type-env
- (realize expected))
- =variant (with-expected-type expected'
- (analyse-variant analyse cursor tag value))
- =variant (foldM @ clean-analysis =variant bindings)
- _ (within-type-env
- (TC;check expected (get-type =variant)))]
- (wrap (replace-type expected =variant)))
- (&;fail (format "Invalid type for variant: " (%type expected)))))))
-
-(def: (analyse eval ast)
- (-> (-> Type AST (Lux Top)) AST (Lux Analysis))
- (do Monad<Lux>
- []
- (case ast
- (^template [<ast-tag> <analysis-tag> <type>]
- [cursor (<ast-tag> value)]
- (do @
- [expected macro;expected-type
- _ (within-type-env
- (TC;check expected <type>))]
- (wrap [[<type> cursor]
- (<analysis-tag> value)])))
- ([#;BoolS #Bool Bool]
- [#;NatS #Nat Nat]
- [#;IntS #Int Int]
- [#;DegS #Deg Deg]
- [#;RealS #Real Real]
- [#;CharS #Char Char]
- [#;TextS #Text Text])
-
- (^ [cursor (#;TupleS (list))])
- (do @
- [expected macro;expected-type
- _ (within-type-env
- (TC;check expected Unit))]
- (wrap [[Unit cursor]
- #Unit]))
-
- (^ [cursor (#;TupleS (list singleton))])
- (analyse eval singleton)
-
- (^ [cursor (#;TupleS elems)])
- (do @
- [expected macro;expected-type]
- (with-expected-type expected
- (analyse-tuple (analyse eval) cursor elems)))
-
- [cursor (#;SymbolS ["" local-name])]
- (do @
- [?local (&env;find local-name)]
- (case ?local
- (#;Some [actual index])
- (do @
- [expected macro;expected-type
- _ (within-type-env
- (TC;check expected actual))]
- (wrap [[expected cursor]
- (#Var index)]))
-
- #;None
- (do @
- [this-module macro;current-module-name]
- (analyse eval [cursor (#;SymbolS [this-module local-name])]))))
-
- [cursor (#;SymbolS def-name)]
- (do @
- [expected macro;expected-type
- actual (&def;find def-name)
- _ (within-type-env
- (TC;check expected actual))]
- (wrap [[expected cursor]
- (#Def def-name)]))
-
- (^ [cursor (#;FormS (list [_ (#;SymbolS ["" "_lux_check"])]
- type
- value))])
- (do @
- [expected macro;expected-type
- actual (eval Type type)
- _ (within-type-env
- (TC;check expected actual))]
- (with-expected-type actual
- (analyse eval value)))
-
- (^ [cursor (#;FormS (list [_ (#;SymbolS ["" "_lux_coerce"])]
- type
- value))])
- (do @
- [expected macro;expected-type
- actual (eval Type type)
- _ (within-type-env
- (TC;check expected actual))
- =value (with-expected-type Top
- (analyse eval value))]
- (wrap (replace-type actual =value)))
-
- (^ [cursor (#;FormS (list [_ (#;NatS tag)]
- value))])
- (analyse-variant (analyse eval) cursor tag value)
-
- _
- (&;fail (format "Unrecognized syntax: " (%ast ast)))
- )))
+ (&;fail (format "Unrecognized syntax: " (%ast ast)))
+ ))
diff --git a/new-luxc/source/luxc/analyser/common.lux b/new-luxc/source/luxc/analyser/common.lux
new file mode 100644
index 000000000..0deceaa39
--- /dev/null
+++ b/new-luxc/source/luxc/analyser/common.lux
@@ -0,0 +1,78 @@
+(;module:
+ lux
+ (lux (control monad
+ pipe)
+ (data text/format
+ [product])
+ [macro #+ Monad<Lux>]
+ [type]
+ (type ["TC" check]))
+ (luxc ["&" base]
+ lang))
+
+(def: #export get-type
+ (-> Analysis Type)
+ (|>. product;left
+ product;left))
+
+(def: #export (replace-type replacement analysis)
+ (-> Type Analysis Analysis)
+ (let [[[_type _cursor] _analysis] analysis]
+ (: Analysis
+ [[(: Type replacement)
+ (: Cursor _cursor)]
+ (: (Analysis' Analysis)
+ _analysis)])))
+
+(def: #export (clean type analysis)
+ (-> Type Analysis (Lux Analysis))
+ (case type
+ (#;VarT id)
+ (do Monad<Lux>
+ [=type (&;within-type-env
+ (TC;clean id type))]
+ (wrap (replace-type =type analysis)))
+
+ (#;ExT id)
+ (undefined)
+
+ _
+ (&;fail (format "Cannot clean type: " (%type type)))))
+
+(def: #export (with-unknown-type action)
+ (All [a] (-> (Lux Analysis) (Lux Analysis)))
+ (do Monad<Lux>
+ [[var-id var-type] (&;within-type-env
+ TC;create-var)
+ analysis (|> (wrap action)
+ (%> @
+ [(&;with-expected-type var-type)]
+ [(clean var-type)]))
+ _ (&;within-type-env
+ (TC;delete-var var-id))]
+ (wrap analysis)))
+
+(def: #export (realize expected)
+ (-> Type (TC;Check [(List Type) Type]))
+ (case expected
+ (#;NamedT [module name] _expected)
+ (realize _expected)
+
+ (#;UnivQ env body)
+ (do TC;Monad<Check>
+ [[var-id var-type] TC;create-var
+ [tail =expected] (realize (default (undefined)
+ (type;apply-type expected var-type)))]
+ (wrap [(list& var-type tail)
+ =expected]))
+
+ (#;ExQ env body)
+ (do TC;Monad<Check>
+ [[ex-id ex-type] TC;existential
+ [tail =expected] (realize (default (undefined)
+ (type;apply-type expected ex-type)))]
+ (wrap [(list& ex-type tail)
+ =expected]))
+
+ _
+ (:: TC;Monad<Check> wrap [(list) expected])))
diff --git a/new-luxc/source/luxc/analyser/lux.lux b/new-luxc/source/luxc/analyser/lux.lux
new file mode 100644
index 000000000..24ac1e093
--- /dev/null
+++ b/new-luxc/source/luxc/analyser/lux.lux
@@ -0,0 +1,255 @@
+(;module:
+ lux
+ (lux (control monad
+ pipe)
+ [io #- run]
+ (concurrency ["A" atom])
+ (data ["E" error]
+ [text "T/" Eq<Text>]
+ text/format
+ (coll [list "L/" Fold<List> Monoid<List> Monad<List>]
+ ["D" dict])
+ [number]
+ [product])
+ [macro #+ Monad<Lux>]
+ [type]
+ (type ["TC" check]))
+ (luxc ["&" base]
+ [lang #*]
+ ["&;" module]
+ ["&;" env]
+ (analyser ["&;" common])))
+
+(do-template [<name> <type> <tag>]
+ [(def: #export (<name> cursor value)
+ (-> Cursor <type> (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type
+ _ (&;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]
+ )
+
+(def: #export (analyse-unit cursor)
+ (-> Cursor (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected Unit))]
+ (wrap [[expected cursor]
+ (#lang;Primitive #lang;Unit)])))
+
+(def: #export (analyse-definition cursor def-name)
+ (-> Cursor Ident (Lux Analysis))
+ (do Monad<Lux>
+ [actual (macro;find-def-type def-name)
+ expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected actual))]
+ (wrap [[expected cursor]
+ (#lang;Reference (#lang;Absolute def-name))])))
+
+(def: #export (analyse-variable cursor var-name)
+ (-> Cursor Text (Lux (Maybe Analysis)))
+ (do Monad<Lux>
+ [?var (&env;find var-name)]
+ (case ?var
+ (#;Some [actual ref])
+ (do @
+ [expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected actual))
+ #let [analysis [[expected cursor]
+ (#lang;Reference (#lang;Relative ref))]]]
+ (wrap (#;Some analysis)))
+
+ #;None
+ (wrap #;None))))
+
+(def: #export (analyse-reference cursor reference)
+ (-> Cursor Ident (Lux Analysis))
+ (case reference
+ ["" simple-name]
+ (do Monad<Lux>
+ [?var (analyse-variable cursor simple-name)]
+ (case ?var
+ (#;Some analysis)
+ (wrap analysis)
+
+ #;None
+ (do @
+ [this-module macro;current-module-name]
+ (analyse-definition cursor [this-module simple-name]))))
+
+ _
+ (analyse-definition cursor reference)))
+
+(def: #export (analyse-check analyse eval cursor type value)
+ (-> Analyser Eval Cursor AST AST (Lux Analysis))
+ (do Monad<Lux>
+ [actual (eval Type type)
+ #let [actual (:! Type actual)]
+ expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected actual))]
+ (&;with-expected-type actual
+ (analyse eval value))))
+
+(def: #export (analyse-coerce analyse eval cursor type value)
+ (-> Analyser Eval Cursor AST AST (Lux Analysis))
+ (do Monad<Lux>
+ [actual (eval Type type)
+ #let [actual (:! Type actual)]
+ expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected actual))
+ =value (&;with-expected-type Top
+ (analyse eval value))]
+ (wrap (&common;replace-type actual =value))))
+
+(def: (analyse-typed-tuple analyse cursor members)
+ (-> (-> AST (Lux Analysis)) Cursor
+ (List AST)
+ (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (let [member-types (type;flatten-tuple expected)
+ num-types (list;size member-types)
+ num-members (list;size members)]
+ (cond (n.= num-types num-members)
+ (do @
+ [=tuple (: (Lux (List Analysis))
+ (mapM @
+ (function [[expected member]]
+ (&;with-expected-type expected
+ (analyse member)))
+ (list;zip2 member-types members)))]
+ (wrap [[expected cursor]
+ (#lang;Structure (#lang;Tuple =tuple))]))
+
+ (n.< num-types num-members)
+ (do @
+ [#let [[head-ts tail-ts] (list;split (n.- +2 num-members)
+ member-types)]
+ =prevs (mapM @
+ (function [[expected member]]
+ (&;with-expected-type expected
+ (analyse member)))
+ (list;zip2 head-ts members))
+ =last (&;with-expected-type (type;tuple tail-ts)
+ (analyse (default (undefined)
+ (list;last members))))]
+ (wrap [[expected cursor]
+ (#lang;Structure (#lang;Tuple (L/append =prevs (list =last))))]))
+
+ ## (n.> num-types num-members)
+ (do @
+ [#let [[head-xs tail-xs] (list;split (n.- +2 num-types)
+ members)]
+ =prevs (mapM @
+ (function [[expected member]]
+ (&;with-expected-type expected
+ (analyse member)))
+ (list;zip2 member-types head-xs))
+ =last (&;with-expected-type (default (undefined)
+ (list;last member-types))
+ (analyse-typed-tuple analyse cursor tail-xs))]
+ (wrap [[expected cursor]
+ (#lang;Structure (#lang;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))]
+ [[tuple-type cursor]
+ (#lang;Structure (#lang;Tuple members))]))
+
+(def: #export (analyse-tuple analyse cursor members)
+ (-> (-> AST (Lux Analysis)) Cursor
+ (List AST)
+ (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (case expected
+ (#;ProdT _)
+ (analyse-typed-tuple analyse cursor members)
+
+ (#;VarT id)
+ (do @
+ [bound? (&;within-type-env
+ (TC;bound? id))]
+ (if bound?
+ (do @
+ [expected' (&;within-type-env
+ (TC;read-var id))
+ =tuple (&;with-expected-type expected'
+ (analyse-tuple analyse cursor members))]
+ (wrap (&common;replace-type expected =tuple)))
+ (do @
+ [=members (mapM @ (<|. &common;with-unknown-type
+ analyse)
+ members)
+ #let [=tuple (tuple cursor =members)]
+ _ (&;within-type-env
+ (TC;check expected (&common;get-type =tuple)))]
+ (wrap (&common;replace-type expected =tuple)))))
+
+ _
+ (if (type;quantified? expected)
+ (do @
+ [[bindings expected'] (&;within-type-env
+ (&common;realize expected))
+ =tuple (&;with-expected-type expected'
+ (analyse-tuple analyse cursor members))
+ =tuple (foldM @ &common;clean =tuple bindings)
+ _ (&;within-type-env
+ (TC;check expected (&common;get-type =tuple)))]
+ (wrap (&common;replace-type expected =tuple)))
+ (&;fail (format "Invalid type for tuple: " (%type expected))))
+ )))
+
+(def: #export (analyse-variant analyse cursor tag value)
+ (-> (-> AST (Lux Analysis)) Cursor
+ Nat AST
+ (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (case expected
+ (#;SumT _)
+ (let [flat (type;flatten-variant expected)
+ type-size (list;size flat)]
+ (if (n.< type-size tag)
+ (do @
+ [#let [last? (n.= tag (n.dec type-size))
+ variant-type (default (undefined)
+ (list;nth tag flat))]
+ =value (&;with-expected-type variant-type
+ (analyse value))]
+ (wrap [[expected cursor]
+ (#lang;Structure (#lang;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"
+ " Type: " (%type expected) "\n"))))
+
+ _
+ (if (type;quantified? expected)
+ (do @
+ [[bindings expected'] (&;within-type-env
+ (&common;realize expected))
+ =variant (&;with-expected-type expected'
+ (analyse-variant analyse cursor tag value))
+ =variant (foldM @ &common;clean =variant bindings)
+ _ (&;within-type-env
+ (TC;check expected (&common;get-type =variant)))]
+ (wrap (&common;replace-type expected =variant)))
+ (&;fail (format "Invalid type for variant: " (%type expected)))))))
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux
index ce872e9da..8660d7ccf 100644
--- a/new-luxc/source/luxc/base.lux
+++ b/new-luxc/source/luxc/base.lux
@@ -1,8 +1,11 @@
(;module:
lux
(lux (control monad)
- (data text/format)
- [macro #+ Monad<Lux>]))
+ (data [text "T/" Eq<Text>]
+ text/format
+ ["E" error])
+ [macro #+ Monad<Lux>]
+ (type ["TC" check])))
(type: #export Path Text)
@@ -19,3 +22,62 @@
"," (|> col nat-to-int %i))]]
(macro;fail (format "@ " location
"\n" message))))
+
+(def: #export (with-expected-type expected action)
+ (All [a] (-> Type (Lux a) (Lux 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 (within-type-env action)
+ (All [a] (-> (TC;Check a) (Lux a)))
+ (function [compiler]
+ (case (action (get@ #;type-context compiler))
+ (#E;Error error)
+ (#E;Error error)
+
+ (#E;Success [context' output])
+ (#E;Success [(set@ #;type-context context' compiler)
+ output]))))
+
+(def: #export (pl::put key val table)
+ (All [a] (-> Text a (List [Text a]) (List [Text a])))
+ (case table
+ #;Nil
+ (list [key val])
+
+ (#;Cons [k' v'] table')
+ (if (T/= key k')
+ (#;Cons [key val]
+ table')
+ (#;Cons [k' v']
+ (pl::put key val table')))))
+
+(def: #export (pl::get key table)
+ (All [a] (-> Text (List [Text a]) (Maybe a)))
+ (case table
+ #;Nil
+ #;None
+
+ (#;Cons [k' v'] table')
+ (if (T/= key k')
+ (#;Some v')
+ (pl::get key table'))))
+
+(def: #export (with-source-code source action)
+ (All [a] (-> [Cursor Text] (Lux a) (Lux 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])))))
diff --git a/new-luxc/source/luxc/compiler.lux b/new-luxc/source/luxc/compiler.lux
index 205c62df0..4ac865786 100644
--- a/new-luxc/source/luxc/compiler.lux
+++ b/new-luxc/source/luxc/compiler.lux
@@ -1,14 +1,15 @@
(;module:
lux
(lux (control monad)
- [io #- run]
+ (concurrency ["P" promise])
(data ["E" error]
- [text "T/" Eq<Text>]
+ [text "T/" Hash<Text>]
text/format)
[macro #+ Monad<Lux>])
(luxc ["&" base]
["&;" io]
["&;" module]
+ ["&;" parser]
(compiler ["&&;" runtime]
["&&;" statement])
))
@@ -36,60 +37,119 @@
[result action]
(exhaust action)))
-(def: (compile-module source-dirs module-name compiler-state)
- (-> (List &;Path) Text Compiler (IO (Error Compiler)))
- (do Monad<IO>
- [[file-name file-content] (&io;read-module source-dirs module-name)
- #let [file-hash (T/hash file-content)]
- #let [result (macro;run compiler-state
- (do Monad<Lux>
- [module-exists? (&module;exists? module-name)]
- (if module-exists?
- (&;fail (format "Cannot re-define a module: " module-name))
- (wrap []))))]]
- (case result
- (#E;Success [compiler-state _])
- (let [result (macro;run compiler-state
- (do Monad<Lux>
- [_ (&module;create module-name file-hash)
- _ (&module;flag-active module-name)
- _ (if (T/= "lux" module-name)
- &&runtime;compile-runtime
- (wrap []))
- _ (exhaust
- (do @
- [ast parse]
- (compile ast)))
- _ (&module;flag-compiled module-name)]
- (&module;generate-module file-hash module-name)))]
- (case result
- (#E;Success [compiler-state module-descriptor])
- (do @
- [_ (&io;write-module module-name module-descriptor)]
- (wrap (#E;Success compiler-state)))
+(def: (ensure-new-module! file-hash module-name)
+ (-> Nat Text (Lux Unit))
+ (do Monad<Lux>
+ [module-exists? (macro;module-exists? module-name)
+ _ (: (Lux Unit)
+ (if module-exists?
+ (&;fail (format "Cannot re-define a module: " module-name))
+ (wrap [])))
+ _ (&module;create file-hash module-name)]
+ (wrap [])))
+
+(def: prelude Text "lux")
+
+(def: (with-active-compilation [module-name file-name source-code] action)
+ (All [a] (-> [Text Text Text] (Lux a) (Lux a)))
+ (do Monad<Lux>
+ [_ (ensure-new-module! (T/hash source-code) module-name)
+ #let [init-cursor [file-name +0 +0]]
+ output (&;with-source-code [init-cursor source-code]
+ action)
+ _ (&module;flag-compiled! module-name)]
+ (wrap output)))
+(def: parse
+ (Lux AST)
+ (function [compiler]
+ (case (&parser;parse (get@ #;source compiler))
+ (#E;Error error)
+ (#E;Error error)
+
+ (#E;Success [source' output])
+ (#E;Success [(set@ #;source source' compiler)
+ output]))))
+
+(def: (compile-module source-dirs module-name compiler)
+ (-> (List &;Path) Text Compiler (P;Promise (E;Error Compiler)))
+ (do P;Monad<Promise>
+ [?input (&io;read-module source-dirs module-name)]
+ (case ?input
+ (#E;Success [file-name file-content])
+ (let [compilation (do Monad<Lux>
+ [_ (with-active-compilation [module-name
+ file-name
+ file-content]
+ (exhaust
+ (do @
+ [ast parse]
+ (compile ast))))]
+ (wrap [])
+ ## (&module;generate-descriptor module-name)
+ )]
+ (case (macro;run' compiler compilation)
+ (#E;Success [compiler module-descriptor])
+ (do @
+ [## _ (&io;write-module module-name module-descriptor)
+ ]
+ (wrap (#E;Success compiler)))
+
(#E;Error error)
(wrap (#E;Error error))))
-
+
(#E;Error error)
(wrap (#E;Error error)))))
-(def: (or-crash! action)
- (All [a] (-> (IO (E;Error a)) (IO a)))
- (do Monad<IO>
- [result action]
- (case result
- (#E;Success output)
- (wrap output)
+(type: Host Unit)
+
+(def: init-host Host [])
+
+(def: init-cursor Cursor ["" +0 +0])
+
+(def: init-type-context
+ Type-Context
+ {#;ex-counter +0
+ #;var-counter +0
+ #;var-bindings (list)})
+(def: compiler-version Text "0.6.0")
+
+(def: init-compiler-info
+ Compiler-Info
+ {#;compiler-version compiler-version
+ #;compiler-mode #;Release})
+
+(def: (init-compiler host)
+ (-> Host Compiler)
+ {#;info init-compiler-info
+ #;source [init-cursor ""]
+ #;cursor init-cursor
+ #;modules (list)
+ #;scopes (list)
+ #;type-context init-type-context
+ #;expected #;None
+ #;seed +0
+ #;scope-type-vars (list)
+ #;host (:! Void host)})
+
+(def: (or-crash! action)
+ (All [a] (-> (P;Promise (E;Error a)) (P;Promise a)))
+ (do P;Monad<Promise>
+ [?output action]
+ (case ?output
(#E;Error error)
- (error! (format "Compilation failed:\n" error)))))
+ (error! error)
+
+ (#E;Success output)
+ (wrap output))))
(def: #export (compile-program mode program target sources)
- (-> &;Mode &;Path &;Path (List &;Path) (IO Unit))
- (do Monad<IO>
- [#let [compiler-state (init-compiler-state mode host-state)]
- compiler-state (or-crash! (compile-module source-dirs "lux" compiler-state))
- compiler-state (or-crash! (compile-module source-dirs program compiler-state))
+ (-> &;Mode &;Path &;Path (List &;Path) (P;Promise Unit))
+ (do P;Monad<Promise>
+ [#let [compiler (init-compiler init-host)]
+ _ (or-crash! (&&runtime;compile-runtime []))
+ compiler (or-crash! (compile-module sources prelude compiler))
+ compiler (or-crash! (compile-module sources program compiler))
#let [_ (log! "Compilation complete!")]]
(wrap [])))
diff --git a/new-luxc/source/luxc/compiler/expr.jvm.lux b/new-luxc/source/luxc/compiler/expr.jvm.lux
index 6655abd5f..138d0d540 100644
--- a/new-luxc/source/luxc/compiler/expr.jvm.lux
+++ b/new-luxc/source/luxc/compiler/expr.jvm.lux
@@ -2,26 +2,29 @@
lux
(lux (control monad)
(data text/format)
- [macro #+ Monad<Lux>])
+ [macro #+ Monad<Lux> "Lux/" Monad<Lux>])
(luxc ["&" base]
- ["&;" module]
- ["&;" env]
+ lang
["&;" analyser]
- ["&;" synthesizer #+ Synthesis]))
+ ["&;" synthesizer]))
(type: #export JVM-Bytecode
Void)
-(type: Compiled
+(type: #export Compiled
JVM-Bytecode)
(def: (compile-synthesis synthesis)
(-> Synthesis Compiled)
(undefined))
+(def: (eval type code)
+ Eval
+ (undefined))
+
(def: #export (compile input)
(-> AST (Lux Compiled))
(|> input
- &analyser;analyse
+ (&analyser;analyse eval)
(Lux/map &synthesizer;synthesize)
(Lux/map compile-synthesis)))
diff --git a/new-luxc/source/luxc/compiler/runtime.jvm.lux b/new-luxc/source/luxc/compiler/runtime.jvm.lux
index 2d48b3617..b6cebb193 100644
--- a/new-luxc/source/luxc/compiler/runtime.jvm.lux
+++ b/new-luxc/source/luxc/compiler/runtime.jvm.lux
@@ -1,6 +1,11 @@
(;module:
lux
(lux (control monad)
- (data text/format))
+ (concurrency ["P" promise "P/" Monad<Promise>])
+ (data text/format
+ ["E" error]))
(luxc ["&" base]))
+(def: #export (compile-runtime _)
+ (-> Top (P;Promise (E;Error Unit)))
+ (P/wrap (#E;Success [])))
diff --git a/new-luxc/source/luxc/compiler/statement.jvm.lux b/new-luxc/source/luxc/compiler/statement.jvm.lux
index c4c23746e..0e53ba37d 100644
--- a/new-luxc/source/luxc/compiler/statement.jvm.lux
+++ b/new-luxc/source/luxc/compiler/statement.jvm.lux
@@ -11,16 +11,16 @@
["&;" env]
(compiler ["&;" expr])))
-(def: (compile-def def-name def-value def-meta)
+(def: #export (compile-def def-name def-value def-meta)
(-> Text AST AST (Lux Unit))
(do Monad<Lux>
[=def-value (&expr;compile def-value)
=def-meta (&expr;compile def-meta)]
(undefined)))
-(def: (compile-program prog-args prog-body)
+(def: #export (compile-program prog-args prog-body)
(-> Text AST (Lux Unit))
(do Monad<Lux>
[=prog-body (&env;with-local [prog-args (type (List Text))]
- (&expr;compile prog-body))]
+ (&expr;compile prog-body))]
(undefined)))
diff --git a/new-luxc/source/luxc/env.lux b/new-luxc/source/luxc/env.lux
index be68f84e9..338375a29 100644
--- a/new-luxc/source/luxc/env.lux
+++ b/new-luxc/source/luxc/env.lux
@@ -5,9 +5,12 @@
text/format
[maybe #+ Monad<Maybe> "Maybe/" Monad<Maybe>]
[product]
- (coll [list "L/" Fold<List> Monoid<List>])))
+ ["E" error]
+ (coll [list "L/" Fold<List> Monoid<List>]))
+ [macro])
(luxc ["&" base]))
+(type: Locals (Bindings Text [Type Nat]))
(type: Captured (Bindings Text [Type Ref]))
(def: (pl::contains? key mappings)
@@ -104,3 +107,35 @@
(#;Right [(set@ #;scopes scopes compiler)
(#;Some [ref-type ref])]))
))))
+
+(def: #export (with-local [name type] action)
+ (All [a] (-> [Text Type] (Lux a) (Lux a)))
+ (function [compiler]
+ (case (get@ #;scopes compiler)
+ (#;Cons head tail)
+ (let [old-mappings (get@ [#;locals #;mappings] head)
+ new-var-id (get@ [#;locals #;counter] head)
+ new-head (update@ #;locals
+ (: (-> Locals Locals)
+ (|>. (update@ #;counter n.inc)
+ (update@ #;mappings (pl::put name [type new-var-id]))))
+ head)]
+ (case (macro;run' (set@ #;scopes (#;Cons new-head tail) compiler)
+ action)
+ (#E;Success [compiler' output])
+ (case (get@ #;scopes compiler')
+ (#;Cons head' tail')
+ (let [scopes' (#;Cons (set@ #;locals (get@ #;locals head) head')
+ tail')]
+ (#E;Success [(set@ #;scopes scopes' compiler')
+ output]))
+
+ _
+ (error! "Invalid scope alteration."))
+
+ (#E;Error error)
+ (#E;Error error)))
+
+ _
+ (#E;Error "Cannot create local binding without a scope."))
+ ))
diff --git a/new-luxc/source/luxc/lang.lux b/new-luxc/source/luxc/lang.lux
new file mode 100644
index 000000000..0c5c97192
--- /dev/null
+++ b/new-luxc/source/luxc/lang.lux
@@ -0,0 +1,44 @@
+(;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 AST (Lux Top)))
+
+(type: #export Analyser
+ (-> Eval AST (Lux Analysis)))
diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux
index 2d48b3617..e5848fccb 100644
--- a/new-luxc/source/luxc/module.lux
+++ b/new-luxc/source/luxc/module.lux
@@ -1,6 +1,59 @@
(;module:
lux
(lux (control monad)
- (data text/format))
+ (data [text "T/" Eq<Text>]
+ text/format
+ ["E" error]))
(luxc ["&" base]))
+(def: (new-module hash)
+ (-> Nat Module)
+ {#;module-hash hash
+ #;module-aliases (list)
+ #;defs (list)
+ #;imports (list)
+ #;tags (list)
+ #;types (list)
+ #;module-anns (list)
+ #;module-state #;Active})
+
+(def: #export (create hash name)
+ (-> Nat Text (Lux Module))
+ (function [compiler]
+ (let [module (new-module hash)]
+ (#E;Success [(update@ #;modules
+ (&;pl::put name module)
+ compiler)
+ module]))))
+
+(do-template [<flagger> <asker> <tag>]
+ [(def: #export (<flagger> module-name)
+ (-> Text (Lux Unit))
+ (function [compiler]
+ (case (|> compiler (get@ #;modules) (&;pl::get module-name))
+ (#;Some module)
+ (#E;Success [(update@ #;modules
+ (&;pl::put module-name (set@ #;module-state <tag> module))
+ compiler)
+ []])
+
+ #;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))
+ (#;Some module)
+ (#E;Success [compiler
+ (case (get@ #;module-state module)
+ <tag> true
+ _ false)])
+
+ #;None
+ (#E;Error (format "Module does not exist: " module-name)))
+ ))]
+
+ [flag-active! active? #;Active]
+ [flag-compiled! compiled? #;Compiled]
+ [flag-cached! cached? #;Cached]
+ )
diff --git a/new-luxc/source/luxc/module/def.lux b/new-luxc/source/luxc/module/def.lux
deleted file mode 100644
index 2d48b3617..000000000
--- a/new-luxc/source/luxc/module/def.lux
+++ /dev/null
@@ -1,6 +0,0 @@
-(;module:
- lux
- (lux (control monad)
- (data text/format))
- (luxc ["&" base]))
-
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux
index 682bbe3ec..900c16e05 100644
--- a/new-luxc/source/luxc/synthesizer.lux
+++ b/new-luxc/source/luxc/synthesizer.lux
@@ -4,10 +4,8 @@
(data text/format)
[macro #+ Monad<Lux>])
(luxc ["&" base]
- ["&;" analyser #+ Analysis]))
-
-(type: #export Synthesis
- Unit)
+ lang
+ ["&;" analyser]))
(def: #export (synthesize analysis)
(-> Analysis Synthesis)
diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux
index 07f21962b..e7fa95c2d 100644
--- a/new-luxc/source/program.lux
+++ b/new-luxc/source/program.lux
@@ -41,7 +41,8 @@
[sources (cli;some (tagged (list "-s" "--source")))])
(case command
#;None
- (io (log! "Hello, REPL!"))
+ (io (log! "No REPL for you!"))
(#;Some [mode program target])
- (&compiler;compile-program mode program target sources)))
+ (exec (&compiler;compile-program mode program target sources)
+ (io []))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 02:48:50 +0000