PHP: Algebraic Data Types, Functors, and Applicative Functors

adt-5.6.php

<?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";

output.txt

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]