diff --git a/semantic-python/test/Instances.hs b/semantic-python/test/Instances.hs index d7d672b9a..7f00a636a 100644 --- a/semantic-python/test/Instances.hs +++ b/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 diff --git a/src/Control/Carrier/Parse/Measured.hs b/src/Control/Carrier/Parse/Measured.hs index fddbd3d30..2116ea22a 100644 --- a/src/Control/Carrier/Parse/Measured.hs +++ b/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 diff --git a/src/Control/Carrier/Parse/Simple.hs b/src/Control/Carrier/Parse/Simple.hs index d7bf004dc..9339f041b 100644 --- a/src/Control/Carrier/Parse/Simple.hs +++ b/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) diff --git a/src/Diffing/Algorithm/RWS.hs b/src/Diffing/Algorithm/RWS.hs index ca6966cf8..5097a67c6 100644 --- a/src/Diffing/Algorithm/RWS.hs +++ b/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) - -> (Term syntax (FeatureVector, ann) -> Term syntax (FeatureVector, ann) -> Bool) - -> [Term syntax (FeatureVector, ann)] - -> [Term syntax (FeatureVector, ann)] - -> EditScript (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) + => ComparabilityRelation syntax (FeatureVector, ann1) (FeatureVector, ann2) + -> (Term syntax (FeatureVector, ann1) -> Term syntax (FeatureVector, ann2) -> Bool) + -> [Term syntax (FeatureVector, ann1)] + -> [Term syntax (FeatureVector, ann2)] + -> 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] diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index aeb67c242..0359952da 100644 --- a/src/Diffing/Interpreter.hs +++ b/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 ann - -> Diff.Diff syntax ann ann + => Term syntax ann1 + -> Term syntax ann2 + -> 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 ann ann + => Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2) + -> Diff.Diff syntax ann1 ann2 stripDiff = bimap snd snd --- | Diff a 'These' of terms. -diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Diff.Diff syntax ann ann -diffTermPair = these Diff.deleting Diff.inserting diffTerms +class DiffTerms term diff | diff -> term, term -> diff where + -- | Diff a 'These' of terms. + 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, ann)) - (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) - (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m) + (Term syntax (FeatureVector, ann1)) + (Term syntax (FeatureVector, ann2)) + (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) + (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) - (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m) where + (Diff (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) :+: sig) + (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 diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index c287bdb78..3443805fd 100644 --- a/src/Parsing/Parser.hs +++ b/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) diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 207898e26..a371aff3c 100644 --- a/src/Rendering/TOC.hs +++ b/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 diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 22e750986..5eb41b112 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/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 (diffTermPair) +import Diffing.Interpreter (DiffTerms(..)) 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 DiffShow = distributeFoldMap showDiff -parseDiffBuilder DiffDotGraph = distributeFoldMap dotGraphDiff +parseDiffBuilder DiffSExpression = distributeFoldMap (doDiff (const id) sexprDiff) +parseDiffBuilder DiffShow = distributeFoldMap (doDiff (const id) showDiff) +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) => RenderJSON m syntax -> BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) -jsonDiff f blobPair = doDiff blobPair (const id) f `catchError` jsonError blobPair +jsonDiff :: DiffEffects sig m => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) +jsonDiff blobPair = doDiff (const id) (pure . jsonTreeDiff blobPair) blobPair `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 blobPair = doDiff blobPair (const id) render + go :: DiffEffects sig m => BlobPair -> m DiffTreeFileGraph + 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 syntax . CanDiff syntax => Blob -> Term syntax a -> Term syntax b +type Decorate a b = forall term diff . DiffActions term diff => Blob -> term a -> term b -type TermPairConstraints = - '[ ConstructorName - , Diffable - , Eq1 - , HasDeclaration - , Hashable1 - , Show1 - , Traversable - , ToJSONFields1 - ] -doDiff :: (DiffEffects sig m) - => BlobPair -> Decorate Loc ann -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output) -> m output -doDiff blobPair decorate render = do +class DOTGraphDiff diff where + dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder + +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) - => BlobPair -> Join These (Term syntax ann) -> m (Diff syntax ann ann) +diffTerms :: (DiffActions term diff, Member Telemetry sig, Carrier sig m, MonadIO m) + => 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 - SomeTermPair :: ApplyAll typeclasses syntax => Join These (Term syntax ann) -> SomeTermPair typeclasses ann - -withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a -withSomeTermPair with (SomeTermPair terms) = with terms +data SomeTermPair ann where + SomeTermPair :: DiffActions term diff => Join These (term ann) -> SomeTermPair ann diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 31b3f6c3e..9aabbe786 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/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 Parsing.Parser +import qualified Parsing.Parser as 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 blob@Blob{..} = (doParse blob >>= withSomeTerm renderToSymbols) `catchError` (\(SomeException _) -> pure (pure emptyFile)) + go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m [Legacy.File] + 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 = pure . pure . tagsToFile . runTagging blob symbolsToSummarize + renderToSymbols :: Precise.ToTags t => t Loc -> [Legacy.File] + 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 blobs = do - modes <- ask - ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs (go modes) +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 = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go where - go :: ParseEffects sig m => PerLanguageModes -> Blob -> m File - go modes blob@Blob{..} - | Precise <- pythonMode modes - , Python <- blobLanguage' - = catching $ renderPreciseToSymbols <$> parse precisePythonParser blob - | otherwise = catching $ withSomeTerm renderToSymbols <$> doParse blob + go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m File + go blob@Blob{..} = catching $ doParse (pure . renderToSymbols) symbolsToSummarize 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 term = tagsToFile (runTagging blob symbolsToSummarize term) - - renderPreciseToSymbols :: Py.Term Loc -> File - renderPreciseToSymbols term = tagsToFile (Precise.tags blobSource term) + renderToSymbols :: Precise.ToTags t => t Loc -> File + renderToSymbols 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 diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index dcbdff76f..9af3fc53a 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/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 blobPair = doDiff blobPair (\ blob -> decoratorWithAlgebra (declarationAlgebra blob)) render + go :: DiffEffects sig m => BlobPair -> m Summaries + 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 blobPair = doDiff blobPair (\ blob -> decoratorWithAlgebra (declarationAlgebra blob)) render + go :: DiffEffects sig m => BlobPair -> m TOCSummaryFile + 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) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 30cfa3fae..75f95f293 100644 --- a/src/Semantic/Api/Terms.hs +++ b/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 TermDotGraph = distributeFoldMap dotGraphTerm -parseTermBuilder TermShow = distributeFoldMap showTerm +parseTermBuilder TermSExpression = distributeFoldMap (doParse sexprTerm) +parseTermBuilder TermDotGraph = distributeFoldMap (doParse dotGraphTerm) +parseTermBuilder TermShow = distributeFoldMap (doParse showTerm) parseTermBuilder TermQuiet = distributeFoldMap quietTerm -jsonTerm :: (ParseEffects sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) -jsonTerm blob = (doParse blob >>= withSomeTerm (pure . renderJSONTerm blob)) `catchError` jsonError blob +jsonTerm :: ParseEffects sig m => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) +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) -doParse blob = case blobLanguage blob of - Go -> SomeTerm <$> parse goParser blob - Haskell -> SomeTerm <$> parse haskellParser blob - JavaScript -> SomeTerm <$> parse tsxParser blob - JSON -> SomeTerm <$> parse jsonParser blob - JSX -> SomeTerm <$> parse tsxParser blob - Markdown -> SomeTerm <$> parse markdownParser blob - Python -> SomeTerm <$> parse pythonParser blob - Ruby -> SomeTerm <$> parse rubyParser blob - TypeScript -> SomeTerm <$> parse typescriptParser blob - TSX -> SomeTerm <$> parse tsxParser blob - PHP -> SomeTerm <$> parse phpParser blob +class ShowTerm term where + showTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder + +instance (Functor syntax, Show1 syntax) => ShowTerm (Term syntax) where + showTerm = serialize Show . quieterm + +instance ShowTerm Py.Term where + showTerm = serialize Show . Py.getTerm + + +class SExprTerm term where + sexprTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder + +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) diff --git a/src/Serializing/SExpression/Precise.hs b/src/Serializing/SExpression/Precise.hs index f1807042d..a0b0ef098 100644 --- a/src/Serializing/SExpression/Precise.hs +++ b/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 diff --git a/src/Tags/Taggable.hs b/src/Tags/Taggable.hs index 8010186ce..5b265d772 100644 --- a/src/Tags/Taggable.hs +++ b/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) diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index 71127736a..46a5de3ef 100644 --- a/src/Tags/Tagging.hs +++ b/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 - . tagging blob + . contextualizing source toKind + . 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 diff --git a/test/Tags/Spec.hs b/test/Tags/Spec.hs index 90c235805..24089583c 100644 --- a/test/Tags/Spec.hs +++ b/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")