From cf412d7287b229c0f38558dbed0bad474a3e1bf1 Mon Sep 17 00:00:00 2001
From: widmogrod <widmogrod@gmail.com>
Date: Mon, 11 Dec 2017 00:39:09 +0100
Subject: [PATCH] Another implementation of free

---
 .codeclimate.yml              |   2 +
 composer.json                 |   1 +
 example/Free2MonadTest.php    | 215 ++++++++++++++++++++++++++++++++++++++++++
 example/FreeDSLTest.php       |  51 ++++++++++
 src/Monad/Free2/Free.php      | 113 ++++++++++++++++++++++
 src/Monad/Free2/MonadFree.php |  22 +++++
 src/Monad/Free2/Pure.php      |  49 ++++++++++
 src/Monad/Free2/functions.php |  45 +++++++++
 test/Monad/Free2Test.php      |  99 +++++++++++++++++++
 9 files changed, 597 insertions(+)
 create mode 100644 example/Free2MonadTest.php
 create mode 100644 example/FreeDSLTest.php
 create mode 100644 src/Monad/Free2/Free.php
 create mode 100644 src/Monad/Free2/MonadFree.php
 create mode 100644 src/Monad/Free2/Pure.php
 create mode 100644 src/Monad/Free2/functions.php
 create mode 100644 test/Monad/Free2Test.php

diff --git a/.codeclimate.yml b/.codeclimate.yml
index 7a4cbba..0800c87 100644
--- a/.codeclimate.yml
+++ b/.codeclimate.yml
@@ -18,6 +18,8 @@ engines:
         enabled: false
       UnusedFormalParameter:
         enabled: false
+      Naming/ConstantNamingConventions:
+        enabled: false
 ratings:
   paths:
   - "**.php"
diff --git a/composer.json b/composer.json
index 2263f77..580b7f2 100644
--- a/composer.json
+++ b/composer.json
@@ -35,6 +35,7 @@
       "src/Monad/Either/functions.php",
       "src/Monad/Maybe/functions.php",
       "src/Monad/Free/functions.php",
+      "src/Monad/Free2/functions.php",
       "src/Monad/IO/functions.php",
       "src/Monad/IO/errors.php",
       "src/Monad/Reader/functions.php",
