Permalink
Browse files

functor / pointed / applicative / monad + identity / list

  • Loading branch information...
1 parent 9fdab59 commit 5e8d0154424f9715174ea4967eb1458a8cb61df7 @jrockway committed Oct 11, 2010
View
2 .eproject
@@ -1 +1 @@
-:mxdeclare-project-p t
+:mxdeclare-project-p nil
View
96 lib/Data/Function.pm
@@ -0,0 +1,96 @@
+package Data::Function;
+# ABSTRACT: helpful functions for working with functions
+use strict;
+use warnings;
+
+use Sub::Exporter -setup => {
+ exports => [qw/curry lambda flip id const/],
+};
+
+sub curry($$) {
+ my ($code, $val) = @_;
+ return sub {
+ $code->($val, @_);
+ }
+}
+
+sub lambda(&$;@);
+sub lambda(&$;@) {
+ my ($code, $cnt) = @_;
+ return $code->() if $cnt < 1;
+ return sub {
+ my @args = @_;
+ return lambda {
+ $code->(@args, @_);
+ } ($cnt-@args);
+ }
+
+}
+
+
+sub id() {
+ return lambda { my $arg = shift; $arg } 1;
+}
+
+sub flip($) {
+ my $f = shift;
+ return lambda {
+ my ($x, $y) = @_;
+ $f->($y, $x);
+ } 2;
+}
+
+sub const($) {
+ my $const = shift;
+ return lambda { $const } 1;
+}
+
+1;
+
+__END__
+
+=head1 SYNOPSIS
+
+ use Data::Function qw/lambda flip id const/;
+
+ my $f = lambda { $_[0] - $_[1] } 2; # CODE(0x3974383) --> x - y
+ my $g = $f->(42); # CODE(0x1234567) --> 42 - y
+ $g->(1); # 41
+
+ my $fprime = flip $f; # CODE(0x8374388) --> y - x
+ my $gprime = $fprime->(42); # CODE(0x1a423a2) --> y - 42
+ $gprime->(43); # 1
+
+ my $forty_two = const 42; # CODE(0x2938473) --> sub { my $x = shift; 42 }
+ $forty_two->(1234548754); # 42
+
+ my $id = id; # CODE(0x4985744)
+ $id->(123); # 123
+
+
+=head1 DESCRIPTION
+
+This module provides a few utility functions for making functions more
+Haskell-like.
+
+=head1 EXPORTS
+
+You must request each function that you want to use.
+
+=head2 lambda BLOCK SCALAR
+
+Creates an anonymous function from BLOCK. After being applied
+with SCALAR arguments, it will call the BLOCK with all the args.
+
+=head2 flip CODEREF
+
+Converts a 2 arg lambda into a 2 arg lambda that takes its arguments
+in the opposite order.
+
+=head2 id
+
+Returns the identity function.
+
+=head2 const VALUE
+
+Returns a function of one argument that always returns VALUE.
View
28 lib/Data/Functor.pm
@@ -0,0 +1,28 @@
+package Data::Functor;
+# ABSTRACT: tags a data structure as a functor
+use Moose::Role;
+use Data::Monad::Util qw(make_type_checker);
+use namespace::autoclean;
+
+with 'Data::Functor::API';
+
+around fmap => make_type_checker('fmap');
+
+1;
+
+__END__
+
+=head1 DESCRIPTION
+
+Consume this role to allow your data structure to work as a functor.
+A functor is a container type that allows function application to be
+lifted into the container with a function called C<fmap>.
+
+A list is a functor, with C<map> as its C<fmap> operation.
+
+=head1 METHODS
+
+=head2 fmap FUNCTION
+
+Apply the value inside the functor to FUNCTION, returning a new value
+inside the functor.
View
8 lib/Data/Functor/API.pm
@@ -0,0 +1,8 @@
+package Data::Functor::API;
+# ABSTRACT: API role for a functor
+use Moose::Role;
+use namespace::autoclean;
+
+requires 'fmap';
+
+1;
View
20 lib/Data/Functor/Applicative.pm
@@ -0,0 +1,20 @@
+package Data::Functor::Applicative;
+# ABSTRACT: tags a data structure as an applicative functor
+use Data::Monad::Util qw(make_type_checker);
+use Moose::Role;
+use namespace::autoclean;
+
+with 'Data::Functor::Applicative::API', 'Data::Functor', 'Data::Pointed';
+
+around ap => make_type_checker('ap');
+
+1;
+
+__END__
+
+=head1 DESCRIPTION
+
+This is a role that you can consume if your data structure is an
+applicative functor. An applicative functor is a pointed functor with
+the addition of an C<ap> function; function application lifted to your
+functor.
View
10 lib/Data/Functor/Applicative/API.pm
@@ -0,0 +1,10 @@
+package Data::Functor::Applicative::API;
+# ABSTRACT: API for an applicative functor
+use Moose::Role;
+use namespace::autoclean;
+
+with 'Data::Pointed::API', 'Data::Functor::API';
+
+requires 'ap';
+
+1;
View
29 lib/Data/Functor/Applicative/FromMonad.pm
@@ -0,0 +1,29 @@
+package Data::Functor::Applicative::FromMonad;
+# ABSTRACT: make a monad an applicative functor
+use Moose::Role;
+use namespace::autoclean;
+
+with 'Data::Monad';
+
+requires 'bind';
+requires 'pure';
+
+sub ap {
+ my ($self, $other) = @_;
+ return $self->bind(sub {
+ my $f = shift;
+ return $other->bind(sub {
+ my $x = shift;
+ return $self->pure($f->($x));
+ });
+ });
+}
+
+1;
+
+__END__
+
+=head1 DESCRIPTION
+
+Consume this role to make a L<Data::Monad|Data::Monad> monad into an
+applicative functor. It uses C<pure> and C<bind> to create C<ap>.
View
33 lib/Data/Identity.pm
@@ -0,0 +1,33 @@
+package Data::Identity;
+# ABSTRACT: the identity monad
+use Moose;
+use namespace::autoclean;
+
+with 'Data::Monad::Cat', 'Data::Functor::Applicative::FromMonad';
+
+has 'it' => ( is => 'ro', isa => 'Any', required => 1 );
+
+sub pure {
+ my ($class, $it) = @_;
+ $class = $class->meta->name if blessed $class;
+ return $class->new( it => $it );
+}
+
+sub fmap {
+ my ($self, $f) = @_;
+ return $self->pure($f->($self->it));
+}
+
+sub join {
+ my ($self) = @_;
+ return $self->it;
+}
+
+1;
+
+__END__
+
+=head1 DESCRIPTION
+
+This is an example monad / functor / applicative functor. It does
+nothing.
View
49 lib/Data/List.pm
@@ -0,0 +1,49 @@
+package Data::List;
+# ABSTRACT: The Haskell-style List monad
+use Moose;
+use namespace::autoclean;
+
+with 'Data::Monad::Cat', 'Data::Functor::Applicative::FromMonad';
+
+has 'list' => (
+ is => 'ro',
+ isa => 'ArrayRef',
+ required => 1,
+);
+
+sub pure {
+ my ($class, $value) = @_;
+ $class = $class->meta->name if blessed $class;
+ return $class->new( list => [$value] );
+}
+
+sub fmap {
+ my ($self, $f) = @_;
+ return $self->meta->name->new(
+ list => [ map { $f->($_) } @{$self->list} ],
+ );
+}
+
+sub join {
+ my ($self) = @_;
+ return $self->meta->name->new(
+ list => [ map { @{$_->list} } @{$self->list} ],
+ );
+}
+
+1;
+
+__END__
+
+=head1 DESCRIPTION
+
+The List monad represents a computation strategy where each
+computation may return zero or more results.
+
+=head1 SEE ALSO
+
+L<Data::Functor>
+
+L<Data::Functor::Applicative>
+
+L<Data::Monad>
View
41 lib/Data/Monad.pm
@@ -0,0 +1,41 @@
+package Data::Monad;
+# ABSTRACT: tags a data structure as a monad
+use Data::Monad::Util qw(make_type_checker);
+use Moose::Util qw(does_role);
+use Moose::Role;
+use namespace::autoclean;
+
+with 'Data::Monad::API', 'Data::Functor::Applicative';
+
+around join => make_type_checker('join');
+around bind => make_type_checker('bind');
+
+1;
+
+__END__
+
+=head1 DESCRIPTION
+
+Consume this role if your type can act as a monad.
+
+=head1 METHODS
+
+=head2 pure VALUE
+
+Lift a value into the monad
+
+=head2 fmap FUNCTION
+
+Apply a function inside the monad
+
+=head2 join
+
+Remove one level of nesting
+
+=head2 bind FUNCTION
+
+Apply the value inside the monad to FUNCTION, returning a monad.
+
+=head2 ap
+
+Lifted function application
View
11 lib/Data/Monad/API.pm
@@ -0,0 +1,11 @@
+package Data::Monad::API;
+# ABSTRACT: API role for a monad
+use Moose::Role;
+use namespace::autoclean;
+
+with 'Data::Functor::Applicative::API';
+
+requires 'join';
+requires 'bind';
+
+1;
View
26 lib/Data/Monad/Cat.pm
@@ -0,0 +1,26 @@
+package Data::Monad::Cat;
+# ABSTRACT: make a Data::Monad from a pure/fmap/join triple
+use Moose::Role;
+use namespace::autoclean;
+
+with 'Data::Monad';
+
+requires 'pure';
+requires 'fmap';
+requires 'join';
+
+sub bind {
+ my ($k, $f) = @_;
+ return $k->fmap($f)->join;
+}
+
+1;
+
+__END__
+
+=head1 DESCRIPTION
+
+Consume this role to make C<bind> from C<pure>, C<fmap>, and C<join>.
+
+(The "Cat" in the name means, "make a monad from its I<cat>egory
+theory definition".)
View
32 lib/Data/Monad/Haskell.pm
@@ -0,0 +1,32 @@
+package Data::Monad::Haskell;
+# ABSTRACT: create a Data::Monad monad from return and bind
+use Moose::Role;
+use Data::Function qw(id);
+use namespace::autoclean;
+
+with 'Data::Monad';
+
+requires 'pure';
+requires 'bind';
+
+sub fmap {
+ my ($self, $f) = @_;
+ $self->bind(sub {
+ my $k = shift;
+ return $self->pure($f->($k));
+ });
+}
+
+sub join {
+ my ($self) = @_;
+ $self->bind(id);
+}
+
+1;
+
+__END__
+
+=head1 DESCRIPTION
+
+Build C<fmap> and C<join> from C<pure> (C<return>) and C<bind>. This
+is how Haskell programmers typically define a monad.
View
24 lib/Data/Monad/Util.pm
@@ -0,0 +1,24 @@
+package Data::Monad::Util;
+use strict;
+use warnings;
+use Sub::Exporter -setup => { exports => ['make_type_checker'] };
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+sub make_type_checker {
+ my ($name) = @_;
+ return sub {
+ my ($orig, $self, @args) = @_;
+ my $result = $self->$orig(@args);
+ my $type = blessed $result || '<not even an object>';
+ $self = ref $self ? ref $self : $self;
+ confess "The result of $name ('$result') must be a '$self', ".
+ "but is actually a '$type'"
+ unless blessed $result && $type->isa($self->meta->name);
+
+ return $result;
+ };
+}
+
+1;
View
22 lib/Data/Pointed.pm
@@ -0,0 +1,22 @@
+package Data::Pointed;
+# ABSTRACT: tags a data structure as a pointed
+use Moose::Role;
+use Data::Monad::Util qw(make_type_checker);
+use namespace::autoclean;
+
+with 'Data::Pointed::API';
+
+around 'pure' => make_type_checker('pure');
+
+1;
+
+__END__
+
+=head1 DESCRIPTION
+
+A type that can have a value lifted into it. This is slightly
+different than a functor, since there is no operation to apply
+a function to the value.
+
+Typically, you'll consume both Pointed and Functor and implement
+C<join> or C<ap> to become a Monad or Applicative Functor.
View
9 lib/Data/Pointed/API.pm
@@ -0,0 +1,9 @@
+package Data::Pointed::API;
+# ABSTRACT: API role for a pointed
+
+use Moose::Role;
+use namespace::autoclean;
+
+requires 'pure';
+
+1;
View
15 t/00use.t
@@ -0,0 +1,15 @@
+use strict;
+use warnings;
+use Test::More;
+
+use ok 'Data::Pointed';
+use ok 'Data::Functor';
+use ok 'Data::Functor::Applicative';
+use ok 'Data::Monad';
+
+use ok 'Data::Pointed::API';
+use ok 'Data::Functor::API';
+use ok 'Data::Functor::Applicative::API';
+use ok 'Data::Monad::API';
+
+done_testing;
View
37 t/bad.t
@@ -0,0 +1,37 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+
+{ package Bad;
+ use Moose;
+ with 'Data::Monad';
+
+ sub pure { 'oh noes' };
+ sub fmap { 'oh noes' };
+ sub ap { 'oh noes' };
+ sub join { 'oh noes' };
+ sub bind { 'oh noes' };
+}
+
+throws_ok {
+ Bad->pure(123);
+} qr/the result of pure \('oh noes'\) must be a 'Bad', but is actually a '<not even an object>'/i, 'bad pure threw error';
+
+throws_ok {
+ Bad->new->fmap(sub {})
+} qr/the result of fmap \('oh noes'\) must be a 'Bad', but is actually a '<not even an object>'/i, 'bad fmap threw error';
+
+throws_ok {
+ Bad->new->join
+} qr/the result of join \('oh noes'\) must be a 'Bad', but is actually a '<not even an object>'/i, 'bad join threw error';
+
+throws_ok {
+ Bad->new->bind(sub {})
+} qr/the result of bind \('oh noes'\) must be a 'Bad', but is actually a '<not even an object>'/i, 'bad bind threw error';
+
+throws_ok {
+ Bad->new->ap(Bad->new)
+} qr/the result of ap \('oh noes'\) must be a 'Bad', but is actually a '<not even an object>'/i, 'bad ap threw error';
+
+done_testing;
View
46 t/function.t
@@ -0,0 +1,46 @@
+use strict;
+use warnings;
+use Test::More;
+
+use Data::Function qw/curry lambda id flip const/;
+
+{
+ my $add = sub { $_[0] + $_[1] };
+ my $add1 = curry $add, 1;
+ is $add1->(2), 3, 'currying works';
+
+ my $three = curry $add1, 2;
+ is ref $three, 'CODE', 'is still a coderef';
+ is $three->(), 3, 'currying twice works';
+}
+
+my $nullary = lambda { 42 } 0;
+is $nullary, 42, '0-ary function is a value';
+
+my $add42 = lambda { 42 + $_[0] } 1;
+is ref $add42, 'CODE', '1-ary function is a coderef';
+
+my $fortythree = $add42->(1);
+is $fortythree, 43, 'applying 1 to add42 == 43';
+
+my $f = lambda { $_[0] - $_[1] } 2;
+is ref $f, 'CODE', 'f is code';
+my $g = $f->(42);
+is ref $g, 'CODE', 'g is code';
+my $r = $g->(1);
+is $r, 41, 'and now it is evaulated';
+
+is $g->(42), 0, 'g was reused OK';
+my $g2 = $f->(1);
+is ref $g2, 'CODE', 'f reused into g2';
+is $g2->(42), -41, 'g2 used ok';
+
+is(flip($f)->(42)->(1), -41, 'flip works');
+
+is ref (const 42), 'CODE', 'const returns a coderef';
+is((const 42)->(123), 42, 'const works');
+
+is ref id, 'CODE', 'id returns a coderef';
+is(id->(42), 42, 'id works');
+
+done_testing;
View
60 t/identity.t
@@ -0,0 +1,60 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+
+use Data::Function qw/lambda/;
+use ok 'Data::Identity';
+
+my $id;
+lives_ok {
+ $id = Data::Identity->pure(42);
+} 'did not die';
+ok $id, 'got something';
+isa_ok $id, 'Data::Identity';
+is $id->it, 42, 'got wrapped value';
+
+my $result;
+lives_ok {
+ $result = Data::Identity->pure(42)->fmap(sub { $_[0] - 42 });
+} '(fmap . pure) lives ok';
+
+is $result->it, 0, 'got correct result';
+
+lives_ok {
+ $result = Data::Identity->pure($id);
+} 'id can hold an id';
+
+lives_ok {
+ $result = $result->join;
+} 'result can join';
+
+isa_ok $result, 'Data::Identity';
+
+is $result->it, 42, 'got thing back';
+
+my $new = Data::Identity->pure(42);
+
+throws_ok {
+ $new->bind(sub { $_[0] - 42 });
+} qr/must be a 'Data::Identity'/,
+ 'dies when bound function returns the wrong thing';
+
+lives_ok {
+ $result = $new->bind(sub { Data::Identity->pure($_[0] - 42) });
+} 'bind works';
+
+is $result->it, 0, 'bind works';
+
+lives_ok {
+ $result =
+ Data::Identity->pure(lambda { $_[0] - $_[1] } 2)->ap(
+ Data::Identity->pure(42),
+ )->ap(
+ Data::Identity->pure(1),
+ );
+} '"xpure (-) `ap` pure 42 `ap` pure 1" lives';
+
+is $result->it, 41, 'and is == 41';
+
+done_testing;
View
46 t/list.t
@@ -0,0 +1,46 @@
+use strict;
+use warnings;
+use Test::More;
+
+use Data::Function qw(lambda);
+
+use ok 'Data::List';
+
+is_deeply(
+ Data::List->new( list => [1..10] )->fmap(sub { $_[0] + 1 })->list,
+ [2..11],
+ '(+1) <$> [1..10] works',
+);
+
+is_deeply(
+ Data::List->pure( lambda { $_[0] - $_[1] } 2 )->ap(
+ Data::List->pure(1),
+ )->ap(
+ Data::List->new(list => [1..10]),
+ )->list,
+ [0,-1,-2,-3,-4,-5,-6,-7,-8,-9],
+ 'pure (-) <*> [1] <*> [1..10] works',
+);
+
+is_deeply(
+ Data::List->new( list => [1..3] )->fmap( lambda { $_[0] + $_[1] } 2 )->ap(
+ Data::List->new( list => [10..12] ),
+ )->list,
+ [11, 12, 13, 12, 13, 14, 13, 14, 15],
+ '(+) <$> [1..3] <*> [10..12] works',
+);
+
+is_deeply(
+ Data::List->new( list => [1..3] )->bind( sub {
+ my $x = shift;
+ Data::List->new( list => [4..6] )->bind( sub {
+ my $y = shift;
+ return Data::List->new( list => [$x * $y, $x + $y] );
+ });
+ })->list,
+ [4,5,5,6,6,7,8,6,10,7,12,8,12,7,15,8,18,9],
+ '[1..3] >>= \x -> [4..6] >>= \y -> [x * y, x + y] works',
+);
+
+
+done_testing;

0 comments on commit 5e8d015

Please sign in to comment.