[はじめての圏論 その第1歩：しりとりの圏 - 檜山正幸のキマイラ飼育記](http://d.hatena.ne.jp/m-hiyama/20060821/1156120185)のしりとりの圏をHaskellで実装した例です＞ω＜

ShiritoriTH.hs

{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
module ShiritoriTH where
import Data.Char
import Language.Haskell.TH
import Language.Haskell.TH.Quote

letterDec :: (Char, Char) -> Q [Dec]
letterDec (from, to) = (mapM (\c -> let
  n = mkName $ "Letter" ++ return c
  in return $ [DataD [] n [] [NormalC n []] [],
               InstanceD [] (AppT (ConT ''Show) (ConT n))
                 [FunD 'show [Clause [ConP n []] (NormalB (LitE (StringL $ return c))) [] ]]]) $
    enumFromTo from to) >>= return . concat

data Shiritori a b = SWord String deriving Show

unit :: Show a => a -> Shiritori a a
unit x = SWord $ show x

(>>>) :: Shiritori a b -> Shiritori b c -> Shiritori a c
(SWord xs) >>> (SWord (_:ys)) = SWord $ xs ++ ys

wordExp :: String -> Q Exp
wordExp xs = let
  xs' = map toUpper xs
  x = head xs'
  y = last xs'
  in return (SigE (AppE (ConE 'SWord ) (LitE $ StringL xs'))
      (AppT (AppT (ConT ''Shiritori) (ConT $ mkName $ "Letter" ++ return x)) (ConT $ mkName $ "Letter" ++ return y)))

word :: QuasiQuoter
word = QuasiQuoter {
    quoteExp = wordExp
  , quotePat = undefined
  , quoteType = undefined
  , quoteDec = undefined
}

Shitori.hs

{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
module Shiritori where
import ShiritoriTH

letterDec ('A', 'Z')
letterDec ('ぁ', 'ん')

USAGE

$ ghci Shiritori.hs -XQuasiQuotes
GHCi, version 7.4.2: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
[1 of 2] Compiling ShiritoriTH      ( ShiritoriTH.hs, interpreted )
[2 of 2] Compiling Shiritori        ( Shiritori.hs, interpreted )
Loading package pretty-1.1.1.0 ... linking ... done.
Loading package array-0.4.0.0 ... linking ... done.
Loading package deepseq-1.3.0.0 ... linking ... done.
Loading package containers-0.4.2.1 ... linking ... done.
Loading package template-haskell ... linking ... done.
Ok, modules loaded: Shiritori, ShiritoriTH.
*Shiritori> unit LetterA
SWord "A"
*Shiritori> :t unit LetterA
unit LetterA :: Shiritori LetterA LetterA
*Shiritori> [word|hello|]
SWord "HELLO"
*Shiritori> :t [word|hello|]
[word|hello|] :: Shiritori LetterH LetterO
*Shiritori> [word|hello|] >>> [word|ok|]
SWord "HELLOK"
*Shiritori> :t [word|hello|] >>> [word|ok|]
[word|hello|] >>> [word|ok|] :: Shiritori LetterH LetterK
*Shiritori> [word|hello|] >>> unit LetterO
SWord "HELLO"
*Shiritori> unit LetterH >>> [word|hello|]
SWord "HELLO"
*Shiritori> ([word|たぬき|] >>> [word|きつね|]) >>> [word|ねこ|]
SWord "\12383\12396\12365\12388\12397\12371"
*Shiritori> [word|たぬき|] >>> ([word|きつね|] >>> [word|ねこ|])
SWord "\12383\12396\12365\12388\12397\12371"
*Shiritori> :q
Leaving GHCi.