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