Going further into madness. Generate PHP code form haskell's data

diff --git a/example/FreeUnionTypeGeneratorTest.php b/example/FreeUnionTypeGeneratorTest.php
new file mode 100644 (file)
index 0000000..79e2dd9
--- /dev/null
+++ b/example/FreeUnionTypeGeneratorTest.php
@@ -0,0 +1,370 @@
+<?php
+
+declare(strict_types=1);
+
+namespace example;
+
+use FunctionalPHP\FantasyLand\Functor;
+use Widmogrod\Monad\Free\MonadFree;
+use Widmogrod\Monad\Free\Pure;
+use Widmogrod\Monad\Identity;
+use Widmogrod\Primitive\Listt;
+use Widmogrod\Primitive\Stringg;
+use Widmogrod\Useful\PatternMatcher;
+use function Widmogrod\Functional\compose;
+use function Widmogrod\Functional\curryN;
+use function Widmogrod\Functional\fromIterable;
+use function Widmogrod\Functional\prepend;
+use function Widmogrod\Functional\reduce;
+use function Widmogrod\Monad\Free\foldFree;
+use function Widmogrod\Monad\Free\liftF;
+use function Widmogrod\Useful\match;
+
+/**
+ * type UnionF _ next
+ *  | Declare_ name [args] (a -> next)
+ *  | Union_ a name [args] (a -> next)
+ *  | Derived_ a [interfaces] (a -> next)
+ */
+interface UnionF extends Functor, PatternMatcher
+{
+}
+
+class Declare_ implements UnionF
+{
+    private $name;
+    private $args;
+    private $next;
+
+    public function __construct($name, array $args, callable $next)
+    {
+        $this->name = $name;
+        $this->args = $args;
+        $this->next = $next;
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function map(callable $function): Functor
+    {
+        return new self(
+            $this->name,
+            $this->args,
+            compose($function, $this->next)
+        );
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function patternMatched(callable $fn)
+    {
+        return $fn($this->name, $this->args, $this->next);
+    }
+}
+
+class Union_ implements UnionF
+{
+    private $a;
+    private $name;
+    private $args;
+    private $next;
+
+    public function __construct($a, $name, array $args, callable $next)
+    {
+        $this->a = $a;
+        $this->name = $name;
+        $this->args = $args;
+        $this->next = $next;
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function map(callable $function): Functor
+    {
+        return new self(
+            $this->a,
+            $this->name,
+            $this->args,
+            compose($function, $this->next)
+        );
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function patternMatched(callable $fn)
+    {
+        return $fn($this->a, $this->name, $this->args, $this->next);
+    }
+}
+
+
+class Derived_ implements UnionF
+{
+    private $a;
+    private $interfaces;
+    private $next;
+
+    public function __construct($a, array $interfaces, callable $next)
+    {
+        $this->a = $a;
+        $this->interfaces = $interfaces;
+        $this->next = $next;
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function map(callable $function): Functor
+    {
+        return new self(
+            $this->a,
+            $this->interfaces,
+            compose($function, $this->next)
+        );
+    }
+
+    /**
+     * @inheritdoc
+     */
+    public function patternMatched(callable $fn)
+    {
+        return $fn($this->a, $this->interfaces, $this->next);
+    }
+}
+
+function data_(string $name, array $args): MonadFree {
+    return liftF(new Declare_($name, $args, Pure::of));
+}
+
+function declaree(MonadFree $data, Listt $mx): MonadFree {
+    return reduce(function (MonadFree $m, callable $next) {
+        return $m->bind($next);
+    }, $data, $mx);
+}
+
+function declareType(string $name, array $args, callable $first, callable ...$rest)
+{
+    $mx = fromIterable($rest);
+    $mx = prepend($first, $mx);
+
+    return declaree(data_($name, $args), $mx);
+
+}
+
+function type(string $name, array $args = [], $a = null)
+{
+    return curryN(3, function (string $name, array $args, $a): MonadFree {
+        return liftF(new Union_($a, $name, $args, Pure::of));
+    })(...func_get_args());
+}
+
+function derived(array $interface = [], $a = null)
+{
+    return curryN(2, function (array $interface, $a): MonadFree {
+        return liftF(new Derived_($a, $interface, Pure::of));
+    })(...func_get_args());
+}
+
+class GeneratorLazy
+{
+    public $declaration = [];
+
+    public function generate(): string
+    {
+        $r = $this->generateInterface($this->declaration['interface'], $this->declaration['extends']);
+        foreach ($this->declaration['classes'] as $c) {
+            $r = $r->concat(
+                $this->generateClass($c['name'], $c['args'], $this->declaration['interface'])
+            );
+        }
+
+        return $r->extract();
+    }
+
+    public function generateInterface($name, array $extends): Stringg
+    {
+        if (!count($extends)) {
+            return Stringg::of(sprintf(
+                "interface %s {}\n",
+                $name
+            ));
+        }
+
+        return Stringg::of(sprintf(
+            "interface %s extends %s {}\n",
+            $name,
+            join(', ', $extends)
+        ));
+    }
+
+    public function generateClass($name, array $args, $interface): Stringg
+    {
+        $args = array_map(function ($name) {
+            return is_array($name) ? $name[0] : $name;
+        }, $args);
+        $privates = array_reduce($args, function ($body, $name) {
+            return $body . "private \$$name;\n";
+        }, '');
+
+        $set = array_reduce($args, function ($body, $name) {
+            return $body . "\$this->$name = \$$name;\n";
+        }, '');
+
+        $const = array_reduce($args, function ($body, $name) {
+            return $body . "\$$name,";
+        }, '');
+        $const = trim($const, ', ');
+
+        $pattern = array_reduce($args, function ($body, $name) {
+            return $body . "\$this->$name, ";
+        }, '');
+        $pattern = trim($pattern, ', ');
+
+        $constructorWithProps = '%s
+    public function __construct(%s) {
+        %s 
+    }';
+        $constructorWithProps = sprintf($constructorWithProps, $privates, $const, $set);
+
+        $constructorWithProps = count($args) ? $constructorWithProps : '';
+
+
+        return Stringg::of(sprintf(
+            "class %s implements %s {
+    %s
+    public function patternMatched(callable \$fn) {
+        return \$fn(%s);
+    }
+}\n",
+            $name,
+            $interface,
+            $constructorWithProps,
+            $pattern
+        ));
+    }
+
+    public function __toString()
+    {
+        return $this->generate();
+    }
+}
+
+const interpretTypesAndGenerate = 'example\interpretTypesAndGenerate';
+
+/**
+ * @param UnionF $f
+ * @return Identity
+ * @throws \Widmogrod\Useful\PatternNotMatchedError
+ */
+function interpretTypesAndGenerate(UnionF $f): Identity {
+    return match([
+        Declare_::class => function (string $name, array $args, callable $next): Identity {
+            $a = new GeneratorLazy();
+            $a->declaration = [
+                'interface' => $name,
+                'extends' => [],
+                'classes' => []
+            ];
+
+            return Identity::of($a)->map($next);
+        },
+        Union_::class => function (GeneratorLazy $a, string $name, array $args, callable $next): Identity {
+            $a->declaration['classes'][] = ['name' => $name, 'args' => $args];
+
+            return Identity::of($a)->map($next);
+        },
+        Derived_::class => function (GeneratorLazy $a, array $interfaces, callable $next): Identity {
+            $a->declaration['extends'] = $interfaces;
+
+            return Identity::of($a)->map($next);
+        }
+    ], $f);
+};
+
+class FreeUnionTypeGeneratorTest extends \PHPUnit\Framework\TestCase
+{
+    public function test_example_1()
+    {
+        // $interpret :: UnionF -> Identity Free a
+        $interpret = function (UnionF $f): Identity {
+            return match([
+                Declare_::class => function (string $name, array $args, callable $next): Identity {
+                    return Identity::of([
+                        'interface' => $name,
+                        'extends' => [],
+                        'classes' => []
+                    ])
+                        ->map($next);
+                },
+                Union_::class => function ($a, string $name, array $args, callable $next): Identity {
+                    $a['classes'][] = ['name' => $name, 'args' => $args];
+
+                    return Identity::of($a)->map($next);
+                },
+                Derived_::class => function ($a, array $interfaces, callable $next): Identity {
+                    $a['extends'] = $interfaces;
+
+                    return Identity::of($a)->map($next);
+                }
+            ], $f);
+        };
+
+        $declaration = declareType(
+            'Maybe',
+            ['a'],
+            type('Just', ['a']),
+            type('Nothing', []),
+            derived(['\Widmogrod\Useful\PatternMatcher'])
+        );
+
+        $expected = [
+            'interface' => 'Maybe',
+            'extends' => ['\Widmogrod\Useful\PatternMatcher'],
+            'classes' => [
+                ['name' => 'Just', 'args' => ['a']],
+                ['name' => 'Nothing', 'args' => []],
+            ],
+        ];
+
+        $result = foldFree($interpret, $declaration, Identity::of);
+        $this->assertEquals(Identity::of($expected), $result);
+    }
+
+    public function test_example_2()
+    {
+        $declaration = declareType(
+            'Maybe',
+            ['a'],
+            type('Just', ['a']),
+            type('Nothing', []),
+            derived(['\Widmogrod\Useful\PatternMatcher'])
+        );
+
+        $expected = 'interface Maybe extends \Widmogrod\Useful\PatternMatcher {}
+class Just implements Maybe {
+    private $a;
+
+    public function __construct($a) {
+        $this->a = $a;
+ 
+    }
+    public function patternMatched(callable $fn) {
+        return $fn($this->a);
+    }
+}
+class Nothing implements Maybe {
+    
+    public function patternMatched(callable $fn) {
+        return $fn();
+    }
+}
+';
+
+        $result = foldFree(interpretTypesAndGenerate, $declaration, Identity::of);
+        $this->assertEquals($expected, $result->extract()->generate());
+    }
+}

diff --git a/example/ParserTest.php b/example/ParserTest.php
index 8185e21..ad262a5 100644 (file)
--- a/example/ParserTest.php
+++ b/example/ParserTest.php
@@ -31,6 +31,7 @@ use function Widmogrod\Monad\Maybe\nothing;
 
 // Some dependencies are needed
 require_once __DIR__ . '/FreeCalculatorTest.php';
+require_once __DIR__ . '/FreeUnionTypeGeneratorTest.php';
 
 
 /**
@@ -453,7 +454,7 @@ class ParserTest extends \PHPUnit\Framework\TestCase
      * word   = char word
      * args   = word | word args
      */
-    public function test_generate_union_type()
+    public function test_generate_data_types_as_array()
     {
         // lexeme :: ([a] -> Maybe (a, [a])) -> [a] -> Maybe (a, [a])
         $lexeme = function (callable $fn, Listt $a = null) {
@@ -628,4 +629,171 @@ class ParserTest extends \PHPUnit\Framework\TestCase
             $ast
         );
     }
+
+    public function test_generate_data_types_as_free_string()
+    {
+        // lexeme :: ([a] -> Maybe (a, [a])) -> [a] -> Maybe (a, [a])
+        $lexeme = function (callable $fn, Listt $a = null) {
+            return curryN(2, function (callable $fn, Listt $a) {
+                // TODO Not optimal, for test only
+                $trimNil = dropWhile(function (Stringg $s) {
+                    return trim($s->extract()) === "";
+                }, $a);
+
+                return $fn($trimNil);
+            })(...func_get_args());
+        };
+
+        // lexeme :: ([a] -> Maybe (a, [a])) -> [a] -> Maybe (a, [a])
+        $lexeme2 = function (callable $fn, Listt $a = null) {
+            return curryN(2, function (callable $fn, Listt $a) {
+                $trimNil = dropWhile(function (Stringg $s) {
+                    return trim($s->extract(), " ") === "";
+                }, $a);
+
+                return $fn($trimNil);
+            })(...func_get_args());
+        };
+
+        // lexeme :: ([a] -> Maybe (a, [a])) -> [a] -> Maybe (a, [a])
+        $lexemeOr = function (callable $fn, Listt $a = null) {
+            return curryN(2, function (callable $fn, Listt $a) {
+                $trimNil = dropWhile(function (Stringg $s) {
+                    return trim($s->extract(), " \0\n\t\r|") === "";
+                }, $a);
+
+                return $fn($trimNil);
+            })(...func_get_args());
+        };
+
+        $reserved = function (string $name) {
+            return matchP(function (Stringg $s, Stringg $matched) use ($name) {
+                $c = concatM($matched, $s);
+                $e = Stringg::of($name);
+                if (equal($c, $e)) {
+                    return true;
+                }
+
+                // TODO not optimal :/
+                return preg_match(sprintf('/^%s(.+)/', preg_quote($c->extract())), $e->extract());
+            });
+        };
+
+        $or = $lexeme(charP('|'));
+        $eql = $lexeme(charP('='));
+        $parOp = $lexeme(charP('('));
+        $parCl = $lexeme(charP(')'));
+
+        $upperCaseWord = $lexeme(matchP(function (Stringg $s, Stringg $matched) {
+            return equal($matched, emptyM($matched))
+                ? preg_match('/[A-Z]/', $s->extract())
+                : preg_match('/[a-z]/i', $s->extract());
+        }));
+        $lowerCaseWord = $lexeme2(matchP(function (Stringg $s, Stringg $matched) {
+            return strlen($matched->extract())
+                ? false
+                : preg_match('/[a-z]/', $s->extract());
+        }));
+        $reservedData = $lexeme($reserved('data'));
+        $reservedDeriving = $lexeme($reserved('deriving'));
+
+        $classDerivde = manyP(fromIterable([
+            $upperCaseWord
+        ]), function (Listt $a) {
+            return derived($a->extract());
+        });
+
+        $dataDeriving = allOfP(fromIterable([
+            $reservedDeriving, $parOp, $classDerivde, $parCl,
+        ]), function (Listt $l) {
+            return $l->extract()[2];
+        });
+
+        $grouping = allOfP(fromIterable([
+            $parOp, &$typeName, $parCl,
+        ]), function (Listt $attr) {
+            return $attr->extract()[1];
+        });
+
+        $args = $lexeme2(manyP(fromIterable([
+            oneofP(fromIterable([$lowerCaseWord, $grouping])),
+        ]), function (Listt $attr) {
+            return $attr->extract();
+        }));
+
+        $typeNameWithoutArgs = $lexeme(allOfP(fromIterable([
+            $upperCaseWord
+        ]), function (Listt $a) {
+            list($name) = $a->extract();
+
+            return [$name, []];
+        }));
+
+        $typeNameWithArgs = $lexeme(allOfP(fromIterable([
+            $upperCaseWord, $args
+        ]), function (Listt $a) {
+            list($name, $args) = $a->extract();
+
+            return [$name, $args];
+        }));
+
+        $typeName = $lexemeOr(oneOfP(fromIterable([
+            $typeNameWithArgs,
+            $typeNameWithoutArgs
+        ])));
+
+        $representations = manyP(fromIterable([
+            $typeName,
+        ]), function (Listt $a): Listt {
+            return $a;
+        });
+
+        $declaration = allOfP(fromIterable([
+            $reservedData, $typeName, $eql, $representations,
+        ]), function (Listt $a) {
+            list(, list($tname, $targ), , $rep) = $a->extract();
+
+            return declaree(data_($tname, $targ), fromIterable($rep)->map(function($t) {
+                list($tname, $targ) = $t;
+                return type($tname, $targ);
+            }));
+        });
+
+        $declarationDerived = endByP($declaration, $dataDeriving, function (Listt $a) {
+            [$declaration, $derived] = $a->extract();
+
+            return declaree($declaration, fromValue($derived));
+        });
+
+        $tokens = tokens('
+        data A = B deriving (Show)
+        data Maybe a = Just a | Nothing
+        data Either a b = Left a | Right b
+        data Free f a = Pure a | Free f (Free f a)
+        ');
+
+        $expression = manyP(fromIterable([
+            $declarationDerived,
+            $declaration,
+        ]), function (Listt $a) {
+            return $a->extract();
+        });
+
+        $result = $expression($tokens);
+        $ast = $result->extract()[0][0];
+
+        $expected = 'interface A extends Show {}
+class B implements A {
+    
+    public function patternMatched(callable $fn) {
+        return $fn();
+    }
+}
+';
+
+        $result = foldFree(interpretTypesAndGenerate, $ast, Identity::of);
+        $generated = $result->extract()->generate();
+        $this->assertEquals($expected, $generated);
+
+    }
 }