"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"
]
}
--- /dev/null
+<?php
+
+declare(strict_types=1);
+
+namespace example;
+
+use function Widmogrod\Monad\Control\Doo\doo;
+use function Widmogrod\Monad\Control\Doo\in;
+use function Widmogrod\Monad\Control\Doo\let;
+use Widmogrod\Monad\Identity;
+
+class FreeDooDSLTest extends \PHPUnit\Framework\TestCase
+{
+ public function test_it()
+ {
+ $result = doo(
+ let('a', Identity::of(1)),
+ let('b', Identity::of(2)),
+ 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(9), $result);
+ }
+}
use Widmogrod\FantasyLand\Functor;
use Widmogrod\FantasyLand\Monad;
use Widmogrod\FantasyLand\Traversable;
-use Widmogrod\Monad\Identity;
use Widmogrod\Primitive\Listt;
use Widmogrod\Primitive\ListtCons;
*
* 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());
}
/**
}
/**
- * @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]
*
* ```haskell
--- /dev/null
+<?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
+ */
+interface DooF extends Functor, PatternMatcher
+{
+}
--- /dev/null
+<?php
+
+declare(strict_types=1);
+namespace Widmogrod\Monad\Control\Doo\Algebra;
+
+use Widmogrod\FantasyLand\Functor;
+
+class In implements DooF
+{
+ private $names;
+ private $fn;
+
+ public function __construct(array $names, callable $fn)
+ {
+ $this->names = $names;
+ $this->fn = $fn;
+ }
+
+ /**
+ * @inheritdoc
+ */
+ public function map(callable $function): Functor
+ {
+ return new self(
+ $this->names,
+ $this->fn
+ );
+ }
+
+ /**
+ * @inheritdoc
+ */
+ public function patternMatched(callable $fn)
+ {
+ return $fn($this->names, $this->fn);
+ }
+}
--- /dev/null
+<?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);
+ }
+}
--- /dev/null
+<?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);
+ }
+}
--- /dev/null
+<?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;
+ }
+}
--- /dev/null
+<?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);
+ }
+}
--- /dev/null
+<?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));
+}
--- /dev/null
+<?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): Reader {
+ return Reader::of(function (Registry $registry) use ($names, $fn) {
+ $args = array_map(function ($name) use ($registry) {
+ return $registry->get($name);
+ }, $names);
+
+ return Pure::of($fn(...$args));
+ });
+ },
+ ], $f);
+}
+
+function doo(MonadFree ...$operation)
+{
+ $registry = new Registry();
+
+ return runReader(
+ foldFree(interpretation, sequenceM(...$operation), pure),
+ $registry
+ );
+}
projects / php-functional.git / commitdiff
