generic-aeson 0.1.1.1 → 0.2.0.0

raw patch · 5 files changed

+162/−71 lines, 5 filesdep +unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• README.md +24/−2
• generic-aeson.cabal +2/−1
• src/Generics/Generic/Aeson.hs +96/−61
• src/Generics/Generic/Aeson/Util.hs +28/−7

@@ -1,5 +1,17 @@ # Changelog +## 0.2.0.0++* Add `gtoJsonWithSettings` and `gparseJsonWithSettings` to customize+  the generated JSON, currently only to strip specified prefixes from+  record fields.+* Format Change: The behavior of Maybes was inconsistent and buggy,+  now we always map `Just` directly to the value, and `Nothing` to+  null if on the top level or in an unnamed field and remove the+  property if it's in a named field.+* Changed the type of `selNameT` to return a `Maybe Text` which will+  be `Nothing` instead of `""` (unnamed fields)+ #### 0.1.1.1  * Fix regression in implementation of `multipleConstructors` introduced in 0.1.1

@@ -5,7 +5,7 @@ The structure of the generated JSON is meant to be close to idiomatic JSON. This means: -* Enumerations are converted to JSON strings.+* Enumerations (data types containing constructors without fields) are converted to JSON strings.  * Record fields become JSON keys. @@ -15,6 +15,28 @@  * Multiple constructors are represented by keys. -* 'Maybe' values are either an absent key, or the value.+* `Maybe` values are either an absent key, or the value. +* Leading and trailing underscores are removed from constructor names and record fields+ See `tests/Main.hs` for more examples.+++## How does generic-aeson compare to the TH/Generics already present in aeson?++generic-aeson contains more special cases for creating more concise+and idiomatic json. If you're working with the JSON representation+directly generic-aeson should feel more natural.++## Will the generated format ever change?++Changing the format would incur a breaking change to every API that+uses generic-aeson so we must keep it intact.++If we find a bug where the fix changes the format we need to create a+new package or version the generation code.++## Schemas++[json-schema](http://hackage.haskell.org/package/json-schema) has+generic derivation of schemas that match the generic-aeson format.

@@ -1,5 +1,5 @@ name:                generic-aeson-version:             0.1.1.1+version:             0.2.0.0 synopsis:            Derivation of Aeson instances using GHC generics. description:         Derivation of Aeson instances using GHC generics. author:              Silk@@ -34,4 +34,5 @@     , mtl >= 2.0 && < 2.3     , tagged >= 0.2 && < 0.8     , text >= 0.11 && < 1.2+    , unordered-containers == 0.2.*     , vector == 0.10.*

