aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/analyser')
-rw-r--r--new-luxc/source/luxc/analyser/case.lux260
-rw-r--r--new-luxc/source/luxc/analyser/case/coverage.lux299
-rw-r--r--new-luxc/source/luxc/analyser/common.lux41
-rw-r--r--new-luxc/source/luxc/analyser/function.lux111
-rw-r--r--new-luxc/source/luxc/analyser/inference.lux228
-rw-r--r--new-luxc/source/luxc/analyser/primitive.lux34
-rw-r--r--new-luxc/source/luxc/analyser/procedure.lux23
-rw-r--r--new-luxc/source/luxc/analyser/procedure/common.lux418
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux1241
-rw-r--r--new-luxc/source/luxc/analyser/reference.lux53
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux311
-rw-r--r--new-luxc/source/luxc/analyser/type.lux31
12 files changed, 0 insertions, 3050 deletions
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux
deleted file mode 100644
index 29256865a..000000000
--- a/new-luxc/source/luxc/analyser/case.lux
+++ /dev/null
@@ -1,260 +0,0 @@
-(;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])))
- (../.. ["&" base]
- (lang ["la" analysis])
- ["&;" scope])
- (.. ["&;" common]
- ["&;" structure])
- (. ["&&;" coverage]))
-
-(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 (&structure;normalize record)
- [members recordT] (&structure;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] (&common;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 &&coverage;determine)
- outputTC (monad;map @ (|>. product;left &&coverage;determine) outputT)
- _ (case (monad;fold e;Monad<Error> &&coverage;merge outputHC outputTC)
- (#e;Success coverage)
- (if (&&coverage;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/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux
deleted file mode 100644
index 554aea1a8..000000000
--- a/new-luxc/source/luxc/analyser/case/coverage.lux
+++ /dev/null
@@ -1,299 +0,0 @@
-(;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/analyser/common.lux b/new-luxc/source/luxc/analyser/common.lux
deleted file mode 100644
index 4cbf5aedf..000000000
--- a/new-luxc/source/luxc/analyser/common.lux
+++ /dev/null
@@ -1,41 +0,0 @@
-(;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/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux
deleted file mode 100644
index 3d2da6326..000000000
--- a/new-luxc/source/luxc/analyser/function.lux
+++ /dev/null
@@ -1,111 +0,0 @@
-(;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]
- [";L" variable #+ Variable])
- ["&;" scope]
- (analyser ["&;" common]
- ["&;" inference])))
-
-(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/analyser/inference.lux b/new-luxc/source/luxc/analyser/inference.lux
deleted file mode 100644
index 049abec28..000000000
--- a/new-luxc/source/luxc/analyser/inference.lux
+++ /dev/null
@@ -1,228 +0,0 @@
-(;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])
- (analyser ["&;" 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/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux
deleted file mode 100644
index c7f7243fd..000000000
--- a/new-luxc/source/luxc/analyser/primitive.lux
+++ /dev/null
@@ -1,34 +0,0 @@
-(;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/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux
deleted file mode 100644
index 225fb7b23..000000000
--- a/new-luxc/source/luxc/analyser/procedure.lux
+++ /dev/null
@@ -1,23 +0,0 @@
-(;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/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux
deleted file mode 100644
index 0fad41958..000000000
--- a/new-luxc/source/luxc/analyser/procedure/common.lux
+++ /dev/null
@@ -1,418 +0,0 @@
-(;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])
- (analyser ["&;" 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/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
deleted file mode 100644
index 015379a1b..000000000
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ /dev/null
@@ -1,1241 +0,0 @@
-(;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])
- (analyser ["&;" 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/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux
deleted file mode 100644
index 5bc1f96c9..000000000
--- a/new-luxc/source/luxc/analyser/reference.lux
+++ /dev/null
@@ -1,53 +0,0 @@
-(;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/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux
deleted file mode 100644
index d523065ea..000000000
--- a/new-luxc/source/luxc/analyser/structure.lux
+++ /dev/null
@@ -1,311 +0,0 @@
-(;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])
- ["&;" module]
- ["&;" scope]
- (analyser ["&;" common]
- ["&;" inference])))
-
-(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/analyser/type.lux b/new-luxc/source/luxc/analyser/type.lux
deleted file mode 100644
index d0b038d93..000000000
--- a/new-luxc/source/luxc/analyser/type.lux
+++ /dev/null
@@ -1,31 +0,0 @@
-(;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))))