diff options
Diffstat (limited to 'stdlib/source/lux/platform/compiler/default/phase.lux')
-rw-r--r-- | stdlib/source/lux/platform/compiler/default/phase.lux | 115 |
1 files changed, 115 insertions, 0 deletions
diff --git a/stdlib/source/lux/platform/compiler/default/phase.lux b/stdlib/source/lux/platform/compiler/default/phase.lux new file mode 100644 index 000000000..a81d5dfa7 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/default/phase.lux @@ -0,0 +1,115 @@ +(.module: + [lux #* + [control + ["." state] + ["ex" exception (#+ Exception exception:)] + [monad (#+ do)]] + [data + ["." product] + ["." error (#+ Error) ("error/." Functor<Error>)] + ["." text + format]] + [time + ["." instant] + ["." duration]] + ["." io] + [macro + ["s" syntax (#+ syntax:)]]]) + +(type: #export (Operation s o) + (state.State' Error s o)) + +(def: #export Monad<Operation> + (state.Monad<State'> error.Monad<Error>)) + +(type: #export (Phase s i o) + (-> i (Operation s o))) + +(def: #export (run' state operation) + (All [s o] + (-> s (Operation s o) (Error [s o]))) + (operation state)) + +(def: #export (run state operation) + (All [s o] + (-> s (Operation s o) (Error o))) + (|> state + operation + (:: error.Monad<Error> map product.right))) + +(def: #export get-state + (All [s o] + (Operation s s)) + (function (_ state) + (#error.Success [state state]))) + +(def: #export (set-state state) + (All [s o] + (-> s (Operation s Any))) + (function (_ _) + (#error.Success [state []]))) + +(def: #export (sub [get set] operation) + (All [s s' o] + (-> [(-> s s') (-> s' s s)] + (Operation s' o) + (Operation s o))) + (function (_ state) + (do error.Monad<Error> + [[state' output] (operation (get state))] + (wrap [(set state' state) output])))) + +(def: #export fail + (-> Text Operation) + (|>> error.fail (state.lift error.Monad<Error>))) + +(def: #export (throw exception parameters) + (All [e] (-> (Exception e) e Operation)) + (state.lift error.Monad<Error> + (ex.throw exception parameters))) + +(def: #export (lift error) + (All [s a] (-> (Error a) (Operation s a))) + (function (_ state) + (error/map (|>> [state]) error))) + +(syntax: #export (assert exception message test) + (wrap (list (` (if (~ test) + (:: ..Monad<Operation> (~' wrap) []) + (..throw (~ exception) (~ message))))))) + +(def: #export (with-stack exception message action) + (All [e s o] (-> (Exception e) e (Operation s o) (Operation s o))) + (<<| (ex.with-stack exception message) + action)) + +(def: #export identity + (All [s a] (Phase s a a)) + (function (_ input state) + (#error.Success [state input]))) + +(def: #export (compose pre post) + (All [s0 s1 i t o] + (-> (Phase s0 i t) + (Phase s1 t o) + (Phase [s0 s1] i o))) + (function (_ input [pre/state post/state]) + (do error.Monad<Error> + [[pre/state' temp] (pre input pre/state) + [post/state' output] (post temp post/state)] + (wrap [[pre/state' post/state'] output])))) + +(def: #export (timed definition description operation) + (All [s a] + (-> Name Text (Operation s a) (Operation s a))) + (do Monad<Operation> + [_ (wrap []) + #let [pre (io.run instant.now)] + output operation + #let [_ (log! (|> instant.now + io.run + instant.relative + (duration.difference (instant.relative pre)) + %duration + (format (%name definition) " [" description "]: ")))]] + (wrap output))) |