{-# LANGUAGE TemplateHaskellQuotes #-}
module Language.Haskell.TH.HashableGADT (
  deriveHashable,
) where

import Control.Category ((>>>))
import Control.Monad (forM)
import Data.Hashable
import Language.Haskell.TH


-- | The predicate indicates whether a particular field is to be included. If
-- all fields are to be hashed, return @True@. It gets passed the name of the
-- constructor, the index of the field, and the type of the field.
deriveHashable :: (Name -> Int -> Type -> Bool) -> Name -> Q [Dec]
deriveHashable includepred dataname = do
  info <- reify dataname
  (params, cons) <- case info of
    TyConI (DataD [] _ params _ cons _) -> return (params, cons)
    _ -> fail "deriveHashable: only data types supported"

  saltVar <- newName "s"
  clauses <- concat <$> mapM (processCon saltVar includepred) cons

  let paramVars = map (VarT . bndrName) params
      headType = foldl' AppT (ConT dataname) paramVars
  return [InstanceD Nothing [] (ConT ''Hashable `AppT` headType)
            [FunD 'hashWithSalt clauses]]

processCon :: Name -> (Name -> Int -> Type -> Bool) -> Con -> Q [Clause]
processCon saltVar includepred constr = do
  let thd (_,_,c) = c
  let getFields (NormalC name fields) = return [(name, map snd fields)]
      getFields (RecC name fields) = return [(name, map thd fields)]
      getFields (InfixC t1 name t2) = return [(name, [snd t1, snd t2])]
      getFields (GadtC names fields _) = return [(name, map snd fields) | name <- names]
      getFields (RecGadtC names fields _) = return [(name, map thd fields) | name <- names]
      getFields (ForallC _ _ con) = getFields con

  actualcons <- getFields constr
  forM actualcons $ \(name, fields) -> do
    _

bndrName :: TyVarBndr flag -> Name
bndrName (PlainTV n _) = n
bndrName (KindedTV n _ _) = n