From 8da1b8877d88d2339b2413005bd0c57e414f67d2 Mon Sep 17 00:00:00 2001
From: Rob Rix <robrix@github.com>
Date: Fri, 18 Oct 2019 21:40:23 -0400
Subject: [PATCH] Revert "Revert "Define TSX.Term recursively.""

This reverts commit 5b64b3819cbfa0653d9de5a21e08b3dce9adf527.
---
 src/Language/TSX/Assignment.hs   |  8 +++---
 src/Language/TSX/Term.hs         | 45 +++++++++++++++++++++++++-------
 src/Semantic/Api/Diffs.hs        | 25 ++++++++++++++----
 src/Semantic/Api/Symbols.hs      |  6 +++--
 src/Semantic/Api/TOCSummaries.hs |  6 +++--
 src/Semantic/Api/Terms.hs        | 15 +++++++----
 6 files changed, 77 insertions(+), 28 deletions(-)

diff --git a/src/Language/TSX/Assignment.hs b/src/Language/TSX/Assignment.hs
index ed968a9d6..8a2ad7f7d 100644
--- a/src/Language/TSX/Assignment.hs
+++ b/src/Language/TSX/Assignment.hs
@@ -30,19 +30,17 @@ import qualified Data.Syntax.Expression as Expression
 import qualified Data.Syntax.Literal as Literal
 import qualified Data.Syntax.Statement as Statement
 import qualified Data.Syntax.Type as Type
-import qualified Data.Term as Term
 import qualified Language.TSX.Syntax as TSX.Syntax
 import qualified Language.TypeScript.Resolution as TypeScript.Resolution
-import qualified Language.TSX.Term as TSX
+import Language.TSX.Term as TSX
 import Prologue
 import TreeSitter.TSX as Grammar
 
-type Term = Term.Term (Sum TSX.Syntax)
 type Assignment = Assignment.Assignment [] Grammar
 
 -- | Assignment from AST in TSX’s grammar onto a program in TSX’s syntax.
-assignment :: Assignment (TSX.Term Loc)
-assignment = fmap TSX.Term . handleError $ makeTerm <$> symbol Program <*> children (Statement.Statements <$> manyTerm statement) <|> parseError
+assignment :: Assignment (Term Loc)
+assignment = handleError $ makeTerm <$> symbol Program <*> children (Statement.Statements <$> manyTerm statement) <|> parseError
 
 expression :: Assignment (Term Loc)
 expression = handleError everything
diff --git a/src/Language/TSX/Term.hs b/src/Language/TSX/Term.hs
index 60766d011..62ccb0dbc 100644
--- a/src/Language/TSX/Term.hs
+++ b/src/Language/TSX/Term.hs
@@ -10,10 +10,13 @@ import Data.Abstract.Declarations
 import Data.Abstract.FreeVariables
 import Data.Bifoldable
 import Data.Bifunctor
+import Data.Bitraversable
+import Data.Coerce
 import qualified Data.Diff as Diff
-import Data.Functor.Foldable
-import Data.Graph.ControlFlowVertex (VertexDeclaration)
-import Data.Sum (Sum)
+import Data.Foldable (fold)
+import Data.Functor.Foldable (Base, Recursive(..))
+import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1)
+import qualified Data.Sum as Sum
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Comment as Comment
 import qualified Data.Syntax.Declaration as Declaration
@@ -22,8 +25,10 @@ import qualified Data.Syntax.Literal as Literal
 import qualified Data.Syntax.Statement as Statement
 import qualified Data.Syntax.Type as Type
 import qualified Data.Term as Term
+import Data.Traversable
 import Diffing.Interpreter
 import qualified Language.TSX.Syntax as TSX.Syntax
+import Source.Loc
 import Source.Span
 
 type Syntax =
@@ -197,20 +202,42 @@ type Syntax =
   ]
 
 
-newtype Term ann = Term { getTerm :: Term.Term (Sum Syntax) ann }
-  deriving (Eq, Declarations, Foldable, FreeVariables, Functor, Syntax.HasErrors, Ord, Show, Traversable, VertexDeclaration)
+newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) }
+  deriving (Eq, Declarations, FreeVariables, Ord, Show)
 
-newtype Diff ann1 ann2 = Diff { getDiff :: Diff.Diff (Sum Syntax) ann1 ann2 }
+instance Term.IsTerm Term where
+  type Syntax Term = Sum.Sum Syntax
+  toTermF = coerce
+  fromTermF = coerce
+
+instance Foldable Term where
+  foldMap = foldMapDefault
+
+instance Functor Term where
+  fmap = fmapDefault
+
+instance Traversable Term where
+  traverse f = go where go = fmap Term . bitraverse f go . getTerm
+
+instance VertexDeclaration Term where
+  toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax
+
+instance Syntax.HasErrors Term where
+  getErrors = cata $ \ (Term.In Loc{..} syntax) ->
+    maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax)
+
+
+newtype Diff ann1 ann2 = Diff { getDiff :: Diff.Diff (Sum.Sum Syntax) ann1 ann2 }
   deriving (Bifoldable, Bifunctor)
 
 instance DiffTerms Term where
   type DiffFor Term = Diff
