Skip to content

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Arrows and Kleislies
#include <memory>
#include <iostream>
#include <sstream>
#include <utility>
#include <algorithm>
#include <iterator>
/* MakeT T : X -> T X */
template< template<class...> class T > struct MakeT {
template< class ...X, class R = T< typename std::decay<X>::type... > >
constexpr R operator () ( X&& ...x ) {
return R( std::forward<X>(x)... );
}
};
/* pair : X x Y -> (X,Y) */
constexpr auto pair = MakeT<std::pair>();
struct sequence_tag {};
struct pointer_tag {};
template< class X >
X category( ... );
template< class S >
auto category( const S& s ) -> decltype( std::begin(s), sequence_tag() );
template< class T > struct Category {
using type = decltype( category<T>(std::declval<T>()) );
};
template< class R, class ... X > struct Category< R(&)(X...) > {
using type = R(&)(X...);
};
template< class R, class ... X > struct Category< R(*)(X...) > {
using type = R(&)(X...);
};
template< class T >
using Cat = typename Category< typename std::decay<T>::type >::type;
/* closet : (A -> ... -> C) x A -> (... -> C) */
template< class F, class X >
struct Part {
F f = F();
X x;
template< class _F, class _X >
constexpr Part( _F&& f, _X&& x )
: f(std::forward<_F>(f)), x(std::forward<_X>(x))
{
}
template< class _X >
constexpr Part( _X&& x ) : x( std::forward<_X>(x) ) { }
template< class ... Xs >
constexpr auto operator () ( Xs&& ...xs )
-> decltype( f(x,std::declval<Xs>()...) )
{
return f( x, std::forward<Xs>(xs)... );
}
};
template< class F, class X > struct RPart {
F f = F();
X x;
template< class _F, class _X >
constexpr RPart( _F&& f, _X&& x )
: f( std::forward<_F>(f) ), x( std::forward<_X>(x) ) { }
template< class _X >
constexpr RPart( _X&& x ) : x( std::forward<_X>(x) ) { }
template< class ...Y >
constexpr decltype( f(std::declval<Y>()..., x) )
operator() ( Y&& ...y ) {
return f( std::forward<Y>(y)..., x );
}
};
constexpr auto closet = MakeT<Part>();
constexpr auto rcloset = MakeT<RPart>();
/* compose : (B -> C) x (A -> B) -> (A -> C) */
template< class F, class G >
struct Composition
{
F f; G g;
template< class _F, class _G >
constexpr Composition( _F&& f, _G&& g )
: f(std::forward<_F>(f)), g(std::forward<_G>(g)) { }
template< class X >
constexpr auto operator() ( X&& x)
-> decltype( f(g(std::declval<X>())) )
{
return f( g( std::forward<X>(x) ) );
}
};
constexpr auto compose = MakeT<Composition>();
template< class ... > struct Monad;
/* mbind : (A -> M<B>) x M<A> -> M<B> */
template< class F, class M, class ...N, class Mo=Monad<Cat<M>> >
constexpr auto mbind( F&& f, M&& m, N&& ...n )
-> decltype( Mo::mbind(std::declval<F>(),
std::declval<M>(),std::declval<N>()...) )
{
return Mo::mbind( std::forward<F>(f),
std::forward<M>(m), std::forward<N>(n)... );
}
/* mdo : M<A> x M<B> -> M<B> */
template< class F, class M, class ...N, class Mo=Monad<Cat<M>> >
constexpr auto mdo( F&& f, M&& m )
-> decltype( Mo::mdo(std::declval<F>(), std::declval<M>()) )
{
return Mo::mdo( std::forward<F>(f), std::forward<M>(m) );
}
// The first template argument must be explicit!
/* mreturn M : X -> M<X> */
template< class M, class X, class ...Y, class Mo = Monad<Cat<M>> >
constexpr auto mreturn( X&& x, Y&& ...y )
-> decltype( Mo::template mreturn<M>( std::declval<X>(),
std::declval<Y>()... ) )
{
return Mo::template mreturn<M>( std::forward<X>(x),
std::forward<Y>(y)... );
}
template< template<class...>class M, class X, class ...Y,
class _M = M< typename std::decay<X>::type >,
class Mo = Monad<Cat<_M>> >
constexpr auto mreturn( X&& x, Y&& ...y )
-> decltype( Mo::template mreturn<_M>( std::declval<X>(),
std::declval<Y>()... ) )
{
return Mo::template mreturn<_M>( std::forward<X>(x),
std::forward<Y>(y)... );
}
// Also has explicit template argument.
template< class M, class Mo = Monad<Cat<M>> >
auto mfail() -> decltype( Mo::template mfail<M>() ) {
return Mo::template mfail<M>();
}
template< class M, class F >
constexpr auto operator >>= ( M&& m, F&& f )
-> decltype( mbind(std::declval<F>(),std::declval<M>()) )
{
return mbind( std::forward<F>(f), std::forward<M>(m) );
}
template< class M, class F >
constexpr auto operator >> ( M&& m, F&& f )
-> decltype( mdo(std::declval<M>(),std::declval<F>()) )
{
return mdo( std::forward<M>(m), std::forward<F>(f) );
}
template< class F, class M >
constexpr auto operator ^ ( F&& f, M&& m )
-> decltype( fmap(std::declval<F>(),std::declval<M>()) )
{
return fmap( std::forward<F>(f), std::forward<M>(m) );
}
template< class... > struct Rebind;
template< template<class...> class S, class X >
struct Rebind<S<X>> {
template< class Y > using rebind = S<Y>;
};
template< class S, class X >
using rebind = typename Rebind<S>::template rebind<X>;
template< > struct Monad< sequence_tag > {
template< class S >
using mvalue = typename S::value_type;
template< class F, template<class...>class S, class X,
class R = typename std::result_of<F(X)>::type >
static R mbind( F&& f, const S<X>& xs ) {
R r;
for( const X& x : xs ) {
auto ys = std::forward<F>(f)( x );
std::move( std::begin(ys), std::end(ys), std::back_inserter(r) );
}
return r;
}
template< class F, template<class...>class S,
class X, class Y,
class R = typename std::result_of<F(X,Y)>::type >
static R mbind( F&& f, const S<X>& xs, const S<Y>& ys ) {
R r;
for( const X& x : xs ) {
for( const Y& y : ys ) {
auto zs = std::forward<F>(f)( x, y );
std::move( std::begin(zs), std::end(zs),
std::back_inserter(r) );
}
}
return r;
}
template< template< class... > class S, class X, class Y >
static S<Y> mdo( const S<X>& mx, const S<Y>& my ) {
// Note: This is not a strictly correct definition.
// It should return my concatenated to itself for every element of mx.
return mx.size() ? my : S<Y>{};
}
template< class S, class X >
static rebind<S,X> mreturn( X&& x ) {
return { std::forward<X>(x) }; // Construct an S of one element.
}
template< class S >
static S mfail() { return S{}; }
};
template< > struct Monad< pointer_tag > {
template< class P >
using mvalue = typename P::element_type;
template< class F, template<class...>class Ptr, class X,
class R = typename std::result_of<F(X)>::type >
static R mbind( F&& f, const Ptr<X>& p ) {
return p ? std::forward<F>(f)( *p ) : nullptr;
}
template< class F, template<class...>class Ptr,
class X, class Y,
class R = typename std::result_of<F(X,Y)>::type >
static R mbind( F&& f, const Ptr<X>& p, const Ptr<Y>& q ) {
return p and q ? std::forward<F>(f)( *p, *q ) : nullptr;
}
template< template< class... > class M, class X, class Y >
static M<Y> mdo( const M<X>& mx, const M<Y>& my ) {
return mx ? (my ? mreturn<M<Y>>(*my) : nullptr)
: nullptr;
}
template< class M, class X >
static M mreturn( X&& x ) {
using Y = typename M::element_type;
return M( new Y(std::forward<X>(x)) );
}
template< class M >
static M mfail() { return nullptr; }
};
constexpr bool is_int( char c ) {
return c >= '0' and c <= '9';
}
template< class ... > struct MonadZero;
template< class ... > struct MonadPlus;
/* mzero M : () -> M */
template< class M, class Mo = MonadZero< Cat<M> > >
auto mzero() -> decltype( Mo::template mzero<M>() )
{
return Mo::template mzero<M>();
}
/* mplus : M<A> x M<A> -> M<A> */
template< class A, class B, class Mo = MonadPlus<Cat<A>> >
auto mplus( A&& a, B&& b ) -> decltype( Mo::mplus(std::declval<A>(),std::declval<B>()) )
{
return Mo::mplus( std::forward<A>(a), std::forward<B>(b) );
}
template<> struct MonadZero< sequence_tag > {
template< class S >
S mzero() { return S{}; }
};
template< class X, class Y >
auto operator + ( X&& x, Y&& y ) -> decltype( mplus(std::declval<X>(),std::declval<Y>()) )
{
return mplus( std::forward<X>(x), std::forward<Y>(y) );
}
/* mplus( xs, ys ) = "append xs with ys" */
template<> struct MonadPlus< sequence_tag > {
template< class A, class B >
static A mplus( A a, const B& b ) {
std::copy( b.begin(), b.end(), std::back_inserter(a) );
return a;
}
};
/* id : X -> X */
constexpr struct Id {
template< class X >
constexpr X operator () ( X&& x ) {
return std::forward<X>(x);
}
} id{};
template< class ... > struct Arrow;
/* arr : (A -> B) -> Arrow A B */
template< class A, class F, class Arr = Arrow< Cat<A> > >
constexpr auto arr( F&& f ) -> decltype( Arr::arr( std::declval<F>() ) )
{
return Arr::arr( std::forward<F>(f) );
}
template< class A > struct Arr {
template< class F >
constexpr auto operator () ( F&& f ) -> decltype( arr(std::declval<F>()) )
{
return arr( std::forward<F>(f) );
}
};
/* split : (A -> B) x (X -> Y) -> (pair<A,X> -> pair<B,Y>) */
constexpr struct Split {
template< class F, class G, class A = Arrow<Cat<F>> >
constexpr auto operator () ( F&& f, G&& g )
-> decltype( A::split(std::declval<F>(), std::declval<G>()) )
{
return A::split( std::forward<F>(f), std::forward<G>(g) );
}
} split{};
/* fan : (A -> B) x (A -> C) -> (A -> pair<B,C>) */
constexpr struct Fan {
template< class F, class G, class A = Arrow<Cat<F>> >
constexpr auto operator () ( F&& f, G&& g )
-> decltype( A::fan(std::declval<F>(),std::declval<G>()) )
{
return A::fan( std::forward<F>(f), std::forward<G>(g) );
}
} fan{};
/* first : (A -> B) -> (pair<A,X> -> pair<B,X>) */
constexpr struct First {
template< class F, class A = Arrow<Cat<F>> >
constexpr auto operator () ( F&& f )
-> decltype( A::first(std::declval<F>()) )
{
return A::first( std::forward<F>(f) );
}
} first{};
/* first : (A -> B) -> (pair<X,A> -> pair<X,B>) */
constexpr struct Second {
template< class F, class A = Arrow<Cat<F>> >
constexpr auto operator () ( F&& f ) -> decltype( A::second(std::declval<F>()) ) {
return A::second( std::forward<F>(f) );
}
} second{};
/* duplicate : X -> (X,X) */
constexpr struct Duplicate {
template< class X, class P = std::pair<X,X> >
constexpr P operator() ( const X& x ) {
return P( x, x );
}
} duplicate{};
template< class Binary > struct Uncurrier {
Binary b;
template< class P >
constexpr auto operator () ( P&& p )
-> decltype( b( std::get<0>(std::declval<P>()), std::get<1>(std::declval<P>()) ) )
{
return b( std::get<0>(std::forward<P>(p)), std::get<1>(std::forward<P>(p)) );
}
};
constexpr auto uncurry = MakeT<Uncurrier>();
/* pairCompose : (A -> B) x (X -> Y) -> (pair<A,X> -> pair<B,Y>) */
template< class F, class G > struct PairComposition {
F f; G g;
template< class _F, class _G >
constexpr PairComposition( _F&& f, _G&& g )
: f(std::forward<_F>(f)), g(std::forward<_G>(g))
{
}
template< class P/*air*/ >
constexpr auto operator() ( const P& p )
-> decltype( std::make_pair( f(std::get<0>(p)), g(std::get<1>(p)) ) )
{
return std::make_pair( f(std::get<0>(p)), g(std::get<1>(p)) );
}
};
constexpr auto pairCompose = MakeT<PairComposition>();
template< class Func > struct Arrow<Func> {
template< class F >
static constexpr F arr( F&& f ) { return std::forward<F>(f); }
/* split(f,g)(x,y) = { f(x), g(y) } */
template< class F, class G >
static constexpr auto split( F f, G g )
-> PairComposition<F,G>
{
return pairCompose( std::move(f), std::move(g) );
}
/*
* first(f)(x,y) = { f(x), y }
* second(f)(x,y) = { x, f(y) }
*/
template< class F >
static constexpr auto first( F f )
-> decltype( split(std::move(f),id) )
{
return split( std::move(f), id );
}
template< class F >
static constexpr auto second( F f )
-> decltype( split(id,std::move(f)) )
{
return split( id, std::move(f) );
}
/* fan(f,g)(x) = { f(x), g(x) } */
template< class F, class G >
static constexpr auto fan( F f, G g )
-> decltype( compose( split(std::move(f),std::move(g)), duplicate ) )
{
return compose( split(std::move(f),std::move(g)), duplicate );
}
};
/* Forwarder F : F */
template< class F > struct Forwarder {
using function = typename std::decay<F>::type;
function f = F();
template< class ...G >
constexpr Forwarder( G&& ...g ) : f( std::forward<G>(g)... ) { }
template< class ...X >
constexpr auto operator() ( X&& ...x )
-> decltype( f(std::declval<X>()...) )
{
return f( std::forward<X>(x)... );
}
constexpr operator function () { return f; }
};
/* Kleisli M F : F -- where F : A -> M<B> */
template< template<class...> class M, class F = Id >
struct Kleisli : Forwarder<F> {
template< class ...G >
constexpr Kleisli( G&& ...g ) : Forwarder<F>(std::forward<G>(g)...) { }
};
template< template<class...> class M, class F,
class K = Kleisli<M,F> >
constexpr K kleisli( F f ) {
return K( std::move(f) );
}
/* Composition : Kleisli(B -> M<C>) x Kleisli(A -> M<B>) -> (A -> M<C>) */
template< template<class...> class M, class F, class G >
struct Composition<Kleisli<M,F>,Kleisli<M,G>>
{
Kleisli<M,F> f;
Kleisli<M,G> g;
template< class _F, class _G >
constexpr Composition( _F&& f, _G&& g )
: f(std::forward<_F>(f)), g(std::forward<_G>(g)) { }
template< class X >
constexpr auto operator() ( X&& x )
-> decltype( g(std::forward<X>(x)) >>= f )
{
return g(std::forward<X>(x)) >>= f;
}
};
/* Composition : Kleisli(B -> M<C>) x Kleisli(A -> M<B>) -> Kleisli(A -> M<C>) */
constexpr struct KCompose {
template< template<class...> class M, class F, class G >
constexpr auto operator () ( Kleisli<M,F> f, Kleisli<M,G> g )
-> Kleisli< M, Composition<Kleisli<M,F>,Kleisli<M,G>> >
{
return kleisli<M> (
compose( std::move(f), std::move(g) )
);
}
} kcompose{};
template< class M > struct Return {
template< class X >
constexpr auto operator () ( X&& x )
-> decltype( mreturn<M>(std::declval<X>()) )
{
return mreturn<M>( std::forward<X>(x) );
}
};
/*
* liftM : (A -> B) x M<A> -> M<B>
* liftM : (A x B -> C) x M<A> x M<B> -> M<C>
*/
constexpr struct LiftM {
template< class F, class M, class R = Return<typename std::decay<M>::type> >
constexpr auto operator () ( F&& f, M&& m )
-> decltype( std::declval<M>() >>= compose(R(),std::declval<F>()) )
{
return std::forward<M>(m) >>= compose( R(), std::forward<F>(f) );
}
template< class F, class A, class B >
constexpr auto operator () ( F&& f, A&& a, B&& b )
-> decltype( std::declval<A>() >>= compose (
rcloset( LiftM(), std::declval<B>() ),
closet(closet,std::declval<F>())
) )
{
return std::forward<A>(a) >>= compose (
rcloset( LiftM(), std::forward<B>(b) ),
closet(closet,std::forward<F>(f))
);
}
} liftM{};
/* kleisliSplit : Kleisli(A -> M<B>) x Kleisli(X -> M<Y>) -> (piar<A,X> -> M<pair<B,Y>>) */
template< template<class...> class M, class F, class G >
struct KleisliSplit {
F f;
G g;
constexpr KleisliSplit( F f, G g ) : f(std::move(f)), g(std::move(g)) { }
template< class X, class Y >
constexpr auto operator () ( const std::pair<X,Y>& p )
-> decltype( liftM(pair,f(std::get<0>(p)),g(std::get<1>(p))) )
{
return liftM (
pair,
f( std::get<0>(p) ),
g( std::get<1>(p) )
);
}
};
template< template<class...> class M, class F >
struct Arrow< Kleisli<M,F> > {
template< class G >
using K = Kleisli<M,G>;
template< class G >
static constexpr auto arr( G g ) -> Kleisli< M, Part<LiftM,G> > {
return kleisli<M>( closet(liftM,std::move(g)) );
}
template< class G >
static constexpr auto first( G g )
-> K<decltype( ::split(std::move(g),arr(id)) )>
{
// id is not a Kleisli.
// The call to arr refers to the arr above, not ::arr.
// arr(id) : Kleisli(X -> M X)
return ::split( std::move(g), arr(id) );
}
template< class G >
static constexpr auto second( G g)
-> K<decltype( ::split(arr(id),std::move(g)) )>
{
return ::split( arr(id), std::move(g) );
}
template< class G >
static constexpr auto split( Kleisli<M,F> f, Kleisli<M,G> g )
-> K< KleisliSplit<M,F,G> >
{
return KleisliSplit<M,F,G>( std::move(f.f), std::move(g.f) );
}
template< class G >
static constexpr auto fan( Kleisli<M,F> f, Kleisli<M,G> g )
-> K< decltype( compose(std::declval<KleisliSplit<M,F,G>>(),duplicate) ) >
{
return compose (
KleisliSplit<M,F,G>( std::move(f.f), std::move(g.f) ),
duplicate
);
}
};
static std::ostringstream oss;
template< class X >
static std::string show( const X& x ) {
oss.str( "" );
oss << x;
return oss.str();
}
static std::string show( std::string str ) {
return str;
}
static constexpr const char* show( const char* str ) {
return str;
}
template< class X, class Y, class ...Z >
static std::string show( const X& x, const Y& y, const Z& ...z )
{
return show(x) + show(y,z...);
}
std::ostream& operator << ( std::ostream& os, const std::string& s ) {
return os << '"' << s.c_str() << '"';
}
template< class X, class Y >
std::ostream& operator << ( std::ostream& os, const std::pair<X,Y>& p ) {
return os << '(' << p.first << ',' << p.second << ')';
}
template< class X >
std::ostream& operator << ( std::ostream& os, const std::unique_ptr<X>& p ) {
if( p )
os << "Just " << *p;
else
os << "Nothing";
return os;
}
template< class X >
std::ostream& operator << ( std::ostream& os, const std::vector<X>& v ) {
os << '[';
for( auto it=std::begin(v); it != std::end(v); it++ ) {
os << *it;
if( std::next(it) != std::end(v) )
os << ',';
}
os << ']';
return os;
}
namespace std {
std::string to_string( const std::string& s );
template< class X, class Y >
std::string to_string( const std::pair<X,Y>& p );
std::string to_string( const std::string& s ) {
return "\"" + s + "\"";
}
template< class X, class Y >
std::string to_string( const std::pair<X,Y>& p ) {
return "(" + to_string(p.first) + "," + to_string(p.second) + ")";
}
}
/* string : X -> std::string */
constexpr struct ToString {
template< class X >
std::string operator () ( const X& x ) const {
return std::to_string(x);
}
} string{};
constexpr struct MakeJust {
template< class X, class D = typename std::decay<X>::type,
class P = std::unique_ptr<D> >
P operator () ( X&& x ) {
return P( new D(std::forward<X>(x)) );
}
} Just{};
constexpr auto JustK = kleisli<std::unique_ptr>(Just);
/*
* Get 0 : (X,Y) -> X
* Get 1 : (X,Y) -> Y
*/
template< size_t N > struct Get {
template< class P >
constexpr auto operator () ( P&& p )
-> decltype( std::get<N>(std::declval<P>()) )
{
return std::get<N>( std::forward<P>(p) );
}
};
/* fcomp : (A -> B) x (B -> C) -> (A -> C) */
constexpr struct FComp {
template< class G, class F, class C = Composition<F,G> >
constexpr C operator () ( G g, F f ) {
return C(std::move(f),std::move(g));
}
} fcomp{};
/* prefcomp : (A -> B) x Arrow B C -> Arrow A C */
constexpr struct PreFComp {
template< class F, class A >
constexpr auto operator () ( F&& f, A&& a )
-> decltype( arr<A>(declval<F>()) > declval<A>() )
{
return arr<A>(forward<F>(f)) > forward<A>(a);
}
} prefcomp{};
/* prefcomp : Arrow A B x (B -> C) -> Arrow A C */
constexpr struct PostFComp {
template< class A, class F >
constexpr auto operator () ( A&& a, F&& f )
-> decltype( declval<A>() > arr<A>(declval<F>()) )
{
return forward<A>(a) > arr<A>(forward<F>(f));
}
} postfcomp{};
int main() {
using std::cin;
using std::cout;
using std::endl;
using std::to_string;
auto plus2 = []( int x ){ return x+2; };
std::pair<int,int> p( 1, 1 );
cout << "(+2) *** (+2) >>> string *** (+2) $ (1,1) = "
<< compose( pairCompose(string,plus2), pairCompose(plus2,plus2) )(p) << endl;
cout << "(+2) *** (+2) >>> string *** (+2) $ 1 = "
<< compose( split(string,plus2), fan(plus2,plus2) )(1) << endl;
constexpr auto fst = Get<0>();
constexpr auto snd = Get<1>();
constexpr auto oneHundred = []( int x ){ return 100; };
// Hide the hundred.
auto hidden = fan( fan(id,fan(oneHundred,id)), id )( 0 );
// Function to find it again.
auto find = fcomp( fcomp(fst,snd), fst );
cout << "I found " << find(hidden) << "!" << endl;
auto k1 = kleisli<std::vector> (
[] (int x) -> std::vector<int> { return {x,x+1}; }
);
cout << "let k1 x = [x,x+1]\n";
cout << "k1( k1(1) ) = " << compose(k1,k1)(1) << endl;
auto stars = kleisli<std::vector> (
[] (char c) {
return c == '*' ? std::vector<char>{'+','+'} :
c == '+' ? std::vector<char>{'*',' ','*'} : std::vector<char>{c};
}
);
auto starsSqr = kcompose( stars, stars );
auto starsCube = kcompose( starsSqr, stars );
cout << "stars of '*' : " << stars('*') << endl;
cout << "stars^2 of '*' : " << starsSqr('*') << endl;
cout << "stars^3 of '*' : " << starsCube('*') << endl;
auto hairs = kleisli<std::vector> (
[] (char c) -> std::vector<char> {
return c == '*' ? std::vector<char>{'\'','"','\''} :
c == '+' ? std::vector<char>{'"',' ','"'} :
c == '"' ? std::vector<char>{'\''} :
c == '\'' ? std::vector<char>{} :
std::vector<char>{c};
}
);
cout << "hairs of '*' : " << hairs('*') << endl;
cout << "hairs^2 of '*' : " << compose(hairs,hairs)('*') << endl;
cout << "split(stars,hairs) (*,*) = " << split(stars,hairs)(pair('*','*')) << endl;
cout << "fan(stars,hairs) (*) = " << fan(stars,hairs)('*') << endl;
cout << "fan(hairs,stars) (*) = " << fan(hairs,stars)('*') << endl;
cout << "split(hairs,stars) . fan(stars,hairs) = "
<< compose( split(hairs,stars), fan(stars,hairs) )('*') << endl;
//cout << "'*' => (stars,hairs) -> (hairs,stars) => "
// << kcompose( split(hairs,stars), fan(stars,hairs) )('*') << endl;
cout << to_string(p) << " --- first(string) . second(plus2) ---> "
<< compose( first(string), second(plus2) )( p ) << endl;
cout << to_string(p) << " --- first(string) . second(plus2) ---> "
<< split( string, plus2 )( p ) << endl;
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.