レコードっぽい JSON に対する FromJSON のインスタンス宣言をつくる

Main.hs

{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
import Data.Aeson
import Data.ByteString.Lazy.Char8 ()

import Data.Aeson.TH.Record

data Obj = MkObj { objFooBar :: Int, objHoge :: [String] } deriving Show
newtype R = MkR { unR :: Obj } deriving Show
data X = MkX { xNullableInt :: Maybe Int, xOptionalDouble :: Maybe Double } deriving Show

deriveFromJSONRecord (camelToSnake . drop 3) ''Obj
deriveFromJSONRecord (const "result") ''R
deriveFromJSONRecord' (camelToSnake . drop 1) (== "optional_double") ''X

main :: IO ()
main = do
  let x = decode' "{\"foo_bar\": 10, \"hoge\": [\"fuga\", \"piyo\"]}" :: Maybe Obj
      y = decode' "{\"hoge\": [\"fuga\"], \"piyo\":[], \"foo_bar\": 30}" :: Maybe Obj
      z = decode' "{\"result\": {\"hoge\": [\"fuga\"], \"piyo\":[], \"foo_bar\": 30}}" :: Maybe R
      w1 = decode' "{\"nullable_int\": null}" :: Maybe X
      w2 = decode' "{\"optional_double\": 3.14}" :: Maybe X
  print x
  print y
  print z
  print w1  -- Just (MkX {xNullableInt = Nothing, xOptionalDouble = Nothing})
  print w2  -- Nothing

Record.hs

{-# LANGUAGE TemplateHaskell #-}
module Data.Aeson.TH.Record
  ( deriveFromJSONRecord
  , deriveFromJSONRecord'
  , camelToSnake
  ) where
import Control.Applicative
import Data.Char (isUpper, toLower)
import Data.Aeson.Types
import Language.Haskell.TH
import Data.Text (pack)

camelToSnake :: String -> String
camelToSnake [] = []
camelToSnake (x:xs) = toLower x : go xs
  where
    go [] = []
    go (y:ys)
      | isUpper y = '_' : toLower y : go ys
      | otherwise = y : go ys

deriveFromJSONRecord :: (String -> String) -> Name -> Q [Dec]
deriveFromJSONRecord renamer = deriveFromJSONRecord' renamer (const False)

deriveFromJSONRecord' :: (String -> String) -> (String -> Bool) -> Name -> Q [Dec]
deriveFromJSONRecord' renamer isOptional typeName = do
  objName <- newName "obj"
  pure <$>
    instanceD (cxt []) (conT ''FromJSON `appT` conT typeName)
      [funD 'parseJSON $ mkClauses objName]
  where
    mkClauses objName =
      [ clause [conP 'Object [varP objName]] (normalB $ mkParserExp renamer isOptional objName typeName) []
      , clause [wildP] (normalB [| fail $ strTypeName ++ " is not an object" |]) []
      ]

    strTypeName = nameBase typeName

mkParserExp :: (String -> String) -> (String -> Bool) -> Name -> Name -> ExpQ
mkParserExp renamer isOptional objName typeName = do
  info <- reify typeName
  case info of
    TyConI (DataD _ _ _ [RecC dataName fields] _) -> go dataName $ map (\(x,_,_) -> renamer $ nameBase x) fields
    TyConI (NewtypeD _ _ _  (RecC dataName fields) _) -> go dataName $ map (\(x,_,_) -> renamer $ nameBase x) fields
    _ -> fail $ nameBase typeName ++ " is not a record"
  where
    go _ [] = fail "unreachable?"
    go dataName (x:xs) = foldl f b xs
      where
        b = [| $(conE dataName) <$> $(g x) |]
        f e field = [| $e <*> $(g field) |]
        g y
          | isOptional y = [| $(varE objName) .:? pack y |]
          | otherwise = [| $(varE objName) .: pack y |]