-  diffTermPair = Diff . diffTermPair . bimap getTerm getTerm
+  diffTermPair = Diff . diffTermPair . bimap (cata Term.Term) (cata Term.Term)
 
-type instance Base (Term ann) = Term.TermF (Sum Syntax) ann
+type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann
 
 instance Recursive (Term ann) where
-  project = fmap Term . project . getTerm
+  project = getTerm
 
 instance HasSpan ann => HasSpan (Term ann) where
   span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i })
diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs
index 7a52912d1..2b2a23fc3 100644
--- a/src/Semantic/Api/Diffs.hs
+++ b/src/Semantic/Api/Diffs.hs
@@ -102,7 +102,8 @@ deriving instance DOTGraphDiff Markdown.Term
 deriving instance DOTGraphDiff PHP.Term
 deriving instance DOTGraphDiff Python.Term
 deriving instance DOTGraphDiff Ruby.Term
-deriving instance DOTGraphDiff TSX.Term
+instance DOTGraphDiff TSX.Term where
+  dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph . TSX.getDiff
 deriving instance DOTGraphDiff TypeScript.Term
 
 
@@ -132,7 +133,18 @@ deriving instance JSONGraphDiff Markdown.Term
 deriving instance JSONGraphDiff PHP.Term
 deriving instance JSONGraphDiff Python.Term
 deriving instance JSONGraphDiff Ruby.Term
-deriving instance JSONGraphDiff TSX.Term
+instance JSONGraphDiff TSX.Term where
+  jsonGraphDiff blobPair (TSX.Diff diff)
+    = let graph = renderTreeGraph diff
+          toEdge (Edge (a, b)) = defMessage & P.source .~ a^.diffVertexId & P.target .~ b^.diffVertexId
+          path = T.pack $ pathForBlobPair blobPair
+          lang = bridging # languageForBlobPair blobPair
+      in defMessage
+           & P.path .~ path
+           & P.language .~ lang
+           & P.vertices .~ vertexList graph
+           & P.edges .~ fmap toEdge (edgeList graph)
+           & P.errors .~ mempty
 deriving instance JSONGraphDiff TypeScript.Term
 
 
@@ -150,7 +162,8 @@ deriving instance JSONTreeDiff Markdown.Term
 deriving instance JSONTreeDiff PHP.Term
 deriving instance JSONTreeDiff Python.Term
 deriving instance JSONTreeDiff Ruby.Term
-deriving instance JSONTreeDiff TSX.Term
+instance JSONTreeDiff TSX.Term where
+  jsonTreeDiff blobs = renderJSONDiff blobs . TSX.getDiff
 deriving instance JSONTreeDiff TypeScript.Term
 
 
@@ -168,7 +181,8 @@ deriving instance SExprDiff Markdown.Term
 deriving instance SExprDiff PHP.Term
 deriving instance SExprDiff Python.Term
 deriving instance SExprDiff Ruby.Term
-deriving instance SExprDiff TSX.Term
+instance SExprDiff TSX.Term where
+  sexprDiff = serialize (SExpression ByConstructorName) . TSX.getDiff
 deriving instance SExprDiff TypeScript.Term
 
 
@@ -186,7 +200,8 @@ deriving instance ShowDiff Markdown.Term
 deriving instance ShowDiff PHP.Term
 deriving instance ShowDiff Python.Term
 deriving instance ShowDiff Ruby.Term
-deriving instance ShowDiff TSX.Term
+instance ShowDiff TSX.Term where
+  showDiff = serialize Show . TSX.getDiff
 deriving instance ShowDiff TypeScript.Term
 
 
diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs
index 85cf794d2..317b98df8 100644
--- a/src/Semantic/Api/Symbols.hs
+++ b/src/Semantic/Api/Symbols.hs
@@ -10,6 +10,7 @@ import           Control.Effect.Parse
 import           Control.Effect.Reader
 import           Control.Exception
 import           Control.Lens
+import           Data.Abstract.Declarations (Declarations1)
 import           Data.Blob hiding (File (..))
 import           Data.ByteString.Builder
 import           Data.Language
@@ -115,7 +116,7 @@ symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"]
 class ToTags t where
   tags :: Language -> [Text] -> Source -> t Loc -> [Tag]
 
