From 4433c9bcd6c6cac44c018aad2e21a5b4d7cc4896 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Wed, 29 Nov 2017 22:49:56 -0400
Subject: - Adapted main codebase to the latest syntatic changes.
---
new-luxc/source/luxc/lang/analysis/case.lux | 312 +++---
.../source/luxc/lang/analysis/case/coverage.lux | 106 +-
new-luxc/source/luxc/lang/analysis/common.lux | 12 +-
new-luxc/source/luxc/lang/analysis/expression.lux | 106 +-
new-luxc/source/luxc/lang/analysis/function.lux | 84 +-
new-luxc/source/luxc/lang/analysis/inference.lux | 188 ++--
new-luxc/source/luxc/lang/analysis/primitive.lux | 22 +-
new-luxc/source/luxc/lang/analysis/procedure.lux | 20 +-
.../source/luxc/lang/analysis/procedure/common.lux | 168 +--
.../luxc/lang/analysis/procedure/host.jvm.lux | 1130 ++++++++++----------
new-luxc/source/luxc/lang/analysis/reference.lux | 44 +-
new-luxc/source/luxc/lang/analysis/structure.lux | 278 ++---
new-luxc/source/luxc/lang/analysis/type.lux | 18 +-
13 files changed, 1244 insertions(+), 1244 deletions(-)
(limited to 'new-luxc/source/luxc/lang/analysis')
diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux
index 949e18a26..16f775907 100644
--- a/new-luxc/source/luxc/lang/analysis/case.lux
+++ b/new-luxc/source/luxc/lang/analysis/case.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:]
@@ -16,11 +16,11 @@
(lang [type]
(type ["tc" check])))
(luxc ["&" lang]
- (lang ["&;" scope]
+ (lang ["&." scope]
["la" analysis]
- (analysis [";A" common]
- [";A" structure]
- (case [";A" coverage])))))
+ (analysis [".A" common]
+ [".A" structure]
+ (case [".A" coverage])))))
(exception: #export Cannot-Match-Type-With-Pattern)
(exception: #export Sum-Type-Has-No-Case)
@@ -38,11 +38,11 @@
(def: (re-quantify envs baseT)
(-> (List (List Type)) Type Type)
(case envs
- #;Nil
+ #.Nil
baseT
- (#;Cons head tail)
- (re-quantify tail (#;UnivQ head baseT))))
+ (#.Cons head tail)
+ (re-quantify tail (#.UnivQ head baseT))))
## Type-checking on the input value is done during the analysis of a
## "case" expression, to ensure that the patterns being used make
@@ -57,70 +57,70 @@
(list))
caseT caseT]
(case caseT
- (#;Var id)
- (do macro;Monad
- [?caseT' (&;with-type-env
- (tc;read id))]
+ (#.Var id)
+ (do macro.Monad
+ [?caseT' (&.with-type-env
+ (tc.read id))]
(case ?caseT'
- (#;Some caseT')
+ (#.Some caseT')
(recur envs caseT')
_
- (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+ (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
- (#;Named name unnamedT)
+ (#.Named name unnamedT)
(recur envs unnamedT)
- (#;UnivQ env unquantifiedT)
- (recur (#;Cons env envs) unquantifiedT)
+ (#.UnivQ env unquantifiedT)
+ (recur (#.Cons env envs) unquantifiedT)
## (^template [ ]
## ( _)
- ## (do macro;Monad
- ## [[_ instanceT] (&;with-type-env
+ ## (do macro.Monad
+ ## [[_ instanceT] (&.with-type-env
## )]
- ## (recur (maybe;assume (type;apply (list instanceT) caseT)))))
- ## ([#;UnivQ tc;var]
- ## [#;ExQ tc;existential])
+ ## (recur (maybe.assume (type.apply (list instanceT) caseT)))))
+ ## ([#.UnivQ tc.var]
+ ## [#.ExQ tc.existential])
- (#;ExQ _)
- (do macro;Monad
- [[ex-id exT] (&;with-type-env
- tc;existential)]
- (recur envs (maybe;assume (type;apply (list exT) caseT))))
+ (#.ExQ _)
+ (do macro.Monad
+ [[ex-id exT] (&.with-type-env
+ tc.existential)]
+ (recur envs (maybe.assume (type.apply (list exT) caseT))))
- (#;Apply inputT funcT)
+ (#.Apply inputT funcT)
(case funcT
- (#;Var funcT-id)
- (do macro;Monad
- [funcT' (&;with-type-env
- (do tc;Monad
- [?funct' (tc;read funcT-id)]
+ (#.Var funcT-id)
+ (do macro.Monad
+ [funcT' (&.with-type-env
+ (do tc.Monad
+ [?funct' (tc.read funcT-id)]
(case ?funct'
- (#;Some funct')
+ (#.Some funct')
(wrap funct')
_
- (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))]
- (recur envs (#;Apply inputT funcT')))
+ (tc.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))]
+ (recur envs (#.Apply inputT funcT')))
_
- (case (type;apply (list inputT) funcT)
- (#;Some outputT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
(recur envs outputT)
- #;None
- (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+ #.None
+ (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
- (#;Product _)
+ (#.Product _)
(|> caseT
- type;flatten-tuple
+ type.flatten-tuple
(list/map (re-quantify envs))
- type;tuple
- (:: macro;Monad wrap))
+ type.tuple
+ (:: macro.Monad wrap))
_
- (:: macro;Monad wrap (re-quantify envs caseT)))))
+ (:: macro.Monad wrap (re-quantify envs caseT)))))
## This function handles several concerns at once, but it must be that
## way because those concerns are interleaved when doing
@@ -139,169 +139,169 @@
## 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])))
+ (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a])))
(case pattern
- [cursor (#;Symbol ["" name])]
- (&;with-cursor cursor
- (do macro;Monad
- [outputA (&scope;with-local [name inputT]
+ [cursor (#.Symbol ["" name])]
+ (&.with-cursor cursor
+ (do macro.Monad
+ [outputA (&scope.with-local [name inputT]
next)
- idx &scope;next-local]
- (wrap [(` ("lux case bind" (~ (code;nat idx)))) outputA])))
+ idx &scope.next-local]
+ (wrap [(` ("lux case bind" (~ (code.nat idx)))) outputA])))
- [cursor (#;Symbol ident)]
- (&;with-cursor cursor
- (&;throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident)))
+ [cursor (#.Symbol ident)]
+ (&.with-cursor cursor
+ (&.throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident)))
(^template [ ]
[cursor ( test)]
- (&;with-cursor cursor
- (do macro;Monad
- [_ (&;with-type-env
- (tc;check inputT ))
+ (&.with-cursor cursor
+ (do macro.Monad
+ [_ (&.with-type-env
+ (tc.check inputT ))
outputA next]
(wrap [pattern outputA]))))
- ([Bool #;Bool]
- [Nat #;Nat]
- [Int #;Int]
- [Deg #;Deg]
- [Frac #;Frac]
- [Text #;Text])
-
- (^ [cursor (#;Tuple (list))])
- (&;with-cursor cursor
- (do macro;Monad
- [_ (&;with-type-env
- (tc;check inputT Unit))
+ ([Bool #.Bool]
+ [Nat #.Nat]
+ [Int #.Int]
+ [Deg #.Deg]
+ [Frac #.Frac]
+ [Text #.Text])
+
+ (^ [cursor (#.Tuple (list))])
+ (&.with-cursor cursor
+ (do macro.Monad
+ [_ (&.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 (list singleton))])
+ (analyse-pattern #.None inputT singleton next)
- [cursor (#;Tuple sub-patterns)]
- (&;with-cursor cursor
- (do macro;Monad
+ [cursor (#.Tuple sub-patterns)]
+ (&.with-cursor cursor
+ (do macro.Monad
[inputT' (simplify-case-type inputT)]
(case inputT'
- (#;Product _)
- (let [sub-types (type;flatten-tuple inputT')
- num-sub-types (maybe;default (list;size sub-types)
+ (#.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)))))
+ 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)
+ ## (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])))
+ (-> [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])))
+ [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a])))
analyse-pattern)
- #;None memberT memberC then)]
+ #.None memberT memberC then)]
(wrap [(list& memberP memberP+) thenA]))))
(do @
[nextA next]
(wrap [(list) nextA]))
- (list;reverse matches))]
+ (list.reverse matches))]
(wrap [(` ("lux case tuple" [(~@ memberP+)]))
thenA])))
_
- (&;throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))
+ (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))
)))
- [cursor (#;Record record)]
- (do macro;Monad
- [record (structureA;normalize record)
- [members recordT] (structureA;order record)
- _ (&;with-type-env
- (tc;check inputT recordT))]
- (analyse-pattern (#;Some (list;size members)) inputT [cursor (#;Tuple members)] next))
-
- [cursor (#;Tag tag)]
- (&;with-cursor cursor
- (analyse-pattern #;None inputT (` ((~ pattern))) next))
-
- (^ [cursor (#;Form (list& [_ (#;Nat idx)] values))])
- (&;with-cursor cursor
- (do macro;Monad
+ [cursor (#.Record record)]
+ (do macro.Monad
+ [record (structureA.normalize record)
+ [members recordT] (structureA.order record)
+ _ (&.with-type-env
+ (tc.check inputT recordT))]
+ (analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next))
+
+ [cursor (#.Tag tag)]
+ (&.with-cursor cursor
+ (analyse-pattern #.None inputT (` ((~ pattern))) next))
+
+ (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))])
+ (&.with-cursor cursor
+ (do macro.Monad
[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 macro;Monad
- [[testP nextA] (analyse-pattern #;None
- (type;variant (list;drop (n.dec num-cases) flat-sum))
+ (#.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 macro.Monad
+ [[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)))
+ (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP)))
nextA]))
- (do macro;Monad
- [[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)]
- (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
+ (do macro.Monad
+ [[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
+ (&.throw Sum-Type-Has-No-Case
(format "Case: " (%n idx) "\n"
"Type: " (%type inputT)))))
_
- (&;throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)))))
+ (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)))))
- (^ [cursor (#;Form (list& [_ (#;Tag tag)] values))])
- (&;with-cursor cursor
- (do macro;Monad
- [tag (macro;normalize tag)
- [idx group variantT] (macro;resolve-tag tag)
- _ (&;with-type-env
- (tc;check inputT variantT))]
- (analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next)))
+ (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))])
+ (&.with-cursor cursor
+ (do macro.Monad
+ [tag (macro.normalize tag)
+ [idx group variantT] (macro.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))
+ (&.throw Unrecognized-Pattern-Syntax (%code pattern))
))
(def: #export (analyse-case analyse inputC branches)
- (-> &;Analyser Code (List [Code Code]) (Meta la;Analysis))
+ (-> &.Analyser Code (List [Code Code]) (Meta la.Analysis))
(case branches
- #;Nil
- (&;throw Cannot-Have-Empty-Branches "")
+ #.Nil
+ (&.throw Cannot-Have-Empty-Branches "")
- (#;Cons [patternH bodyH] branchesT)
- (do macro;Monad
- [[inputT inputA] (commonA;with-unknown-type
+ (#.Cons [patternH bodyH] branchesT)
+ (do macro.Monad
+ [[inputT inputA] (commonA.with-unknown-type
(analyse inputC))
- outputH (analyse-pattern #;None inputT patternH (analyse bodyH))
- outputT (monad;map @
+ outputH (analyse-pattern #.None inputT patternH (analyse bodyH))
+ outputT (monad.map @
(function [[patternT bodyT]]
- (analyse-pattern #;None inputT patternT (analyse bodyT)))
+ (analyse-pattern #.None inputT patternT (analyse bodyT)))
branchesT)
- outputHC (|> outputH product;left coverageA;determine)
- outputTC (monad;map @ (|>. product;left coverageA;determine) outputT)
- _ (case (monad;fold e;Monad coverageA;merge outputHC outputTC)
- (#e;Success coverage)
- (&;assert Non-Exhaustive-Pattern-Matching ""
- (coverageA;exhaustive? coverage))
-
- (#e;Error error)
- (&;fail error))]
- (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT)))))))))
+ outputHC (|> outputH product.left coverageA.determine)
+ outputTC (monad.map @ (|>> product.left coverageA.determine) outputT)
+ _ (case (monad.fold e.Monad coverageA.merge outputHC outputTC)
+ (#e.Success coverage)
+ (&.assert Non-Exhaustive-Pattern-Matching ""
+ (coverageA.exhaustive? coverage))
+
+ (#e.Error error)
+ (&.fail error))]
+ (wrap (` ("lux case" (~ inputA) (~ (code.record (list& outputH outputT)))))))))
diff --git a/new-luxc/source/luxc/lang/analysis/case/coverage.lux b/new-luxc/source/luxc/lang/analysis/case/coverage.lux
index 283e21d02..5d34387b4 100644
--- a/new-luxc/source/luxc/lang/analysis/case/coverage.lux
+++ b/new-luxc/source/luxc/lang/analysis/case/coverage.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:]
@@ -45,7 +45,7 @@
(exception: #export Unknown-Pattern)
(def: #export (determine pattern)
- (-> la;Pattern (Meta Coverage))
+ (-> la.Pattern (Meta Coverage))
(case pattern
## Binding amounts to exhaustive coverage because any value can be
## matched that way.
@@ -59,14 +59,14 @@
## Primitive patterns always have partial coverage because there
## are too many possibilities as far as values go.
- (^or [_ (#;Nat _)] [_ (#;Int _)] [_ (#;Deg _)]
- [_ (#;Frac _)] [_ (#;Text _)])
+ (^or [_ (#.Nat _)] [_ (#.Int _)] [_ (#.Deg _)]
+ [_ (#.Frac _)] [_ (#.Text _)])
(macro/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)]
+ [_ (#.Bool value)]
(macro/wrap (#Bool value))
## Tuple patterns can be exhaustive if there is exhaustiveness for all of
@@ -74,11 +74,11 @@
(^code ("lux case tuple" [(~@ subs)]))
(loop [subs subs]
(case subs
- #;Nil
+ #.Nil
(macro/wrap #Exhaustive)
- (#;Cons sub subs')
- (do macro;Monad
+ (#.Cons sub subs')
+ (do macro.Monad
[pre (determine sub)
post (recur subs')]
(if (exhaustive? post)
@@ -87,15 +87,15 @@
## 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 macro;Monad
+ (^code ("lux case variant" (~ [_ (#.Nat tag-id)]) (~ [_ (#.Nat num-tags)]) (~ sub)))
+ (do macro.Monad
[=sub (determine sub)]
(wrap (#Variant num-tags
- (|> (dict;new number;Hash)
- (dict;put tag-id =sub)))))
+ (|> (dict.new number.Hash)
+ (dict.put tag-id =sub)))))
_
- (&;throw Unknown-Pattern (%code pattern))))
+ (&.throw Unknown-Pattern (%code pattern))))
(def: (xor left right)
(-> Bool Bool Bool)
@@ -109,8 +109,8 @@
## 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."))
+ (e.Error Coverage)
+ (e.fail "Redundant pattern."))
(def: (flatten-alt coverage)
(-> Coverage (List Coverage))
@@ -131,8 +131,8 @@
(bool/= sideR sideS)
[(#Variant allR casesR) (#Variant allS casesS)]
- (and (n.= allR allS)
- (:: (dict;Eq =) = casesR casesS))
+ (and (n/= allR allS)
+ (:: (dict.Eq =) = casesR casesS))
[(#Seq leftR rightR) (#Seq leftS rightS)]
(and (= leftR leftS)
@@ -141,10 +141,10 @@
[(#Alt _) (#Alt _)]
(let [flatR (flatten-alt reference)
flatS (flatten-alt sample)]
- (and (n.= (list;size flatR) (list;size flatS))
- (list;every? (function [[coverageR coverageS]]
+ (and (n/= (list.size flatR) (list.size flatS))
+ (list.every? (function [[coverageR coverageS]]
(= coverageR coverageS))
- (list;zip2 flatR flatS))))
+ (list.zip2 flatR flatS))))
_
false)))
@@ -156,7 +156,7 @@
## pattern-matching expression is exhaustive and whether it contains
## redundant patterns.
(def: #export (merge addition so-far)
- (-> Coverage Coverage (e;Error Coverage))
+ (-> Coverage Coverage (e.Error Coverage))
(case [addition so-far]
## The addition cannot possibly improve the coverage.
[_ #Exhaustive]
@@ -175,28 +175,28 @@
(error/wrap #Exhaustive)
[(#Variant allA casesA) (#Variant allSF casesSF)]
- (cond (not (n.= allSF allA))
- (e;fail "Variants do not match.")
+ (cond (not (n/= allSF allA))
+ (e.fail "Variants do not match.")
- (:: (dict;Eq Eq) = casesSF casesA)
+ (:: (dict.Eq Eq) = casesSF casesA)
redundant-pattern
## else
- (do e;Monad
- [casesM (monad;fold @
+ (do e.Monad
+ [casesM (monad.fold @
(function [[tagA coverageA] casesSF']
- (case (dict;get tagA casesSF')
- (#;Some coverageSF)
+ (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)))
+ (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)))))
@@ -212,7 +212,7 @@
## Same prefix
[true false]
- (do e;Monad
+ (do e.Monad
[rightM (merge rightA rightSF)]
(if (exhaustive? rightM)
## If all that follows is exhaustive, then it can be safely dropped
@@ -223,7 +223,7 @@
## Same suffix
[false true]
- (do e;Monad
+ (do e.Monad
[leftM (merge leftA leftSF)]
(wrap (#Seq leftM rightA))))
@@ -247,48 +247,48 @@
## This process must be repeated until no further productive
## merges can be done.
[_ (#Alt leftS rightS)]
- (do e;Monad
+ (do e.Monad
[#let [fuse-once (: (-> Coverage (List Coverage)
- (e;Error [(Maybe Coverage)
+ (e.Error [(Maybe Coverage)
(List Coverage)]))
(function [coverage possibilities]
(loop [alts possibilities]
(case alts
- #;Nil
- (wrap [#;None (list coverage)])
+ #.Nil
+ (wrap [#.None (list coverage)])
- (#;Cons alt alts')
+ (#.Cons alt alts')
(case (merge coverage alt)
- (#e;Success altM)
+ (#e.Success altM)
(case altM
(#Alt _)
(do @
[[success alts+] (recur alts')]
- (wrap [success (#;Cons alt alts+)]))
+ (wrap [success (#.Cons alt alts+)]))
_
- (wrap [(#;Some altM) alts']))
+ (wrap [(#.Some altM) alts']))
- (#e;Error error)
- (e;fail error))
+ (#e.Error error)
+ (e.fail error))
))))]
[success possibilities] (fuse-once addition (flatten-alt so-far))]
(loop [success success
possibilities possibilities]
(case success
- (#;Some coverage')
+ (#.Some coverage')
(do @
[[success' possibilities'] (fuse-once coverage' possibilities)]
(recur success' possibilities'))
- #;None
- (case (list;reverse possibilities)
- (#;Cons last prevs)
+ #.None
+ (case (list.reverse possibilities)
+ (#.Cons last prevs)
(wrap (list/fold (function [left right] (#Alt left right))
last
prevs))
- #;Nil
+ #.Nil
(undefined)))))
_
diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux
index c1a2a4f5b..aeed656a8 100644
--- a/new-luxc/source/luxc/lang/analysis/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/common.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
lux
(lux (control monad
["ex" exception #+ exception:])
@@ -12,18 +12,18 @@
(def: #export (with-unknown-type action)
(All [a] (-> (Meta a) (Meta [Type a])))
- (do macro;Monad
- [[_ varT] (&;with-type-env tc;var)
- analysis (&;with-type varT
+ (do macro.Monad
+ [[_ varT] (&.with-type-env tc.var)
+ analysis (&.with-type varT
action)
- knownT (&;with-type-env (tc;clean varT))]
+ knownT (&.with-type-env (tc.clean varT))]
(wrap [knownT analysis])))
(exception: #export Variant-Tag-Out-Of-Bounds)
(def: #export (variant-out-of-bounds-error type size tag)
(All [a] (-> Type Nat Nat (Meta a)))
- (&;throw Variant-Tag-Out-Of-Bounds
+ (&.throw Variant-Tag-Out-Of-Bounds
(format " Tag: " (%n tag) "\n"
"Variant Size: " (%n size) "\n"
"Variant Type: " (%type type))))
diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux
index b16499c01..0f3cdcf6e 100644
--- a/new-luxc/source/luxc/lang/analysis/expression.lux
+++ b/new-luxc/source/luxc/lang/analysis/expression.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
@@ -10,94 +10,94 @@
(type ["tc" check]))
[host])
(luxc ["&" lang]
- (lang ["&;" module]
- [";L" host]
- [";L" macro]
+ (lang ["&." module]
+ [".L" host]
+ [".L" macro]
["la" analysis]
- (translation [";T" common])))
- (// [";A" common]
- [";A" function]
- [";A" primitive]
- [";A" reference]
- [";A" structure]
- [";A" procedure]))
+ (translation [".T" common])))
+ (// [".A" common]
+ [".A" function]
+ [".A" primitive]
+ [".A" reference]
+ [".A" structure]
+ [".A" procedure]))
(exception: #export Macro-Expression-Must-Have-Single-Expansion)
(exception: #export Unrecognized-Syntax)
(exception: #export Macro-Expansion-Failed)
(def: #export (analyser eval)
- (-> &;Eval &;Analyser)
- (: (-> Code (Meta la;Analysis))
+ (-> &.Eval &.Analyser)
+ (: (-> Code (Meta la.Analysis))
(function analyse [code]
- (do macro;Monad
- [expectedT macro;expected-type]
+ (do macro.Monad
+ [expectedT macro.expected-type]
(let [[cursor code'] code]
## The cursor must be set in the compiler for the sake
## of having useful error messages.
- (&;with-cursor cursor
+ (&.with-cursor cursor
(case code'
(^template [ ]
( value)
( value))
- ([#;Bool primitiveA;analyse-bool]
- [#;Nat primitiveA;analyse-nat]
- [#;Int primitiveA;analyse-int]
- [#;Deg primitiveA;analyse-deg]
- [#;Frac primitiveA;analyse-frac]
- [#;Text primitiveA;analyse-text])
+ ([#.Bool primitiveA.analyse-bool]
+ [#.Nat primitiveA.analyse-nat]
+ [#.Int primitiveA.analyse-int]
+ [#.Deg primitiveA.analyse-deg]
+ [#.Frac primitiveA.analyse-frac]
+ [#.Text primitiveA.analyse-text])
- (^ (#;Tuple (list)))
- primitiveA;analyse-unit
+ (^ (#.Tuple (list)))
+ primitiveA.analyse-unit
## Singleton tuples are equivalent to the element they contain.
- (^ (#;Tuple (list singleton)))
+ (^ (#.Tuple (list singleton)))
(analyse singleton)
- (^ (#;Tuple elems))
- (structureA;analyse-product analyse elems)
+ (^ (#.Tuple elems))
+ (structureA.analyse-product analyse elems)
- (^ (#;Record pairs))
- (structureA;analyse-record analyse pairs)
+ (^ (#.Record pairs))
+ (structureA.analyse-record analyse pairs)
- (#;Symbol reference)
- (referenceA;analyse-reference reference)
+ (#.Symbol reference)
+ (referenceA.analyse-reference reference)
- (^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
- (procedureA;analyse-procedure analyse eval proc-name proc-args)
+ (^ (#.Form (list& [_ (#.Text proc-name)] proc-args)))
+ (procedureA.analyse-procedure analyse eval proc-name proc-args)
(^template [ ]
- (^ (#;Form (list& [_ ( tag)]
+ (^ (#.Form (list& [_ ( tag)]
values)))
(case values
- (#;Cons value #;Nil)
+ (#.Cons value #.Nil)
( analyse tag value)
_
( analyse tag (` [(~@ values)]))))
- ([#;Nat structureA;analyse-sum]
- [#;Tag structureA;analyse-tagged-sum])
+ ([#.Nat structureA.analyse-sum]
+ [#.Tag structureA.analyse-tagged-sum])
- (#;Tag tag)
- (structureA;analyse-tagged-sum analyse tag (' []))
+ (#.Tag tag)
+ (structureA.analyse-tagged-sum analyse tag (' []))
- (^ (#;Form (list& func args)))
- (do macro;Monad
- [[funcT funcA] (commonA;with-unknown-type
+ (^ (#.Form (list& func args)))
+ (do macro.Monad
+ [[funcT funcA] (commonA.with-unknown-type
(analyse func))]
(case funcA
- [_ (#;Symbol def-name)]
+ [_ (#.Symbol def-name)]
(do @
- [?macro (&;with-error-tracking
- (macro;find-macro def-name))]
+ [?macro (&.with-error-tracking
+ (macro.find-macro def-name))]
(case ?macro
- (#;Some macro)
+ (#.Some macro)
(do @
[expansion (: (Meta (List Code))
(function [compiler]
- (case (macroL;expand macro args compiler)
- (#e;Error error)
- ((&;throw Macro-Expansion-Failed error) compiler)
+ (case (macroL.expand macro args compiler)
+ (#e.Error error)
+ ((&.throw Macro-Expansion-Failed error) compiler)
output
output)))]
@@ -106,14 +106,14 @@
(analyse single)
_
- (&;throw Macro-Expression-Must-Have-Single-Expansion (%code code))))
+ (&.throw Macro-Expression-Must-Have-Single-Expansion (%code code))))
_
- (functionA;analyse-apply analyse funcT funcA args)))
+ (functionA.analyse-apply analyse funcT funcA args)))
_
- (functionA;analyse-apply analyse funcT funcA args)))
+ (functionA.analyse-apply analyse funcT funcA args)))
_
- (&;throw Unrecognized-Syntax (%code code))
+ (&.throw Unrecognized-Syntax (%code code))
)))))))
diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux
index b4aa31c90..758acd681 100644
--- a/new-luxc/source/luxc/lang/analysis/function.lux
+++ b/new-luxc/source/luxc/lang/analysis/function.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
lux
(lux (control monad
["ex" exception #+ exception:])
@@ -11,11 +11,11 @@
(lang [type]
(type ["tc" check])))
(luxc ["&" lang]
- (lang ["&;" scope]
+ (lang ["&." scope]
["la" analysis #+ Analysis]
- (analysis ["&;" common]
- ["&;" inference])
- [";L" variable #+ Variable])))
+ (analysis ["&." common]
+ ["&." inference])
+ [".L" variable #+ Variable])))
(exception: #export Cannot-Analyse-Function)
(exception: #export Invalid-Function-Type)
@@ -23,81 +23,81 @@
## [Analysers]
(def: #export (analyse-function analyse func-name arg-name body)
- (-> &;Analyser Text Text Code (Meta Analysis))
- (do macro;Monad
- [functionT macro;expected-type]
+ (-> &.Analyser Text Text Code (Meta Analysis))
+ (do macro.Monad
+ [functionT macro.expected-type]
(loop [expectedT functionT]
- (&;with-stacked-errors
+ (&.with-stacked-errors
(function [_] (Cannot-Analyse-Function (format " Type: " (%type expectedT) "\n"
"Function: " func-name "\n"
"Argument: " arg-name "\n"
" Body: " (%code body))))
(case expectedT
- (#;Named name unnamedT)
+ (#.Named name unnamedT)
(recur unnamedT)
- (#;Apply argT funT)
- (case (type;apply (list argT) funT)
- (#;Some value)
+ (#.Apply argT funT)
+ (case (type.apply (list argT) funT)
+ (#.Some value)
(recur value)
- #;None
- (&;throw Invalid-Function-Type (%type expectedT)))
+ #.None
+ (&.throw Invalid-Function-Type (%type expectedT)))
(^template [ ]
( _)
(do @
- [[_ instanceT] (&;with-type-env )]
- (recur (maybe;assume (type;apply (list instanceT) expectedT)))))
- ([#;UnivQ tc;existential]
- [#;ExQ tc;var])
+ [[_ instanceT] (&.with-type-env )]
+ (recur (maybe.assume (type.apply (list instanceT) expectedT)))))
+ ([#.UnivQ tc.existential]
+ [#.ExQ tc.var])
- (#;Var id)
+ (#.Var id)
(do @
- [?expectedT' (&;with-type-env
- (tc;read id))]
+ [?expectedT' (&.with-type-env
+ (tc.read id))]
(case ?expectedT'
- (#;Some expectedT')
+ (#.Some expectedT')
(recur expectedT')
_
## Inference
(do @
- [[input-id inputT] (&;with-type-env tc;var)
- [output-id outputT] (&;with-type-env tc;var)
- #let [funT (#;Function inputT outputT)]
+ [[input-id inputT] (&.with-type-env tc.var)
+ [output-id outputT] (&.with-type-env tc.var)
+ #let [funT (#.Function inputT outputT)]
funA (recur funT)
- _ (&;with-type-env
- (tc;check expectedT funT))]
+ _ (&.with-type-env
+ (tc.check expectedT funT))]
(wrap funA))
))
- (#;Function inputT outputT)
+ (#.Function inputT outputT)
(<| (:: @ map (function [[scope bodyA]]
- (` ("lux function" [(~@ (list/map code;int (variableL;environment scope)))]
+ (` ("lux function" [(~@ (list/map code.int (variableL.environment scope)))]
(~ bodyA)))))
- &;with-scope
+ &.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-type outputT)
+ (&scope.with-local [func-name expectedT])
+ (&scope.with-local [arg-name inputT])
+ (&.with-type outputT)
(analyse body))
_
- (&;fail "")
+ (&.fail "")
)))))
(def: #export (analyse-apply analyse funcT funcA args)
- (-> &;Analyser Type Analysis (List Code) (Meta Analysis))
- (&;with-stacked-errors
+ (-> &.Analyser Type Analysis (List Code) (Meta Analysis))
+ (&.with-stacked-errors
(function [_]
(Cannot-Apply-Function (format " Function: " (%type funcT) "\n"
"Arguments:" (|> args
- list;enumerate
+ list.enumerate
(list/map (function [[idx argC]]
(format "\n " (%n idx) " " (%code argC))))
- (text;join-with "")))))
- (do macro;Monad
- [[applyT argsA] (&inference;general analyse funcT args)]
- (wrap (la;apply argsA funcA)))))
+ (text.join-with "")))))
+ (do macro.Monad
+ [[applyT argsA] (&inference.general analyse funcT args)]
+ (wrap (la.apply argsA funcA)))))
diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux
index e89ab2e1e..881eee4a6 100644
--- a/new-luxc/source/luxc/lang/analysis/inference.lux
+++ b/new-luxc/source/luxc/lang/analysis/inference.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
@@ -11,7 +11,7 @@
(type ["tc" check])))
(luxc ["&" lang]
(lang ["la" analysis #+ Analysis]
- (analysis ["&;" common]))))
+ (analysis ["&." common]))))
(exception: #export Cannot-Infer)
(def: (cannot-infer type args)
@@ -19,10 +19,10 @@
(format " Type: " (%type type) "\n"
"Arguments:"
(|> args
- list;enumerate
+ list.enumerate
(list/map (function [[idx argC]]
(format "\n " (%n idx) " " (%code argC))))
- (text;join-with ""))))
+ (text.join-with ""))))
(exception: #export Cannot-Infer-Argument)
(exception: #export Smaller-Variant-Than-Expected)
@@ -33,29 +33,29 @@
(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))
+ (#.Primitive name params)
+ (#.Primitive name (list/map (replace-bound bound-idx replacementT) params))
(^template []
( left right)
( (replace-bound bound-idx replacementT left)
(replace-bound bound-idx replacementT right)))
- ([#;Sum]
- [#;Product]
- [#;Function]
- [#;Apply])
+ ([#.Sum]
+ [#.Product]
+ [#.Function]
+ [#.Apply])
- (#;Bound idx)
- (if (n.= bound-idx idx)
+ (#.Bound idx)
+ (if (n/= bound-idx idx)
replacementT
type)
(^template []
( env quantified)
( (list/map (replace-bound bound-idx replacementT) env)
- (replace-bound (n.+ +2 bound-idx) replacementT quantified)))
- ([#;UnivQ]
- [#;ExQ])
+ (replace-bound (n/+ +2 bound-idx) replacementT quantified)))
+ ([#.UnivQ]
+ [#.ExQ])
_
type))
@@ -68,36 +68,36 @@
## But, so long as the type being used for the inference can be treated
## as a function type, this method of inference should work.
(def: #export (general analyse inferT args)
- (-> &;Analyser Type (List Code) (Meta [Type (List Analysis)]))
+ (-> &.Analyser Type (List Code) (Meta [Type (List Analysis)]))
(case args
- #;Nil
- (do macro;Monad
- [_ (&;infer inferT)]
+ #.Nil
+ (do macro.Monad
+ [_ (&.infer inferT)]
(wrap [inferT (list)]))
- (#;Cons argC args')
+ (#.Cons argC args')
(case inferT
- (#;Named name unnamedT)
+ (#.Named name unnamedT)
(general analyse unnamedT args)
- (#;UnivQ _)
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)]
- (general analyse (maybe;assume (type;apply (list varT) inferT)) args))
+ (#.UnivQ _)
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)]
+ (general analyse (maybe.assume (type.apply (list varT) inferT)) args))
- (#;ExQ _)
- (do macro;Monad
- [[ex-id exT] (&;with-type-env
- tc;existential)]
- (general analyse (maybe;assume (type;apply (list exT) inferT)) args))
+ (#.ExQ _)
+ (do macro.Monad
+ [[ex-id exT] (&.with-type-env
+ tc.existential)]
+ (general analyse (maybe.assume (type.apply (list exT) inferT)) args))
- (#;Apply inputT transT)
- (case (type;apply (list inputT) transT)
- (#;Some outputT)
+ (#.Apply inputT transT)
+ (case (type.apply (list inputT) transT)
+ (#.Some outputT)
(general analyse outputT args)
- #;None
- (&;throw Invalid-Type-Application (%type inferT)))
+ #.None
+ (&.throw Invalid-Type-Application (%type inferT)))
## Arguments are inferred back-to-front because, by convention,
## Lux functions take the most important arguments *last*, which
@@ -106,59 +106,59 @@
## 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 macro;Monad
+ (#.Function inputT outputT)
+ (do macro.Monad
[[outputT' args'A] (general analyse outputT args')
- argA (&;with-stacked-errors
+ argA (&.with-stacked-errors
(function [_] (Cannot-Infer-Argument
(format "Inferred Type: " (%type inputT) "\n"
" Argument: " (%code argC))))
- (&;with-type inputT
+ (&.with-type inputT
(analyse argC)))]
(wrap [outputT' (list& argA args'A)]))
- (#;Var infer-id)
- (do macro;Monad
- [?inferT' (&;with-type-env (tc;read infer-id))]
+ (#.Var infer-id)
+ (do macro.Monad
+ [?inferT' (&.with-type-env (tc.read infer-id))]
(case ?inferT'
- (#;Some inferT')
+ (#.Some inferT')
(general analyse inferT' args)
_
- (&;throw Cannot-Infer (cannot-infer inferT args))))
+ (&.throw Cannot-Infer (cannot-infer inferT args))))
_
- (&;throw Cannot-Infer (cannot-infer inferT args)))
+ (&.throw Cannot-Infer (cannot-infer inferT args)))
))
## Turns a record type into the kind of function type suitable for inference.
(def: #export (record inferT)
(-> Type (Meta Type))
(case inferT
- (#;Named name unnamedT)
+ (#.Named name unnamedT)
(record unnamedT)
(^template []
( env bodyT)
- (do macro;Monad
+ (do macro.Monad
[bodyT+ (record bodyT)]
(wrap ( env bodyT+))))
- ([#;UnivQ]
- [#;ExQ])
+ ([#.UnivQ]
+ [#.ExQ])
- (#;Apply inputT funcT)
- (case (type;apply (list inputT) funcT)
- (#;Some outputT)
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
(record outputT)
- #;None
- (&;throw Invalid-Type-Application (%type inferT)))
+ #.None
+ (&.throw Invalid-Type-Application (%type inferT)))
- (#;Product _)
- (macro/wrap (type;function (type;flatten-tuple inferT) inferT))
+ (#.Product _)
+ (macro/wrap (type.function (type.flatten-tuple inferT) inferT))
_
- (&;throw Not-A-Record-Type (%type inferT))))
+ (&.throw Not-A-Record-Type (%type inferT))))
## Turns a variant type into the kind of function type suitable for inference.
(def: #export (variant tag expected-size inferT)
@@ -166,60 +166,60 @@
(loop [depth +0
currentT inferT]
(case currentT
- (#;Named name unnamedT)
- (do macro;Monad
+ (#.Named name unnamedT)
+ (do macro.Monad
[unnamedT+ (recur depth unnamedT)]
(wrap unnamedT+))
(^template []
( env bodyT)
- (do macro;Monad
- [bodyT+ (recur (n.inc depth) bodyT)]
+ (do macro.Monad
+ [bodyT+ (recur (n/inc depth) bodyT)]
(wrap ( 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)
- (macro/wrap (if (n.= +0 depth)
- (type;function (list caseT) currentT)
- (let [replace! (replace-bound (|> depth n.dec (n.* +2)) inferT)]
- (type;function (list (replace! caseT))
+ ([#.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)
+ (macro/wrap (if (n/= +0 depth)
+ (type.function (list caseT) currentT)
+ (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)]
+ (type.function (list (replace! caseT))
(replace! currentT)))))
- #;None
- (&common;variant-out-of-bounds-error inferT expected-size tag))
+ #.None
+ (&common.variant-out-of-bounds-error inferT expected-size tag))
- (n.< expected-size actual-size)
- (&;throw Smaller-Variant-Than-Expected
+ (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))]
- (macro/wrap (if (n.= +0 depth)
- (type;function (list caseT) currentT)
- (let [replace! (replace-bound (|> depth n.dec (n.* +2)) inferT)]
- (type;function (list (replace! caseT))
+ (n/= boundary tag)
+ (let [caseT (type.variant (list.drop boundary cases))]
+ (macro/wrap (if (n/= +0 depth)
+ (type.function (list caseT) currentT)
+ (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)]
+ (type.function (list (replace! caseT))
(replace! currentT))))))
## else
- (&common;variant-out-of-bounds-error inferT expected-size tag)))
+ (&common.variant-out-of-bounds-error inferT expected-size tag)))
- (#;Apply inputT funcT)
- (case (type;apply (list inputT) funcT)
- (#;Some outputT)
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
(variant tag expected-size outputT)
- #;None
- (&;throw Invalid-Type-Application (%type inferT)))
+ #.None
+ (&.throw Invalid-Type-Application (%type inferT)))
_
- (&;throw Not-A-Variant-Type (%type inferT)))))
+ (&.throw Not-A-Variant-Type (%type inferT)))))
diff --git a/new-luxc/source/luxc/lang/analysis/primitive.lux b/new-luxc/source/luxc/lang/analysis/primitive.lux
index 9124ca271..8270e7e73 100644
--- a/new-luxc/source/luxc/lang/analysis/primitive.lux
+++ b/new-luxc/source/luxc/lang/analysis/primitive.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
lux
(lux (control monad)
[macro]
@@ -11,20 +11,20 @@
(do-template [ ]
[(def: #export ( value)
(-> (Meta Analysis))
- (do macro;Monad
- [_ (&;infer )]
+ (do macro.Monad
+ [_ (&.infer )]
(wrap ( 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]
+ [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 macro;Monad
- [_ (&;infer Unit)]
+ (do macro.Monad
+ [_ (&.infer Unit)]
(wrap (` []))))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure.lux b/new-luxc/source/luxc/lang/analysis/procedure.lux
index 4e9843ddd..25e1be335 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
@@ -8,19 +8,19 @@
(coll [dict])))
(luxc ["&" lang]
(lang ["la" analysis]))
- (/ ["/;" common]
- ["/;" host]))
+ (/ ["/." common]
+ ["/." host]))
(exception: #export Unknown-Procedure)
(def: procedures
- /common;Bundle
- (|> /common;procedures
- (dict;merge /host;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 (&;throw Unknown-Procedure (%t proc-name)))
- (do maybe;Monad
- [proc (dict;get proc-name procedures)]
+ (-> &.Analyser &.Eval Text (List Code) (Meta la.Analysis))
+ (<| (maybe.default (&.throw Unknown-Procedure (%t proc-name)))
+ (do maybe.Monad
+ [proc (dict.get proc-name procedures)]
(wrap ((proc proc-name) analyse eval proc-args)))))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
index f5afca5bf..b003edfa7 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
@@ -14,16 +14,16 @@
[io])
(luxc ["&" lang]
(lang ["la" analysis]
- (analysis ["&;" common]
- [";A" function]
- [";A" case]
- [";A" type]))))
+ (analysis ["&." common]
+ [".A" function]
+ [".A" case]
+ [".A" type]))))
(exception: #export Incorrect-Procedure-Arity)
## [Utils]
(type: #export Proc
- (-> &;Analyser &;Eval (List Code) (Meta la;Analysis)))
+ (-> &.Analyser &.Eval (List Code) (Meta la.Analysis)))
(type: #export Bundle
(Dict Text (-> Text Proc)))
@@ -31,14 +31,14 @@
(def: #export (install name unnamed)
(-> Text (-> Text Proc)
(-> Bundle Bundle))
- (dict;put name unnamed))
+ (dict.put name unnamed))
(def: #export (prefix prefix bundle)
(-> Text Bundle Bundle)
(|> bundle
- dict;entries
+ dict.entries
(list/map (function [[key val]] [(format prefix " " key) val]))
- (dict;from-list text;Hash)))
+ (dict.from-list text.Hash)))
(def: #export (wrong-arity proc expected actual)
(-> Text Nat Nat Text)
@@ -48,19 +48,19 @@
(def: (simple proc inputsT+ outputT)
(-> Text (List Type) Type Proc)
- (let [num-expected (list;size inputsT+)]
+ (let [num-expected (list.size inputsT+)]
(function [analyse eval args]
- (let [num-actual (list;size args)]
- (if (n.= num-expected num-actual)
- (do macro;Monad
- [_ (&;infer outputT)
- argsA (monad;map @
+ (let [num-actual (list.size args)]
+ (if (n/= num-expected num-actual)
+ (do macro.Monad
+ [_ (&.infer outputT)
+ argsA (monad.map @
(function [[argT argC]]
- (&;with-type argT
+ (&.with-type argT
(analyse argC)))
- (list;zip2 inputsT+ args))]
- (wrap (la;procedure proc argsA)))
- (&;throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual)))))))
+ (list.zip2 inputsT+ args))]
+ (wrap (la.procedure proc argsA)))
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual)))))))
(def: #export (nullary valueT proc)
(-> Type Text Proc)
@@ -83,8 +83,8 @@
(def: (lux-is proc)
(-> Text Proc)
(function [analyse eval args]
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)]
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)]
((binary varT varT Bool proc)
analyse eval args))))
@@ -95,37 +95,37 @@
(function [analyse eval args]
(case args
(^ (list opC))
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)
- _ (&;infer (type (Either Text varT)))
- opA (&;with-type (type (io;IO varT))
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)
+ _ (&.infer (type (Either Text varT)))
+ opA (&.with-type (type (io.IO varT))
(analyse opC))]
- (wrap (la;procedure proc (list opA))))
+ (wrap (la.procedure proc (list opA))))
_
- (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args))))))
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
(def: (lux//function proc)
(-> Text Proc)
(function [analyse eval args]
(case args
- (^ (list [_ (#;Symbol ["" func-name])]
- [_ (#;Symbol ["" arg-name])]
+ (^ (list [_ (#.Symbol ["" func-name])]
+ [_ (#.Symbol ["" arg-name])]
body))
- (functionA;analyse-function analyse func-name arg-name body)
+ (functionA.analyse-function analyse func-name arg-name body)
_
- (&;throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list;size args))))))
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list.size args))))))
(def: (lux//case proc)
(-> Text Proc)
(function [analyse eval args]
(case args
- (^ (list input [_ (#;Record branches)]))
- (caseA;analyse-case analyse input branches)
+ (^ (list input [_ (#.Record branches)]))
+ (caseA.analyse-case analyse input branches)
_
- (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args))))))
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))
(do-template [ ]
[(def: ( proc)
@@ -136,28 +136,28 @@
( analyse eval typeC valueC)
_
- (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args))))))]
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list.size args))))))]
- [lux//check typeA;analyse-check]
- [lux//coerce typeA;analyse-coerce])
+ [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 macro;Monad
- [_ (&;infer (type Type))
- valueA (&;with-type Type
+ (do macro.Monad
+ [_ (&.infer (type Type))
+ valueA (&.with-type Type
(analyse valueC))]
(wrap valueA))
_
- (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args))))))
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
(def: lux-procs
Bundle
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "is" lux-is)
(install "try" lux-try)
(install "function" lux//function)
@@ -169,7 +169,7 @@
(def: io-procs
Bundle
(<| (prefix "io")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "log" (unary Text Unit))
(install "error" (unary Text Bottom))
(install "exit" (unary Int Bottom))
@@ -178,7 +178,7 @@
(def: bit-procs
Bundle
(<| (prefix "bit")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "count" (unary Nat Nat))
(install "and" (binary Nat Nat Nat))
(install "or" (binary Nat Nat Nat))
@@ -191,7 +191,7 @@
(def: nat-procs
Bundle
(<| (prefix "nat")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "+" (binary Nat Nat Nat))
(install "-" (binary Nat Nat Nat))
(install "*" (binary Nat Nat Nat))
@@ -207,7 +207,7 @@
(def: int-procs
Bundle
(<| (prefix "int")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "+" (binary Int Int Int))
(install "-" (binary Int Int Int))
(install "*" (binary Int Int Int))
@@ -223,7 +223,7 @@
(def: deg-procs
Bundle
(<| (prefix "deg")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "+" (binary Deg Deg Deg))
(install "-" (binary Deg Deg Deg))
(install "*" (binary Deg Deg Deg))
@@ -240,7 +240,7 @@
(def: frac-procs
Bundle
(<| (prefix "frac")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "+" (binary Frac Frac Frac))
(install "-" (binary Frac Frac Frac))
(install "*" (binary Frac Frac Frac))
@@ -262,7 +262,7 @@
(def: text-procs
Bundle
(<| (prefix "text")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "=" (binary Text Text Bool))
(install "<" (binary Text Text Bool))
(install "concat" (binary Text Text Text))
@@ -280,31 +280,31 @@
(def: (array//get proc)
(-> Text Proc)
(function [analyse eval args]
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)]
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)]
((binary (type (Array varT)) Nat (type (Maybe varT)) proc)
analyse eval args))))
(def: (array//put proc)
(-> Text Proc)
(function [analyse eval args]
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)]
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)]
((trinary (type (Array varT)) Nat varT (type (Array varT)) proc)
analyse eval args))))
(def: (array//remove proc)
(-> Text Proc)
(function [analyse eval args]
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)]
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)]
((binary (type (Array varT)) Nat (type (Array varT)) proc)
analyse eval args))))
(def: array-procs
Bundle
(<| (prefix "array")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "new" (unary Nat Array))
(install "get" array//get)
(install "put" array//put)
@@ -315,7 +315,7 @@
(def: math-procs
Bundle
(<| (prefix "math")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "cos" (unary Frac Frac))
(install "sin" (unary Frac Frac))
(install "tan" (unary Frac Frac))
@@ -341,36 +341,36 @@
(function [analyse eval args]
(case args
(^ (list initC))
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)
- _ (&;infer (type (Atom varT)))
- initA (&;with-type varT
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)
+ _ (&.infer (type (Atom varT)))
+ initA (&.with-type varT
(analyse initC))]
- (wrap (la;procedure proc (list initA))))
+ (wrap (la.procedure proc (list initA))))
_
- (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args))))))
+ (&.throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list.size args))))))
(def: (atom-read proc)
(-> Text Proc)
(function [analyse eval args]
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)]
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)]
((unary (type (Atom varT)) varT proc)
analyse eval args))))
(def: (atom//compare-and-swap proc)
(-> Text Proc)
(function [analyse eval args]
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)]
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)]
((trinary (type (Atom varT)) varT varT Bool proc)
analyse eval args))))
(def: atom-procs
Bundle
(<| (prefix "atom")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "new" atom-new)
(install "read" atom-read)
(install "compare-and-swap" atom//compare-and-swap)
@@ -379,25 +379,25 @@
(def: process-procs
Bundle
(<| (prefix "process")
- (|> (dict;new text;Hash)
+ (|> (dict.new text.Hash)
(install "concurrency-level" (nullary Nat))
- (install "future" (unary (type (io;IO Top)) Unit))
- (install "schedule" (binary Nat (type (io;IO Top)) Unit))
+ (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)
- (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))))
+ (|> (dict.new text.Hash)
+ (dict.merge lux-procs)
+ (dict.merge bit-procs)
+ (dict.merge nat-procs)
+ (dict.merge int-procs)
+ (dict.merge deg-procs)
+ (dict.merge frac-procs)
+ (dict.merge text-procs)
+ (dict.merge array-procs)
+ (dict.merge math-procs)
+ (dict.merge atom-procs)
+ (dict.merge process-procs)
+ (dict.merge io-procs))))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
index bb388434f..3c29410d0 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
[lux #- char]
(lux (control [monad #+ do]
["p" parser]
@@ -21,10 +21,10 @@
(type ["tc" check]))
[host])
(luxc ["&" lang]
- (lang ["&;" host]
+ (lang ["&." host]
["la" analysis]
- (analysis ["&;" common]
- [";A" inference])))
+ (analysis ["&." common]
+ [".A" inference])))
["@" //common]
)
@@ -32,7 +32,7 @@
(def: (wrong-syntax procedure args)
(-> Text (List Code) Text)
(format "Procedure: " procedure "\n"
- "Arguments: " (%code (code;tuple args))))
+ "Arguments: " (%code (code.tuple args))))
(exception: #export JVM-Type-Is-Not-Class)
@@ -74,7 +74,7 @@
(def: #export null-class Text "#Null")
(do-template [ ]
- [(def: #export Type (#;Primitive (list)))]
+ [(def: #export Type (#.Primitive (list)))]
## Boxes
[Boolean "java.lang.Boolean"]
@@ -99,52 +99,52 @@
)
(def: conversion-procs
- @;Bundle
- (<| (@;prefix "convert")
- (|> (dict;new text;Hash)
- (@;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))
+ @.Bundle
+ (<| (@.prefix "convert")
+ (|> (dict.new text.Hash)
+ (@.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 [ ]
[(def:
- @;Bundle
- (<| (@;prefix )
- (|> (dict;new text;Hash)
- (@;install "+" (@;binary ))
- (@;install "-" (@;binary ))
- (@;install "*" (@;binary ))
- (@;install "/" (@;binary ))
- (@;install "%" (@;binary ))
- (@;install "=" (@;binary Boolean))
- (@;install "<" (@;binary Boolean))
- (@;install "and" (@;binary ))
- (@;install "or" (@;binary ))
- (@;install "xor" (@;binary ))
- (@;install "shl" (@;binary Integer ))
- (@;install "shr" (@;binary Integer ))
- (@;install "ushr" (@;binary Integer ))
+ @.Bundle
+ (<| (@.prefix )
+ (|> (dict.new text.Hash)
+ (@.install "+" (@.binary ))
+ (@.install "-" (@.binary ))
+ (@.install "*" (@.binary ))
+ (@.install "/" (@.binary ))
+ (@.install "%" (@.binary ))
+ (@.install "=" (@.binary Boolean))
+ (@.install "<" (@.binary Boolean))
+ (@.install "and" (@.binary ))
+ (@.install "or" (@.binary ))
+ (@.install "xor" (@.binary ))
+ (@.install "shl" (@.binary Integer ))
+ (@.install "shr" (@.binary Integer ))
+ (@.install "ushr" (@.binary Integer ))
)))]
[int-procs "int" Integer]
@@ -153,16 +153,16 @@
(do-template [ ]
[(def:
- @;Bundle
- (<| (@;prefix )
- (|> (dict;new text;Hash)
- (@;install "+" (@;binary ))
- (@;install "-" (@;binary ))
- (@;install "*" (@;binary ))
- (@;install "/" (@;binary ))
- (@;install "%" (@;binary ))
- (@;install "=" (@;binary Boolean))
- (@;install "<" (@;binary Boolean))
+ @.Bundle
+ (<| (@.prefix )
+ (|> (dict.new text.Hash)
+ (@.install "+" (@.binary ))
+ (@.install "-" (@.binary ))
+ (@.install "*" (@.binary ))
+ (@.install "/" (@.binary ))
+ (@.install "%" (@.binary ))
+ (@.install "=" (@.binary Boolean))
+ (@.install "<" (@.binary Boolean))
)))]
[float-procs "float" Float]
@@ -170,11 +170,11 @@
)
(def: char-procs
- @;Bundle
- (<| (@;prefix "char")
- (|> (dict;new text;Hash)
- (@;install "=" (@;binary Character Character Boolean))
- (@;install "<" (@;binary Character Character Boolean))
+ @.Bundle
+ (<| (@.prefix "char")
+ (|> (dict.new text.Hash)
+ (@.install "=" (@.binary Character Character Boolean))
+ (@.install "<" (@.binary Character Character Boolean))
)))
(def: #export boxes
@@ -187,439 +187,439 @@
["float" "java.lang.Float"]
["double" "java.lang.Double"]
["char" "java.lang.Character"])
- (dict;from-list text;Hash)))
+ (dict.from-list text.Hash)))
(def: (array-length proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list arrayC))
- (do macro;Monad
- [_ (&;infer Nat)
- [var-id varT] (&;with-type-env tc;var)
- arrayA (&;with-type (type (Array varT))
+ (do macro.Monad
+ [_ (&.infer Nat)
+ [var-id varT] (&.with-type-env tc.var)
+ arrayA (&.with-type (type (Array varT))
(analyse arrayC))]
- (wrap (la;procedure proc (list arrayA))))
+ (wrap (la.procedure proc (list arrayA))))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
(def: (array-new proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list lengthC))
- (do macro;Monad
- [lengthA (&;with-type Nat
+ (do macro.Monad
+ [lengthA (&.with-type Nat
(analyse lengthC))
- expectedT macro;expected-type
+ expectedT macro.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)
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
(recur outputT level)
- #;None
- (&;throw Non-Array (%type expectedT)))
+ #.None
+ (&.throw Non-Array (%type expectedT)))
- (^ (#;Primitive "#Array" (list elemT)))
- (recur elemT (n.inc level))
+ (^ (#.Primitive "#Array" (list elemT)))
+ (recur elemT (n/inc level))
- (#;Primitive class _)
+ (#.Primitive class _)
(wrap [level class])
_
- (&;throw Non-Array (%type expectedT)))))
- _ (if (n.> +0 level)
+ (&.throw Non-Array (%type expectedT)))))
+ _ (if (n/> +0 level)
(wrap [])
- (&;throw Non-Array (%type expectedT)))]
- (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA))))
+ (&.throw Non-Array (%type expectedT)))]
+ (wrap (la.procedure proc (list (code.nat (n/dec level)) (code.text elem-class) lengthA))))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
(def: (check-jvm objectT)
(-> Type (Meta Text))
(case objectT
- (#;Primitive name _)
+ (#.Primitive name _)
(macro/wrap name)
- (#;Named name unnamed)
+ (#.Named name unnamed)
(check-jvm unnamed)
- (#;Var id)
+ (#.Var id)
(macro/wrap "java.lang.Object")
(^template []
( env unquantified)
(check-jvm unquantified))
- ([#;UnivQ]
- [#;ExQ])
+ ([#.UnivQ]
+ [#.ExQ])
- (#;Apply inputT funcT)
- (case (type;apply (list inputT) funcT)
- (#;Some outputT)
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
(check-jvm outputT)
- #;None
- (&;throw Non-Object (%type objectT)))
+ #.None
+ (&.throw Non-Object (%type objectT)))
_
- (&;throw Non-Object (%type objectT))))
+ (&.throw Non-Object (%type objectT))))
(def: (check-object objectT)
(-> Type (Meta Text))
- (do macro;Monad
+ (do macro.Monad
[name (check-jvm objectT)]
- (if (dict;contains? name boxes)
- (&;throw Primitives-Are-Not-Objects name)
+ (if (dict.contains? name boxes)
+ (&.throw Primitives-Are-Not-Objects name)
(macro/wrap name))))
(def: (box-array-element-type elemT)
(-> Type (Meta [Type Text]))
(case elemT
- (#;Primitive name #;Nil)
- (let [boxed-name (|> (dict;get name boxes)
- (maybe;default name))]
- (macro/wrap [(#;Primitive boxed-name #;Nil)
+ (#.Primitive name #.Nil)
+ (let [boxed-name (|> (dict.get name boxes)
+ (maybe.default name))]
+ (macro/wrap [(#.Primitive boxed-name #.Nil)
boxed-name]))
- (#;Primitive name _)
- (if (dict;contains? name boxes)
- (&;throw Primitives-Cannot-Have-Type-Parameters name)
+ (#.Primitive name _)
+ (if (dict.contains? name boxes)
+ (&.throw Primitives-Cannot-Have-Type-Parameters name)
(macro/wrap [elemT name]))
_
- (&;throw Invalid-Type-For-Array-Element (%type elemT))))
+ (&.throw Invalid-Type-For-Array-Element (%type elemT))))
(def: (array-read proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list arrayC idxC))
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)
- _ (&;infer varT)
- arrayA (&;with-type (type (Array varT))
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)
+ _ (&.infer varT)
+ arrayA (&.with-type (type (Array varT))
(analyse arrayC))
- ?elemT (&;with-type-env
- (tc;read var-id))
- [elemT elem-class] (box-array-element-type (maybe;default varT ?elemT))
- idxA (&;with-type Nat
+ ?elemT (&.with-type-env
+ (tc.read var-id))
+ [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT))
+ idxA (&.with-type Nat
(analyse idxC))]
- (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA))))
+ (wrap (la.procedure proc (list (code.text elem-class) idxA arrayA))))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
(def: (array-write proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list arrayC idxC valueC))
- (do macro;Monad
- [[var-id varT] (&;with-type-env tc;var)
- _ (&;infer (type (Array varT)))
- arrayA (&;with-type (type (Array varT))
+ (do macro.Monad
+ [[var-id varT] (&.with-type-env tc.var)
+ _ (&.infer (type (Array varT)))
+ arrayA (&.with-type (type (Array varT))
(analyse arrayC))
- ?elemT (&;with-type-env
- (tc;read var-id))
- [valueT elem-class] (box-array-element-type (maybe;default varT ?elemT))
- idxA (&;with-type Nat
+ ?elemT (&.with-type-env
+ (tc.read var-id))
+ [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT))
+ idxA (&.with-type Nat
(analyse idxC))
- valueA (&;with-type valueT
+ valueA (&.with-type valueT
(analyse valueC))]
- (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA))))
+ (wrap (la.procedure proc (list (code.text elem-class) idxA valueA arrayA))))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
(def: array-procs
- @;Bundle
- (<| (@;prefix "array")
- (|> (dict;new text;Hash)
- (@;install "length" array-length)
- (@;install "new" array-new)
- (@;install "read" array-read)
- (@;install "write" array-write)
+ @.Bundle
+ (<| (@.prefix "array")
+ (|> (dict.new text.Hash)
+ (@.install "length" array-length)
+ (@.install "new" array-new)
+ (@.install "read" array-read)
+ (@.install "write" array-write)
)))
(def: (object-null proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list))
- (do macro;Monad
- [expectedT macro;expected-type
+ (do macro.Monad
+ [expectedT macro.expected-type
_ (check-object expectedT)]
- (wrap (la;procedure proc (list))))
+ (wrap (la.procedure proc (list))))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +0 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args))))))
(def: (object-null? proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list objectC))
- (do macro;Monad
- [_ (&;infer Bool)
- [objectT objectA] (&common;with-unknown-type
+ (do macro.Monad
+ [_ (&.infer Bool)
+ [objectT objectA] (&common.with-unknown-type
(analyse objectC))
_ (check-object objectT)]
- (wrap (la;procedure proc (list objectA))))
+ (wrap (la.procedure proc (list objectA))))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
(def: (object-synchronized proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list monitorC exprC))
- (do macro;Monad
- [[monitorT monitorA] (&common;with-unknown-type
+ (do macro.Monad
+ [[monitorT monitorA] (&common.with-unknown-type
(analyse monitorC))
_ (check-object monitorT)
exprA (analyse exprC)]
- (wrap (la;procedure proc (list monitorA exprA))))
+ (wrap (la.procedure proc (list monitorA exprA))))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-(host;import java.lang.Object
+(host.import java/lang/Object
(equals [Object] boolean))
-(host;import java.lang.ClassLoader)
+(host.import java/lang/ClassLoader)
-(host;import #long java.lang.reflect.Type
+(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/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/ParameterizedType
+ (getRawType [] java/lang/reflect/Type)
+ (getActualTypeArguments [] (Array java/lang/reflect/Type)))
-(host;import (java.lang.reflect.TypeVariable d)
+(host.import (java/lang/reflect/TypeVariable d)
(getName [] String)
- (getBounds [] (Array java.lang.reflect.Type)))
+ (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/WildcardType d)
+ (getLowerBounds [] (Array java/lang/reflect/Type))
+ (getUpperBounds [] (Array java/lang/reflect/Type)))
-(host;import java.lang.reflect.Modifier
+(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))
+(host.import java/lang/reflect/Field
+ (getDeclaringClass [] (java/lang/Class Object))
(getModifiers [] int)
- (getGenericType [] java.lang.reflect.Type))
+ (getGenericType [] java/lang/reflect/Type))
-(host;import java.lang.reflect.Method
+(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)))
+ (getGenericParameterTypes [] (Array java/lang/reflect/Type))
+ (getGenericReturnType [] java/lang/reflect/Type)
+ (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
-(host;import (java.lang.reflect.Constructor c)
+(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)))
+ (getGenericParameterTypes [] (Array java/lang/reflect/Type))
+ (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
-(host;import (java.lang.Class c)
+(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)
+ (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 macro;Monad
- [class-loader &host;class-loader]
- (case (Class.forName [name false class-loader])
- (#e;Success [class])
+ (do macro.Monad
+ [class-loader &host.class-loader]
+ (case (Class::forName [name false class-loader])
+ (#e.Success [class])
(wrap class)
- (#e;Error error)
- (&;throw Unknown-Class name))))
+ (#e.Error error)
+ (&.throw Unknown-Class name))))
(def: (sub-class? super sub)
(-> Text Text (Meta Bool))
- (do macro;Monad
+ (do macro.Monad
[super (load-class super)
sub (load-class sub)]
- (wrap (Class.isAssignableFrom [sub] super))))
+ (wrap (Class::isAssignableFrom [sub] super))))
(def: (object-throw proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list exceptionC))
- (do macro;Monad
- [_ (&;infer Bottom)
- [exceptionT exceptionA] (&common;with-unknown-type
+ (do macro.Monad
+ [_ (&.infer Bottom)
+ [exceptionT exceptionA] (&common.with-unknown-type
(analyse exceptionC))
exception-class (check-object exceptionT)
? (sub-class? "java.lang.Throwable" exception-class)
_ (: (Meta Unit)
(if ?
(wrap [])
- (&;throw Non-Throwable exception-class)))]
- (wrap (la;procedure proc (list exceptionA))))
+ (&.throw Non-Throwable exception-class)))]
+ (wrap (la.procedure proc (list exceptionA))))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
(def: (object-class proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list classC))
(case classC
- [_ (#;Text class)]
- (do macro;Monad
- [_ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))
+ [_ (#.Text class)]
+ (do macro.Monad
+ [_ (&.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
_ (load-class class)]
- (wrap (la;procedure proc (list (code;text class)))))
+ (wrap (la.procedure proc (list (code.text class)))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
(def: (object-instance? proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list classC objectC))
(case classC
- [_ (#;Text class)]
- (do macro;Monad
- [_ (&;infer Bool)
- [objectT objectA] (&common;with-unknown-type
+ [_ (#.Text class)]
+ (do macro.Monad
+ [_ (&.infer Bool)
+ [objectT objectA] (&common.with-unknown-type
(analyse objectC))
object-class (check-object objectT)
? (sub-class? class object-class)]
(if ?
- (wrap (la;procedure proc (list (code;text class))))
- (&;throw Cannot-Possibly-Be-Instance (format object-class " !<= " class))))
+ (wrap (la.procedure proc (list (code.text class))))
+ (&.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
(def: object-procs
- @;Bundle
- (<| (@;prefix "object")
- (|> (dict;new text;Hash)
- (@;install "null" object-null)
- (@;install "null?" object-null?)
- (@;install "synchronized" object-synchronized)
- (@;install "throw" object-throw)
- (@;install "class" object-class)
- (@;install "instance?" object-instance?)
+ @.Bundle
+ (<| (@.prefix "object")
+ (|> (dict.new text.Hash)
+ (@.install "null" object-null)
+ (@.install "null?" object-null?)
+ (@.install "synchronized" object-synchronized)
+ (@.install "throw" object-throw)
+ (@.install "class" object-class)
+ (@.install "instance?" object-instance?)
)))
(def: type-descriptor
- (-> java.lang.reflect.Type Text)
- (java.lang.reflect.Type.getTypeName []))
+ (-> 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)
- (macro/wrap (Class.getName [] (:! Class type)))
+ (-> java/lang/reflect/Type (Meta Text))
+ (cond (host.instance? Class type)
+ (macro/wrap (Class::getName [] (:! Class type)))
- (host;instance? ParameterizedType type)
- (java-type-to-class (ParameterizedType.getRawType [] (:! ParameterizedType type)))
+ (host.instance? ParameterizedType type)
+ (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type)))
## else
- (&;throw Cannot-Convert-To-Class (type-descriptor type))))
+ (&.throw Cannot-Convert-To-Class (type-descriptor type))))
(type: Mappings
(Dict Text Type))
-(def: fresh-mappings Mappings (dict;new text;Hash))
+(def: fresh-mappings Mappings (dict.new text.Hash))
(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)
+ (-> 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)
(macro/wrap var-type)
- #;None
- (&;throw Unknown-Type-Var var-name)))
+ #.None
+ (&.throw Unknown-Type-Var var-name)))
- (host;instance? WildcardType java-type)
+ (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)])
+ (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)
_
(macro/wrap Top)))
- (host;instance? Class java-type)
+ (host.instance? Class java-type)
(let [java-type (:! (Class Object) java-type)
- class-name (Class.getName [] java-type)]
- (macro/wrap (case (array;size (Class.getTypeParameters [] java-type))
+ class-name (Class::getName [] java-type)]
+ (macro/wrap (case (array.size (Class::getTypeParameters [] java-type))
+0
- (#;Primitive class-name (list))
+ (#.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)))))
+ (|> (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)
+ (host.instance? ParameterizedType java-type)
(let [java-type (:! ParameterizedType java-type)
- raw (ParameterizedType.getRawType [] java-type)]
- (if (host;instance? Class raw)
- (do macro;Monad
+ raw (ParameterizedType::getRawType [] java-type)]
+ (if (host.instance? Class raw)
+ (do macro.Monad
[paramsT (|> java-type
- (ParameterizedType.getActualTypeArguments [])
- array;to-list
- (monad;map @ (java-type-to-lux-type mappings)))]
- (macro/wrap (#;Primitive (Class.getName [] (:! (Class Object) raw))
+ (ParameterizedType::getActualTypeArguments [])
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))]
+ (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw))
paramsT)))
- (&;throw JVM-Type-Is-Not-Class (type-descriptor raw))))
+ (&.throw JVM-Type-Is-Not-Class (type-descriptor raw))))
- (host;instance? GenericArrayType java-type)
- (do macro;Monad
+ (host.instance? GenericArrayType java-type)
+ (do macro.Monad
[innerT (|> (:! GenericArrayType java-type)
- (GenericArrayType.getGenericComponentType [])
+ (GenericArrayType::getGenericComponentType [])
(java-type-to-lux-type mappings))]
- (wrap (#;Primitive "#Array" (list innerT))))
+ (wrap (#.Primitive "#Array" (list innerT))))
## else
- (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
+ (&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
(type: Direction
#In
@@ -634,18 +634,18 @@
(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))
- num-class-params (list;size class-params)
- num-type-params (list;size params)]
+ (#.Primitive name params)
+ (let [class-name (Class::getName [] class)
+ class-params (array.to-list (Class::getTypeParameters [] class))
+ num-class-params (list.size class-params)
+ num-type-params (list.size params)]
(cond (not (text/= class-name name))
- (&;throw Cannot-Correspond-Type-With-Class
+ (&.throw Cannot-Correspond-Type-With-Class
(format "Class = " class-name "\n"
"Type = " (%type type)))
- (not (n.= num-class-params num-type-params))
- (&;throw Type-Parameter-Mismatch
+ (not (n/= num-class-params num-type-params))
+ (&.throw Type-Parameter-Mismatch
(format "Expected: " (%i (nat-to-int num-class-params)) "\n"
" Actual: " (%i (nat-to-int num-type-params)) "\n"
" Class: " class-name "\n"
@@ -653,28 +653,28 @@
## else
(macro/wrap (|> params
- (list;zip2 (list/map (TypeVariable.getName []) class-params))
- (dict;from-list text;Hash)))
+ (list.zip2 (list/map (TypeVariable::getName []) class-params))
+ (dict.from-list text.Hash)))
))
_
- (&;throw Non-JVM-Type (%type type))))
+ (&.throw Non-JVM-Type (%type type))))
(def: (cast direction to from)
(-> Direction Type Type (Meta [Text Type]))
- (do macro;Monad
+ (do macro.Monad
[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))]
+ (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 (cannot-cast to from))))
+ (wrap [(choose direction to-name from-name) (#.Primitive to-name (list))])
+ (&.throw Cannot-Cast (cannot-cast to from))))
- (dict;contains? from-name boxes)
- (let [box (maybe;assume (dict;get from-name boxes))]
+ (dict.contains? from-name boxes)
+ (let [box (maybe.assume (dict.get from-name boxes))]
(do @
- [[_ castT] (cast direction to (#;Primitive box (list)))]
+ [[_ castT] (cast direction to (#.Primitive box (list)))]
(wrap [(choose direction to-name from-name) castT])))
(text/= to-name from-name)
@@ -687,226 +687,226 @@
(do @
[to-class (load-class to-name)
from-class (load-class from-name)
- _ (&;assert Cannot-Cast (cannot-cast to from)
- (Class.isAssignableFrom [from-class] to-class))
- candiate-parents (monad;map @
+ _ (&.assert Cannot-Cast (cannot-cast to from)
+ (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))))]
+ (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 _)
+ (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
- (&;throw Cannot-Cast (cannot-cast to from)))))))
+ #.Nil
+ (&.throw Cannot-Cast (cannot-cast to from)))))))
(def: (infer-out outputT)
(-> Type (Meta [Text Type]))
- (do macro;Monad
- [expectedT macro;expected-type
+ (do macro.Monad
+ [expectedT macro.expected-type
[unboxed castT] (cast #Out expectedT outputT)
- _ (&;with-type-env
- (tc;check expectedT castT))]
+ _ (&.with-type-env
+ (tc.check expectedT castT))]
(wrap [unboxed castT])))
(def: (find-field class-name field-name)
(-> Text Text (Meta [(Class Object) Field]))
- (do macro;Monad
+ (do macro.Monad
[class (load-class class-name)]
- (case (Class.getDeclaredField [field-name] class)
- (#e;Success field)
- (let [owner (Field.getDeclaringClass [] field)]
+ (case (Class::getDeclaredField [field-name] class)
+ (#e.Success field)
+ (let [owner (Field::getDeclaringClass [] field)]
(if (is owner class)
(wrap [class field])
- (&;throw Mistaken-Field-Owner
+ (&.throw Mistaken-Field-Owner
(format " Field: " field-name "\n"
- " Owner Class: " (Class.getName [] owner) "\n"
+ " Owner Class: " (Class::getName [] owner) "\n"
"Target Class: " class-name "\n"))))
- (#e;Error _)
- (&;throw Unknown-Field (format class-name "#" field-name)))))
+ (#e.Error _)
+ (&.throw Unknown-Field (format class-name "#" field-name)))))
(def: (static-field class-name field-name)
(-> Text Text (Meta [Type Bool]))
- (do macro;Monad
+ (do macro.Monad
[[class fieldJ] (find-field class-name field-name)
- #let [modifiers (Field.getModifiers [] fieldJ)]]
- (if (Modifier.isStatic [modifiers])
- (let [fieldJT (Field.getGenericType [] fieldJ)]
+ #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])])))
- (&;throw Not-Static-Field (format class-name "#" field-name)))))
+ (wrap [fieldT (Modifier::isFinal [modifiers])])))
+ (&.throw Not-Static-Field (format class-name "#" field-name)))))
(def: (virtual-field class-name field-name objectT)
(-> Text Text Type (Meta [Type Bool]))
- (do macro;Monad
+ (do macro.Monad
[[class fieldJ] (find-field class-name field-name)
- #let [modifiers (Field.getModifiers [] fieldJ)]]
- (if (not (Modifier.isStatic [modifiers]))
+ #let [modifiers (Field::getModifiers [] fieldJ)]]
+ (if (not (Modifier::isStatic [modifiers]))
(do @
- [#let [fieldJT (Field.getGenericType [] fieldJ)
+ [#let [fieldJT (Field::getGenericType [] fieldJ)
var-names (|> class
- (Class.getTypeParameters [])
- array;to-list
- (list/map (TypeVariable.getName [])))]
+ (Class::getTypeParameters [])
+ array.to-list
+ (list/map (TypeVariable::getName [])))]
mappings (: (Meta Mappings)
(case objectT
- (#;Primitive _class-name _class-params)
+ (#.Primitive _class-name _class-params)
(do @
- [#let [num-params (list;size _class-params)
- num-vars (list;size var-names)]
- _ (&;assert Type-Parameter-Mismatch
+ [#let [num-params (list.size _class-params)
+ num-vars (list.size var-names)]
+ _ (&.assert Type-Parameter-Mismatch
(format "Expected: " (%i (nat-to-int num-params)) "\n"
" Actual: " (%i (nat-to-int num-vars)) "\n"
" Class: " _class-name "\n"
" Type: " (%type objectT))
- (n.= num-params num-vars))]
- (wrap (|> (list;zip2 var-names _class-params)
- (dict;from-list text;Hash))))
+ (n/= num-params num-vars))]
+ (wrap (|> (list.zip2 var-names _class-params)
+ (dict.from-list text.Hash))))
_
- (&;throw Non-Object (%type objectT))))
+ (&.throw Non-Object (%type objectT))))
fieldT (java-type-to-lux-type mappings fieldJT)]
- (wrap [fieldT (Modifier.isFinal [modifiers])]))
- (&;throw Not-Virtual-Field (format class-name "#" field-name)))))
+ (wrap [fieldT (Modifier::isFinal [modifiers])]))
+ (&.throw Not-Virtual-Field (format class-name "#" field-name)))))
(def: (analyse-object class analyse sourceC)
- (-> Text &;Analyser Code (Meta [Type la;Analysis]))
- (do macro;Monad
+ (-> Text &.Analyser Code (Meta [Type la.Analysis]))
+ (do macro.Monad
[target-class (load-class class)
targetT (java-type-to-lux-type fresh-mappings
- (:! java.lang.reflect.Type
+ (:! java/lang/reflect/Type
target-class))
- [sourceT sourceA] (&common;with-unknown-type
+ [sourceT sourceA] (&common.with-unknown-type
(analyse sourceC))
[unboxed castT] (cast #Out targetT sourceT)
- _ (&;assert Cannot-Cast (cannot-cast targetT sourceT)
- (not (dict;contains? unboxed boxes)))]
+ _ (&.assert Cannot-Cast (cannot-cast targetT sourceT)
+ (not (dict.contains? unboxed boxes)))]
(wrap [castT sourceA])))
(def: (analyse-input analyse targetT sourceC)
- (-> &;Analyser Type Code (Meta [Type Text la;Analysis]))
- (do macro;Monad
- [[sourceT sourceA] (&common;with-unknown-type
+ (-> &.Analyser Type Code (Meta [Type Text la.Analysis]))
+ (do macro.Monad
+ [[sourceT sourceA] (&common.with-unknown-type
(analyse sourceC))
[unboxed castT] (cast #In targetT sourceT)]
(wrap [castT unboxed sourceA])))
(def: (static-get proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list classC fieldC))
(case [classC fieldC]
- [[_ (#;Text class)] [_ (#;Text field)]]
- (do macro;Monad
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do macro.Monad
[[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)))))
+ (wrap (la.procedure proc (list (code.text class) (code.text field)
+ (code.text unboxed)))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
(def: (static-put proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list classC fieldC valueC))
(case [classC fieldC]
- [[_ (#;Text class)] [_ (#;Text field)]]
- (do macro;Monad
- [_ (&;infer Unit)
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do macro.Monad
+ [_ (&.infer Unit)
[fieldT final?] (static-field class field)
- _ (&;assert Cannot-Set-Final-Field (format class "#" field)
+ _ (&.assert Cannot-Set-Final-Field (format class "#" field)
(not final?))
[valueT unboxed valueA] (analyse-input analyse fieldT valueC)
- _ (&;with-type-env
- (tc;check fieldT valueT))]
- (wrap (la;procedure proc (list (code;text class) (code;text field)
- (code;text unboxed) valueA))))
+ _ (&.with-type-env
+ (tc.check fieldT valueT))]
+ (wrap (la.procedure proc (list (code.text class) (code.text field)
+ (code.text unboxed) valueA))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
(def: (virtual-get proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list classC fieldC objectC))
(case [classC fieldC]
- [[_ (#;Text class)] [_ (#;Text field)]]
- (do macro;Monad
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do macro.Monad
[[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))))
+ (wrap (la.procedure proc (list (code.text class) (code.text field)
+ (code.text unboxed) objectA))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
(def: (virtual-put proc)
- (-> Text @;Proc)
+ (-> Text @.Proc)
(function [analyse eval args]
(case args
(^ (list classC fieldC valueC objectC))
(case [classC fieldC]
- [[_ (#;Text class)] [_ (#;Text field)]]
- (do macro;Monad
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do macro.Monad
[[objectT objectA] (analyse-object class analyse objectC)
- _ (&;infer objectT)
+ _ (&.infer objectT)
[fieldT final?] (virtual-field class field objectT)
- _ (&;assert Cannot-Set-Final-Field (format class "#" field)
+ _ (&.assert Cannot-Set-Final-Field (format class "#" field)
(not final?))
[valueT unboxed valueA] (analyse-input analyse fieldT valueC)]
- (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA))))
+ (wrap (la.procedure proc (list (code.text class) (code.text field) (code.text unboxed) valueA objectA))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +4 (list;size args))))))
+ (&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +4 (list.size args))))))
(def: (java-type-to-parameter type)
- (-> java.lang.reflect.Type (Meta Text))
- (cond (host;instance? Class type)
- (macro/wrap (Class.getName [] (:! Class type)))
+ (-> java/lang/reflect/Type (Meta Text))
+ (cond (host.instance? Class type)
+ (macro/wrap (Class::getName [] (:! Class type)))
- (host;instance? ParameterizedType type)
- (java-type-to-parameter (ParameterizedType.getRawType [] (:! ParameterizedType type)))
+ (host.instance? ParameterizedType type)
+ (java-type-to-parameter (ParameterizedType::getRawType [] (:! ParameterizedType type)))
- (or (host;instance? TypeVariable type)
- (host;instance? WildcardType type))
+ (or (host.instance? TypeVariable type)
+ (host.instance? WildcardType type))
(macro/wrap "java.lang.Object")
- (host;instance? GenericArrayType type)
- (do macro;Monad
- [componentP (java-type-to-parameter (GenericArrayType.getGenericComponentType [] (:! GenericArrayType type)))]
+ (host.instance? GenericArrayType type)
+ (do macro.Monad
+ [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))]
(wrap (format componentP "[]")))
## else
- (&;throw Cannot-Convert-To-Parameter (type-descriptor type))))
+ (&.throw Cannot-Convert-To-Parameter (type-descriptor type))))
(type: Method-Type
#Static
@@ -917,326 +917,326 @@
(def: (check-method class method-name method-type arg-classes method)
(-> (Class Object) Text Method-Type (List Text) Method (Meta Bool))
- (do macro;Monad
- [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))
+ (do macro.Monad
+ [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])
+ (Modifier::isStatic [modifiers])
_
true)
(case method-type
#Special
- (not (or (Modifier.isInterface [(Class.getModifiers [] class)])
- (Modifier.isAbstract [modifiers])))
+ (not (or (Modifier::isInterface [(Class::getModifiers [] class)])
+ (Modifier::isAbstract [modifiers])))
_
true)
- (n.= (list;size arg-classes) (list;size parameters))
+ (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))))))
+ (list.zip2 arg-classes parameters))))))
(def: (check-constructor class arg-classes constructor)
(-> (Class Object) (List Text) (Constructor Object) (Meta Bool))
- (do macro;Monad
- [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))
+ (do macro.Monad
+ [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))))))
+ (list.zip2 arg-classes parameters))))))
(def: idx-to-bound
(-> Nat Type)
- (|>. (n.* +2) n.inc #;Bound))
+ (|>> (n/* +2) n/inc #.Bound))
(def: (type-vars amount offset)
(-> Nat Nat (List Type))
- (if (n.= +0 amount)
+ (if (n/= +0 amount)
(list)
- (|> (list;n.range offset (|> amount n.dec (n.+ offset)))
+ (|> (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)
+ (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)
+ (|> (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)
+ 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)
+ (if (list.empty? all-tvars)
fresh-mappings
(|> (list/compose owner-tvarsT method-tvarsT)
- list;reverse
- (list;zip2 all-tvars)
- (dict;from-list text;Hash))))]
- (do macro;Monad
- [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
+ list.reverse
+ (list.zip2 all-tvars)
+ (dict.from-list text.Hash))))]
+ (do macro.Monad
+ [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))
+ (list& (#.Primitive owner-name (list.reverse owner-tvarsT))
inputsT)))
outputT)]]
(wrap [methodT exceptionsT]))))
(def: (methods class-name method-name method-type arg-classes)
(-> Text Text Method-Type (List Text) (Meta [Type (List Type)]))
- (do macro;Monad
+ (do macro.Monad
[class (load-class class-name)
candidates (|> class
- (Class.getDeclaredMethods [])
- array;to-list
- (monad;map @ (function [method]
+ (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-Candidates (format class-name "#" method-name))
+ (case (list.filter product.left candidates)
+ #.Nil
+ (&.throw No-Candidates (format class-name "#" method-name))
- (#;Cons candidate #;Nil)
- (|> candidate product;right (method-to-type method-type))
+ (#.Cons candidate #.Nil)
+ (|> candidate product.right (method-to-type method-type))
_
- (&;throw Too-Many-Candidates (format class-name "#" method-name)))))
+ (&.throw Too-Many-Candidates (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)
+ (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)
+ 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)
+ (if (list.empty? all-tvars)
fresh-mappings
(|> (list/compose owner-tvarsT constructor-tvarsT)
- list;reverse
- (list;zip2 all-tvars)
- (dict;from-list text;Hash))))]
- (do macro;Monad
- [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)
+ list.reverse
+ (list.zip2 all-tvars)
+ (dict.from-list text.Hash))))]
+ (do macro.Monad
+ [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]))))
(def: (constructor-methods class-name arg-classes)
(-> Text (List Text) (Meta [Type (List Type)]))
- (do macro;Monad
+ (do macro.Monad
[class (load-class class-name)
candidates (|> class
- (Class.getConstructors [])
- array;to-list
- (monad;map @ (function [constructor]
+ (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-Candidates (format class-name "(" (text;join-with ", " arg-classes) ")"))
+ (case (list.filter product.left candidates)
+ #.Nil
+ (&.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")"))
- (#;Cons candidate #;Nil)
- (|> candidate product;right constructor-to-type)
+ (#.Cons candidate #.Nil)
+ (|> candidate product.right constructor-to-type)
_
- (&;throw Too-Many-Candidates class-name))))
+ (&.throw Too-Many-Candidates class-name))))
(def: (decorate-inputs typesT inputsA)
- (-> (List Text) (List la;Analysis) (List la;Analysis))
+ (-> (List Text) (List la.Analysis) (List la.Analysis))
(|> inputsA
- (list;zip2 (list/map code;text typesT))
+ (list.zip2 (list/map code.text typesT))
(list/map (function [[type value]]
- (la;product (list type value))))))
+ (la.product (list type value))))))
(def: (sub-type-analyser analyse)
- (-> &;Analyser &;Analyser)
+ (-> &.Analyser &.Analyser)
(function [argC]
- (do macro;Monad
- [[argT argA] (&common;with-unknown-type
+ (do macro.Monad
+ [[argT argA] (&common.with-unknown-type
(analyse argC))
- expectedT macro;expected-type
+ expectedT macro.expected-type
[unboxed castT] (cast #In expectedT argT)]
(wrap argA))))
(def: (invoke//static proc)
- (-> Text @;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 macro;Monad
- [#let [argsT (list/map product;left argsTC)]
+ (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 macro.Monad
+ [#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (methods class method #Static argsT)
- [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC))
+ [outputT argsA] (inferenceA.general (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)))))
+ (wrap (la.procedure proc (list& (code.text class) (code.text method)
+ (code.text unboxed) (decorate-inputs argsT argsA)))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//virtual proc)
- (-> Text @;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 macro;Monad
- [#let [argsT (list/map product;left argsTC)]
+ (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 macro.Monad
+ [#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (methods class method #Virtual argsT)
- [outputT allA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [outputT allA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC)))
#let [[objectA argsA] (case allA
- (#;Cons objectA argsA)
+ (#.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)))))
+ (wrap (la.procedure proc (list& (code.text class) (code.text method)
+ (code.text unboxed) objectA (decorate-inputs argsT argsA)))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//special proc)
- (-> Text @;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 macro;Monad
- [#let [argsT (list/map product;left argsTC)]
+ (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 macro.Monad
+ [#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (methods class method #Special argsT)
- [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [outputT argsA] (inferenceA.general (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)))))
+ (wrap (la.procedure proc (list& (code.text class) (code.text method)
+ (code.text unboxed) (decorate-inputs argsT argsA)))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//interface proc)
- (-> Text @;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 macro;Monad
- [#let [argsT (list/map product;left argsTC)]
+ (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 macro.Monad
+ [#let [argsT (list/map product.left argsTC)]
class (load-class class-name)
- _ (&;assert Non-Interface class-name
- (Modifier.isInterface [(Class.getModifiers [] class)]))
+ _ (&.assert Non-Interface class-name
+ (Modifier::isInterface [(Class::getModifiers [] class)]))
[methodT exceptionsT] (methods class-name method #Interface argsT)
- [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [outputT argsA] (inferenceA.general (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)
+ (wrap (la.procedure proc
+ (list& (code.text class-name) (code.text method) (code.text unboxed)
(decorate-inputs argsT argsA)))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//constructor proc)
- (-> Text @;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 macro;Monad
- [#let [argsT (list/map product;left argsTC)]
+ (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 macro.Monad
+ [#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (constructor-methods class argsT)
- [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC))
+ [outputT argsA] (inferenceA.general (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)))))
+ (wrap (la.procedure proc (list& (code.text class) (decorate-inputs argsT argsA)))))
_
- (&;throw Wrong-Syntax (wrong-syntax proc args)))))
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))))
(def: member-procs
- @;Bundle
- (<| (@;prefix "member")
- (|> (dict;new text;Hash)
- (dict;merge (<| (@;prefix "static")
- (|> (dict;new text;Hash)
- (@;install "get" static-get)
- (@;install "put" static-put))))
- (dict;merge (<| (@;prefix "virtual")
- (|> (dict;new text;Hash)
- (@;install "get" virtual-get)
- (@;install "put" virtual-put))))
- (dict;merge (<| (@;prefix "invoke")
- (|> (dict;new text;Hash)
- (@;install "static" invoke//static)
- (@;install "virtual" invoke//virtual)
- (@;install "special" invoke//special)
- (@;install "interface" invoke//interface)
- (@;install "constructor" invoke//constructor)
+ @.Bundle
+ (<| (@.prefix "member")
+ (|> (dict.new text.Hash)
+ (dict.merge (<| (@.prefix "static")
+ (|> (dict.new text.Hash