Merge branch 'master' into json-and-core-are-breaking-up

semantic-python/test/Instances.hs

@@ -21,10 +21,6 @@ import           Data.Scope (Scope, Incr)
 import qualified Data.Scope as Scope
 import           Data.Name
 
--- We default to deriving the default toEncoding definition (that piggybacks
--- off of toJSON) so that we never hit the problematic code paths associated
--- with toEncoding above.
-
 instance ToJSON a => ToJSON (File a) where
   toJSON File{fileLoc, fileBody} = object
     [ "location" .= fileLoc

src/Control/Carrier/Parse/Measured.hs

@@ -75,7 +75,6 @@ runParser blob@Blob{..} parser = case parser of
     time "parse.cmark_parse" languageTag $
       let term = cmarkParser blobSource
       in length term `seq` pure term
-  SomeParser parser -> SomeTerm <$> runParser blob parser
   where languageTag = [("language" :: String, show (blobLanguage blob))]
 
 data ParserCancelled = ParserTimedOut | AssignmentTimedOut

src/Control/Carrier/Parse/Simple.hs

@@ -65,7 +65,6 @@ runParser timeout blob@Blob{..} parser = case parser of
   MarkdownParser ->
     let term = cmarkParser blobSource
     in length term `seq` pure term
-  SomeParser parser -> SomeTerm <$> runParser timeout blob parser
 
 data ParseFailure = ParseFailure String
   deriving (Show, Typeable)

src/Diffing/Algorithm/RWS.hs

@@ -30,11 +30,11 @@ import Prologue
 type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool
 
 rws :: (Foldable syntax, Functor syntax, Diffable syntax)
-    => ComparabilityRelation syntax (FeatureVector, ann) (FeatureVector, ann)
+    => ComparabilityRelation syntax (FeatureVector, ann1) (FeatureVector, ann2)
-    -> (Term syntax (FeatureVector, ann) -> Term syntax (FeatureVector, ann) -> Bool)
+    -> (Term syntax (FeatureVector, ann1) -> Term syntax (FeatureVector, ann2) -> Bool)
-    -> [Term syntax (FeatureVector, ann)]
+    -> [Term syntax (FeatureVector, ann1)]
-    -> [Term syntax (FeatureVector, ann)]
+    -> [Term syntax (FeatureVector, ann2)]
-    -> EditScript (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann))
+    -> EditScript (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2))
 rws _          _          as [] = This <$> as
 rws _          _          [] bs = That <$> bs
 rws canCompare _          [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a]

src/Diffing/Interpreter.hs

@@ -1,7 +1,7 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
 module Diffing.Interpreter
 ( diffTerms
-, diffTermPair
+, DiffTerms(..)
 , stripDiff
 ) where
 
@@ -16,30 +16,33 @@ import Prologue
 
 -- | Diff two à la carte terms recursively.
 diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax)
-          => Term syntax ann
+          => Term syntax ann1
-          -> Term syntax ann
+          -> Term syntax ann2
-          -> Diff.Diff syntax ann ann
+          -> Diff.Diff syntax ann1 ann2
 diffTerms t1 t2 = stripDiff (fromMaybe (Diff.replacing t1' t2') (run (runNonDetOnce (runDiff (algorithmForTerms t1' t2')))))
   where (t1', t2') = ( defaultFeatureVectorDecorator t1
                      , defaultFeatureVectorDecorator t2)
 
 -- | Strips the head annotation off a diff annotated with non-empty records.
 stripDiff :: Functor syntax
-          => Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)
+          => Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)
-          -> Diff.Diff syntax ann ann
+          -> Diff.Diff syntax ann1 ann2
 stripDiff = bimap snd snd
 
--- | Diff a 'These' of terms.
+class DiffTerms term diff | diff -> term, term -> diff where
-diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Diff.Diff syntax ann ann
+  -- | Diff a 'These' of terms.
-diffTermPair = these Diff.deleting Diff.inserting diffTerms
+  diffTermPair :: These (term ann1) (term ann2) -> diff ann1 ann2
+
+instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) (Diff.Diff syntax) where
+  diffTermPair = these Diff.deleting Diff.inserting diffTerms
 
 
 -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations.
 runDiff :: Algorithm
-             (Term syntax (FeatureVector, ann))
+             (Term syntax (FeatureVector, ann1))
-             (Term syntax (FeatureVector, ann))
+             (Term syntax (FeatureVector, ann2))
-             (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann))
+             (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2))
-             (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m)
+             (DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m)
              result
         -> m result
 runDiff = runDiffC . runAlgorithm
@@ -57,8 +60,8 @@ instance ( Alternative m
          , Traversable syntax
          )
       => Carrier
-        (Diff (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) :+: sig)
+        (Diff (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) :+: sig)
-        (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m) where
+        (DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m) where
   eff (L op) = case op of
     Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= k
     Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= k

src/Parsing/Parser.hs

@@ -1,8 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
 module Parsing.Parser
 ( Parser(..)
-, SomeTerm(..)
-, withSomeTerm
 , SomeAnalysisParser(..)
 , SomeASTParser(..)
 , someASTParser
@@ -112,8 +110,7 @@ data Parser term where
                       -> Parser (Term (Sum syntaxes) Loc)
   -- | A parser for 'Markdown' using cmark.
   MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
-  -- | An abstraction over parsers when we don’t know the details of the term type.
+
-  SomeParser :: ApplyAll typeclasses syntax => Parser (Term syntax ann) -> Parser (SomeTerm typeclasses ann)
 
 -- | Apply all of a list of typeclasses to all of a list of functors using 'Apply'. Used by 'someParser' to constrain all of the language-specific syntax types to the typeclasses in question.
 type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *) :: Constraint where
