{-# LANGUAGE TemplateHaskell, FlexibleContexts #-}
module THUtil where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Generics
import Data.Char
import Control.Newtype(Newtype) -- package: newtype
import Data.Aeson(Object)       -- package: aeson
import Data.Map((!))
import qualified Data.Text as T -- package: text


modifyNames :: Data d => (Name -> Name) -> d -> d 
modifyNames f = everywhere (mkT f)

substName ::  Data d => String -> String -> d -> d
substName n n' = modifyNames f
    where
        f x@(Name o flavour) | occString o == n = Name (mkOccName n') flavour
                             | otherwise        = x 

substNamesPositional :: Data d => [String] -> Q d  -> Q d 
substNamesPositional names = fmap f
    where
        f d = foldr (\(i,name) -> 
                        substName ( (if isLower (head name) then "x" else "X") ++ show i ) 
                                  name) 
                d 
                (zip [1..] names)

upperHead (c:cs) = toUpper c : cs

possessiveClass :: TypeQ -> String -> String -> DecsQ
possessiveClass tQ name jsonkey = 
    substNamesPositional ["Has"++upperHead name, name] 
    [d| 
        class Newtype a Object => X1 a

        x2 :: X1 a => a -> $(tQ)
        x2 = (! (T.pack jsonkey)) 

    |]