Merge pull request #1332 from github/relocate-json-fields

Relocate ToJSONFields

semantic-diff.cabal

@@ -23,6 +23,7 @@ library
                      , Data.Functor.Classes.Eq.Generic
                      , Data.Functor.Classes.Pretty.Generic
                      , Data.Functor.Classes.Show.Generic
+                     , Data.JSON.Fields
                      , Data.Mergeable
                      , Data.Mergeable.Generic
                      , Data.Output

src/Category.hs

@@ -3,8 +3,10 @@
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 module Category where
 
+import Data.Aeson
 import Data.Hashable
-import Data.Text (Text)
+import Data.JSON.Fields
+import Data.Text (Text, pack)
 import Data.Text.Prettyprint.Doc
 import GHC.Generics
 
@@ -247,3 +249,6 @@ instance Hashable Category
 
 instance Pretty Category where
   pretty = pretty . show
+
+instance ToJSONFields Category where
+  toJSONFields c = ["category" .= case c of { Other s -> s ; _ -> pack (show c) }]

src/Data/JSON/Fields.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Data.JSON.Fields where
+
+import Data.Aeson
+import Data.Bifunctor.Join
+import Data.Foldable (toList)
+import Data.Proxy (Proxy(..))
+import Data.Union
+
+class ToJSONFields a where
+  toJSONFields :: KeyValue kv => a -> [kv]
+
+class ToJSONFields1 f where
+  toJSONFields1 :: (KeyValue kv, ToJSON a) => f a -> [kv]
+
+
+instance ToJSONFields a => ToJSONFields (Join (,) a) where
+  toJSONFields (Join (a, b)) = [ "before" .= object (toJSONFields a), "after" .= object (toJSONFields b) ]
+
+instance ToJSONFields a => ToJSONFields (Maybe a) where
+  toJSONFields = maybe [] toJSONFields
+
+instance ToJSON a => ToJSONFields [a] where
+  toJSONFields list = [ "children" .= list ]
+
+instance (Apply1 Foldable fs) => ToJSONFields1 (Union fs) where
+  toJSONFields1 = apply1 (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ])

src/Data/Output.hs

@@ -1,9 +1,20 @@
 module Data.Output where
 
+import Data.Aeson (Value, encode)
 import Data.ByteString (ByteString)
+import Data.ByteString.Lazy (toStrict)
+import Data.Map (Map)
+import Data.Semigroup
+import Data.Text (Text)
 
 class Monoid o => Output o where
   toOutput :: o -> ByteString
 
 instance Output ByteString where
   toOutput s = s
+
+instance Output (Map Text Value) where
+  toOutput = toStrict . (<> "\n") . encode
+
+instance Output [Value] where
+  toOutput = toStrict . (<> "\n") . encode

src/Data/Range.hs

@@ -6,6 +6,8 @@ module Data.Range
 , intersectsRange
 ) where
 
+import Data.Aeson
+import Data.JSON.Fields
 import Data.Semigroup
 import Data.Text.Prettyprint.Doc
 import GHC.Generics
@@ -37,3 +39,7 @@ instance Ord Range where
 
 instance Pretty Range where
   pretty (Range from to) = pretty from <> pretty '-' <> pretty to
+
+
+instance ToJSONFields Range where
+  toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]

src/Data/Record.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Data.Record where
 
+import Data.Aeson
+import Data.JSON.Fields
 import Data.Kind
 import Data.Semigroup
 import Data.Text.Prettyprint.Doc
@@ -81,3 +83,15 @@ instance ConstrainAll Pretty ts => Pretty (Record ts) where
     where collectPretty :: ConstrainAll Pretty ts => Record ts -> [Doc ann]
           collectPretty Nil = []
           collectPretty (first :. rest) = pretty first : collectPretty rest
