aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/exception.lux48
-rw-r--r--stdlib/source/lux/control/monad.lux58
-rw-r--r--stdlib/source/lux/data/collection/array.lux28
-rw-r--r--stdlib/source/lux/type/check.lux145
-rw-r--r--stdlib/source/lux/world/file.lux18
5 files changed, 167 insertions, 130 deletions
diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
index a906c97aa..ca6ab6540 100644
--- a/stdlib/source/lux/control/exception.lux
+++ b/stdlib/source/lux/control/exception.lux
@@ -4,7 +4,7 @@
[monad (#+ do)]
["p" parser]]
[data
- ["/" error (#+ Error)]
+ ["//" error (#+ Error)]
["." maybe]
["." product]
["." text ("text/." Monoid<Text>)]
@@ -37,33 +37,33 @@
(-> (Exception e) (-> Text a) (Error a)
(Error a)))
(case try
- (#/.Success output)
- (#/.Success output)
+ (#//.Success output)
+ (#//.Success output)
- (#/.Error error)
+ (#//.Error error)
(let [reference (get@ #label exception)]
(if (text.starts-with? reference error)
- (#/.Success (|> error
- (text.clip (text.size reference) (text.size error))
- maybe.assume
- then))
- (#/.Error error)))))
+ (#//.Success (|> error
+ (text.clip (text.size reference) (text.size error))
+ maybe.assume
+ then))
+ (#//.Error error)))))
(def: #export (otherwise to-do try)
{#.doc "If no handler could be found to catch the exception, then run a function as a last-resort measure."}
(All [a]
(-> (-> Text a) (Error a) a))
(case try
- (#/.Success output)
+ (#//.Success output)
output
- (#/.Error error)
+ (#//.Error error)
(to-do error)))
(def: #export (return value)
{#.doc "A way to lift normal values into the error-handling context."}
(All [a] (-> a (Error a)))
- (#/.Success value))
+ (#//.Success value))
(def: #export (construct exception message)
{#.doc "Constructs an exception."}
@@ -73,12 +73,12 @@
(def: #export (throw exception message)
{#.doc "Decorate an error message with an Exception and lift it into the error-handling context."}
(All [e] (-> (Exception e) e Error))
- (#/.Error (construct exception message)))
+ (#//.Error (construct exception message)))
(def: #export (assert exception message test)
(All [e] (-> (Exception e) e Bit (Error Any)))
(if test
- (#/.Success [])
+ (#//.Success [])
(..throw exception message)))
(syntax: #export (exception: {export csr.export}
@@ -139,16 +139,16 @@
(def: #export (with-stack exception message computation)
(All [e a] (-> (Exception e) e (Error a) (Error a)))
(case computation
- (#/.Error error)
- (#/.Error (case error
- ""
- (..construct exception message)
-
- _
- ($_ "lux text concat"
- (..construct exception message)
- ..separator
- error)))
+ (#//.Error error)
+ (#//.Error (case error
+ ""
+ (..construct exception message)
+
+ _
+ ($_ "lux text concat"
+ (..construct exception message)
+ ..separator
+ error)))
success
success))
diff --git a/stdlib/source/lux/control/monad.lux b/stdlib/source/lux/control/monad.lux
index 36b2354fc..6f07ceb0a 100644
--- a/stdlib/source/lux/control/monad.lux
+++ b/stdlib/source/lux/control/monad.lux
@@ -93,38 +93,42 @@
(#.Left "Wrong syntax for 'do'")))
## [Functions]
-(def: #export (seq monad xs)
+(def: #export (seq monad)
{#.doc "Run all the monadic values in the list and produce a list of the base values."}
(All [M a]
- (-> (Monad M) (List (M a)) (M (List a))))
- (case xs
- #.Nil
- (:: monad wrap #.Nil)
-
- (#.Cons x xs')
- (do monad
- [_x x
- _xs (seq monad xs')]
- (wrap (#.Cons _x _xs)))
- ))
-
-(def: #export (map monad f xs)
- {#.doc "Apply a monad-producing function to all values in a list."}
+ (-> (Monad M) (List (M a))
+ (M (List a))))
+ (let [(^open "!/.") monad]
+ (function (recur xs)
+ (case xs
+ #.Nil
+ (!/wrap #.Nil)
+
+ (#.Cons x xs')
+ (|> x
+ (!/map (function (_ _x)
+ (!/map (|>> (#.Cons _x)) (recur xs'))))
+ !/join)))))
+
+(def: #export (map monad f)
+ {#.doc "Apply a monadic function to all values in a list."}
(All [M a b]
- (-> (Monad M) (-> a (M b)) (List a) (M (List b))))
- (case xs
- #.Nil
- (:: monad wrap #.Nil)
-
- (#.Cons x xs')
- (do monad
- [_x (f x)
- _xs (map monad f xs')]
- (wrap (#.Cons _x _xs)))
- ))
+ (-> (Monad M) (-> a (M b)) (List a)
+ (M (List b))))
+ (let [(^open "!/.") monad]
+ (function (recur xs)
+ (case xs
+ #.Nil
+ (!/wrap #.Nil)
+
+ (#.Cons x xs')
+ (|> (f x)
+ (!/map (function (_ _x)
+ (!/map (|>> (#.Cons _x)) (recur xs'))))
+ !/join)))))
(def: #export (fold monad f init xs)
- {#.doc "Fold a list with a monad-producing function."}
+ {#.doc "Fold a list with a monadic function."}
(All [M a b]
(-> (Monad M) (-> b a (M a)) a (List b)
(M a)))
diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux
index 2e92ec64b..339e4e7ca 100644
--- a/stdlib/source/lux/data/collection/array.lux
+++ b/stdlib/source/lux/data/collection/array.lux
@@ -8,6 +8,7 @@
[predicate (#+ Predicate)]]
[data
["." product]
+ ["." maybe]
[collection
["." list ("list/." Fold<List>)]]]
[compiler
@@ -56,6 +57,23 @@
(`` (for {(~~ (static host.jvm))
("jvm aastore" xs i x)})))
+(def: #export (update index transform array)
+ (All [a]
+ (-> Nat (-> a a) (Array a) (Array a)))
+ (case (read index array)
+ #.None
+ array
+
+ (#.Some value)
+ (write index (transform value) array)))
+
+(def: #export (upsert index default transform array)
+ (All [a]
+ (-> Nat a (-> a a) (Array a) (Array a)))
+ (write index
+ (|> array (read index) (maybe.default default) transform)
+ array))
+
(def: #export (delete i xs)
(All [a]
(-> Nat (Array a) (Array a)))
@@ -182,6 +200,16 @@
#.None
output)))))
+(def: #export (to-list' default array)
+ (All [a] (-> a (Array a) (List a)))
+ (loop [idx (dec (size array))
+ output #.Nil]
+ (if (n/= underflow idx)
+ output
+ (recur (dec idx)
+ (#.Cons (maybe.default default (read idx array))
+ output)))))
+
(structure: #export (Equivalence<Array> Equivalence<a>)
(All [a] (-> (Equivalence a) (Equivalence (Array a))))
(def: (= xs ys)
diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux
index 3a2b96635..7d2e55982 100644
--- a/stdlib/source/lux/type/check.lux
+++ b/stdlib/source/lux/type/check.lux
@@ -55,12 +55,11 @@
(def: (map f fa)
(function (_ context)
(case (fa context)
- (#error.Error error)
- (#error.Error error)
-
(#error.Success [context' output])
(#error.Success [context' (f output)])
- ))))
+
+ (#error.Error error)
+ (#error.Error error)))))
(structure: #export _ (Apply Check)
(def: functor Functor<Check>)
@@ -109,15 +108,14 @@
(def: (var::get id plist)
(-> Var Type-Vars (Maybe (Maybe Type)))
(case plist
- #.Nil
- #.None
-
(#.Cons [var-id var-type]
plist')
(if (!n/= id var-id)
(#.Some var-type)
(var::get id plist'))
- ))
+
+ #.Nil
+ #.None))
(def: (var::new id plist)
(-> Var Type-Vars Type-Vars)
@@ -135,32 +133,30 @@
(#.Cons [var-id value]
plist')
(#.Cons [var-id var-type]
- (var::put id value plist')))
- ))
+ (var::put id value plist')))))
(def: (var::remove id plist)
(-> Var Type-Vars Type-Vars)
(case plist
- #.Nil
- #.Nil
-
(#.Cons [var-id var-type]
plist')
(if (!n/= id var-id)
plist'
(#.Cons [var-id var-type]
(var::remove id plist')))
- ))
+
+ #.Nil
+ #.Nil))
## [[Logic]]
(def: #export (run context proc)
(All [a] (-> Type-Context (Check a) (Error a)))
(case (proc context)
- (#error.Error error)
- (#error.Error error)
-
(#error.Success [context' output])
- (#error.Success output)))
+ (#error.Success output)
+
+ (#error.Error error)
+ (#error.Error error)))
(def: #export (throw exception message)
(All [e a] (-> (ex.Exception e) e (Check a)))
@@ -190,8 +186,8 @@
#.None
(ex.throw unknown-type-var id))))]
- [bound? Bit #0 #1]
- [read (Maybe Type) #.None (#.Some bound)]
+ [bound? Bit #0 #1]
+ [read (Maybe Type) #.None (#.Some bound)]
)
(def: (peek id)
@@ -201,24 +197,24 @@
(#.Some (#.Some bound))
(#error.Success [context bound])
- (#.Some #.None)
+ (#.Some _)
(ex.throw unbound-type-var id)
- #.None
+ _
(ex.throw unknown-type-var id))))
(def: #export (bind type id)
(-> Type Var (Check Any))
(function (_ context)
(case (|> context (get@ #.var-bindings) (var::get id))
- (#.Some (#.Some bound))
- (ex.throw cannot-rebind-var [id type bound])
-
(#.Some #.None)
(#error.Success [(update@ #.var-bindings (var::put id (#.Some type)) context)
[]])
- #.None
+ (#.Some (#.Some bound))
+ (ex.throw cannot-rebind-var [id type bound])
+
+ _
(ex.throw unknown-type-var id))))
(def: (update type id)
@@ -229,7 +225,7 @@
(#error.Success [(update@ #.var-bindings (var::put id (#.Some type)) context)
[]])
- #.None
+ _
(ex.throw unknown-type-var id))))
(def: #export var
@@ -241,18 +237,6 @@
(update@ #.var-bindings (var::new id)))
[id (#.Var id)]]))))
-(def: get-bindings
- (Check (List [Var (Maybe Type)]))
- (function (_ context)
- (#error.Success [context
- (get@ #.var-bindings context)])))
-
-(def: (set-bindings value)
- (-> (List [Var (Maybe Type)]) (Check Any))
- (function (_ context)
- (#error.Success [(set@ #.var-bindings value context)
- []])))
-
(def: (apply-type! funcT argT)
(-> Type Type (Check Type))
(case funcT
@@ -260,35 +244,35 @@
(do Monad<Check>
[?funcT' (read func-id)]
(case ?funcT'
- #.None
- (throw invalid-type-application [funcT argT])
-
(#.Some funcT')
- (apply-type! funcT' argT)))
+ (apply-type! funcT' argT)
+
+ _
+ (throw invalid-type-application [funcT argT])))
_
- (function (_ context)
- (case (//.apply (list argT) funcT)
- #.None
- (ex.throw invalid-type-application [funcT argT])
+ (case (//.apply (list argT) funcT)
+ (#.Some output)
+ (check/wrap output)
- (#.Some output)
- (#error.Success [context output])))))
+ _
+ (throw invalid-type-application [funcT argT]))))
(type: #export Ring (Set Var))
(def: empty-ring Ring (set.new number.Hash<Nat>))
-(def: #export (ring id)
+## TODO: Optimize this by not using sets anymore.
+(def: #export (ring start)
(-> Var (Check Ring))
(function (_ context)
- (loop [current id
- output (set.add id empty-ring)]
+ (loop [current start
+ output (set.add start empty-ring)]
(case (|> context (get@ #.var-bindings) (var::get current))
(#.Some (#.Some type))
(case type
(#.Var post)
- (if (!n/= id post)
+ (if (!n/= start post)
(#error.Success [context output])
(recur post (set.add post output)))
@@ -351,6 +335,7 @@
(-> Assumption (List Assumption) (List Assumption))
(#.Cons assumption assumptions))
+## TODO: "if-bind" can be optimized...
(def: (if-bind id type then else)
(All [a]
(-> Var Type (Check a) (-> Type (Check a))
@@ -360,7 +345,7 @@
[_ (..bind type id)]
then)
(do Monad<Check>
- [ring (ring id)
+ [ring (..ring id)
_ (assert "" (n/> 1 (set.size ring)))
_ (monad.map @ (update type) (set.to-list ring))]
then)
@@ -368,18 +353,21 @@
[?bound (read id)]
(else (maybe.default (#.Var id) ?bound)))))
+## TODO: "link-2" can be optimized...
(def: (link-2 left right)
(-> Var Var (Check Any))
(do Monad<Check>
[_ (..bind (#.Var right) left)]
(..bind (#.Var left) right)))
+## TODO: "link-3" can be optimized...
(def: (link-3 interpose to from)
(-> Var Var Var (Check Any))
(do Monad<Check>
[_ (update (#.Var interpose) from)]
(update (#.Var to) interpose)))
+## TODO: "check-vars" can be optimized...
(def: (check-vars check' assumptions idE idA)
(-> (-> (List Assumption) Type Type (Check (List Assumption)))
(List Assumption)
@@ -391,7 +379,7 @@
[ebound (attempt (peek idE))
abound (attempt (peek idA))]
(case [ebound abound]
- ## Link the 2 variables circularily
+ ## Link the 2 variables circularly
[#.None #.None]
(do @
[_ (link-2 idE idA)]
@@ -423,8 +411,8 @@
(case [etype atype]
[(#.Var targetE) (#.Var targetA)]
(do @
- [ringE (ring idE)
- ringA (ring idA)]
+ [ringE (..ring idE)
+ ringA (..ring idA)]
(if (:: set.Equivalence<Set> = ringE ringA)
(wrap assumptions)
## Fuse 2 rings
@@ -436,18 +424,15 @@
targetE
(set.to-list ringA))]
(wrap assumptions))))
-
- [(#.Var targetE) _]
- (do @
- [ring (ring idE)
- _ (monad.map @ (update atype) (set.to-list ring))]
- (wrap assumptions))
-
- [_ (#.Var targetA)]
- (do @
- [ring (ring idA)
- _ (monad.map @ (update etype) (set.to-list ring))]
- (wrap assumptions))
+
+ (^template [<pattern> <id> <type>]
+ <pattern>
+ (do @
+ [ring (..ring <id>)
+ _ (monad.map @ (update <type>) (set.to-list ring))]
+ (wrap assumptions)))
+ ([[(#.Var _) _] idE atype]
+ [[_ (#.Var _)] idA etype])
_
(check' assumptions etype atype))))))
@@ -472,6 +457,7 @@
output
output)))
+## TODO: "check-apply" can be optimized...
(def: (check-apply check' assumptions [eAT eFT] [aAT aFT])
(-> (-> (List Assumption) Type Type (Check (List Assumption))) (List Assumption)
[Type Type] [Type Type]
@@ -523,6 +509,7 @@
_
(fail "")))
+## TODO: "check'" can be optimized...
(def: #export (check' assumptions expected actual)
{#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."}
(-> (List Assumption) Type Type (Check (List Assumption)))
@@ -555,18 +542,19 @@
[(#.Var id) F2])
[(#.Apply A F) _]
- (let [fx-pair [expected actual]]
- (if (assumed? fx-pair assumptions)
+ (let [new-assumption [expected actual]]
+ (if (assumed? new-assumption assumptions)
(check/wrap assumptions)
(do Monad<Check>
[expected' (apply-type! F A)]
- (check' (assume! fx-pair assumptions) expected' actual))))
+ (check' (assume! new-assumption assumptions) expected' actual))))
[_ (#.Apply A F)]
(do Monad<Check>
[actual' (apply-type! F A)]
(check' assumptions expected actual'))
+ ## TODO: Refactor-away as cold-code
(^template [<tag> <instancer>]
[(<tag> _) _]
(do Monad<Check>
@@ -576,6 +564,7 @@
([#.UnivQ ..existential]
[#.ExQ ..var])
+ ## TODO: Refactor-away as cold-code
(^template [<tag> <instancer>]
[_ (<tag> _)]
(do Monad<Check>
@@ -654,9 +643,9 @@
(-> Type (Check Type))
(case inputT
(#.Primitive name paramsT+)
- (do Monad<Check>
- [paramsT+' (monad.map @ clean paramsT+)]
- (wrap (#.Primitive name paramsT+')))
+ (|> paramsT+
+ (monad.map Monad<Check> clean)
+ (check/map (|>> (#.Primitive name))))
(^or (#.Parameter _) (#.Ex _) (#.Named _))
(check/wrap inputT)
@@ -664,9 +653,9 @@
(^template [<tag>]
(<tag> leftT rightT)
(do Monad<Check>
- [leftT' (clean leftT)
- rightT' (clean rightT)]
- (wrap (<tag> leftT' rightT'))))
+ [leftT' (clean leftT)]
+ (|> (clean rightT)
+ (check/map (|>> (<tag> leftT'))))))
([#.Sum] [#.Product] [#.Function] [#.Apply])
(#.Var id)
diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux
index aa8ce2116..4bc2e6632 100644
--- a/stdlib/source/lux/world/file.lux
+++ b/stdlib/source/lux/world/file.lux
@@ -4,8 +4,9 @@
["." monad (#+ Monad do)]
["ex" exception (#+ Exception exception:)]]
[data
+ ["." maybe]
["." error (#+ Error)]
- [text
+ ["." text
format]
[collection
["." array (#+ Array)]]]
@@ -83,6 +84,21 @@
separator)
)
+(def: #export (un-nest System<!> file)
+ (All [!] (-> (System !) File (Maybe [File Text])))
+ (case (text.last-index-of (:: System<!> separator) file)
+ #.None
+ #.None
+
+ (#.Some last-separator)
+ (let [[parent temp] (maybe.assume (text.split last-separator file))
+ [_ child] (maybe.assume (text.split (text.size (:: System<!> separator)) temp))]
+ (#.Some [parent child]))))
+
+(def: #export (nest System<!> [parent child])
+ (All [!] (-> (System !) [File Text] File))
+ (format parent (:: System<!> separator) child))
+
(do-template [<name>]
[(exception: #export (<name> {file File})
(ex.report ["File" file]))]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-10 01:43:33 +0000