by-other-names 1.2.0.1 → 1.2.1.0

raw patch · 4 files changed

+142/−44 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• by-other-names.cabal +1/−1
• lib/ByOtherNames/Aeson.hs +111/−43
• tests/tests.hs +25/−0

@@ -1,4 +1,9 @@ +1.2.1.0+=======++- JSONEnum: FromJSON / ToJSON instances for enum-like types without fields.+ 1.2.0.1 ======= 

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                by-other-names-version:             1.2.0.1+version:             1.2.1.0 synopsis:            Give aliases to record fields.  description:         Give aliases to record fields.

@@ -2,20 +2,17 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE LambdaCase #-}  -- | A 'Rubric' for JSON serialization using Aeson, along with some helper -- newtypes and re-exports.@@ -65,16 +62,39 @@ -- :} -- -- Some limitations:--- +-- -- - Fields in branches of sum types can't have selectors. When there is more than one field in a branch, they are parsed as a JSON Array.--- --- - For sum types, only the "object with a single key consisting in the branch tag" style of serialization is supported. --+-- - The "object with a single key consisting in the branch tag" style of serialization is used.+--+-- Sometimes we have enum-like sum types without any fields, and want to+-- serialize them to simple JSON strings, instead of to objects. In that case,+-- we can do the following:+--+-- >>> :{+-- data Enumy+--   = Xx+--   | Yy+--   | Zz+--   deriving (Read, Show, Eq, Generic)+--   deriving (FromJSON, ToJSON) via (JSONEnum Enumy)+-- instance Aliased JSON Enumy where+--   aliases =+--     aliasListBegin+--       $ alias @"Xx" "x"+--       $ alias @"Yy" "y"+--       $ alias @"Zz" "z"+--       $ aliasListEnd+-- :}+--+--+ module ByOtherNames.Aeson   ( -- * JSON helpers     JSONRubric (..),     JSONRecord (..),     JSONSum (..),+    JSONEnum (..),      -- * Re-exports from ByOtherNames     Aliased (aliases),@@ -89,15 +109,16 @@ where  import ByOtherNames-import Control.Applicative import Data.Aeson+import Data.Aeson.Key (fromText, toText) import Data.Aeson.Types+import Data.Foldable import Data.Functor.Compose import Data.Kind+import Data.Proxy+import Data.Void import GHC.Generics import GHC.TypeLits-import Data.Proxy-import Data.Foldable  -- | Aliases for JSON serialization fall under this 'Rubric'. -- The constructor 'JSON' is used as a type, with DataKinds.@@ -121,41 +142,53 @@ type JSONSum :: Symbol -> Type -> Type newtype JSONSum objectName r = JSONSum r +-- | Helper newtype for deriving 'FromJSON' and 'ToJSON' for enum-like sum types,+-- using DerivingVia. --+-- Each constructor is serialized to a JSON string.+type JSONEnum :: Type -> Type+newtype JSONEnum r = JSONEnum r+ ---instance (KnownSymbol objectName, Aliased JSON r, GSum FromJSON (Rep r)) => FromJSON (JSONSum objectName r) where+--+instance (Aliased JSON r, GSum FromJSON (Rep r)) => FromJSON (JSONEnum r) where   parseJSON v =-    let parsers = gToSum @FromJSON (aliases @JSONRubric @JSON @r) -          (\a -> \case -              ZeroSlots v -> BranchParser \o -> do-                Null :: Value <- o .: a-                pure v-              SingleSlot p -> BranchParser \o -> do-                value <- o .: a-                runProductInBranchParser1 p value-              ManySlots p -> BranchParser \o -> do-                valueList <- o .: a-                (prod, _) <- runProductInBranchParser p valueList-                pure prod-            ) -          (ProductInBranchParser1 parseJSON) -          (ProductInBranchParser \case -            [] -> parseFail "not enough field values for branch"-            v : vs -> do-              r <- parseJSON v-              pure (r, vs))-        parserForObject o = asum $ fmap (($ o) . runBranchParser) parsers-     in JSONSum . to <$> withObject (symbolVal (Proxy @objectName)) parserForObject v-newtype BranchParser v = BranchParser { runBranchParser :: Object -> Parser v}-  deriving stock Functor+    let parsers =+          gToSum @FromJSON+            (aliases @JSONRubric @JSON @r)+            ( \a -> \case+                ZeroSlots x -> EnumBranchParser \case+                  String a' | a == fromText a' -> pure x+                  _ -> mempty+                SingleSlot _ -> EnumBranchParser mempty+                ManySlots _ -> EnumBranchParser mempty+            )+            Proxy+            Proxy+        parserForValue v = asum $ fmap (($ v) . runEnumBranchParser) parsers+     in JSONEnum . to <$> parserForValue v -newtype ProductInBranchParser1 v = ProductInBranchParser1 { runProductInBranchParser1 :: Value -> Parser v }-  deriving stock Functor-  deriving Applicative via (Compose ((->) Value) Parser)+newtype EnumBranchParser v = EnumBranchParser {runEnumBranchParser :: Value -> Parser v}+  deriving stock (Functor) -newtype ProductInBranchParser v = ProductInBranchParser { runProductInBranchParser :: [Value] -> Parser (v, [Value]) }-  deriving stock Functor+instance (Aliased JSON r, GSum Impossible (Rep r)) => ToJSON (JSONEnum r) where+  toJSON (JSONEnum o) =+    let (key, slots) = gFromSum @Impossible @(Rep r) @Key @Value @Value (aliases @JSONRubric @JSON @r) absurd (from @r o)+     in case slots of+          [] -> String (toText key)+          [_] -> error "never happens"+          _ -> error "never happens" +newtype BranchParser v = BranchParser {runBranchParser :: Object -> Parser v}+  deriving stock (Functor)++newtype ProductInBranchParser1 v = ProductInBranchParser1 {runProductInBranchParser1 :: Value -> Parser v}+  deriving stock (Functor)+  deriving (Applicative) via (Compose ((->) Value) Parser)++newtype ProductInBranchParser v = ProductInBranchParser {runProductInBranchParser :: [Value] -> Parser (v, [Value])}+  deriving stock (Functor)+ instance Applicative ProductInBranchParser where   pure v = ProductInBranchParser \vs -> pure (v, vs)   ProductInBranchParser left <*> ProductInBranchParser right =@@ -167,15 +200,50 @@  -- --+class (x ~ Void) => Impossible x++instance (x ~ Void) => Impossible x++instance (KnownSymbol objectName, Aliased JSON r, GSum FromJSON (Rep r)) => FromJSON (JSONSum objectName r) where+  parseJSON v =+    let parsers =+          gToSum @FromJSON+            (aliases @JSONRubric @JSON @r)+            ( \a -> \case+                ZeroSlots v -> BranchParser \o -> do+                  Null :: Value <- o .: a+                  pure v+                SingleSlot p -> BranchParser \o -> do+                  value <- o .: a+                  runProductInBranchParser1 p value+                ManySlots p -> BranchParser \o -> do+                  valueList <- o .: a+                  (prod, _) <- runProductInBranchParser p valueList+                  pure prod+            )+            (ProductInBranchParser1 parseJSON)+            ( ProductInBranchParser \case+                [] -> parseFail "not enough field values for branch"+                v : vs -> do+                  r <- parseJSON v+                  pure (r, vs)+            )+        parserForObject o = asum $ fmap (($ o) . runBranchParser) parsers+     in JSONSum . to <$> withObject (symbolVal (Proxy @objectName)) parserForObject v++--+-- instance (KnownSymbol objectName, Aliased JSON r, GRecord FromJSON (Rep r)) => FromJSON (JSONRecord objectName r) where   parseJSON v =-    let FieldParser parser = gToRecord @FromJSON (aliases @JSONRubric @JSON @r) -          (\fieldName -> FieldParser (\o ->explicitParseField parseJSON o fieldName))+    let FieldParser parser =+          gToRecord @FromJSON+            (aliases @JSONRubric @JSON @r)+            (\fieldName -> FieldParser (\o -> explicitParseField parseJSON o fieldName))         objectName = symbolVal (Proxy @objectName)      in JSONRecord . to <$> withObject objectName parser v+ newtype FieldParser a = FieldParser (Object -> Parser a)   deriving (Functor, Applicative) via ((->) Object `Compose` Parser)-  -- --