@@ -168,12 +165,6 @@ precisePythonParser :: Parser (Py.Term Loc)
 precisePythonParser = UnmarshalParser tree_sitter_python
 
 
-data SomeTerm typeclasses ann where
-  SomeTerm :: ApplyAll typeclasses syntax => Term syntax ann -> SomeTerm typeclasses ann
-
-withSomeTerm :: (forall syntax . ApplyAll typeclasses syntax => Term syntax ann -> a) -> SomeTerm typeclasses ann -> a
-withSomeTerm with (SomeTerm term) = with term
-
 -- | A parser for producing specialized (tree-sitter) ASTs.
 data SomeASTParser where
   SomeASTParser :: (Bounded grammar, Enum grammar, Show grammar)

src/Rendering/TOC.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DerivingVia, RankNTypes, ScopedTypeVariables #-}
 module Rendering.TOC
 ( renderToCDiff
-, renderToCTerm
 , diffTOC
 , Summaries(..)
 , TOCSummary(..)
@@ -143,15 +142,6 @@ renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isV
 diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [TOCSummary]
 diffTOC = fmap entrySummary . dedupe . tableOfContentsBy declaration
 
-renderToCTerm :: (Foldable f, Functor f) => Blob -> Term f (Maybe Declaration) -> Summaries
-renderToCTerm b@Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC
-  where
-    toMap [] = mempty
-    toMap as = Map.singleton (T.pack (blobPath b)) (toJSON <$> as)
-
-    termToC :: (Foldable f, Functor f) => Term f (Maybe Declaration) -> [TOCSummary]
-    termToC = fmap (recordSummary "unchanged") . termTableOfContentsBy declaration
-
 -- The user-facing category name
 toCategoryName :: Declaration -> T.Text
 toCategoryName declaration = case declaration of

src/Semantic/Api/Diffs.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, ConstraintKinds, TypeOperators, RankNTypes #-}
+{-# LANGUAGE GADTs, ConstraintKinds, FunctionalDependencies, LambdaCase, RankNTypes #-}
 module Semantic.Api.Diffs
   ( parseDiffBuilder
   , DiffOutputFormat(..)
@@ -8,11 +8,14 @@ module Semantic.Api.Diffs
   , DiffEffects
 
   , SomeTermPair(..)
-  , withSomeTermPair
+
+  , LegacySummarizeDiff(..)
+  , SummarizeDiff(..)
   ) where
 
 import           Analysis.ConstructorName (ConstructorName)
-import           Analysis.TOCSummary (HasDeclaration)
+import           Analysis.Decorator (decoratorWithAlgebra)
+import           Analysis.TOCSummary (Declaration, HasDeclaration, declarationAlgebra)
 import           Control.Effect.Error
 import           Control.Effect.Parse
 import           Control.Effect.Reader
@@ -28,13 +31,13 @@ import           Data.Language
 import           Data.Term
 import qualified Data.Text as T
 import qualified Data.Vector as V
-import           Diffing.Algorithm (Diffable)
+import           Diffing.Interpreter (DiffTerms(..))
-import           Diffing.Interpreter (diffTermPair)
 import           Parsing.Parser
 import           Prologue
 import           Rendering.Graph
 import           Rendering.JSON hiding (JSON)
 import qualified Rendering.JSON
+import           Rendering.TOC
 import           Semantic.Api.Bridge
 import           Semantic.Config
 import           Semantic.Proto.SemanticPB hiding (Blob, BlobPair)
@@ -53,83 +56,139 @@ data DiffOutputFormat
   deriving (Eq, Show)
 
 parseDiffBuilder :: (Traversable t, DiffEffects sig m) => DiffOutputFormat -> t BlobPair -> m Builder
-parseDiffBuilder DiffJSONTree    = distributeFoldMap (jsonDiff renderJSONTree) >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs.
+parseDiffBuilder DiffJSONTree    = distributeFoldMap jsonDiff >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs.
 parseDiffBuilder DiffJSONGraph   = diffGraph >=> serialize Format.JSON
-parseDiffBuilder DiffSExpression = distributeFoldMap sexpDiff
+parseDiffBuilder DiffSExpression = distributeFoldMap (doDiff (const id) sexprDiff)
-parseDiffBuilder DiffShow        = distributeFoldMap showDiff
+parseDiffBuilder DiffShow        = distributeFoldMap (doDiff (const id) showDiff)
-parseDiffBuilder DiffDotGraph    = distributeFoldMap dotGraphDiff
+parseDiffBuilder DiffDotGraph    = distributeFoldMap (doDiff (const id) dotGraphDiff)
 
-type RenderJSON m syntax = forall syntax . CanDiff syntax => BlobPair -> Diff syntax Loc Loc -> m (Rendering.JSON.JSON "diffs" SomeJSON)
+jsonDiff :: DiffEffects sig m => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON)
-
+jsonDiff blobPair = doDiff (const id) (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair
-jsonDiff :: (DiffEffects sig m) => RenderJSON m syntax -> BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON)
-jsonDiff f blobPair = doDiff blobPair (const id) f `catchError` jsonError blobPair
 
 jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON)
 jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e)
 
-renderJSONTree :: (Applicative m, ToJSONFields1 syntax) => BlobPair -> Diff syntax Loc Loc -> m (Rendering.JSON.JSON "diffs" SomeJSON)
-renderJSONTree blobPair = pure . renderJSONDiff blobPair
-
 diffGraph :: (Traversable t, DiffEffects sig m) => t BlobPair -> m DiffTreeGraphResponse
 diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor blobs go
   where
