diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 32c75c673..624f31eef 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -54,6 +54,7 @@ library , Syntax , Term , Term.Arbitrary + , Term.Instances , TreeSitter build-depends: base >= 4.8 && < 5 , aeson diff --git a/src/Data/Record.hs b/src/Data/Record.hs index cd8d3df9f..0fb1a2ea1 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -7,6 +7,8 @@ import Test.QuickCheck import Category import Range import SourceSpan +import Data.Aeson +import Data.Aeson.Types -- | A type alias for HasField constraints commonly used throughout semantic-diff. @@ -61,6 +63,12 @@ instance (Show h, Show (Record t)) => Show (Record (h ': t)) where instance Show (Record '[]) where showsPrec n RNil = showParen (n > 0) ("RNil" <>) +instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (Record (a ': b ': c ': d ': '[])) where + toJSON (RCons a (RCons b (RCons c (RCons d RNil)))) = toJSONList [toJSON a, toJSON b, toJSON c, toJSON d] + +instance ToJSON (Record '[]) where + toJSON _ = emptyArray + instance (Eq h, Eq (Record t)) => Eq (Record (h ': t)) where RCons h1 t1 == RCons h2 t2 = h1 == h2 && t1 == t2 diff --git a/src/Diffing.hs b/src/Diffing.hs index 919a37060..4dae1d903 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -32,7 +32,7 @@ import Term import TreeSitter import Text.Parser.TreeSitter.Language import qualified Data.Text as T -import Data.Aeson (toJSON, toEncoding) +import Data.Aeson (ToJSON, toJSON, toEncoding) import Data.Aeson.Encoding (encodingToLazyByteString) -- | Given a parser and renderer, diff two sources and return the rendered @@ -127,7 +127,7 @@ diffCostWithCachedTermCosts diff = unCost $ case runFree diff of Pure patch -> sum (cost . extract <$> patch) -- | Returns a rendered diff given a parser, diff arguments and two source blobs. -textDiff :: (DefaultFields fields, HasField fields Cost) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO Output +textDiff :: (ToJSON (Record fields), DefaultFields fields, HasField fields Cost) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO Output textDiff parser arguments = diffFiles parser $ case format arguments of Split -> split Patch -> patch @@ -143,7 +143,7 @@ truncatedDiff arguments sources = pure $ case format arguments of Summary -> SummaryOutput mempty -- | Prints a rendered diff to stdio or a filepath given a parser, diff arguments and two source blobs. -printDiff :: (DefaultFields fields, HasField fields Cost) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO () +printDiff :: (ToJSON (Record fields), DefaultFields fields, HasField fields Cost) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO () printDiff parser arguments sources = do rendered <- textDiff parser arguments sources let renderedText = case rendered of diff --git a/src/Info.hs b/src/Info.hs index f456aabcf..3e66c85ec 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -7,9 +7,10 @@ import Category import Range import SourceSpan import Test.QuickCheck +import Data.Aeson newtype Cost = Cost { unCost :: Int } - deriving (Eq, Num, Ord, Show) + deriving (Eq, Num, Ord, Show, ToJSON) characterRange :: HasField fields Range => Record fields -> Range characterRange = getField diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 3bac15fea..7263e39e0 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -22,7 +22,7 @@ import Term import qualified Data.Map as Map -- | Render a diff to a string representing its JSON. -json :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) +json :: (ToJSON (Record fields), HasField fields Category, HasField fields Range) => Renderer (Record fields) json blobs diff = JSONOutput $ Map.fromList [ ("rows", toJSON (annotateRows (alignDiff (source <$> blobs) diff))), ("oids", toJSON (oid <$> blobs)), @@ -32,7 +32,7 @@ json blobs diff = JSONOutput $ Map.fromList [ -- | A numbered 'a'. newtype NumberedLine a = NumberedLine (Int, a) -instance (HasField fields Category, HasField fields Range) => ToJSON (NumberedLine (SplitSyntaxDiff leaf fields)) where +instance (ToJSON leaf, ToJSON (Record fields), HasField fields Category, HasField fields Range) => ToJSON (NumberedLine (SplitSyntaxDiff leaf fields)) where toJSON (NumberedLine (n, a)) = object (lineFields n a (getRange a)) toEncoding (NumberedLine (n, a)) = pairs $ mconcat (lineFields n a (getRange a)) @@ -51,7 +51,7 @@ instance ToJSON a => ToJSON (Join These a) where instance ToJSON a => ToJSON (Join (,) a) where toJSON (Join (a, b)) = A.Array . Vector.fromList $ toJSON <$> [ a, b ] -instance (HasField fields Category, HasField fields Range) => ToJSON (SplitSyntaxDiff leaf fields) where +instance (ToJSON leaf, ToJSON (Record fields), HasField fields Category, HasField fields Range) => ToJSON (SplitSyntaxDiff leaf fields) where toJSON splitDiff = case runFree splitDiff of (Free (info :< syntax)) -> object (termFields info syntax) (Pure patch) -> object (patchFields patch) @@ -59,11 +59,13 @@ instance (HasField fields Category, HasField fields Range) => ToJSON (SplitSynta (Free (info :< syntax)) -> pairs $ mconcat (termFields info syntax) (Pure patch) -> pairs $ mconcat (patchFields patch) -instance (HasField fields Category, HasField fields Range) => ToJSON (SyntaxTerm leaf fields) where - toJSON term | (info :< syntax) <- runCofree term = object (termFields info syntax) - toEncoding term | (info :< syntax) <- runCofree term = pairs $ mconcat (termFields info syntax) +instance (ToJSON (Record fields), ToJSON leaf, HasField fields Category, HasField fields Range) => ToJSON (SyntaxTerm leaf fields) where + toJSON term | + (info :< syntax) <- runCofree term = object (termFields info syntax) + toEncoding term | + (info :< syntax) <- runCofree term = pairs $ mconcat (termFields info syntax) -lineFields :: (HasField fields Category, HasField fields Range) => KeyValue kv => Int -> SplitSyntaxDiff leaf fields -> Range -> [kv] +lineFields :: (ToJSON leaf, ToJSON (Record fields), HasField fields Category, HasField fields Range) => KeyValue kv => Int -> SplitSyntaxDiff leaf fields -> Range -> [kv] lineFields n term range = [ "number" .= n , "terms" .= [ term ] , "range" .= range @@ -76,12 +78,14 @@ termFields :: (ToJSON recur, KeyValue kv, HasField fields Category, HasField fie [kv] termFields info syntax = "range" .= characterRange info : "category" .= category info : syntaxToTermField syntax -patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (SyntaxTerm leaf fields) -> [kv] +patchFields :: (ToJSON (Record fields), ToJSON leaf, KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (SyntaxTerm leaf fields) -> [kv] patchFields patch = case patch of SplitInsert term -> fields "insert" term SplitDelete term -> fields "delete" term SplitReplace term -> fields "replace" term - where fields kind term | (info :< syntax) <- runCofree term = "patch" .= T.pack kind : termFields info syntax + where + fields kind term | + (info :< syntax) <- runCofree term = "patch" .= T.pack kind : termFields info syntax syntaxToTermField :: (ToJSON recur, KeyValue kv) => Syntax leaf recur -> [kv] syntaxToTermField syntax = case syntax of diff --git a/src/Syntax.hs b/src/Syntax.hs index 71775ae35..58f67bb1a 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -5,6 +5,7 @@ import Prologue import Data.Mergeable import GHC.Generics import Test.QuickCheck hiding (Fixed) +import Data.Aeson -- | A node in an abstract syntax tree. -- @@ -87,10 +88,11 @@ data Syntax a f | BlockExpression (Maybe f) [f] -- | A rescue block: maybe Args to rescue, maybe a local var for the last exception, and a list of expressions. | Rescue (Maybe f) (Maybe f) [f] - -- | A rescue modifier has a left and right expression (e.g. foo rescue nil). + -- | A rescue modifier has a left and right expression (e.g. in Ruby foo rescue nil). | RescueModifier f f + -- | The last exception captured in a rescue block to a local variable (e.g. in Ruby rescue => x). | LastException f - deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable, ToJSON) -- Instances diff --git a/src/Term/Instances.hs b/src/Term/Instances.hs new file mode 100644 index 000000000..9c89ae55e --- /dev/null +++ b/src/Term/Instances.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Term.Instances where + +import Prologue +import Data.Record +import Term +import Data.Aeson + +instance (ToJSON leaf, ToJSON (Record fields)) => ToJSON (SyntaxTerm leaf fields) where + toJSON syntaxTerm = case runCofree syntaxTerm of + (record :< syntax) -> object [ ("record", toJSON record), ("syntax", toJSON syntax) ]