{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Aeson.Schema.TH.Enum
( genFromJSONEnum
, genToJSONEnum
, mkEnum
) where
import Control.Monad (forM, unless)
import Data.Aeson (FromJSON(..), ToJSON(..), Value(..))
import Data.Char (toLower)
import Data.Maybe (mapMaybe)
import qualified Data.Text as Text
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (lift)
mkEnum :: String -> [String] -> Q [Dec]
mkEnum name vals = concat <$> sequence
[ (:[]) <$> dataDec
, mkFromJSON name' vals'
, mkToJSON 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 = getEnumConstructors name >>= mkFromJSON name
genToJSONEnum :: Name -> Q [Dec]
genToJSONEnum name = getEnumConstructors name >>= mkToJSON name
getEnumConstructors :: Name -> Q [Name]
getEnumConstructors 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
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 -> [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 |]
mkToJSON :: Name -> [Name] -> Q [Dec]
mkToJSON name cons =
[d|
instance ToJSON $(conT name) where
toJSON = $(lamCaseE $ map encodeConstructor cons)
|]
where
encodeConstructor con = match (conP con []) (normalB [| String $ Text.pack $(lift $ nameBase con) |]) []