freckle-app 1.20.2.1 → 1.20.3.0
raw patch · 5 files changed
+229/−3 lines, 5 filesdep +servant-server
Dependencies added: servant-server
Files
- CHANGELOG.md +5/−1
- freckle-app.cabal +7/−1
- library/Freckle/App/TextualEnum.hs +116/−0
- package.yaml +6/−1
- tests/Freckle/App/TextualEnumSpec.hs +95/−0
CHANGELOG.md view
@@ -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)
freckle-app.cabal view
@@ -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
+ library/Freckle/App/TextualEnum.hs view
@@ -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
package.yaml view
@@ -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
+ tests/Freckle/App/TextualEnumSpec.hs view
@@ -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])