-instance IsTaggable syntax => ToTags (Term syntax) where
+instance (IsTaggable syntax, Declarations1 syntax) => ToTags (Term syntax) where
   tags = runTagging
 
 deriving instance ToTags Go.Term
@@ -123,7 +124,8 @@ deriving instance ToTags Markdown.Term
 deriving instance ToTags PHP.Term
 deriving instance ToTags PythonALaCarte.Term
 deriving instance ToTags Ruby.Term
-deriving instance ToTags TSX.Term
+instance ToTags TSX.Term where
+  tags = runTagging
 deriving instance ToTags TypeScript.Term
 
 deriving via (ViaPrecise Java.Term)          instance ToTags Java.Term
diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs
index 05edbf441..9f19282a1 100644
--- a/src/Semantic/Api/TOCSummaries.hs
+++ b/src/Semantic/Api/TOCSummaries.hs
@@ -22,6 +22,7 @@ import           Data.Edit
 import           Data.Either (partitionEithers)
 import           Data.Function (on)
 import           Data.Functor.Classes
+import           Data.Functor.Foldable (cata)
 import           Data.Hashable.Lifted
 import           Data.Language (Language, PerLanguageModes)
 import           Data.Map (Map)
@@ -29,7 +30,7 @@ import qualified Data.Map.Monoidal as Map
 import           Data.Maybe (mapMaybe)
 import           Data.ProtoLens (defMessage)
 import           Data.Semilattice.Lower
-import           Data.Term (Term)
+import           Data.Term (Term(Term))
 import qualified Data.Text as T
 import           Diffing.Algorithm (Diffable)
 import qualified Diffing.Algorithm.SES as SES
@@ -126,7 +127,8 @@ deriving instance SummarizeTerms Markdown.Term
 deriving instance SummarizeTerms PHP.Term
 deriving instance SummarizeTerms PythonALaCarte.Term
 deriving instance SummarizeTerms Ruby.Term
-deriving instance SummarizeTerms TSX.Term
+instance SummarizeTerms TSX.Term where
+  summarizeTerms = summarizeTerms . bimap (fmap (cata Term)) (fmap (cata Term))
 deriving instance SummarizeTerms TypeScript.Term
 
 
diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs
index 4adfddb4e..2c662817d 100644
--- a/src/Semantic/Api/Terms.hs
+++ b/src/Semantic/Api/Terms.hs
@@ -129,7 +129,8 @@ deriving instance ShowTerm Markdown.Term
 deriving instance ShowTerm PHP.Term
 deriving instance ShowTerm PythonALaCarte.Term
 deriving instance ShowTerm Ruby.Term
-deriving instance ShowTerm TSX.Term
+instance ShowTerm TSX.Term where
+  showTerm = showTerm . cata Term
 deriving instance ShowTerm TypeScript.Term
 
 
@@ -156,7 +157,8 @@ deriving instance SExprTerm Markdown.Term
 deriving instance SExprTerm PHP.Term
 deriving instance SExprTerm PythonALaCarte.Term
 deriving instance SExprTerm Ruby.Term
-deriving instance SExprTerm TSX.Term
+instance SExprTerm TSX.Term where
+  sexprTerm = SExpr.serializeSExpression ByConstructorName
 deriving instance SExprTerm TypeScript.Term
 
 
@@ -174,7 +176,8 @@ deriving instance DOTGraphTerm Markdown.Term
 deriving instance DOTGraphTerm PHP.Term
 deriving instance DOTGraphTerm PythonALaCarte.Term
 deriving instance DOTGraphTerm Ruby.Term
-deriving instance DOTGraphTerm TSX.Term
+instance DOTGraphTerm TSX.Term where
+  dotGraphTerm = serialize (DOT (termStyle "terms")) . renderTreeGraph
 deriving instance DOTGraphTerm TypeScript.Term
 
 
@@ -192,7 +195,8 @@ deriving instance JSONTreeTerm Markdown.Term
 deriving instance JSONTreeTerm PHP.Term
 deriving instance JSONTreeTerm PythonALaCarte.Term
 deriving instance JSONTreeTerm Ruby.Term
-deriving instance JSONTreeTerm TSX.Term
+instance JSONTreeTerm TSX.Term where
+  jsonTreeTerm blob = jsonTreeTerm blob . cata Term
 deriving instance JSONTreeTerm TypeScript.Term
 
 
@@ -220,5 +224,6 @@ deriving instance JSONGraphTerm Markdown.Term
 deriving instance JSONGraphTerm PHP.Term
 deriving instance JSONGraphTerm PythonALaCarte.Term
 deriving instance JSONGraphTerm Ruby.Term
-deriving instance JSONGraphTerm TSX.Term
+instance JSONGraphTerm TSX.Term where
+  jsonGraphTerm blob = jsonGraphTerm blob . cata Term
 deriving instance JSONGraphTerm TypeScript.Term