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 :: 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

-- |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 :: 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 -- eugh
        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