*/
-use FunctionalPHP\FantasyLand\Monoid;
-use FunctionalPHP\FantasyLand\Semigroup;
+use PHPUnit\Runner\Exception;
use Widmogrod\Monad\Maybe\Just;
use Widmogrod\Monad\Maybe\Maybe;
use Widmogrod\Monad\Maybe\Nothing;
use Widmogrod\Primitive\Listt;
use Widmogrod\Useful\PatternMatcher;
+use function Widmogrod\Functional\concatM;
use function Widmogrod\Functional\constt;
use function Widmogrod\Functional\curryN;
use function Widmogrod\Functional\foldr;
+use function Widmogrod\Functional\fromIterable;
use function Widmogrod\Functional\map;
+use function Widmogrod\Functional\reduce;
+use function Widmogrod\Functional\zip;
+use function Widmogrod\Monad\Maybe\just;
+use function Widmogrod\Monad\Maybe\nothing;
use function Widmogrod\Useful\match;
use const Widmogrod\Functional\identity;
-interface Exp
+interface Exp extends PatternMatcher
{
}
}
}
-interface Lit
+interface Lit extends PatternMatcher
{
}
}
// data Scheme = Scheme [ String ] Type
-class Scheme
+class Scheme implements PatternMatcher
{
/**
* @var array
}
}
-class Set implements Monoid
+class Set
{
+ const union = 'example\\Set::union';
+
+ private static $data;
+
+ private function __construct(\ArrayObject $data)
+ {
+ self::$data = $data;
+ }
+
/**
* @inheritdoc
*/
public static function mempty()
{
- // TODO: Implement mempty() method.
+ return new static(new \ArrayObject());
}
public static function fromList(Listt $l)
{
+ return reduce(function (Set $acc, $value) {
+ return $acc::insert($value, $acc);
+ }, static::mempty(), $l);
}
public static function toList(Set $set): Listt
{
+ return fromIterable(array_keys($set::$data->getArrayCopy()));
}
- public static function withValue($n)
+ public static function withValue($n): Set
{
+ return new static(new \ArrayObject([
+ $n => true,
+ ]));
}
- /**
- * @inheritdoc
- */
- public function concat(Semigroup $value): Semigroup
+ public static function insert($value, Set $set): Listt
+ {
+ $new = clone $set::$data;
+ $new[$value] = true;
+ return new static($new);
+ }
+
+ public static function union(Set $a, Set $b): Set
+ {
+ return self::fromList(concatM(
+ static::toList($a),
+ static::toList($b)
+ ));
+ }
+
+ public static function difference(Set $a, Set $b): Set
{
- // TODO: Implement concat() method.
+ $diffA = reduce(function (Set $acc, $value) use ($b) {
+ return static::member($value, $b)
+ ? $acc
+ : static::insert($value, $acc);
+ }, static::mempty(), static::toList($a));
+ $diffB = reduce(function (Set $acc, $value) use ($a) {
+ return static::member($value, $a)
+ ? $acc
+ : static::insert($value, $acc);
+ }, static::mempty(), static::toList($b));
+
+ return static::union($diffA, $diffB);
+ }
+
+ private static function member($value, Set $set): bool
+ {
+ return isset($set::$data[$value]);
}
}
function union(Set $a, Set $b): Set
{
- // TODO: Implement union() method.
+ return Set::union($a, $b);
}
function difference(Set $a, Set $b): Set
{
- // TODO: Implement difference() method.
+ return Set::difference($a, $b);
}
class Map
{
const delete = 'Map::delete';
+ protected static $data;
+
+ private function __construct(\ArrayObject $data)
+ {
+ self::$data = $data;
+ }
+
+ public static function mempty()
+ {
+ return new static(new \ArrayObject());
+ }
+
public static function elems(Map $map): Listt
{
+ return fromIterable(array_keys($map::$data->getArrayCopy()));
}
- /**
- * @return $this
- */
- public static function union(Map $a, Map $b)
+ public static function union(Map $a, Map $b): Map
{
+ return reduce(function (Map $acc, $key) use ($b) {
+ return static::insert($ksey, $b::$data[$key], $acc);
+ }, $a, static::elems($b));
}
- /**
- * @return $this
- */
- public static function map(callable $fn, Map $map)
+ public static function map(callable $fn, Map $map): Map
{
+ return reduce(function (Map $acc, $key) use ($fn, $map) {
+ return static::insert($key, $fn($map::$data[$key]), $acc);
+ }, static::mempty(), static::elems($map));
}
- public static function lookup($key): Maybe
+ public static function lookup($key, Map $map): Maybe
{
+ return isset($map::$data[$key])
+ ? just($map::$data[$key])
+ : nothing();
}
- /**
- * @return $this
- */
- public static function delete($key, Map $map)
+ public static function delete($key, Map $map): Map
{
+ $new = clone $map::$data;
+ unset($new[$key]);
+ return new static($new);
+ }
+
+ public static function insert($key, $value, Map $map): Map
+ {
+ $new = clone $map::$data;
+ $new[$key] = $value;
+ return new static($new);
+ }
+
+ public static function fromList(Listt $list)
+ {
+ return reduce(function (Map $acc, $tuple) {
+ [$key, $value] = $tuple;
+ return static::insert($key, $value, $acc);
+ }, static::mempty(), $list);
}
}
function lookup(Map $map, $key): Maybe
{
- return $map->lookup($key);
+ return MaP::lookup($key, $map);
}
// type Subst = Map.Map String Type
class Subst extends Map implements PatternMatcher
{
- private $vars;
- private $type;
-
- public function __construct(Listt $vars, Type $type)
- {
- $this->vars = $vars;
- $this->type = $type;
- }
-
-
/**
- * @inheritdoc
+ * should be used with conjuction
+ * @param callable $fn
+ * @return mixed
*/
public function patternMatched(callable $fn)
{
- return $fn($this->vars, $this->type);
+ throw new Exception('not implemented');
+ // TODO: Implement patternMatched() method.
}
}
// type TI a = ErrorT String (ReaderT TIEnv (StateT TIState IO)) a
//class TI
+$increment = 0;
+
// instantiate :: Scheme → TI Type
-function instantiate(Scheme): TI {
+function instantiate(Scheme $s)
+{
+ global $increment;
+
// instantiate (Scheme vars t)
// = do nvars ← mapM (λ → newTyVar "a") vars
// let s = Map.fromList (zip vars nvars)
// return $ apply s t
+ return match([
+ Scheme::class => function (Listt $vars, Type $t) use (&$increment) {
+ $nvars = map(function () use (&$increment) {
+ return new TVar('$a' . (++$increment));
+ }, $vars);
+
+ $s = Subst::fromList(zip($vars, $nvars));
+ return apply($s, $t);
+ },
+ ], $s);
}
/*
function tiLit(Lit $li)
{
return match([
- LInt::class => new TI([nullSubst(), TInt::class]),
- TBool::class => new TI([nullSubst(), TBool::class]),
+ LInt::class => constt([nullSubst(), new TInt()]),
+ LBool::class => constt([nullSubst(), new TBool()]),
], $li);
}
* @return mixed
* @throws \Widmogrod\Useful\PatternNotMatchedError
*/
-function ti(TypeEnv $env, Exp $e): TI
+function ti(TypeEnv $env, Exp $e)
{
return match([
- EVar::class => function () use ($env) {
+ TypeEnv::class => function (Map $envMap) use ($env, $e) {
return match([
- Nothing::class => function () {
-
+ EVar::class => function ($n) use ($envMap) {
+ return match([
+ Nothing::class => function () {
+ throw new Exception('not implemented');
+ },
+ Just::class => function ($sigma) {
+ return [nullSubst(), instantiate($sigma)];
+ },
+ ], Map::lookup($n, $envMap));
},
- Just::class => function ($sigma) {
- return instantiate($sigma)->bind(function ($t) {
- return [nullSubst, $t];
- });
+ ELit::class => function (Lit $l) {
+ return tiLit($l);
},
- ], $env);
- },
- ELit::class => function (Lit $l) {
- return tiLit($l);
- },
- EAbs::class => function () {
-
- },
- EApp::class => function () {
-
- },
- ELet::class => function () {
-
+ EAbs::class => function () {
+ throw new Exception('not implemented');
+ },
+ EApp::class => function () {
+ throw new Exception('not implemented');
+ },
+ ELet::class => function ($n, Exp $e1, Exp $e2) use ($env, $envMap) {
+ [$s1, $t1] = ti($env, $e1);
+ $t1 = generalize(apply($s1, $env), $t1);
+ $env = new TypeEnv(Map::insert($n, $t1, $envMap));
+ [$s2, $t2] = ti($env, $e2);
+ return [composeSubst($s1, $s2), $t2];
+ },
+ ], $e);
},
- ], $e);
+ ], $env);
}
-// typeInference :: Map.Map String Scheme → Exp → TI Type
-function typeInference(Map $env, Exp $e): TI
+/**
+ * // typeInference :: Map.Map String Scheme → Exp → TI Type
+ * @param \example\Map $env
+ * @param Exp $e
+ * @return mixed
+ * @throws \Widmogrod\Useful\PatternNotMatchedError
+ */
+function typeInference(Map $env, Exp $e)
{
+ [$s, $t] = ti(new TypeEnv($env), $e);
+ return apply($s, $t);
+}
+/**
+ * @param Type $t
+ * @return mixed
+ * @throws \Widmogrod\Useful\PatternNotMatchedError
+ */
+function showType(Type $t)
+{
+ return match([
+ TInt::class => constt('Int'),
+ TBool::class => constt('Bool'),
+ TVar::class => identity,
+ TFun::class => function (Type $t1, Type $t2) {
+ return sprintf('(%s -> %s)', showType($t1), showType($t2));
+ }
+ ], $t);
}
class FreeMonadTest extends \PHPUnit\Framework\TestCase
/**
* @dataProvider provideExamples
*/
- public function test(Exp $expression)
+ public function test(Exp $expression, $expected)
{
$this->assertInstanceOf(Exp::class, $expression);
+ $result = typeInference(Map::mempty(), $expression);
+ $this->assertEquals($expected, showType($result));
}
public function provideExamples()
{
return [
- // e0 = ELet "id" (EAbs "x" (EVar "x")) (EVar "id")
- 'let id = (x -> x) in id)' => [
- 'expression' => new ELet(
- 'id',
- new EAbs("x", new EVar("x")),
- new EVar("id")
- ),
- 'expected' => 'a1 -> a1',
- ],
- // e1 = ELet "id" (EAbs "x" (EVar "x")) (EApp (EVar "id") (EVar "id"))
- 'let id = (x -> x) in id id' => [
- 'expression' => new ELet(
- 'id',
- new EAbs(
- 'x',
- new EVar('x')
- ),
- new EApp(
- new EVar('id'),
- new EVar('id')
- )
- ),
- 'expected' => 'a3 -> a3',
- ],
- // e2 = ELet "id" (EAbs "x" (ELet "y" (EVar "x") (EVar "y"))) (EApp (EVar "id") (EVar "id"))
- 'let id = (x -> let y = x in y) in id id ' => [
- 'expression' => new ELet(
- 'x',
- new EAbs(
- 'x',
- new ELet(
- 'y',
- new EVar('x'),
- new EVar('y')
- )
- ),
- new EApp(
- new EVar('id'),
- new EVar('id')
- )
- ),
- 'expected' => 'a3 -> a3',
- ],
- // e3 = ELet "id" (EAbs "x" (ELet "y" (EVar "x") (EVar "y"))) (EApp (EApp (EVar "id") (EVar "id")) (ELit (LInt 2)))
- 'let id = (x -> let y = x in y) in ((id id) 2)' => [
- 'expression' => new ELet(
- 'id',
- new EAbs(
- 'x',
- new ELet(
- 'y',
- new EVar('x'),
- new EVar('y')
- )
- ),
- new EApp(
- new EApp(
- new EVar('id'),
- new EVar('id')
- ),
- new ELit(new LInt(2))
- )
- ),
+ '2' => [
+ 'expression' => new ELit(new LInt(2)),
'expected' => 'Int',
],
- // e4 = ELet "id" (EAbs "x" (EApp (EVar "x") (EVar "x"))) (EVar "id")
- 'let id = (x -> (x x)) in id' => [
+ 'let id = 2 in id' => [
'expression' => new ELet(
'id',
- new EAbs(
- 'x',
- new EApp(
- new EVar('x'),
- new EVar('x')
- )
- ),
- new EVar('id')
- ),
- 'expected' => 'error: occur check fails: a0 vs. a0 -> a1',
- ],
- // e5 = EAbs "m" (ELet "y" (EVar "m")
- // (ELet "x" (EApp (EVar "y") (ELit (LBool True)))
- // (EVar "x")))
- '(m -> let y = m in let x = (y true) in x)' => [
- 'expression' => new EAbs(
- 'm',
- new ELet(
- 'y',
- new EVar('m'),
- new ELet(
- 'x',
- new EApp(
- new EVar('y'),
- new ELit(new LBool(true))
- ),
- new EVar('x')
- )
- )
- ),
- 'expected' => '(Bool -> a1) -> a1',
- ],
- // e6 = EApp (ELit (LInt 2)) (ELit (LInt 2))
- '(2 2)' => [
- 'expression' => new EApp(
new ELit(new LInt(2)),
- new ELit(new LInt(2))
- ),
- 'expected' => 'error: types do not unify: Int vs. Int -> a0',
- ],
- // e7 = ELet "id" (EAbs "x" (EVar "y")) (EVar "id")
- 'let id = (x -> y) in id)' => [
- 'expression' => new ELet(
- 'id',
- new EAbs("x", new EVar("y")),
new EVar("id")
),
- 'expected' => 'error: unbound variable: y',
+ 'expected' => 'Int',
],
+ // e0 = ELet "id" (EAbs "x" (EVar "x")) (EVar "id")
+// 'let id = (x -> x) in id)' => [
+// 'expression' => new ELet(
+// 'id',
+// new EAbs("x", new EVar("x")),
+// new EVar("id")
+// ),
+// 'expected' => 'a1 -> a1',
+// ],
+// // e1 = ELet "id" (EAbs "x" (EVar "x")) (EApp (EVar "id") (EVar "id"))
+// 'let id = (x -> x) in id id' => [
+// 'expression' => new ELet(
+// 'id',
+// new EAbs(
+// 'x',
+// new EVar('x')
+// ),
+// new EApp(
+// new EVar('id'),
+// new EVar('id')
+// )
+// ),
+// 'expected' => 'a3 -> a3',
+// ],
+// // e2 = ELet "id" (EAbs "x" (ELet "y" (EVar "x") (EVar "y"))) (EApp (EVar "id") (EVar "id"))
+// 'let id = (x -> let y = x in y) in id id ' => [
+// 'expression' => new ELet(
+// 'x',
+// new EAbs(
+// 'x',
+// new ELet(
+// 'y',
+// new EVar('x'),
+// new EVar('y')
+// )
+// ),
+// new EApp(
+// new EVar('id'),
+// new EVar('id')
+// )
+// ),
+// 'expected' => 'a3 -> a3',
+// ],
+// // e3 = ELet "id" (EAbs "x" (ELet "y" (EVar "x") (EVar "y"))) (EApp (EApp (EVar "id") (EVar "id")) (ELit (LInt 2)))
+// 'let id = (x -> let y = x in y) in ((id id) 2)' => [
+// 'expression' => new ELet(
+// 'id',
+// new EAbs(
+// 'x',
+// new ELet(
+// 'y',
+// new EVar('x'),
+// new EVar('y')
+// )
+// ),
+// new EApp(
+// new EApp(
+// new EVar('id'),
+// new EVar('id')
+// ),
+// new ELit(new LInt(2))
+// )
+// ),
+// 'expected' => 'Int',
+// ],
+// // e4 = ELet "id" (EAbs "x" (EApp (EVar "x") (EVar "x"))) (EVar "id")
+// 'let id = (x -> (x x)) in id' => [
+// 'expression' => new ELet(
+// 'id',
+// new EAbs(
+// 'x',
+// new EApp(
+// new EVar('x'),
+// new EVar('x')
+// )
+// ),
+// new EVar('id')
+// ),
+// 'expected' => 'error: occur check fails: a0 vs. a0 -> a1',
+// ],
+// // e5 = EAbs "m" (ELet "y" (EVar "m")
+// // (ELet "x" (EApp (EVar "y") (ELit (LBool True)))
+// // (EVar "x")))
+// '(m -> let y = m in let x = (y true) in x)' => [
+// 'expression' => new EAbs(
+// 'm',
+// new ELet(
+// 'y',
+// new EVar('m'),
+// new ELet(
+// 'x',
+// new EApp(
+// new EVar('y'),
+// new ELit(new LBool(true))
+// ),
+// new EVar('x')
+// )
+// )
+// ),
+// 'expected' => '(Bool -> a1) -> a1',
+// ],
+// // e6 = EApp (ELit (LInt 2)) (ELit (LInt 2))
+// '(2 2)' => [
+// 'expression' => new EApp(
+// new ELit(new LInt(2)),
+// new ELit(new LInt(2))
+// ),
+// 'expected' => 'error: types do not unify: Int vs. Int -> a0',
+// ],
+ // e7 = ELet "id" (EAbs "x" (EVar "y")) (EVar "id")
+// 'let id = (x -> y) in id)' => [
+// 'expression' => new ELet(
+// 'id',
+// new EAbs("x", new EVar("y")),
+// new EVar("id")
+// ),
+// 'expected' => 'error: unbound variable: y',
+// ],
];
}
}
projects / php-functional.git / commitdiff
