Enum.hs

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)

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

-- |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 lookupText lookupValue expectedText = JsonFormat $ JsonProfunctor toJson fromJson
  where
    toJson a =
      case lookupValue a of
        Nothing -> error $ "unrecognized enum value " ++ show a -- eugh
        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