Add TextualEnum newtype wrapper

This is an experiment that I'm putting out for review to see what the team
thinks. I won't feel bad if we don't like it.

**What is it?**

`TextualEnum` is a `newtype` wrapper meant to provide a lot of boilerplate
serialization/deserialization instances that we keep defining and redefining as
we introduce new types and services.

**How's it work?**

The core idea is that if you can give your type an `Enum` instance, a `Bounded`
instance, and a way to convert to text, then that should be enough to provide
string-type (i.e. textual) representations of it.

So `toText` tells us how to serialize the value, and we can look through the
`Bounded`/`Enum` instance values to parse it "from text".

`toText` is preferable from `fromText` because, for bounded/enums, totality is
straightforward.

**EnumName**

I've also included `EnumName` because we've started introducing codec/schema
definitions that can be named.

**Example**

You can see the specs (`PrimaryColor`) for an example.

**Benefits**

This should reduce a great deal of boilerplate, and, if used, will reduce a lot
of ad-hoc-ry that exists across our in-the-wild definitions.

freckle-app/freckle-app.cabal

@@ -52,6 +52,7 @@ library
       Freckle.App.Test.Properties.PathPiece
       Freckle.App.Test.Properties.PersistValue
       Freckle.App.Test.Yesod
+      Freckle.App.TextualEnum
       Freckle.App.Wai
       Freckle.App.Yesod
       Freckle.App.Yesod.Routes
@@ -152,6 +153,7 @@ library
     , resourcet
     , scientist
     , semigroupoids
+    , servant-server
     , template-haskell
     , text
     , time
@@ -210,6 +212,7 @@ test-suite spec
       Freckle.App.Test.Properties.JSONSpec
       Freckle.App.Test.Properties.PathPieceSpec
       Freckle.App.Test.Properties.PersistValueSpec
+      Freckle.App.TextualEnumSpec
       Freckle.App.WaiSpec
       Spec
       Paths_freckle_app
@@ -246,7 +249,10 @@ test-suite spec
     , http-types
     , monad-validate
     , nonempty-containers
+    , path-pieces
+    , persistent
     , postgresql-simple
+    , servant-server
     , vector
     , wai
     , wai-extra

freckle-app/library/Freckle/App/TextualEnum.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Typical instances for enumerated data types with textual representation
+module Freckle.App.TextualEnum
+  ( TextualEnum (..)
+  , EnumValue (..)
+  , EnumName (..)
+  , enums
+  , fromText
+  , prop_roundTripEnumText
+  ) where
+
+import Freckle.App.Prelude
+
+import Autodocodec
+import Control.Lens hiding (elements)
+import Control.Monad (mzero)
+import Data.Aeson
+import Data.Csv qualified as CSV
+import Data.Dynamic (Typeable)
+import Data.List.NonEmpty qualified as NE
+import Data.OpenApi
+import Data.Text.Encoding qualified as T
+import Database.Persist.Sql
+  ( PersistField (..)
+  , PersistFieldSql (..)
+  , SqlType (..)
+  )
+import Servant
+import Test.QuickCheck (Arbitrary (..), elements)
+import Web.PathPieces
+
+class EnumValue a where
+  -- | Convert a 'TextualEnum' to 'Text'
+  toText :: a -> Text
+
+class EnumName a where
+  -- | Name of a 'TextualEnum', used for naming schemas
+  enumName :: Proxy a -> Text
+
+-- | Wrapper around enums
+--
+-- N.B. This should not be used for "enormous" enumerations. It's primary purpose
+-- is to provide standard instances for discriminated-union-defined enums.
+newtype TextualEnum a = TextualEnum {enumValue :: a}
+  deriving newtype (Eq, Show, Ord, Generic)
+
+-- | All values of a 'TextualEnum'
+enums :: (Bounded a, Enum a) => NonEmpty (TextualEnum a)
+enums = fmap TextualEnum $ minBound NE.:| drop 1 [minBound .. maxBound]
+
+-- | Parse a 'TextualEnum' from 'Text'
+fromText :: (EnumValue a, Bounded a, Enum a) => Text -> Maybe (TextualEnum a)
+fromText txt = find ((== txt) . toText . enumValue) enums
+
+instance EnumValue a => ToJSON (TextualEnum a) where
+  toJSON = toJSON . toText . enumValue
+  toEncoding = toEncoding . toText . enumValue
+
+instance (EnumValue a, Bounded a, Enum a) => FromJSON (TextualEnum a) where
+  parseJSON = withText "TextualEnum" $ maybe mzero pure . fromText
+
+instance (Bounded a, Enum a) => Arbitrary (TextualEnum a) where
+  arbitrary = elements $ toList enums
+
+instance (EnumValue a, Bounded a, Enum a) => PathPiece (TextualEnum a) where
+  toPathPiece = toPathPiece . toText . enumValue
+  fromPathPiece = fromText
+
+instance EnumValue a => CSV.ToField (TextualEnum a) where
+  toField = CSV.toField . toText . enumValue
+
+instance (EnumValue a, Bounded a, Enum a) => CSV.FromField (TextualEnum a) where
+  parseField = maybe mzero pure . fromText . T.decodeUtf8
+
+instance
+  (Bounded a, Enum a, EnumValue a, Typeable a, EnumName a)
+  => ToSchema (TextualEnum a)
+  where
+  declareNamedSchema = pure . NamedSchema (Just $ enumName $ Proxy @a) . enumOptions
+   where
+    enumOptions _ =
+      mempty
+        & type_ ?~ OpenApiString
+        & enum_ ?~ (toJSON . toText . enumValue <$> toList (enums @a))
+        & example ?~ (toJSON . toText . enumValue $ NE.head (enums @a))
+
+instance (Bounded a, Enum a, EnumValue a) => ToParamSchema (TextualEnum a) where
+  toParamSchema _ =
+    mempty
+      & type_ ?~ OpenApiString
+      & enum_ ?~ (toJSON . toText . enumValue <$> toList (enums @a))
+      & example ?~ (toJSON . toText . enumValue $ NE.head (enums @a))
+
+instance (Bounded a, Enum a, EnumValue a, Eq a) => HasCodec (TextualEnum a) where
+  codec = stringConstCodec $ (id &&& (toText . enumValue)) <$> enums @a
+
+instance (Bounded a, Enum a, EnumValue a) => PersistField (TextualEnum a) where
+  toPersistValue = toPersistValue . toText . enumValue
+  fromPersistValue =
+    maybe (Left "Not member of enumeration") Right . fromText <=< fromPersistValue
+
+instance (Bounded a, Enum a, EnumValue a) => PersistFieldSql (TextualEnum a) where
+  sqlType _ = SqlString
+
+instance (Bounded a, Enum a, EnumValue a) => FromHttpApiData (TextualEnum a) where
+  parseUrlPiece =
+    maybe (Left "Not member of enumeration") Right . fromText
+
+instance EnumValue a => ToHttpApiData (TextualEnum a) where
+  toUrlPiece = toText . enumValue
+
+-- | Test that enum instances are coherent
+prop_roundTripEnumText
+  :: (Bounded a, Enum a, EnumValue a, Eq a) => TextualEnum a -> Bool
+prop_roundTripEnumText a = fromText (toText $ enumValue a) == Just a

