TagBanana.hs

import TagField
import Data.Text (Text)
import Data.Aeson

data Banana = Banana
  { shape :: Field "banana-shape" Text
  , size  :: Field "banana size" (Maybe Int)
  , name  :: Field "banana's name" Text
  } deriving Show

deriveToJSONFields ''Banana

b = Banana (Field "foo") (Field (Just 2)) (Field "bar")

TagField.hs

module TagField where

import GHC.TypeLits
import Data.Aeson (ToJSON, toJSON, object, (.=))
import Language.Haskell.TH

newtype Field (n :: Symbol) v = Field { unField :: v }
  deriving Show

deriveToJSONFields ty = do
  t <- reify ty
  case t of
    TyConI (DataD _ _ ts [cs] _) -> do
      let (n, cs') = case cs of
                      NormalC n xs -> (n, [t | (_, t)    <- xs])
                      RecC n xs ->    (n, [t | (_, _, t) <- xs])
      fs <- sequence [(,) (fieldName x) `fmap` newName "a" | x <- cs']
      sequence [instanceD (return []) (appT (conT ''ToJSON) (conT ty)) [
          funD 'toJSON [clause [conP n (map (varP . snd) fs)] (normalB (
              appE (varE 'object) (listE [
                appE (appE (varE '(.=)) (litE (StringL fk)))
                     (appE (varE 'unField) (varE fv))
              | (fk, fv) <- fs ])
            )) []]
        ]]
    _ -> error "single constr only for now"
  where
    fieldName :: Type -> String
    fieldName (AppT (AppT (ConT _Name) (LitT (StrTyLit s))) _) = s