module Composite.Aeson.Enum where
import Control.Monad.Error.Class (throwError)
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, conNameOf)
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 :: forall e a.
(Show a, Ord a, Generic a, ConNames (Rep a), Enum' (Rep a)) =>
String -> JsonFormat e a
enumJsonFormat String
prefix =
let removePrefix :: String -> String
removePrefix String
s
| Just String
suffix <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
s = String
suffix
| Bool
otherwise = String
s
values :: [a]
values = forall a. (Generic a, Enum' (Rep a)) => [a]
genumDefault
names :: [Text]
names = forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
removePrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (ConNames (Rep a), Generic a) => a -> String
conNameOf) [a]
values
lookupText :: Text -> Maybe a
lookupText = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
names [a]
values
lookupValue :: a -> Maybe Text
lookupValue = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [a]
values [Text]
names
expectedValues :: String
expectedValues = String
"one of " forall a. [a] -> [a] -> [a]
++ (forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> String
unpack forall a b. (a -> b) -> a -> b
$ [Text]
names)
in forall a e.
Show a =>
(Text -> Maybe a) -> (a -> Maybe Text) -> String -> JsonFormat e a
enumMapJsonFormat Text -> Maybe a
lookupText a -> Maybe Text
lookupValue String
expectedValues
enumMapJsonFormat :: Show a => (Text -> Maybe a) -> (a -> Maybe Text) -> String -> JsonFormat e a
enumMapJsonFormat :: forall a e.
Show a =>
(Text -> Maybe a) -> (a -> Maybe Text) -> String -> JsonFormat e a
enumMapJsonFormat Text -> Maybe a
lookupText a -> Maybe Text
lookupValue String
expectedText = forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat forall a b. (a -> b) -> a -> b
$ forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor a -> Value
toJson ParseT e Identity a
fromJson
where
toJson :: a -> Value
toJson a
a =
case a -> Maybe Text
lookupValue a
a of
Maybe Text
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"unrecognized enum value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a
Just Text
t -> Text -> Value
Aeson.String Text
t
fromJson :: ParseT e Identity a
fromJson = do
Text
t <- forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
ABE.asText
case Text -> Maybe a
lookupText Text
t of
Maybe a
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABE.BadSchema [] forall a b. (a -> b) -> a -> b
$ forall err. String -> ErrorSpecifics err
ABE.FromAeson forall a b. (a -> b) -> a -> b
$
String
"expected " forall a. [a] -> [a] -> [a]
++ String
expectedText forall a. [a] -> [a] -> [a]
++ String
", not " forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
t
Just a
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v