aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser.lux122
-rw-r--r--new-luxc/source/luxc/analyser/common.lux67
-rw-r--r--new-luxc/source/luxc/analyser/function.lux188
-rw-r--r--new-luxc/source/luxc/analyser/lux.lux397
-rw-r--r--new-luxc/source/luxc/analyser/primitive.lux34
-rw-r--r--new-luxc/source/luxc/analyser/proc.lux20
-rw-r--r--new-luxc/source/luxc/analyser/proc/lux.lux321
-rw-r--r--new-luxc/source/luxc/analyser/reference.lux51
-rw-r--r--new-luxc/source/luxc/analyser/struct.lux172
-rw-r--r--new-luxc/source/luxc/analyser/type.lux29
-rw-r--r--new-luxc/source/luxc/base.lux10
-rw-r--r--new-luxc/source/luxc/compiler.lux2
-rw-r--r--new-luxc/source/luxc/compiler/expr.jvm.lux6
-rw-r--r--new-luxc/source/luxc/lang/analysis.lux14
14 files changed, 923 insertions, 510 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index 05a755b08..b220fb433 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -1,14 +1,9 @@
(;module:
lux
- (lux (control monad
- pipe)
- [io #- run]
- (concurrency ["A" atom])
+ (lux (control monad)
(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>]
@@ -18,48 +13,91 @@
(lang ["la" analysis])
["&;" module]
["&;" env])
- (. ["&&;" lux]))
+ (. ["&&;" common]
+ ["&&;" function]
+ ["&&;" primitive]
+ ["&&;" reference]
+ ["&&;" type]
+ ["&&;" struct]
+ ["&&;" proc]))
-(def: #export (analyse eval ast)
- &;Analyser
- (case ast
- (^template [<tag> <analyser>]
- [cursor (<tag> value)]
- (<analyser> cursor value))
- ([#;Bool &&lux;analyse-bool]
- [#;Nat &&lux;analyse-nat]
- [#;Int &&lux;analyse-int]
- [#;Deg &&lux;analyse-deg]
- [#;Real &&lux;analyse-real]
- [#;Char &&lux;analyse-char]
- [#;Text &&lux;analyse-text])
+(def: #export (analyser eval)
+ (-> &;Eval &;Analyser)
+ (: (-> Code (Lux la;Analysis))
+ (function analyse [ast]
+ (case ast
+ (^template [<tag> <analyser>]
+ [cursor (<tag> value)]
+ (<analyser> value))
+ ([#;Bool &&primitive;analyse-bool]
+ [#;Nat &&primitive;analyse-nat]
+ [#;Int &&primitive;analyse-int]
+ [#;Deg &&primitive;analyse-deg]
+ [#;Real &&primitive;analyse-real]
+ [#;Char &&primitive;analyse-char]
+ [#;Text &&primitive;analyse-text])
- (^ [cursor (#;Tuple (list))])
- (&&lux;analyse-unit cursor)
+ (^ [cursor (#;Tuple (list))])
+ &&primitive;analyse-unit
- (^ [cursor (#;Tuple (list singleton))])
- (analyse eval singleton)
+ (^ [cursor (#;Tuple (list singleton))])
+ (analyse singleton)
- (^ [cursor (#;Tuple elems)])
- (&&lux;analyse-tuple (analyse eval) cursor elems)
+ (^ [cursor (#;Tuple elems)])
+ (&&struct;analyse-tuple analyse elems)
- [cursor (#;Symbol reference)]
- (&&lux;analyse-reference cursor reference)
+ [cursor (#;Symbol reference)]
+ (&&reference;analyse-reference reference)
- (^ [cursor (#;Form (list [_ (#;Symbol ["" "_lux_check"])]
- type
- value))])
- (&&lux;analyse-check analyse eval cursor type value)
+ (^ [cursor (#;Form (list [_ (#;Symbol ["" "_lux_check"])]
+ type
+ value))])
+ (&&type;analyse-check analyse eval type value)
- (^ [cursor (#;Form (list [_ (#;Symbol ["" "_lux_coerce"])]
- type
- value))])
- (&&lux;analyse-coerce analyse eval cursor type value)
+ (^ [cursor (#;Form (list [_ (#;Symbol ["" "_lux_coerce"])]
+ type
+ value))])
+ (&&type;analyse-coerce analyse eval type value)
- (^ [cursor (#;Form (list [_ (#;Nat tag)]
- value))])
- (&&lux;analyse-variant (analyse eval) cursor tag value)
+ (^ [cursor (#;Form (list [_ (#;Symbol ["" "_lux_proc"])]
+ [_ (#;Symbol proc)]
+ [_ (#;Tuple args)]))])
+ (&&proc;analyse-proc analyse proc args)
- _
- (&;fail (format "Unrecognized syntax: " (%ast ast)))
- ))
+ (^ [cursor (#;Form (list [_ (#;Nat tag)]
+ value))])
+ (&&struct;analyse-variant analyse tag value)
+
+ (^ [cursor (#;Form (list& func args))])
+ (do Monad<Lux>
+ [[funcT =func] (&&common;with-unknown-type
+ (analyse func))]
+ (case =func
+ (#la;Absolute def-name)
+ (do @
+ [[def-type def-anns def-value] (macro;find-def def-name)]
+ (if (macro;macro? def-anns)
+ (do @
+ [## macro-expansion (function [compiler]
+ ## (case (macro-caller def-value args compiler)
+ ## (#E;Success [compiler' output])
+ ## (#E;Success [compiler' output])
+
+ ## (#E;Error error)
+ ## ((&;fail error) compiler)))
+ macro-expansion (: (Lux (List Code))
+ (undefined))]
+ (case macro-expansion
+ (^ (list single-expansion))
+ (analyse single-expansion)
+
+ _
+ (&;fail (format "Macro expressions must expand to a single expression: " (%code ast)))))
+ (&&function;analyse-apply analyse funcT =func args)))
+
+ _
+ (&&function;analyse-apply analyse funcT =func args)))
+
+ _
+ (&;fail (format "Unrecognized syntax: " (%code ast)))
+ ))))
diff --git a/new-luxc/source/luxc/analyser/common.lux b/new-luxc/source/luxc/analyser/common.lux
index ed2b6eba7..7a9e5dbf8 100644
--- a/new-luxc/source/luxc/analyser/common.lux
+++ b/new-luxc/source/luxc/analyser/common.lux
@@ -10,64 +10,23 @@
(luxc ["&" base]
(lang analysis)))
-(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
- (#;Var id)
- (do Monad<Lux>
- [=type (&;within-type-env
- (TC;clean id type))]
- (wrap (replace-type =type analysis)))
-
- (#;Ex id)
- (undefined)
-
- _
- (&;fail (format "Cannot clean type: " (%type type)))))
-
(def: #export (with-unknown-type action)
- (All [a] (-> (Lux Analysis) (Lux Analysis)))
+ (All [a] (-> (Lux Analysis) (Lux [Type 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)]))
+ analysis (&;with-expected-type var-type
+ action)
+ analysis-type (&;within-type-env
+ (TC;clean var-id var-type))
_ (&;within-type-env
(TC;delete-var var-id))]
- (wrap analysis)))
-
-(def: #export (realize expected)
- (-> Type (TC;Check [(List Type) Type]))
- (case expected
- (#;Named [module name] _expected)
- (realize _expected)
+ (wrap [analysis-type analysis])))
- (#;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: #export (with-var body)
+ (All [a] (-> (-> [Nat Type] (Lux a)) (Lux a)))
+ (do Monad<Lux>
+ [[id var] (&;within-type-env TC;create-var)
+ output (body [id var])
+ _ (&;within-type-env (TC;delete-var id))]
+ (wrap output)))
diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux
new file mode 100644
index 000000000..17441b760
--- /dev/null
+++ b/new-luxc/source/luxc/analyser/function.lux
@@ -0,0 +1,188 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data ["E" error]
+ [text]
+ text/format
+ (coll [list "L/" Fold<List> Monoid<List> Monad<List>]))
+ [macro #+ Monad<Lux>]
+ [type]
+ (type ["TC" check]))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis])
+ ["&;" env]
+ (analyser ["&;" common])))
+
+## [Analysers]
+(def: (bind-var var-id bound-idx type)
+ (-> Nat Nat Type Type)
+ (case type
+ (#;Host name params)
+ (#;Host name (L/map (bind-var var-id bound-idx) params))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (<tag> (bind-var var-id bound-idx left)
+ (bind-var var-id bound-idx right)))
+ ([#;Sum]
+ [#;Product]
+ [#;Function]
+ [#;App])
+
+ (#;Var id)
+ (if (n.= var-id id)
+ (#;Bound bound-idx)
+ type)
+
+ (^template [<tag>]
+ (<tag> env quantified)
+ (<tag> (L/map (bind-var var-id bound-idx) env)
+ (bind-var var-id (n.+ +2 bound-idx) quantified)))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ (#;Named name unnamedT)
+ (#;Named name
+ (bind-var var-id bound-idx unnamedT))
+
+ _
+ type))
+
+(def: #export (analyse-function analyse func-name arg-name body)
+ (-> &;Analyser Text Text Code (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (&;with-stacked-errors
+ (function [_] (format "Functions require function types: " (type;to-text expected)))
+ (case expected
+ (#;Named name unnamedT)
+ (&;with-expected-type unnamedT
+ (analyse-function analyse func-name arg-name body))
+
+ (#;App funT argT)
+ (do @
+ [fully-applied (case (type;apply-type funT argT)
+ (#;Some value)
+ (wrap value)
+
+ #;None
+ (&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT))))]
+ (&;with-expected-type fully-applied
+ (analyse-function analyse func-name arg-name body)))
+
+ (#;UnivQ _)
+ (do @
+ [[var-id var] (&;within-type-env
+ TC;existential)]
+ (&;with-expected-type (assume (type;apply-type expected var))
+ (analyse-function analyse func-name arg-name body)))
+
+ (#;ExQ _)
+ (&common;with-var
+ (function [[var-id var]]
+ (&;with-expected-type (assume (type;apply-type expected var))
+ (analyse-function analyse func-name arg-name body))))
+
+ (#;Var id)
+ (do @
+ [? (&;within-type-env
+ (TC;bound? id))]
+ (if ?
+ (do @
+ [expected' (&;within-type-env
+ (TC;read-var id))]
+ (&;with-expected-type expected'
+ (analyse-function analyse func-name arg-name body)))
+ ## Inference
+ (&common;with-var
+ (function [[input-id inputT]]
+ (&common;with-var
+ (function [[output-id outputT]]
+ (do @
+ [#let [funT (#;Function inputT outputT)]
+ =function (&;with-expected-type funT
+ (analyse-function analyse func-name arg-name body))
+ funT' (&;within-type-env
+ (TC;clean output-id funT))
+ concrete-input? (&;within-type-env
+ (TC;bound? input-id))
+ funT'' (if concrete-input?
+ (&;within-type-env
+ (TC;clean input-id funT'))
+ (wrap (#;UnivQ (list) (bind-var input-id +1 funT'))))
+ _ (&;within-type-env
+ (TC;check expected funT''))]
+ (wrap =function))
+ ))))))
+
+ (#;Function inputT outputT)
+ (<| (:: @ map (|>. #la;Function))
+ &;with-scope
+ (&env;with-local [func-name expected])
+ (&env;with-local [arg-name inputT])
+ (&;with-expected-type outputT)
+ (analyse body))
+
+ _
+ (&;fail "")
+ ))))
+
+(def: (analyse-apply' analyse funcT args)
+ (-> &;Analyser Type (List Code) (Lux [Type (List Analysis)]))
+ (case args
+ #;Nil
+ (:: Monad<Lux> wrap [funcT (list)])
+
+ (#;Cons arg args')
+ (&;with-stacked-errors
+ (function [_] (format "Cannot apply function " (%type funcT)
+ " to args: " (|> args (L/map %code) (text;join-with " "))))
+ (case funcT
+ (#;Named name unnamedT)
+ (analyse-apply' analyse unnamedT args)
+
+ (#;UnivQ _)
+ (&common;with-var
+ (function [[var-id varT]]
+ (do Monad<Lux>
+ [[outputT argsA] (analyse-apply' analyse (assume (type;apply-type funcT varT)) args)]
+ (do @
+ [? (&;within-type-env
+ (TC;bound? var-id))
+ outputT' (if ?
+ (&;within-type-env
+ (TC;clean var-id outputT))
+ (wrap (#;UnivQ (list) (bind-var var-id +1 outputT))))]
+ (wrap [outputT' argsA])))))
+
+ (#;ExQ _)
+ (do Monad<Lux>
+ [[ex-id exT] (&;within-type-env
+ TC;existential)]
+ (analyse-apply' analyse (assume (type;apply-type funcT exT)) args))
+
+ (#;Function inputT outputT)
+ (do Monad<Lux>
+ [[outputT' args'A] (analyse-apply' analyse outputT args')
+ argA (&;with-stacked-errors
+ (function [_] (format "Expected type: " (%type inputT) "\n"
+ " For argument: " (%code arg)))
+ (&;with-expected-type inputT
+ (analyse arg)))]
+ (wrap [outputT' (list& argA args'A)]))
+
+ _
+ (&;fail (format "Cannot apply a non-function: " (%type funcT)))))
+ ))
+
+(def: #export (analyse-apply analyse funcT funcA args)
+ (-> &;Analyser Type Analysis (List Code) (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type
+ [applyT argsA] (analyse-apply' analyse funcT args)
+ _ (&;within-type-env
+ (TC;check expected applyT))]
+ (wrap (L/fold (function [arg func]
+ (#la;Apply arg func))
+ funcA
+ argsA))))
diff --git a/new-luxc/source/luxc/analyser/lux.lux b/new-luxc/source/luxc/analyser/lux.lux
deleted file mode 100644
index 7bce8ed8d..000000000
--- a/new-luxc/source/luxc/analyser/lux.lux
+++ /dev/null
@@ -1,397 +0,0 @@
-(;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 ["la" analysis #+ Analysis])
- ["&;" 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]
- (<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)
- (-> Cursor (Lux Analysis))
- (do Monad<Lux>
- [expected macro;expected-type
- _ (&;within-type-env
- (TC;check expected Unit))]
- (wrap [[expected cursor]
- #la;Unit])))
-
-(def: (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]
- (#la;Absolute def-name)])))
-
-(def: (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]
- (#la;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 Code Code (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 Code Code (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 expected =value))))
-
-(def: (analyse-typed-tuple analyse cursor members)
- (-> (-> Code (Lux Analysis)) Cursor
- (List Code)
- (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]
- (#la;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]
- (#la;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]
- (#la;Tuple (L/append =prevs (list =last)))]))
- ))))
-
-(def: (tuple cursor members)
- (-> Cursor (List Analysis) Analysis)
- (let [tuple-type (type;tuple (L/map la;get-type members))]
- [[tuple-type cursor]
- (#la;Tuple members)]))
-
-(def: #export (analyse-tuple analyse cursor members)
- (-> (-> Code (Lux Analysis)) Cursor
- (List Code)
- (Lux Analysis))
- (do Monad<Lux>
- [expected macro;expected-type]
- (case expected
- (#;Product _)
- (analyse-typed-tuple analyse cursor members)
-
- (#;Var 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 (la;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 (la;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)
- (-> (-> Code (Lux Analysis)) Cursor
- Nat Code
- (Lux Analysis))
- (do Monad<Lux>
- [expected macro;expected-type]
- (case expected
- (#;Sum _)
- (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]
- (#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"
- " 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 (la;get-type =variant)))]
- (wrap (&common;replace-type expected =variant)))
- (&;fail (format "Invalid type for variant: " (%type expected)))))))
-
-## Functions
-(def: (maybe-to-lux input)
- (All [a] (-> (Maybe a) (Lux a)))
- (case input
- #;None
- (&;fail "")
-
- (#;Some value)
- (:: Monad<Lux> wrap value)))
-
-(def: (with-var body)
- (All [a] (-> (-> [Nat Type] (Lux a)) (Lux a)))
- (do Monad<Lux>
- [[id var] (&;within-type-env TC;create-var)
- output (body [id var])
- _ (&;within-type-env (TC;delete-var id))]
- (wrap output)))
-
-(def: (bind-var var-id bound-idx type)
- (-> Nat Nat Type Type)
- (case type
- (#;Host name params)
- (#;Host name (L/map (bind-var var-id bound-idx) params))
-
- (^template [<tag>]
- (<tag> left right)
- (<tag> (bind-var var-id bound-idx left)
- (bind-var var-id bound-idx right)))
- ([#;Sum]
- [#;Product]
- [#;Function]
- [#;App])
-
- (#;Var id)
- (if (n.= var-id id)
- (#;Bound bound-idx)
- type)
-
- (^template [<tag>]
- (<tag> env quantified)
- (<tag> (L/map (bind-var var-id bound-idx) env)
- (bind-var var-id (n.+ +2 bound-idx) quantified)))
- ([#;UnivQ]
- [#;ExQ])
-
- (#;Named name unnamed)
- (#;Named name
- (bind-var var-id bound-idx unnamed))
-
- _
- type))
-
-(def: #export (analyse-function analyse cursor func-name arg-name body)
- (-> (-> Code (Lux Analysis)) Cursor
- Text Text Code
- (Lux Analysis))
- (do Monad<Lux>
- [expected macro;expected-type]
- (&;with-try
- (function [error]
- (let [raw (format "Functions require function types: " (type;to-text expected))]
- (&;fail (if (T/= "" error)
- raw
- (format error "\n" raw)))))
- (case expected
- (#;Named name unnamed)
- (do @
- [=function (&;with-expected-type unnamed
- (analyse-function analyse cursor func-name arg-name body))]
- (wrap (&common;replace-type expected =function)))
-
- (#;App funT argT)
- (do @
- [fully-applied (maybe-to-lux (type;apply-type funT argT))
- =function (&;with-expected-type fully-applied
- (analyse-function analyse cursor func-name arg-name body))]
- (wrap (&common;replace-type expected =function)))
-
- (#;UnivQ _)
- (do @
- [[var-id var] (&;within-type-env
- TC;existential)
- expected' (maybe-to-lux (type;apply-type expected var))
- =function (&;with-expected-type expected'
- (analyse-function analyse cursor func-name arg-name body))]
- (wrap (&common;replace-type expected =function)))
-
- (#;ExQ _)
- (with-var
- (function [[var-id var]]
- (do @
- [expected' (maybe-to-lux (type;apply-type expected var))
- =function (&;with-expected-type expected'
- (analyse-function analyse cursor func-name arg-name body))]
- (&common;clean var =function))))
-
- (#;Var id)
- (do @
- [? (&;within-type-env
- (TC;bound? id))]
- (if ?
- (do @
- [expected' (&;within-type-env
- (TC;read-var id))]
- (&;with-expected-type expected'
- (analyse-function analyse cursor func-name arg-name body)))
- ## Inference
- (with-var
- (function [[input-id inputT]]
- (with-var
- (function [[output-id outputT]]
- (do @
- [#let [funT (#;Function inputT outputT)]
- =function (&;with-expected-type funT
- (analyse-function analyse cursor func-name arg-name body))
- funT' (&;within-type-env
- (TC;clean output-id funT))
- concrete-input? (&;within-type-env
- (TC;bound? input-id))
- funT'' (if concrete-input?
- (&;within-type-env
- (TC;clean input-id funT'))
- (wrap (#;UnivQ (list) (bind-var input-id +1 funT'))))
- _ (&;within-type-env
- (TC;check expected funT''))]
- (wrap (&common;replace-type expected =function)))
- ))))))
-
- (#;Function inputT outputT)
- (do @
- [[=scope =body] (&;with-scope
- (&env;with-local [func-name expected]
- (&env;with-local [arg-name inputT]
- (&;with-expected-type outputT
- (analyse body)))))]
- (wrap [[expected cursor]
- (#la;Function =scope =body)]))
-
- _
- (&;fail "")
- ))))
diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux
new file mode 100644
index 000000000..26580a503
--- /dev/null
+++ b/new-luxc/source/luxc/analyser/primitive.lux
@@ -0,0 +1,34 @@
+(;module:
+ lux
+ (lux (control monad)
+ [macro #+ Monad<Lux>]
+ (type ["TC" check]))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis])))
+
+## [Analysers]
+(do-template [<name> <type> <tag>]
+ [(def: #export (<name> value)
+ (-> <type> (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected <type>))]
+ (wrap (<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
+ (Lux Analysis)
+ (do Monad<Lux>
+ [expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected Unit))]
+ (wrap #la;Unit)))
diff --git a/new-luxc/source/luxc/analyser/proc.lux b/new-luxc/source/luxc/analyser/proc.lux
new file mode 100644
index 000000000..8bd975272
--- /dev/null
+++ b/new-luxc/source/luxc/analyser/proc.lux
@@ -0,0 +1,20 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data ["E" error]
+ [text]
+ text/format
+ (coll ["D" dict])
+ maybe))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis]))
+ (. ["&&;" lux]))
+
+(def: #export (analyse-proc analyse [proc-category proc-name] proc-args)
+ (-> &;Analyser Ident (List Code) (Lux Analysis))
+ (default (let [proc-description (format "[" (%t proc-category) " " (%t proc-name) "]")]
+ (&;fail (format "Unknown procedure: " proc-description)))
+ (do Monad<Maybe>
+ [procs (D;get proc-category &&lux;procs)
+ proc (D;get proc-name procs)]
+ (wrap (proc analyse proc-args)))))
diff --git a/new-luxc/source/luxc/analyser/proc/lux.lux b/new-luxc/source/luxc/analyser/proc/lux.lux
new file mode 100644
index 000000000..8ad88baed
--- /dev/null
+++ b/new-luxc/source/luxc/analyser/proc/lux.lux
@@ -0,0 +1,321 @@
+(;module:
+ lux
+ (lux (control monad)
+ (concurrency ["A" atom])
+ (data [text]
+ text/format
+ (coll [list]
+ [array #+ Array]
+ ["D" dict]))
+ [macro #+ Monad<Lux>]
+ (type ["TC" check])
+ [io])
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis])
+ (analyser ["&;" common])))
+
+## [Utils]
+(type: Proc-Analyser
+ (-> &;Analyser (List Code) (Lux Analysis)))
+
+(type: Proc-Set
+ (D;Dict Text Proc-Analyser))
+
+(def: (wrong-amount-error proc expected actual)
+ (-> Ident Nat Nat Text)
+ (let [[proc-category proc-name] proc
+ proc-description (format "[" (%t proc-category) " " (%t proc-name) "]")]
+ (format "Wrong number of arguments for " proc-description "\n"
+ "Expected: " (|> expected nat-to-int %i) "\n"
+ " Actual: " (|> actual nat-to-int %i))))
+
+(def: (simple-proc proc input-types output-type)
+ (-> Ident (List Type) Type Proc-Analyser)
+ (let [num-expected (list;size input-types)]
+ (function [analyse args]
+ (let [num-actual (list;size args)]
+ (if (n.= num-expected num-actual)
+ (do Monad<Lux>
+ [argsA (mapM @
+ (function [[argT argC]]
+ (&;with-expected-type argT
+ (analyse argC)))
+ (list;zip2 input-types args))
+ expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected output-type))]
+ (wrap (#la;Procedure proc argsA)))
+ (&;fail (wrong-amount-error proc num-expected num-actual)))))))
+
+(def: (binary-operation proc subjectT paramT outputT)
+ (-> Ident Type Type Type Proc-Analyser)
+ (simple-proc proc (list subjectT paramT) outputT))
+
+(def: (trinary-operation proc subjectT param0T param1T outputT)
+ (-> Ident Type Type Type Type Proc-Analyser)
+ (simple-proc proc (list subjectT param0T param1T) outputT))
+
+(def: (unary-operation proc inputT outputT)
+ (-> Ident Type Type Proc-Analyser)
+ (simple-proc proc (list inputT) outputT))
+
+(def: (special-value proc valueT)
+ (-> Ident Type Proc-Analyser)
+ (simple-proc proc (list) valueT))
+
+(def: (converter proc fromT toT)
+ (-> Ident Type Type Proc-Analyser)
+ (simple-proc proc (list fromT) toT))
+
+## [Analysers]
+(def: (analyse-lux-is analyse args)
+ Proc-Analyser
+ (&common;with-var
+ (function [[var-id varT]]
+ ((binary-operation ["lux" "is"] varT varT Bool)
+ analyse args))))
+
+(def: (analyse-lux-try analyse args)
+ Proc-Analyser
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list opC))
+ (do Monad<Lux>
+ [opA (&;with-expected-type (type (io;IO varT))
+ (analyse opC))
+ outputT (&;within-type-env
+ (TC;clean var-id (type (Either Text varT))))
+ expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected outputT))]
+ (wrap (#la;Procedure ["lux" "try"] (list opA))))
+
+ _
+ (&;fail (wrong-amount-error ["lux" "try"] +1 (list;size args)))))))
+
+(def: lux-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "is" analyse-lux-is)
+ (D;put "try" analyse-lux-try)))
+
+(def: io-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "log" (converter ["io" "log"] Text Unit))
+ (D;put "error" (converter ["io" "error"] Text Bottom))
+ (D;put "exit" (converter ["io" "exit"] Nat Bottom))
+ (D;put "current-time" (special-value ["io" "current-time"] Int))))
+
+(def: bit-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "count" (unary-operation ["bit" "count"] Nat Nat))
+ (D;put "and" (binary-operation ["bit" "and"] Nat Nat Nat))
+ (D;put "or" (binary-operation ["bit" "or"] Nat Nat Nat))
+ (D;put "xor" (binary-operation ["bit" "xor"] Nat Nat Nat))
+ (D;put "shift-left" (binary-operation ["bit" "shift-left"] Nat Nat Nat))
+ (D;put "unsigned-shift-right" (binary-operation ["bit" "unsigned-shift-right"] Nat Nat Nat))
+ (D;put "shift-right" (binary-operation ["bit" "shift-right"] Int Nat Int))
+ ))
+
+(def: nat-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "+" (binary-operation ["nat" "+"] Nat Nat Nat))
+ (D;put "-" (binary-operation ["nat" "-"] Nat Nat Nat))
+ (D;put "*" (binary-operation ["nat" "*"] Nat Nat Nat))
+ (D;put "/" (binary-operation ["nat" "/"] Nat Nat Nat))
+ (D;put "%" (binary-operation ["nat" "%"] Nat Nat Nat))
+ (D;put "=" (binary-operation ["nat" "="] Nat Nat Bool))
+ (D;put "<" (binary-operation ["nat" "<"] Nat Nat Bool))
+ (D;put "min-value" (special-value ["nat" "min-value"] Nat))
+ (D;put "max-value" (special-value ["nat" "max-value"] Nat))
+ (D;put "to-int" (converter ["nat" "to-int"] Nat Int))
+ (D;put "to-text" (converter ["nat" "to-text"] Nat Text))))
+
+(def: int-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "+" (binary-operation ["int" "+"] Int Int Int))
+ (D;put "-" (binary-operation ["int" "-"] Int Int Int))
+ (D;put "*" (binary-operation ["int" "*"] Int Int Int))
+ (D;put "/" (binary-operation ["int" "/"] Int Int Int))
+ (D;put "%" (binary-operation ["int" "%"] Int Int Int))
+ (D;put "=" (binary-operation ["int" "="] Int Int Bool))
+ (D;put "<" (binary-operation ["int" "<"] Int Int Bool))
+ (D;put "min-value" (special-value ["int" "min-value"] Int))
+ (D;put "max-value" (special-value ["int" "max-value"] Int))
+ (D;put "to-nat" (converter ["int" "to-nat"] Int Nat))
+ (D;put "to-real" (converter ["int" "to-real"] Int Real))))
+
+(def: deg-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "+" (binary-operation ["deg" "+"] Deg Deg Deg))
+ (D;put "-" (binary-operation ["deg" "-"] Deg Deg Deg))
+ (D;put "*" (binary-operation ["deg" "*"] Deg Deg Deg))
+ (D;put "/" (binary-operation ["deg" "/"] Deg Deg Deg))
+ (D;put "%" (binary-operation ["deg" "%"] Deg Deg Deg))
+ (D;put "=" (binary-operation ["deg" "="] Deg Deg Bool))
+ (D;put "<" (binary-operation ["deg" "<"] Deg Deg Bool))
+ (D;put "scale" (binary-operation ["deg" "scale"] Deg Nat Deg))
+ (D;put "reciprocal" (binary-operation ["deg" "scale"] Deg Nat Deg))
+ (D;put "min-value" (special-value ["deg" "min-value"] Deg))
+ (D;put "max-value" (special-value ["deg" "max-value"] Deg))
+ (D;put "to-real" (converter ["deg" "to-real"] Deg Real))))
+
+(def: real-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "+" (binary-operation ["real" "+"] Real Real Real))
+ (D;put "-" (binary-operation ["real" "-"] Real Real Real))
+ (D;put "*" (binary-operation ["real" "*"] Real Real Real))
+ (D;put "/" (binary-operation ["real" "/"] Real Real Real))
+ (D;put "%" (binary-operation ["real" "%"] Real Real Real))
+ (D;put "=" (binary-operation ["real" "="] Real Real Bool))
+ (D;put "<" (binary-operation ["real" "<"] Real Real Bool))
+ (D;put "smallest-value" (special-value ["real" "smallest-value"] Real))
+ (D;put "min-value" (special-value ["real" "min-value"] Real))
+ (D;put "max-value" (special-value ["real" "max-value"] Real))
+ (D;put "not-a-number" (special-value ["real" "not-a-number"] Real))
+ (D;put "positive-infinity" (special-value ["real" "positive-infinity"] Real))
+ (D;put "negative-infinity" (special-value ["real" "negative-infinity"] Real))
+ (D;put "to-deg" (converter ["real" "to-deg"] Real Deg))
+ (D;put "to-int" (converter ["real" "to-int"] Real Int))
+ (D;put "hash" (unary-operation ["real" "hash"] Real Nat))
+ (D;put "encode" (converter ["real" "encode"] Real Text))
+ (D;put "decode" (converter ["real" "decode"] Text (type (Maybe Real))))))
+
+(def: text-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "=" (binary-operation ["text" "="] Text Text Bool))
+ (D;put "<" (binary-operation ["text" "<"] Text Text Bool))
+ (D;put "prepend" (binary-operation ["text" "prepend"] Text Text Text))
+ (D;put "index" (trinary-operation ["text" "index"] Text Text Nat (type (Maybe Nat))))
+ (D;put "size" (unary-operation ["text" "size"] Text Nat))
+ (D;put "hash" (unary-operation ["text" "hash"] Text Nat))
+ (D;put "replace-once" (binary-operation ["text" "replace-once"] Text Text Text))
+ (D;put "replace-all" (binary-operation ["text" "replace-all"] Text Text Text))
+ (D;put "char" (binary-operation ["text" "char"] Text Nat Nat))
+ (D;put "clip" (trinary-operation ["text" "clip"] Text Nat Nat Text))
+ ))
+
+(def: (analyse-array-get analyse args)
+ Proc-Analyser
+ (&common;with-var
+ (function [[var-id varT]]
+ ((binary-operation ["lux" "get"] Nat (type (Array varT)) varT)
+ analyse args))))
+
+(def: (analyse-array-put analyse args)
+ Proc-Analyser
+ (&common;with-var
+ (function [[var-id varT]]
+ ((trinary-operation ["lux" "put"] Nat varT (type (Array varT)) (type (Array varT)))
+ analyse args))))
+
+(def: (analyse-array-remove analyse args)
+ Proc-Analyser
+ (&common;with-var
+ (function [[var-id varT]]
+ ((binary-operation ["lux" "remove"] Nat (type (Array varT)) (type (Array varT)))
+ analyse args))))
+
+(def: array-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "new" (unary-operation ["array" "hash"] Nat Array))
+ (D;put "get" analyse-array-get)
+ (D;put "put" analyse-array-put)
+ (D;put "remove" analyse-array-remove)
+ (D;put "size" (unary-operation ["array" "size"] (type (Ex [a] (Array a))) Nat))
+ ))
+
+(def: math-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "cos" (unary-operation ["math" "cos"] Real Real))
+ (D;put "sin" (unary-operation ["math" "sin"] Real Real))
+ (D;put "tan" (unary-operation ["math" "tan"] Real Real))
+ (D;put "acos" (unary-operation ["math" "acos"] Real Real))
+ (D;put "asin" (unary-operation ["math" "asin"] Real Real))
+ (D;put "atan" (unary-operation ["math" "atan"] Real Real))
+ (D;put "cosh" (unary-operation ["math" "cosh"] Real Real))
+ (D;put "sinh" (unary-operation ["math" "sinh"] Real Real))
+ (D;put "tanh" (unary-operation ["math" "tanh"] Real Real))
+ (D;put "exp" (unary-operation ["math" "exp"] Real Real))
+ (D;put "log" (unary-operation ["math" "log"] Real Real))
+ (D;put "root2" (unary-operation ["math" "root2"] Real Real))
+ (D;put "root3" (unary-operation ["math" "root3"] Real Real))
+ (D;put "ceil" (unary-operation ["math" "ceil"] Real Real))
+ (D;put "floor" (unary-operation ["math" "floor"] Real Real))
+ (D;put "round" (unary-operation ["math" "round"] Real Real))
+ (D;put "atan2" (binary-operation ["math" "atan2"] Real Real Real))
+ (D;put "pow" (binary-operation ["math" "pow"] Real Real Real))
+ ))
+
+(def: (analyse-atom-new analyse args)
+ Proc-Analyser
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list initC))
+ (do Monad<Lux>
+ [initA (&;with-expected-type varT
+ (analyse initC))
+ outputT (&;within-type-env
+ (TC;clean var-id (type (A;Atom varT))))
+ expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected outputT))]
+ (wrap (#la;Procedure ["atom" "new"] (list initA))))
+
+ _
+ (&;fail (wrong-amount-error ["atom" "new"] +1 (list;size args)))))))
+
+(def: (analyse-atom-read analyse args)
+ (&common;with-var
+ (function [[var-id varT]]
+ ((unary-operation ["atom" "read"] (type (A;Atom varT)) varT)
+ analyse args))))
+
+(def: (analyse-atom-compare-and-swap analyse args)
+ (&common;with-var
+ (function [[var-id varT]]
+ ((trinary-operation ["atom" "compare-and-swap"] varT varT (type (A;Atom varT)) Bool)
+ analyse args))))
+
+(def: atom-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "new" analyse-atom-new)
+ (D;put "read" analyse-atom-read)
+ (D;put "compare-and-swap" analyse-atom-compare-and-swap)
+ ))
+
+(def: process-procs
+ Proc-Set
+ (|> (D;new text;Hash<Text>)
+ (D;put "concurrency-level" (special-value ["process" "concurrency-level"] Nat))
+ (D;put "future" (unary-operation ["process" "future"] (type (io;IO Top)) Unit))
+ (D;put "schedule" (binary-operation ["process" "schedule"] Nat (type (io;IO Top)) Unit))
+ ))
+
+(def: #export procs
+ (D;Dict Text Proc-Set)
+ (|> (D;new text;Hash<Text>)
+ (D;put "lux" lux-procs)
+ (D;put "bit" bit-procs)
+ (D;put "nat" nat-procs)
+ (D;put "int" int-procs)
+ (D;put "deg" deg-procs)
+ (D;put "real" real-procs)
+ (D;put "text" text-procs)
+ (D;put "array" array-procs)
+ (D;put "math" math-procs)
+ (D;put "atom" atom-procs)
+ (D;put "process" process-procs)
+ (D;put "io" io-procs)))
diff --git a/new-luxc/source/luxc/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux
new file mode 100644
index 000000000..ea0505c3b
--- /dev/null
+++ b/new-luxc/source/luxc/analyser/reference.lux
@@ -0,0 +1,51 @@
+(;module:
+ lux
+ (lux (control monad)
+ [macro #+ Monad<Lux>]
+ (type ["TC" check]))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis])
+ ["&;" env]))
+
+## [Analysers]
+(def: (analyse-definition def-name)
+ (-> 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 (#la;Absolute def-name))))
+
+(def: (analyse-variable var-name)
+ (-> 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))]
+ (wrap (#;Some (#la;Relative ref))))
+
+ #;None
+ (wrap #;None))))
+
+(def: #export (analyse-reference reference)
+ (-> Ident (Lux Analysis))
+ (case reference
+ ["" simple-name]
+ (do Monad<Lux>
+ [?var (analyse-variable simple-name)]
+ (case ?var
+ (#;Some analysis)
+ (wrap analysis)
+
+ #;None
+ (do @
+ [this-module macro;current-module-name]
+ (analyse-definition [this-module simple-name]))))
+
+ _
+ (analyse-definition reference)))
diff --git a/new-luxc/source/luxc/analyser/struct.lux b/new-luxc/source/luxc/analyser/struct.lux
new file mode 100644
index 000000000..a698fb49f
--- /dev/null
+++ b/new-luxc/source/luxc/analyser/struct.lux
@@ -0,0 +1,172 @@
+(;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 ["la" analysis #+ Analysis])
+ ["&;" module]
+ ["&;" env]
+ (analyser ["&;" common])))
+
+## [Analysers]
+(def: (analyse-typed-tuple analyse members)
+ (-> &;Analyser (List Code) (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 (#la;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 (#la;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 tail-xs))]
+ (wrap (#la;Tuple (L/append =prevs (list =last)))))
+ ))))
+
+(def: #export (analyse-tuple analyse members)
+ (-> &;Analyser (List Code) (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (&;with-stacked-errors
+ (function [_] (format "Invalid type for tuple: " (%type expected)))
+ (case expected
+ (#;Product _)
+ (analyse-typed-tuple analyse members)
+
+ (#;Named name unnamedT)
+ (&;with-expected-type unnamedT
+ (analyse-tuple analyse members))
+
+ (#;Var id)
+ (do @
+ [bound? (&;within-type-env
+ (TC;bound? id))]
+ (if bound?
+ (do @
+ [expected' (&;within-type-env
+ (TC;read-var id))]
+ (&;with-expected-type expected'
+ (analyse-tuple analyse members)))
+ (do @
+ [=members (mapM @ (|>. analyse &common;with-unknown-type)
+ members)
+ #let [tuple-type (type;tuple (L/map product;left =members))]
+ _ (&;within-type-env
+ (TC;check expected tuple-type))]
+ (wrap (#la;Tuple (L/map product;right =members))))))
+
+ (#;UnivQ _)
+ (do @
+ [[var-id var] (&;within-type-env
+ TC;existential)]
+ (&;with-expected-type (assume (type;apply-type expected var))
+ (analyse-tuple analyse members)))
+
+ (#;ExQ _)
+ (&common;with-var
+ (function [[var-id var]]
+ (&;with-expected-type (assume (type;apply-type expected var))
+ (analyse-tuple analyse members))))
+
+ _
+ (&;fail "")
+ ))))
+
+(def: #export (analyse-variant analyse tag value)
+ (-> &;Analyser Nat Code (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (&;with-stacked-errors
+ (function [_] (format "Invalid type for variant: " (%type expected)))
+ (case expected
+ (#;Sum _)
+ (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 (#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"
+ " Type: " (%type expected) "\n"))))
+
+ (#;Named name unnamedT)
+ (&;with-expected-type unnamedT
+ (analyse-variant analyse tag value))
+
+ (#;Var id)
+ (do @
+ [bound? (&;within-type-env
+ (TC;bound? id))]
+ (if bound?
+ (do @
+ [expected' (&;within-type-env
+ (TC;read-var id))]
+ (&;with-expected-type expected'
+ (analyse-variant analyse tag value)))
+ (&;fail (format "Invalid type for variant: " (%type expected)))))
+
+ (#;UnivQ _)
+ (do @
+ [[var-id var] (&;within-type-env
+ TC;existential)]
+ (&;with-expected-type (assume (type;apply-type expected var))
+ (analyse-variant analyse tag value)))
+
+ (#;ExQ _)
+ (&common;with-var
+ (function [[var-id var]]
+ (&;with-expected-type (assume (type;apply-type expected var))
+ (analyse-variant analyse tag value))))
+
+ _
+ (&;fail "")))))
diff --git a/new-luxc/source/luxc/analyser/type.lux b/new-luxc/source/luxc/analyser/type.lux
new file mode 100644
index 000000000..3b9b83245
--- /dev/null
+++ b/new-luxc/source/luxc/analyser/type.lux
@@ -0,0 +1,29 @@
+(;module:
+ lux
+ (lux (control monad)
+ [macro #+ Monad<Lux>]
+ (type ["TC" check]))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis])))
+
+## [Analysers]
+(def: #export (analyse-check analyse eval type value)
+ (-> &;Analyser &;Eval Code Code (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 value))))
+
+(def: #export (analyse-coerce analyse eval type value)
+ (-> &;Analyser &;Eval Code Code (Lux Analysis))
+ (do Monad<Lux>
+ [actual (eval Type type)
+ expected macro;expected-type
+ _ (&;within-type-env
+ (TC;check expected (:! Type actual)))]
+ (&;with-expected-type Top
+ (analyse value))))
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux
index 74e316b3c..ee2d4464d 100644
--- a/new-luxc/source/luxc/base.lux
+++ b/new-luxc/source/luxc/base.lux
@@ -12,7 +12,7 @@
(-> Type Code (Lux Top)))
(type: #export Analyser
- (-> Eval Code (Lux la;Analysis)))
+ (-> Code (Lux la;Analysis)))
(type: #export Path Text)
@@ -100,15 +100,17 @@
(#E;Success [(set@ #;source old-source compiler')
output])))))
-(def: #export (with-try handler action)
- (All [a] (-> (-> Text (Lux a)) (Lux a) (Lux a)))
+(def: #export (with-stacked-errors handler action)
+ (All [a] (-> (-> [] Text) (Lux a) (Lux a)))
(function [compiler]
(case (action compiler)
(#E;Success [compiler' output])
(#E;Success [compiler' output])
(#E;Error error)
- ((handler error) compiler))))
+ (#E;Error (if (T/= "" error)
+ (handler [])
+ (format error "\n-----------------------------------------\n" (handler [])))))))
(def: fresh-bindings
(All [k v] (Bindings k v))
diff --git a/new-luxc/source/luxc/compiler.lux b/new-luxc/source/luxc/compiler.lux
index 2af00b049..92d4bf8ab 100644
--- a/new-luxc/source/luxc/compiler.lux
+++ b/new-luxc/source/luxc/compiler.lux
@@ -35,7 +35,7 @@
(&&statement;compile-program prog-args prog-body)
_
- (&;fail (format "Unrecognized statement: " (%ast ast)))))
+ (&;fail (format "Unrecognized statement: " (%code ast)))))
(def: (exhaust action)
(All [a] (-> (Lux a) (Lux Unit)))
diff --git a/new-luxc/source/luxc/compiler/expr.jvm.lux b/new-luxc/source/luxc/compiler/expr.jvm.lux
index 33a41541b..173293b1c 100644
--- a/new-luxc/source/luxc/compiler/expr.jvm.lux
+++ b/new-luxc/source/luxc/compiler/expr.jvm.lux
@@ -50,8 +50,12 @@
&;Eval
(undefined))
+(def: analyse
+ &;Analyser
+ (&analyser;analyser eval))
+
(def: #export (compile input)
(-> Code (Lux &common;Compiled))
(do Monad<Lux>
- [analysis (&analyser;analyse eval input)]
+ [analysis (analyse input)]
(compile-synthesis (&synthesizer;synthesize analysis))))
diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux
index 092b561f0..71073f901 100644
--- a/new-luxc/source/luxc/lang/analysis.lux
+++ b/new-luxc/source/luxc/lang/analysis.lux
@@ -3,7 +3,7 @@
(lux (data [product]))
(.. ["lp" pattern]))
-(type: #export (Analysis' Analysis)
+(type: #export #rec Analysis
#Unit
(#Bool Bool)
(#Nat Nat)
@@ -16,15 +16,7 @@
(#Tuple (List Analysis))
(#Case (List [lp;Pattern Analysis]))
(#Function Scope Analysis)
- (#Call Analysis (List Analysis))
- (#Procedure Text (List Analysis))
+ (#Apply Analysis Analysis)
+ (#Procedure Ident (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))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 16:08:16 +0000