From b041cf72679f1d562086394048a03a82f1a00a99 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 13 Oct 2018 11:19:52 -0400 Subject: - Some refactoring. - Small additions/features. --- stdlib/source/lux/control/exception.lux | 48 ++++----- stdlib/source/lux/control/monad.lux | 58 +++++------ stdlib/source/lux/data/collection/array.lux | 28 ++++++ stdlib/source/lux/type/check.lux | 145 +++++++++++++--------------- stdlib/source/lux/world/file.lux | 18 +++- 5 files changed, 167 insertions(+), 130 deletions(-) (limited to 'stdlib') 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)] @@ -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)]]] [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 Equivalence) (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) @@ -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 [?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)) -(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 - [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 [_ (..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 [_ (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 = 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 [ ] + + (do @ + [ring (..ring ) + _ (monad.map @ (update ) (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 [expected' (apply-type! F A)] - (check' (assume! fx-pair assumptions) expected' actual)))) + (check' (assume! new-assumption assumptions) expected' actual)))) [_ (#.Apply A F)] (do Monad [actual' (apply-type! F A)] (check' assumptions expected actual')) + ## TODO: Refactor-away as cold-code (^template [ ] [( _) _] (do Monad @@ -576,6 +564,7 @@ ([#.UnivQ ..existential] [#.ExQ ..var]) + ## TODO: Refactor-away as cold-code (^template [ ] [_ ( _)] (do Monad @@ -654,9 +643,9 @@ (-> Type (Check Type)) (case inputT (#.Primitive name paramsT+) - (do Monad - [paramsT+' (monad.map @ clean paramsT+)] - (wrap (#.Primitive name paramsT+'))) + (|> paramsT+ + (monad.map Monad clean) + (check/map (|>> (#.Primitive name)))) (^or (#.Parameter _) (#.Ex _) (#.Named _)) (check/wrap inputT) @@ -664,9 +653,9 @@ (^template [] ( leftT rightT) (do Monad - [leftT' (clean leftT) - rightT' (clean rightT)] - (wrap ( leftT' rightT')))) + [leftT' (clean leftT)] + (|> (clean rightT) + (check/map (|>> ( 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 [] [(exception: #export ( {file File}) (ex.report ["File" file]))] -- cgit v1.2.3