Ticket #3731: NewData.hs

{-# LANGUAGE TemplateHaskell, CPP #-}
{-# OPTIONS_GHC -Wall -Werror #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Happstack.Data.DeriveAll
-- Copyright   :  (c) 2009 Happstack.com; (c) 2007 HAppS LLC
-- License     :  BSD3
--
-- Maintainer  :  happs@googlegroups.com
-- Stability   :  experimental
-- Portability :  Not portable
--
-- Concisely specify which classes to derive for your datatypes.
-- As well as the standard derivable classes, it can also
-- derive syb-with-class's 'New.Data' class and Happstack.Data.Default's
-- 'Default' class.
--
-----------------------------------------------------------------------------

module NewData (deriveNewData) where

import Data.Generics.SYB.WithClass.Derive
import Default
import Language.Haskell.TH

{- | Derives instances for syb-with-class's Data class and 
   Happstack.Data.Default's Default class.
   The list of names should be of the form [''Foo,''Bar,..]
-}
deriveNewData :: [Name] -> Q [Dec]
deriveNewData names
 = do nd <- deriveData names
      defaults <- mapM mkDefaultInstance names
      return (nd ++ concat defaults)

mkDefaultInstance :: Name -> Q [Dec]
mkDefaultInstance name
 = do info <- reify name
      case info of
          TyConI (NewtypeD _ nm tvs _ _) -> return $ deriveDefault True (conv tvs) nm
          TyConI (DataD    _ nm tvs _ _) -> return $ deriveDefault True (conv tvs) nm
          _ -> fail ("mkDefaultInstance: Bad info: " ++ pprint info)
 where conv = map tyVarBndrToName

tyVarBndrToName :: TyVarBndr -> Name
tyVarBndrToName (PlainTV nm) = nm
tyVarBndrToName (KindedTV nm _) = nm

deriveDefault :: Bool -> [Name] -> Name -> [Dec]
deriveDefault False _ _ = []
deriveDefault True tvs n = [InstanceD context instanceHead []]
    where tvs' = map VarT tvs
          mkDef x = ConT ''Default `AppT` x
          context = map mkCtx tvs'
          instanceHead = mkDef $ foldl AppT (ConT n) tvs'
          mkCtx x = ClassP ''Default [x]