Merge pull request #87 from widmogrod/feature/free-example

 Use free monad to design - haskell like do notation in PHP

Author: widmogrod

composer.json

@@ -47,6 +47,8 @@
       "src/Monad/Reader/functions.php",
       "src/Monad/State/functions.php",
       "src/Monad/Writer/functions.php",
+      "src/Monad/Control/Doo/actions.php",
+      "src/Monad/Control/Doo/interpretation.php",
       "src/Useful/match.php"
     ]
   }

example/FreeDooDSLTest.php

@@ -0,0 +1,45 @@
+<?php
+
+declare(strict_types=1);
+
+namespace example;
+
+use Widmogrod\Monad\Identity;
+use function Widmogrod\Monad\Control\Doo\doo;
+use function Widmogrod\Monad\Control\Doo\in;
+use function Widmogrod\Monad\Control\Doo\let;
+
+class FreeDooDSLTest extends \PHPUnit\Framework\TestCase
+{
+    public function test_example_with_do_notation()
+    {
+        $result = doo(
+            let('a', Identity::of(1)),
+            let('b', Identity::of(3)),
+            let('c', in(['a', 'b'], function (int $a, int $b): Identity {
+                return Identity::of($a + $b);
+            })),
+            in(['c'], function (int $c): Identity {
+                return Identity::of($c * $c);
+            })
+        );
+
+        $this->assertEquals(Identity::of(16), $result);
+    }
+
+    public function test_example_without_do_notation()
+    {
+        $result = Identity::of(1)
+            ->bind(function ($a) {
+                return Identity::of(3)
+                    ->bind(function ($b) use ($a) {
+                        return Identity::of($a + $b)
+                            ->bind(function ($c) {
+                                return Identity::of($c * $c);
+                            });
+                    });
+            });
+
+        $this->assertEquals(Identity::of(16), $result);
+    }
+}

src/Functional/functions.php

@@ -10,7 +10,6 @@
 use Widmogrod\FantasyLand\Functor;
 use Widmogrod\FantasyLand\Monad;
 use Widmogrod\FantasyLand\Traversable;
-use Widmogrod\Monad\Identity;
 use Widmogrod\Primitive\Listt;
 use Widmogrod\Primitive\ListtCons;
 
