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)

-- |For some type @a@ which represents an enumeration (i.e. all nullary constructors) generate a 'JsonFormat' which maps that type to strings in JSON.
--
-- Each constructor will be mapped to a string with the same value as its name with some prefix removed.
--
-- For example, given:
--
-- > data MyEnum = MyEnumFoo | MyEnumBar
-- > myEnumFormat :: JsonFormat e MyEnum
-- > myEnumFormat = enumJsonFormat "MyEnum"
--
-- Then:
--
-- > toJsonWithFormat myEnumFormat MyEnumFoo == Aeson.String "Foo"
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

-- |For some type @a@ which bidirectional mapping functions can be provided, produce a 'JsonFormat' which maps to JSON strings.
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 -- eugh
        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