aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang')
-rw-r--r--new-luxc/source/luxc/lang/analysis/case.lux260
-rw-r--r--new-luxc/source/luxc/lang/analysis/case/coverage.lux299
-rw-r--r--new-luxc/source/luxc/lang/analysis/common.lux41
-rw-r--r--new-luxc/source/luxc/lang/analysis/expression.lux141
-rw-r--r--new-luxc/source/luxc/lang/analysis/function.lux111
-rw-r--r--new-luxc/source/luxc/lang/analysis/inference.lux228
-rw-r--r--new-luxc/source/luxc/lang/analysis/primitive.lux34
-rw-r--r--new-luxc/source/luxc/lang/analysis/procedure.lux23
-rw-r--r--new-luxc/source/luxc/lang/analysis/procedure/common.lux418
-rw-r--r--new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux1241
-rw-r--r--new-luxc/source/luxc/lang/analysis/reference.lux53
-rw-r--r--new-luxc/source/luxc/lang/analysis/structure.lux311
-rw-r--r--new-luxc/source/luxc/lang/analysis/type.lux31
-rw-r--r--new-luxc/source/luxc/lang/parser.lux610
14 files changed, 3801 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux
new file mode 100644
index 000000000..1e40e38f1
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/case.lux
@@ -0,0 +1,260 @@
+(;module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
+ eq)
+ (data [bool]
+ [number]
+ [product]
+ ["e" error]
+ [maybe]
+ [text]
+ text/format
+ (coll [list "list/" Fold<List> Monoid<List> Functor<List>]))
+ [meta]
+ (meta [code]
+ [type]
+ (type ["tc" check])))
+ (luxc ["&" base]
+ (lang ["la" analysis]
+ (analysis [";A" common]
+ [";A" structure]
+ (case [";A" coverage])))
+ ["&;" scope]))
+
+(exception: #export Cannot-Match-Type-With-Pattern)
+(exception: #export Sum-Type-Has-No-Case)
+(exception: #export Unrecognized-Pattern-Syntax)
+(exception: #export Cannot-Simplify-Type-For-Pattern-Matching)
+
+(def: (pattern-error type pattern)
+ (-> Type Code Text)
+ (Cannot-Match-Type-With-Pattern
+ (format " Type: " (%type type) "\n"
+ "Pattern: " (%code pattern))))
+
+## Type-checking on the input value is done during the analysis of a
+## "case" expression, to ensure that the patterns being used make
+## sense for the type of the input value.
+## Sometimes, that input value is complex, by depending on
+## type-variables or quantifications.
+## This function makes it easier for "case" analysis to properly
+## type-check the input with respect to the patterns.
+(def: (simplify-case-type type)
+ (-> Type (Meta Type))
+ (case type
+ (#;Var id)
+ (do meta;Monad<Meta>
+ [? (&;with-type-env
+ (tc;bound? id))]
+ (if ?
+ (do @
+ [type' (&;with-type-env
+ (tc;read id))]
+ (simplify-case-type type'))
+ (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type type))))
+
+ (#;Named name unnamedT)
+ (simplify-case-type unnamedT)
+
+ (^or (#;UnivQ _) (#;ExQ _))
+ (do meta;Monad<Meta>
+ [[ex-id exT] (&;with-type-env
+ tc;existential)]
+ (simplify-case-type (maybe;assume (type;apply (list exT) type))))
+
+ (#;Apply inputT funcT)
+ (case (type;apply (list inputT) funcT)
+ (#;Some outputT)
+ (:: meta;Monad<Meta> wrap outputT)
+
+ #;None
+ (&;fail (format "Cannot apply type " (%type funcT) " to type " (%type inputT))))
+
+ _
+ (:: meta;Monad<Meta> wrap type)))
+
+## This function handles several concerns at once, but it must be that
+## way because those concerns are interleaved when doing
+## pattern-matching and they cannot be separated.
+## The pattern is analysed in order to get a general feel for what is
+## expected of the input value. This, in turn, informs the
+## type-checking of the input.
+## A kind of "continuation" value is passed around which signifies
+## what needs to be done _after_ analysing a pattern.
+## In general, this is done to analyse the "body" expression
+## associated to a particular pattern _in the context of_ said
+## pattern.
+## The reason why *context* is important is because patterns may bind
+## values to local variables, which may in turn be referenced in the
+## body expressions.
+## That is why the body must be analysed in the context of the
+## pattern, and not separately.
+(def: (analyse-pattern num-tags inputT pattern next)
+ (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la;Pattern a])))
+ (case pattern
+ [cursor (#;Symbol ["" name])]
+ (&;with-cursor cursor
+ (do meta;Monad<Meta>
+ [outputA (&scope;with-local [name inputT]
+ next)
+ idx &scope;next-local]
+ (wrap [(` ("lux case bind" (~ (code;nat idx)))) outputA])))
+
+ [cursor (#;Symbol ident)]
+ (&;with-cursor cursor
+ (&;fail (format "Symbols must be unqualified inside patterns: " (%ident ident))))
+
+ (^template [<type> <code-tag>]
+ [cursor (<code-tag> test)]
+ (&;with-cursor cursor
+ (do meta;Monad<Meta>
+ [_ (&;with-type-env
+ (tc;check inputT <type>))
+ outputA next]
+ (wrap [pattern outputA]))))
+ ([Bool #;Bool]
+ [Nat #;Nat]
+ [Int #;Int]
+ [Deg #;Deg]
+ [Frac #;Frac]
+ [Text #;Text])
+
+ (^ [cursor (#;Tuple (list))])
+ (&;with-cursor cursor
+ (do meta;Monad<Meta>
+ [_ (&;with-type-env
+ (tc;check inputT Unit))
+ outputA next]
+ (wrap [(` ("lux case tuple" [])) outputA])))
+
+ (^ [cursor (#;Tuple (list singleton))])
+ (analyse-pattern #;None inputT singleton next)
+
+ [cursor (#;Tuple sub-patterns)]
+ (&;with-cursor cursor
+ (do meta;Monad<Meta>
+ [inputT' (simplify-case-type inputT)]
+ (case inputT'
+ (#;Product _)
+ (let [sub-types (type;flatten-tuple inputT')
+ num-sub-types (maybe;default (list;size sub-types)
+ num-tags)
+ num-sub-patterns (list;size sub-patterns)
+ matches (cond (n.< num-sub-types num-sub-patterns)
+ (let [[prefix suffix] (list;split (n.dec num-sub-patterns) sub-types)]
+ (list;zip2 (list/compose prefix (list (type;tuple suffix))) sub-patterns))
+
+ (n.> num-sub-types num-sub-patterns)
+ (let [[prefix suffix] (list;split (n.dec num-sub-types) sub-patterns)]
+ (list;zip2 sub-types (list/compose prefix (list (code;tuple suffix)))))
+
+ ## (n.= num-sub-types num-sub-patterns)
+ (list;zip2 sub-types sub-patterns)
+ )]
+ (do @
+ [[memberP+ thenA] (list/fold (: (All [a]
+ (-> [Type Code] (Meta [(List la;Pattern) a])
+ (Meta [(List la;Pattern) a])))
+ (function [[memberT memberC] then]
+ (do @
+ [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la;Pattern a])))
+ analyse-pattern)
+ #;None memberT memberC then)]
+ (wrap [(list& memberP memberP+) thenA]))))
+ (do @
+ [nextA next]
+ (wrap [(list) nextA]))
+ matches)]
+ (wrap [(` ("lux case tuple" [(~@ memberP+)]))
+ thenA])))
+
+ _
+ (&;fail (pattern-error inputT pattern))
+ )))
+
+ [cursor (#;Record record)]
+ (do meta;Monad<Meta>
+ [record (structureA;normalize record)
+ [members recordT] (structureA;order record)
+ _ (&;with-type-env
+ (tc;check inputT recordT))]
+ (analyse-pattern (#;Some (list;size members)) inputT [cursor (#;Tuple members)] next))
+
+ [cursor (#;Tag tag)]
+ (&;with-cursor cursor
+ (analyse-pattern #;None inputT (` ((~ pattern))) next))
+
+ (^ [cursor (#;Form (list& [_ (#;Nat idx)] values))])
+ (&;with-cursor cursor
+ (do meta;Monad<Meta>
+ [inputT' (simplify-case-type inputT)]
+ (case inputT'
+ (#;Sum _)
+ (let [flat-sum (type;flatten-variant inputT')
+ size-sum (list;size flat-sum)
+ num-cases (maybe;default size-sum num-tags)]
+ (case (list;nth idx flat-sum)
+ (^multi (#;Some case-type)
+ (n.< num-cases idx))
+ (if (and (n.> num-cases size-sum)
+ (n.= (n.dec num-cases) idx))
+ (do meta;Monad<Meta>
+ [[testP nextA] (analyse-pattern #;None
+ (type;variant (list;drop (n.dec num-cases) flat-sum))
+ (` [(~@ values)])
+ next)]
+ (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
+ nextA]))
+ (do meta;Monad<Meta>
+ [[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)]
+ (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
+ nextA])))
+
+ _
+ (&;throw Sum-Type-Has-No-Case
+ (format "Case: " (%n idx) "\n"
+ "Type: " (%type inputT)))))
+
+ _
+ (&;fail (pattern-error inputT pattern)))))
+
+ (^ [cursor (#;Form (list& [_ (#;Tag tag)] values))])
+ (&;with-cursor cursor
+ (do meta;Monad<Meta>
+ [tag (meta;normalize tag)
+ [idx group variantT] (meta;resolve-tag tag)
+ _ (&;with-type-env
+ (tc;check inputT variantT))]
+ (analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next)))
+
+ _
+ (&;throw Unrecognized-Pattern-Syntax (%code pattern))
+ ))
+
+(def: #export (analyse-case analyse inputC branches)
+ (-> &;Analyser Code (List [Code Code]) (Meta la;Analysis))
+ (case branches
+ #;Nil
+ (&;fail "Cannot have empty branches in pattern-matching expression.")
+
+ (#;Cons [patternH bodyH] branchesT)
+ (do meta;Monad<Meta>
+ [[inputT inputA] (commonA;with-unknown-type
+ (analyse inputC))
+ outputH (analyse-pattern #;None inputT patternH (analyse bodyH))
+ outputT (monad;map @
+ (function [[patternT bodyT]]
+ (analyse-pattern #;None inputT patternT (analyse bodyT)))
+ branchesT)
+ outputHC (|> outputH product;left coverageA;determine)
+ outputTC (monad;map @ (|>. product;left coverageA;determine) outputT)
+ _ (case (monad;fold e;Monad<Error> coverageA;merge outputHC outputTC)
+ (#e;Success coverage)
+ (if (coverageA;exhaustive? coverage)
+ (wrap [])
+ (&;fail "Pattern-matching is not exhaustive."))
+
+ (#e;Error error)
+ (&;fail error))]
+ (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT)))))))))
diff --git a/new-luxc/source/luxc/lang/analysis/case/coverage.lux b/new-luxc/source/luxc/lang/analysis/case/coverage.lux
new file mode 100644
index 000000000..554aea1a8
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/case/coverage.lux
@@ -0,0 +1,299 @@
+(;module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
+ eq)
+ (data [bool "bool/" Eq<Bool>]
+ [number]
+ ["e" error "error/" Monad<Error>]
+ text/format
+ (coll [list "list/" Fold<List>]
+ [dict #+ Dict]))
+ [meta "meta/" Monad<Meta>])
+ (luxc ["&" base]
+ (lang ["la" analysis])))
+
+## The coverage of a pattern-matching expression summarizes how well
+## all the possible values of an input are being covered by the
+## different patterns involved.
+## Ideally, the pattern-matching has "exhaustive" coverage, which just
+## means that every possible value can be matched by at least 1
+## pattern.
+## Every other coverage is considered partial, and it would be valued
+## as insuficient (since it could lead to runtime errors due to values
+## not being handled by any pattern).
+## The #Partial tag covers arbitrary partial coverages in a general
+## way, while the other tags cover more specific cases for booleans
+## and variants.
+(type: #export #rec Coverage
+ #Partial
+ (#Bool Bool)
+ (#Variant Nat (Dict Nat Coverage))
+ (#Seq Coverage Coverage)
+ (#Alt Coverage Coverage)
+ #Exhaustive)
+
+(def: #export (exhaustive? coverage)
+ (-> Coverage Bool)
+ (case coverage
+ (#Exhaustive _)
+ true
+
+ _
+ false))
+
+(exception: #export Unknown-Pattern)
+
+(def: #export (determine pattern)
+ (-> la;Pattern (Meta Coverage))
+ (case pattern
+ ## Binding amounts to exhaustive coverage because any value can be
+ ## matched that way.
+ ## Unit [] amounts to exhaustive coverage because there is only one
+ ## possible value, so matching against it covers all cases.
+ (^or (^code ("lux case bind" (~ _))) (^code ("lux case tuple" [])))
+ (meta/wrap #Exhaustive)
+
+ (^code ("lux case tuple" [(~ singleton)]))
+ (determine singleton)
+
+ ## Primitive patterns always have partial coverage because there
+ ## are too many possibilities as far as values go.
+ (^or [_ (#;Nat _)] [_ (#;Int _)] [_ (#;Deg _)]
+ [_ (#;Frac _)] [_ (#;Text _)])
+ (meta/wrap #Partial)
+
+ ## Bools are the exception, since there is only "true" and
+ ## "false", which means it is possible for boolean
+ ## pattern-matching to become exhaustive if complementary parts meet.
+ [_ (#;Bool value)]
+ (meta/wrap (#Bool value))
+
+ ## Tuple patterns can be exhaustive if there is exhaustiveness for all of
+ ## their sub-patterns.
+ (^code ("lux case tuple" [(~@ subs)]))
+ (loop [subs subs]
+ (case subs
+ #;Nil
+ (meta/wrap #Exhaustive)
+
+ (#;Cons sub subs')
+ (do meta;Monad<Meta>
+ [pre (determine sub)
+ post (recur subs')]
+ (if (exhaustive? post)
+ (wrap pre)
+ (wrap (#Seq pre post))))))
+
+ ## Variant patterns can be shown to be exhaustive if all the possible
+ ## cases are handled exhaustively.
+ (^code ("lux case variant" (~ [_ (#;Nat tag-id)]) (~ [_ (#;Nat num-tags)]) (~ sub)))
+ (do meta;Monad<Meta>
+ [=sub (determine sub)]
+ (wrap (#Variant num-tags
+ (|> (dict;new number;Hash<Nat>)
+ (dict;put tag-id =sub)))))
+
+ _
+ (&;throw Unknown-Pattern (%code pattern))))
+
+(def: (xor left right)
+ (-> Bool Bool Bool)
+ (or (and left (not right))
+ (and (not left) right)))
+
+## The coverage checker not only verifies that pattern-matching is
+## exhaustive, but also that there are no redundant patterns.
+## Redundant patterns will never be executed, since there will
+## always be a pattern prior to them that would match the input.
+## Because of that, the presence of redundant patterns is assumed to
+## be a bug, likely due to programmer carelessness.
+(def: redundant-pattern
+ (e;Error Coverage)
+ (e;fail "Redundant pattern."))
+
+(def: (flatten-alt coverage)
+ (-> Coverage (List Coverage))
+ (case coverage
+ (#Alt left right)
+ (list& left (flatten-alt right))
+
+ _
+ (list coverage)))
+
+(struct: _ (Eq Coverage)
+ (def: (= reference sample)
+ (case [reference sample]
+ [#Exhaustive #Exhaustive]
+ true
+
+ [(#Bool sideR) (#Bool sideS)]
+ (bool/= sideR sideS)
+
+ [(#Variant allR casesR) (#Variant allS casesS)]
+ (and (n.= allR allS)
+ (:: (dict;Eq<Dict> =) = casesR casesS))
+
+ [(#Seq leftR rightR) (#Seq leftS rightS)]
+ (and (= leftR leftS)
+ (= rightR rightS))
+
+ [(#Alt _) (#Alt _)]
+ (let [flatR (flatten-alt reference)
+ flatS (flatten-alt sample)]
+ (and (n.= (list;size flatR) (list;size flatS))
+ (list;every? (function [[coverageR coverageS]]
+ (= coverageR coverageS))
+ (list;zip2 flatR flatS))))
+
+ _
+ false)))
+
+(open Eq<Coverage> "C/")
+
+## After determining the coverage of each individual pattern, it is
+## necessary to merge them all to figure out if the entire
+## pattern-matching expression is exhaustive and whether it contains
+## redundant patterns.
+(def: #export (merge addition so-far)
+ (-> Coverage Coverage (e;Error Coverage))
+ (case [addition so-far]
+ ## The addition cannot possibly improve the coverage.
+ [_ #Exhaustive]
+ redundant-pattern
+
+ ## The addition completes the coverage.
+ [#Exhaustive _]
+ (error/wrap #Exhaustive)
+
+ [#Partial #Partial]
+ (error/wrap #Partial)
+
+ ## 2 boolean coverages are exhaustive if they compliment one another.
+ (^multi [(#Bool sideA) (#Bool sideSF)]
+ (xor sideA sideSF))
+ (error/wrap #Exhaustive)
+
+ [(#Variant allA casesA) (#Variant allSF casesSF)]
+ (cond (not (n.= allSF allA))
+ (e;fail "Variants do not match.")
+
+ (:: (dict;Eq<Dict> Eq<Coverage>) = casesSF casesA)
+ redundant-pattern
+
+ ## else
+ (do e;Monad<Error>
+ [casesM (monad;fold @
+ (function [[tagA coverageA] casesSF']
+ (case (dict;get tagA casesSF')
+ (#;Some coverageSF)
+ (do @
+ [coverageM (merge coverageA coverageSF)]
+ (wrap (dict;put tagA coverageM casesSF')))
+
+ #;None
+ (wrap (dict;put tagA coverageA casesSF'))))
+ casesSF (dict;entries casesA))]
+ (wrap (if (let [case-coverages (dict;values casesM)]
+ (and (n.= allSF (list;size case-coverages))
+ (list;every? exhaustive? case-coverages)))
+ #Exhaustive
+ (#Variant allSF casesM)))))
+
+ [(#Seq leftA rightA) (#Seq leftSF rightSF)]
+ (case [(C/= leftSF leftA) (C/= rightSF rightA)]
+ ## There is nothing the addition adds to the coverage.
+ [true true]
+ redundant-pattern
+
+ ## The 2 sequences cannot possibly be merged.
+ [false false]
+ (error/wrap (#Alt so-far addition))
+
+ ## Same prefix
+ [true false]
+ (do e;Monad<Error>
+ [rightM (merge rightA rightSF)]
+ (if (exhaustive? rightM)
+ ## If all that follows is exhaustive, then it can be safely dropped
+ ## (since only the "left" part would influence whether the
+ ## merged coverage is exhaustive or not).
+ (wrap leftSF)
+ (wrap (#Seq leftSF rightM))))
+
+ ## Same suffix
+ [false true]
+ (do e;Monad<Error>
+ [leftM (merge leftA leftSF)]
+ (wrap (#Seq leftM rightA))))
+
+ ## The left part will always match, so the addition is redundant.
+ (^multi [(#Seq left right) single]
+ (C/= left single))
+ redundant-pattern
+
+ ## The right part is not necessary, since it can always match the left.
+ (^multi [single (#Seq left right)]
+ (C/= left single))
+ (error/wrap single)
+
+ ## When merging a new coverage against one based on Alt, it may be
+ ## that one of the many coverages in the Alt is complementary to
+ ## the new one, so effort must be made to fuse carefully, to match
+ ## the right coverages together.
+ ## If one of the Alt sub-coverages matches the new one, the cycle
+ ## must be repeated, in case the resulting coverage can now match
+ ## other ones in the original Alt.
+ ## This process must be repeated until no further productive
+ ## merges can be done.
+ [_ (#Alt leftS rightS)]
+ (do e;Monad<Error>
+ [#let [fuse-once (: (-> Coverage (List Coverage)
+ (e;Error [(Maybe Coverage)
+ (List Coverage)]))
+ (function [coverage possibilities]
+ (loop [alts possibilities]
+ (case alts
+ #;Nil
+ (wrap [#;None (list coverage)])
+
+ (#;Cons alt alts')
+ (case (merge coverage alt)
+ (#e;Success altM)
+ (case altM
+ (#Alt _)
+ (do @
+ [[success alts+] (recur alts')]
+ (wrap [success (#;Cons alt alts+)]))
+
+ _
+ (wrap [(#;Some altM) alts']))
+
+ (#e;Error error)
+ (e;fail error))
+ ))))]
+ [success possibilities] (fuse-once addition (flatten-alt so-far))]
+ (loop [success success
+ possibilities possibilities]
+ (case success
+ (#;Some coverage')
+ (do @
+ [[success' possibilities'] (fuse-once coverage' possibilities)]
+ (recur success' possibilities'))
+
+ #;None
+ (case (list;reverse possibilities)
+ (#;Cons last prevs)
+ (wrap (list/fold (function [left right] (#Alt left right))
+ last
+ prevs))
+
+ #;Nil
+ (undefined)))))
+
+ _
+ (if (C/= so-far addition)
+ ## The addition cannot possibly improve the coverage.
+ redundant-pattern
+ ## There are now 2 alternative paths.
+ (error/wrap (#Alt so-far addition)))))
diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux
new file mode 100644
index 000000000..4cbf5aedf
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/common.lux
@@ -0,0 +1,41 @@
+(;module:
+ lux
+ (lux (control monad
+ pipe)
+ (data text/format
+ [product])
+ [meta #+ Monad<Meta>]
+ (meta [type]
+ (type ["tc" check])))
+ (luxc ["&" base]
+ (lang analysis)))
+
+(def: #export (with-unknown-type action)
+ (All [a] (-> (Meta Analysis) (Meta [Type Analysis])))
+ (do Monad<Meta>
+ [[var-id var-type] (&;with-type-env
+ tc;create)
+ analysis (&;with-expected-type var-type
+ action)
+ analysis-type (&;with-type-env
+ (tc;clean var-id var-type))
+ _ (&;with-type-env
+ (tc;delete var-id))]
+ (wrap [analysis-type analysis])))
+
+(def: #export (with-var body)
+ (All [a] (-> (-> [Nat Type] (Meta a)) (Meta a)))
+ (do Monad<Meta>
+ [[id var] (&;with-type-env
+ tc;create)
+ output (body [id var])
+ _ (&;with-type-env
+ (tc;delete id))]
+ (wrap output)))
+
+(def: #export (variant-out-of-bounds-error type size tag)
+ (All [a] (-> Type Nat Nat (Meta a)))
+ (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n"
+ " Tag: " (%i (nat-to-int tag)) "\n"
+ "Size: " (%i (nat-to-int size)) "\n"
+ "Type: " (%type type))))
diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux
new file mode 100644
index 000000000..e3a623089
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/expression.lux
@@ -0,0 +1,141 @@
+(;module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data ["e" error]
+ [product]
+ text/format)
+ [meta]
+ (meta [type]
+ (type ["tc" check]))
+ [host])
+ (luxc ["&" base]
+ [";L" host]
+ (lang ["la" analysis])
+ ["&;" module]
+ (generator [";G" common]))
+ (.. [";A" common]
+ [";A" function]
+ [";A" primitive]
+ [";A" reference]
+ [";A" structure]
+ [";A" procedure]))
+
+(for {"JVM" (as-is (host;import java.lang.reflect.Method
+ (invoke [Object (Array Object)] #try Object))
+ (host;import (java.lang.Class c)
+ (getMethod [String (Array (Class Object))] #try Method))
+ (host;import java.lang.Object
+ (getClass [] (Class Object))
+ (toString [] String))
+ (def: _object-class (Class Object) (host;class-for Object))
+ (def: _apply-args
+ (Array (Class Object))
+ (|> (host;array (Class Object) +2)
+ (host;array-write +0 _object-class)
+ (host;array-write +1 _object-class)))
+ (def: (call-macro macro inputs)
+ (-> Macro (List Code) (Meta (List Code)))
+ (do meta;Monad<Meta>
+ [class (commonG;load-class hostL;function-class)]
+ (function [compiler]
+ (do e;Monad<Error>
+ [apply-method (Class.getMethod ["apply" _apply-args] class)
+ output (Method.invoke [(:! Object macro)
+ (|> (host;array Object +2)
+ (host;array-write +0 (:! Object inputs))
+ (host;array-write +1 (:! Object compiler)))]
+ apply-method)]
+ (:! (e;Error [Compiler (List Code)])
+ output))))))
+ })
+
+(exception: #export Macro-Expression-Must-Have-Single-Expansion)
+(exception: #export Unrecognized-Syntax)
+
+(def: #export (analyser eval)
+ (-> &;Eval &;Analyser)
+ (: (-> Code (Meta la;Analysis))
+ (function analyse [ast]
+ (do meta;Monad<Meta>
+ [expectedT meta;expected-type]
+ (let [[cursor ast'] ast]
+ ## The cursor must be set in the compiler for the sake
+ ## of having useful error messages.
+ (&;with-cursor cursor
+ (case ast'
+ (^template [<tag> <analyser>]
+ (<tag> value)
+ (<analyser> value))
+ ([#;Bool primitiveA;analyse-bool]
+ [#;Nat primitiveA;analyse-nat]
+ [#;Int primitiveA;analyse-int]
+ [#;Deg primitiveA;analyse-deg]
+ [#;Frac primitiveA;analyse-frac]
+ [#;Text primitiveA;analyse-text])
+
+ (^ (#;Tuple (list)))
+ primitiveA;analyse-unit
+
+ ## Singleton tuples are equivalent to the element they contain.
+ (^ (#;Tuple (list singleton)))
+ (analyse singleton)
+
+ (^ (#;Tuple elems))
+ (structureA;analyse-product analyse elems)
+
+ (^ (#;Record pairs))
+ (structureA;analyse-record analyse pairs)
+
+ (#;Symbol reference)
+ (referenceA;analyse-reference reference)
+
+ (^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
+ (procedureA;analyse-procedure analyse eval proc-name proc-args)
+
+ (^template [<tag> <analyser>]
+ (^ (#;Form (list& [_ (<tag> tag)]
+ values)))
+ (case values
+ (#;Cons value #;Nil)
+ (<analyser> analyse tag value)
+
+ _
+ (<analyser> analyse tag (` [(~@ values)]))))
+ ([#;Nat structureA;analyse-sum]
+ [#;Tag structureA;analyse-tagged-sum])
+
+ (#;Tag tag)
+ (structureA;analyse-tagged-sum analyse tag (' []))
+
+ (^ (#;Form (list& func args)))
+ (do meta;Monad<Meta>
+ [[funcT =func] (commonA;with-unknown-type
+ (analyse func))]
+ (case =func
+ [_ (#;Symbol def-name)]
+ (do @
+ [[def-type def-anns def-value] (meta;find-def def-name)]
+ (if (meta;macro? def-anns)
+ (do @
+ [expansion (function [compiler]
+ (case (call-macro (:! Macro def-value) args compiler)
+ (#e;Success [compiler' output])
+ (#e;Success [compiler' output])
+
+ (#e;Error error)
+ ((&;fail error) compiler)))]
+ (case expansion
+ (^ (list single))
+ (analyse single)
+
+ _
+ (&;throw Macro-Expression-Must-Have-Single-Expansion (%code ast))))
+ (functionA;analyse-apply analyse funcT =func args)))
+
+ _
+ (functionA;analyse-apply analyse funcT =func args)))
+
+ _
+ (&;throw Unrecognized-Syntax (%code ast))
+ )))))))
diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux
new file mode 100644
index 000000000..627fb7c0a
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/function.lux
@@ -0,0 +1,111 @@
+(;module:
+ lux
+ (lux (control monad
+ ["ex" exception #+ exception:])
+ (data [maybe]
+ [text]
+ text/format
+ (coll [list "list/" Fold<List> Monoid<List> Monad<List>]))
+ [meta]
+ (meta [code]
+ [type]
+ (type ["tc" check])))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis]
+ (analysis ["&;" common]
+ ["&;" inference])
+ [";L" variable #+ Variable])
+ ["&;" scope]))
+
+(exception: #export Invalid-Function-Type)
+(exception: #export Cannot-Apply-Function)
+
+## [Analysers]
+(def: #export (analyse-function analyse func-name arg-name body)
+ (-> &;Analyser Text Text Code (Meta Analysis))
+ (do meta;Monad<Meta>
+ [functionT meta;expected-type]
+ (loop [expectedT functionT]
+ (&;with-stacked-errors
+ (function [_] (Invalid-Function-Type (%type expectedT)))
+ (case expectedT
+ (#;Named name unnamedT)
+ (recur unnamedT)
+
+ (#;Apply argT funT)
+ (case (type;apply (list argT) funT)
+ (#;Some value)
+ (recur value)
+
+ #;None
+ (&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT))))
+
+ (#;UnivQ _)
+ (do @
+ [[var-id var] (&;with-type-env
+ tc;existential)]
+ (recur (maybe;assume (type;apply (list var) expectedT))))
+
+ (#;ExQ _)
+ (&common;with-var
+ (function [[var-id var]]
+ (recur (maybe;assume (type;apply (list var) expectedT)))))
+
+ (#;Var id)
+ (do @
+ [? (&;with-type-env
+ (tc;concrete? id))]
+ (if ?
+ (do @
+ [expectedT' (&;with-type-env
+ (tc;read id))]
+ (recur expectedT'))
+ ## Inference
+ (&common;with-var
+ (function [[input-id inputT]]
+ (&common;with-var
+ (function [[output-id outputT]]
+ (do @
+ [#let [funT (#;Function inputT outputT)]
+ funA (recur funT)
+ funT' (&;with-type-env
+ (tc;clean output-id funT))
+ concrete-input? (&;with-type-env
+ (tc;concrete? input-id))
+ funT'' (if concrete-input?
+ (&;with-type-env
+ (tc;clean input-id funT'))
+ (wrap (type;univ-q +1 (&inference;replace-var input-id +1 funT'))))
+ _ (&;with-type-env
+ (tc;check expectedT funT''))]
+ (wrap funA))
+ ))))))
+
+ (#;Function inputT outputT)
+ (<| (:: @ map (function [[scope bodyA]]
+ (` ("lux function" [(~@ (list/map code;int (variableL;environment scope)))]
+ (~ bodyA)))))
+ &;with-scope
+ ## Functions have access not only to their argument, but
+ ## also to themselves, through a local variable.
+ (&scope;with-local [func-name expectedT])
+ (&scope;with-local [arg-name inputT])
+ (&;with-expected-type outputT)
+ (analyse body))
+
+ _
+ (&;fail "")
+ )))))
+
+(def: #export (analyse-apply analyse funcT funcA args)
+ (-> &;Analyser Type Analysis (List Code) (Meta Analysis))
+ (&;with-stacked-errors
+ (function [_]
+ (Cannot-Apply-Function (format " Function: " (%type funcT) "\n"
+ "Arguments: " (|> args (list/map %code) (text;join-with " ")))))
+ (do meta;Monad<Meta>
+ [expected meta;expected-type
+ [applyT argsA] (&inference;apply-function analyse funcT args)
+ _ (&;with-type-env
+ (tc;check expected applyT))]
+ (wrap (la;apply argsA funcA)))))
diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux
new file mode 100644
index 000000000..cd484a623
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/inference.lux
@@ -0,0 +1,228 @@
+(;module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data [maybe]
+ [text]
+ text/format
+ (coll [list "list/" Functor<List>]))
+ [meta #+ Monad<Meta>]
+ (meta [type]
+ (type ["tc" check])))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis]
+ (analysis ["&;" common]))))
+
+(exception: #export Cannot-Infer)
+(exception: #export Cannot-Infer-Argument)
+(exception: #export Smaller-Variant-Than-Expected)
+
+## When doing inference, type-variables often need to be created in
+## order to figure out which types are present in the expression being
+## inferred.
+## If a type-variable never gets bound/resolved to a type, then that
+## means the expression can be generalized through universal
+## quantification.
+## When that happens, the type-variable must be replaced by an
+## argument to the universally-quantified type.
+(def: #export (replace-var var-id bound-idx type)
+ (-> Nat Nat Type Type)
+ (case type
+ (#;Primitive name params)
+ (#;Primitive name (list/map (replace-var var-id bound-idx) params))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (<tag> (replace-var var-id bound-idx left)
+ (replace-var var-id bound-idx right)))
+ ([#;Sum]
+ [#;Product]
+ [#;Function]
+ [#;Apply])
+
+ (#;Var id)
+ (if (n.= var-id id)
+ (#;Bound bound-idx)
+ type)
+
+ (^template [<tag>]
+ (<tag> env quantified)
+ (<tag> (list/map (replace-var var-id bound-idx) env)
+ (replace-var var-id (n.+ +2 bound-idx) quantified)))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ _
+ type))
+
+(def: (replace-bound bound-idx replacementT type)
+ (-> Nat Type Type Type)
+ (case type
+ (#;Primitive name params)
+ (#;Primitive name (list/map (replace-bound bound-idx replacementT) params))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (<tag> (replace-bound bound-idx replacementT left)
+ (replace-bound bound-idx replacementT right)))
+ ([#;Sum]
+ [#;Product]
+ [#;Function]
+ [#;Apply])
+
+ (#;Bound idx)
+ (if (n.= bound-idx idx)
+ replacementT
+ type)
+
+ (^template [<tag>]
+ (<tag> env quantified)
+ (<tag> (list/map (replace-bound bound-idx replacementT) env)
+ (replace-bound (n.+ +2 bound-idx) replacementT quantified)))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ _
+ type))
+
+## Type-inference works by applying some (potentially quantified) type
+## to a sequence of values.
+## Function types are used for this, although inference is not always
+## done for function application (alternative uses may be records and
+## tagged variants).
+## But, so long as the type being used for the inference can be trated
+## as a function type, this method of inference should work.
+(def: #export (apply-function analyse funcT args)
+ (-> &;Analyser Type (List Code) (Meta [Type (List Analysis)]))
+ (case args
+ #;Nil
+ (:: Monad<Meta> wrap [funcT (list)])
+
+ (#;Cons argC args')
+ (case funcT
+ (#;Named name unnamedT)
+ (apply-function analyse unnamedT args)
+
+ (#;UnivQ _)
+ (&common;with-var
+ (function [[var-id varT]]
+ (do Monad<Meta>
+ [[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) funcT)) args)]
+ (do @
+ [? (&;with-type-env
+ (tc;bound? var-id))
+ ## Quantify over the type if genericity/parametricity
+ ## is discovered.
+ outputT' (if ?
+ (&;with-type-env
+ (tc;clean var-id outputT))
+ (wrap (type;univ-q +1 (replace-var var-id +1 outputT))))]
+ (wrap [outputT' argsA])))))
+
+ (#;ExQ _)
+ (do Monad<Meta>
+ [[ex-id exT] (&;with-type-env
+ tc;existential)]
+ (apply-function analyse (maybe;assume (type;apply (list exT) funcT)) args))
+
+ ## Arguments are inferred back-to-front because, by convention,
+ ## Lux functions take the most important arguments *last*, which
+ ## means that the most information for doing proper inference is
+ ## located in the last arguments to a function call.
+ ## By inferring back-to-front, a lot of type-annotations can be
+ ## avoided in Lux code, since the inference algorithm can piece
+ ## things together more easily.
+ (#;Function inputT outputT)
+ (do Monad<Meta>
+ [[outputT' args'A] (apply-function analyse outputT args')
+ argA (&;with-stacked-errors
+ (function [_] (Cannot-Infer-Argument
+ (format "Inferred Type: " (%type inputT) "\n"
+ " Argument: " (%code argC))))
+ (&;with-expected-type inputT
+ (analyse argC)))]
+ (wrap [outputT' (list& argA args'A)]))
+
+ _
+ (&;throw Cannot-Infer (format "Inference Type: " (%type funcT)
+ " Arguments: " (|> args (list/map %code) (text;join-with " ")))))
+ ))
+
+## Turns a record type into the kind of function type suitable for inference.
+(def: #export (record type)
+ (-> Type (Meta Type))
+ (case type
+ (#;Named name unnamedT)
+ (do Monad<Meta>
+ [unnamedT+ (record unnamedT)]
+ (wrap unnamedT+))
+
+ (^template [<tag>]
+ (<tag> env bodyT)
+ (do Monad<Meta>
+ [bodyT+ (record bodyT)]
+ (wrap (<tag> env bodyT+))))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ (#;Product _)
+ (:: Monad<Meta> wrap (type;function (type;flatten-tuple type) type))
+
+ _
+ (&;fail (format "Not a record type: " (%type type)))))
+
+## Turns a variant type into the kind of function type suitable for inference.
+(def: #export (variant tag expected-size type)
+ (-> Nat Nat Type (Meta Type))
+ (loop [depth +0
+ currentT type]
+ (case currentT
+ (#;Named name unnamedT)
+ (do Monad<Meta>
+ [unnamedT+ (recur depth unnamedT)]
+ (wrap unnamedT+))
+
+ (^template [<tag>]
+ (<tag> env bodyT)
+ (do Monad<Meta>
+ [bodyT+ (recur (n.inc depth) bodyT)]
+ (wrap (<tag> env bodyT+))))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ (#;Sum _)
+ (let [cases (type;flatten-variant currentT)
+ actual-size (list;size cases)
+ boundary (n.dec expected-size)]
+ (cond (or (n.= expected-size actual-size)
+ (and (n.> expected-size actual-size)
+ (n.< boundary tag)))
+ (case (list;nth tag cases)
+ (#;Some caseT)
+ (:: Monad<Meta> wrap (if (n.= +0 depth)
+ (type;function (list caseT) currentT)
+ (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
+ (type;function (list (replace! caseT))
+ (replace! currentT)))))
+
+ #;None
+ (&common;variant-out-of-bounds-error type expected-size tag))
+
+ (n.< expected-size actual-size)
+ (&;throw Smaller-Variant-Than-Expected
+ (format "Expected: " (%i (nat-to-int expected-size)) "\n"
+ " Actual: " (%i (nat-to-int actual-size))))
+
+ (n.= boundary tag)
+ (let [caseT (type;variant (list;drop boundary cases))]
+ (:: Monad<Meta> wrap (if (n.= +0 depth)
+ (type;function (list caseT) currentT)
+ (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
+ (type;function (list (replace! caseT))
+ (replace! currentT))))))
+
+ ## else
+ (&common;variant-out-of-bounds-error type expected-size tag)))
+
+ _
+ (&;fail (format "Not a variant type: " (%type type))))))
diff --git a/new-luxc/source/luxc/lang/analysis/primitive.lux b/new-luxc/source/luxc/lang/analysis/primitive.lux
new file mode 100644
index 000000000..c7f7243fd
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/primitive.lux
@@ -0,0 +1,34 @@
+(;module:
+ lux
+ (lux (control monad)
+ [meta]
+ (meta [code]
+ (type ["tc" check])))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis])))
+
+## [Analysers]
+(do-template [<name> <type> <tag>]
+ [(def: #export (<name> value)
+ (-> <type> (Meta Analysis))
+ (do meta;Monad<Meta>
+ [expected meta;expected-type
+ _ (&;with-type-env
+ (tc;check expected <type>))]
+ (wrap (<tag> value))))]
+
+ [analyse-bool Bool code;bool]
+ [analyse-nat Nat code;nat]
+ [analyse-int Int code;int]
+ [analyse-deg Deg code;deg]
+ [analyse-frac Frac code;frac]
+ [analyse-text Text code;text]
+ )
+
+(def: #export analyse-unit
+ (Meta Analysis)
+ (do meta;Monad<Meta>
+ [expected meta;expected-type
+ _ (&;with-type-env
+ (tc;check expected Unit))]
+ (wrap (` []))))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure.lux b/new-luxc/source/luxc/lang/analysis/procedure.lux
new file mode 100644
index 000000000..225fb7b23
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/procedure.lux
@@ -0,0 +1,23 @@
+(;module:
+ lux
+ (lux (control [monad #+ do])
+ (data [maybe]
+ [text]
+ text/format
+ (coll [dict])))
+ (luxc ["&" base]
+ (lang ["la" analysis]))
+ (. ["./;" common]
+ ["./;" host]))
+
+(def: procedures
+ ./common;Bundle
+ (|> ./common;procedures
+ (dict;merge ./host;procedures)))
+
+(def: #export (analyse-procedure analyse eval proc-name proc-args)
+ (-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis))
+ (<| (maybe;default (&;fail (format "Unknown procedure: " (%t proc-name))))
+ (do maybe;Monad<Maybe>
+ [proc (dict;get proc-name procedures)]
+ (wrap (proc analyse eval proc-args)))))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
new file mode 100644
index 000000000..e06a3d2b4
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
@@ -0,0 +1,418 @@
+(;module:
+ lux
+ (lux (control [monad #+ do])
+ (concurrency ["A" atom])
+ (data [text]
+ text/format
+ (coll [list "list/" Functor<List>]
+ [array]
+ [dict #+ Dict]))
+ [meta]
+ (meta [code]
+ (type ["tc" check]))
+ [io])
+ (luxc ["&" base]
+ (lang ["la" analysis]
+ (analysis ["&;" common]
+ [";A" function]
+ [";A" case]
+ [";A" type]))))
+
+## [Utils]
+(type: #export Proc
+ (-> &;Analyser &;Eval (List Code) (Meta la;Analysis)))
+
+(type: #export Bundle
+ (Dict Text Proc))
+
+(def: #export (install name unnamed)
+ (-> Text (-> Text Proc)
+ (-> Bundle Bundle))
+ (dict;put name (unnamed name)))
+
+(def: #export (prefix prefix bundle)
+ (-> Text Bundle Bundle)
+ (|> bundle
+ dict;entries
+ (list/map (function [[key val]] [(format prefix " " key) val]))
+ (dict;from-list text;Hash<Text>)))
+
+(def: #export (wrong-arity proc expected actual)
+ (-> Text Nat Nat Text)
+ (format "Wrong arity for " (%t proc) "\n"
+ "Expected: " (|> expected nat-to-int %i) "\n"
+ " Actual: " (|> actual nat-to-int %i)))
+
+(def: (simple proc input-types output-type)
+ (-> Text (List Type) Type Proc)
+ (let [num-expected (list;size input-types)]
+ (function [analyse eval args]
+ (let [num-actual (list;size args)]
+ (if (n.= num-expected num-actual)
+ (do meta;Monad<Meta>
+ [argsA (monad;map @
+ (function [[argT argC]]
+ (&;with-expected-type argT
+ (analyse argC)))
+ (list;zip2 input-types args))
+ expected meta;expected-type
+ _ (&;with-type-env
+ (tc;check expected output-type))]
+ (wrap (la;procedure proc argsA)))
+ (&;fail (wrong-arity proc num-expected num-actual)))))))
+
+(def: #export (nullary valueT proc)
+ (-> Type Text Proc)
+ (simple proc (list) valueT))
+
+(def: #export (unary inputT outputT proc)
+ (-> Type Type Text Proc)
+ (simple proc (list inputT) outputT))
+
+(def: #export (binary subjectT paramT outputT proc)
+ (-> Type Type Type Text Proc)
+ (simple proc (list subjectT paramT) outputT))
+
+(def: #export (trinary subjectT param0T param1T outputT proc)
+ (-> Type Type Type Type Text Proc)
+ (simple proc (list subjectT param0T param1T) outputT))
+
+## [Analysers]
+## "lux is" represents reference/pointer equality.
+(def: (lux-is proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ ((binary varT varT Bool proc)
+ analyse eval args)))))
+
+## "lux try" provides a simple way to interact with the host platform's
+## error-handling facilities.
+(def: (lux-try proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list opC))
+ (do meta;Monad<Meta>
+ [opA (&;with-expected-type (type (io;IO varT))
+ (analyse opC))
+ outputT (&;with-type-env
+ (tc;clean var-id (type (Either Text varT))))
+ expected meta;expected-type
+ _ (&;with-type-env
+ (tc;check expected outputT))]
+ (wrap (la;procedure proc (list opA))))
+
+ _
+ (&;fail (wrong-arity proc +1 (list;size args))))))))
+
+(def: (lux//function proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list [_ (#;Symbol ["" func-name])]
+ [_ (#;Symbol ["" arg-name])]
+ body))
+ (functionA;analyse-function analyse func-name arg-name body)
+
+ _
+ (&;fail (wrong-arity proc +3 (list;size args))))))))
+
+(def: (lux//case proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list input [_ (#;Record branches)]))
+ (caseA;analyse-case analyse input branches)
+
+ _
+ (&;fail (wrong-arity proc +2 (list;size args))))))))
+
+(do-template [<name> <analyser>]
+ [(def: (<name> proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list typeC valueC))
+ (<analyser> analyse eval typeC valueC)
+
+ _
+ (&;fail (wrong-arity proc +2 (list;size args))))))))]
+
+ [lux//check typeA;analyse-check]
+ [lux//coerce typeA;analyse-coerce])
+
+(def: (lux//check//type proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (case args
+ (^ (list valueC))
+ (do meta;Monad<Meta>
+ [valueA (&;with-expected-type Type
+ (analyse valueC))
+ expected meta;expected-type
+ _ (&;with-type-env
+ (tc;check expected Type))]
+ (wrap valueA))
+
+ _
+ (&;fail (wrong-arity proc +1 (list;size args))))))
+
+(def: lux-procs
+ Bundle
+ (|> (dict;new text;Hash<Text>)
+ (install "is" lux-is)
+ (install "try" lux-try)
+ (install "function" lux//function)
+ (install "case" lux//case)
+ (install "check" lux//check)
+ (install "coerce" lux//coerce)
+ (install "check type" lux//check//type)))
+
+(def: io-procs
+ Bundle
+ (<| (prefix "io")
+ (|> (dict;new text;Hash<Text>)
+ (install "log" (unary Text Unit))
+ (install "error" (unary Text Bottom))
+ (install "exit" (unary Nat Bottom))
+ (install "current-time" (nullary Int)))))
+
+(def: bit-procs
+ Bundle
+ (<| (prefix "bit")
+ (|> (dict;new text;Hash<Text>)
+ (install "count" (unary Nat Nat))
+ (install "and" (binary Nat Nat Nat))
+ (install "or" (binary Nat Nat Nat))
+ (install "xor" (binary Nat Nat Nat))
+ (install "shift-left" (binary Nat Nat Nat))
+ (install "unsigned-shift-right" (binary Nat Nat Nat))
+ (install "shift-right" (binary Int Nat Int))
+ )))
+
+(def: nat-procs
+ Bundle
+ (<| (prefix "nat")
+ (|> (dict;new text;Hash<Text>)
+ (install "+" (binary Nat Nat Nat))
+ (install "-" (binary Nat Nat Nat))
+ (install "*" (binary Nat Nat Nat))
+ (install "/" (binary Nat Nat Nat))
+ (install "%" (binary Nat Nat Nat))
+ (install "=" (binary Nat Nat Bool))
+ (install "<" (binary Nat Nat Bool))
+ (install "min" (nullary Nat))
+ (install "max" (nullary Nat))
+ (install "to-int" (unary Nat Int))
+ (install "to-text" (unary Nat Text)))))
+
+(def: int-procs
+ Bundle
+ (<| (prefix "int")
+ (|> (dict;new text;Hash<Text>)
+ (install "+" (binary Int Int Int))
+ (install "-" (binary Int Int Int))
+ (install "*" (binary Int Int Int))
+ (install "/" (binary Int Int Int))
+ (install "%" (binary Int Int Int))
+ (install "=" (binary Int Int Bool))
+ (install "<" (binary Int Int Bool))
+ (install "min" (nullary Int))
+ (install "max" (nullary Int))
+ (install "to-nat" (unary Int Nat))
+ (install "to-frac" (unary Int Frac)))))
+
+(def: deg-procs
+ Bundle
+ (<| (prefix "deg")
+ (|> (dict;new text;Hash<Text>)
+ (install "+" (binary Deg Deg Deg))
+ (install "-" (binary Deg Deg Deg))
+ (install "*" (binary Deg Deg Deg))
+ (install "/" (binary Deg Deg Deg))
+ (install "%" (binary Deg Deg Deg))
+ (install "=" (binary Deg Deg Bool))
+ (install "<" (binary Deg Deg Bool))
+ (install "scale" (binary Deg Nat Deg))
+ (install "reciprocal" (binary Deg Nat Deg))
+ (install "min" (nullary Deg))
+ (install "max" (nullary Deg))
+ (install "to-frac" (unary Deg Frac)))))
+
+(def: frac-procs
+ Bundle
+ (<| (prefix "frac")
+ (|> (dict;new text;Hash<Text>)
+ (install "+" (binary Frac Frac Frac))
+ (install "-" (binary Frac Frac Frac))
+ (install "*" (binary Frac Frac Frac))
+ (install "/" (binary Frac Frac Frac))
+ (install "%" (binary Frac Frac Frac))
+ (install "=" (binary Frac Frac Bool))
+ (install "<" (binary Frac Frac Bool))
+ (install "smallest" (nullary Frac))
+ (install "min" (nullary Frac))
+ (install "max" (nullary Frac))
+ (install "not-a-number" (nullary Frac))
+ (install "positive-infinity" (nullary Frac))
+ (install "negative-infinity" (nullary Frac))
+ (install "to-deg" (unary Frac Deg))
+ (install "to-int" (unary Frac Int))
+ (install "encode" (unary Frac Text))
+ (install "decode" (unary Text (type (Maybe Frac)))))))
+
+(def: text-procs
+ Bundle
+ (<| (prefix "text")
+ (|> (dict;new text;Hash<Text>)
+ (install "=" (binary Text Text Bool))
+ (install "<" (binary Text Text Bool))
+ (install "prepend" (binary Text Text Text))
+ (install "index" (trinary Text Text Nat (type (Maybe Nat))))
+ (install "size" (unary Text Nat))
+ (install "hash" (unary Text Nat))
+ (install "replace-once" (trinary Text Text Text Text))
+ (install "replace-all" (trinary Text Text Text Text))
+ (install "char" (binary Text Nat Nat))
+ (install "clip" (trinary Text Nat Nat Text))
+ )))
+
+(def: (array-get proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ ((binary Nat (type (Array varT)) varT proc)
+ analyse eval args)))))
+
+(def: (array-put proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc)
+ analyse eval args)))))
+
+(def: (array-remove proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ ((binary Nat (type (Array varT)) (type (Array varT)) proc)
+ analyse eval args)))))
+
+(def: array-procs
+ Bundle
+ (<| (prefix "array")
+ (|> (dict;new text;Hash<Text>)
+ (install "new" (unary Nat Array))
+ (install "get" array-get)
+ (install "put" array-put)
+ (install "remove" array-remove)
+ (install "size" (unary (type (Ex [a] (Array a))) Nat))
+ )))
+
+(def: math-procs
+ Bundle
+ (<| (prefix "math")
+ (|> (dict;new text;Hash<Text>)
+ (install "cos" (unary Frac Frac))
+ (install "sin" (unary Frac Frac))
+ (install "tan" (unary Frac Frac))
+ (install "acos" (unary Frac Frac))
+ (install "asin" (unary Frac Frac))
+ (install "atan" (unary Frac Frac))
+ (install "cosh" (unary Frac Frac))
+ (install "sinh" (unary Frac Frac))
+ (install "tanh" (unary Frac Frac))
+ (install "exp" (unary Frac Frac))
+ (install "log" (unary Frac Frac))
+ (install "root2" (unary Frac Frac))
+ (install "root3" (unary Frac Frac))
+ (install "ceil" (unary Frac Frac))
+ (install "floor" (unary Frac Frac))
+ (install "round" (unary Frac Frac))
+ (install "atan2" (binary Frac Frac Frac))
+ (install "pow" (binary Frac Frac Frac))
+ )))
+
+(def: (atom-new proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list initC))
+ (do meta;Monad<Meta>
+ [initA (&;with-expected-type varT
+ (analyse initC))
+ outputT (&;with-type-env
+ (tc;clean var-id (type (A;Atom varT))))
+ expected meta;expected-type
+ _ (&;with-type-env
+ (tc;check expected outputT))]
+ (wrap (la;procedure proc (list initA))))
+
+ _
+ (&;fail (wrong-arity proc +1 (list;size args))))))))
+
+(def: (atom-read proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ ((unary (type (A;Atom varT)) varT proc)
+ analyse eval args)))))
+
+(def: (atom-compare-and-swap proc)
+ (-> Text Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ ((trinary varT varT (type (A;Atom varT)) Bool proc)
+ analyse eval args)))))
+
+(def: atom-procs
+ Bundle
+ (<| (prefix "atom")
+ (|> (dict;new text;Hash<Text>)
+ (install "new" atom-new)
+ (install "read" atom-read)
+ (install "compare-and-swap" atom-compare-and-swap)
+ )))
+
+(def: process-procs
+ Bundle
+ (<| (prefix "process")
+ (|> (dict;new text;Hash<Text>)
+ (install "concurrency-level" (nullary Nat))
+ (install "future" (unary (type (io;IO Top)) Unit))
+ (install "schedule" (binary Nat (type (io;IO Top)) Unit))
+ )))
+
+(def: #export procedures
+ Bundle
+ (<| (prefix "lux")
+ (|> (dict;new text;Hash<Text>)
+ (dict;merge lux-procs)
+ (dict;merge bit-procs)
+ (dict;merge nat-procs)
+ (dict;merge int-procs)
+ (dict;merge deg-procs)
+ (dict;merge frac-procs)
+ (dict;merge text-procs)
+ (dict;merge array-procs)
+ (dict;merge math-procs)
+ (dict;merge atom-procs)
+ (dict;merge process-procs)
+ (dict;merge io-procs))))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
new file mode 100644
index 000000000..3ba7713ac
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
@@ -0,0 +1,1241 @@
+(;module:
+ [lux #- char]
+ (lux (control [monad #+ do]
+ ["p" parser]
+ ["ex" exception #+ exception:])
+ (concurrency ["A" atom])
+ (data ["e" error]
+ [maybe]
+ [product]
+ [bool "bool/" Eq<Bool>]
+ [text "text/" Eq<Text>]
+ (text format
+ ["l" lexer])
+ (coll [list "list/" Fold<List> Functor<List> Monoid<List>]
+ [array]
+ [dict #+ Dict]))
+ [meta "meta/" Monad<Meta>]
+ (meta [code]
+ ["s" syntax]
+ [type]
+ (type ["tc" check]))
+ [host])
+ (luxc ["&" base]
+ ["&;" host]
+ (lang ["la" analysis]
+ (analysis ["&;" common]
+ ["&;" inference])))
+ ["@" ../common]
+ )
+
+(def: #export null-class Text "#Null")
+
+(do-template [<name> <class>]
+ [(def: #export <name> Type (#;Primitive <class> (list)))]
+
+ ## Boxes
+ [Boolean "java.lang.Boolean"]
+ [Byte "java.lang.Byte"]
+ [Short "java.lang.Short"]
+ [Integer "java.lang.Integer"]
+ [Long "java.lang.Long"]
+ [Float "java.lang.Float"]
+ [Double "java.lang.Double"]
+ [Character "java.lang.Character"]
+ [String "java.lang.String"]
+
+ ## Primitives
+ [boolean "boolean"]
+ [byte "byte"]
+ [short "short"]
+ [int "int"]
+ [long "long"]
+ [float "float"]
+ [double "double"]
+ [char "char"]
+ )
+
+(def: conversion-procs
+ @;Bundle
+ (<| (@;prefix "convert")
+ (|> (dict;new text;Hash<Text>)
+ (@;install "double-to-float" (@;unary Double Float))
+ (@;install "double-to-int" (@;unary Double Integer))
+ (@;install "double-to-long" (@;unary Double Long))
+ (@;install "float-to-double" (@;unary Float Double))
+ (@;install "float-to-int" (@;unary Float Integer))
+ (@;install "float-to-long" (@;unary Float Long))
+ (@;install "int-to-byte" (@;unary Integer Byte))
+ (@;install "int-to-char" (@;unary Integer Character))
+ (@;install "int-to-double" (@;unary Integer Double))
+ (@;install "int-to-float" (@;unary Integer Float))
+ (@;install "int-to-long" (@;unary Integer Long))
+ (@;install "int-to-short" (@;unary Integer Short))
+ (@;install "long-to-double" (@;unary Long Double))
+ (@;install "long-to-float" (@;unary Long Float))
+ (@;install "long-to-int" (@;unary Long Integer))
+ (@;install "long-to-short" (@;unary Long Short))
+ (@;install "long-to-byte" (@;unary Long Byte))
+ (@;install "char-to-byte" (@;unary Character Byte))
+ (@;install "char-to-short" (@;unary Character Short))
+ (@;install "char-to-int" (@;unary Character Integer))
+ (@;install "char-to-long" (@;unary Character Long))
+ (@;install "byte-to-long" (@;unary Byte Long))
+ (@;install "short-to-long" (@;unary Short Long))
+ )))
+
+(do-template [<name> <prefix> <type>]
+ [(def: <name>
+ @;Bundle
+ (<| (@;prefix <prefix>)
+ (|> (dict;new text;Hash<Text>)
+ (@;install "+" (@;binary <type> <type> <type>))
+ (@;install "-" (@;binary <type> <type> <type>))
+ (@;install "*" (@;binary <type> <type> <type>))
+ (@;install "/" (@;binary <type> <type> <type>))
+ (@;install "%" (@;binary <type> <type> <type>))
+ (@;install "=" (@;binary <type> <type> Boolean))
+ (@;install "<" (@;binary <type> <type> Boolean))
+ (@;install "and" (@;binary <type> <type> <type>))
+ (@;install "or" (@;binary <type> <type> <type>))
+ (@;install "xor" (@;binary <type> <type> <type>))
+ (@;install "shl" (@;binary <type> Integer <type>))
+ (@;install "shr" (@;binary <type> Integer <type>))
+ (@;install "ushr" (@;binary <type> Integer <type>))
+ )))]
+
+ [int-procs "int" Integer]
+ [long-procs "long" Long]
+ )
+
+(do-template [<name> <prefix> <type>]
+ [(def: <name>
+ @;Bundle
+ (<| (@;prefix <prefix>)
+ (|> (dict;new text;Hash<Text>)
+ (@;install "+" (@;binary <type> <type> <type>))
+ (@;install "-" (@;binary <type> <type> <type>))
+ (@;install "*" (@;binary <type> <type> <type>))
+ (@;install "/" (@;binary <type> <type> <type>))
+ (@;install "%" (@;binary <type> <type> <type>))
+ (@;install "=" (@;binary <type> <type> Boolean))
+ (@;install "<" (@;binary <type> <type> Boolean))
+ )))]
+
+ [float-procs "float" Float]
+ [double-procs "double" Double]
+ )
+
+(def: char-procs
+ @;Bundle
+ (<| (@;prefix "char")
+ (|> (dict;new text;Hash<Text>)
+ (@;install "=" (@;binary Character Character Boolean))
+ (@;install "<" (@;binary Character Character Boolean))
+ )))
+
+(def: #export boxes
+ (Dict Text Text)
+ (|> (list ["boolean" "java.lang.Boolean"]
+ ["byte" "java.lang.Byte"]
+ ["short" "java.lang.Short"]
+ ["int" "java.lang.Integer"]
+ ["long" "java.lang.Long"]
+ ["float" "java.lang.Float"]
+ ["double" "java.lang.Double"]
+ ["char" "java.lang.Character"])
+ (dict;from-list text;Hash<Text>)))
+
+(def: (array-length proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list arrayC))
+ (do meta;Monad<Meta>
+ [arrayA (&;with-expected-type (type (Array varT))
+ (analyse arrayC))
+ _ (&;infer Nat)]
+ (wrap (la;procedure proc (list arrayA))))
+
+ _
+ (&;fail (@;wrong-arity proc +1 (list;size args))))))))
+
+(def: (invalid-array-type arrayT)
+ (-> Type Text)
+ (format "Invalid type for array: " (%type arrayT)))
+
+(def: (array-new proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case args
+ (^ (list lengthC))
+ (do meta;Monad<Meta>
+ [lengthA (&;with-expected-type Nat
+ (analyse lengthC))
+ expectedT meta;expected-type
+ [level elem-class] (: (Meta [Nat Text])
+ (loop [analysisT expectedT
+ level +0]
+ (case analysisT
+ (#;Apply inputT funcT)
+ (case (type;apply (list inputT) funcT)
+ (#;Some outputT)
+ (recur outputT level)
+
+ #;None
+ (&;fail (invalid-array-type expectedT)))
+
+ (^ (#;Primitive "#Array" (list elemT)))
+ (recur elemT (n.inc level))
+
+ (#;Primitive class _)
+ (wrap [level class])
+
+ _
+ (&;fail (invalid-array-type expectedT)))))
+ _ (&;assert "Must have at least 1 level of nesting in array type."
+ (n.> +0 level))]
+ (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA))))
+
+ _
+ (&;fail (@;wrong-arity proc +1 (list;size args))))))
+
+(exception: #export Not-Object-Type)
+
+(def: (check-jvm objectT)
+ (-> Type (Meta Text))
+ (case objectT
+ (#;Primitive name _)
+ (meta/wrap name)
+
+ (#;Named name unnamed)
+ (check-jvm unnamed)
+
+ (#;Var id)
+ (meta/wrap "java.lang.Object")
+
+ (^template [<tag>]
+ (<tag> env unquantified)
+ (check-jvm unquantified))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ (#;Apply inputT funcT)
+ (case (type;apply (list inputT) funcT)
+ (#;Some outputT)
+ (check-jvm outputT)
+
+ #;None
+ (&;throw Not-Object-Type (%type objectT)))
+
+ _
+ (&;throw Not-Object-Type (%type objectT))))
+
+(def: (check-object objectT)
+ (-> Type (Meta Text))
+ (do meta;Monad<Meta>
+ [name (check-jvm objectT)]
+ (if (dict;contains? name boxes)
+ (&;fail (format "Primitives are not objects: " name))
+ (:: meta;Monad<Meta> wrap name))))
+
+(def: (box-array-element-type elemT)
+ (-> Type (Meta [Type Text]))
+ (do meta;Monad<Meta>
+ []
+ (case elemT
+ (#;Primitive name #;Nil)
+ (let [boxed-name (|> (dict;get name boxes)
+ (maybe;default name))]
+ (wrap [(#;Primitive boxed-name #;Nil)
+ boxed-name]))
+
+ (#;Primitive name _)
+ (if (dict;contains? name boxes)
+ (&;fail (format "Primitives cannot be parameterized: " name))
+ (:: meta;Monad<Meta> wrap [elemT name]))
+
+ _
+ (&;fail (format "Invalid type for array element: " (%type elemT))))))
+
+(def: (array-read proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list arrayC idxC))
+ (do meta;Monad<Meta>
+ [arrayA (&;with-expected-type (type (Array varT))
+ (analyse arrayC))
+ elemT (&;with-type-env
+ (tc;read var-id))
+ [elemT elem-class] (box-array-element-type elemT)
+ idxA (&;with-expected-type Nat
+ (analyse idxC))
+ _ (&;infer elemT)]
+ (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA))))
+
+ _
+ (&;fail (@;wrong-arity proc +2 (list;size args))))))))
+
+(def: (array-write proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list arrayC idxC valueC))
+ (do meta;Monad<Meta>
+ [arrayA (&;with-expected-type (type (Array varT))
+ (analyse arrayC))
+ elemT (&;with-type-env
+ (tc;read var-id))
+ [valueT elem-class] (box-array-element-type elemT)
+ idxA (&;with-expected-type Nat
+ (analyse idxC))
+ valueA (&;with-expected-type valueT
+ (analyse valueC))
+ _ (&;infer (type (Array elemT)))]
+ (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA))))
+
+ _
+ (&;fail (@;wrong-arity proc +3 (list;size args))))))))
+
+(def: array-procs
+ @;Bundle
+ (<| (@;prefix "array")
+ (|> (dict;new text;Hash<Text>)
+ (@;install "length" array-length)
+ (@;install "new" array-new)
+ (@;install "read" array-read)
+ (@;install "write" array-write)
+ )))
+
+(def: (object-null proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case args
+ (^ (list))
+ (do meta;Monad<Meta>
+ [expectedT meta;expected-type
+ _ (check-object expectedT)]
+ (wrap (la;procedure proc (list))))
+
+ _
+ (&;fail (@;wrong-arity proc +0 (list;size args))))))
+
+(def: (object-null? proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list objectC))
+ (do meta;Monad<Meta>
+ [objectA (&;with-expected-type varT
+ (analyse objectC))
+ objectT (&;with-type-env
+ (tc;read var-id))
+ _ (check-object objectT)
+ _ (&;infer Bool)]
+ (wrap (la;procedure proc (list objectA))))
+
+ _
+ (&;fail (@;wrong-arity proc +1 (list;size args))))))))
+
+(def: (object-synchronized proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list monitorC exprC))
+ (do meta;Monad<Meta>
+ [monitorA (&;with-expected-type varT
+ (analyse monitorC))
+ monitorT (&;with-type-env
+ (tc;read var-id))
+ _ (check-object monitorT)
+ exprA (analyse exprC)]
+ (wrap (la;procedure proc (list monitorA exprA))))
+
+ _
+ (&;fail (@;wrong-arity proc +2 (list;size args))))))))
+
+(host;import java.lang.Object
+ (equals [Object] boolean))
+
+(host;import java.lang.ClassLoader)
+
+(host;import #long java.lang.reflect.Type
+ (getTypeName [] String))
+
+(host;import java.lang.reflect.GenericArrayType
+ (getGenericComponentType [] java.lang.reflect.Type))
+
+(host;import java.lang.reflect.ParameterizedType
+ (getRawType [] java.lang.reflect.Type)
+ (getActualTypeArguments [] (Array java.lang.reflect.Type)))
+
+(host;import (java.lang.reflect.TypeVariable d)
+ (getName [] String)
+ (getBounds [] (Array java.lang.reflect.Type)))
+
+(host;import (java.lang.reflect.WildcardType d)
+ (getLowerBounds [] (Array java.lang.reflect.Type))
+ (getUpperBounds [] (Array java.lang.reflect.Type)))
+
+(host;import java.lang.reflect.Modifier
+ (#static isStatic [int] boolean)
+ (#static isFinal [int] boolean)
+ (#static isInterface [int] boolean)
+ (#static isAbstract [int] boolean))
+
+(host;import java.lang.reflect.Field
+ (getDeclaringClass [] (java.lang.Class Object))
+ (getModifiers [] int)
+ (getGenericType [] java.lang.reflect.Type))
+
+(host;import java.lang.reflect.Method
+ (getName [] String)
+ (getModifiers [] int)
+ (getDeclaringClass [] (Class Object))
+ (getTypeParameters [] (Array (TypeVariable Method)))
+ (getGenericParameterTypes [] (Array java.lang.reflect.Type))
+ (getGenericReturnType [] java.lang.reflect.Type)
+ (getGenericExceptionTypes [] (Array java.lang.reflect.Type)))
+
+(host;import (java.lang.reflect.Constructor c)
+ (getModifiers [] int)
+ (getDeclaringClass [] (Class c))
+ (getTypeParameters [] (Array (TypeVariable (Constructor c))))
+ (getGenericParameterTypes [] (Array java.lang.reflect.Type))
+ (getGenericExceptionTypes [] (Array java.lang.reflect.Type)))
+
+(host;import (java.lang.Class c)
+ (getName [] String)
+ (getModifiers [] int)
+ (#static forName [String boolean ClassLoader] #try (Class Object))
+ (isAssignableFrom [(Class Object)] boolean)
+ (getTypeParameters [] (Array (TypeVariable (Class c))))
+ (getGenericInterfaces [] (Array java.lang.reflect.Type))
+ (getGenericSuperclass [] java.lang.reflect.Type)
+ (getDeclaredField [String] #try Field)
+ (getConstructors [] (Array (Constructor Object)))
+ (getDeclaredMethods [] (Array Method)))
+
+(def: (load-class name)
+ (-> Text (Meta (Class Object)))
+ (do meta;Monad<Meta>
+ [class-loader &host;class-loader]
+ (case (Class.forName [name false class-loader])
+ (#e;Success [class])
+ (wrap class)
+
+ (#e;Error error)
+ (&;fail (format "Unknown class: " name)))))
+
+(def: (sub-class? super sub)
+ (-> Text Text (Meta Bool))
+ (do meta;Monad<Meta>
+ [super (load-class super)
+ sub (load-class sub)]
+ (wrap (Class.isAssignableFrom [sub] super))))
+
+(exception: #export Not-Throwable)
+
+(def: (object-throw proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list exceptionC))
+ (do meta;Monad<Meta>
+ [exceptionA (&;with-expected-type varT
+ (analyse exceptionC))
+ exceptionT (&;with-type-env
+ (tc;read var-id))
+ exception-class (check-object exceptionT)
+ ? (sub-class? "java.lang.Throwable" exception-class)
+ _ (: (Meta Unit)
+ (if ?
+ (wrap [])
+ (&;throw Not-Throwable exception-class)))
+ _ (&;infer Bottom)]
+ (wrap (la;procedure proc (list exceptionA))))
+
+ _
+ (&;fail (@;wrong-arity proc +1 (list;size args))))))))
+
+(def: (object-class proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case args
+ (^ (list classC))
+ (case classC
+ [_ (#;Text class)]
+ (do meta;Monad<Meta>
+ [_ (load-class class)
+ _ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))]
+ (wrap (la;procedure proc (list (code;text class)))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +1 (list;size args))))))
+
+(exception: #export Cannot-Be-Instance)
+
+(def: (object-instance? proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (&common;with-var
+ (function [[var-id varT]]
+ (case args
+ (^ (list classC objectC))
+ (case classC
+ [_ (#;Text class)]
+ (do meta;Monad<Meta>
+ [objectA (&;with-expected-type varT
+ (analyse objectC))
+ objectT (&;with-type-env
+ (tc;read var-id))
+ object-class (check-object objectT)
+ ? (sub-class? class object-class)]
+ (if ?
+ (do @
+ [_ (&;infer Bool)]
+ (wrap (la;procedure proc (list (code;text class)))))
+ (&;throw Cannot-Be-Instance (format object-class " !<= " class))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +2 (list;size args))))))))
+
+(def: object-procs
+ @;Bundle
+ (<| (@;prefix "object")
+ (|> (dict;new text;Hash<Text>)
+ (@;install "null" object-null)
+ (@;install "null?" object-null?)
+ (@;install "synchronized" object-synchronized)
+ (@;install "throw" object-throw)
+ (@;install "class" object-class)
+ (@;install "instance?" object-instance?)
+ )))
+
+(exception: #export Final-Field)
+
+(exception: #export Cannot-Convert-To-Class)
+(exception: #export Cannot-Convert-To-Parameter)
+(exception: #export Cannot-Convert-To-Lux-Type)
+(exception: #export Cannot-Cast-To-Primitive)
+(exception: #export JVM-Type-Is-Not-Class)
+
+(def: type-descriptor
+ (-> java.lang.reflect.Type Text)
+ (java.lang.reflect.Type.getTypeName []))
+
+(def: (java-type-to-class type)
+ (-> java.lang.reflect.Type (Meta Text))
+ (cond (host;instance? Class type)
+ (meta/wrap (Class.getName [] (:! Class type)))
+
+ (host;instance? ParameterizedType type)
+ (java-type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type)))
+
+ ## else
+ (&;throw Cannot-Convert-To-Class (type-descriptor type))))
+
+(exception: #export Unknown-Type-Var)
+
+(type: Mappings
+ (Dict Text Type))
+
+(def: fresh-mappings Mappings (dict;new text;Hash<Text>))
+
+(def: (java-type-to-lux-type mappings java-type)
+ (-> Mappings java.lang.reflect.Type (Meta Type))
+ (cond (host;instance? TypeVariable java-type)
+ (let [var-name (TypeVariable.getName [] (:! TypeVariable java-type))]
+ (case (dict;get var-name mappings)
+ (#;Some var-type)
+ (meta/wrap var-type)
+
+ #;None
+ (&;throw Unknown-Type-Var var-name)))
+
+ (host;instance? WildcardType java-type)
+ (let [java-type (:! WildcardType java-type)]
+ (case [(array;read +0 (WildcardType.getUpperBounds [] java-type))
+ (array;read +0 (WildcardType.getLowerBounds [] java-type))]
+ (^or [(#;Some bound) _] [_ (#;Some bound)])
+ (java-type-to-lux-type mappings bound)
+
+ _
+ (meta/wrap Top)))
+
+ (host;instance? Class java-type)
+ (let [java-type (:! (Class Object) java-type)
+ class-name (Class.getName [] java-type)]
+ (meta/wrap (case (array;size (Class.getTypeParameters [] java-type))
+ +0
+ (#;Primitive class-name (list))
+
+ arity
+ (|> (list;n.range +0 (n.dec arity))
+ list;reverse
+ (list/map (|>. (n.* +2) n.inc #;Bound))
+ (#;Primitive class-name)
+ (type;univ-q arity)))))
+
+ (host;instance? ParameterizedType java-type)
+ (let [java-type (:! ParameterizedType java-type)
+ raw (ParameterizedType.getRawType [] java-type)]
+ (if (host;instance? Class raw)
+ (do meta;Monad<Meta>
+ [paramsT (|> java-type
+ (ParameterizedType.getActualTypeArguments [])
+ array;to-list
+ (monad;map @ (java-type-to-lux-type mappings)))]
+ (meta/wrap (#;Primitive (Class.getName [] (:! (Class Object) raw))
+ paramsT)))
+ (&;throw JVM-Type-Is-Not-Class (type-descriptor raw))))
+
+ (host;instance? GenericArrayType java-type)
+ (do meta;Monad<Meta>
+ [innerT (|> (:! GenericArrayType java-type)
+ (GenericArrayType.getGenericComponentType [])
+ (java-type-to-lux-type mappings))]
+ (wrap (#;Primitive "#Array" (list innerT))))
+
+ ## else
+ (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
+
+(type: Direction
+ #In
+ #Out)
+
+(def: (choose direction to from)
+ (-> Direction Text Text Text)
+ (case direction
+ #In to
+ #Out from))
+
+(def: (correspond-type-params class type)
+ (-> (Class Object) Type (Meta Mappings))
+ (case type
+ (#;Primitive name params)
+ (let [class-name (Class.getName [] class)
+ class-params (array;to-list (Class.getTypeParameters [] class))]
+ (if (text/= class-name name)
+ (if (n.= (list;size class-params)
+ (list;size params))
+ (meta/wrap (|> params
+ (list;zip2 (list/map (TypeVariable.getName []) class-params))
+ (dict;from-list text;Hash<Text>)))
+ (&;fail (format "Class and host-type parameters do not match: " "class = " class-name " | host type = " name)))
+ (&;fail (format "Class and host-type names do not match: " "class = " class-name " | host type = " name))))
+
+ _
+ (&;fail (format "Not a host type: " (%type type)))))
+
+(def: (cast direction to from)
+ (-> Direction Type Type (Meta [Text Type]))
+ (do meta;Monad<Meta>
+ [to-name (check-jvm to)
+ from-name (check-jvm from)]
+ (cond (dict;contains? to-name boxes)
+ (let [box (maybe;assume (dict;get to-name boxes))]
+ (if (text/= box from-name)
+ (wrap [(choose direction to-name from-name) (#;Primitive to-name (list))])
+ (&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name))))
+
+ (dict;contains? from-name boxes)
+ (let [box (maybe;assume (dict;get from-name boxes))]
+ (do @
+ [[_ castT] (cast direction to (#;Primitive box (list)))]
+ (wrap [(choose direction to-name from-name) castT])))
+
+ (text/= to-name from-name)
+ (wrap [(choose direction to-name from-name) from])
+
+ (text/= null-class from-name)
+ (wrap [(choose direction to-name from-name) to])
+
+ ## else
+ (do @
+ [to-class (load-class to-name)
+ from-class (load-class from-name)
+ _ (&;assert (format "Class '" from-name "' is not a sub-class of class '" to-name "'.")
+ (Class.isAssignableFrom [from-class] to-class))
+ candiate-parents (monad;map @
+ (function [java-type]
+ (do @
+ [class-name (java-type-to-class java-type)
+ class (load-class class-name)]
+ (wrap [java-type (Class.isAssignableFrom [class] to-class)])))
+ (list& (Class.getGenericSuperclass [] from-class)
+ (array;to-list (Class.getGenericInterfaces [] from-class))))]
+ (case (|> candiate-parents
+ (list;filter product;right)
+ (list/map product;left))
+ (#;Cons parent _)
+ (do @
+ [mapping (correspond-type-params from-class from)
+ parentT (java-type-to-lux-type mapping parent)
+ [_ castT] (cast direction to parentT)]
+ (wrap [(choose direction to-name from-name) castT]))
+
+ #;Nil
+ (&;fail (format "No valid path between " (%type from) "and " (%type to) ".")))))))
+
+(def: (infer-out outputT)
+ (-> Type (Meta [Text Type]))
+ (do meta;Monad<Meta>
+ [expectedT meta;expected-type
+ [unboxed castT] (cast #Out expectedT outputT)
+ _ (&;with-type-env
+ (tc;check expectedT castT))]
+ (wrap [unboxed castT])))
+
+(def: (find-field class-name field-name)
+ (-> Text Text (Meta [(Class Object) Field]))
+ (do meta;Monad<Meta>
+ [class (load-class class-name)]
+ (case (Class.getDeclaredField [field-name] class)
+ (#e;Success field)
+ (let [owner (Field.getDeclaringClass [] field)]
+ (if (is owner class)
+ (wrap [class field])
+ (&;fail (format "Field '" field-name "' does not belong to class '" class-name "'.\n"
+ "Belongs to '" (Class.getName [] owner) "'."))))
+
+ (#e;Error _)
+ (&;fail (format "Unknown field '" field-name "' for class '" class-name "'.")))))
+
+(def: (static-field class-name field-name)
+ (-> Text Text (Meta [Type Bool]))
+ (do meta;Monad<Meta>
+ [[class fieldJ] (find-field class-name field-name)
+ #let [modifiers (Field.getModifiers [] fieldJ)]]
+ (if (Modifier.isStatic [modifiers])
+ (let [fieldJT (Field.getGenericType [] fieldJ)]
+ (do @
+ [fieldT (java-type-to-lux-type fresh-mappings fieldJT)]
+ (wrap [fieldT (Modifier.isFinal [modifiers])])))
+ (&;fail (format "Field '" field-name "' of class '" class-name "' is not static.")))))
+
+(exception: #export Non-Object-Type)
+
+(def: (virtual-field class-name field-name objectT)
+ (-> Text Text Type (Meta [Type Bool]))
+ (do meta;Monad<Meta>
+ [[class fieldJ] (find-field class-name field-name)
+ #let [modifiers (Field.getModifiers [] fieldJ)]]
+ (if (not (Modifier.isStatic [modifiers]))
+ (do @
+ [#let [fieldJT (Field.getGenericType [] fieldJ)
+ var-names (|> class
+ (Class.getTypeParameters [])
+ array;to-list
+ (list/map (TypeVariable.getName [])))]
+ mappings (: (Meta Mappings)
+ (case objectT
+ (#;Primitive _class-name _class-params)
+ (do @
+ [#let [num-params (list;size _class-params)
+ num-vars (list;size var-names)]
+ _ (&;assert (format "Number of paremeters in type does not match expected amount (" (%n num-vars) "): " (%type objectT))
+ (n.= num-params num-vars))]
+ (wrap (|> (list;zip2 var-names _class-params)
+ (dict;from-list text;Hash<Text>))))
+
+ _
+ (&;throw Non-Object-Type (%type objectT))))
+ fieldT (java-type-to-lux-type mappings fieldJT)]
+ (wrap [fieldT (Modifier.isFinal [modifiers])]))
+ (&;fail (format "Field '" field-name "' of class '" class-name "' is static.")))))
+
+(def: (analyse-object class analyse sourceC)
+ (-> Text &;Analyser Code (Meta [Type la;Analysis]))
+ (<| &common;with-var (function [[var-id varT]])
+ (do meta;Monad<Meta>
+ [target-class (load-class class)
+ targetT (java-type-to-lux-type fresh-mappings
+ (:! java.lang.reflect.Type
+ target-class))
+ sourceA (&;with-expected-type varT
+ (analyse sourceC))
+ sourceT (&;with-type-env
+ (tc;read var-id))
+ [unboxed castT] (cast #Out targetT sourceT)
+ _ (&;assert (format "Object cannot be a primitive: " unboxed)
+ (not (dict;contains? unboxed boxes)))]
+ (wrap [castT sourceA]))))
+
+(def: (analyse-input analyse targetT sourceC)
+ (-> &;Analyser Type Code (Meta [Type Text la;Analysis]))
+ (<| &common;with-var (function [[var-id varT]])
+ (do meta;Monad<Meta>
+ [sourceA (&;with-expected-type varT
+ (analyse sourceC))
+ sourceT (&;with-type-env
+ (tc;read var-id))
+ [unboxed castT] (cast #In targetT sourceT)]
+ (wrap [castT unboxed sourceA]))))
+
+(def: (static-get proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case args
+ (^ (list classC fieldC))
+ (case [classC fieldC]
+ [[_ (#;Text class)] [_ (#;Text field)]]
+ (do meta;Monad<Meta>
+ [[fieldT final?] (static-field class field)
+ [unboxed castT] (infer-out fieldT)]
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed)))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +2 (list;size args))))))
+
+(def: (static-put proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case args
+ (^ (list classC fieldC valueC))
+ (case [classC fieldC]
+ [[_ (#;Text class)] [_ (#;Text field)]]
+ (do meta;Monad<Meta>
+ [[fieldT final?] (static-field class field)
+ _ (&;assert (Final-Field (format class "#" field))
+ (not final?))
+ [valueT unboxed valueA] (analyse-input analyse fieldT valueC)
+ _ (&;with-type-env
+ (tc;check fieldT valueT))
+ _ (&;infer Unit)]
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed) valueA))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +3 (list;size args))))))
+
+(def: (virtual-get proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case args
+ (^ (list classC fieldC objectC))
+ (case [classC fieldC]
+ [[_ (#;Text class)] [_ (#;Text field)]]
+ (do meta;Monad<Meta>
+ [[objectT objectA] (analyse-object class analyse objectC)
+ [fieldT final?] (virtual-field class field objectT)
+ [unboxed castT] (infer-out fieldT)]
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed) objectA))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +3 (list;size args))))))
+
+(def: (virtual-put proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case args
+ (^ (list classC fieldC valueC objectC))
+ (case [classC fieldC]
+ [[_ (#;Text class)] [_ (#;Text field)]]
+ (do meta;Monad<Meta>
+ [[objectT objectA] (analyse-object class analyse objectC)
+ [fieldT final?] (virtual-field class field objectT)
+ _ (&;assert (Final-Field (format class "#" field))
+ (not final?))
+ [valueT unboxed valueA] (analyse-input analyse fieldT valueC)
+ _ (&;with-type-env
+ (tc;check fieldT valueT))
+ _ (&;infer objectT)]
+ (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))
+
+ _
+ (&;fail (@;wrong-arity proc +4 (list;size args))))))
+
+(def: (java-type-to-parameter type)
+ (-> java.lang.reflect.Type (Meta Text))
+ (cond (host;instance? Class type)
+ (meta/wrap (Class.getName [] (:! Class type)))
+
+ (host;instance? ParameterizedType type)
+ (java-type-to-parameter (ParameterizedType.getRawType [] (:! ParameterizedType type)))
+
+ (or (host;instance? TypeVariable type)
+ (host;instance? WildcardType type))
+ (meta/wrap "java.lang.Object")
+
+ (host;instance? GenericArrayType type)
+ (do meta;Monad<Meta>
+ [componentP (java-type-to-parameter (GenericArrayType.getGenericComponentType [] (:! GenericArrayType type)))]
+ (wrap (format componentP "[]")))
+
+ ## else
+ (&;throw Cannot-Convert-To-Parameter (type-descriptor type))))
+
+(type: Method-Type
+ #Static
+ #Abstract
+ #Virtual
+ #Special
+ #Interface)
+
+(def: (check-method class method-name method-type arg-classes method)
+ (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool))
+ (do meta;Monad<Meta>
+ [parameters (|> (Method.getGenericParameterTypes [] method)
+ array;to-list
+ (monad;map @ java-type-to-parameter))
+ #let [modifiers (Method.getModifiers [] method)]]
+ (wrap (and (Object.equals [class] (Method.getDeclaringClass [] method))
+ (text/= method-name (Method.getName [] method))
+ (case #Static
+ #Special
+ (Modifier.isStatic [modifiers])
+
+ _
+ true)
+ (case method-type
+ #Special
+ (not (or (Modifier.isInterface [(Class.getModifiers [] class)])
+ (Modifier.isAbstract [modifiers])))
+
+ _
+ true)
+ (n.= (list;size arg-classes) (list;size parameters))
+ (list/fold (function [[expectedJC actualJC] prev]
+ (and prev
+ (text/= expectedJC actualJC)))
+ true
+ (list;zip2 arg-classes parameters))))))
+
+(def: (check-constructor class arg-classes constructor)
+ (-> (Class Object) (List Text) (Constructor Object) (Meta Bool))
+ (do meta;Monad<Meta>
+ [parameters (|> (Constructor.getGenericParameterTypes [] constructor)
+ array;to-list
+ (monad;map @ java-type-to-parameter))]
+ (wrap (and (Object.equals [class] (Constructor.getDeclaringClass [] constructor))
+ (n.= (list;size arg-classes) (list;size parameters))
+ (list/fold (function [[expectedJC actualJC] prev]
+ (and prev
+ (text/= expectedJC actualJC)))
+ true
+ (list;zip2 arg-classes parameters))))))
+
+(def: idx-to-bound
+ (-> Nat Type)
+ (|>. (n.* +2) n.inc #;Bound))
+
+(def: (type-vars amount offset)
+ (-> Nat Nat (List Type))
+ (if (n.= +0 amount)
+ (list)
+ (|> (list;n.range offset (|> amount n.dec (n.+ offset)))
+ (list/map idx-to-bound))))
+
+(def: (method-to-type method-type method)
+ (-> Method-Type Method (Meta [Type (List Type)]))
+ (let [owner (Method.getDeclaringClass [] method)
+ owner-name (Class.getName [] owner)
+ owner-tvars (case method-type
+ #Static
+ (list)
+
+ _
+ (|> (Class.getTypeParameters [] owner)
+ array;to-list
+ (list/map (TypeVariable.getName []))))
+ method-tvars (|> (Method.getTypeParameters [] method)
+ array;to-list
+ (list/map (TypeVariable.getName [])))
+ num-owner-tvars (list;size owner-tvars)
+ num-method-tvars (list;size method-tvars)
+ all-tvars (list/compose owner-tvars method-tvars)
+ num-all-tvars (list;size all-tvars)
+ owner-tvarsT (type-vars num-owner-tvars +0)
+ method-tvarsT (type-vars num-method-tvars num-owner-tvars)
+ mappings (: Mappings
+ (if (list;empty? all-tvars)
+ fresh-mappings
+ (|> (list/compose owner-tvarsT method-tvarsT)
+ list;reverse
+ (list;zip2 all-tvars)
+ (dict;from-list text;Hash<Text>))))]
+ (do meta;Monad<Meta>
+ [inputsT (|> (Method.getGenericParameterTypes [] method)
+ array;to-list
+ (monad;map @ (java-type-to-lux-type mappings)))
+ outputT (java-type-to-lux-type mappings (Method.getGenericReturnType [] method))
+ exceptionsT (|> (Method.getGenericExceptionTypes [] method)
+ array;to-list
+ (monad;map @ (java-type-to-lux-type mappings)))
+ #let [methodT (<| (type;univ-q num-all-tvars)
+ (type;function (case method-type
+ #Static
+ inputsT
+
+ _
+ (list& (#;Primitive owner-name (list;reverse owner-tvarsT))
+ inputsT)))
+ outputT)]]
+ (wrap [methodT exceptionsT]))))
+
+(exception: #export No-Candidate-Method)
+(exception: #export Too-Many-Candidate-Methods)
+
+(def: (methods class-name method-name method-type arg-classes)
+ (-> Text Text Method-Type (List Text) (Meta [Type (List Type)]))
+ (do meta;Monad<Meta>
+ [class (load-class class-name)
+ candidates (|> class
+ (Class.getDeclaredMethods [])
+ array;to-list
+ (monad;map @ (function [method]
+ (do @
+ [passes? (check-method class method-name method-type arg-classes method)]
+ (wrap [passes? method])))))]
+ (case (list;filter product;left candidates)
+ #;Nil
+ (&;throw No-Candidate-Method (format class-name "#" method-name))
+
+ (#;Cons candidate #;Nil)
+ (|> candidate product;right (method-to-type method-type))
+
+ _
+ (&;throw Too-Many-Candidate-Methods (format class-name "#" method-name)))))
+
+(def: (constructor-to-type constructor)
+ (-> (Constructor Object) (Meta [Type (List Type)]))
+ (let [owner (Constructor.getDeclaringClass [] constructor)
+ owner-name (Class.getName [] owner)
+ owner-tvars (|> (Class.getTypeParameters [] owner)
+ array;to-list
+ (list/map (TypeVariable.getName [])))
+ constructor-tvars (|> (Constructor.getTypeParameters [] constructor)
+ array;to-list
+ (list/map (TypeVariable.getName [])))
+ num-owner-tvars (list;size owner-tvars)
+ all-tvars (list/compose owner-tvars constructor-tvars)
+ num-all-tvars (list;size all-tvars)
+ owner-tvarsT (type-vars num-owner-tvars +0)
+ constructor-tvarsT (type-vars num-all-tvars num-owner-tvars)
+ mappings (: Mappings
+ (if (list;empty? all-tvars)
+ fresh-mappings
+ (|> (list/compose owner-tvarsT constructor-tvarsT)
+ list;reverse
+ (list;zip2 all-tvars)
+ (dict;from-list text;Hash<Text>))))]
+ (do meta;Monad<Meta>
+ [inputsT (|> (Constructor.getGenericParameterTypes [] constructor)
+ array;to-list
+ (monad;map @ (java-type-to-lux-type mappings)))
+ exceptionsT (|> (Constructor.getGenericExceptionTypes [] constructor)
+ array;to-list
+ (monad;map @ (java-type-to-lux-type mappings)))
+ #let [objectT (#;Primitive owner-name (list;reverse owner-tvarsT))
+ constructorT (<| (type;univ-q num-all-tvars)
+ (type;function inputsT)
+ objectT)]]
+ (wrap [constructorT exceptionsT]))))
+
+(exception: #export No-Candidate-Constructor)
+(exception: #export Too-Many-Candidate-Constructors)
+
+(def: (constructor-methods class-name arg-classes)
+ (-> Text (List Text) (Meta [Type (List Type)]))
+ (do meta;Monad<Meta>
+ [class (load-class class-name)
+ candidates (|> class
+ (Class.getConstructors [])
+ array;to-list
+ (monad;map @ (function [constructor]
+ (do @
+ [passes? (check-constructor class arg-classes constructor)]
+ (wrap [passes? constructor])))))]
+ (case (list;filter product;left candidates)
+ #;Nil
+ (&;throw No-Candidate-Constructor (format class-name "(" (text;join-with ", " arg-classes) ")"))
+
+ (#;Cons candidate #;Nil)
+ (|> candidate product;right constructor-to-type)
+
+ _
+ (&;throw Too-Many-Candidate-Constructors class-name))))
+
+(def: (decorate-inputs typesT inputsA)
+ (-> (List Text) (List la;Analysis) (List la;Analysis))
+ (|> inputsA
+ (list;zip2 (list/map code;text typesT))
+ (list/map (function [[type value]]
+ (la;product (list type value))))))
+
+(def: (sub-type-analyser analyse)
+ (-> &;Analyser &;Analyser)
+ (function [argC]
+ (do meta;Monad<Meta>
+ [[argT argA] (&common;with-unknown-type
+ (analyse argC))
+ expectedT meta;expected-type
+ [unboxed castT] (cast #In expectedT argT)]
+ (wrap argA))))
+
+(def: (invoke//static proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case (: (e;Error [Text Text (List [Text Code])])
+ (s;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any))))))
+ (#e;Success [class method argsTC])
+ (do meta;Monad<Meta>
+ [#let [argsT (list/map product;left argsTC)]
+ [methodT exceptionsT] (methods class method #Static argsT)
+ [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) (decorate-inputs argsT argsA)))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))))
+
+(def: (invoke//virtual proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case (: (e;Error [Text Text Code (List [Text Code])])
+ (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))))))
+ (#e;Success [class method objectC argsTC])
+ (do meta;Monad<Meta>
+ [#let [argsT (list/map product;left argsTC)]
+ [methodT exceptionsT] (methods class method #Virtual argsT)
+ [outputT allA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ #let [[objectA argsA] (case allA
+ (#;Cons objectA argsA)
+ [objectA argsA]
+
+ _
+ (undefined))]
+ [unboxed castT] (infer-out outputT)]
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) objectA (decorate-inputs argsT argsA)))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))))
+
+(def: (invoke//special proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case (: (e;Error [(List Code) [Text Text Code (List [Text Code]) Unit]])
+ (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!)))
+ (#e;Success [_ [class method objectC argsTC _]])
+ (do meta;Monad<Meta>
+ [#let [argsT (list/map product;left argsTC)]
+ [methodT exceptionsT] (methods class method #Special argsT)
+ [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) (decorate-inputs argsT argsA)))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))))
+
+(exception: #export Not-Interface)
+
+(def: (invoke//interface proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case (: (e;Error [Text Text Code (List [Text Code])])
+ (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))))))
+ (#e;Success [class-name method objectC argsTC])
+ (do meta;Monad<Meta>
+ [#let [argsT (list/map product;left argsTC)]
+ class (load-class class-name)
+ _ (&;assert (Not-Interface class-name)
+ (Modifier.isInterface [(Class.getModifiers [] class)]))
+ [methodT exceptionsT] (methods class-name method #Interface argsT)
+ [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (la;procedure proc
+ (list& (code;text class-name) (code;text method) (code;text unboxed)
+ (decorate-inputs argsT argsA)))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))))
+
+(def: (invoke//constructor proc)
+ (-> Text @;Proc)
+ (function [analyse eval args]
+ (case (: (e;Error [Text (List [Text Code])])
+ (s;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any))))))
+ (#e;Success [class argsTC])
+ (do meta;Monad<Meta>
+ [#let [argsT (list/map product;left argsTC)]
+ [methodT exceptionsT] (constructor-methods class argsT)
+ [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
+ [unboxed castT] (infer-out outputT)]
+ (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA)))))
+
+ _
+ (&;fail (format "Wrong syntax for '" proc "'.")))))
+
+(def: member-procs
+ @;Bundle
+ (<| (@;prefix "member")
+ (|> (dict;new text;Hash<Text>)
+ (dict;merge (<| (@;prefix "static")
+ (|> (dict;new text;Hash<Text>)
+ (@;install "get" static-get)
+ (@;install "put" static-put))))
+ (dict;merge (<| (@;prefix "virtual")
+ (|> (dict;new text;Hash<Text>)
+ (@;install "get" virtual-get)
+ (@;install "put" virtual-put))))
+ (dict;merge (<| (@;prefix "invoke")
+ (|> (dict;new text;Hash<Text>)
+ (@;install "static" invoke//static)
+ (@;install "virtual" invoke//virtual)
+ (@;install "special" invoke//special)
+ (@;install "interface" invoke//interface)
+ (@;install "constructor" invoke//constructor)
+ )))
+ )))
+
+(def: #export procedures
+ @;Bundle
+ (<| (@;prefix "jvm")
+ (|> (dict;new text;Hash<Text>)
+ (dict;merge conversion-procs)
+ (dict;merge int-procs)
+ (dict;merge long-procs)
+ (dict;merge float-procs)
+ (dict;merge double-procs)
+ (dict;merge char-procs)
+ (dict;merge array-procs)
+ (dict;merge object-procs)
+ (dict;merge member-procs)
+ )))
diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux
new file mode 100644
index 000000000..5bc1f96c9
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/reference.lux
@@ -0,0 +1,53 @@
+(;module:
+ lux
+ (lux (control monad)
+ [meta]
+ (meta [code]
+ (type ["tc" check])))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis]
+ [";L" variable #+ Variable])
+ ["&;" scope]))
+
+## [Analysers]
+(def: (analyse-definition def-name)
+ (-> Ident (Meta Analysis))
+ (do meta;Monad<Meta>
+ [actualT (meta;find-def-type def-name)
+ expectedT meta;expected-type
+ _ (&;with-type-env
+ (tc;check expectedT actualT))]
+ (wrap (code;symbol def-name))))
+
+(def: (analyse-variable var-name)
+ (-> Text (Meta (Maybe Analysis)))
+ (do meta;Monad<Meta>
+ [?var (&scope;find var-name)]
+ (case ?var
+ (#;Some [actualT ref])
+ (do @
+ [expectedT meta;expected-type
+ _ (&;with-type-env
+ (tc;check expectedT actualT))]
+ (wrap (#;Some (` ((~ (code;int (variableL;from-ref ref))))))))
+
+ #;None
+ (wrap #;None))))
+
+(def: #export (analyse-reference reference)
+ (-> Ident (Meta Analysis))
+ (case reference
+ ["" simple-name]
+ (do meta;Monad<Meta>
+ [?var (analyse-variable simple-name)]
+ (case ?var
+ (#;Some analysis)
+ (wrap analysis)
+
+ #;None
+ (do @
+ [this-module meta;current-module-name]
+ (analyse-definition [this-module simple-name]))))
+
+ _
+ (analyse-definition reference)))
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
new file mode 100644
index 000000000..0284245e1
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/structure.lux
@@ -0,0 +1,311 @@
+(;module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
+ pipe)
+ [function]
+ (concurrency ["A" atom])
+ (data [ident]
+ [number]
+ [product]
+ [maybe]
+ (coll [list "list/" Functor<List>]
+ [dict #+ Dict])
+ [text]
+ text/format)
+ [meta]
+ (meta [code]
+ [type]
+ (type ["tc" check])))
+ (luxc ["&" base]
+ (lang ["la" analysis]
+ (analysis ["&;" common]
+ ["&;" inference]))
+ ["&;" module]
+ ["&;" scope]))
+
+(exception: #export Not-Variant-Type)
+(exception: #export Not-Tuple-Type)
+(exception: #export Cannot-Infer-Numeric-Tag)
+
+(type: Type-Error
+ (-> Type Text))
+
+(def: (not-quantified type)
+ Type-Error
+ (format "Not a quantified type: " (%type type)))
+
+(def: #export (analyse-sum analyse tag valueC)
+ (-> &;Analyser Nat Code (Meta la;Analysis))
+ (do meta;Monad<Meta>
+ [expectedT meta;expected-type]
+ (&;with-stacked-errors
+ (function [_] (Not-Variant-Type (format " Tag: " (%n tag) "\n"
+ "Value: " (%code valueC) "\n"
+ " Type: " (%type expectedT))))
+ (case expectedT
+ (#;Sum _)
+ (let [flat (type;flatten-variant expectedT)
+ type-size (list;size flat)]
+ (case (list;nth tag flat)
+ (#;Some variant-type)
+ (do @
+ [valueA (&;with-expected-type variant-type
+ (analyse valueC))
+ temp &scope;next-local]
+ (wrap (la;sum tag type-size temp valueA)))
+
+ #;None
+ (&common;variant-out-of-bounds-error expectedT type-size tag)))
+
+ (#;Named name unnamedT)
+ (&;with-expected-type unnamedT
+ (analyse-sum analyse tag valueC))
+
+ (#;Var id)
+ (do @
+ [bound? (&;with-type-env
+ (tc;bound? id))]
+ (if bound?
+ (do @
+ [expectedT' (&;with-type-env
+ (tc;read id))]
+ (&;with-expected-type expectedT'
+ (analyse-sum analyse tag valueC)))
+ ## Cannot do inference when the tag is numeric.
+ ## This is because there is no way of knowing how many
+ ## cases the inferred sum type would have.
+ (&;throw Cannot-Infer-Numeric-Tag (format " Tag: " (%n tag) "\n"
+ "Value: " (%code valueC) "\n"
+ " Type: " (%type expectedT)))))
+
+ (#;UnivQ _)
+ (do @
+ [[var-id var] (&;with-type-env
+ tc;existential)]
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
+ (analyse-sum analyse tag valueC)))
+
+ (#;ExQ _)
+ (&common;with-var
+ (function [[var-id var]]
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
+ (analyse-sum analyse tag valueC))))
+
+ (#;Apply inputT funT)
+ (case (type;apply (list inputT) funT)
+ #;None
+ (&;fail (not-quantified funT))
+
+ (#;Some outputT)
+ (&;with-expected-type outputT
+ (analyse-sum analyse tag valueC)))
+
+ _
+ (&;throw Not-Variant-Type (format " Tag: " (%n tag) "\n"
+ "Value: " (%code valueC) "\n"
+ " Type: " (%type expectedT)))))))
+
+(def: (analyse-typed-product analyse members)
+ (-> &;Analyser (List Code) (Meta la;Analysis))
+ (do meta;Monad<Meta>
+ [expectedT meta;expected-type]
+ (loop [expectedT expectedT
+ members members]
+ (case [expectedT members]
+ ## If the type and the code are still ongoing, match each
+ ## sub-expression to its corresponding type.
+ [(#;Product leftT rightT) (#;Cons leftC rightC)]
+ (do @
+ [leftA (&;with-expected-type leftT
+ (analyse leftC))
+ rightA (recur rightT rightC)]
+ (wrap (` [(~ leftA) (~ rightA)])))
+
+ ## If the tuple runs out, whatever expression is the last gets
+ ## matched to the remaining type.
+ [tailT (#;Cons tailC #;Nil)]
+ (&;with-expected-type tailT
+ (analyse tailC))
+
+ ## If, however, the type runs out but there is still enough
+ ## tail, the remaining elements get packaged into another
+ ## tuple, and analysed through the intermediation of a
+ ## temporary local variable.
+ ## The reason for this is that it is assumed that the type of
+ ## the tuple represents the expectations of the user.
+ ## If the type is for a 3-tuple, but a 5-tuple is provided, it
+ ## is assumed that the user intended the following layout:
+ ## [0, 1, [2, 3, 4]]
+ ## but that, for whatever reason, it was written in a flat
+ ## way.
+ ## The reason why an intermediate variable is used is that if
+ ## the code was just re-written with just tuple nesting, the
+ ## resulting analysis would have undone the explicity nesting,
+ ## since Product nodes rely on nesting inherently, thereby
+ ## blurring the line between what was wanted (the separation)
+ ## and what was analysed.
+ [tailT tailC]
+ (do @
+ [g!tail (meta;gensym "tail")]
+ (&;with-expected-type tailT
+ (analyse (` ((~' _lux_case) [(~@ tailC)]
+ (~ g!tail)
+ (~ g!tail))))))
+ ))))
+
+(def: #export (analyse-product analyse membersC)
+ (-> &;Analyser (List Code) (Meta la;Analysis))
+ (do meta;Monad<Meta>
+ [expectedT meta;expected-type]
+ (&;with-stacked-errors
+ (function [_] (Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
+ "Value: " (%code (` [(~@ membersC)])))))
+ (case expectedT
+ (#;Product _)
+ (analyse-typed-product analyse membersC)
+
+ (#;Named name unnamedT)
+ (&;with-expected-type unnamedT
+ (analyse-product analyse membersC))
+
+ (#;Var id)
+ (do @
+ [bound? (&;with-type-env
+ (tc;bound? id))]
+ (if bound?
+ (do @
+ [expectedT' (&;with-type-env
+ (tc;read id))]
+ (&;with-expected-type expectedT'
+ (analyse-product analyse membersC)))
+ ## Must do inference...
+ (do @
+ [membersTA (monad;map @ (|>. analyse &common;with-unknown-type)
+ membersC)
+ _ (&;with-type-env
+ (tc;check expectedT
+ (type;tuple (list/map product;left membersTA))))]
+ (wrap (la;product (list/map product;right membersTA))))))
+
+ (#;UnivQ _)
+ (do @
+ [[var-id var] (&;with-type-env
+ tc;existential)]
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
+ (analyse-product analyse membersC)))
+
+ (#;ExQ _)
+ (&common;with-var
+ (function [[var-id var]]
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
+ (analyse-product analyse membersC))))
+
+ (#;Apply inputT funT)
+ (case (type;apply (list inputT) funT)
+ #;None
+ (&;fail (not-quantified funT))
+
+ (#;Some outputT)
+ (&;with-expected-type outputT
+ (analyse-product analyse membersC)))
+
+ _
+ (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
+ "Value: " (%code (` [(~@ membersC)]))))
+ ))))
+
+(def: #export (analyse-tagged-sum analyse tag valueC)
+ (-> &;Analyser Ident Code (Meta la;Analysis))
+ (do meta;Monad<Meta>
+ [tag (meta;normalize tag)
+ [idx group variantT] (meta;resolve-tag tag)
+ expectedT meta;expected-type]
+ (case expectedT
+ (#;Var _)
+ (do @
+ [#let [case-size (list;size group)]
+ inferenceT (&inference;variant idx case-size variantT)
+ [inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC))
+ _ (&;with-type-env
+ (tc;check expectedT inferredT))
+ temp &scope;next-local]
+ (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume))))
+
+ _
+ (analyse-sum analyse idx valueC))))
+
+## There cannot be any ambiguity or improper syntax when analysing
+## records, so they must be normalized for further analysis.
+## Normalization just means that all the tags get resolved to their
+## canonical form (with their corresponding module identified).
+(def: #export (normalize record)
+ (-> (List [Code Code]) (Meta (List [Ident Code])))
+ (monad;map meta;Monad<Meta>
+ (function [[key val]]
+ (case key
+ [_ (#;Tag key)]
+ (do meta;Monad<Meta>
+ [key (meta;normalize key)]
+ (wrap [key val]))
+
+ _
+ (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key)))))
+ record))
+
+## Lux already possesses the means to analyse tuples, so
+## re-implementing the same functionality for records makes no sense.
+## Records, thus, get transformed into tuples by ordering the elements.
+(def: #export (order record)
+ (-> (List [Ident Code]) (Meta [(List Code) Type]))
+ (case record
+ ## empty-record = empty-tuple = unit = []
+ #;Nil
+ (:: meta;Monad<Meta> wrap [(list) Unit])
+
+ (#;Cons [head-k head-v] _)
+ (do meta;Monad<Meta>
+ [head-k (meta;normalize head-k)
+ [_ tag-set recordT] (meta;resolve-tag head-k)
+ #let [size-record (list;size record)
+ size-ts (list;size tag-set)]
+ _ (if (n.= size-ts size-record)
+ (wrap [])
+ (&;fail (format "Record size does not match tag-set size." "\n"
+ "Expected: " (|> size-ts nat-to-int %i) "\n"
+ " Actual: " (|> size-record nat-to-int %i) "\n"
+ "For type: " (%type recordT))))
+ #let [tuple-range (list;n.range +0 (n.dec size-ts))
+ tag->idx (dict;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))]
+ idx->val (monad;fold @
+ (function [[key val] idx->val]
+ (do @
+ [key (meta;normalize key)]
+ (case (dict;get key tag->idx)
+ #;None
+ (&;fail (format "Tag " (%code (code;tag key))
+ " does not belong to tag-set for type " (%type recordT)))
+
+ (#;Some idx)
+ (if (dict;contains? idx idx->val)
+ (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key))))
+ (wrap (dict;put idx val idx->val))))))
+ (: (Dict Nat Code)
+ (dict;new number;Hash<Nat>))
+ record)
+ #let [ordered-tuple (list/map (function [idx] (maybe;assume (dict;get idx idx->val)))
+ tuple-range)]]
+ (wrap [ordered-tuple recordT]))
+ ))
+
+(def: #export (analyse-record analyse members)
+ (-> &;Analyser (List [Code Code]) (Meta la;Analysis))
+ (do meta;Monad<Meta>
+ [members (normalize members)
+ [members recordT] (order members)
+ expectedT meta;expected-type
+ inferenceT (&inference;record recordT)
+ [inferredT membersA] (&inference;apply-function analyse inferenceT members)
+ _ (&;with-type-env
+ (tc;check expectedT inferredT))]
+ (wrap (la;product membersA))))
diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux
new file mode 100644
index 000000000..d0b038d93
--- /dev/null
+++ b/new-luxc/source/luxc/lang/analysis/type.lux
@@ -0,0 +1,31 @@
+(;module:
+ lux
+ (lux (control monad)
+ [meta #+ Monad<Meta>]
+ (meta (type ["TC" check])))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis])))
+
+## These 2 analysers are somewhat special, since they require the
+## means of evaluating Lux expressions at compile-time for the sake of
+## computing Lux type values.
+(def: #export (analyse-check analyse eval type value)
+ (-> &;Analyser &;Eval Code Code (Meta Analysis))
+ (do Monad<Meta>
+ [actual (eval Type type)
+ #let [actual (:! Type actual)]
+ expected meta;expected-type
+ _ (&;with-type-env
+ (TC;check expected actual))]
+ (&;with-expected-type actual
+ (analyse value))))
+
+(def: #export (analyse-coerce analyse eval type value)
+ (-> &;Analyser &;Eval Code Code (Meta Analysis))
+ (do Monad<Meta>
+ [actual (eval Type type)
+ expected meta;expected-type
+ _ (&;with-type-env
+ (TC;check expected (:! Type actual)))]
+ (&;with-expected-type Top
+ (analyse value))))
diff --git a/new-luxc/source/luxc/lang/parser.lux b/new-luxc/source/luxc/lang/parser.lux
new file mode 100644
index 000000000..93800c1b7
--- /dev/null
+++ b/new-luxc/source/luxc/lang/parser.lux
@@ -0,0 +1,610 @@
+## This is the LuxC's parser.
+## It takes the source code of a Lux file in raw text form and
+## extracts the syntactic structure of the code from it.
+## It only produces Lux Code nodes, and thus removes any white-space
+## and comments while processing its inputs.
+
+## Another important aspect of the parser is that it keeps track of
+## its position within the input data.
+## That is, the parser takes into account the line and column
+## information in the input text (it doesn't really touch the
+## file-name aspect of the cursor, leaving it intact in whatever
+## base-line cursor it is given).
+
+## This particular piece of functionality is not located in one
+## function, but it is instead scattered throughout several parsers,
+## since the logic for how to update the cursor varies, depending on
+## what is being parsed, and the rules involved.
+
+## You will notice that several parsers have a "where" parameter, that
+## tells them the cursor position prior to the parser being run.
+## They are supposed to produce some parsed output, alongside an
+## updated cursor pointing to the end position, after the parser was run.
+
+## Lux Code nodes/tokens are annotated with cursor meta-data
+## (file-name, line, column) to keep track of their provenance and
+## location, which is helpful for documentation and debugging.
+(;module:
+ lux
+ (lux (control monad
+ ["p" parser "p/" Monad<Parser>])
+ (data [bool]
+ [text]
+ ["e" error]
+ [number]
+ [product]
+ [maybe]
+ (text ["l" lexer]
+ format)
+ (coll [sequence #+ Sequence]))))
+
+(def: white-space Text "\t\v \r\f")
+(def: new-line Text "\n")
+
+## This is the parser for white-space.
+## Whenever a new-line is encountered, the column gets reset to 0, and
+## the line gets incremented.
+## It operates recursively in order to produce the longest continuous
+## chunk of white-space.
+(def: (space^ where)
+ (-> Cursor (l;Lexer [Cursor Text]))
+ (p;either (do p;Monad<Parser>
+ [content (l;many (l;one-of white-space))]
+ (wrap [(update@ #;column (n.+ (text;size content)) where)
+ content]))
+ ## New-lines must be handled as a separate case to ensure line
+ ## information is handled properly.
+ (do p;Monad<Parser>
+ [content (l;many (l;one-of new-line))]
+ (wrap [(|> where
+ (update@ #;line (n.+ (text;size content)))
+ (set@ #;column +0))
+ content]))
+ ))
+
+## Single-line comments can start anywhere, but only go up to the
+## next new-line.
+(def: (single-line-comment^ where)
+ (-> Cursor (l;Lexer [Cursor Text]))
+ (do p;Monad<Parser>
+ [_ (l;this "##")
+ comment (l;some (l;none-of new-line))
+ _ (l;this new-line)]
+ (wrap [(|> where
+ (update@ #;line n.inc)
+ (set@ #;column +0))
+ comment])))
+
+## This is just a helper parser to find text which doesn't run into
+## any special character sequences for multi-line comments.
+(def: comment-bound^
+ (l;Lexer Unit)
+ ($_ p;either
+ (l;this new-line)
+ (l;this ")#")
+ (l;this "#(")))
+
+## Multi-line comments are bounded by #( these delimiters, #(and, they may
+## also be nested)# )#.
+## Multi-line comment syntax must be balanced.
+## That is, any nested comment must have matched delimiters.
+## Unbalanced comments ought to be rejected as invalid code.
+(def: (multi-line-comment^ where)
+ (-> Cursor (l;Lexer [Cursor Text]))
+ (do p;Monad<Parser>
+ [_ (l;this "#(")]
+ (loop [comment ""
+ where (update@ #;column (n.+ +2) where)]
+ ($_ p;either
+ ## These are normal chunks of commented text.
+ (do @
+ [chunk (l;many (l;not comment-bound^))]
+ (recur (format comment chunk)
+ (|> where
+ (update@ #;column (n.+ (text;size chunk))))))
+ ## This is a special rule to handle new-lines within
+ ## comments properly.
+ (do @
+ [_ (l;this new-line)]
+ (recur (format comment new-line)
+ (|> where
+ (update@ #;line n.inc)
+ (set@ #;column +0))))
+ ## This is the rule for handling nested sub-comments.
+ ## Ultimately, the whole comment is just treated as text
+ ## (the comment must respect the syntax structure, but the
+ ## output produced is just a block of text).
+ ## That is why the sub-comment is covered in delimiters
+ ## and then appended to the rest of the comment text.
+ (do @
+ [[sub-where sub-comment] (multi-line-comment^ where)]
+ (recur (format comment "#(" sub-comment ")#")
+ sub-where))
+ ## Finally, this is the rule for closing the comment.
+ (do @
+ [_ (l;this ")#")]
+ (wrap [(update@ #;column (n.+ +2) where)
+ comment]))
+ ))))
+
+## This is the only parser that should be used directly by other
+## parsers, since all comments must be treated as either being
+## single-line or multi-line.
+## That is, there is no syntactic rule prohibiting one type of comment
+## from being used in any situation (alternatively, forcing one type
+## of comment to be the only usable one).
+(def: (comment^ where)
+ (-> Cursor (l;Lexer [Cursor Text]))
+ (p;either (single-line-comment^ where)
+ (multi-line-comment^ where)))
+
+## To simplify parsing, I remove any left-padding that an Code token
+## may have prior to parsing the token itself.
+## Left-padding is assumed to be either white-space or a comment.
+## The cursor gets updated, but the padding gets ignored.
+(def: (left-padding^ where)
+ (-> Cursor (l;Lexer Cursor))
+ ($_ p;either
+ (do p;Monad<Parser>
+ [[where comment] (comment^ where)]
+ (left-padding^ where))
+ (do p;Monad<Parser>
+ [[where white-space] (space^ where)]
+ (left-padding^ where))
+ (:: p;Monad<Parser> wrap where)))
+
+## Escaped character sequences follow the usual syntax of
+## back-slash followed by a letter (e.g. \n).
+## Unicode escapes are possible, with hexadecimal sequences between 1
+## and 4 characters long (e.g. \u12aB).
+## Escaped characters may show up in Char and Text literals.
+(def: escaped-char^
+ (l;Lexer [Nat Text])
+ (p;after (l;this "\\")
+ (do p;Monad<Parser>
+ [code l;any]
+ (case code
+ ## Handle special cases.
+ "t" (wrap [+2 "\t"])
+ "v" (wrap [+2 "\v"])
+ "b" (wrap [+2 "\b"])
+ "n" (wrap [+2 "\n"])
+ "r" (wrap [+2 "\r"])
+ "f" (wrap [+2 "\f"])
+ "\"" (wrap [+2 "\""])
+ "\\" (wrap [+2 "\\"])
+
+ ## Handle unicode escapes.
+ "u"
+ (do p;Monad<Parser>
+ [code (l;between +1 +4 l;hexadecimal)]
+ (wrap (case (|> code (format "+") (:: number;Hex@Codec<Text,Nat> decode))
+ (#;Right value)
+ [(n.+ +2 (text;size code)) (text;from-code value)]
+
+ _
+ (undefined))))
+
+ _
+ (p;fail (format "Invalid escaping syntax: " (%t code)))))))
+
+## These are very simple parsers that just cut chunks of text in
+## specific shapes and then use decoders already present in the
+## standard library to actually produce the values from the literals.
+(def: rich-digit
+ (l;Lexer Text)
+ (p;either l;decimal
+ (p;after (l;this "_") (p/wrap ""))))
+
+(def: rich-digits^
+ (l;Lexer Text)
+ (l;seq l;decimal
+ (l;some rich-digit)))
+
+(def: (marker^ token)
+ (-> Text (l;Lexer Text))
+ (p;after (l;this token) (p/wrap token)))
+
+(do-template [<name> <tag> <lexer> <codec>]
+ [(def: #export (<name> where)
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (do p;Monad<Parser>
+ [chunk <lexer>]
+ (case (:: <codec> decode chunk)
+ (#;Left error)
+ (p;fail error)
+
+ (#;Right value)
+ (wrap [(update@ #;column (n.+ (text;size chunk)) where)
+ [where (<tag> value)]]))))]
+
+ [bool #;Bool
+ (p;either (marker^ "true") (marker^ "false"))
+ bool;Codec<Text,Bool>]
+
+ [int #;Int
+ (l;seq (p;default "" (l;one-of "-"))
+ rich-digits^)
+ number;Codec<Text,Int>]
+
+ [deg #;Deg
+ (l;seq (l;one-of ".")
+ rich-digits^)
+ number;Codec<Text,Deg>]
+ )
+
+(def: (nat-char where)
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (do p;Monad<Parser>
+ [_ (l;this "#\"")
+ [where' char] (: (l;Lexer [Cursor Text])
+ ($_ p;either
+ ## Normal text characters.
+ (do @
+ [normal (l;none-of "\\\"\n")]
+ (wrap [(|> where
+ (update@ #;column n.inc))
+ normal]))
+ ## Must handle escaped
+ ## chars separately.
+ (do @
+ [[chars-consumed char] escaped-char^]
+ (wrap [(|> where
+ (update@ #;column (n.+ chars-consumed)))
+ char]))))
+ _ (l;this "\"")
+ #let [char (maybe;assume (text;nth +0 char))]]
+ (wrap [(|> where'
+ (update@ #;column n.inc))
+ [where (#;Nat char)]])))
+
+(def: (normal-nat where)
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (do p;Monad<Parser>
+ [chunk (l;seq (l;one-of "+")
+ rich-digits^)]
+ (case (:: number;Codec<Text,Nat> decode chunk)
+ (#;Left error)
+ (p;fail error)
+
+ (#;Right value)
+ (wrap [(update@ #;column (n.+ (text;size chunk)) where)
+ [where (#;Nat value)]]))))
+
+(def: #export (nat where)
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (p;either (normal-nat where)
+ (nat-char where)))
+
+(def: (normal-frac where)
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (do p;Monad<Parser>
+ [chunk ($_ l;seq
+ (p;default "" (l;one-of "-"))
+ rich-digits^
+ (l;one-of ".")
+ rich-digits^
+ (p;default ""
+ ($_ l;seq
+ (l;one-of "eE")
+ (p;default "" (l;one-of "+-"))
+ rich-digits^)))]
+ (case (:: number;Codec<Text,Frac> decode chunk)
+ (#;Left error)
+ (p;fail error)
+
+ (#;Right value)
+ (wrap [(update@ #;column (n.+ (text;size chunk)) where)
+ [where (#;Frac value)]]))))
+
+(def: frac-ratio-fragment
+ (l;Lexer Frac)
+ (<| (p;codec number;Codec<Text,Frac>)
+ (:: p;Monad<Parser> map (function [digits]
+ (format digits ".0")))
+ rich-digits^))
+
+(def: (ratio-frac where)
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (do p;Monad<Parser>
+ [chunk ($_ l;seq
+ (p;default "" (l;one-of "-"))
+ rich-digits^
+ (l;one-of "/")
+ rich-digits^)
+ value (l;local chunk
+ (do @
+ [signed? (l;this? "-")
+ numerator frac-ratio-fragment
+ _ (l;this? "/")
+ denominator frac-ratio-fragment
+ _ (p;assert "Denominator cannot be 0."
+ (not (f.= 0.0 denominator)))]
+ (wrap (|> numerator
+ (f.* (if signed? -1.0 1.0))
+ (f./ denominator)))))]
+ (wrap [(update@ #;column (n.+ (text;size chunk)) where)
+ [where (#;Frac value)]])))
+
+(def: #export (frac where)
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (p;either (normal-frac where)
+ (ratio-frac where)))
+
+## This parser looks so complex because text in Lux can be multi-line
+## and there are rules regarding how this is handled.
+(def: #export (text where)
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (do p;Monad<Parser>
+ [## Lux text "is delimited by double-quotes", as usual in most
+ ## programming languages.
+ _ (l;this "\"")
+ ## I must know what column the text body starts at (which is
+ ## always 1 column after the left-delimiting quote).
+ ## This is important because, when procesing subsequent lines,
+ ## they must all start at the same column, being left-padded with
+ ## as many spaces as necessary to be column-aligned.
+ ## This helps ensure that the formatting on the text in the
+ ## source-code matches the formatting of the Text value.
+ #let [offset-column (n.inc (get@ #;column where))]
+ [where' text-read] (: (l;Lexer [Cursor Text])
+ ## I must keep track of how much of the
+ ## text body has been read, how far the
+ ## cursor has progressed, and whether I'm
+ ## processing a subsequent line, or just
+ ## processing normal text body.
+ (loop [text-read ""
+ where (|> where
+ (update@ #;column n.inc))
+ must-have-offset? false]
+ (p;either (if must-have-offset?
+ ## If I'm at the start of a
+ ## new line, I must ensure the
+ ## space-offset is at least
+ ## as great as the column of
+ ## the text's body's column,
+ ## to ensure they are aligned.
+ (do @
+ [offset (l;many (l;one-of " "))
+ #let [offset-size (text;size offset)]]
+ (if (n.>= offset-column offset-size)
+ ## Any extra offset
+ ## becomes part of the
+ ## text's body.
+ (recur (|> offset
+ (text;split offset-column)
+ (maybe;default (undefined))
+ product;right
+ (format text-read))
+ (|> where
+ (update@ #;column (n.+ offset-size)))
+ false)
+ (p;fail (format "Each line of a multi-line text must have an appropriate offset!\n"
+ "Expected: " (%i (nat-to-int offset-column)) " columns.\n"
+ " Actual: " (%i (nat-to-int offset-size)) " columns.\n"))))
+ ($_ p;either
+ ## Normal text characters.
+ (do @
+ [normal (l;many (l;none-of "\\\"\n"))]
+ (recur (format text-read normal)
+ (|> where
+ (update@ #;column (n.+ (text;size normal))))
+ false))
+ ## Must handle escaped
+ ## chars separately.
+ (do @
+ [[chars-consumed char] escaped-char^]
+ (recur (format text-read char)
+ (|> where
+ (update@ #;column (n.+ chars-consumed)))
+ false))
+ ## The text ends when it
+ ## reaches the right-delimiter.
+ (do @
+ [_ (l;this "\"")]
+ (wrap [(update@ #;column n.inc where)
+ text-read]))))
+ ## If a new-line is
+ ## encountered, it gets
+ ## appended to the value and
+ ## the loop is alerted that the
+ ## next line must have an offset.
+ (do @
+ [_ (l;this new-line)]
+ (recur (format text-read new-line)
+ (|> where
+ (update@ #;line n.inc)
+ (set@ #;column +0))
+ true)))))]
+ (wrap [where'
+ [where (#;Text text-read)]])))
+
+## Form and tuple syntax is mostly the same, differing only in the
+## delimiters involved.
+## They may have an arbitrary number of arbitrary Code nodes as elements.
+(do-template [<name> <tag> <open> <close>]
+ [(def: (<name> where ast)
+ (-> Cursor
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (l;Lexer [Cursor Code]))
+ (do p;Monad<Parser>
+ [_ (l;this <open>)
+ [where' elems] (loop [elems (: (Sequence Code)
+ sequence;empty)
+ where where]
+ (p;either (do @
+ [## Must update the cursor as I
+ ## go along, to keep things accurate.
+ [where' elem] (ast where)]
+ (recur (sequence;add elem elems)
+ where'))
+ (do @
+ [## Must take into account any
+ ## padding present before the
+ ## end-delimiter.
+ where' (left-padding^ where)
+ _ (l;this <close>)]
+ (wrap [(update@ #;column n.inc where')
+ (sequence;to-list elems)]))))]
+ (wrap [where'
+ [where (<tag> elems)]])))]
+
+ [form #;Form "(" ")"]
+ [tuple #;Tuple "[" "]"]
+ )
+
+## Records are almost (syntactically) the same as forms and tuples,
+## with the exception that their elements must come in pairs (as in
+## key-value pairs).
+## Semantically, though, records and tuples are just 2 different
+## representations for the same thing (a tuple).
+## In normal Lux syntax, the key position in the pair will be a tag
+## Code node, however, record Code nodes allow any Code node to occupy
+## this position, since it may be useful when processing Code syntax in
+## macros.
+(def: (record where ast)
+ (-> Cursor
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (l;Lexer [Cursor Code]))
+ (do p;Monad<Parser>
+ [_ (l;this "{")
+ [where' elems] (loop [elems (: (Sequence [Code Code])
+ sequence;empty)
+ where where]
+ (p;either (do @
+ [[where' key] (ast where)
+ [where' val] (ast where')]
+ (recur (sequence;add [key val] elems)
+ where'))
+ (do @
+ [where' (left-padding^ where)
+ _ (l;this "}")]
+ (wrap [(update@ #;column n.inc where')
+ (sequence;to-list elems)]))))]
+ (wrap [where'
+ [where (#;Record elems)]])))
+
+## The parts of an identifier are separated by a single mark.
+## E.g. module;name.
+## Only one such mark may be used in an identifier, since there
+## can only be 2 parts to an identifier (the module [before the
+## mark], and the name [after the mark]).
+## There are also some extra rules regarding identifier syntax,
+## encoded on the parser.
+(def: identifier-separator Text ";")
+
+## A Lux identifier is a pair of chunks of text, where the first-part
+## refers to the module that gives context to the identifier, and the
+## second part corresponds to the name of the identifier itself.
+## The module part may be absent (by being the empty text ""), but the
+## name part must always be present.
+## The rules for which characters you may use are specified in terms
+## of which characters you must avoid (to keep things as open-ended as
+## possible).
+## In particular, no white-space can be used, and neither can other
+## characters which are already used by Lux as delimiters for other
+## Code nodes (thereby reducing ambiguity while parsing).
+## Additionally, the first character in an identifier's part cannot be
+## a digit, to avoid confusion with regards to numbers.
+(def: ident-part^
+ (l;Lexer Text)
+ (do p;Monad<Parser>
+ [#let [digits "0123456789"
+ delimiters (format "()[]{}#\"" identifier-separator)
+ space (format white-space new-line)
+ head-lexer (l;none-of (format digits delimiters space))
+ tail-lexer (l;some (l;none-of (format delimiters space)))]
+ head head-lexer
+ tail tail-lexer]
+ (wrap (format head tail))))
+
+(def: ident^
+ (l;Lexer [Ident Nat])
+ ($_ p;either
+ ## When an identifier starts with 2 marks, it's module is
+ ## taken to be the current-module being compiled at the moment.
+ ## This can be useful when mentioning identifiers and tags
+ ## inside quoted/templated code in macros.
+ (do p;Monad<Parser>
+ [#let [current-module-mark (format identifier-separator identifier-separator)]
+ _ (l;this current-module-mark)
+ def-name ident-part^]
+ (p;fail (format "Cannot handle " current-module-mark " syntax for identifiers.")))
+ ## If the identifier is prefixed by the mark, but no module
+ ## part, the module is assumed to be "lux" (otherwise known as
+ ## the 'prelude').
+ ## This makes it easy to refer to definitions in that module,
+ ## since it is the most fundamental module in the entire
+ ## standard library.
+ (do p;Monad<Parser>
+ [_ (l;this identifier-separator)
+ def-name ident-part^]
+ (wrap [["lux" def-name]
+ (n.inc (text;size def-name))]))
+ ## Not all identifiers must be specified with a module part.
+ ## If that part is not provided, the identifier will be created
+ ## with the empty "" text as the module.
+ ## During program analysis, such identifiers tend to be treated
+ ## as if their context is the current-module, but this only
+ ## applies to identifiers for tags and module definitions.
+ ## Function arguments and local-variables may not be referred-to
+ ## using identifiers with module parts, so being able to specify
+ ## identifiers with empty modules helps with those use-cases.
+ (do p;Monad<Parser>
+ [first-part ident-part^]
+ (p;either (do @
+ [_ (l;this identifier-separator)
+ second-part ident-part^]
+ (wrap [[first-part second-part]
+ ($_ n.+
+ (text;size first-part)
+ +1
+ (text;size second-part))]))
+ (wrap [["" first-part]
+ (text;size first-part)])))))
+
+## The only (syntactic) difference between a symbol and a tag (both
+## being identifiers), is that tags must be prefixed with a hash-sign
+## (i.e. #).
+## Semantically, though, they are very different, with symbols being
+## used to refer to module definitions and local variables, while tags
+## provide the compiler with information related to data-structure
+## construction and de-structuring (during pattern-matching).
+(do-template [<name> <tag> <lexer> <extra>]
+ [(def: #export (<name> where)
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (do p;Monad<Parser>
+ [[value length] <lexer>]
+ (wrap [(update@ #;column (|>. ($_ n.+ <extra> length)) where)
+ [where (<tag> value)]])))]
+
+ [symbol #;Symbol ident^ +0]
+ [tag #;Tag (p;after (l;this "#") ident^) +1]
+ )
+
+(def: (ast where)
+ (-> Cursor (l;Lexer [Cursor Code]))
+ (do p;Monad<Parser>
+ [where (left-padding^ where)]
+ ($_ p;either
+ (form where ast)
+ (tuple where ast)
+ (record where ast)
+ (bool where)
+ (nat where)
+ (frac where)
+ (int where)
+ (deg where)
+ (symbol where)
+ (tag where)
+ (text where)
+ )))
+
+(def: #export (parse [where offset source])
+ (-> Source (e;Error [Source Code]))
+ (case (p;run [offset source] (ast where))
+ (#e;Error error)
+ (#e;Error error)
+
+ (#e;Success [[offset' remaining] [where' output]])
+ (#e;Success [[where' offset' remaining] output])))