-    go :: (DiffEffects sig m) => BlobPair -> m DiffTreeFileGraph
+    go :: DiffEffects sig m => BlobPair -> m DiffTreeFileGraph
-    go blobPair = doDiff blobPair (const id) render
+    go blobPair = doDiff (const id) (pure . jsonGraphDiff blobPair) blobPair
       `catchError` \(SomeException e) ->
         pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
       where
         path = T.pack $ pathForBlobPair blobPair
         lang = bridging # languageForBlobPair blobPair
 
-        render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Loc Loc -> m DiffTreeFileGraph
-        render _ diff =
-          let graph = renderTreeGraph diff
-              toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b)
-          in pure $ DiffTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty
-
-
-sexpDiff :: (DiffEffects sig m) => BlobPair -> m Builder
-sexpDiff blobPair = doDiff blobPair (const id) (const (serialize (SExpression ByConstructorName)))
-
-showDiff :: (DiffEffects sig m) => BlobPair -> m Builder
-showDiff blobPair = doDiff blobPair (const id) (const (serialize Show))
-
-dotGraphDiff :: (DiffEffects sig m) => BlobPair -> m Builder
-dotGraphDiff blobPair = doDiff blobPair (const id) render
-  where render _ = serialize (DOT (diffStyle "diffs")) . renderTreeGraph
-
 type DiffEffects sig m = (Member (Error SomeException) sig, Member (Reader Config) sig, Member Telemetry sig, Member Distribute sig, Member Parse sig, Carrier sig m, MonadIO m)
 
-type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax)
+type Decorate a b = forall term diff . DiffActions term diff => Blob -> term a -> term b
-type Decorate a b = forall syntax . CanDiff syntax => Blob -> Term syntax a -> Term syntax b
 
-type TermPairConstraints =
- '[ ConstructorName
-  , Diffable
-  , Eq1
-  , HasDeclaration
-  , Hashable1
-  , Show1
-  , Traversable
-  , ToJSONFields1
-  ]
 
-doDiff :: (DiffEffects sig m)
+class DOTGraphDiff diff where
-  => BlobPair -> Decorate Loc ann -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output) -> m output
+  dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder
-doDiff blobPair decorate render = do
+
+instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphDiff (Diff syntax) where
+  dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph
+
+
+class JSONGraphDiff diff where
+  jsonGraphDiff :: BlobPair -> diff Loc Loc -> DiffTreeFileGraph
+
+instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphDiff (Diff syntax) where
+  jsonGraphDiff blobPair diff
+    = let graph = renderTreeGraph diff
+          toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b)
+      in DiffTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty where
+        path = T.pack $ pathForBlobPair blobPair
+        lang = bridging # languageForBlobPair blobPair
+
+
+class JSONTreeDiff diff where
+  jsonTreeDiff :: BlobPair -> diff Loc Loc -> Rendering.JSON.JSON "diffs" SomeJSON
+
+instance ToJSONFields1 syntax => JSONTreeDiff (Diff syntax) where
+  jsonTreeDiff = renderJSONDiff
+
+
+class SExprDiff diff where
+  sexprDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder
+
+instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprDiff (Diff syntax) where
+  sexprDiff = serialize (SExpression ByConstructorName)
+
+
+class ShowDiff diff where
+  showDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder
+
+instance Show1 syntax => ShowDiff (Diff syntax) where
+  showDiff = serialize Show
+
+
+class LegacySummarizeDiff term diff | diff -> term, term -> diff where
+  legacyDecorateTerm :: Blob -> term Loc -> term (Maybe Declaration)
+  legacySummarizeDiff :: BlobPair -> diff (Maybe Declaration) (Maybe Declaration) -> Summaries
+
+instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => LegacySummarizeDiff (Term syntax) (Diff syntax) where
+  legacyDecorateTerm = decoratorWithAlgebra . declarationAlgebra
+  legacySummarizeDiff = renderToCDiff
+
+
+class SummarizeDiff term diff | diff -> term, term -> diff where
+  decorateTerm :: Blob -> term Loc -> term (Maybe Declaration)
+  summarizeDiff :: BlobPair -> diff (Maybe Declaration) (Maybe Declaration) -> TOCSummaryFile
+
+instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDiff (Term syntax) (Diff syntax) where
+  decorateTerm = decoratorWithAlgebra . declarationAlgebra
+  summarizeDiff blobPair diff = foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff)
+    where
+      path = T.pack $ pathKeyForBlobPair blobPair
+      lang = bridging # languageForBlobPair blobPair
+
+      toChangeType = \case
+        "added" -> Added
+        "modified" -> Modified
+        "removed" -> Removed
+        _ -> None
+
+      go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile
+      go TOCSummary{..} TOCSummaryFile{..}
+        = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (converting #? summarySpan) (toChangeType summaryChangeType)) changes) errors
+      go ErrorSummary{..} TOCSummaryFile{..}
+        = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors)
+
+
+type DiffActions term diff =
+  ( Bifoldable diff
+  , DiffTerms term diff
+  , DOTGraphDiff diff
+  , JSONGraphDiff diff
+  , JSONTreeDiff diff
+  , SExprDiff diff
+  , ShowDiff diff
+  , LegacySummarizeDiff term diff
+  , SummarizeDiff term diff
+  )
+
+doDiff
+  :: DiffEffects sig m
+  => Decorate Loc ann
+  -> (forall term diff . DiffActions term diff => diff ann ann -> m output)
+  -> BlobPair
+  -> m output
+doDiff decorate render blobPair = do
   SomeTermPair terms <- doParse blobPair decorate
   diff <- diffTerms blobPair terms
-  render blobPair diff
+  render diff
 