+
+
+instance (ToJSONFields h, ToJSONFields (Record t)) => ToJSONFields (Record (h ': t)) where
+  toJSONFields (h :. t) = toJSONFields h <> toJSONFields t
+
+instance ToJSONFields (Record '[]) where
+  toJSONFields _ = []
+
+
+instance ToJSONFields (Record fs) => ToJSON (Record fs) where
+  toJSON = object . toJSONFields
+  toEncoding = pairs . mconcat . toJSONFields

src/Data/Span.hs

@@ -11,6 +11,7 @@ module Data.Span
 
 import Data.Aeson ((.=), (.:))
 import qualified Data.Aeson as A
+import Data.JSON.Fields
 import Data.Hashable (Hashable)
 import Data.Semigroup
 import Data.Text.Prettyprint.Doc
@@ -61,3 +62,7 @@ instance Pretty Pos where
 
 instance Pretty Span where
   pretty Span{..} = pretty spanStart <> pretty '-' <> pretty spanEnd
+
+
+instance ToJSONFields Span where
+  toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]

src/Decorators.hs

@@ -8,11 +8,11 @@ module Decorators
 import Data.Aeson
 import Data.ByteString.Char8 (ByteString, pack, unpack)
 import Data.Functor.Classes (Show1 (liftShowsPrec))
+import Data.JSON.Fields
 import Data.Proxy
 import Data.Text.Encoding (decodeUtf8)
 import Data.Union
 import GHC.Generics
-import Renderer.JSON
 import Term
 
 -- | Compute a 'ByteString' label for a 'Show1'able 'Term'.

src/Diff.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-}
 module Diff where
 
+import Data.Aeson
 import Data.Bifoldable
 import Data.Bifunctor
 import Data.Bitraversable
@@ -9,6 +10,7 @@ import Data.Functor.Both as Both
 import Data.Functor.Classes
 import Data.Functor.Classes.Pretty.Generic as Pretty
 import Data.Functor.Foldable hiding (fold)
+import Data.JSON.Fields
 import Data.Mergeable
 import Data.Record
 import Data.Union
@@ -161,3 +163,15 @@ instance Foldable f => Bifoldable (DiffF f) where
 instance Traversable f => Bitraversable (DiffF f) where
   bitraverse f g (Copy as r) = Copy <$> traverse f as <*> traverse g r
   bitraverse f _ (Patch p) = Patch <$> traverse (traverse f) p
+
+
+instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Diff f a) where
+  toJSON = object . toJSONFields
+  toEncoding = pairs . mconcat . toJSONFields
+
+instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Diff f a) where
+  toJSONFields = toJSONFields . unDiff
+
+instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (DiffF f a b) where
+  toJSONFields (Copy a f)  = toJSONFields a <> toJSONFields1 f
+  toJSONFields (Patch a) = toJSONFields a

src/Patch.hs

@@ -11,10 +11,12 @@ module Patch
 , mapPatch
 ) where
 
+import Data.Aeson
 import Data.Align
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Pretty.Generic
 import Data.Functor.Classes.Show.Generic
+import Data.JSON.Fields
 import Data.These
 import GHC.Generics
 
@@ -71,3 +73,9 @@ instance Pretty1 Patch where liftPretty = genericLiftPretty
 
 instance Pretty a => Pretty (Patch a) where
   pretty = liftPretty pretty prettyList
+
+
+instance ToJSONFields a => ToJSONFields (Patch a) where
+  toJSONFields (Insert a)    = [ "insert" .= object (toJSONFields a) ]
+  toJSONFields (Delete a)    = [ "delete" .= object (toJSONFields a) ]
+  toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ]

src/Renderer.hs

@@ -21,6 +21,7 @@ module Renderer
 import Data.Aeson (Value, (.=))
 import Data.ByteString (ByteString)
 import Data.Foldable (asum)
+import Data.JSON.Fields
 import qualified Data.Map as Map
 import Data.Output
 import Data.Syntax.Algebra (RAlgebra)

src/Renderer/JSON.hs

@@ -1,33 +1,18 @@
-{-# LANGUAGE DataKinds, GADTs, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Renderer.JSON
 ( renderJSONDiff
 , renderJSONTerm
-, ToJSONFields(..)
 ) where
 
-import Data.Aeson (ToJSON, toJSON, encode, object, (.=))
+import Data.Aeson (ToJSON, toJSON, object, (.=))
 import Data.Aeson as A hiding (json)
-import Data.Bifunctor.Join
 import Data.Blob
-import Data.ByteString.Lazy (toStrict)
 import Data.Foldable (toList)
 import Data.Functor.Both (Both)
 import qualified Data.Map as Map
-import Data.Output
-import Data.Proxy
-import Data.Record
-import Data.Semigroup ((<>))
-import Data.Text (pack, Text)
+import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8)
-import Data.Union
-import Diff
 import GHC.Generics
-import Info
 import Language
-import Patch
-import Syntax as S
-import Term
 
 --
 -- Diffs
@@ -41,87 +26,11 @@ renderJSONDiff blobs diff = Map.fromList
   , ("paths", toJSON (blobPath <$> toList blobs))
   ]
 