@@ -33,6 +33,10 @@   , GtoJson (..)   , GfromJson (..)   , formatLabel+  , Settings (..)+  , defaultSettings+  , gtoJsonWithSettings+  , gparseJsonWithSettings   ) where  import Control.Applicative@@ -44,8 +48,9 @@ import Data.Text (Text) import GHC.Generics import Generics.Deriving.ConNames-import qualified Data.Text   as T-import qualified Data.Vector as V+import qualified Data.HashMap.Strict as H+import qualified Data.Text           as T+import qualified Data.Vector         as V  import Generics.Generic.Aeson.Util @@ -59,7 +64,7 @@   -- constructors). A functor is then converted to either a list   -- of values (for non-labeled fields) or a list of String/value   -- pairs (for labeled fields).-  gtoJSONf :: Bool -> Bool -> f a -> Either [Value] [(Text, Value)]+  gtoJSONf :: Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]  -- | Class for parsing the functors from "GHC.Generics" from JSON. -- You generally don't need to give any custom instances. Just add@@ -73,58 +78,71 @@   -- data type is an enumeration (only empty constructors). The third   -- is a function for parsing the recursive positions. A JSON value   -- is then parsed to either a functor, or a failure.-  gparseJSONf :: Bool -> Bool -> Bool -> StateT [Value] Parser (f a)+  gparseJSONf :: Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)  -- Void: Used for data types without constructors -- instance GJSON V1  -- Unit: Used for constructors without arguments instance GtoJson U1 where-  gtoJSONf _ _ U1 = Right []+  gtoJSONf _ _ _ U1 = Right [] instance GfromJson U1 where-  gparseJSONf _ _ _ = return U1+  gparseJSONf _ _ _ _ = return U1  -- | Convert any datatype with a 'Generic' instance to a JSON 'Value'.-gtoJson :: forall a. (Generic a, GtoJson (Rep a), ConNames (Rep a), GIsEnum (Rep a)) -        => a -> Value-gtoJson x =-  case gtoJSONf (multipleConstructors $ conNames x) (isEnum (Proxy :: Proxy a)) (from x) of+gtoJson+  :: forall a. (Generic a, GtoJson (Rep a), ConNames (Rep a), GIsEnum (Rep a))+  => a -> Value+gtoJson = gtoJsonWithSettings defaultSettings++gtoJsonWithSettings+  :: forall a. (Generic a, GtoJson (Rep a), ConNames (Rep a), GIsEnum (Rep a))+   => Settings -> a -> Value+gtoJsonWithSettings settings x =+  case gtoJSONf settings (multipleConstructors $ conNames x) (isEnum (Proxy :: Proxy a)) (from x) of     Left  [v] -> v     Left  _   -> error "The impossible happened: multiple returned values in gtoJSON."     Right _   -> error "The impossible happened: labeled values returned in gtoJSON."  -- | Parse any datatype with a 'Generic' instance from a JSON 'Value'.-gparseJson :: forall a. (Generic a, GfromJson (Rep a), ConNames (Rep a), GIsEnum (Rep a))-           => Value -> Parser a gparseJson+  :: forall a. (Generic a, GfromJson (Rep a), ConNames (Rep a), GIsEnum (Rep a))+  => Value -> Parser a+gparseJson = gparseJsonWithSettings defaultSettings++gparseJsonWithSettings+  :: forall a. (Generic a, GfromJson (Rep a), ConNames (Rep a), GIsEnum (Rep a))+  => Settings -> Value -> Parser a+gparseJsonWithSettings set   = fmap to-  . evalStateT (gparseJSONf (multipleConstructors $ conNames (undefined :: a)) False (isEnum (Proxy :: Proxy a)))+  . evalStateT (gparseJSONf set (multipleConstructors $ conNames (undefined :: a)) False (isEnum (Proxy :: Proxy a)))   . return  -- Structure type for constant values. instance (ToJSON c) => GtoJson (K1 a c) where-  gtoJSONf _ _ (K1 a) = Left [toJSON a]+  gtoJSONf _ _ _ (K1 a) = Left [toJSON a] instance (FromJSON c) => GfromJson (K1 a c) where-  gparseJSONf _ _ _   = lift . fmap K1 . parseJSON =<< pop+  gparseJSONf _ _ _ _   = lift . fmap K1 . parseJSON =<< pop  instance (GtoJson f, GtoJson g) => GtoJson (f :+: g) where-  gtoJSONf mc enm (L1 x) = gtoJSONf mc enm x-  gtoJSONf mc enm (R1 x) = gtoJSONf mc enm x+  gtoJSONf set mc enm (L1 x) = gtoJSONf set mc enm x+  gtoJSONf set mc enm (R1 x) = gtoJSONf set mc enm x instance (GfromJson f, GfromJson g) => GfromJson (f :+: g) where-  gparseJSONf mc smf enm  =  L1 <$> gparseJSONf mc smf enm-                        <|> R1 <$> gparseJSONf mc smf enm+  gparseJSONf set mc smf enm+    =  L1 <$> gparseJSONf set mc smf enm+   <|> R1 <$> gparseJSONf set mc smf enm  instance (GtoJson f, GtoJson g) => GtoJson (f :*: g) where-  gtoJSONf mc enm (x :*: y) =-    case (gtoJSONf mc enm x, gtoJSONf mc enm y) of+  gtoJSONf set mc enm (x :*: y) =+    case (gtoJSONf set mc enm x, gtoJSONf set mc enm y) of       (Left  xvs, Left  yvs) -> Left  (xvs ++ yvs)       (Right xvs, Right yvs) -> Right (xvs ++ yvs)       _                      -> error "The impossible happened: product of mixed label and non-label fields in GJSON instance for (:*:)." instance (GfromJson f, GfromJson g) => GfromJson (f :*: g) where-  gparseJSONf mc smf enm =+  gparseJSONf set mc smf enm =     do unless smf selFields-       (:*:) <$> gparseJSONf mc True enm <*> gparseJSONf mc True enm+       (:*:) <$> gparseJSONf set mc True enm <*> gparseJSONf set mc True enm     where       selFields =         do v <- pop@@ -133,25 +151,15 @@              Array vs   -> put (V.toList vs)              _          -> fail "Expected object or array in gparseJSONf for (:*:)." -instance (Selector c, ToJSON a) => GtoJson (M1 S c (K1 i (Maybe a))) where-  gtoJSONf _  _ (M1 (K1 Nothing )) = Right []-  gtoJSONf _  _ (M1 (K1 (Just x))) = Right [(selNameT (undefined :: M1 S c f p), toJSON x)]-instance (Selector c, FromJSON a) => GfromJson (M1 S c (K1 i (Maybe a))) where-  gparseJSONf mc smf enm =-    do (M1 (K1 x)) <- gparseJSONf mc smf enm :: StateT [Value] Parser (M1 S c (K1 i a) p)-       return (M1 (K1 (Just x)))-    <|>-    return (M1 (K1 Nothing))- instance GtoJson f => GtoJson (M1 D c f) where-  gtoJSONf a b (M1 x) = gtoJSONf a b x+  gtoJSONf set a b (M1 x) = gtoJSONf set a b x instance GfromJson f => GfromJson (M1 D c f) where-  gparseJSONf a b x = M1 <$> gparseJSONf a b x+  gparseJSONf set a b x = M1 <$> gparseJSONf set a b x  instance (Constructor c, GtoJson f) => GtoJson (M1 C c f) where-  gtoJSONf _  True  (M1 _) = Left [toJSON $ conNameT (undefined :: M1 C c f p)]-  gtoJSONf mc False (M1 x) =-    case gtoJSONf mc False x of+  gtoJSONf set _  True  (M1 _) = Left [toJSON $ conNameT set (undefined :: M1 C c f p)]+  gtoJSONf set mc False (M1 x) =+    case gtoJSONf set mc False x of       -- Single field constructors are not wrapped in an array.       Left  [v] -> Left [wrap v]       Left  vs  -> Left [wrap . Array $ V.fromList vs]@@ -160,46 +168,73 @@       wrap = if mc              then toObject                 . return-                . (conNameT (undefined :: M1 C c f p), )+                . (conNameT set (undefined :: M1 C c f p), )              else id instance (Constructor c, GfromJson f) => GfromJson (M1 C c f) where-  gparseJSONf mc smf True =+  gparseJSONf set mc smf True =     do str    <- pop        conStr <- lift (parseJSON str)-       let expectedConStr = conNameT (undefined :: M1 C c f p)+       let expectedConStr = conNameT set (undefined :: M1 C c f p)        unless (conStr == expectedConStr) $          fail $ "Error parsing enumeration: expected " ++ T.unpack expectedConStr ++ ", found " ++ T.unpack conStr ++ "."-       M1 <$> gparseJSONf mc smf True-  gparseJSONf mc smf False =-    do when mc (selProp "C" propName)-       M1 <$> gparseJSONf mc smf False+       M1 <$> gparseJSONf set mc smf True+  gparseJSONf set mc smf False =+    do+       when mc (selProp "C" propName)+       M1 <$> gparseJSONf set mc smf False     where-      propName = conNameT (undefined :: M1 C c f p)+      propName = case conNameT set (undefined :: M1 C c f p) of+        "" -> Nothing+        n  -> Just n  instance (Selector c, GtoJson f) => GtoJson (M1 S c f) where-  gtoJSONf mc enm (M1 x) =-    case gtoJSONf mc enm x of-      Left  [v] -> case selNameT (undefined :: M1 S c f p) of-        "" -> Left [v]-        n  -> Right [(n, v)]+  gtoJSONf set mc enm (M1 x) =+    case gtoJSONf set mc enm x of+      Left  [v] -> case selNameT set (undefined :: M1 S c f p) of+        Nothing -> Left [v]+        Just n  -> Right [(n, v)]       Left  _   -> error "The impossible happened: multiple returned values inside label in GJSON instance for S."       Right _   -> error "The impossible happened: label inside a label in GJSON instance for S." instance (Selector c, GfromJson f) => GfromJson (M1 S c f) where-  gparseJSONf mc smf enm =+  gparseJSONf set mc smf enm =     do selProp "S" propName-       M1 <$> gparseJSONf mc smf enm+       M1 <$> gparseJSONf set mc smf enm     where-      propName = selNameT (undefined :: M1 S c f p)+      propName = selNameT set (undefined :: M1 S c f p) -selProp :: Text -> Text -> StateT [Value] Parser ()+instance (Selector c, ToJSON a) => GtoJson (M1 S c (K1 i (Maybe a))) where+  gtoJSONf set   _  _   (M1 (K1 n@Nothing)) = case selNameT set (undefined :: M1 S c f p) of+    Nothing -> Left [toJSON n]+    Just _  -> Right []+  gtoJSONf set mc enm (M1 (K1 (Just x))) = gtoJSONf set mc enm (M1 (K1 x) :: (M1 S c (K1 i a)) p)+instance (Selector c, FromJSON a) => GfromJson (M1 S c (K1 i (Maybe a))) where+  gparseJSONf set mc smf enm =+    do (M1 (K1 x)) <- parser+       return (M1 (K1 (Just x)))+    <|>+    do case selNameT set (undefined :: M1 S c (K1 i a) p) of+         Nothing ->+           do o <- pop+              M1 . K1 <$> lift (parseJSON o)+         Just n  ->+           do o <- pop+              case o of+                Object h | H.member n h -> error impossible <$> parser+                         | otherwise    -> return $ M1 (K1 Nothing)+                _ -> lift $ typeMismatch "Object" (Array V.empty)+    where+      parser = (gparseJSONf set mc smf enm :: StateT [Value] Parser (M1 S c (K1 i a) p))+      impossible = "The impossible happened: parser succeeded after failing in GfromJson S Maybe"++selProp :: Text -> Maybe Text -> StateT [Value] Parser () selProp cname propName =   case propName of-    "" -> do o <- pop-             modify (o:)-    _  -> do o <- pop-             v <- lift (withObject ("Expected property " ++ show propName ++ " in object in gparseJSONf for " ++ show cname ++ ".")-                                   (.: propName) o)-             modify (v:)+    Nothing -> do o <- pop+                  modify (o:)+    Just p  -> do o <- pop+                  v <- lift (withObject ("Expected property " ++ show propName ++ " in object in gparseJSONf for " ++ show cname ++ ".")+                                        (.: p) o)+                  modify (v:)  pop :: MonadState [Value] m => m Value pop =

