リストとタプルのチャーチエンコーディング

List.hs

{-# LANGUAGE Rank2Types #-}
module Data.List.Church
  ( List
  -- * Basic functions
  , empty
  , singleton
  , append
  , head
  , last
  , tail
  , init
  , null
  , length
  , fmap
  , reverse
  -- * List transformations
  , intersperse
  , intercalate
  , transpose
  , concat
  , concatMap
  , zip
  , zipWith
  , module Data.Tuple.Church
  ) where

import Data.Tuple.Church   (Pair, pair, fst, snd)
import Control.Applicative (Applicative(..), (<$>))
import Control.Monad       (ap)
import Data.List           (unfoldr)
import Data.Foldable       (Foldable(..), all, foldl')
import Data.Key            (Zip(..))
import Data.Monoid         (Monoid(..))
import Prelude hiding ( (!!)
                      , all
                      , concat
                      , concatMap
                      , foldl
                      , foldr
                      , foldr1
                      , fst
                      , head
                      , init
                      , last
                      , length
                      , null
                      , reverse
                      , snd
                      , tail
                      , zip
                      , zipWith
                      )

newtype List a = List { unList :: forall r. (a -> r -> r) -> r -> r }

instance Monoid (List a) where
  mempty  = empty
  mappend = append

instance Foldable List where
  foldr f z (List r) = r f z

instance Functor List where
  fmap f = foldr (cons . f) empty

instance Applicative List where
  pure = singleton
  (<*>) = ap

instance Monad List where
  return = pure
  (>>=)  = flip foldMap

instance Show a => Show (List a) where
  show xs
    | null xs   = "[]"
    | otherwise = "[" ++ show (head xs) ++ foldr go "]" (tail xs)
    where go a ss = "," ++ show a ++ "" ++ ss

instance Zip List where
  zipWith f a b
    | null a    = empty
    | null b    = empty
    | otherwise = cons (f (head a) (head b))
                       (zipWith f (tail a) (tail b))

null :: List a -> Bool
null (List r) = r (\_ _ -> False) True

empty :: List a
empty = List (\_ z -> z)

singleton :: a -> List a
singleton x = cons x empty

cons :: a -> List a -> List a
cons x (List r) = List $ \f z -> f x (r f z)

head :: List a -> a
head (List r) = r (flip (const id)) (error "Data.List.Church.head: empty list")

tail :: List a -> List a
tail (List r) = fst $ r (\f z -> pair (snd z) (cons f (snd z)))
                        (pair empty empty)

length :: List a -> Int
length = foldr (const succ) 0

fromList :: [a] -> List a
fromList = foldr cons empty

toList :: List a -> [a]
toList = unfoldr phi
  where phi xs
          | null xs   = Nothing
          | otherwise = Just (head xs, tail xs)

append :: List a -> List a -> List a
append xs ys = foldr cons ys xs

last :: List a -> a
last = foldl' (const id) (error "Data.List.Church.last: empty list")

init :: List a -> List a
init xs
  | null xs   = error "Data.List.Church.init: empty list"
  | otherwise = init' (head xs) (tail xs)
  where init' y ys
          | null ys   = empty
          | otherwise = cons y $ init' (head ys) (tail ys)

reverse :: List a -> List a
reverse = foldl (flip cons) empty

intersperse :: a -> List a -> List a
intersperse s xs
  | null xs        = empty
  | null (tail xs) = singleton $ head xs
  | otherwise      = cons (head xs) (cons s (intersperse s (tail xs)))

concatMap :: (a -> List b) -> List a -> List b
concatMap = foldMap

concat :: List (List a) -> List a
concat = foldMap id

intercalate :: List a -> List (List a) -> List a
intercalate = (concat .) . intersperse

transpose :: List (List a) -> List (List a)
transpose xs
  | null xs        = empty
  | null (head xs) = transpose (tail xs)
  | otherwise      = cons (cons z (head <$> ys))
                          (transpose (cons zs (tail <$> ys)))
  where (y, ys) = (head xs, tail xs)
        (z, zs) = (head y,  tail y)

partition :: (a -> Bool) -> List a -> Pair (List a) (List a)
partition p = foldr (select p) (pair empty empty)
  where select :: (a -> Bool) -> a -> Pair (List a) (List a) -> Pair (List a) (List a)
        select p x pr
          | p x       = pair (cons x (fst pr)) (snd pr)
          | otherwise = pair (fst pr) (cons x (snd pr))

Tuple.hs

{-# LANGUAGE Rank2Types #-}
module Data.Tuple.Church
  ( Pair
  , pair, fst, snd, swap
  ) where

import Data.Function (on)
import Data.Ord      (comparing)
import Prelude hiding (fst, snd)

newtype Pair a b = Pair { unPair :: forall r. (a -> b -> r) -> r }

pair :: a -> b -> Pair a b
pair a b = Pair $ \p -> p a b

fst :: Pair a b -> a
fst (Pair p) = p const

snd :: Pair a b -> b
snd (Pair p) = p (flip const)

swap :: Pair a b -> Pair b a
swap p = pair (snd p) (fst p)

instance (Show a, Show b) => Show (Pair a b) where
  show p = "(" ++ show (fst p) ++ "," ++ show (snd p) ++ ")"

instance (Eq a, Eq b) => Eq (Pair a b) where
  p == q = fst p == fst q && snd p == snd q

instance (Ord a, Ord b) => Ord (Pair a b) where
  p `compare` q = case comparing fst p q of
                    EQ -> comparing snd p q
                    r  -> r