-instance Output (Map.Map Text Value) where
-  toOutput = toStrict . (<> "\n") . encode
-
-instance ToJSONFields a => ToJSONFields (Join (,) a) where
-  toJSONFields (Join (a, b)) = [ "before" .= object (toJSONFields a), "after" .= object (toJSONFields b) ]
-
-instance ToJSON a => ToJSON (Join (,) a) where
-  toJSON = toJSON . toList
-  toEncoding = foldable
-
-instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a))) => ToJSON (Diff f a) where
-  toJSON = object . toJSONFields
-  toEncoding = pairs . mconcat . toJSONFields
-
-instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) where
-  toJSON = object . toJSONFields
-  toEncoding = pairs . mconcat . toJSONFields
-
-class ToJSONFields a where
-  toJSONFields :: KeyValue kv => a -> [kv]
-
-instance (ToJSONFields h, ToJSONFields (Record t)) => ToJSONFields (Record (h ': t)) where
-  toJSONFields (h :. t) = toJSONFields h <> toJSONFields t
-
-instance ToJSONFields (Record '[]) where
-  toJSONFields _ = []
-
-instance ToJSONFields (Record fs) => ToJSON (Record fs) where
-  toJSON = object . toJSONFields
-  toEncoding = pairs . mconcat . toJSONFields
-
-instance ToJSONFields Range where
-  toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]
-
-instance ToJSONFields Category where
-  toJSONFields c = ["category" .= case c of { Other s -> s ; _ -> pack (show c) }]
-
-instance ToJSONFields Span where
-  toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
-
-instance ToJSONFields a => ToJSONFields (Maybe a) where
-  toJSONFields = maybe [] toJSONFields
-
-instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a) where
-  toJSONFields = toJSONFields . unTerm
-
-instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (TermF f a b) where
-  toJSONFields (In a f) = toJSONFields a <> toJSONFields f
-
-instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a))) => ToJSONFields (Diff f a) where
-  toJSONFields = toJSONFields . unDiff
-
-instance (ToJSONFields a, ToJSONFields (f b), ToJSONFields (f (Term f a))) => ToJSONFields (DiffF f a b) where
-  toJSONFields (Copy a f)  = toJSONFields a <> toJSONFields f
-  toJSONFields (Patch a) = toJSONFields a
-
-instance ToJSONFields a => ToJSONFields (Patch a) where
-  toJSONFields (Insert a)    = [ "insert" .= object (toJSONFields a) ]
-  toJSONFields (Delete a)    = [ "delete" .= object (toJSONFields a) ]
-  toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ]
-
-instance ToJSON a => ToJSONFields [a] where
-  toJSONFields list = [ "children" .= list ]
-
-instance ToJSON recur => ToJSONFields (Syntax recur) where
-  toJSONFields syntax = [ "children" .= toList syntax ]
-
-instance (Apply1 Foldable fs, ToJSON a) => ToJSONFields (Union fs a) where
-  toJSONFields = apply1 (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ])
-
-instance ToJSONFields (Union '[] a) where
-  toJSONFields _ = []
-
 data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a }
   deriving (Generic, Show)
 
 instance ToJSON a => ToJSON (File a) where
   toJSON File{..} = object [ "filePath" .= filePath, "language" .= fileLanguage, "programNode" .= fileContent ]
 
-instance Output [Value] where
-  toOutput = toStrict . (<> "\n") . encode
-
 renderJSONTerm :: ToJSON a => Blob -> a -> [Value]
 renderJSONTerm Blob{..} = pure . toJSON . File blobPath blobLanguage

src/Syntax.hs

@@ -3,10 +3,12 @@ module Syntax where
 
 import Data.Aeson
 import Data.Align.Generic
+import Data.Foldable (toList)
 import Data.Functor.Classes
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Pretty.Generic
 import Data.Functor.Classes.Show.Generic
+import Data.JSON.Fields
 import Data.Mergeable
 import Data.Text (Text)
 import GHC.Generics
@@ -123,3 +125,6 @@ extractLeafValue syntax = case syntax of
 instance Eq1 Syntax where liftEq = genericLiftEq
 instance Show1 Syntax where liftShowsPrec = genericLiftShowsPrec
 instance Pretty1 Syntax where liftPretty = genericLiftPretty
+
+instance ToJSONFields1 Syntax where
+  toJSONFields1 syntax = [ "children" .= toList syntax ]

src/Term.hs

@@ -15,12 +15,14 @@ module Term
 
 import Control.Comonad
 import Control.Comonad.Cofree.Class
+import Data.Aeson
 import Data.Bifoldable
 import Data.Bifunctor
 import Data.Bitraversable
 import Data.Functor.Classes
 import Data.Functor.Classes.Pretty.Generic as Pretty
 import Data.Functor.Foldable
+import Data.JSON.Fields
 import Data.Proxy
 import Data.Record
 import Data.Union
@@ -130,3 +132,14 @@ instance (Pretty1 f, Pretty a) => Pretty1 (TermF f a) where
 
 instance (Pretty1 f, Pretty a, Pretty b) => Pretty (TermF f a b) where
   pretty = liftPretty pretty prettyList
+
+
+instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Term f a) where
+  toJSON = object . toJSONFields
+  toEncoding = pairs . mconcat . toJSONFields
+
+instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Term f a) where
+  toJSONFields = toJSONFields . unTerm
+
+instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (TermF f a b) where
+  toJSONFields (In a f) = toJSONFields a <> toJSONFields1 f