freckle-app/package.yaml

@@ -1,5 +1,6 @@
 name: freckle-app
 version: 1.20.2.1
+
 maintainer: Freckle Education
 category: Utils
 github: freckle/freckle-app
@@ -128,6 +129,7 @@ library:
     - primitive
     - resource-pool >= 0.4.0.0 # defaultPoolConfig, etc
     - resourcet
+    - servant-server
     - scientist
     - semigroupoids
     - template-haskell
@@ -167,7 +169,10 @@ tests:
       - http-types
       - monad-validate
       - nonempty-containers
+      - path-pieces
+      - persistent
       - postgresql-simple
+      - servant-server
       - vector
       - wai
       - wai-extra

freckle-app/tests/Freckle/App/TextualEnumSpec.hs

@@ -0,0 +1,95 @@
+module Freckle.App.TextualEnumSpec
+  ( spec
+  ) where
+
+import Freckle.App.Prelude
+
+import Data.Aeson qualified as JSON
+import Data.Csv qualified as CSV
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Database.Persist.Sql qualified as Sql
+import Freckle.App.Test.Properties.JSON
+import Freckle.App.Test.Properties.PathPiece
+import Freckle.App.Test.Properties.PersistValue
+import Freckle.App.TextualEnum
+import Servant qualified
+import Test.Hspec
+import Test.QuickCheck
+import Web.PathPieces qualified as Path
+
+data PrimaryColor
+  = Red
+  | Blue
+  | Yellow
+  deriving stock (Bounded, Enum, Eq, Show)
+  deriving
+    ( CSV.ToField
+    , CSV.FromField
+    , JSON.ToJSON
+    , JSON.FromJSON
+    , Servant.FromHttpApiData
+    , Servant.ToHttpApiData
+    , Path.PathPiece
+    , Sql.PersistField
+    , Arbitrary
+    )
+    via TextualEnum PrimaryColor
+
+instance EnumValue PrimaryColor where
+  toText = \case
+    Red -> "red"
+    Blue -> "blue"
+    Yellow -> "yellow"
+
+data BadExample
+  = Okay
+  | Conflict1
+  | Conflict2
+  deriving stock (Bounded, Enum, Eq, Show)
+
+instance EnumValue BadExample where
+  toText = \case
+    Okay -> "ok"
+    Conflict1 -> "conflict"
+    Conflict2 -> "conflict"
+
+spec :: Spec
+spec = do
+  describe "TextualEnum" $ do
+    describe "JSON" $
+      it "round trips" $
+        property $
+          prop_roundTripJSON @PrimaryColor
+
+    describe "PathPiece" $
+      it "round trips" $
+        property $
+          prop_roundTripPathPiece @PrimaryColor
+
+    describe "HttpApiData" $
+      it "round trips" $
+        property $
+          \(e :: PrimaryColor) -> Servant.parseUrlPiece (Servant.toUrlPiece e) == Right e
+
+    describe "PersistValue" $
+      it "round trips" $
+        property $
+          prop_roundTripPersistValue @PrimaryColor
+
+    describe "CSV" $
+      it "round trips" $
+        property $ \(e :: PrimaryColor) ->
+          CSV.runParser (CSV.parseField $ CSV.toField e) == Right e
+
+    describe "prop_roundTripEnumText" $ do
+      it "holds for a well defined toText" $
+        property $
+          prop_roundTripEnumText @PrimaryColor
+
+      it "does not hold when toText doesn't map to distinct values" $
+        any (not . prop_roundTripEnumText @BadExample) enums
+
+    describe "enums" $ do
+      it "returns all values" $
+        enums @PrimaryColor
+          `shouldBe` fmap TextualEnum (Red :| [Blue, Yellow])