module Happstack.Data.DeriveAll (deriveAll, deriveNewData, deriveNewDataNoDefault)
where
import qualified Data.Generics as Old
import Data.Generics.SYB.WithClass.Derive
import Data.List
import Happstack.Data.Default
import Language.Haskell.TH
deriveNewData :: [Name] -> Q [Dec]
deriveNewData names
= do nd <- deriveData names
defaults <- mapM mkDefaultInstance names
return (nd ++ concat defaults)
deriveNewDataNoDefault :: [Name] -> Q [Dec]
deriveNewDataNoDefault = deriveData
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
#if MIN_VERSION_template_haskell(2,4,0)
tyVarBndrToName :: TyVarBndr -> Name
tyVarBndrToName (PlainTV nm) = nm
tyVarBndrToName (KindedTV nm _) = nm
#else
tyVarBndrToName :: Name -> Name
tyVarBndrToName = id
#endif
deriveAll :: [Name] -> Q [Dec] -> Q [Dec]
deriveAll classes0 qdecs
= do decs <- qdecs
derivedDecs <- deriveDec (filter isDataOrNewtype decs)
let (classDefault, classes1) = partition (''Default ==) classes0
classes2 = ''Old.Data : classes1
addDefaultInstance = not $ null classDefault
f = addDerivedClasses addDefaultInstance classes2
decs' = concatMap f decs
return (decs' ++ derivedDecs)
addDerivedClasses :: Bool -> [Name] -> Dec -> [Dec]
addDerivedClasses def cs (DataD ctxt nm tvs cons derivs)
= DataD ctxt nm tvs cons (cs ++ derivs)
: deriveDefault def (map tyVarBndrToName tvs) nm
addDerivedClasses def cs (NewtypeD ctxt nm tvs con derivs)
= NewtypeD ctxt nm tvs con (cs ++ derivs)
: deriveDefault def (map tyVarBndrToName tvs) nm
addDerivedClasses _ _ d = [d]
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'
#if MIN_VERSION_template_haskell(2,4,0)
mkCtx x = ClassP ''Default [x]
#else
mkCtx = mkDef
#endif
isDataOrNewtype :: Dec -> Bool
isDataOrNewtype (DataD {}) = True
isDataOrNewtype (NewtypeD {}) = True
isDataOrNewtype _ = False