{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Aeson.Schema.TH.Enum
( genFromJSONEnum
, mkEnum
) where
import Control.Monad (forM, unless)
import Data.Aeson (FromJSON(..), Value(..))
import Data.Char (toLower)
import Data.Maybe (mapMaybe)
import qualified Data.Text as Text
import Language.Haskell.TH
mkEnum :: String -> [String] -> Q [Dec]
mkEnum name vals = do
(:) <$> dataDec <*> mkFromJSON name' vals'
where
name' = mkName name
vals' = map mkName vals
dataDec = dataD (pure []) name' [] Nothing (map toCon vals') [derivClause Nothing deriveClasses]
deriveClasses =
[ [t| Eq |]
, [t| Ord |]
, [t| Show |]
, [t| Enum |]
]
toCon val = normalC val []
genFromJSONEnum :: Name -> Q [Dec]
genFromJSONEnum name = do
ClassI _ instances <- reify ''Enum
let instanceNames = flip mapMaybe instances $ \case
InstanceD _ _ (AppT _ (ConT n)) _ -> Just n
_ -> Nothing
unless (name `elem` instanceNames) $ fail $ "Not an Enum type: " ++ show name
cons <- reify name >>= \case
TyConI (DataD _ _ _ _ cons _) -> forM cons $ \case
NormalC con [] -> return con
con -> fail $ "Invalid constructor: " ++ show con
info -> fail $ "Invalid data type: " ++ show info
mkFromJSON name cons
mkFromJSON :: Name -> [Name] -> Q [Dec]
mkFromJSON name cons = do
let toPattern = litP . stringL . map toLower . nameBase
toMatch con = match (toPattern con) (normalB [| pure $(conE con) |]) []
t <- newName "t"
let parseEnum = caseE [| Text.unpack $ Text.toLower $(varE t) |] $
map toMatch cons ++ [match wildP (normalB $ appE badParse $ varE t) []]
[d|
instance FromJSON $(conT name) where
parseJSON (String $(varP t)) = $parseEnum
parseJSON v = $badParse v
|]
where
badParse =
let prefix = litE $ stringL $ "Bad " ++ nameBase name ++ ": "
in [| fail . ($prefix ++) . show |]