Skip to content

Commit 282ed2b

Browse files
widmogrodwidmogrod
authored
Merge pull request #87 from widmogrod/feature/free-example
 Use free monad to design - haskell like do notation in PHP
2 parents 5b79110 + 6afaff5 commit 282ed2b

File tree

11 files changed

+314
-42
lines changed

11 files changed

+314
-42
lines changed

‎composer.json

+2
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,8 @@
4747
"src/Monad/Reader/functions.php",
4848
"src/Monad/State/functions.php",
4949
"src/Monad/Writer/functions.php",
50+
"src/Monad/Control/Doo/actions.php",
51+
"src/Monad/Control/Doo/interpretation.php",
5052
"src/Useful/match.php"
5153
]
5254
}

‎example/FreeDooDSLTest.php

+45
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,45 @@
1+
<?php
2+
3+
declare(strict_types=1);
4+
5+
namespace example;
6+
7+
use Widmogrod\Monad\Identity;
8+
use function Widmogrod\Monad\Control\Doo\doo;
9+
use function Widmogrod\Monad\Control\Doo\in;
10+
use function Widmogrod\Monad\Control\Doo\let;
11+
12+
class FreeDooDSLTest extends \PHPUnit\Framework\TestCase
13+
{
14+
public function test_example_with_do_notation()
15+
{
16+
$result = doo(
17+
let('a', Identity::of(1)),
18+
let('b', Identity::of(3)),
19+
let('c', in(['a', 'b'], function (int $a, int $b): Identity {
20+
return Identity::of($a + $b);
21+
})),
22+
in(['c'], function (int $c): Identity {
23+
return Identity::of($c * $c);
24+
})
25+
);
26+
27+
$this->assertEquals(Identity::of(16), $result);
28+
}
29+
30+
public function test_example_without_do_notation()
31+
{
32+
$result = Identity::of(1)
33+
->bind(function ($a) {
34+
return Identity::of(3)
35+
->bind(function ($b) use ($a) {
36+
return Identity::of($a + $b)
37+
->bind(function ($c) {
38+
return Identity::of($c * $c);
39+
});
40+
});
41+
});
42+
43+
$this->assertEquals(Identity::of(16), $result);
44+
}
45+
}

‎src/Functional/functions.php

+14-42
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,6 @@
1010
use Widmogrod\FantasyLand\Functor;
1111
use Widmogrod\FantasyLand\Monad;
1212
use Widmogrod\FantasyLand\Traversable;
13-
use Widmogrod\Monad\Identity;
1413
use Widmogrod\Primitive\Listt;
1514
use Widmogrod\Primitive\ListtCons;
1615

