diff --git a/freckle-app/freckle-app.cabal b/freckle-app/freckle-app.cabal index b24e91a..ad295b5 100644 --- a/freckle-app/freckle-app.cabal +++ b/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 diff --git a/freckle-app/library/Freckle/App/TextualEnum.hs b/freckle-app/library/Freckle/App/TextualEnum.hs new file mode 100644 index 0000000..a53811f --- /dev/null +++ b/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 diff --git a/freckle-app/package.yaml b/freckle-app/package.yaml index a5486e7..a923084 100644 --- a/freckle-app/package.yaml +++ b/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 diff --git a/freckle-app/tests/Freckle/App/TextualEnumSpec.hs b/freckle-app/tests/Freckle/App/TextualEnumSpec.hs new file mode 100644 index 0000000..5cbe5b4 --- /dev/null +++ b/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])