github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-27 00:44:57 +03:00
Code Issues Projects Releases Wiki Activity

Don't duplicate or drop fields

Browse Source
This commit is contained in:
Timothy Clem 2018-05-31 17:20:37 -07:00
parent 11c1ac39bb
commit 53e1ebf86e
1 changed files with 29 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
src/Data/JSON/Fields.hs
View File

@ -9,6 +9,7 @@ module Data.JSON.Fields
) where
import Data.Aeson
import qualified Data.Map as Map
import Data.Sum (Apply (..), Sum)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
@ -21,7 +22,11 @@ class ToJSONFields1 f where
toJSONFields1 :: (KeyValue kv, ToJSON a) => f a -> [kv]
default toJSONFields1 :: (KeyValue kv, ToJSON a, GToJSONFields1 (Rep1 f), GConstructorName1 (Rep1 f), Generic1 f) => f a -> [kv]
toJSONFields1 s = let r = from1 s in
"term" .= gconstructorName1 r : gtoJSONFields1 r
"term" .= gconstructorName1 r : Map.foldrWithKey m [] (gtoJSONFields1 r)
where
m _ [] acc = acc
m k [v] acc = (k .= v) : acc
m k vs acc = (k .= vs) : acc
instance ToJSONFields a => ToJSONFields (Join (,) a) where
toJSONFields (Join (a, b)) = [ "before" .= object (toJSONFields a), "after" .= object (toJSONFields b) ]
@ -85,7 +90,7 @@ instance (GConstructorName1 f, GConstructorName1 g) => GConstructorName1 (f :+:
-- | A typeclass to calculate a list of 'KeyValue's describing the record selector names and associated values on a datatype.
class GToJSONFields1 f where
gtoJSONFields1 :: (KeyValue kv, ToJSON a) => f a -> [kv]
gtoJSONFields1 :: (ToJSON a) => f a -> Map.Map Text [SomeJSON]
instance GToJSONFields1 f => GToJSONFields1 (M1 D c f) where
gtoJSONFields1 = gtoJSONFields1 . unM1
@ -94,10 +99,10 @@ instance GToJSONFields1 f => GToJSONFields1 (M1 C c f) where
gtoJSONFields1 = gtoJSONFields1 . unM1
instance GToJSONFields1 U1 where
gtoJSONFields1 _ = []
gtoJSONFields1 _ = mempty
instance (Selector c, GSelectorJSONValue1 f) => GToJSONFields1 (M1 S c f) where
gtoJSONFields1 m1 = gselectorJSONValue1 keyName (unM1 m1)
gtoJSONFields1 m1 = Map.fromList [gselectorJSONValue1 keyName (unM1 m1)]
where keyName = case selName m1 of
"" -> Nothing
n -> Just (Text.pack n)
@ -107,23 +112,38 @@ instance (GToJSONFields1 f, GToJSONFields1 g) => GToJSONFields1 (f :+: g) where
gtoJSONFields1 (R1 r) = gtoJSONFields1 r
instance (GToJSONFields1 f, GToJSONFields1 g) => GToJSONFields1 (f :*: g) where
gtoJSONFields1 (x :*: y) = gtoJSONFields1 x <> gtoJSONFields1 y
gtoJSONFields1 (x :*: y) = Map.unionWith (<>) (gtoJSONFields1 x) (gtoJSONFields1 y)
-- | A typeclass to retrieve the JSON 'Value' of a record selector.
class GSelectorJSONValue1 f where
gselectorJSONValue1 :: (KeyValue kv, ToJSON a) => Maybe Text -> f a -> [kv]
gselectorJSONValue1 :: (ToJSON a) => Maybe Text -> f a -> (Text, [SomeJSON])
instance GSelectorJSONValue1 Par1 where
gselectorJSONValue1 k x = [ fromMaybe "children" k .= unPar1 x]
gselectorJSONValue1 k x = (fromMaybe "children" k, [SomeJSON (unPar1 x)])
instance ToJSON1 f => GSelectorJSONValue1 (Rec1 f) where
gselectorJSONValue1 k x = [ fromMaybe "children" k .= toJSON1 (unRec1 x)]
gselectorJSONValue1 k x = (fromMaybe "children" k, [SomeJSON (SomeJSON1 (unRec1 x))])
instance ToJSON k => GSelectorJSONValue1 (K1 r k) where
gselectorJSONValue1 k x = [ fromMaybe "value" k .= unK1 x ]
gselectorJSONValue1 k x = (fromMaybe "value" k, [SomeJSON (unK1 x)])
-- TODO: Fix this orphan instance.
instance ToJSON ByteString where
toJSON = toJSON . Text.decodeUtf8
toEncoding = toEncoding . Text.decodeUtf8
data SomeJSON where
SomeJSON :: ToJSON a => a -> SomeJSON
instance ToJSON SomeJSON where
toJSON (SomeJSON a) = toJSON a
toEncoding (SomeJSON a) = toEncoding a
data SomeJSON1 where
SomeJSON1 :: (ToJSON1 f, ToJSON a) => f a -> SomeJSON1
instance ToJSON SomeJSON1 where
toJSON (SomeJSON1 fa) = toJSON1 fa
toEncoding (SomeJSON1 fa) = toEncoding1 fa