-diffTerms :: (CanDiff syntax, Member Telemetry sig, Carrier sig m, MonadIO m)
+diffTerms :: (DiffActions term diff, Member Telemetry sig, Carrier sig m, MonadIO m)
-  => BlobPair -> Join These (Term syntax ann) -> m (Diff syntax ann ann)
+  => BlobPair -> Join These (term ann) -> m (diff ann ann)
 diffTerms blobs terms = time "diff" languageTag $ do
   let diff = diffTermPair (runJoin terms)
   diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
   where languageTag = languageTagForBlobPair blobs
 
 doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Parse sig, Carrier sig m)
-  => BlobPair -> Decorate Loc ann -> m (SomeTermPair TermPairConstraints ann)
+  => BlobPair -> Decorate Loc ann -> m (SomeTermPair ann)
 doParse blobPair decorate = case languageForBlobPair blobPair of
   Go         -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse goParser blob)
   Haskell    -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse haskellParser blob)
@@ -144,8 +203,5 @@ doParse blobPair decorate = case languageForBlobPair blobPair of
   PHP        -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse phpParser blob)
   _          -> noLanguageForBlob (pathForBlobPair blobPair)
 
-data SomeTermPair typeclasses ann where
+data SomeTermPair ann where
-  SomeTermPair :: ApplyAll typeclasses syntax => Join These (Term syntax ann) -> SomeTermPair typeclasses ann
+  SomeTermPair :: DiffActions term diff => Join These (term ann) -> SomeTermPair ann
-
-withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a
-withSomeTermPair with (SomeTermPair terms) = with terms

src/Semantic/Api/Symbols.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies #-}
+{-# LANGUAGE MonoLocalBinds, RankNTypes #-}
 module Semantic.Api.Symbols
   ( legacyParseSymbols
   , parseSymbols
@@ -17,25 +17,24 @@ import           Data.Term
 import qualified Data.Text as T
 import qualified Data.Vector as V
 import           Data.Text (pack)
-import qualified Language.Python as Py
+import qualified Parsing.Parser as Parser
-import           Parsing.Parser
 import           Prologue
 import           Semantic.Api.Bridge
 import qualified Semantic.Api.LegacyTypes as Legacy
-import           Semantic.Api.Terms (ParseEffects, doParse)
 import           Semantic.Proto.SemanticPB hiding (Blob)
+import           Semantic.Config
 import           Semantic.Task
-import           Serializing.Format
+import           Serializing.Format (Format)
 import           Source.Loc
 import           Tags.Taggable
 import           Tags.Tagging
 import qualified Tags.Tagging.Precise as Precise
 
-legacyParseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse
+legacyParseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse
 legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs
   where
-    go :: ParseEffects sig m => Blob -> m [Legacy.File]
+    go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m [Legacy.File]
-    go blob@Blob{..} = (doParse blob >>= withSomeTerm renderToSymbols) `catchError` (\(SomeException _) -> pure (pure emptyFile))
+    go blob@Blob{..} = doParse (pure . renderToSymbols) symbolsToSummarize blob `catchError` (\(SomeException _) -> pure (pure emptyFile))
       where
         emptyFile = tagsToFile []
 
@@ -43,8 +42,8 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
         symbolsToSummarize :: [Text]
         symbolsToSummarize = ["Function", "Method", "Class", "Module"]
 
-        renderToSymbols :: (IsTaggable f, Applicative m) => Term f Loc -> m [Legacy.File]
+        renderToSymbols :: Precise.ToTags t => t Loc -> [Legacy.File]
-        renderToSymbols = pure . pure . tagsToFile . runTagging blob symbolsToSummarize
+        renderToSymbols = pure . tagsToFile . Precise.tags blobSource
 
         tagsToFile :: [Tag] -> Legacy.File
         tagsToFile tags = Legacy.File (pack (blobPath blob)) (pack (show (blobLanguage blob))) (fmap tagToSymbol tags)
@@ -58,31 +57,22 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
           , symbolSpan = converting #? span
           }
 
-parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder
+parseSymbolsBuilder :: (Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader Config) sig, Member (Reader PerLanguageModes) sig, Carrier sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder
 parseSymbolsBuilder format blobs = parseSymbols blobs >>= serialize format
 
-parseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse
+parseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse
-parseSymbols blobs = do
+parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go
-  modes <- ask
-  ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs (go modes)
   where
-    go :: ParseEffects sig m => PerLanguageModes -> Blob -> m File
+    go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m File
-    go modes blob@Blob{..}
+    go blob@Blob{..} = catching $ doParse (pure . renderToSymbols) symbolsToSummarize blob
-      | Precise <- pythonMode modes
-      , Python  <- blobLanguage'
-      =             catching $ renderPreciseToSymbols       <$> parse precisePythonParser blob
-      | otherwise = catching $ withSomeTerm renderToSymbols <$> doParse                   blob
       where
         catching m = m `catchError` (\(SomeException e) -> pure $ errorFile (show e))
         blobLanguage' = blobLanguage blob
         blobPath' = pack $ blobPath blob
         errorFile e = File blobPath' (bridging # blobLanguage') mempty (V.fromList [ParseError (T.pack e)]) blobOid
 
-        renderToSymbols :: IsTaggable f => Term f Loc -> File
+        renderToSymbols :: Precise.ToTags t => t Loc -> File
-        renderToSymbols term = tagsToFile (runTagging blob symbolsToSummarize term)
+        renderToSymbols term = tagsToFile (Precise.tags blobSource term)
-
-        renderPreciseToSymbols :: Py.Term Loc -> File
-        renderPreciseToSymbols term = tagsToFile (Precise.tags blobSource term)
 
         tagsToFile :: [Tag] -> File
         tagsToFile tags = File blobPath' (bridging # blobLanguage') (V.fromList (fmap tagToSymbol tags)) mempty blobOid
@@ -98,3 +88,40 @@ tagToSymbol Tag{..} = Symbol
   , span = converting #? span
   , docs = fmap Docstring docs
   }
+
+
+data ALaCarteTerm syntax ann = ALaCarteTerm Language [Text] (Term syntax ann)
+
+instance IsTaggable syntax => Precise.ToTags (ALaCarteTerm syntax) where
+  tags source (ALaCarteTerm lang symbolsToSummarize term) = runTagging lang source symbolsToSummarize term
+
+
+doParse
+  :: ( Carrier sig m
+     , Member (Error SomeException) sig
+     , Member Parse sig
+     , Member (Reader PerLanguageModes) sig
+     )
+  => (forall t . Precise.ToTags t => t Loc -> m a)
+  -> [Text]
+  -> Blob
+  -> m a
+doParse with symbolsToSummarize blob = do
+  modes <- ask @PerLanguageModes
+  case blobLanguage blob of
+    Go         -> parse Parser.goParser         blob >>= with . mkTerm
+    Haskell    -> parse Parser.haskellParser    blob >>= with . mkTerm
+    JavaScript -> parse Parser.tsxParser        blob >>= with . mkTerm
+    JSON       -> parse Parser.jsonParser       blob >>= with . mkTerm
+    JSX        -> parse Parser.tsxParser        blob >>= with . mkTerm
+    Markdown   -> parse Parser.markdownParser   blob >>= with . mkTerm
+    Python
+      | Precise <- pythonMode modes -> parse Parser.precisePythonParser blob >>= with
+      | otherwise                   -> parse Parser.pythonParser        blob >>= with . mkTerm
+    Ruby       -> parse Parser.rubyParser       blob >>= with . mkTerm
+    TypeScript -> parse Parser.typescriptParser blob >>= with . mkTerm
+    TSX        -> parse Parser.tsxParser        blob >>= with . mkTerm
+    PHP        -> parse Parser.phpParser        blob >>= with . mkTerm
+    _          -> noLanguageForBlob (blobPath blob)
+    where mkTerm :: Term syntax Loc -> ALaCarteTerm syntax Loc
+          mkTerm = ALaCarteTerm (blobLanguage blob) symbolsToSummarize

src/Semantic/Api/TOCSummaries.hs

@@ -1,14 +1,10 @@
-{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies, LambdaCase #-}
 module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where
 
-import           Analysis.Decorator (decoratorWithAlgebra)
-import           Analysis.TOCSummary (Declaration, declarationAlgebra)
 import           Control.Effect.Error
 import           Control.Lens
 import           Data.Aeson
 import           Data.Blob
 import           Data.ByteString.Builder
-import           Data.Diff
 import qualified Data.Map.Monoidal as Map
 import qualified Data.Text as T
 import qualified Data.Vector as V
@@ -20,46 +16,26 @@ import           Semantic.Proto.SemanticPB hiding (Blob, BlobPair)
 import           Semantic.Task as Task
 import           Serializing.Format
 
-diffSummaryBuilder :: (DiffEffects sig m) => Format DiffTreeTOCResponse -> [BlobPair] -> m Builder
+diffSummaryBuilder :: DiffEffects sig m => Format DiffTreeTOCResponse -> [BlobPair] -> m Builder
 diffSummaryBuilder format blobs = diffSummary blobs >>= serialize format
 
-legacyDiffSummary :: (DiffEffects sig m) => [BlobPair] -> m Summaries
+legacyDiffSummary :: DiffEffects sig m => [BlobPair] -> m Summaries
 legacyDiffSummary = distributeFoldMap go
   where
-    go :: (DiffEffects sig m) => BlobPair -> m Summaries
+    go :: DiffEffects sig m => BlobPair -> m Summaries
-    go blobPair = doDiff blobPair (\ blob -> decoratorWithAlgebra (declarationAlgebra blob)) render
+    go blobPair = doDiff legacyDecorateTerm (pure . legacySummarizeDiff blobPair) blobPair
       `catchError` \(SomeException e) ->
         pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)])
       where path = T.pack $ pathKeyForBlobPair blobPair
             lang = languageForBlobPair blobPair
 
-    render :: (Foldable syntax, Functor syntax, Applicative m) => BlobPair -> Diff syntax (Maybe Declaration) (Maybe Declaration) -> m Summaries
-    render blobPair = pure . renderToCDiff blobPair
 
-diffSummary :: (DiffEffects sig m) => [BlobPair] -> m DiffTreeTOCResponse
+diffSummary :: DiffEffects sig m => [BlobPair] -> m DiffTreeTOCResponse
 diffSummary blobs = DiffTreeTOCResponse . V.fromList <$> distributeFor blobs go
   where
-    go :: (DiffEffects sig m) => BlobPair -> m TOCSummaryFile
+    go :: DiffEffects sig m => BlobPair -> m TOCSummaryFile
-    go blobPair = doDiff blobPair (\ blob -> decoratorWithAlgebra (declarationAlgebra blob)) render
+    go blobPair = doDiff decorateTerm (pure . summarizeDiff blobPair) blobPair
       `catchError` \(SomeException e) ->
         pure $ TOCSummaryFile path lang mempty (V.fromList [TOCSummaryError (T.pack (show e)) Nothing])
       where path = T.pack $ pathKeyForBlobPair blobPair
             lang = bridging # languageForBlobPair blobPair
-
-    render :: (Foldable syntax, Functor syntax, Applicative m) => BlobPair -> Diff syntax (Maybe Declaration) (Maybe Declaration) -> m TOCSummaryFile
-    render blobPair diff = pure $ foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff)
-      where
-        path = T.pack $ pathKeyForBlobPair blobPair
-        lang = bridging # languageForBlobPair blobPair
-
-        toChangeType = \case
-          "added" -> Added
-          "modified" -> Modified
-          "removed" -> Removed
-          _ -> None
-
-        go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile
-        go TOCSummary{..} TOCSummaryFile{..}
-          = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (converting #? summarySpan) (toChangeType summaryChangeType)) changes) errors
-        go ErrorSummary{..} TOCSummaryFile{..}
-          = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors)

src/Semantic/Api/Terms.hs

@@ -1,19 +1,10 @@
-{-# LANGUAGE ConstraintKinds, GADTs, TypeOperators, DerivingStrategies #-}
+{-# LANGUAGE ConstraintKinds, MonoLocalBinds, RankNTypes #-}
 module Semantic.Api.Terms
-  (
+  ( termGraph
-    termGraph
   , parseTermBuilder
   , TermOutputFormat(..)
-
-  , doParse
-  , ParseEffects
-  , TermConstraints
-
-  , SomeTerm(..)
-  , withSomeTerm
   ) where
 
-
 import           Analysis.ConstructorName (ConstructorName)
 import           Control.Effect.Error
 import           Control.Effect.Parse
@@ -21,7 +12,6 @@ import           Control.Effect.Reader
 import           Control.Lens
 import           Control.Monad
 import           Control.Monad.IO.Class
-import           Data.Abstract.Declarations
 import           Data.Blob
 import           Data.ByteString.Builder
 import           Data.Either
@@ -44,23 +34,20 @@ import           Semantic.Task
 import           Serializing.Format hiding (JSON)
 import qualified Serializing.Format as Format
 import           Source.Loc
-import           Tags.Taggable
+
+import qualified Language.Python as Py
 
 termGraph :: (Traversable t, Member Distribute sig, ParseEffects sig m) => t Blob -> m ParseTreeGraphResponse
 termGraph blobs = ParseTreeGraphResponse . V.fromList . toList <$> distributeFor blobs go
   where
     go :: ParseEffects sig m => Blob -> m ParseTreeFileGraph
-    go blob = (doParse blob >>= withSomeTerm (pure . render))
+    go blob = doParse (pure . jsonGraphTerm blob) blob
       `catchError` \(SomeException e) ->
         pure (ParseTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
       where
         path = T.pack $ blobPath blob
         lang = bridging # blobLanguage blob
 
-        render :: (Foldable syntax, Functor syntax, ConstructorName syntax) => Term syntax Loc -> ParseTreeFileGraph
-        render t = let graph = renderTreeGraph t
-                       toEdge (Edge (a, b)) = TermEdge (vertexId a) (vertexId b)
-                   in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty
 
 data TermOutputFormat
   = TermJSONTree
@@ -75,28 +62,19 @@ parseTermBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m, M
   => TermOutputFormat -> t Blob -> m Builder
 parseTermBuilder TermJSONTree    = distributeFoldMap jsonTerm >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blobs.
 parseTermBuilder TermJSONGraph   = termGraph >=> serialize Format.JSON
-parseTermBuilder TermSExpression = distributeFoldMap sexpTerm
+parseTermBuilder TermSExpression = distributeFoldMap (doParse sexprTerm)
-parseTermBuilder TermDotGraph    = distributeFoldMap dotGraphTerm
+parseTermBuilder TermDotGraph    = distributeFoldMap (doParse dotGraphTerm)
-parseTermBuilder TermShow        = distributeFoldMap showTerm
+parseTermBuilder TermShow        = distributeFoldMap (doParse showTerm)
 parseTermBuilder TermQuiet       = distributeFoldMap quietTerm
 
-jsonTerm :: (ParseEffects sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON)
+jsonTerm :: ParseEffects sig m => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON)
-jsonTerm blob = (doParse blob >>= withSomeTerm (pure . renderJSONTerm blob)) `catchError` jsonError blob
+jsonTerm blob = doParse (pure . jsonTreeTerm blob) blob `catchError` jsonError blob
 
 jsonError :: Applicative m => Blob -> SomeException -> m (Rendering.JSON.JSON "trees" SomeJSON)
 jsonError blob (SomeException e) = pure $ renderJSONError blob (show e)
 
-sexpTerm :: (ParseEffects sig m) => Blob -> m Builder
-sexpTerm = doParse >=> withSomeTerm (serialize (SExpression ByConstructorName))
-
-dotGraphTerm :: (ParseEffects sig m) => Blob -> m Builder
-dotGraphTerm = doParse >=> withSomeTerm (serialize (DOT (termStyle "terms")) . renderTreeGraph)
-
-showTerm :: (ParseEffects sig m) => Blob -> m Builder
-showTerm = doParse >=> withSomeTerm (serialize Show . quieterm)
-
 quietTerm :: (ParseEffects sig m, MonadIO m) => Blob -> m Builder
-quietTerm blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fmap (const (Right ())) . serialize Show . quieterm)) `catchError` timingError )
+quietTerm blob = showTiming blob <$> time' ( doParse (fmap (const (Right ())) . showTerm) blob `catchError` timingError )
   where
     timingError (SomeException e) = pure (Left (show e))
     showTiming Blob{..} (res, duration) =
@@ -106,27 +84,70 @@ quietTerm blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fma
 
 type ParseEffects sig m = (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m)
 
-type TermConstraints =
- '[ Taggable
-  , Declarations1
-  , ConstructorName
-  , HasTextElement
-  , Show1
-  , ToJSONFields1
-  , Traversable
-  ]
 
-doParse :: (ParseEffects sig m) => Blob -> m (SomeTerm TermConstraints Loc)
+class ShowTerm term where
-doParse blob = case blobLanguage blob of
+  showTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder
-  Go         -> SomeTerm <$> parse goParser blob
+
-  Haskell    -> SomeTerm <$> parse haskellParser blob
+instance (Functor syntax, Show1 syntax) => ShowTerm (Term syntax) where
-  JavaScript -> SomeTerm <$> parse tsxParser blob
+  showTerm = serialize Show . quieterm
-  JSON       -> SomeTerm <$> parse jsonParser blob
+
-  JSX        -> SomeTerm <$> parse tsxParser blob
+instance ShowTerm Py.Term where
-  Markdown   -> SomeTerm <$> parse markdownParser blob
+  showTerm = serialize Show . Py.getTerm
-  Python     -> SomeTerm <$> parse pythonParser blob
+
-  Ruby       -> SomeTerm <$> parse rubyParser blob
+
-  TypeScript -> SomeTerm <$> parse typescriptParser blob
+class SExprTerm term where
-  TSX        -> SomeTerm <$> parse tsxParser blob
+  sexprTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder
-  PHP        -> SomeTerm <$> parse phpParser blob
+
+instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprTerm (Term syntax) where
+  sexprTerm = serialize (SExpression ByConstructorName)
+
+
+class DOTGraphTerm term where
+  dotGraphTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder
+
+instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphTerm (Term syntax) where
+  dotGraphTerm = serialize (DOT (termStyle "terms")) . renderTreeGraph
+
+
+class JSONTreeTerm term where
+  jsonTreeTerm :: Blob -> term Loc -> Rendering.JSON.JSON "trees" SomeJSON
+
+instance ToJSONFields1 syntax => JSONTreeTerm (Term syntax) where
+  jsonTreeTerm = renderJSONTerm
+
+
+class JSONGraphTerm term where
+  jsonGraphTerm :: Blob -> term Loc -> ParseTreeFileGraph
+
+instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphTerm (Term syntax) where
+  jsonGraphTerm blob t
+    = let graph = renderTreeGraph t
+          toEdge (Edge (a, b)) = TermEdge (vertexId a) (vertexId b)
+      in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty where
+        path = T.pack $ blobPath blob
+        lang = bridging # blobLanguage blob
+
+
+type TermActions t = (DOTGraphTerm t, JSONGraphTerm t, JSONTreeTerm t, SExprTerm t, ShowTerm t)
+
+doParse
+  :: ( Carrier sig m
+     , Member (Error SomeException) sig
+     , Member Parse sig
+     )
+  => (forall term . TermActions term => term Loc -> m a)
+  -> Blob
+  -> m a
+doParse with blob = case blobLanguage blob of
+  Go         -> parse goParser         blob >>= with
+  Haskell    -> parse haskellParser    blob >>= with
+  JavaScript -> parse tsxParser        blob >>= with
+  JSON       -> parse jsonParser       blob >>= with
+  JSX        -> parse tsxParser        blob >>= with
+  Markdown   -> parse markdownParser   blob >>= with
+  Python     -> parse pythonParser     blob >>= with
+  Ruby       -> parse rubyParser       blob >>= with
+  TypeScript -> parse typescriptParser blob >>= with
+  TSX        -> parse tsxParser        blob >>= with
+  PHP        -> parse phpParser        blob >>= with
   _          -> noLanguageForBlob (blobPath blob)

src/Serializing/SExpression/Precise.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Serializing.SExpression.Precise
 ( serializeSExpression
+, ToSExpression(..)
 ) where
 
 import Data.ByteString.Builder

src/Tags/Taggable.hs

@@ -29,7 +29,6 @@ import Analysis.ConstructorName
 import Analysis.HasTextElement
 import Data.Abstract.Declarations
 import Data.Abstract.Name
-import Data.Blob
 import Data.Language
 import Data.Term
 import Data.Text hiding (empty)
@@ -99,10 +98,10 @@ type IsTaggable syntax =
   )
 
 tagging :: (Monad m, IsTaggable syntax)
-        => Blob
+        => Language
         -> Term syntax Loc
         -> Stream (Of Token) m ()
-tagging b = foldSubterms (descend (blobLanguage b))
+tagging = foldSubterms . descend
 
 descend ::
   ( ConstructorName (TermF syntax Loc)

src/Tags/Tagging.hs

@@ -14,7 +14,7 @@ import           Data.Text as T hiding (empty)
 import           Streaming
 import qualified Streaming.Prelude as Streaming
 
-import           Data.Blob
+import           Data.Language
 import           Data.Term
 import           Source.Loc
 import qualified Source.Source as Source
@@ -22,16 +22,17 @@ import           Tags.Tag
 import           Tags.Taggable
 
 runTagging :: (IsTaggable syntax)
-           => Blob
+           => Language
+           -> Source.Source
            -> [Text]
            -> Term syntax Loc
            -> [Tag]
-runTagging blob symbolsToSummarize
+runTagging lang source symbolsToSummarize
   = Eff.run
   . evalState @[ContextToken] []
   . Streaming.toList_
-  . contextualizing blob toKind
+  . contextualizing source toKind
-  . tagging blob
+  . tagging lang
   where
     toKind x = do
       guard (x `elem` symbolsToSummarize)
@@ -49,11 +50,11 @@ type ContextToken = (Text, Range)
 contextualizing :: ( Member (State [ContextToken]) sig
                    , Carrier sig m
                    )
-                => Blob
+                => Source.Source
                 -> (Text -> Maybe Kind)
                 -> Stream (Of Token) m a
                 -> Stream (Of Tag) m a
-contextualizing Blob{..} toKind = Streaming.mapMaybeM $ \case
+contextualizing source toKind = Streaming.mapMaybeM $ \case
   Enter x r -> Nothing <$ enterScope (x, r)
   Exit  x r -> Nothing <$ exitScope (x, r)
   Iden iden span docsLiteralRange -> get @[ContextToken] >>= pure . \case
@@ -63,7 +64,7 @@ contextualizing Blob{..} toKind = Streaming.mapMaybeM $ \case
       -> Just $ Tag iden kind span (firstLine (slice r)) (slice <$> docsLiteralRange)
     _ -> Nothing
   where
-    slice = stripEnd . Source.toText . Source.slice blobSource
+    slice = stripEnd . Source.toText . Source.slice source
     firstLine = T.take 180 . fst . breakOn "\n"
 
 enterScope, exitScope :: ( Member (State [ContextToken]) sig

test/Tags/Spec.hs

@@ -10,40 +10,40 @@ spec = do
   describe "go" $ do
     it "produces tags for functions with docs" $ do
       (blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/simple_functions.go")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "TestFromBits" Function (Span (Pos 6 1) (Pos 8 2)) "func TestFromBits(t *testing.T) {" (Just "// TestFromBits ...")
         , Tag "Hi" Function (Span (Pos 10 1) (Pos 11 2)) "func Hi()" Nothing ]
 
     it "produces tags for methods" $ do
       (blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/method.go")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "CheckAuth" Method (Span (Pos 3 1) (Pos 3 100)) "func (c *apiClient) CheckAuth(req *http.Request, user, repo string) (*authenticatedActor, error)" Nothing]
 
     it "produces tags for calls" $ do
       (blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/simple_functions.go")
-      runTagging blob ["Call"] tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) ["Call"] tree `shouldBe`
         [ Tag "Hi" Call (Span (Pos 7 2) (Pos 7 6)) "Hi()" Nothing]
 
   describe "javascript and typescript" $ do
     it "produces tags for functions with docs" $ do
       (blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/javascript/tags/simple_function_with_docs.js")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "myFunction" Function (Span (Pos 2 1) (Pos 4 2)) "function myFunction()" (Just "// This is myFunction") ]
 
     it "produces tags for classes" $ do
       (blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/typescript/tags/class.ts")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "FooBar" Class (Span (Pos 1 1) (Pos 1 16)) "class FooBar" Nothing ]
 
     it "produces tags for modules" $ do
       (blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/typescript/tags/module.ts")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "APromise" Tags.Module (Span (Pos 1 1) (Pos 1 20)) "module APromise { }" Nothing ]
 
   describe "python" $ do
     it "produces tags for functions" $ do
       (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/simple_functions.py")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "Foo" Function (Span (Pos 1 1) (Pos 5 17)) "def Foo(x):" Nothing
         , Tag "Bar" Function (Span (Pos 7 1) (Pos 11 13)) "def Bar():" Nothing
         , Tag "local" Function (Span (Pos 8 5) (Pos 9 17)) "def local():" Nothing
@@ -51,30 +51,30 @@ spec = do
 
     it "produces tags for functions with docs" $ do
       (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/simple_function_with_docs.py")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "Foo" Function (Span (Pos 1 1) (Pos 3 13)) "def Foo(x):" (Just "\"\"\"This is the foo function\"\"\"") ]
 
     it "produces tags for classes" $ do
       (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/class.py")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "Foo" Class (Span (Pos 1 1) (Pos 5 17)) "class Foo:" (Just "\"\"\"The Foo class\"\"\"")
         , Tag "f" Function (Span (Pos 3 5) (Pos 5 17)) "def f(self):" (Just "\"\"\"The f method\"\"\"")
         ]
 
     it "produces tags for multi-line functions" $ do
       (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/multiline.py")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "Foo" Function (Span (Pos 1 1) (Pos 3 13)) "def Foo(x," Nothing ]
 
   describe "ruby" $ do
     it "produces tags for methods" $ do
       (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method.rb")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "foo" Method (Span (Pos 1 1) (Pos 4 4)) "def foo" Nothing ]
 
     it "produces tags for sends" $ do
       (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method.rb")
-      runTagging blob ["Send"] tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) ["Send"] tree `shouldBe`
         [ Tag "puts" Call (Span (Pos 2 3) (Pos 2 12)) "puts \"hi\"" Nothing
         , Tag "bar" Call (Span (Pos 3 3) (Pos 3 8)) "a.bar" Nothing
         , Tag "a" Call (Span (Pos 3 3) (Pos 3 4)) "a" Nothing
@@ -82,17 +82,17 @@ spec = do
 
     it "produces tags for methods with docs" $ do
       (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method_with_docs.rb")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "foo" Method (Span (Pos 2 1) (Pos 3 4)) "def foo" (Just "# Public: foo") ]
 
     it "correctly tags files containing multibyte UTF-8 characters" $ do
       (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/unicode_identifiers.rb")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "日本語" Method (Span (Pos 2 1) (Pos 4 4)) "def 日本語" (Just "# coding: utf-8")]
 
     it "produces tags for methods and classes with docs" $ do
       (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/class_module.rb")
-      runTagging blob symbolsToSummarize tree `shouldBe`
+      runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
         [ Tag "Foo" Tags.Module (Span (Pos 2 1 ) (Pos 12 4)) "module Foo" (Just "# Public: Foo")
         , Tag "Bar" Class  (Span (Pos 5 3 ) (Pos 11 6)) "class Bar" (Just "# Public: Bar")
         , Tag "baz" Method (Span (Pos 8 5 ) (Pos 10 8)) "def baz(a)" (Just "# Public: baz")