{-# 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 :: String -> [String] -> Q [Dec]
mkEnum String
name [String]
vals =
[[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
[ (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: []) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
dataDec
, Name -> [Name] -> Q [Dec]
mkFromJSON Name
name' [Name]
vals'
, Name -> [Name] -> Q [Dec]
mkToJSON Name
name' [Name]
vals'
]
where
name' :: Name
name' = String -> Name
mkName String
name
vals' :: [Name]
vals' = (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map String -> Name
mkName [String]
vals
dataDec :: Q Dec
dataDec = Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Name
name' [] Maybe Kind
forall a. Maybe a
Nothing ((Name -> Q Con) -> [Name] -> [Q Con]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Con
forall {m :: * -> *}. Quote m => Name -> m Con
toCon [Name]
vals') [Maybe DerivStrategy -> [Q Kind] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Kind] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Q Kind]
deriveClasses]
deriveClasses :: [Q Kind]
deriveClasses =
[ [t|Eq|]
, [t|Ord|]
, [t|Show|]
, [t|Enum|]
]
toCon :: Name -> m Con
toCon Name
val = Name -> [m BangType] -> m Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC Name
val []
genFromJSONEnum :: Name -> Q [Dec]
genFromJSONEnum :: Name -> Q [Dec]
genFromJSONEnum Name
name = Name -> Q [Name]
getEnumConstructors Name
name Q [Name] -> ([Name] -> Q [Dec]) -> Q [Dec]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> [Name] -> Q [Dec]
mkFromJSON Name
name
genToJSONEnum :: Name -> Q [Dec]
genToJSONEnum :: Name -> Q [Dec]
genToJSONEnum Name
name = Name -> Q [Name]
getEnumConstructors Name
name Q [Name] -> ([Name] -> Q [Dec]) -> Q [Dec]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> [Name] -> Q [Dec]
mkToJSON Name
name
getEnumConstructors :: Name -> Q [Name]
getEnumConstructors :: Name -> Q [Name]
getEnumConstructors Name
name = do
ClassI Dec
_ [Dec]
instances <- Name -> Q Info
reify ''Enum
let instanceNames :: [Name]
instanceNames = ((Dec -> Maybe Name) -> [Dec] -> [Name])
-> [Dec] -> (Dec -> Maybe Name) -> [Name]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Dec -> Maybe Name) -> [Dec] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Dec]
instances ((Dec -> Maybe Name) -> [Name]) -> (Dec -> Maybe Name) -> [Name]
forall a b. (a -> b) -> a -> b
$ \case
InstanceD Maybe Overlap
_ Cxt
_ (AppT Kind
_ (ConT Name
n)) [Dec]
_ -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
Dec
_ -> Maybe Name
forall a. Maybe a
Nothing
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
instanceNames) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Not an Enum type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
Name -> Q Info
reify Name
name Q Info -> (Info -> Q [Name]) -> Q [Name]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
TyConI (DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [Con]
cons [DerivClause]
_) -> [Con] -> (Con -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Con]
cons ((Con -> Q Name) -> Q [Name]) -> (Con -> Q Name) -> Q [Name]
forall a b. (a -> b) -> a -> b
$ \case
NormalC Name
con [] -> Name -> Q Name
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
con
Con
con -> String -> Q Name
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"Invalid constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
con
Info
info -> String -> Q [Name]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Name]) -> String -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String
"Invalid data type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
info
mkFromJSON :: Name -> [Name] -> Q [Dec]
mkFromJSON :: Name -> [Name] -> Q [Dec]
mkFromJSON Name
name [Name]
cons = do
let toPattern :: Name -> Q Pat
toPattern = Lit -> Q Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Lit -> Q Pat) -> (Name -> Lit) -> Name -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
toMatch :: Name -> Q Match
toMatch Name
con = Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> Q Pat
toPattern Name
con) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
con)|]) []
Name
t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
let parseEnum :: Q Exp
parseEnum =
Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE [|Text.unpack $ Text.toLower $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t)|] ([Q Match] -> Q Exp) -> [Q Match] -> Q Exp
forall a b. (a -> b) -> a -> b
$
(Name -> Q Match) -> [Name] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Match
toMatch [Name]
cons [Q Match] -> [Q Match] -> [Q Match]
forall a. [a] -> [a] -> [a]
++ [Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE Q Exp
badParse (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) []]
[d|
instance FromJSON $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
name) where
parseJSON (String $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t)) = $Q Exp
parseEnum
parseJSON v = $Q Exp
badParse v
|]
where
badParse :: Q Exp
badParse =
let prefix :: Q Exp
prefix = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
"Bad " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
in [|fail . ($Q Exp
prefix ++) . show|]
mkToJSON :: Name -> [Name] -> Q [Dec]
mkToJSON :: Name -> [Name] -> Q [Dec]
mkToJSON Name
name [Name]
cons =
[d|
instance ToJSON $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
name) where
toJSON = $([Q Match] -> Q Exp
forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE ([Q Match] -> Q Exp) -> [Q Match] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Q Match) -> [Name] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Match
forall {m :: * -> *}. Quote m => Name -> m Match
encodeConstructor [Name]
cons)
|]
where
encodeConstructor :: Name -> m Match
encodeConstructor Name
con = m Pat -> m Body -> [m Dec] -> m Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
con []) (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|String $ Text.pack $(String -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
con)|]) []