@@ -457,37 +456,27 @@ function liftA2(
  *
  * a.k.a haskell >>
  *
- * Sequentially compose two actions, discarding any value produced by the first, like sequencing operators (such as the semicolon) in imperative languages.
+ * Sequentially compose two actions, discarding any value produced by the first,
+ * like sequencing operators (such as the semicolon) in imperative languages.
+ *
+ * This implementation allow to **compose more than just two monads**.
  *
  * @param Monad $a
  * @param Monad $b
  *
  * @return Monad
  */
-function sequenceM(Monad $a, Monad $b)
-{
-    return $a->bind(function () use ($b) {
-        return $b;
-    });
-}
-
-/**
- * @var callable
- */
-const sequence_ = 'Widmogrod\Functional\sequence_';
-
-/**
- * sequence_ :: Monad m => [m a] -> m ()
- *
- * @todo consider to do it like this: foldr (>>) (return ())
- *
- * @param Monad[] $monads
- *
- * @return Monad
- */
-function sequence_(Monad ...$monads)
+function sequenceM(Monad $a, Monad $b = null): Monad
 {
-    return reduce(sequenceM, Identity::of([]), fromIterable($monads));
+    return curryN(2, function (Monad ...$monads): Monad {
+        return array_reduce($monads, function (?Monad $a, Monad $b) {
+            return $a
+                ? $a->bind(function () use ($b) {
+                    return $b;
+                })
+                : $b;
+        }, null);
+    })(...func_get_args());
 }
 
 /**
@@ -515,23 +504,6 @@ function traverse(callable $transformation, Traversable $t = null)
     })(...func_get_args());
 }
 
-/**
- * @var callable
- */
-const sequence = 'Widmogrod\Functional\sequence';
-
-/**
- * sequence :: Monad m => t (m a) -> m (t a)
- *
- * @param Traversable|Monad[] $monads
- *
- * @return Monad
- */
-function sequence(Monad ...$monads)
-{
-    return traverse(identity, fromIterable($monads));
-}
-
 /**
  * filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
  *

src/Monad/Control/Doo/Algebra/DooF.php

@@ -0,0 +1,15 @@
+<?php
+
+declare(strict_types=1);
+namespace Widmogrod\Monad\Control\Doo\Algebra;
+
+use Widmogrod\FantasyLand\Functor;
+use Widmogrod\Useful\PatternMatcher;
+
+/**
+ *  DooF next = Let name m next
+ *            | In [name] fn (m -> next)
+ */
+interface DooF extends Functor, PatternMatcher
+{
+}

src/Monad/Control/Doo/Algebra/In.php

@@ -0,0 +1,42 @@
+<?php
+
+declare(strict_types=1);
+
+namespace Widmogrod\Monad\Control\Doo\Algebra;
+
+use Widmogrod\FantasyLand\Functor;
+use function Widmogrod\Functional\compose;
+
+class In implements DooF
+{
+    private $names;
+    private $fn;
+    private $next;
+
+    public function __construct(array $names, callable $fn, callable $next)
+    {
+        $this->names = $names;
+        $this->fn = $fn;
+        $this->next = $next;
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function map(callable $function): Functor
+    {
+        return new self(
+            $this->names,
+            $this->fn,
+            compose($function, $this->next)
+        );
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function patternMatched(callable $fn)
+    {
+        return $fn($this->names, $this->fn, $this->next);
+    }
+}

src/Monad/Control/Doo/Algebra/Let.php

@@ -0,0 +1,42 @@
+<?php
+
+declare(strict_types=1);
+namespace Widmogrod\Monad\Control\Doo\Algebra;
+
+use Widmogrod\FantasyLand\Functor;
+use Widmogrod\FantasyLand\Monad;
+use Widmogrod\Monad\Free\MonadFree;
+
+class Let implements DooF
+{
+    private $name;
+    private $m;
+    private $next;
+
+    public function __construct(string $name, Monad $m, MonadFree $next)
+    {
+        $this->name = $name;
+        $this->m = $m;
+        $this->next = $next;
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function map(callable $function): Functor
+    {
+        return new self(
+            $this->name,
+            $this->m,
+            $function($this->next)
+        );
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function patternMatched(callable $fn)
+    {
+        return $fn($this->name, $this->m, $this->next);
+    }
+}

src/Monad/Control/Doo/Registry/CannotRedeclareVariableError.php

@@ -0,0 +1,14 @@
+<?php
+
+declare(strict_types=1);
+namespace Widmogrod\Monad\Control\Doo\Registry;
+
+class CannotRedeclareVariableError extends \Exception
+{
+    public function __construct(string $name, array $registered)
+    {
+        $message = 'Cannot redeclare variable "%s". Registered variables %s';
+        $message = sprintf($message, $name, join(',', $registered));
+        parent::__construct($message);
+    }
+}

src/Monad/Control/Doo/Registry/Registry.php

@@ -0,0 +1,38 @@
+<?php
+
+declare(strict_types=1);
+namespace Widmogrod\Monad\Control\Doo\Registry;
+
+class Registry
+{
+    private $data = [];
+
+    /**
+     * @param  string                   $name
+     * @return mixed
+     * @throws VariableNotDeclaredError
+     */
+    public function get(string $name)
+    {
+        if (array_key_exists($name, $this->data)) {
+            return $this->data[$name];
+        }
+
+        throw new VariableNotDeclaredError($name);
+    }
+
+    /**
+     * @param  string                       $name
+     * @param  mixed                        $value
+     * @return mixed
+     * @throws CannotRedeclareVariableError
+     */
+    public function set(string $name, $value)
+    {
+        if (array_key_exists($name, $this->data)) {
+            throw new CannotRedeclareVariableError($name, array_keys($this->data));
+        }
+
+        return $this->data[$name] = $value;
+    }
+}

src/Monad/Control/Doo/Registry/VariableNotDeclaredError.php

@@ -0,0 +1,15 @@
+<?php
+
+declare(strict_types=1);
+namespace Widmogrod\Monad\Control\Doo\Registry;
+
+class VariableNotDeclaredError extends \Exception
+{
+    public function __construct(string $name)
+    {
+        $message = 'Variable "%s" is not declared';
+        $message = sprintf($message, $name);
+
+        parent::__construct($message);
+    }
+}

src/Monad/Control/Doo/actions.php

@@ -0,0 +1,24 @@
+<?php
+
+declare(strict_types=1);
+
+namespace Widmogrod\Monad\Control\Doo;
+
+use Widmogrod\FantasyLand\Monad;
+use Widmogrod\Monad\Free\MonadFree;
+use Widmogrod\Monad\Free\Pure;
+use function Widmogrod\Monad\Free\liftF;
+
+function let(string $name, Monad $m): MonadFree
+{
+    return $m instanceof MonadFree
+        ? $m->bind(function (Monad $m) use ($name): MonadFree {
+            return liftF(new Algebra\Let($name, $m, Pure::of(null)));
+        })
+        : liftF(new Algebra\Let($name, $m, Pure::of(null)));
+}
+
+function in(array $names, callable $fn): MonadFree
+{
+    return liftF(new Algebra\In($names, $fn, Pure::of));
+}

src/Monad/Control/Doo/interpretation.php

@@ -0,0 +1,63 @@
+<?php
+
+declare(strict_types=1);
+namespace Widmogrod\Monad\Control\Doo;
+
+use Widmogrod\FantasyLand\Monad;
+use Widmogrod\Monad\Control\Doo\Algebra\DooF;
+use Widmogrod\Monad\Control\Doo\Algebra\In;
+use Widmogrod\Monad\Control\Doo\Algebra\Let;
+use Widmogrod\Monad\Control\Doo\Registry\Registry;
+use Widmogrod\Monad\Free\MonadFree;
+use Widmogrod\Monad\Free\Pure;
+use Widmogrod\Monad\Reader;
+use const Widmogrod\Monad\Reader\pure;
+use function Widmogrod\Functional\sequenceM;
+use function Widmogrod\Monad\Free\foldFree;
+use function Widmogrod\Monad\Reader\runReader;
+use function Widmogrod\Useful\match;
+
+/**
+ * @var callable
+ */
+const interpretation = 'Widmogrod\Monad\Control\Doo\interpretation';
+
+/**
+ * interpretationOfDoo :: DooF f -> Reader Registry MonadFree
+ *
+ * @param  DooF   $f
+ * @return Reader
+ *
+ * @throws \Widmogrod\Useful\PatternNotMatchedError
+ */
+function interpretation(DooF $f)
+{
+    return match([
+        Let::class => function (string $name, Monad $m, MonadFree $next): Reader {
+            return Reader::of(function (Registry $registry) use ($name, $m, $next) {
+                return $m->bind(function ($v) use ($name, $next, $registry) {
+                    $registry->set($name, $v);
+
+                    return $next;
+                });
+            });
+        },
+        In::class => function (array $names, callable $fn, callable $next): Reader {
+            return Reader::of(function (Registry $registry) use ($names, $fn, $next) {
+                $args = array_map([$registry, 'get'], $names);
+
+                return $next($fn(...$args));
+            });
+        },
+    ], $f);
+}
+
+function doo(MonadFree ...$operation)
+{
+    $registry = new Registry();
+
+    return runReader(
+        foldFree(interpretation, sequenceM(...$operation), pure),
+        $registry
+    );
+}