diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,8 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.2.1...main) +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.3.0...main) + +## [v1.20.3.0](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.2.1...freckle-app-v1.20.3.0) + +Add `Freckle.App.TextualEnum` ## [v1.20.2.1](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.2.0...freckle-app-v1.20.2.1) diff --git a/freckle-app.cabal b/freckle-app.cabal --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -1,6 +1,6 @@ cabal-version: 1.22 name: freckle-app -version: 1.20.2.1 +version: 1.20.3.0 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -46,6 +46,7 @@ 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 @@ -147,6 +148,7 @@ resourcet >=1.2.6, scientist >=0.0.0.0, semigroupoids >=5.3.7, + servant-server >=0.19.2, template-haskell >=2.18.0.0, text >=1.2.5.0, time >=1.11.1.1, @@ -207,6 +209,7 @@ 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 @@ -243,7 +246,10 @@ http-types >=0.12.3, monad-validate >=1.3.0.0, nonempty-containers >=0.3.4.4, + path-pieces >=0.2.1, + persistent >=2.13.3.5, postgresql-simple >=0.6.4, + servant-server >=0.19.2, vector >=0.12.3.1, wai >=3.2.3, wai-extra >=3.1.13.0 diff --git a/library/Freckle/App/TextualEnum.hs b/library/Freckle/App/TextualEnum.hs new file mode 100644 --- /dev/null +++ b/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/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,6 @@ name: freckle-app -version: 1.20.2.1 +version: 1.20.3.0 + maintainer: Freckle Education category: Utils github: freckle/freckle-app @@ -128,6 +129,7 @@ - primitive - resource-pool >= 0.4.0.0 # defaultPoolConfig, etc - resourcet + - servant-server - scientist - semigroupoids - template-haskell @@ -167,7 +169,10 @@ - http-types - monad-validate - nonempty-containers + - path-pieces + - persistent - postgresql-simple + - servant-server - vector - wai - wai-extra diff --git a/tests/Freckle/App/TextualEnumSpec.hs b/tests/Freckle/App/TextualEnumSpec.hs new file mode 100644 --- /dev/null +++ b/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])