diff --git a/src/Command.hs b/src/Command.hs index f5835368b..7cb5690af 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -26,7 +26,7 @@ data CommandF f where ReadFile :: FilePath -> CommandF SourceBlob ReadFilesAtSHAs :: FilePath -> [FilePath] -> String -> String -> CommandF [(SourceBlob, SourceBlob)] - Parse :: Language -> SourceBlob -> CommandF (Term (Syntax Text) (Record '[Range, Category, SourceSpan])) + Parse :: Language -> SourceBlob -> CommandF (Term (Syntax Text) (Record DefaultFields)) -- read the list of files changed between a pair of SHAs diff --git a/src/Command/Diff.hs b/src/Command/Diff.hs index b101f9cb9..4c3c636f3 100644 --- a/src/Command/Diff.hs +++ b/src/Command/Diff.hs @@ -68,13 +68,13 @@ fetchDiffs args@Arguments{..} = do fetchDiff args <$> paths pure $ uncurry (renderDiff args) <$> diffs -fetchDiff :: Arguments -> FilePath -> IO (Both SourceBlob, SyntaxDiff Text '[Range, Category, SourceSpan]) +fetchDiff :: Arguments -> FilePath -> IO (Both SourceBlob, SyntaxDiff Text DefaultFields) fetchDiff args@Arguments{..} filepath = withRepository lgFactory gitDir $ do repo <- getRepository for_ alternateObjectDirs (liftIO . odbBackendAddPath repo . toS) go args filepath where - go :: Arguments -> FilePath -> ReaderT LgRepo IO (Both SourceBlob, SyntaxDiff Text '[Range, Category, SourceSpan]) + go :: Arguments -> FilePath -> ReaderT LgRepo IO (Both SourceBlob, SyntaxDiff Text DefaultFields) go Arguments{..} filepath = do liftIO $ traceEventIO ("START fetchDiff: " <> filepath) sourcesAndOids <- sequence $ traverse (getSourceBlob filepath) <$> shaRange diff --git a/src/Command/Parse.hs b/src/Command/Parse.hs index 909274ce7..5da79c5a4 100644 --- a/src/Command/Parse.hs +++ b/src/Command/Parse.hs @@ -89,7 +89,7 @@ parseDecorator False = const . const Nothing buildParseNodes :: forall nodes b. (FilePath -> nodes -> b) -> (CofreeF (Syntax Text) (Record '[Maybe SourceText, Range, Category, SourceSpan]) (Cofree (Syntax Text) (Record '[Maybe SourceText, Range, Category, SourceSpan]), nodes) -> nodes) - -> (Source -> TermDecorator (Syntax Text) '[Range, Category, SourceSpan] (Maybe SourceText)) + -> (Source -> TermDecorator (Syntax Text) DefaultFields (Maybe SourceText)) -> [SourceBlob] -> IO [b] buildParseNodes programNodeConstructor algebra termDecorator sourceBlobs = @@ -150,15 +150,15 @@ sourceBlobsFromArgs Arguments{..} = _ -> sourceBlobsFromPaths filePaths -- | Return a parser incorporating the provided TermDecorator. -parseWithDecorator :: TermDecorator (Syntax Text) '[Range, Category, SourceSpan] field -> FilePath -> Parser (Syntax Text) (Record '[field, Range, Category, SourceSpan]) +parseWithDecorator :: TermDecorator (Syntax Text) DefaultFields field -> FilePath -> Parser (Syntax Text) (Record '[field, Range, Category, SourceSpan]) parseWithDecorator decorator path blob = decorateTerm decorator <$> parserForType (toS (takeExtension path)) blob -- | Return a parser based on the file extension (including the "."). -parserForType :: Text -> Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) +parserForType :: Text -> Parser (Syntax Text) (Record DefaultFields) parserForType mediaType = maybe lineByLineParser parserForLanguage (languageForType mediaType) -- | Select a parser for a given Language. -parserForLanguage :: Language -> Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) +parserForLanguage :: Language -> Parser (Syntax Text) (Record DefaultFields) parserForLanguage language = case language of C -> treeSitterParser C tree_sitter_c JavaScript -> treeSitterParser JavaScript tree_sitter_javascript @@ -180,7 +180,7 @@ termSourceTextDecorator source term = Just . SourceText . toText $ Source.slice where range' = byteRange $ headF term -- | A fallback parser that treats a file simply as rows of strings. -lineByLineParser :: Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) +lineByLineParser :: Parser (Syntax Text) (Record DefaultFields) lineByLineParser SourceBlob{..} = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of (leaves, _) -> cofree <$> leaves where @@ -192,5 +192,5 @@ lineByLineParser SourceBlob{..} = pure . cofree . root $ case foldl' annotateLea (accum <> [ leaf charIndex (Source.toText line) ] , charIndex + Source.length line) -- | Return the parser that should be used for a given path. -parserForFilepath :: FilePath -> Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) +parserForFilepath :: FilePath -> Parser (Syntax Text) (Record DefaultFields) parserForFilepath = parserForType . toS . takeExtension diff --git a/src/Language/C.hs b/src/Language/C.hs index 740a14359..5796bef6e 100644 --- a/src/Language/C.hs +++ b/src/Language/C.hs @@ -10,8 +10,8 @@ import Term termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. - -> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan])) -- ^ The resulting term, in Maybe. + -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. + -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment _ _ _ = Nothing diff --git a/src/Language/Go.hs b/src/Language/Go.hs index 58cce229e..699bee934 100644 --- a/src/Language/Go.hs +++ b/src/Language/Go.hs @@ -10,8 +10,8 @@ import qualified Syntax as S termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. - -> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan])) -- ^ The resulting term, in Maybe. + -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. + -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment source category children = case (category, children) of (Module, [moduleName]) -> Just $ S.Module moduleName [] (Import, [importName]) -> Just $ S.Import importName [] diff --git a/src/Language/JavaScript.hs b/src/Language/JavaScript.hs index 719f766c6..78a3008a9 100644 --- a/src/Language/JavaScript.hs +++ b/src/Language/JavaScript.hs @@ -11,8 +11,8 @@ import Term termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. - -> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan])) -- ^ The resulting term, in Maybe. + -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. + -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment _ category children = case (category, children) of (Assignment, [ identifier, value ]) -> Just $ S.Assignment identifier value diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index 7fe5316d7..90a9c99d3 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -10,9 +10,9 @@ import Prologue import Source import Syntax -cmarkParser :: Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) +cmarkParser :: Parser (Syntax Text) (Record DefaultFields) cmarkParser SourceBlob{..} = pure . toTerm (totalRange source) (rangeToSourceSpan source $ totalRange source) $ commonmarkToNode [ optSourcePos, optSafe ] (toText source) - where toTerm :: Range -> SourceSpan -> Node -> Cofree (Syntax Text) (Record '[Range, Category, SourceSpan]) + where toTerm :: Range -> SourceSpan -> Node -> Cofree (Syntax Text) (Record DefaultFields) toTerm within withinSpan (Node position t children) = let range = maybe within (sourceSpanToRange source . toSpan) position diff --git a/src/Language/Ruby.hs b/src/Language/Ruby.hs index 208ade2a7..323d61297 100644 --- a/src/Language/Ruby.hs +++ b/src/Language/Ruby.hs @@ -12,8 +12,8 @@ import Term termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. - -> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan])) -- ^ The resulting term, in Maybe. + -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. + -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment _ category children = case (category, children) of (ArgumentPair, [ k, v ] ) -> Just $ S.Pair k v diff --git a/src/Language/TypeScript.hs b/src/Language/TypeScript.hs index 93932de32..b7db1e0df 100644 --- a/src/Language/TypeScript.hs +++ b/src/Language/TypeScript.hs @@ -11,8 +11,8 @@ import Term termAssignment :: Source -- ^ The source of the term. -> Category -- ^ The category for the term. - -> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -- ^ The child nodes of the term. - -> Maybe (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan])) -- ^ The resulting term, in Maybe. + -> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term. + -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe. termAssignment _ category children = case (category, children) of (Assignment, [ identifier, value ]) -> Just $ S.Assignment identifier value diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index c5c3d69db..21bf445f6 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -29,7 +29,7 @@ import SourceSpan import Info -- | Returns a TreeSitter parser for the given language and TreeSitter grammar. -treeSitterParser :: Language -> Ptr TS.Language -> Parser (Syntax.Syntax Text) (Record '[Range, Category, SourceSpan]) +treeSitterParser :: Language -> Ptr TS.Language -> Parser (Syntax.Syntax Text) (Record DefaultFields) treeSitterParser language grammar blob = do document <- ts_document_new ts_document_set_language document grammar @@ -42,13 +42,13 @@ treeSitterParser language grammar blob = do -- | Return a parser for a tree sitter language & document. -documentToTerm :: Language -> Ptr Document -> Parser (Syntax.Syntax Text) (Record '[Range, Category, SourceSpan]) +documentToTerm :: Language -> Ptr Document -> Parser (Syntax.Syntax Text) (Record DefaultFields) documentToTerm language document SourceBlob{..} = do root <- alloca (\ rootPtr -> do ts_document_root_node_p document rootPtr peek rootPtr) toTerm root source - where toTerm :: Node -> Source -> IO (Term (Syntax.Syntax Text) (Record '[Range, Category, SourceSpan])) + where toTerm :: Node -> Source -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) toTerm node source = do name <- peekCString (nodeType node) @@ -77,7 +77,7 @@ nodeSpan :: Node -> SourceSpan nodeSpan Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` SourceSpan (pointPos nodeStartPoint) (pointPos nodeEndPoint) where pointPos TSPoint{..} = pointRow `seq` pointColumn `seq` SourcePos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn) -assignTerm :: Language -> Source -> Record '[Range, Category, SourceSpan] -> [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> IO [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> IO (SyntaxTerm Text '[ Range, Category, SourceSpan ]) +assignTerm :: Language -> Source -> Record DefaultFields -> [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> IO [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> IO (SyntaxTerm Text '[ Range, Category, SourceSpan ]) assignTerm language source annotation children allChildren = cofree . (annotation :<) <$> case assignTermByLanguage language source (category annotation) children of Just a -> pure a @@ -91,7 +91,7 @@ assignTerm language source annotation children allChildren = TypeScript -> TS.termAssignment _ -> \ _ _ _ -> Nothing -defaultTermAssignment :: Source -> Category -> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -> IO [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -> IO (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan])) +defaultTermAssignment :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (S.Syntax Text (SyntaxTerm Text DefaultFields)) defaultTermAssignment source category children allChildren | category `elem` operatorCategories = S.Operator <$> allChildren | otherwise = pure $! case (category, children) of @@ -137,7 +137,7 @@ categoryForLanguageProductionName = withDefaults . byLanguage withDefaults productionMap name = case name of "ERROR" -> ParseError s -> productionMap s - + byLanguage language = case language of JavaScript -> JS.categoryForJavaScriptProductionName C -> C.categoryForCProductionName diff --git a/test/IntegrationSpec.hs b/test/IntegrationSpec.hs index 519acf8d3..1c12fc4da 100644 --- a/test/IntegrationSpec.hs +++ b/test/IntegrationSpec.hs @@ -115,7 +115,7 @@ testParse path expectedOutput = do expected <- (Verbatim . stripWhitespace) <$> B.readFile expectedOutput actual `shouldBe` expected -testDiff :: Renderer (Record '[Range, Category, SourceSpan]) -> Both FilePath -> FilePath -> Expectation +testDiff :: Renderer (Record DefaultFields) -> Both FilePath -> FilePath -> Expectation testDiff renderer paths expectedOutput = do sources <- traverse readAndTranscodeFile' paths diff <- diffFiles parser (sourceBlobs sources) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 257b7a10a..8111e47a0 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -117,8 +117,8 @@ spec = parallel $ do output <- diffOutput sourceBlobs output `shouldBe` "{\"changes\":{},\"errors\":{\"ruby/methods.A.rb -> ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"def bar\\nen\\n\"}]}}" -type Diff' = SyntaxDiff String '[Range, Category, SourceSpan] -type Term' = SyntaxTerm String '[Range, Category, SourceSpan] +type Diff' = SyntaxDiff String DefaultFields +type Term' = SyntaxTerm String DefaultFields diffOutput :: Both SourceBlob -> IO ByteString diffOutput sourceBlobs = do @@ -161,14 +161,14 @@ functionOf name body = cofree $ functionInfo :< S.Function name' [] [body] where name' = cofree $ (Range 0 0 :. C.Identifier :. sourceSpanBetween (0,0) (0,0) :. Nil) :< Leaf name -programInfo :: Record '[Range, Category, SourceSpan] +programInfo :: Record DefaultFields programInfo = Range 0 0 :. C.Program :. sourceSpanBetween (0,0) (0,0) :. Nil -functionInfo :: Record '[Range, Category, SourceSpan] +functionInfo :: Record DefaultFields functionInfo = Range 0 0 :. C.Function :. sourceSpanBetween (0,0) (0,0) :. Nil -- Filter tiers for terms that we consider "meaniningful" in TOC summaries. -isMeaningfulTerm :: ListableF (Term (Syntax leaf)) (Record '[Range, Category, SourceSpan]) -> Bool +isMeaningfulTerm :: ListableF (Term (Syntax leaf)) (Record DefaultFields) -> Bool isMeaningfulTerm a = case runCofree (unListableF a) of (_ :< S.Indexed _) -> False (_ :< S.Fixed _) -> False @@ -177,7 +177,7 @@ isMeaningfulTerm a = case runCofree (unListableF a) of _ -> True -- Filter tiers for terms if the Syntax is a Method or a Function. -isMethodOrFunction :: ListableF (Term (Syntax leaf)) (Record '[Range, Category, SourceSpan]) -> Bool +isMethodOrFunction :: ListableF (Term (Syntax leaf)) (Record DefaultFields) -> Bool isMethodOrFunction a = case runCofree (unListableF a) of (_ :< S.Method{}) -> True (_ :< S.Function{}) -> True @@ -186,7 +186,7 @@ isMethodOrFunction a = case runCofree (unListableF a) of (a :< _) | getField a == C.SingletonMethod -> True _ -> False -testDiff :: Both SourceBlob -> IO (Diff (Syntax Text) (Record '[Range, Category, SourceSpan])) +testDiff :: Both SourceBlob -> IO (Diff (Syntax Text) (Record DefaultFields)) testDiff sourceBlobs = diffFiles parser sourceBlobs where parser = parserForFilepath (path . fst $ sourceBlobs)