aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/analysis/procedure
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis/procedure')
-rw-r--r--new-luxc/source/luxc/lang/analysis/procedure/common.lux183
-rw-r--r--new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux514
2 files changed, 348 insertions, 349 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
index 778e57b94..fff5de504 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
@@ -1,6 +1,7 @@
(;module:
lux
- (lux (control [monad #+ do])
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
(concurrency [atom #+ Atom])
(data [text]
text/format
@@ -18,6 +19,8 @@
[";A" case]
[";A" type]))))
+(exception: #export Incorrect-Procedure-Arity)
+
## [Utils]
(type: #export Proc
(-> &;Analyser &;Eval (List Code) (Meta la;Analysis)))
@@ -39,27 +42,25 @@
(def: #export (wrong-arity proc expected actual)
(-> Text Nat Nat Text)
- (format "Wrong arity for " (%t proc) "\n"
- "Expected: " (|> expected nat-to-int %i) "\n"
- " Actual: " (|> actual nat-to-int %i)))
+ (format " Procedure: " (%t proc) "\n"
+ " Expected Arity: " (|> expected nat-to-int %i) "\n"
+ " Actual Arity: " (|> actual nat-to-int %i)))
-(def: (simple proc input-types output-type)
+(def: (simple proc inputsT+ outputT)
(-> Text (List Type) Type Proc)
- (let [num-expected (list;size input-types)]
+ (let [num-expected (list;size inputsT+)]
(function [analyse eval args]
(let [num-actual (list;size args)]
(if (n.= num-expected num-actual)
(do meta;Monad<Meta>
- [argsA (monad;map @
+ [_ (&;infer outputT)
+ argsA (monad;map @
(function [[argT argC]]
(&;with-expected-type argT
(analyse argC)))
- (list;zip2 input-types args))
- expected meta;expected-type
- _ (&;with-type-env
- (tc;check expected output-type))]
+ (list;zip2 inputsT+ args))]
(wrap (la;procedure proc argsA)))
- (&;fail (wrong-arity proc num-expected num-actual)))))))
+ (&;throw Incorrect-Procedure-Arity (wrong-arity proc num-expected num-actual)))))))
(def: #export (nullary valueT proc)
(-> Type Text Proc)
@@ -82,71 +83,60 @@
(def: (lux-is proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((binary varT varT Bool proc)
- analyse eval args)))))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)]
+ ((binary varT varT Bool proc)
+ analyse eval args))))
## "lux try" provides a simple way to interact with the host platform's
## error-handling facilities.
(def: (lux-try proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list opC))
- (do meta;Monad<Meta>
- [opA (&;with-expected-type (type (io;IO varT))
- (analyse opC))
- outputT (&;with-type-env
- (tc;clean var-id (type (Either Text varT))))
- expected meta;expected-type
- _ (&;with-type-env
- (tc;check expected outputT))]
- (wrap (la;procedure proc (list opA))))
-
- _
- (&;fail (wrong-arity proc +1 (list;size args))))))))
+ (case args
+ (^ (list opC))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)
+ _ (&;infer (type (Either Text varT)))
+ opA (&;with-expected-type (type (io;IO varT))
+ (analyse opC))]
+ (wrap (la;procedure proc (list opA))))
+
+ _
+ (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args))))))
(def: (lux//function proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list [_ (#;Symbol ["" func-name])]
- [_ (#;Symbol ["" arg-name])]
- body))
- (functionA;analyse-function analyse func-name arg-name body)
-
- _
- (&;fail (wrong-arity proc +3 (list;size args))))))))
+ (case args
+ (^ (list [_ (#;Symbol ["" func-name])]
+ [_ (#;Symbol ["" arg-name])]
+ body))
+ (functionA;analyse-function analyse func-name arg-name body)
+
+ _
+ (&;throw Incorrect-Procedure-Arity (wrong-arity proc +3 (list;size args))))))
(def: (lux//case proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list input [_ (#;Record branches)]))
- (caseA;analyse-case analyse input branches)
-
- _
- (&;fail (wrong-arity proc +2 (list;size args))))))))
+ (case args
+ (^ (list input [_ (#;Record branches)]))
+ (caseA;analyse-case analyse input branches)
+
+ _
+ (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args))))))
(do-template [<name> <analyser>]
[(def: (<name> proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list typeC valueC))
- (<analyser> analyse eval typeC valueC)
-
- _
- (&;fail (wrong-arity proc +2 (list;size args))))))))]
+ (case args
+ (^ (list typeC valueC))
+ (<analyser> analyse eval typeC valueC)
+
+ _
+ (&;throw Incorrect-Procedure-Arity (wrong-arity proc +2 (list;size args))))))]
[lux//check typeA;analyse-check]
[lux//coerce typeA;analyse-coerce])
@@ -193,15 +183,13 @@
(case args
(^ (list valueC))
(do meta;Monad<Meta>
- [valueA (&;with-expected-type Type
- (analyse valueC))
- expected meta;expected-type
- _ (&;with-type-env
- (tc;check expected Type))]
+ [_ (&;infer (type Type))
+ valueA (&;with-expected-type Type
+ (analyse valueC))]
(wrap valueA))
_
- (&;fail (wrong-arity proc +1 (list;size args))))))
+ (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args))))))
(def: lux-procs
Bundle
@@ -326,26 +314,26 @@
(def: (array-get proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((binary Nat (type (Array varT)) varT proc)
- analyse eval args)))))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)]
+ ((binary Nat (type (Array varT)) varT proc)
+ analyse eval args))))
(def: (array-put proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc)
- analyse eval args)))))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)]
+ ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc)
+ analyse eval args))))
(def: (array-remove proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((binary Nat (type (Array varT)) (type (Array varT)) proc)
- analyse eval args)))))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)]
+ ((binary Nat (type (Array varT)) (type (Array varT)) proc)
+ analyse eval args))))
(def: array-procs
Bundle
@@ -385,38 +373,33 @@
(def: (atom-new proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list initC))
- (do meta;Monad<Meta>
- [initA (&;with-expected-type varT
- (analyse initC))
- outputT (&;with-type-env
- (tc;clean var-id (type (Atom varT))))
- expected meta;expected-type
- _ (&;with-type-env
- (tc;check expected outputT))]
- (wrap (la;procedure proc (list initA))))
-
- _
- (&;fail (wrong-arity proc +1 (list;size args))))))))
+ (case args
+ (^ (list initC))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)
+ _ (&;infer (type (Atom varT)))
+ initA (&;with-expected-type varT
+ (analyse initC))]
+ (wrap (la;procedure proc (list initA))))
+
+ _
+ (&;throw Incorrect-Procedure-Arity (wrong-arity proc +1 (list;size args))))))
(def: (atom-read proc)
(-> Text Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- ((unary (type (Atom varT)) varT proc)
- analyse eval args)))))
+ (do meta;Monad<Meta>
+ [[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]
- (&common;with-var
- (function [[var-id varT]]
- ((trinary varT varT (type (Atom varT)) Bool proc)
- analyse eval args)))))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)]
+ ((trinary varT varT (type (Atom varT)) Bool proc)
+ analyse eval args))))
(def: atom-procs
Bundle
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 3ba7713ac..fa10a7a1c 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
@@ -28,6 +28,49 @@
["@" ../common]
)
+(exception: #export Wrong-Syntax)
+(def: (wrong-syntax procedure args)
+ (-> Text (List Code) Text)
+ (format "Procedure: " procedure "\n"
+ "Arguments: " (%code (code;tuple args))))
+
+(exception: #export JVM-Type-Is-Not-Class)
+
+(exception: #export Non-Interface)
+(exception: #export Non-Object)
+(exception: #export Non-Array)
+(exception: #export Non-Throwable)
+(exception: #export Non-JVM-Type)
+
+(exception: #export Unknown-Class)
+(exception: #export Primitives-Cannot-Have-Type-Parameters)
+(exception: #export Primitives-Are-Not-Objects)
+(exception: #export Invalid-Type-For-Array-Element)
+
+(exception: #export Unknown-Field)
+(exception: #export Mistaken-Field-Owner)
+(exception: #export Not-Virtual-Field)
+(exception: #export Not-Static-Field)
+(exception: #export Cannot-Set-Final-Field)
+
+(exception: #export No-Candidates)
+(exception: #export Too-Many-Candidates)
+
+(exception: #export Cannot-Cast)
+(def: (cannot-cast to from)
+ (-> Type Type Text)
+ (format "From: " (%type from) "\n"
+ " To: " (%type to)))
+
+(exception: #export Cannot-Possibly-Be-Instance)
+
+(exception: #export Cannot-Convert-To-Class)
+(exception: #export Cannot-Convert-To-Parameter)
+(exception: #export Cannot-Convert-To-Lux-Type)
+(exception: #export Unknown-Type-Var)
+(exception: #export Type-Parameter-Mismatch)
+(exception: #export Cannot-Correspond-Type-With-Class)
+
(def: #export null-class Text "#Null")
(do-template [<name> <class>]
@@ -149,22 +192,17 @@
(def: (array-length proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list arrayC))
- (do meta;Monad<Meta>
- [arrayA (&;with-expected-type (type (Array varT))
- (analyse arrayC))
- _ (&;infer Nat)]
- (wrap (la;procedure proc (list arrayA))))
-
- _
- (&;fail (@;wrong-arity proc +1 (list;size args))))))))
-
-(def: (invalid-array-type arrayT)
- (-> Type Text)
- (format "Invalid type for array: " (%type arrayT)))
+ (case args
+ (^ (list arrayC))
+ (do meta;Monad<Meta>
+ [_ (&;infer Nat)
+ [var-id varT] (&;with-type-env tc;var)
+ arrayA (&;with-expected-type (type (Array varT))
+ (analyse arrayC))]
+ (wrap (la;procedure proc (list arrayA))))
+
+ _
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
(def: (array-new proc)
(-> Text @;Proc)
@@ -185,7 +223,7 @@
(recur outputT level)
#;None
- (&;fail (invalid-array-type expectedT)))
+ (&;throw Non-Array (%type expectedT)))
(^ (#;Primitive "#Array" (list elemT)))
(recur elemT (n.inc level))
@@ -194,15 +232,14 @@
(wrap [level class])
_
- (&;fail (invalid-array-type expectedT)))))
- _ (&;assert "Must have at least 1 level of nesting in array type."
- (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))))
_
- (&;fail (@;wrong-arity proc +1 (list;size args))))))
-
-(exception: #export Not-Object-Type)
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
(def: (check-jvm objectT)
(-> Type (Meta Text))
@@ -228,81 +265,77 @@
(check-jvm outputT)
#;None
- (&;throw Not-Object-Type (%type objectT)))
+ (&;throw Non-Object (%type objectT)))
_
- (&;throw Not-Object-Type (%type objectT))))
+ (&;throw Non-Object (%type objectT))))
(def: (check-object objectT)
(-> Type (Meta Text))
(do meta;Monad<Meta>
[name (check-jvm objectT)]
(if (dict;contains? name boxes)
- (&;fail (format "Primitives are not objects: " name))
- (:: meta;Monad<Meta> wrap name))))
+ (&;throw Primitives-Are-Not-Objects name)
+ (meta/wrap name))))
(def: (box-array-element-type elemT)
(-> Type (Meta [Type Text]))
- (do meta;Monad<Meta>
- []
- (case elemT
- (#;Primitive name #;Nil)
- (let [boxed-name (|> (dict;get name boxes)
- (maybe;default name))]
- (wrap [(#;Primitive boxed-name #;Nil)
- boxed-name]))
-
- (#;Primitive name _)
- (if (dict;contains? name boxes)
- (&;fail (format "Primitives cannot be parameterized: " name))
- (:: meta;Monad<Meta> wrap [elemT name]))
+ (case elemT
+ (#;Primitive name #;Nil)
+ (let [boxed-name (|> (dict;get name boxes)
+ (maybe;default name))]
+ (meta/wrap [(#;Primitive boxed-name #;Nil)
+ boxed-name]))
- _
- (&;fail (format "Invalid type for array element: " (%type elemT))))))
+ (#;Primitive name _)
+ (if (dict;contains? name boxes)
+ (&;throw Primitives-Cannot-Have-Type-Parameters name)
+ (meta/wrap [elemT name]))
+
+ _
+ (&;throw Invalid-Type-For-Array-Element (%type elemT))))
(def: (array-read proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list arrayC idxC))
- (do meta;Monad<Meta>
- [arrayA (&;with-expected-type (type (Array varT))
- (analyse arrayC))
- elemT (&;with-type-env
- (tc;read var-id))
- [elemT elem-class] (box-array-element-type elemT)
- idxA (&;with-expected-type Nat
- (analyse idxC))
- _ (&;infer elemT)]
- (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA))))
-
- _
- (&;fail (@;wrong-arity proc +2 (list;size args))))))))
+ (case args
+ (^ (list arrayC idxC))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)
+ _ (&;infer varT)
+ arrayA (&;with-expected-type (type (Array varT))
+ (analyse arrayC))
+ elemT (&;with-type-env
+ (tc;read var-id))
+ [elemT elem-class] (box-array-element-type elemT)
+ idxA (&;with-expected-type Nat
+ (analyse idxC))]
+ (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA))))
+
+ _
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args))))))
(def: (array-write proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list arrayC idxC valueC))
- (do meta;Monad<Meta>
- [arrayA (&;with-expected-type (type (Array varT))
- (analyse arrayC))
- elemT (&;with-type-env
- (tc;read var-id))
- [valueT elem-class] (box-array-element-type elemT)
- idxA (&;with-expected-type Nat
- (analyse idxC))
- valueA (&;with-expected-type valueT
- (analyse valueC))
- _ (&;infer (type (Array elemT)))]
- (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA))))
-
- _
- (&;fail (@;wrong-arity proc +3 (list;size args))))))))
+ (case args
+ (^ (list arrayC idxC valueC))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)
+ _ (&;infer (type (Array varT)))
+ arrayA (&;with-expected-type (type (Array varT))
+ (analyse arrayC))
+ elemT (&;with-type-env
+ (tc;read var-id))
+ [valueT elem-class] (box-array-element-type elemT)
+ idxA (&;with-expected-type Nat
+ (analyse idxC))
+ valueA (&;with-expected-type valueT
+ (analyse valueC))]
+ (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA))))
+
+ _
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args))))))
(def: array-procs
@;Bundle
@@ -325,45 +358,43 @@
(wrap (la;procedure proc (list))))
_
- (&;fail (@;wrong-arity proc +0 (list;size args))))))
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +0 (list;size args))))))
(def: (object-null? proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list objectC))
- (do meta;Monad<Meta>
- [objectA (&;with-expected-type varT
- (analyse objectC))
- objectT (&;with-type-env
- (tc;read var-id))
- _ (check-object objectT)
- _ (&;infer Bool)]
- (wrap (la;procedure proc (list objectA))))
-
- _
- (&;fail (@;wrong-arity proc +1 (list;size args))))))))
+ (case args
+ (^ (list objectC))
+ (do meta;Monad<Meta>
+ [_ (&;infer Bool)
+ [var-id varT] (&;with-type-env tc;var)
+ objectA (&;with-expected-type varT
+ (analyse objectC))
+ objectT (&;with-type-env
+ (tc;read var-id))
+ _ (check-object objectT)]
+ (wrap (la;procedure proc (list objectA))))
+
+ _
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
(def: (object-synchronized proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list monitorC exprC))
- (do meta;Monad<Meta>
- [monitorA (&;with-expected-type varT
- (analyse monitorC))
- monitorT (&;with-type-env
- (tc;read var-id))
- _ (check-object monitorT)
- exprA (analyse exprC)]
- (wrap (la;procedure proc (list monitorA exprA))))
-
- _
- (&;fail (@;wrong-arity proc +2 (list;size args))))))))
+ (case args
+ (^ (list monitorC exprC))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)
+ monitorA (&;with-expected-type varT
+ (analyse monitorC))
+ monitorT (&;with-type-env
+ (tc;read var-id))
+ _ (check-object monitorT)
+ exprA (analyse exprC)]
+ (wrap (la;procedure proc (list monitorA exprA))))
+
+ _
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args))))))
(host;import java.lang.Object
(equals [Object] boolean))
@@ -436,7 +467,7 @@
(wrap class)
(#e;Error error)
- (&;fail (format "Unknown class: " name)))))
+ (&;throw Unknown-Class name))))
(def: (sub-class? super sub)
(-> Text Text (Meta Bool))
@@ -445,31 +476,28 @@
sub (load-class sub)]
(wrap (Class.isAssignableFrom [sub] super))))
-(exception: #export Not-Throwable)
-
(def: (object-throw proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list exceptionC))
- (do meta;Monad<Meta>
- [exceptionA (&;with-expected-type varT
- (analyse exceptionC))
- exceptionT (&;with-type-env
- (tc;read var-id))
- exception-class (check-object exceptionT)
- ? (sub-class? "java.lang.Throwable" exception-class)
- _ (: (Meta Unit)
- (if ?
- (wrap [])
- (&;throw Not-Throwable exception-class)))
- _ (&;infer Bottom)]
- (wrap (la;procedure proc (list exceptionA))))
-
- _
- (&;fail (@;wrong-arity proc +1 (list;size args))))))))
+ (case args
+ (^ (list exceptionC))
+ (do meta;Monad<Meta>
+ [_ (&;infer Bottom)
+ [var-id varT] (&;with-type-env tc;var)
+ exceptionA (&;with-expected-type varT
+ (analyse exceptionC))
+ exceptionT (&;with-type-env
+ (tc;read var-id))
+ exception-class (check-object exceptionT)
+ ? (sub-class? "java.lang.Throwable" exception-class)
+ _ (: (Meta Unit)
+ (if ?
+ (wrap [])
+ (&;throw Non-Throwable exception-class)))]
+ (wrap (la;procedure proc (list exceptionA))))
+
+ _
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
(def: (object-class proc)
(-> Text @;Proc)
@@ -479,45 +507,38 @@
(case classC
[_ (#;Text class)]
(do meta;Monad<Meta>
- [_ (load-class class)
- _ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))]
+ [_ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))
+ _ (load-class class)]
(wrap (la;procedure proc (list (code;text class)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;fail (@;wrong-arity proc +1 (list;size args))))))
-
-(exception: #export Cannot-Be-Instance)
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +1 (list;size args))))))
(def: (object-instance? proc)
(-> Text @;Proc)
(function [analyse eval args]
- (&common;with-var
- (function [[var-id varT]]
- (case args
- (^ (list classC objectC))
- (case classC
- [_ (#;Text class)]
- (do meta;Monad<Meta>
- [objectA (&;with-expected-type varT
- (analyse objectC))
- objectT (&;with-type-env
- (tc;read var-id))
- object-class (check-object objectT)
- ? (sub-class? class object-class)]
- (if ?
- (do @
- [_ (&;infer Bool)]
- (wrap (la;procedure proc (list (code;text class)))))
- (&;throw Cannot-Be-Instance (format object-class " !<= " class))))
+ (case args
+ (^ (list classC objectC))
+ (case classC
+ [_ (#;Text class)]
+ (do meta;Monad<Meta>
+ [_ (&;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))))
- _
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ _
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
- _
- (&;fail (@;wrong-arity proc +2 (list;size args))))))))
+ _
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args))))))
(def: object-procs
@;Bundle
@@ -531,14 +552,6 @@
(@;install "instance?" object-instance?)
)))
-(exception: #export Final-Field)
-
-(exception: #export Cannot-Convert-To-Class)
-(exception: #export Cannot-Convert-To-Parameter)
-(exception: #export Cannot-Convert-To-Lux-Type)
-(exception: #export Cannot-Cast-To-Primitive)
-(exception: #export JVM-Type-Is-Not-Class)
-
(def: type-descriptor
(-> java.lang.reflect.Type Text)
(java.lang.reflect.Type.getTypeName []))
@@ -554,8 +567,6 @@
## else
(&;throw Cannot-Convert-To-Class (type-descriptor type))))
-(exception: #export Unknown-Type-Var)
-
(type: Mappings
(Dict Text Type))
@@ -634,18 +645,29 @@
(case type
(#;Primitive name params)
(let [class-name (Class.getName [] class)
- class-params (array;to-list (Class.getTypeParameters [] class))]
- (if (text/= class-name name)
- (if (n.= (list;size class-params)
- (list;size params))
- (meta/wrap (|> params
- (list;zip2 (list/map (TypeVariable.getName []) class-params))
- (dict;from-list text;Hash<Text>)))
- (&;fail (format "Class and host-type parameters do not match: " "class = " class-name " | host type = " name)))
- (&;fail (format "Class and host-type names do not match: " "class = " class-name " | host type = " name))))
+ 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
+ (format "Class = " class-name "\n"
+ "Type = " (%type type)))
+
+ (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"
+ " Type: " (%type type)))
+
+ ## else
+ (meta/wrap (|> params
+ (list;zip2 (list/map (TypeVariable.getName []) class-params))
+ (dict;from-list text;Hash<Text>)))
+ ))
_
- (&;fail (format "Not a host type: " (%type type)))))
+ (&;throw Non-JVM-Type (%type type))))
(def: (cast direction to from)
(-> Direction Type Type (Meta [Text Type]))
@@ -656,7 +678,7 @@
(let [box (maybe;assume (dict;get to-name boxes))]
(if (text/= box from-name)
(wrap [(choose direction to-name from-name) (#;Primitive to-name (list))])
- (&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name))))
+ (&;throw Cannot-Cast (cannot-cast to from))))
(dict;contains? from-name boxes)
(let [box (maybe;assume (dict;get from-name boxes))]
@@ -674,7 +696,7 @@
(do @
[to-class (load-class to-name)
from-class (load-class from-name)
- _ (&;assert (format "Class '" from-name "' is not a sub-class of class '" to-name "'.")
+ _ (&;assert Cannot-Cast (cannot-cast to from)
(Class.isAssignableFrom [from-class] to-class))
candiate-parents (monad;map @
(function [java-type]
@@ -695,7 +717,7 @@
(wrap [(choose direction to-name from-name) castT]))
#;Nil
- (&;fail (format "No valid path between " (%type from) "and " (%type to) ".")))))))
+ (&;throw Cannot-Cast (cannot-cast to from)))))))
(def: (infer-out outputT)
(-> Type (Meta [Text Type]))
@@ -715,11 +737,13 @@
(let [owner (Field.getDeclaringClass [] field)]
(if (is owner class)
(wrap [class field])
- (&;fail (format "Field '" field-name "' does not belong to class '" class-name "'.\n"
- "Belongs to '" (Class.getName [] owner) "'."))))
+ (&;throw Mistaken-Field-Owner
+ (format " Field: " field-name "\n"
+ " Owner Class: " (Class.getName [] owner) "\n"
+ "Target Class: " class-name "\n"))))
(#e;Error _)
- (&;fail (format "Unknown field '" field-name "' for class '" class-name "'.")))))
+ (&;throw Unknown-Field (format class-name "#" field-name)))))
(def: (static-field class-name field-name)
(-> Text Text (Meta [Type Bool]))
@@ -731,9 +755,7 @@
(do @
[fieldT (java-type-to-lux-type fresh-mappings fieldJT)]
(wrap [fieldT (Modifier.isFinal [modifiers])])))
- (&;fail (format "Field '" field-name "' of class '" class-name "' is not static.")))))
-
-(exception: #export Non-Object-Type)
+ (&;throw Not-Static-Field (format class-name "#" field-name)))))
(def: (virtual-field class-name field-name objectT)
(-> Text Text Type (Meta [Type Bool]))
@@ -753,44 +775,48 @@
(do @
[#let [num-params (list;size _class-params)
num-vars (list;size var-names)]
- _ (&;assert (format "Number of paremeters in type does not match expected amount (" (%n num-vars) "): " (%type objectT))
+ _ (&;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<Text>))))
_
- (&;throw Non-Object-Type (%type objectT))))
+ (&;throw Non-Object (%type objectT))))
fieldT (java-type-to-lux-type mappings fieldJT)]
(wrap [fieldT (Modifier.isFinal [modifiers])]))
- (&;fail (format "Field '" field-name "' of class '" class-name "' is static.")))))
+ (&;throw Not-Virtual-Field (format class-name "#" field-name)))))
(def: (analyse-object class analyse sourceC)
(-> Text &;Analyser Code (Meta [Type la;Analysis]))
- (<| &common;with-var (function [[var-id varT]])
- (do meta;Monad<Meta>
- [target-class (load-class class)
- targetT (java-type-to-lux-type fresh-mappings
- (:! java.lang.reflect.Type
- target-class))
- sourceA (&;with-expected-type varT
- (analyse sourceC))
- sourceT (&;with-type-env
- (tc;read var-id))
- [unboxed castT] (cast #Out targetT sourceT)
- _ (&;assert (format "Object cannot be a primitive: " unboxed)
- (not (dict;contains? unboxed boxes)))]
- (wrap [castT sourceA]))))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)
+ target-class (load-class class)
+ targetT (java-type-to-lux-type fresh-mappings
+ (:! java.lang.reflect.Type
+ target-class))
+ sourceA (&;with-expected-type varT
+ (analyse sourceC))
+ sourceT (&;with-type-env
+ (tc;read var-id))
+ [unboxed castT] (cast #Out targetT sourceT)
+ _ (&;assert 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]))
- (<| &common;with-var (function [[var-id varT]])
- (do meta;Monad<Meta>
- [sourceA (&;with-expected-type varT
- (analyse sourceC))
- sourceT (&;with-type-env
- (tc;read var-id))
- [unboxed castT] (cast #In targetT sourceT)]
- (wrap [castT unboxed sourceA]))))
+ (do meta;Monad<Meta>
+ [[var-id varT] (&;with-type-env tc;var)
+ sourceA (&;with-expected-type varT
+ (analyse sourceC))
+ sourceT (&;with-type-env
+ (tc;read var-id))
+ [unboxed castT] (cast #In targetT sourceT)]
+ (wrap [castT unboxed sourceA])))
(def: (static-get proc)
(-> Text @;Proc)
@@ -806,10 +832,10 @@
(code;text unboxed)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;fail (@;wrong-arity proc +2 (list;size args))))))
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +2 (list;size args))))))
(def: (static-put proc)
(-> Text @;Proc)
@@ -819,21 +845,21 @@
(case [classC fieldC]
[[_ (#;Text class)] [_ (#;Text field)]]
(do meta;Monad<Meta>
- [[fieldT final?] (static-field class field)
- _ (&;assert (Final-Field (format class "#" field))
+ [_ (&;infer Unit)
+ [fieldT final?] (static-field 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))
- _ (&;infer Unit)]
+ (tc;check fieldT valueT))]
(wrap (la;procedure proc (list (code;text class) (code;text field)
(code;text unboxed) valueA))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;fail (@;wrong-arity proc +3 (list;size args))))))
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args))))))
(def: (virtual-get proc)
(-> Text @;Proc)
@@ -850,10 +876,10 @@
(code;text unboxed) objectA))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;fail (@;wrong-arity proc +3 (list;size args))))))
+ (&;throw @;Incorrect-Procedure-Arity (@;wrong-arity proc +3 (list;size args))))))
(def: (virtual-put proc)
(-> Text @;Proc)
@@ -864,20 +890,18 @@
[[_ (#;Text class)] [_ (#;Text field)]]
(do meta;Monad<Meta>
[[objectT objectA] (analyse-object class analyse objectC)
+ _ (&;infer objectT)
[fieldT final?] (virtual-field class field objectT)
- _ (&;assert (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))
- _ (&;infer objectT)]
+ [valueT unboxed valueA] (analyse-input analyse fieldT valueC)]
(wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))
_
- (&;fail (@;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))
@@ -1007,9 +1031,6 @@
outputT)]]
(wrap [methodT exceptionsT]))))
-(exception: #export No-Candidate-Method)
-(exception: #export Too-Many-Candidate-Methods)
-
(def: (methods class-name method-name method-type arg-classes)
(-> Text Text Method-Type (List Text) (Meta [Type (List Type)]))
(do meta;Monad<Meta>
@@ -1023,13 +1044,13 @@
(wrap [passes? method])))))]
(case (list;filter product;left candidates)
#;Nil
- (&;throw No-Candidate-Method (format class-name "#" method-name))
+ (&;throw No-Candidates (format class-name "#" method-name))
(#;Cons candidate #;Nil)
(|> candidate product;right (method-to-type method-type))
_
- (&;throw Too-Many-Candidate-Methods (format class-name "#" method-name)))))
+ (&;throw Too-Many-Candidates (format class-name "#" method-name)))))
(def: (constructor-to-type constructor)
(-> (Constructor Object) (Meta [Type (List Type)]))
@@ -1066,9 +1087,6 @@
objectT)]]
(wrap [constructorT exceptionsT]))))
-(exception: #export No-Candidate-Constructor)
-(exception: #export Too-Many-Candidate-Constructors)
-
(def: (constructor-methods class-name arg-classes)
(-> Text (List Text) (Meta [Type (List Type)]))
(do meta;Monad<Meta>
@@ -1082,13 +1100,13 @@
(wrap [passes? constructor])))))]
(case (list;filter product;left candidates)
#;Nil
- (&;throw No-Candidate-Constructor (format class-name "(" (text;join-with ", " arg-classes) ")"))
+ (&;throw No-Candidates (format class-name "(" (text;join-with ", " arg-classes) ")"))
(#;Cons candidate #;Nil)
(|> candidate product;right constructor-to-type)
_
- (&;throw Too-Many-Candidate-Constructors class-name))))
+ (&;throw Too-Many-Candidates class-name))))
(def: (decorate-inputs typesT inputsA)
(-> (List Text) (List la;Analysis) (List la;Analysis))
@@ -1122,7 +1140,7 @@
(code;text unboxed) (decorate-inputs argsT argsA)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//virtual proc)
(-> Text @;Proc)
@@ -1145,7 +1163,7 @@
(code;text unboxed) objectA (decorate-inputs argsT argsA)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//special proc)
(-> Text @;Proc)
@@ -1162,9 +1180,7 @@
(code;text unboxed) (decorate-inputs argsT argsA)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))))
-
-(exception: #export Not-Interface)
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//interface proc)
(-> Text @;Proc)
@@ -1175,7 +1191,7 @@
(do meta;Monad<Meta>
[#let [argsT (list/map product;left argsTC)]
class (load-class class-name)
- _ (&;assert (Not-Interface class-name)
+ _ (&;assert Non-Interface class-name
(Modifier.isInterface [(Class.getModifiers [] class)]))
[methodT exceptionsT] (methods class-name method #Interface argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
@@ -1185,7 +1201,7 @@
(decorate-inputs argsT argsA)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))))
(def: (invoke//constructor proc)
(-> Text @;Proc)
@@ -1201,7 +1217,7 @@
(wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA)))))
_
- (&;fail (format "Wrong syntax for '" proc "'.")))))
+ (&;throw Wrong-Syntax (wrong-syntax proc args)))))
(def: member-procs
@;Bundle