Merge pull request gluon-lang#44 from bjz/state-writer

Implement Applicative and Functor for State and Writer

std/state.glu

@@ -1,16 +1,33 @@
-let { Monad } = import "std/prelude.glu"
+let { Applicative, Functor, Monad } = import "std/prelude.glu"
 
 type State s a = s -> { value: a, state: s }
 
-let (>>=) m f: State s a -> (a -> State s b) -> State s b =
-    \state ->
-        let { value, state } = m state
-        and m2 = f value
-        m2 state
+let functor : Functor (State s) =
+    let map f m : (a -> b) -> State s a -> State s b =
+        \state ->
+            let { value, state } = m state
+            { value = f value, state = state  }
 
-let return value: a -> State s a = \state -> { value, state }
+    { map }
 
-let monad: Monad (State s) = { (>>=), return }
+let applicative : Applicative (State s) =
+    let (<*>) mf state : State s (a -> b) -> State s a -> State s b =
+        let { value, state } = mf state
+        functor.map value state
+
+    let pure value: a -> State s a =
+        \state -> { value, state }
+
+    { (<*>), pure }
+
+let monad: Monad (State s) =
+    let (>>=) m f: State s a -> (a -> State s b) -> State s b =
+        \state ->
+            let { value, state } = m state
+            and m2 = f value
+            m2 state
+
+    { (>>=), return = applicative.pure }
 
 let put value: s -> State s () = \state -> { value = (), state = value }
 
@@ -26,4 +43,4 @@ let evalState f state: State s a -> s -> a = (runState f state).value
 
 let execState f state: State s a -> s -> s = (runState f state).state
 
-{ State, monad, put, get, modify, runState, evalState, execState }
+{ State, applicative, functor, monad, put, get, modify, runState, evalState, execState }

std/test.glu

@@ -1,34 +1,35 @@
 let string = import "std/string.glu"
 and writer = import "std/writer.glu"
-and { Writer, make, tell } = writer
+and { Writer, tell } = writer
 and prelude = import "std/prelude.glu"
 and { Show, Num, Eq, Option, List, Monad, Monoid, foldl } = prelude
 and { (+) } = prelude.num_Int
 and { (==) } = prelude.eq_Int
 and { (<) } = prelude.make_Ord prelude.ord_Int
-in
+
 let (++) = string.monoid.(<>)
-in
+
 type Test a = Writer (List String) a
-in
-let monad: Monad Test = make prelude.monoid_List
-in
+
+let monad: Monad Test = writer.make_Monad prelude.monoid_List
+
 let { (>>=), return, (>>), join, map = fmap, lift2, forM_ }
         = prelude.make_Monad monad
-in
+
 let assert x = if x then () else error "Assertion failed"
 and assert_eq show eq = \x y ->
     if eq.(==) x y
     then return ()
     else tell (Cons ("Assertion failed: "
                 ++ show.show x  ++ " != " ++ show.show y) Nil)
-in
+
 let assert_ieq = assert_eq prelude.show_Int prelude.eq_Int
 and assert_feq = assert_eq prelude.show_Float prelude.eq_Float
 and assert_seq = assert_eq string.show string.eq
-in
+
 let run test: Test a -> () =
         match test.writer with
             | Cons _ _ -> error (prelude.foldl (\acc err -> acc ++ "\n" ++ err) "" test.writer)
             | Nil -> ()
-in { Test, monad, assert, assert_eq, assert_ieq, assert_feq, assert_seq, run }
+
+{ Test, monad, assert, assert_eq, assert_ieq, assert_feq, assert_seq, run }

std/writer.glu

@@ -1,15 +1,36 @@
-let { Monad, Monoid } = import "std/prelude.glu"
+let { Applicative, Functor, Monad, Monoid } = import "std/prelude.glu"
 
 type Writer w a = { value: a, writer: w }
 
-let make w: Monoid w -> Monad (Writer w) = {
-    (>>=) = \m g ->
-        let { value, writer } = g m.value
-        { value, writer = w.(<>) m.writer writer },
-    return = \value -> { value, writer = w.empty }
-}
+let make_Functor w: Monoid w -> Functor (Writer w) =
+    let { (<>) } = w
+
+    let map f m : (a -> b) -> Writer w a -> Writer w b =
+        { value = f m.value, writer = m.writer  }
+
+    { map }
+
+let make_Applicative w: Monoid w -> Applicative (Writer w) =
+    let { (<>) } = w
+
+    let (<*>) mf m : Writer w (a -> b) -> Writer w a -> Writer w b =
+        { value = mf.value m.value, writer = mf.writer <> m.writer }
+    let pure value: a -> Writer w a =
+        { value, writer = w.empty }
+
+    { (<*>), pure }
+
+let make_Monad w: Monoid w -> Monad (Writer w) =
+    let { (<>) } = w
+    let { pure } = make_Applicative w
+
+    let (>>=) m f : Writer w a -> (a -> Writer w b) -> Writer w b =
+        let { value, writer } = f m.value
+        { value, writer = m.writer <> writer }
+
+    { (>>=), return = pure }
 
 let tell w: w -> Writer w () =
     { value = (), writer = w }
 
-{ Writer, make, tell }
+{ Writer, make_Functor, make_Applicative, make_Monad, tell }