module Data.Default.TH (deriveDefault) where
import Control.Applicative
import Data.Default
import Data.List
import Language.Haskell.TH
createInstance :: Name -> [Name] -> Name -> [Type] -> Q Dec
createInstance typeConstructorName typeVariables constructorName constructorArgumentTypes = do
reqs <- constraints typeConstructorName constructorArgumentTypes
return $ InstanceD reqs
(AppT (ConT ''Default) (foldl' (\x y -> AppT x (VarT y)) (ConT typeConstructorName) typeVariables))
[FunD 'def [Clause [] (NormalB (foldl' (\x _ -> AppE x (VarE 'def)) (ConE constructorName) constructorArgumentTypes)) []]]
constraints :: Name -> [Type] -> Q [Pred]
constraints tcn ts = nub . concat <$> mapM (constraint tcn) ts
constraint :: Name -> Type -> Q [Pred]
constraint tcn t@(VarT n) = return [ClassP ''Default [t]]
constraint tcn t@(ConT n) = return [ClassP ''Default [t]]
constraint tcn (SigT t StarK) = constraint tcn t
constraint tcn t@(AppT _ _) = case normalize t of
(ArrowT, [_, r]) -> constraint tcn r
(ListT, [t]) -> return []
(TupleT n, ts) -> constraints tcn ts
(ConT n, ts) | n == tcn -> return []
_ -> return [ClassP ''Default [t]]
constraint tcn t = fail $ "I got surprised by the type " ++ pprint t ++ " as a constructor argument while trying to derive a Default instance for " ++ pprint tcn
normalize = normalize' [] where
normalize' acc (AppT t t') = normalize' (t':acc) t
normalize' acc t = (t, reverse acc)
instanceQ :: Name -> [TyVarBndr] -> Name -> [Type] -> Q [Dec]
instanceQ t vs c as = return <$> createInstance t (map name vs) c as
name :: TyVarBndr -> Name
name (PlainTV n) = n
name (KindedTV n k) = n
deriveDefault :: Name -> Q [Dec]
deriveDefault n = do
info <- reify n
case info of
TyConI (DataD _ qn tvars (con:_) _) -> case con of
NormalC conName ts -> instanceQ qn tvars conName (map snd ts)
RecC conName ts -> instanceQ qn tvars conName (map (\(v,s,t) -> t) ts)
InfixC t conName t' -> instanceQ qn tvars conName (map snd [t, t'])
_ -> fail $ "Dunno how to derive Default instances for existential types"
TyConI (DataD _ _ _ [] _) -> fail $ "Really? You want to derive a Default instance for an uninhabited type?"
_ -> fail $ "Couldn't derive a Default instance; didn't know what to do with " ++ pprint info