@@ -11,8 +11,11 @@   , conNameT   , selNameT   , module Generics.Generic.IsEnum+  , Settings (..)+  , defaultSettings   ) where +import Control.Monad ((<=<)) import Data.Char (toLower) import Data.Maybe (fromMaybe) import Data.Text (Text)@@ -21,17 +24,28 @@  import Generics.Generic.IsEnum -conNameT :: forall c (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a. Constructor c => t c f a -> Text-conNameT x = formatLabel . T.pack . conName $ x+conNameT :: forall c (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a. Constructor c => Settings -> t c f a -> Text+conNameT set x = formatLabel set . T.pack . conName $ x -selNameT :: forall s (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a. Selector s => t s f a -> Text-selNameT x = formatLabel . T.pack . selName $ x+selNameT :: forall s (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a. Selector s => Settings -> t s f a -> Maybe Text+selNameT set x = case formatLabel set . T.pack . selName $ x of+  "" -> Nothing+  n  -> Just n  -- | Lowercases the first letter and strips leading and trailing underscores.-formatLabel :: Text -> Text-formatLabel = firstLetterToLower-            . stripLeadingAndTrailingUnderscore+formatLabel :: Settings -> Text -> Text+formatLabel set+  = firstLetterToLower+  . stripLeadingAndTrailingUnderscore+  . stripPref set +stripPref :: Settings -> Text -> Text+stripPref set s = (maybe id (\p t -> fromMaybe t . (disallowEmpty <=< T.stripPrefix (T.pack p)) $ t) . stripPrefix) set s+  where+    disallowEmpty x+      | T.null  x = Just s+      | otherwise = Just x+ stripLeadingAndTrailingUnderscore :: Text -> Text stripLeadingAndTrailingUnderscore = stripLeadingUnderscore                                   . stripTrailingUnderscore@@ -50,3 +64,10 @@  multipleConstructors :: [a] -> Bool multipleConstructors = (> 1) . length++-- Use String over Text so OverloadedStrings isn't necessary+data Settings = Settings { stripPrefix :: Maybe String }+  deriving Show++defaultSettings :: Settings+defaultSettings = Settings { stripPrefix = Nothing }