module HAppS.Data.DeriveAll (deriveAll, deriveNewData, deriveNewDataNoDefault)
where
import qualified Data.Generics as Old
import Data.Generics.SYB.WithClass.Derive
import Data.List
import HAppS.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 tvs nm
TyConI (DataD _ nm tvs _ _) -> return $ deriveDefault True tvs nm
_ -> fail ("mkDefaultInstance: Bad info: " ++ pprint info)
deriveAll :: [Name] -> Q [Dec] -> Q [Dec]
#ifndef __HADDOCK__
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 tvs nm
addDerivedClasses def cs (NewtypeD ctxt nm tvs con derivs)
= NewtypeD ctxt nm tvs con (cs ++ derivs)
: deriveDefault def 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 mkDef tvs'
instanceHead = mkDef $ foldl AppT (ConT n) tvs'
isDataOrNewtype :: Dec -> Bool
isDataOrNewtype (DataD {}) = True
isDataOrNewtype (NewtypeD {}) = True
isDataOrNewtype _ = False
#endif