module Composite.Aeson.Enum where
import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.BetterErrors as ABE
import qualified Data.HashMap.Strict as HM
import Data.List (intercalate, stripPrefix)
import qualified Data.Map.Strict as M
import Data.Text (Text, pack, unpack)
import GHC.Generics (Generic(type Rep))
import Generics.Deriving.ConNames (ConNames, conNames)
import Generics.Deriving.Enum (Enum', genumDefault)
enumJsonFormat :: forall e a. (Show a, Ord a, Generic a, ConNames (Rep a), Enum' (Rep a)) => String -> JsonFormat e a
enumJsonFormat prefix =
let names = map (pack . removePrefix) $ conNames (undefined :: a)
removePrefix s
| Just suffix <- stripPrefix prefix s = suffix
| otherwise = s
values = genumDefault
lookupText = flip HM.lookup . HM.fromList $ zip names values
lookupValue = flip M.lookup . M.fromList $ zip values names
expectedValues = "one of " ++ (intercalate ", " . map unpack $ names)
in enumMapJsonFormat lookupText lookupValue expectedValues
enumMapJsonFormat :: Show a => (Text -> Maybe a) -> (a -> Maybe Text) -> String -> JsonFormat e a
enumMapJsonFormat lookupText lookupValue expectedText = JsonFormat $ JsonProfunctor toJson fromJson
where
toJson a =
case lookupValue a of
Nothing -> error $ "unrecognized enum value " ++ show a
Just t -> Aeson.String t
fromJson = do
t <- ABE.asText
case lookupText t of
Nothing -> fail $ "expected " ++ expectedText ++ ", not " ++ unpack t
Just v -> pure v