@@ -457,37 +456,27 @@ function liftA2(
457456
*
458457
* a.k.a haskell >>
459458
*
460-
* Sequentially compose two actions, discarding any value produced by the first, like sequencing operators (such as the semicolon) in imperative languages.
459+
* Sequentially compose two actions, discarding any value produced by the first,
460+
* like sequencing operators (such as the semicolon) in imperative languages.
461+
*
462+
* This implementation allow to **compose more than just two monads**.
461463
*
462464
* @param Monad $a
463465
* @param Monad $b
464466
*
465467
* @return Monad
466468
*/
467-
function sequenceM(Monad $a, Monad $b)
468-
{
469-
return $a->bind(function () use ($b) {
470-
return $b;
471-
});
472-
}
473-
474-
/**
475-
* @var callable
476-
*/
477-
const sequence_ = 'Widmogrod\Functional\sequence_';
478-
479-
/**
480-
* sequence_ :: Monad m => [m a] -> m ()
481-
*
482-
* @todo consider to do it like this: foldr (>>) (return ())
483-
*
484-
* @param Monad[] $monads
485-
*
486-
* @return Monad
487-
*/
488-
function sequence_(Monad ...$monads)
469+
function sequenceM(Monad $a, Monad $b = null): Monad
489470
{
490-
return reduce(sequenceM, Identity::of([]), fromIterable($monads));
471+
return curryN(2, function (Monad ...$monads): Monad {
472+
return array_reduce($monads, function (?Monad $a, Monad $b) {
473+
return $a
474+
? $a->bind(function () use ($b) {
475+
return $b;
476+
})
477+
: $b;
478+
}, null);
479+
})(...func_get_args());
491480
}
492481

493482
/**
@@ -515,23 +504,6 @@ function traverse(callable $transformation, Traversable $t = null)
515504
})(...func_get_args());
516505
}
517506

518-
/**
519-
* @var callable
520-
*/
521-
const sequence = 'Widmogrod\Functional\sequence';
522-
523-
/**
524-
* sequence :: Monad m => t (m a) -> m (t a)
525-
*
526-
* @param Traversable|Monad[] $monads
527-
*
528-
* @return Monad
529-
*/
530-
function sequence(Monad ...$monads)
531-
{
532-
return traverse(identity, fromIterable($monads));
533-
}
534-
535507
/**
536508
* filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
537509
*

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

+15
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
<?php
2+
3+
declare(strict_types=1);
4+
namespace Widmogrod\Monad\Control\Doo\Algebra;
5+
6+
use Widmogrod\FantasyLand\Functor;
7+
use Widmogrod\Useful\PatternMatcher;
8+
9+
/**
10+
* DooF next = Let name m next
11+
* | In [name] fn (m -> next)
12+
*/
13+
interface DooF extends Functor, PatternMatcher
14+
{
15+
}

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

+42
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
<?php
2+
3+
declare(strict_types=1);
4+
5+
namespace Widmogrod\Monad\Control\Doo\Algebra;
6+
7+
use Widmogrod\FantasyLand\Functor;
8+
use function Widmogrod\Functional\compose;
9+
10+
class In implements DooF
11+
{
12+
private $names;
13+
private $fn;
14+
private $next;
15+
16+
public function __construct(array $names, callable $fn, callable $next)
17+
{
18+
$this->names = $names;
19+
$this->fn = $fn;
20+
$this->next = $next;
21+
}
22+
23+
/**
24+
* @inheritdoc
25+
*/
26+
public function map(callable $function): Functor
27+
{
28+
return new self(
29+
$this->names,
30+
$this->fn,
31+
compose($function, $this->next)
32+
);
33+
}
34+
35+
/**
36+
* @inheritdoc
37+
*/
38+
public function patternMatched(callable $fn)
39+
{
40+
return $fn($this->names, $this->fn, $this->next);
41+
}
42+
}

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

+42
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
<?php
2+
3+
declare(strict_types=1);
4+
namespace Widmogrod\Monad\Control\Doo\Algebra;
5+
6+
use Widmogrod\FantasyLand\Functor;
7+
use Widmogrod\FantasyLand\Monad;
8+
use Widmogrod\Monad\Free\MonadFree;
9+
10+
class Let implements DooF
11+
{
12+
private $name;
13+
private $m;
14+
private $next;
15+
16+
public function __construct(string $name, Monad $m, MonadFree $next)
17+
{
18+
$this->name = $name;
19+
$this->m = $m;
20+
$this->next = $next;
21+
}
22+
23+
/**
24+
* @inheritdoc
25+
*/
26+
public function map(callable $function): Functor
27+
{
28+
return new self(
29+
$this->name,
30+
$this->m,
31+
$function($this->next)
32+
);
33+
}
34+
35+
/**
36+
* @inheritdoc
37+
*/
38+
public function patternMatched(callable $fn)
39+
{
40+
return $fn($this->name, $this->m, $this->next);
41+
}
42+
}

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

+14
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
<?php
2+
3+
declare(strict_types=1);
4+
namespace Widmogrod\Monad\Control\Doo\Registry;
5+
6+
class CannotRedeclareVariableError extends \Exception
7+
{
8+
public function __construct(string $name, array $registered)
9+
{
10+
$message = 'Cannot redeclare variable "%s". Registered variables %s';
11+
$message = sprintf($message, $name, join(',', $registered));
12+
parent::__construct($message);
13+
}
14+
}

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

+38
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,38 @@
1+
<?php
2+
3+
declare(strict_types=1);
4+
namespace Widmogrod\Monad\Control\Doo\Registry;
5+
6+
class Registry
7+
{
8+
private $data = [];
9+
10+
/**
11+
* @param string $name
12+
* @return mixed
13+
* @throws VariableNotDeclaredError
14+
*/
15+
public function get(string $name)
16+
{
17+
if (array_key_exists($name, $this->data)) {
18+
return $this->data[$name];
19+
}
20+
21+
throw new VariableNotDeclaredError($name);
22+
}
23+
24+
/**
25+
* @param string $name
26+
* @param mixed $value
27+
* @return mixed
28+
* @throws CannotRedeclareVariableError
29+
*/
30+
public function set(string $name, $value)
31+
{
32+
if (array_key_exists($name, $this->data)) {
33+
throw new CannotRedeclareVariableError($name, array_keys($this->data));
34+
}
35+
36+
return $this->data[$name] = $value;
37+
}
38+
}

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

+15
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
<?php
2+
3+
declare(strict_types=1);
4+
namespace Widmogrod\Monad\Control\Doo\Registry;
5+
6+
class VariableNotDeclaredError extends \Exception
7+
{
8+
public function __construct(string $name)
9+
{
10+
$message = 'Variable "%s" is not declared';
11+
$message = sprintf($message, $name);
12+
13+
parent::__construct($message);
14+
}
15+
}

‎src/Monad/Control/Doo/actions.php

+24
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
<?php
2+
3+
declare(strict_types=1);
4+
5+
namespace Widmogrod\Monad\Control\Doo;
6+
7+
use Widmogrod\FantasyLand\Monad;
8+
use Widmogrod\Monad\Free\MonadFree;
9+
use Widmogrod\Monad\Free\Pure;
10+
use function Widmogrod\Monad\Free\liftF;
11+
12+
function let(string $name, Monad $m): MonadFree
13+
{
14+
return $m instanceof MonadFree
15+
? $m->bind(function (Monad $m) use ($name): MonadFree {
16+
return liftF(new Algebra\Let($name, $m, Pure::of(null)));
17+
})
18+
: liftF(new Algebra\Let($name, $m, Pure::of(null)));
19+
}
20+
21+
function in(array $names, callable $fn): MonadFree
22+
{
23+
return liftF(new Algebra\In($names, $fn, Pure::of));
24+
}

‎src/Monad/Control/Doo/interpretation.php

+63
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,63 @@
1+
<?php
2+
3+
declare(strict_types=1);
4+
namespace Widmogrod\Monad\Control\Doo;
5+
6+
use Widmogrod\FantasyLand\Monad;
7+
use Widmogrod\Monad\Control\Doo\Algebra\DooF;
8+
use Widmogrod\Monad\Control\Doo\Algebra\In;
9+
use Widmogrod\Monad\Control\Doo\Algebra\Let;
10+
use Widmogrod\Monad\Control\Doo\Registry\Registry;
11+
use Widmogrod\Monad\Free\MonadFree;
12+
use Widmogrod\Monad\Free\Pure;
13+
use Widmogrod\Monad\Reader;
14+
use const Widmogrod\Monad\Reader\pure;
15+
use function Widmogrod\Functional\sequenceM;
16+
use function Widmogrod\Monad\Free\foldFree;
17+
use function Widmogrod\Monad\Reader\runReader;
18+
use function Widmogrod\Useful\match;
19+
20+
/**
21+
* @var callable
22+
*/
23+
const interpretation = 'Widmogrod\Monad\Control\Doo\interpretation';
24+
25+
/**
26+
* interpretationOfDoo :: DooF f -> Reader Registry MonadFree
27+
*
28+
* @param DooF $f
29+
* @return Reader
30+
*
31+
* @throws \Widmogrod\Useful\PatternNotMatchedError
32+
*/
33+
function interpretation(DooF $f)
34+
{
35+
return match([
36+
Let::class => function (string $name, Monad $m, MonadFree $next): Reader {
37+
return Reader::of(function (Registry $registry) use ($name, $m, $next) {
38+
return $m->bind(function ($v) use ($name, $next, $registry) {
39+
$registry->set($name, $v);
40+
41+
return $next;
42+
});
43+
});
44+
},
45+
In::class => function (array $names, callable $fn, callable $next): Reader {
46+
return Reader::of(function (Registry $registry) use ($names, $fn, $next) {
47+
$args = array_map([$registry, 'get'], $names);
48+
49+
return $next($fn(...$args));
50+
});
51+
},
52+
], $f);
53+
}
54+
55+
function doo(MonadFree ...$operation)
56+
{
57+
$registry = new Registry();
58+
59+
return runReader(
60+
foldFree(interpretation, sequenceM(...$operation), pure),
61+
$registry
62+
);
63+
}

0 commit comments

Comments
 (0)