diff --git a/example/Free2MonadTest.php b/example/Free2MonadTest.php
new file mode 100644
index 0000000..42dd066
--- /dev/null
+++ b/example/Free2MonadTest.php
@@ -0,0 +1,215 @@
+<?php
+
+namespace example2;
+
+use Widmogrod\FantasyLand\Functor;
+use Widmogrod\Functional as f;
+use Widmogrod\Monad\Free2 as ff;
+use Widmogrod\Monad\Free2\MonadFree;
+use Widmogrod\Monad\IO;
+use Widmogrod\Monad\State;
+use const Widmogrod\Monad\IO\pure;
+use const Widmogrod\Monad\State\value;
+
+interface TeletypeF extends Functor
+{
+}
+
+class PutStrLn implements TeletypeF
+{
+    public $str;
+    public $next;
+
+    public function __construct($str, ff\MonadFree $next)
+    {
+        $this->str = $str;
+        $this->next = $next;
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function map(callable $function)
+    {
+        return new self(
+            $this->str,
+            $function($this->next)
+        );
+    }
+}
+
+class GetLine implements TeletypeF
+{
+    /**
+     * @var callable
+     */
+    public $processor;
+
+    public function __construct(callable $processor)
+    {
+        $this->processor = $processor;
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function map(callable $function)
+    {
+        return new self(function ($x) use ($function) {
+            return $function(($this->processor)($x));
+        });
+    }
+}
+
+class ExitSuccess implements TeletypeF
+{
+    /**
+     * @inheritdoc
+     */
+    public function map(callable $function)
+    {
+        return $this;
+    }
+}
+
+const putStrLn_ = 'example2\putStrLn_';
+
+// putStrLn' :: String -> Teletype ()
+function putStrLn_($str)
+{
+    return ff\liftF(new PutStrLn($str, ff\Pure::of(null)));
+}
+
+const getLine_ = 'example2\getLine_';
+
+// getLine' :: Teletype String
+function getLine_()
+{
+    return ff\liftF(new GetLine(ff\Pure::of));
+}
+
+const exitSuccess_ = 'example2\exitSuccess_';
+
+// exitSuccess' :: Teletype r
+function exitSuccess_()
+{
+    return ff\liftF(new ExitSuccess());
+}
+
+const interpretIO = 'example2\interpretIO';
+
+// run :: TeletypeF -> IO ()
+function interpretIO(TeletypeF $r)
+{
+    return f\match([
+        PutStrLn::class => function (PutStrLn $a) {
+            return IO\putStrLn($a->str)->map(function () use ($a) {
+                return $a->next;
+            });
+        },
+        GetLine::class => function (GetLine $a) {
+            return IO\getLine()->bind($a->processor);
+        },
+        ExitSuccess::class => function (ExitSuccess $a) {
+            return IO\putStrLn('exit')->bind(ff\Pure::of);
+        },
+    ], $r);
+}
+
+const interpretState = 'example2\interpretState';
+
+// runTest :: TeletypeF -> State MonadFree []
+function interpretState(TeletypeF $r)
+{
+    return f\match([
+        PutStrLn::class => function (PutStrLn $a) {
+            return State::of(function ($state) use ($a) {
+                return [
+                    $a->next,
+                    f\append($state, 'PutStrLn')
+                ];
+            });
+        },
+        GetLine::class => function (GetLine $a) {
+            return State::of(function ($state) use ($a) {
+                return [
+                    ($a->processor)('demo'),
+                    f\append($state, 'GetLine')
+                ];
+            });
+        },
+        ExitSuccess::class => function (ExitSuccess $a) {
+            return State::of(function ($state) use ($a) {
+                return [
+                    ff\Pure::of('exit'),
+                    f\append($state, 'ExitSuccess')
+                ];
+            });
+        },
+    ], $r);
+}
+
+function echo_chaining_()
+{
+    return getLine_()
+        ->bind(function ($str) {
+            return putStrLn_($str)
+                ->bind(function () {
+                    return exitSuccess_()
+                        ->bind(function () {
+                            // In interpretation of IO Monad this place will never be reached
+                            return putStrLn_('Finished');
+                        });
+                });
+        });
+}
+
+function echo_composition_()
+{
+    return call_user_func(f\pipeline(
+        getLine_,
+        f\bind(putStrLn_),
+        f\bind(exitSuccess_),
+        f\bind(putStrLn_) // In interpretation of IO Monad this place will never be reached
+    ));
+}
+
+class Free2MonadTest extends \PHPUnit_Framework_TestCase
+{
+    /**
+     * @dataProvider provideEchoImplementation
+     */
+    public function test_it_should_allow_to_interpret_as_a_state_monad(MonadFree $echo)
+    {
+        $result = ff\foldFree(interpretState, $echo, value);
+        $this->assertInstanceOf(State::class, $result);
+        $result = State\execState($result, []);
+
+        $this->assertEquals($result, [
+            'GetLine',
+            'PutStrLn',
+            'ExitSuccess',
+        ]);
+    }
+
+    /**
+     * @dataProvider provideEchoImplementation
+     */
+    public function test_it_should_allow_to_interpret_as_IO(MonadFree $echo)
+    {
+        $result = ff\foldFree(interpretIO, $echo, pure);
+        $this->assertInstanceOf(IO::class, $result);
+        // Since this requires input, which would block unit
+        // This test serves as an example, uncomment line bellow
+        // for your local test
+        // $result->run();
+    }
+
+    public function provideEchoImplementation()
+    {
+        return [
+            'echo implementation via explicit chaining (bind)' => [echo_chaining_()],
+            'echo implementation via function composition'     => [echo_composition_()],
+        ];
+    }
+}
diff --git a/example/FreeDSLTest.php b/example/FreeDSLTest.php
new file mode 100644
index 0000000..33a6ec1
--- /dev/null
+++ b/example/FreeDSLTest.php
@@ -0,0 +1,51 @@
+<?php
+
+namespace example;
+
+interface ScenarioF
+{
+    //    public function map(callable $function): ScenarioF;
+}
+
+class Given implements ScenarioF
+{
+    public function __construct(string $desc, When $when)
+    {
+    }
+}
+
+class When implements ScenarioF
+{
+    public function __construct(string $desc, When $when)
+    {
+    }
+}
+
+class Then implements ScenarioF
+{
+    public function __construct(string $desc, When $when)
+    {
+    }
+}
+
+class Scenario
+{
+    public function when()
+    {
+    }
+
+    public function then()
+    {
+    }
+}
+
+function given(string $desc, $state): Scenario
+{
+}
+
+class FreeDSLTest extends \PHPUnit_Framework_TestCase
+{
+    public function test_it_should_interpret()
+    {
+    }
+}
diff --git a/src/Monad/Free2/Free.php b/src/Monad/Free2/Free.php
new file mode 100644
index 0000000..597401c
--- /dev/null
+++ b/src/Monad/Free2/Free.php
@@ -0,0 +1,113 @@
+<?php
+
+namespace Widmogrod\Monad\Free2;
+
+use Widmogrod\FantasyLand;
+use function Widmogrod\Functional\bind;
+
+/**
+ * Free (f (Free f a))
+ *
+ * Based on https://hackage.haskell.org/package/free-4.12.4/docs/Control-Monad-Free-Class.html
+ */
+class Free implements MonadFree
+{
+    const of = 'Widmogrod\Monad\Free2\Free::of';
+
+    /**
+     * @var FantasyLand\Functor
+     */
+    private $f;
+
+    public function __construct(FantasyLand\Functor $f)
+    {
+        $this->f = $f;
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public static function of($f)
+    {
+        return new self($f);
+    }
+
+    /**
+     * ```
+     * instance Functor f => Apply (Free f) where
+     *   Pure a  <.> Pure b = Pure (a b)
+     *   Pure a  <.> Free fb = Free $ fmap a <$> fb
+     *   Free fa <.> b = Free $ (<.> b) <$> fa
+     *
+     * instance Functor f => Applicative (Free f) where
+     *   pure = Pure
+     *     Pure a <*> Pure b = Pure $ a b
+     *     Pure a <*> Free mb = Free $ fmap a <$> mb
+     *     Free ma <*> b = Free $ (<*> b) <$> ma
+     * ```
+     *
+     * @inheritdoc
+     */
+    public function ap(FantasyLand\Apply $b)
+    {
+        // Don't know if OK...
+        return $this->bind(function ($f) use ($b) {
+            return $b->map($f);
+        });
+    }
+
+    /**
+     * ```
+     * instance Functor f => Bind (Free f) where
+     *   Pure a >>- f = f a
+     *   Free m >>- f = Free ((>>- f) <$> m)
+     * instance Functor f => Monad (Free f) where
+     *   return = pure
+     *     Pure a >>= f = f a
+     *     Free m >>= f = Free ((>>= f) <$> m)
+     *
+     * (<$>) :: Functor f => (a -> b) -> f a -> f b
+     * ```
+     *
+     * @inheritdoc
+     */
+    public function bind(callable $function)
+    {
+        return new self(
+            $this->f->map(bind($function))
+        );
+    }
+
+    /**
+     * ```
+     * instance Functor f => Functor (Free f) where
+     *  fmap f = go where
+     *      go (Pure a)  = Pure (f a)
+     *      go (Free fa) = Free (go <$> fa)
+     *
+     * (<$>) :: Functor f => (a -> b) -> f a -> f b
+     *```
+     *
+     * @inheritdoc
+     */
+    public function map(callable $go)
+    {
+        return new self(
+            $this->f->map($go)
+        );
+    }
+
+    /**
+     * ```
+     * foldFree f (Free as) = f as >>= foldFree f
+     * ```
+     *
+     * @inheritdoc
+     */
+    public function foldFree(callable $f, callable $return): FantasyLand\Monad
+    {
+        return $f($this->f)->bind(function (MonadFree $next) use ($f, $return) : FantasyLand\Monad {
+            return $next->foldFree($f, $return);
+        });
+    }
+}
diff --git a/src/Monad/Free2/MonadFree.php b/src/Monad/Free2/MonadFree.php
new file mode 100644
index 0000000..78d8d01
--- /dev/null
+++ b/src/Monad/Free2/MonadFree.php
@@ -0,0 +1,22 @@
+<?php
+
+namespace Widmogrod\Monad\Free2;
+
+use Widmogrod\FantasyLand;
+
+interface MonadFree extends FantasyLand\Monad
+{
+    /**
+     * ```
+     * foldFree :: Monad m => (forall x . f x -> m x) -> Free f a -> m a
+     * foldFree _ (Pure a)  = return a
+     * foldFree f (Free as) = f as >>= foldFree f
+     * ```
+     *
+     * @param callable $f (f x -> m x)
+     * @param callable $return
+     *
+     * @return FantasyLand\Monad
+     */
+    public function foldFree(callable $f, callable $return): FantasyLand\Monad;
+}
diff --git a/src/Monad/Free2/Pure.php b/src/Monad/Free2/Pure.php
new file mode 100644
index 0000000..7f8cc51
--- /dev/null
+++ b/src/Monad/Free2/Pure.php
@@ -0,0 +1,49 @@
+<?php
+
+namespace Widmogrod\Monad\Free2;
+
+use Widmogrod\Common;
+use Widmogrod\FantasyLand;
+
+class Pure implements MonadFree
+{
+    use Common\PointedTrait;
+
+    const of = 'Widmogrod\Monad\Free2\Pure::of';
+
+    /**
+     * @inheritdoc
+     */
+    public function ap(FantasyLand\Apply $b)
+    {
+        return $b->map($this->value);
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function bind(callable $function)
+    {
+        return call_user_func($function, $this->value);
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function map(callable $function)
+    {
+        return self::of(call_user_func($function, $this->value));
+    }
+
+    /**
+     * ```
+     * foldFree _ (Pure a)  = return a
+     * ```
+     *
+     * @inheritdoc
+     */
+    public function foldFree(callable $f, callable $return): FantasyLand\Monad
+    {
+        return $return($this->value);
+    }
+}
diff --git a/src/Monad/Free2/functions.php b/src/Monad/Free2/functions.php
new file mode 100644
index 0000000..a3f6c20
--- /dev/null
+++ b/src/Monad/Free2/functions.php
@@ -0,0 +1,45 @@
+<?php
+
+namespace Widmogrod\Monad\Free2;
+
+use Widmogrod\FantasyLand\Functor;
+use Widmogrod\FantasyLand\Monad;
+use function Widmogrod\Functional\curryN;
+
+/**
+ * A version of lift that can be used with just a Functor for f.
+ *
+ * ```
+ * liftF :: (Functor f, MonadFree f m) => f a -> m a
+ * ```
+ *
+ * @param Functor $f
+ *
+ * @return MonadFree
+ */
+function liftF(Functor $f): MonadFree
+{
+    return Free::of($f);
+}
+
+/**
+ * The very definition of a free monad is that given a natural transformation you get a monad homomorphism.
+ *
+ * ```
+ * foldFree :: Monad m => (forall x . f x -> m x) -> Free f a -> m a
+ * foldFree _ (Pure a)  = return a
+ * foldFree f (Free as) = f as >>= foldFree f
+ * ```
+ *
+ * @param callable $interpreter (f x => m x)
+ * @param MonadFree $free
+ * @param callable $return
+ *
+ * @return Monad|callable
+ */
+function foldFree(callable $interpreter, MonadFree $free = null, callable $return = null)
+{
+    return call_user_func_array(curryN(3, function (callable $interpreter, MonadFree $free, callable $return): Monad {
+        return $free->foldFree($interpreter, $return);
+    }), func_get_args());
+}
diff --git a/test/Monad/Free2Test.php b/test/Monad/Free2Test.php
new file mode 100644
index 0000000..a0f8859
--- /dev/null
+++ b/test/Monad/Free2Test.php
@@ -0,0 +1,99 @@
+<?php
+
+namespace test\Monad;
+
+use Widmogrod\FantasyLand\Functor;
+use Widmogrod\Helpful\FunctorLaws;
+use Widmogrod\Helpful\MonadLaws;
+use Widmogrod\Monad\Free2\MonadFree;
+use Widmogrod\Monad\Free2\Pure;
+use Widmogrod\Monad\Identity;
+use function Widmogrod\Monad\Free2\foldFree;
+use function Widmogrod\Monad\Free2\liftF;
+
+class Free2Test extends \PHPUnit_Framework_TestCase
+{
+    /**
+     * @dataProvider provideFunctorTestData
+     */
+    public function test_it_should_obey_functor_laws(
+        callable $f,
+        callable $g,
+        Functor $x
+    ) {
+        FunctorLaws::test(
+            function (MonadFree $a, MonadFree $b, $message) {
+                $this->assertEquals(
+                    foldFree(Identity::of, $a, Identity::of),
+                    foldFree(Identity::of, $b, Identity::of),
+                    $message
+                );
+            },
+            $f,
+            $g,
+            $x
+        );
+    }
+
+    public function provideFunctorTestData()
+    {
+        return [
+            'Pure' => [
+                '$f' => function (int $x) {
+                    return $x + 1;
+                },
+                '$g' => function (int $x) {
+                    return $x + 5;
+                },
+                '$x' => Pure::of(1),
+            ],
+            'Free' => [
+                '$f' => function (int $x) {
+                    return $x + 1;
+                },
+                '$g' => function (int $x) {
+                    return $x + 5;
+                },
+                '$x' => liftF(Pure::of(1)),
+            ],
+        ];
+    }
+
+    /**
+     * @dataProvider provideData
+     */
+    public function test_if_io_monad_obeys_the_laws($f, $g, $x)
+    {
+        MonadLaws::test(
+            function (MonadFree $f, MonadFree $g, $message) {
+                $this->assertEquals(
+                    foldFree(Identity::of, $f, Identity::of),
+                    foldFree(Identity::of, $g, Identity::of),
+                    $message
+                );
+            },
+            Pure::of,
+            $f,
+            $g,
+            $x
+        );
+    }
+
+    public function provideData()
+    {
+        $addOne = function (int $x) {
+            return Pure::of($x + 1);
+        };
+        $addTwo = function (int $x) {
+            return Pure::of($x + 2);
+        };
+
+        return [
+            'Identity' => [
+                '$f' => $addOne,
+                '$g' => $addTwo,
+                '$x' => 10,
+            ],
+        ];
+    }
+}
-- 
2.11.0