Skip to content

Instantly share code, notes, and snippets.

@austinhyde

austinhyde/adt-5.6.php

Last active Aug 29, 2015
Embed
What would you like to do?
PHP: Algebraic Data Types, Functors, and Applicative Functors
<?php
function b($b) { return $b ? 'true' : 'false'; }
function implodekv($ks, $es, $arr) {
return implode($es, array_map(function($k,$v)use($ks){return "$k$ks$v";},array_keys($arr),$arr));
}
interface Functor {
public function fmap(callable $func);
}
interface Applicative extends Functor {
public static function pure($x);
public function extract(Applicative $other);
}
interface Matchable {
public function unapply();
}
interface MatchablePattern {
public function matches(...$args);
}
class MatchableScalar implements MatchablePattern, Matchable {
public function __construct($value) {
$this->value = $value;
}
public function matches(...$args) {
return $this->value === $args[0];
}
public function unapply() {
return $this->value;
}
}
trait ADT {
public static function __callStatic($name, $args) {
$class = get_called_class();
$constant = "$class::$name";
if (defined($constant)) {
$subclass = "{$class}_{$name}";
if (!class_exists($subclass, false)) {
// ewwww....
eval("class $subclass extends $class { }");
}
$def = constant($constant);
if (($d = count($def)) != ($a = count($args))) {
throw new InvalidArgumentException("Expected $d args, got $a");
}
if (empty($def)) {
$data = array();
} else {
$data = array_combine($def, $args);
}
return new $subclass($name, $data);
}
throw new BadMethodCallException("No $class constructor called $name");
}
private function __construct($name, $data) {
$this->_name = $name;
$this->_data = $data;
}
public function __get($prop) {
return $this->_data[$prop];
}
public function __toString() {
return sprintf("%s(%s)", $this->_name, implodekv(':',';',$this->_data));
}
public function matches(...$args) {
foreach (array_values($this->_data) as $i => $val) {
if ($val !== null && $args[$i] !== $val) {
return false;
}
}
return true;
}
public function unapply() {
$args = array_values($this->_data);
return $args;
}
public function match(...$args) {
return match($this, ...$args);
}
}
function match($obj, ...$args) {
if (is_object($obj) && !($obj instanceof Matchable)) {
throw new InvalidArgumentException("Given match target $obj is not a Matchable");
}
$call = function($action, ...$args) {
if (is_callable($action)) {
return $action(...$args);
} else {
return $action;
}
};
$unapplied = is_scalar($obj) ? $obj : $obj->unapply();
for ($i = 0, $ii = count($args); $i < $ii; $i += 2) {
$pattern = $args[$i];
$action = $args[$i + 1];
if ((is_null($unapplied) || is_scalar($unapplied)) && (is_scalar($pattern) || is_null($pattern))) {
if ($pattern === null || $pattern === $unapplied) {
return $call($action, $obj);
}
continue;
}
if (!($pattern instanceof MatchablePattern)) {
throw new InvalidArgumentException("Given pattern $pattern is not a MatchablePattern");
}
if (get_class($obj) == get_class($pattern) && $pattern->matches(...$unapplied)) {
return $call($action, ...$unapplied);
}
}
throw new LogicException("All match() cases were exhausted!");
}
abstract class AbstractADT implements Matchable, MatchablePattern {
use ADT;
}
////////////////////////////////////////
define('_', null);
class Maybe extends AbstractADT implements Applicative {
const Just = ['value'];
const Nothing = [];
public function isPresent() {
return match($this,
Maybe::Just(_), true,
Maybe::Nothing(), false
);
}
public function fmap(callable $f) {
// echo "Maybe->fmap: fmap $f $this = ";
$x = match($this,
Maybe::Just(_), function($x) use ($f) { return Maybe::Just($f($x)); },
Maybe::Nothing(), Maybe::Nothing()
);
// echo "$x\n";
return $x;
}
public static function pure($x) {
return Maybe::Just($x);
}
public function extract(Applicative $other) {
return $this->match(
Maybe::Nothing(), Maybe::Nothing(),
Maybe::Just(_), function($f) use ($other) {
// echo "Maybe->extract: $this <*> $other = fmap $f $other\n";
return $other->fmap($f);
}
);
}
public function __toString() {
return $this->match(
Maybe::Nothing(), 'Nothing',
Maybe::Just(_), function($x) { return "(Just $x)"; }
);
}
}
echo "Maybe test:\n";
$x = Maybe::Just(4);
echo "$x ";
echo 'isPresent: ' . b($x->isPresent()) . "\n";
$y = Maybe::Nothing();
echo "$y ";
echo 'isPresent: ' . b($y->isPresent()) . "\n";
// uncomment for error
// $z = Maybe::Something();
// http://docs.scala-lang.org/tutorials/tour/pattern-matching.html
echo "\nScalar matching test:\n";
$x = 3;
echo match($x,
1, 'one',
2, 'two',
_, 'many'
) . "\n";
// http://danielwestheide.com/blog/2012/11/21/the-neophytes-guide-to-scala-part-1-extractors.html
echo "\nScala equivalent test:\n";
class User extends AbstractADT {
const FreeUser = ['name','score','upgrade'];
const PremiumUser = ['name','score'];
}
$user = User::FreeUser('Daniel', 3000, 0.7);
match($user,
User::FreeUser(_, _, _), function($name, $_, $p) {
if ($p > 0.75) echo "$name, what can we do for you?\n";
else echo "Hello $name.\n";
},
User::PremiumUser(_, _), function($name, $_) {
echo "Welcome back, dear $name\n";
}
);
///////////////////////////////////////////////////////////
// http://learnyouahaskell.com/functor-applicative-functors-and-monoids
echo "\nFunctor test:\n";
class SimpleList implements Applicative {
public static function pure($x) {
return new static([$x]);
}
public function __construct($arr) {
$this->arr = $arr;
}
public function fmap(callable $f) {
return new SimpleList(array_map($f, $this->arr));
}
public function extract(Applicative $other) {
$out = array();
foreach ($this->arr as $f) {
foreach ($other->arr as $x) {
$out[] = $f($x);
}
}
return new static($out);
}
public function __toString() {
return '[' . implode(', ', $this->arr) . ']';
}
}
class Func implements Functor {
public function __construct($g, $label = false) {
$this->label = $label;
$this->g = $g;
}
public function fmap(callable $f) {
$g = $this->g;
return new Func(function (...$args) use ($f, $g) {
return $f($g(...$args));
},"($f . $this)");
}
public function __invoke(...$args) {
return call_user_func_array($this->g, $args);
}
public function __toString() {
return $this->label ?: 'Func';
}
}
function lift($x) {
if ($x instanceof Functor) {
return $x;
}
if (is_array($x)) {
return new SimpleList($x);
}
if (is_callable($x)) {
return new Func($x);
}
throw new InvalidArgumentException("Unliftable type");
}
function fmap(callable $f, $g) {
return lift($g)->fmap($f);
}
function cfmap(callable $f) {
return function ($g) use ($f) {
return fmap($f, $g);
};
}
function aextract($l, $r) {
// echo "aextract: $l <*> $r\n";
return lift($l)->extract(lift($r));
}
$id = new Func(function ($x) { return $x; }, 'id');
$times3 = new Func(function ($x) { return $x * 3; }, '(*3)');
$add3 = new Func(function ($x) { return $x + 3; }, '(+3)');
$add100 = new Func(function ($x) { return $x + 100; }, '(*100)');
$xs = lift([1,2,3]);
$j4 = Maybe::Just(4);
$n = Maybe::Nothing();
echo "fmap $times3 $xs: " . fmap($times3, $xs) . "\n";
echo "fmap $times3 $j4: " . fmap($times3, $j4) . "\n";
echo "fmap $times3 $n: " . fmap($times3, $n) . "\n";
$f = fmap($times3, $add100);
echo "fmap $times3 $add100 1: " . $f(1) . "\n";
echo "fmap $id $xs: " . fmap($id, $xs) . "\n";
echo "fmap $id $j4: " . fmap($id, $j4) . "\n";
echo "fmap $id $n: " . fmap($id, $n) . "\n";
echo "fmap $id $add100: " . fmap($id, $add100) . "\n";
echo "\nApplicative test:\n";
echo "(Just $add3) <*> $j4: " . aextract(Maybe::Just($add3), $j4) . "\n";
$concat = new Func(function ($x) { return $x . 'haha'; }, '(++"haha")');
echo "(Just $concat) <*> $n: " . aextract(Maybe::Just($concat), $n) . "\n";
echo "$n <*> (Just 'woot'): " . aextract($n, Maybe::Just('woot')) . "\n";
$times0 = new Func(function ($x) { return $x * 0; }, '(*0)');
$square = new Func(function ($x) { return $x ** 2; }, '(^2)');
$fs = lift([$times0, $add100, $square]);
echo "$fs <*> $xs: " . aextract($fs, $xs) . "\n";
Maybe test:
(Just 4) isPresent: true
Nothing isPresent: false
Scalar matching test:
many
Scala equivalent test:
Hello Daniel.
Functor test:
fmap (*3) [1, 2, 3]: [3, 6, 9]
fmap (*3) (Just 4): (Just 12)
fmap (*3) Nothing: Nothing
fmap (*3) (*100) 1: 303
fmap id [1, 2, 3]: [1, 2, 3]
fmap id (Just 4): (Just 4)
fmap id Nothing: Nothing
fmap id (*100): (id . (*100))
Applicative test:
(Just (+3)) <*> (Just 4): (Just 7)
(Just (++"haha")) <*> Nothing: Nothing
Nothing <*> (Just 'woot'): Nothing
[(*0), (*100), (^2)] <*> [1, 2, 3]: [0, 0, 0, 101, 102, 103, 1, 4, 9]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment