aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser/procedure
diff options
context:
space:
mode:
authorEduardo Julian2017-10-11 18:57:44 -0400
committerEduardo Julian2017-10-11 18:57:44 -0400
commit74a835634fc9ee5457f3cc7109af069dad9f2d2f (patch)
treedec444467ecde32ac165627f782f315ac41567e8 /new-luxc/source/luxc/analyser/procedure
parentccabfc6a5e41650788199cb8fd5d87731f094bcd (diff)
- Migrated new-luxc to latest version of stdlib.
- Some refactoring.
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser/procedure.lux20
-rw-r--r--new-luxc/source/luxc/analyser/procedure/common.lux86
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux57
3 files changed, 82 insertions, 81 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux
index 064a28e9b..23fbae198 100644
--- a/new-luxc/source/luxc/analyser/procedure.lux
+++ b/new-luxc/source/luxc/analyser/procedure.lux
@@ -1,23 +1,23 @@
(;module:
lux
(lux (control [monad #+ do])
- (data [text]
+ (data [maybe]
+ [text]
text/format
- (coll ["d" dict])
- [maybe]))
+ (coll [dict])))
(luxc ["&" base]
- (lang ["la" analysis #+ Analysis]))
+ (lang ["la" analysis]))
(. ["./;" common]
["./;" host]))
(def: procedures
./common;Bundle
(|> ./common;procedures
- (d;merge ./host;procedures)))
+ (dict;merge ./host;procedures)))
(def: #export (analyse-procedure analyse proc-name proc-args)
- (-> &;Analyser Text (List Code) (Lux Analysis))
- (default (&;fail (format "Unknown procedure: " (%t proc-name)))
- (do maybe;Monad<Maybe>
- [proc (d;get proc-name procedures)]
- (wrap (proc analyse proc-args)))))
+ (-> &;Analyser Text (List Code) (Lux la;Analysis))
+ (<| (maybe;default (&;fail (format "Unknown procedure: " (%t proc-name))))
+ (do maybe;Monad<Maybe>
+ [proc (dict;get proc-name procedures)]
+ (wrap (proc analyse proc-args)))))
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux
index ffb87a2ca..a0f739f3b 100644
--- a/new-luxc/source/luxc/analyser/procedure/common.lux
+++ b/new-luxc/source/luxc/analyser/procedure/common.lux
@@ -6,32 +6,32 @@
text/format
(coll [list "list/" Functor<List>]
[array #+ Array]
- ["d" dict]))
+ [dict #+ Dict]))
[macro #+ Monad<Lux>]
- (type ["TC" check])
+ (type ["tc" check])
[io])
(luxc ["&" base]
- (lang ["la" analysis #+ Analysis])
+ (lang ["la" analysis])
(analyser ["&;" common])))
## [Utils]
(type: #export Proc
- (-> &;Analyser (List Code) (Lux Analysis)))
+ (-> &;Analyser (List Code) (Lux la;Analysis)))
(type: #export Bundle
- (d;Dict Text Proc))
+ (Dict Text Proc))
(def: #export (install name unnamed)
(-> Text (-> Text Proc)
(-> Bundle Bundle))
- (d;put name (unnamed name)))
+ (dict;put name (unnamed name)))
(def: #export (prefix prefix bundle)
(-> Text Bundle Bundle)
(|> bundle
- d;entries
+ dict;entries
(list/map (function [[key val]] [(format prefix " " key) val]))
- (d;from-list text;Hash<Text>)))
+ (dict;from-list text;Hash<Text>)))
(def: #export (wrong-arity proc expected actual)
(-> Text Nat Nat Text)
@@ -52,8 +52,8 @@
(analyse argC)))
(list;zip2 input-types args))
expected macro;expected-type
- _ (&;within-type-env
- (TC;check expected output-type))]
+ _ (&;with-type-env
+ (tc;check expected output-type))]
(wrap (#la;Procedure proc argsA)))
(&;fail (wrong-arity proc num-expected num-actual)))))))
@@ -95,11 +95,11 @@
(do Monad<Lux>
[opA (&;with-expected-type (type (io;IO varT))
(analyse opC))
- outputT (&;within-type-env
- (TC;clean var-id (type (Either Text varT))))
+ outputT (&;with-type-env
+ (tc;clean var-id (type (Either Text varT))))
expected macro;expected-type
- _ (&;within-type-env
- (TC;check expected outputT))]
+ _ (&;with-type-env
+ (tc;check expected outputT))]
(wrap (#la;Procedure proc (list opA))))
_
@@ -107,14 +107,14 @@
(def: lux-procs
Bundle
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "is" lux-is)
(install "try" lux-try)))
(def: io-procs
Bundle
(<| (prefix "io")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "log" (unary Text Unit))
(install "error" (unary Text Bottom))
(install "exit" (unary Nat Bottom))
@@ -123,7 +123,7 @@
(def: bit-procs
Bundle
(<| (prefix "bit")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "count" (unary Nat Nat))
(install "and" (binary Nat Nat Nat))
(install "or" (binary Nat Nat Nat))
@@ -136,7 +136,7 @@
(def: nat-procs
Bundle
(<| (prefix "nat")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "+" (binary Nat Nat Nat))
(install "-" (binary Nat Nat Nat))
(install "*" (binary Nat Nat Nat))
@@ -152,7 +152,7 @@
(def: int-procs
Bundle
(<| (prefix "int")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "+" (binary Int Int Int))
(install "-" (binary Int Int Int))
(install "*" (binary Int Int Int))
@@ -168,7 +168,7 @@
(def: deg-procs
Bundle
(<| (prefix "deg")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "+" (binary Deg Deg Deg))
(install "-" (binary Deg Deg Deg))
(install "*" (binary Deg Deg Deg))
@@ -185,7 +185,7 @@
(def: frac-procs
Bundle
(<| (prefix "frac")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "+" (binary Frac Frac Frac))
(install "-" (binary Frac Frac Frac))
(install "*" (binary Frac Frac Frac))
@@ -207,7 +207,7 @@
(def: text-procs
Bundle
(<| (prefix "text")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "=" (binary Text Text Bool))
(install "<" (binary Text Text Bool))
(install "prepend" (binary Text Text Text))
@@ -246,7 +246,7 @@
(def: array-procs
Bundle
(<| (prefix "array")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "new" (unary Nat Array))
(install "get" array-get)
(install "put" array-put)
@@ -257,7 +257,7 @@
(def: math-procs
Bundle
(<| (prefix "math")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "cos" (unary Frac Frac))
(install "sin" (unary Frac Frac))
(install "tan" (unary Frac Frac))
@@ -288,11 +288,11 @@
(do Monad<Lux>
[initA (&;with-expected-type varT
(analyse initC))
- outputT (&;within-type-env
- (TC;clean var-id (type (A;Atom varT))))
+ outputT (&;with-type-env
+ (tc;clean var-id (type (A;Atom varT))))
expected macro;expected-type
- _ (&;within-type-env
- (TC;check expected outputT))]
+ _ (&;with-type-env
+ (tc;check expected outputT))]
(wrap (#la;Procedure proc (list initA))))
_
@@ -317,7 +317,7 @@
(def: atom-procs
Bundle
(<| (prefix "atom")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "new" atom-new)
(install "read" atom-read)
(install "compare-and-swap" atom-compare-and-swap)
@@ -326,7 +326,7 @@
(def: process-procs
Bundle
(<| (prefix "process")
- (|> (d;new text;Hash<Text>)
+ (|> (dict;new text;Hash<Text>)
(install "concurrency-level" (nullary Nat))
(install "future" (unary (type (io;IO Top)) Unit))
(install "schedule" (binary Nat (type (io;IO Top)) Unit))
@@ -335,16 +335,16 @@
(def: #export procedures
Bundle
(<| (prefix "lux")
- (|> (d;new text;Hash<Text>)
- (d;merge lux-procs)
- (d;merge bit-procs)
- (d;merge nat-procs)
- (d;merge int-procs)
- (d;merge deg-procs)
- (d;merge frac-procs)
- (d;merge text-procs)
- (d;merge array-procs)
- (d;merge math-procs)
- (d;merge atom-procs)
- (d;merge process-procs)
- (d;merge io-procs))))
+ (|> (dict;new text;Hash<Text>)
+ (dict;merge lux-procs)
+ (dict;merge bit-procs)
+ (dict;merge nat-procs)
+ (dict;merge int-procs)
+ (dict;merge deg-procs)
+ (dict;merge frac-procs)
+ (dict;merge text-procs)
+ (dict;merge array-procs)
+ (dict;merge math-procs)
+ (dict;merge atom-procs)
+ (dict;merge process-procs)
+ (dict;merge io-procs))))
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index a8af2748a..1dba7a5f8 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -5,6 +5,7 @@
["ex" exception #+ exception:])
(concurrency ["A" atom])
(data ["R" result]
+ [maybe]
[product]
[text "text/" Eq<Text>]
(text format
@@ -18,7 +19,7 @@
[host])
(luxc ["&" base]
["&;" host]
- (lang ["la" analysis #+ Analysis])
+ (lang ["la" analysis])
(analyser ["&;" common]))
["@" ../common]
)
@@ -245,7 +246,7 @@
(case elemT
(#;Host name #;Nil)
(let [boxed-name (|> (dict;get name boxes)
- (default name))]
+ (maybe;default name))]
(wrap [(#;Host boxed-name #;Nil)
boxed-name]))
@@ -267,8 +268,8 @@
(do macro;Monad<Lux>
[arrayA (&;with-expected-type (type (Array varT))
(analyse arrayC))
- elemT (&;within-type-env
- (tc;read-var var-id))
+ elemT (&;with-type-env
+ (tc;read var-id))
[elemT elem-class] (box-array-element-type elemT)
idxA (&;with-expected-type Nat
(analyse idxC))
@@ -288,8 +289,8 @@
(do macro;Monad<Lux>
[arrayA (&;with-expected-type (type (Array varT))
(analyse arrayC))
- elemT (&;within-type-env
- (tc;read-var var-id))
+ elemT (&;with-type-env
+ (tc;read var-id))
[valueT elem-class] (box-array-element-type elemT)
idxA (&;with-expected-type Nat
(analyse idxC))
@@ -334,8 +335,8 @@
(do macro;Monad<Lux>
[objectA (&;with-expected-type varT
(analyse objectC))
- objectT (&;within-type-env
- (tc;read-var var-id))
+ objectT (&;with-type-env
+ (tc;read var-id))
_ (check-object objectT)
_ (&;infer Bool)]
(wrap (#la;Procedure proc (list objectA))))
@@ -353,8 +354,8 @@
(do macro;Monad<Lux>
[monitorA (&;with-expected-type varT
(analyse monitorC))
- monitorT (&;within-type-env
- (tc;read-var var-id))
+ monitorT (&;with-type-env
+ (tc;read var-id))
_ (check-object monitorT)
exprA (analyse exprC)]
(wrap (#la;Procedure proc (list monitorA exprA))))
@@ -432,8 +433,8 @@
(do macro;Monad<Lux>
[exceptionA (&;with-expected-type varT
(analyse exceptionC))
- exceptionT (&;within-type-env
- (tc;read-var var-id))
+ exceptionT (&;with-type-env
+ (tc;read var-id))
exception-class (check-object exceptionT)
? (sub-class? "java.lang.Throwable" exception-class)
_ (: (Lux Unit)
@@ -478,8 +479,8 @@
(do macro;Monad<Lux>
[objectA (&;with-expected-type varT
(analyse objectC))
- objectT (&;within-type-env
- (tc;read-var var-id))
+ objectT (&;with-type-env
+ (tc;read var-id))
object-class (check-object objectT)
? (sub-class? class object-class)]
(if ?
@@ -599,13 +600,13 @@
[to-name (check-jvm to)
from-name (check-jvm from)]
(cond (dict;contains? to-name boxes)
- (let [box (assume (dict;get to-name boxes))]
+ (let [box (maybe;assume (dict;get to-name boxes))]
(if (text/= box from-name)
(wrap [box (#;Host to-name (list))])
(&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name))))
(dict;contains? from-name boxes)
- (let [box (assume (dict;get from-name boxes))]
+ (let [box (maybe;assume (dict;get from-name boxes))]
(do @
[[_ castT] (cast to (#;Host box (list)))]
(wrap [from-name castT])))
@@ -709,8 +710,8 @@
target-class))
sourceA (&;with-expected-type varT
(analyse sourceC))
- sourceT (&;within-type-env
- (tc;read-var var-id))
+ sourceT (&;with-type-env
+ (tc;read var-id))
[unboxed castT] (cast targetT sourceT)
_ (&;assert (format "Object cannot be a primitive: " unboxed)
(text;empty? unboxed))]
@@ -722,8 +723,8 @@
(do macro;Monad<Lux>
[sourceA (&;with-expected-type varT
(analyse sourceC))
- sourceT (&;within-type-env
- (tc;read-var var-id))
+ sourceT (&;with-type-env
+ (tc;read var-id))
[unboxed castT] (cast targetT sourceT)]
(wrap [castT unboxed sourceA]))))
@@ -738,8 +739,8 @@
[[fieldT final?] (static-field class field)
expectedT macro;expected-type
[unboxed castT] (cast expectedT fieldT)
- _ (&;within-type-env
- (tc;check expectedT castT))]
+ _ (&;with-type-env
+ (tc;check expectedT castT))]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed)))))
_
@@ -760,8 +761,8 @@
_ (&;assert (Final-Field (format class "#" field))
(not final?))
[valueT unboxed valueA] (analyse-input analyse fieldT valueC)
- _ (&;within-type-env
- (tc;check fieldT valueT))
+ _ (&;with-type-env
+ (tc;check fieldT valueT))
_ (&;infer Unit)]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA))))
@@ -783,8 +784,8 @@
[fieldT final?] (virtual-field class field objectT)
expectedT macro;expected-type
[unboxed castT] (cast expectedT fieldT)
- _ (&;within-type-env
- (tc;check expectedT castT))]
+ _ (&;with-type-env
+ (tc;check expectedT castT))]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA))))
_
@@ -806,8 +807,8 @@
_ (&;assert (Final-Field (format class "#" field))
(not final?))
[valueT unboxed valueA] (analyse-input analyse fieldT valueC)
- _ (&;within-type-env
- (tc;check fieldT valueT))
+ _ (&;with-type-env
+ (tc;check fieldT valueT))
_ (&;infer Unit)]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA objectA))))