Question: Deriving boilerplate matching function.

DeriveADT.hs

{-# LANGUAGE TemplateHaskell #-}
module DeriveADT 
    ( deriveExtract
    , deriveIs
    ) where

import Data.Maybe
import Data.Char

import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax

deriveIs :: Name -> Q [Dec]
deriveIs = adtDerive mkIs
    where
        mkIs (NormalC nm t) = do
            let tn = nameBase nm
            funD (mkName $ "is" ++ toV tn) [ clause [conP nm (replicate (length t) wildP)] (normalB true) []
                                           , clause [wildP] (normalB false) []
                                           ]


deriveExtract :: Name -> Q [Dec]
deriveExtract = adtDerive mkExtract
    where
        mkExtract (NormalC nm t) = do
            p <- mapM (\_ -> newName "x") t
            let tn = nameBase nm
                one = (length t) == 1
            funD (mkName $ "extract" ++toV tn) 
                 [ clause [conP nm (map varP p)] (normalB $ inner p) []
                 , clause [wildP] (normalB nothing) []
                 ]
        inner (p:[])  = appE just (varE p)
        inner (ps)    = appE just (tupE $ map varE ps)

-- Helpers

adtDerive :: (Con -> Q Dec) -> Name -> Q [Dec]
adtDerive f t = do
    info <- reify t
    reified <- case info of
        TyConI (DataD _ _ _ constructors _) -> return constructors
        otherwise -> error "e"
    mapM f reified

toV (x:xs) = x:map toLower xs

isNormalC (NormalC _ _) = True
isNormalC _ = False

true = conE $ mkName "True"
false = conE $ mkName "False"
nothing = conE $ mkName "Nothing"
just = conE $ mkName "Just"

gistfile1.hs

data A = A | B () | C () () 

$(deriveIs ''A)

extractA :: A -> Maybe ()
extractA A = Just ()
extractA _ = Nothing

extractB :: A -> Maybe ()
extractB (B a) = Just a
extractB   _   = Nothing

extractC :: A -> Maybe ((), ())
extractC (C a b) = Just (a, b)
extractC   _     = Nothing

main = do                                                                          
    let vars = [A, B (), C 5]                                                      
        test = [isA, isB, isC]                                                     
        r    = [ (i:j:':':' ':(show $ t v)) | (i,t) <- zip ['1'..] test,           
                                              (j,v) <- zip ['a'..] vars]           
    mapM_ print r