継続？

cps.hs

{-# LANGUAGE RankNTypes, MonadComprehensions, FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

import Control.Applicative
import Data.String

a :: ListC Char
a = "Hello," `appc` " " `appc` "world!"

b :: Maybe' (Char, ListS Char)
b = hdtls "foobar"

-- Cont
newtype Id' a = Id' { runId' :: forall r. (a -> r) -> r }
instance Show a => Show (Id' a) where
	showsPrec n (Id' i) = showParen (n > 10) $ ("Id' " ++) . i (showsPrec 11)
instance Functor Id' where
	fmap f (Id' i) = Id' $ \g -> i $ g . f
instance Applicative Id' where
	pure a = Id' ($ a)
	Id' f <*> Id' i = Id' $ \g -> f (\h -> i (g . h))
instance Monad Id' where
	return = pure
	Id' i >>= f = Id' $ \g -> i (\a -> (runId' (f a)) g)

-- R^R^(1+A) ~= R^(R*R^A) ~= (R^R)^(R^A)
newtype Maybe' a = Maybe' { runMaybe' :: forall r. (a -> r) -> r -> r }
instance Show a => Show (Maybe' a) where
	showsPrec n (Maybe' m) = m
		(\a -> showParen (n > 10) $ ("Just' " ++) . showsPrec 11 a)
		("Nothing'" ++)
instance Functor Maybe' where
	fmap f (Maybe' m) = Maybe' $ \j n -> m (j . f) n
instance Applicative Maybe' where
	pure = just
	Maybe' f <*> Maybe' m = Maybe' $ \j n -> f (\g -> m (j . g) n) n
instance Monad Maybe' where
	return = pure
	Maybe' m >>= f = Maybe' $ \j n -> m (\a -> (runMaybe' (f a)) j n) n
nothing :: Maybe' a
nothing = Maybe' $ \_ n -> n
just :: a -> Maybe' a
just a = Maybe' $ \j _ -> j a

newtype Either' a b = Either' { runEither' :: forall r. (a -> r) -> (b -> r) -> r }
instance (Show a, Show b) => Show (Either' a b) where
	showsPrec n (Either' e) = e
		(\l -> showParen (n > 10) $ ("Left' "  ++) . showsPrec 11 l)
		(\r -> showParen (n > 10) $ ("Right' " ++) . showsPrec 11 r)
instance Functor (Either' e) where
	fmap f (Either' e) = Either' $ \l r -> e l (r . f)
instance Applicative (Either' e) where
	pure = right
	Either' f <*> Either' e = Either' $ \l r -> f l (\g -> e l (r . g))
instance Monad (Either' e) where
	return = pure
	Either' e >>= f = Either' $ \l r -> e l (\a -> (runEither' (f a)) l r)
left :: a -> Either' a b
left a = Either' $ \f _ -> f a
right :: b -> Either' a b
right b = Either' $ \_ f -> f b

newtype ListC a = ListC { runListC :: forall r. (a -> r -> r) -> r -> r }
instance Show a => Show (ListC a) where
	showsPrec _ (ListC xs) = ("ListC' " ++) . showList (xs (:) [])
instance Functor ListC where
	fmap f (ListC xss) = ListC $ \c n -> xss (c . f) n
instance Applicative ListC where
	pure a = consc a nilc
	ListC f <*> ListC xs = ListC $ \c n -> f (\g -> xs (c . g)) n
instance Monad ListC where
	return = pure
	ListC xss >>= f = ListC $ \c n -> xss (\x xs -> (runListC (f x)) c xs) n
instance IsString (ListC Char) where
	fromString = foldr consc nilc
nilc :: ListC a
nilc = ListC $ \_ n -> n
consc :: a -> ListC a -> ListC a
consc x (ListC xs) = ListC $ \c n -> c x (xs c n)
appc :: ListC a -> ListC a -> ListC a
appc (ListC xs) (ListC ys) = ListC $ \c -> xs c . ys c

newtype ListS a = ListS { runListS :: forall r. (a -> ListS a -> r) -> r -> r }
instance Show a => Show (ListS a) where
	showsPrec n xs = ("ListS " ++) . showList (foldrs (:) [] xs)
instance Functor ListS where
	fmap f xss = foldrs (\x xs -> f x `conss` xs) nils xss
instance Applicative ListS where
	pure a = conss a nils
	ListS fss <*> ListS xss = ListS $ \c n -> fss (\f fs -> xss (\x xs -> c (f x) (fs <*> xs)) n) n
instance IsString (ListS Char) where
	fromString = foldr conss nils
foldrs :: (a -> b -> b) -> b -> ListS a -> b
foldrs f c (ListS xss) = xss (\x xs -> f x $ foldrs f c xs) c
nils :: ListS a
nils = ListS $ \_ n -> n
conss :: a -> ListS a -> ListS a
conss x xs = ListS $ \c _ -> c x xs
hdtls :: ListS a -> Maybe' (a, ListS a)
hdtls (ListS xs) = xs (\a b -> just (a,b)) nothing

newtype NonEmptyC a = NonEmptyC { runNonEmptyC :: forall r. (a -> r -> r) -> (a -> r) -> r }
instance Show a => Show (NonEmptyC a) where
	showsPrec _ (NonEmptyC xs) = ("NonEmptyC " ++) . showList (xs (:) return)
instance Functor NonEmptyC where
	fmap f (NonEmptyC xss) = NonEmptyC $ \c n -> xss (c . f) (n . f)
instance Applicative NonEmptyC where
	pure = nilnc
	NonEmptyC f <*> NonEmptyC xs = NonEmptyC $ \c n -> f
		(\g r -> xs (c . g) (\a -> c (g a) r))
		(\g -> xs (\a r -> c (g a) r) (n . g))
instance Monad NonEmptyC where
	return = pure
	NonEmptyC xss >>= f = NonEmptyC $ \c n -> xss
		(\x xs -> (runNonEmptyC (f x)) c (\b -> c b xs))
		(\x -> (runNonEmptyC (f x)) c n)
nilnc :: a -> NonEmptyC a
nilnc a = NonEmptyC $ \_ n -> n a
consnc :: a -> NonEmptyC a -> NonEmptyC a
consnc x (NonEmptyC xs) = NonEmptyC $ \c n -> c x (xs c n)