Ticket #3731: NewData.hs

File NewData.hs, 1.9 KB (added by dsf, 4 years ago)

Definitions copied from Happstack.Data.DeriveAll?, use with Bug2.hs

Line 
1{-# LANGUAGE TemplateHaskell, CPP #-}
2{-# OPTIONS_GHC -Wall -Werror #-}
3
4-----------------------------------------------------------------------------
5-- |
6-- Module      :  Happstack.Data.DeriveAll
7-- Copyright   :  (c) 2009 Happstack.com; (c) 2007 HAppS LLC
8-- License     :  BSD3
9--
10-- Maintainer  :  happs@googlegroups.com
11-- Stability   :  experimental
12-- Portability :  Not portable
13--
14-- Concisely specify which classes to derive for your datatypes.
15-- As well as the standard derivable classes, it can also
16-- derive syb-with-class's 'New.Data' class and Happstack.Data.Default's
17-- 'Default' class.
18--
19-----------------------------------------------------------------------------
20
21module NewData (deriveNewData) where
22
23import Data.Generics.SYB.WithClass.Derive
24import Default
25import Language.Haskell.TH
26
27{- | Derives instances for syb-with-class's Data class and
28   Happstack.Data.Default's Default class.
29   The list of names should be of the form [''Foo,''Bar,..]
30-}
31deriveNewData :: [Name] -> Q [Dec]
32deriveNewData names
33 = do nd <- deriveData names
34      defaults <- mapM mkDefaultInstance names
35      return (nd ++ concat defaults)
36
37mkDefaultInstance :: Name -> Q [Dec]
38mkDefaultInstance name
39 = do info <- reify name
40      case info of
41          TyConI (NewtypeD _ nm tvs _ _) -> return $ deriveDefault True (conv tvs) nm
42          TyConI (DataD    _ nm tvs _ _) -> return $ deriveDefault True (conv tvs) nm
43          _ -> fail ("mkDefaultInstance: Bad info: " ++ pprint info)
44 where conv = map tyVarBndrToName
45
46tyVarBndrToName :: TyVarBndr -> Name
47tyVarBndrToName (PlainTV nm) = nm
48tyVarBndrToName (KindedTV nm _) = nm
49
50deriveDefault :: Bool -> [Name] -> Name -> [Dec]
51deriveDefault False _ _ = []
52deriveDefault True tvs n = [InstanceD context instanceHead []]
53    where tvs' = map VarT tvs
54          mkDef x = ConT ''Default `AppT` x
55          context = map mkCtx tvs'
56          instanceHead = mkDef $ foldl AppT (ConT n) tvs'
57          mkCtx x = ClassP ''Default [x]