1 files changed, 149 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/control/state.lux b/stdlib/source/library/lux/control/state.lux
new file mode 100644
index 000000000..ef0e2dbb7
--- /dev/null
+++ b/stdlib/source/library/lux/control/state.lux
@@ -0,0 +1,149 @@
+(.module:
+  [library
+   [lux #*
+    [abstract
+     [functor (#+ Functor)]
+     [apply (#+ Apply)]
+     [monad (#+ Monad do)]]]])
+
+(type: #export (State s a)
+  {#.doc "Stateful computations."}
+  (-> s [s a]))
+
+(def: #export get
+  {#.doc "Read the current state."}
+  (All [s] (State s s))
+  (function (_ state)
+    [state state]))
+
+(def: #export (put new-state)
+  {#.doc "Set the new state."}
+  (All [s] (-> s (State s Any)))
+  (function (_ state)
+    [new-state []]))
+
+(def: #export (update change)
+  {#.doc "Compute the new state."}
+  (All [s] (-> (-> s s) (State s Any)))
+  (function (_ state)
+    [(change state) []]))
+
+(def: #export (use user)
+  {#.doc "Run function on current state."}
+  (All [s a] (-> (-> s a) (State s a)))
+  (function (_ state)
+    [state (user state)]))
+
+(def: #export (local change action)
+  {#.doc "Run computation with a locally-modified state."}
+  (All [s a] (-> (-> s s) (State s a) (State s a)))
+  (function (_ state)
+    (let [[state' output] (action (change state))]
+      [state output])))
+
+(def: #export (run state action)
+  {#.doc "Run a stateful computation."}
+  (All [s a] (-> s (State s a) [s a]))
+  (action state))
+
+(implementation: #export functor
+  (All [s] (Functor (State s)))
+  
+  (def: (map f ma)
+    (function (_ state)
+      (let [[state' a] (ma state)]
+        [state' (f a)]))))
+
+(implementation: #export apply
+  (All [s] (Apply (State s)))
+  
+  (def: &functor ..functor)
+
+  (def: (apply ff fa)
+    (function (_ state)
+      (let [[state' f] (ff state)
+            [state'' a] (fa state')]
+        [state'' (f a)]))))
+
+(implementation: #export monad
+  (All [s] (Monad (State s)))
+  
+  (def: &functor ..functor)
+
+  (def: (wrap a)
+    (function (_ state)
+      [state a]))
+
+  (def: (join mma)
+    (function (_ state)
+      (let [[state' ma] (mma state)]
+        (ma state')))))
+
+(def: #export (while condition body)
+  (All [s] (-> (State s Bit) (State s Any) (State s Any)))
+  (do {! ..monad}
+    [execute? condition]
+    (if execute?
+      (do !
+        [_ body]
+        (while condition body))
+      (wrap []))))
+
+(def: #export (do-while condition body)
+  (All [s] (-> (State s Bit) (State s Any) (State s Any)))
+  (do ..monad
+    [_ body]
+    (while condition body)))
+
+(implementation: (with//functor functor)
+  (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a]))))))
+  
+  (def: (map f sfa)
+    (function (_ state)
+      (\ functor map (function (_ [s a]) [s (f a)])
+         (sfa state)))))
+
+(implementation: (with//apply monad)
+  (All [M s] (-> (Monad M) (Apply (All [a] (-> s (M [s a]))))))
+  
+  (def: &functor (with//functor (\ monad &functor)))
+
+  (def: (apply sFf sFa)
+    (function (_ state)
+      (do monad
+        [[state f] (sFf state)
+         [state a] (sFa state)]
+        (wrap [state (f a)])))))
+
+(type: #export (State' M s a)
+  {#.doc "Stateful computations decorated by a monad."}
+  (-> s (M [s a])))
+
+(def: #export (run' state action)
+  {#.doc "Run a stateful computation decorated by a monad."}
+  (All [M s a] (-> s (State' M s a) (M [s a])))
+  (action state))
+
+(implementation: #export (with monad)
+  {#.doc "A monad transformer to create composite stateful computations."}
+  (All [M s] (-> (Monad M) (Monad (State' M s))))
+
+  (def: &functor (with//functor (\ monad &functor)))
+
+  (def: (wrap a)
+    (function (_ state)
+      (\ monad wrap [state a])))
+  
+  (def: (join sMsMa)
+    (function (_ state)
+      (do monad
+        [[state' sMa] (sMsMa state)]
+        (sMa state')))))
+
+(def: #export (lift monad ma)
+  {#.doc "Lift monadic values to the State' wrapper."}
+  (All [M s a] (-> (Monad M) (M a) (State' M s a)))
+  (function (_ state)
+    (do monad
+      [a ma]
+      (wrap [state a]))))