@@ -18,6 +18,7 @@     JSONRecord (..),     JSONRubric (JSON),     JSONSum (..),+    JSONEnum (..),     alias,     aliasListBegin,     aliasListEnd,@@ -127,6 +128,22 @@     ("Eex", [typeRep (Proxy @Int)])   ] ++data Enumy+  = Xx+  | Yy+  | Zz+  deriving (Read, Show, Eq, Generic)+  deriving (FromJSON, ToJSON) via (JSONEnum Enumy)+instance Aliased JSON Enumy where+  aliases =+    aliasListBegin+      $ alias @"Xx" "x"+      $ alias @"Yy" "y"+      $ alias @"Zz" "z"+      $ aliasListEnd++ -- >>> enumSummy  roundtrip :: forall t. (Eq t, Show t, FromJSON t, ToJSON t) => t -> IO ()@@ -175,6 +192,14 @@           testCase "d" $ roundtrip $ Dd 'f' True 0,           testCase "e" $ roundtrip $ Ee 3         ],+      testGroup+        "enumRoundtrip"+        [+          testCase "x" $ roundtrip Xx,+          testCase "y" $ roundtrip Yy,+          testCase "z" $ roundtrip Zz+        ]+       ,       testGroup         "enums"         [ testCase "prod typeReps" $ assertEqual "prod typeReps match" expectedEnumFoo enumFoo,