github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into update-ci

Browse Source 
* master:
  Stop publishing binaries to S3
  I guess GHC thinks these UNPACKs are unusable.
  legacyMakeBlob => makeBlob. Also unpack File.
  If we're not gonna rename File, give Blob the logical field name.
  Fix shadowing issues.
  Fix shadowing issues.
  Fix all the test cases.
  absolutely massive patch that touches everything
This commit is contained in:
Douglas Creager 2019-05-24 13:23:56 -04:00
commit 2854065c89
30 changed files with 150 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
semantic.cabal
View File

@ -128,10 +128,10 @@ library
, Data.Algebra
, Data.AST
, Data.Blob
, Data.Blob.IO
, Data.Diff
, Data.Duration
, Data.Error
, Data.File
, Data.Flag
, Data.Functor.Both
, Data.Functor.Classes.Generic

18
src/Analysis/TOCSummary.hs
View File

@ -76,8 +76,8 @@ class CustomHasDeclaration whole syntax where
-- | Produce a 'HeadingDeclaration' from the first line of the heading of a 'Markdown.Heading' node.
instance CustomHasDeclaration whole Markdown.Heading where
customToDeclaration Blob{..} ann (Markdown.Heading level terms _)
= Just $ HeadingDeclaration (headingText terms) mempty (locationSpan ann) blobLanguage level
customToDeclaration blob@Blob{..} ann (Markdown.Heading level terms _)
= Just $ HeadingDeclaration (headingText terms) mempty (locationSpan ann) (blobLanguage blob) level
where headingText terms = getSource $ maybe (locationByteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms))
headingByteRange (Term (In ann _), _) = locationByteRange ann
getSource = firstLine . toText . flip Source.slice blobSource
@ -85,8 +85,8 @@ instance CustomHasDeclaration whole Markdown.Heading where
-- | Produce an 'ErrorDeclaration' for 'Syntax.Error' nodes.
instance CustomHasDeclaration whole Syntax.Error where
customToDeclaration Blob{..} ann err@Syntax.Error{}
= Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (locationSpan ann) err))) mempty (locationSpan ann) blobLanguage
customToDeclaration blob@Blob{..} ann err@Syntax.Error{}
= Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (locationSpan ann) err))) mempty (locationSpan ann) (blobLanguage blob)
where formatTOCError e = showExpectation (flag Colourize False) (errorExpected e) (errorActual e) ""
-- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range').
@ -95,7 +95,7 @@ instance CustomHasDeclaration whole Declaration.Function where
-- Do not summarize anonymous functions
| isEmpty identifierAnn = Nothing
-- Named functions
| otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (locationSpan ann) blobLanguage
| otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (locationSpan ann) (blobLanguage blob)
where isEmpty = (== 0) . rangeLength . locationByteRange
functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl)
@ -103,12 +103,12 @@ instance CustomHasDeclaration whole Declaration.Function where
instance CustomHasDeclaration whole Declaration.Method where
customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _ _)
-- Methods without a receiver
| isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) blobLanguage Nothing
| isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) (blobLanguage blob) Nothing
-- Methods with a receiver type and an identifier (e.g. (a *Type) in Go).
| blobLanguage == Go
, [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) blobLanguage (Just (getSource blobSource receiverType))
| blobLanguage blob == Go
, [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) (blobLanguage blob) (Just (getSource blobSource receiverType))
-- Methods with a receiver (class methods) are formatted like `receiver.method_name`
| otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) blobLanguage (Just (getSource blobSource receiverAnn))
| otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) (blobLanguage blob) (Just (getSource blobSource receiverAnn))
where
isEmpty = (== 0) . rangeLength . locationByteRange
methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl)

6
src/Data/Abstract/Module.hs
View File

@ -28,9 +28,9 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo
-> Blob -- ^ The 'Blob' containing the module.
-> term -- ^ The @term@ representing the body of the module.
-> Module term -- ^ A 'Module' named appropriate for the 'Blob', holding the @term@, and constructed relative to the root 'FilePath', if any.
moduleForBlob rootDir Blob{..} = Module info
where root = fromMaybe (takeDirectory blobPath) rootDir
info = ModuleInfo (makeRelative root blobPath) blobLanguage blobOid
moduleForBlob rootDir b = Module info
where root = fromMaybe (takeDirectory (blobPath b)) rootDir
info = ModuleInfo (makeRelative root (blobPath b)) (blobLanguage b) (blobOid b)
type ModulePath = FilePath

58
src/Data/Blob.hs
View File

@ -1,7 +1,12 @@
{-# LANGUAGE DeriveAnyClass, ExplicitNamespaces, PatternSynonyms #-}
module Data.Blob
( Blob(..)
( File(..)
, fileForPath
, Blob(..)
, Blobs(..)
, blobLanguage
, blobPath
, makeBlob
, decodeBlobs
, nullBlob
, sourceBlob
@ -28,14 +33,32 @@ import Data.JSON.Fields
import Data.Language
import Data.Source as Source
-- | The source, path, and language of a blob.
-- | A 'FilePath' paired with its corresponding 'Language'.
-- Unpacked to have the same size overhead as (FilePath, Language).
data File = File
{ filePath :: FilePath
, fileLanguage :: Language
} deriving (Show, Eq, Generic)
fileForPath :: FilePath -> File
fileForPath p = File p (languageForFilePath p)
-- | The source, path information, and language of a file read from disk.
data Blob = Blob
{ blobSource :: Source -- ^ The UTF-8 encoded source text of the blob.
, blobPath :: FilePath -- ^ The file path to the blob.
, blobLanguage :: Language -- ^ The language of this blob.
, blobOid :: Text -- ^ Git OID for this blob, mempty if blob is not from a git db.
}
deriving (Show, Eq, Generic)
{ blobSource :: Source -- ^ The UTF-8 encoded source text of the blob.
, blobFile :: File -- ^ Path/language information for this blob.
, blobOid :: Text -- ^ Git OID for this blob, mempty if blob is not from a git db.
} deriving (Show, Eq, Generic)
blobLanguage :: Blob -> Language
blobLanguage = fileLanguage . blobFile
blobPath :: Blob -> FilePath
blobPath = filePath . blobFile
makeBlob :: Source -> FilePath -> Language -> Text -> Blob
makeBlob s p l = Blob s (File p l)
{-# INLINE makeBlob #-}
newtype Blobs a = Blobs { blobs :: [a] }
deriving (Generic, FromJSON)
@ -50,12 +73,12 @@ nullBlob :: Blob -> Bool
nullBlob Blob{..} = nullSource blobSource
sourceBlob :: FilePath -> Language -> Source -> Blob
sourceBlob filepath language source = Blob source filepath language mempty
sourceBlob filepath language source = makeBlob source filepath language mempty
inferringLanguage :: Source -> FilePath -> Language -> Blob
inferringLanguage src pth lang
| knownLanguage lang = Blob src pth lang mempty
| otherwise = Blob src pth (languageForFilePath pth) mempty
| knownLanguage lang = makeBlob src pth lang mempty
| otherwise = makeBlob src pth (languageForFilePath pth) mempty
decodeBlobs :: BL.ByteString -> Either String [Blob]
decodeBlobs = fmap blobs <$> eitherDecode
@ -100,8 +123,8 @@ maybeBlobPair a b = case (a, b) of
_ -> Prologue.fail "expected file pair with content on at least one side"
languageForBlobPair :: BlobPair -> Language
languageForBlobPair (Deleting Blob{..}) = blobLanguage
languageForBlobPair (Inserting Blob{..}) = blobLanguage
languageForBlobPair (Deleting b) = blobLanguage b
languageForBlobPair (Inserting b) = blobLanguage b
languageForBlobPair (Diffing a b)
| blobLanguage a == Unknown || blobLanguage b == Unknown
= Unknown
@ -109,9 +132,10 @@ languageForBlobPair (Diffing a b)
= blobLanguage b
pathForBlobPair :: BlobPair -> FilePath
pathForBlobPair (Deleting Blob{..}) = blobPath
pathForBlobPair (Inserting Blob{..}) = blobPath
pathForBlobPair (Diffing _ Blob{..}) = blobPath
pathForBlobPair x = blobPath $ case x of
(Inserting b) -> b
(Deleting b) -> b
(Diffing _ b) -> b
languageTagForBlobPair :: BlobPair -> [(String, String)]
languageTagForBlobPair pair = showLanguage (languageForBlobPair pair)
@ -125,7 +149,7 @@ pathKeyForBlobPair blobs = case bimap blobPath blobPath (runJoin blobs) of
| otherwise -> before <> " -> " <> after
instance ToJSONFields Blob where
toJSONFields Blob{..} = [ "path" .= blobPath, "language" .= blobLanguage ]
toJSONFields p = [ "path" .= blobPath p, "language" .= blobLanguage p]
decodeBlobPairs :: BL.ByteString -> Either String [BlobPair]
decodeBlobPairs = fmap blobs <$> eitherDecode

43
src/Data/File.hs → src/Data/Blob/IO.hs
View File

@ -1,39 +1,24 @@
{-# LANGUAGE RankNTypes #-}
module Data.File
( File (..)
, file
, toFile
, readBlobFromFile
-- | These are primitive file IO methods for use in ghci and as internal functions.
-- Instead of using these, consider if you can use the Files DSL instead.
module Data.Blob.IO
( readBlobFromFile
, readBlobFromFile'
, readBlobsFromDir
, readBlobsFromGitRepo
, readFilePair
) where
import qualified Control.Concurrent.Async as Async
import Data.Blob
import qualified Data.ByteString as B
import Data.Language
import Data.Source
import Prologue
import Prologue
import Data.Blob
import Data.Language
import Semantic.IO
import Data.Source
import qualified Semantic.Git as Git
import Semantic.IO
import System.FilePath.Posix
data File = File
{ filePath :: FilePath
, fileLanguage :: Language
} deriving (Eq, Ord, Show)
file :: FilePath -> File
file path = File path (languageForFilePath path)
where languageForFilePath = languageForType . takeExtension
-- This is kind of a wart; Blob and File should be two views of
-- the same higher-kinded datatype.
toFile :: Blob -> File
toFile (Blob _ p l _) = File p l
import qualified Control.Concurrent.Async as Async
import qualified Data.ByteString as B
-- | Read a utf8-encoded file to a 'Blob'.
readBlobFromFile :: forall m. MonadIO m => File -> m (Maybe Blob)
@ -51,7 +36,7 @@ readBlobFromFile' file = do
-- | Read all blobs in the directory with Language.supportedExts
readBlobsFromDir :: MonadIO m => FilePath -> m [Blob]
readBlobsFromDir path = liftIO . fmap catMaybes $
findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . file)
findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForPath)
-- | Read all blobs from the Git repo with Language.supportedExts
readBlobsFromGitRepo :: MonadIO m => FilePath -> Git.OID -> [FilePath] -> m [Blob]
@ -68,7 +53,7 @@ readBlobsFromGitRepo path oid excludePaths = liftIO . fmap catMaybes $
= Just . sourceBlob' path lang oid . fromText <$> Git.catFile gitDir oid
blobFromTreeEntry _ _ = pure Nothing
sourceBlob' filepath language (Git.OID oid) source = Blob source filepath language oid
sourceBlob' filepath language (Git.OID oid) source = makeBlob source filepath language oid
readFilePair :: MonadIO m => File -> File -> m BlobPair
readFilePair a b = do

2
src/Data/Error.hs
View File

@ -54,7 +54,7 @@ formatError includeSource colourize blob@Blob{..} Error{..}
. (if Flag.toBool LogPrintSource includeSource then showExcerpt colourize errorSpan blob else id)
. showCallStack colourize callStack . showChar '\n'
where
path = Just $ if Flag.toBool LogPrintSource includeSource then blobPath else "<filtered>"
path = Just $ if Flag.toBool LogPrintSource includeSource then blobPath blob else "<filtered>"
showExcerpt :: Flag Colourize -> Span -> Blob -> ShowS
showExcerpt colourize Span{..} Blob{..}

4
src/Data/Project.hs
View File

@ -18,7 +18,7 @@ import Prologue
import Control.Effect
import Control.Effect.Error
import Data.Blob
import Data.File
import Data.Blob.IO
import Data.Language
import qualified Data.Text as T
import System.FilePath.Posix
@ -52,7 +52,7 @@ projectExtensions :: Project -> [String]
projectExtensions = extensionsForLanguage . projectLanguage
projectFiles :: Project -> [File]
projectFiles = fmap toFile . projectBlobs
projectFiles = fmap blobFile . projectBlobs
newtype ProjectException
= FileNotFound FilePath

6
src/Parsing/TreeSitter.hs
View File

@ -65,7 +65,7 @@ parseToAST :: ( Bounded grammar
-> Ptr TS.Language
-> Blob
-> m (Maybe (AST [] grammar))
parseToAST parseTimeout language Blob{..} = bracket (liftIO TS.ts_parser_new) (liftIO . TS.ts_parser_delete) $ \ parser -> do
parseToAST parseTimeout language b@Blob{..} = bracket (liftIO TS.ts_parser_new) (liftIO . TS.ts_parser_delete) $ \ parser -> do
result <- liftIO $ do
let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout
TS.ts_parser_set_timeout_micros parser timeoutMicros
@ -73,8 +73,8 @@ parseToAST parseTimeout language Blob{..} = bracket (liftIO TS.ts_parser_new) (l
TS.ts_parser_set_language parser language
runParser parser blobSource
case result of
Failed -> Nothing <$ trace ("tree-sitter: parsing failed " <> blobPath)
(Succeeded ast) -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath)
Failed -> Nothing <$ trace ("tree-sitter: parsing failed " <> blobPath b)
(Succeeded ast) -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath b)
toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node)
toAST node@TS.Node{..} = do

9
src/Rendering/JSON.hs
View File

@ -105,10 +105,11 @@ renderJSONError blob e = JSON [ renderError blob e ]
-- | Render an error for a particular blob.
renderError :: ToJSON a => Blob -> a -> SomeJSON
renderError Blob{..} e = SomeJSON $ object
[ "error" .= e
, "path" .= blobPath
, "language" .= blobLanguage ]
renderError b e = SomeJSON $ object
[ "error" .= e
, "path" .= blobPath b
, "language" .= blobLanguage b
]
-- | Render an error for diffs.
renderJSONDiffError :: BlobPair -> String -> JSON "diffs" SomeJSON

4
src/Rendering/TOC.hs
View File

@ -144,10 +144,10 @@ diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declarat
diffTOC = fmap entrySummary . dedupe . tableOfContentsBy declaration
renderToCTerm :: (Foldable f, Functor f) => Blob -> Term f (Maybe Declaration) -> Summaries
renderToCTerm Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC
renderToCTerm b@Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC
where
toMap [] = mempty
toMap as = Map.singleton (T.pack blobPath) (toJSON <$> as)
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

4
src/Semantic/AST.hs
View File

@ -29,8 +29,8 @@ withSomeAST f (SomeAST ast) = f ast
astParseBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m SomeAST
astParseBlob blob@Blob{..}
| Just (SomeASTParser parser) <- someASTParser blobLanguage = SomeAST <$> parse parser blob
| otherwise = noLanguageForBlob blobPath
| Just (SomeASTParser parser) <- someASTParser (blobLanguage blob) = SomeAST <$> parse parser blob
| otherwise = noLanguageForBlob (blobPath blob)
data ASTFormat = SExpression | JSON | Show | Quiet

4
src/Semantic/Api/Bridge.hs
View File

@ -97,8 +97,8 @@ instance APIBridge T.Text Data.Language where
instance APIBridge API.Blob Data.Blob where
bridging = iso apiBlobToBlob blobToApiBlob where
blobToApiBlob Data.Blob{..} = API.Blob (toText blobSource) (T.pack blobPath) (bridging # blobLanguage)
apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (language ^. bridging) mempty
blobToApiBlob b = API.Blob (toText (Data.blobSource b)) (T.pack (Data.blobPath b)) (bridging # Data.blobLanguage b)
apiBlobToBlob API.Blob{..} = Data.makeBlob (fromText content) (T.unpack path) (language ^. bridging) mempty
instance APIConvert API.BlobPair Data.BlobPair where

2
src/Semantic/Api/LegacyTypes.hs
View File

@ -10,7 +10,7 @@ module Semantic.Api.LegacyTypes
) where
import Data.Aeson
import Data.Blob
import Data.Blob hiding (File(..))
import Prologue
newtype DiffTreeRequest = DiffTreeRequest { blobs :: [BlobPair] }

51
src/Semantic/Api/Symbols.hs
View File

@ -11,7 +11,7 @@ import Control.Effect
import Control.Effect.Error
import Control.Exception
import Control.Lens
import Data.Blob
import Data.Blob hiding (File (..))
import Data.ByteString.Builder
import Data.Location
import Data.Maybe
@ -34,27 +34,28 @@ legacyParseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t)
legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs
where
go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m [Legacy.File]
go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException _) -> pure (pure emptyFile))
where emptyFile = Legacy.File (pack blobPath) (pack (show blobLanguage)) []
go blob@Blob{..} = (doParse blob >>= withSomeTerm renderToSymbols) `catchError` (\(SomeException _) -> pure (pure emptyFile))
where
emptyFile = tagsToFile []
-- Legacy symbols output doesn't include Function Calls.
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module"]
-- Legacy symbols output doesn't include Function Calls.
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module"]
renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m [Legacy.File]
renderToSymbols blob term = pure $ either mempty (pure . tagsToFile blob) (runTagging blob symbolsToSummarize term)
renderToSymbols :: (IsTaggable f, Applicative m) => Term f Location -> m [Legacy.File]
renderToSymbols term = pure $ either mempty (pure . tagsToFile) (runTagging blob symbolsToSummarize term)
tagsToFile :: Blob -> [Tag] -> Legacy.File
tagsToFile Blob{..} tags = Legacy.File (pack blobPath) (pack (show blobLanguage)) (fmap tagToSymbol tags)
tagsToFile :: [Tag] -> Legacy.File
tagsToFile tags = Legacy.File (pack (blobPath blob)) (pack (show (blobLanguage blob))) (fmap tagToSymbol tags)
tagToSymbol :: Tag -> Legacy.Symbol
tagToSymbol Tag{..}
= Legacy.Symbol
{ symbolName = name
, symbolKind = kind
, symbolLine = fromMaybe mempty line
, symbolSpan = converting #? span
}
tagToSymbol :: Tag -> Legacy.Symbol
tagToSymbol Tag{..}
= Legacy.Symbol
{ symbolName = name
, symbolKind = kind
, symbolLine = fromMaybe mempty line
, symbolSpan = converting #? span
}
parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder
parseSymbolsBuilder format blobs = parseSymbols blobs >>= serialize format
@ -63,18 +64,20 @@ parseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t
parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go
where
go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m File
go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException e) -> pure $ errorFile (show e))
go blob@Blob{..} = (doParse blob >>= withSomeTerm renderToSymbols) `catchError` (\(SomeException e) -> pure $ errorFile (show e))
where
errorFile e = File (pack blobPath) (bridging # blobLanguage) mempty (V.fromList [ParseError (T.pack e)]) blobOid
blobLanguage' = blobLanguage blob
blobPath' = pack $ blobPath blob
errorFile e = File blobPath' (bridging # blobLanguage blob) mempty (V.fromList [ParseError (T.pack e)]) blobOid
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"]
renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m File
renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob symbolsToSummarize term)
renderToSymbols :: (IsTaggable f, Applicative m) => Term f Location -> m File
renderToSymbols term = pure $ either (errorFile . show) tagsToFile (runTagging blob symbolsToSummarize term)
tagsToFile :: Blob -> [Tag] -> File
tagsToFile Blob{..} tags = File (pack blobPath) (bridging # blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty blobOid
tagsToFile :: [Tag] -> File
tagsToFile tags = File blobPath' (bridging # blobLanguage') (V.fromList (fmap tagToSymbol tags)) mempty blobOid
tagToSymbol :: Tag -> Symbol
tagToSymbol Tag{..}

6
src/Semantic/Api/Terms.hs
View File

@ -99,7 +99,7 @@ quietTerm blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fma
timingError (SomeException e) = pure (Left (show e))
showTiming Blob{..} (res, duration) =
let status = if isLeft res then "ERR" else "OK"
in stringUtf8 (status <> "\t" <> show blobLanguage <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n")
in stringUtf8 (status <> "\t" <> show (blobLanguage blob) <> "\t" <> blobPath blob <> "\t" <> show duration <> " ms\n")
type ParseEffects sig m = (Member (Error SomeException) sig, Member Task sig, Carrier sig m)
@ -113,7 +113,7 @@ type TermConstraints =
]
doParse :: (ParseEffects sig m) => Blob -> m (SomeTerm TermConstraints Location)
doParse blob@Blob{..} = case blobLanguage of
doParse blob = case blobLanguage blob of
Go -> SomeTerm <$> parse goParser blob
Haskell -> SomeTerm <$> parse haskellParser blob
Java -> SomeTerm <$> parse javaParser blob
@ -125,4 +125,4 @@ doParse blob@Blob{..} = case blobLanguage of
Ruby -> SomeTerm <$> parse rubyParser blob
TypeScript -> SomeTerm <$> parse typescriptParser blob
PHP -> SomeTerm <$> parse phpParser blob
_ -> noLanguageForBlob blobPath
_ -> noLanguageForBlob (blobPath blob)

3
src/Semantic/CLI.hs
View File

@ -2,7 +2,8 @@
module Semantic.CLI (main) where
import Control.Exception as Exc (displayException)
import Data.File
import Data.Blob
import Data.Blob.IO
import Data.Handle
import Data.Language (languageForFilePath, parseLanguage)
import Data.List (intercalate, uncons)

1
src/Semantic/Graph.hs
View File

@ -49,7 +49,6 @@ import Data.Abstract.Value.Concrete as Concrete
import Data.Abstract.Value.Type as Type
import Data.Abstract.AccessControls.Instances ()
import Data.Blob
import Data.File
import Data.Graph
import Data.Graph.ControlFlowVertex (VertexDeclarationStrategy, VertexDeclarationWithStrategy)
import Data.Language as Language

4
src/Semantic/REPL.hs
View File

@ -18,9 +18,9 @@ import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package
import Data.Abstract.Value.Concrete as Concrete
import Data.Blob (Blob(..))
import Data.Blob (File(..), Blob(..))
import Data.Error (Colourize (..), showExcerpt)
import Data.File (File (..), readBlobFromFile)
import Data.Blob.IO (readBlobFromFile)
import Data.Flag (flag)
import Data.Graph (topologicalSort)
import Data.Language as Language

5
src/Semantic/Resolution.hs
View File

@ -13,7 +13,6 @@ import Control.Effect.Sum
import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Data.Blob
import Data.File
import Data.Project
import qualified Data.Map as Map
import Data.Source
@ -26,12 +25,12 @@ import System.FilePath.Posix
nodeJSResolutionMap :: (Member Files sig, Carrier sig m, MonadIO m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath)
nodeJSResolutionMap rootDir prop excludeDirs = do
files <- findFiles rootDir [".json"] excludeDirs
let packageFiles = file <$> filter ((==) "package.json" . takeFileName) files
let packageFiles = fileForPath <$> filter ((==) "package.json" . takeFileName) files
blobs <- readBlobs (FilesFromPaths packageFiles)
pure $ fold (mapMaybe (lookup prop) blobs)
where
lookup :: Text -> Blob -> Maybe (Map FilePath FilePath)
lookup k Blob{..} = decodeStrict (sourceBytes blobSource) >>= lookupProp blobPath k
lookup k b@Blob{..} = decodeStrict (sourceBytes blobSource) >>= lookupProp (blobPath b) k
lookupProp :: FilePath -> Text -> Object -> Maybe (Map FilePath FilePath)
lookupProp path k res = flip parseMaybe res $ \obj -> Map.singleton relPkgDotJSONPath . relEntryPath <$> obj .: k

4
src/Semantic/Task.hs
View File

@ -286,7 +286,7 @@ runParser blob@Blob{..} parser = case parser of
let term = cmarkParser blobSource
in length term `seq` pure term
SomeParser parser -> SomeTerm <$> runParser blob parser
where languageTag = pure . (,) ("language" :: String) . show $ blobLanguage
where languageTag = pure . (,) ("language" :: String) . show $ blobLanguage blob
errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) Assignment.Location -> [Error.Error String]
errors = cata $ \ (In Assignment.Location{..} syntax) -> case syntax of
_ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError locationSpan err]
@ -313,7 +313,7 @@ runParser blob@Blob{..} parser = case parser of
let requestID' = ("github_request_id", requestID taskSession)
let isPublic' = ("github_is_public", show (isPublic taskSession))
let logPrintFlag = configLogPrintSource . config $ taskSession
let blobFields = ("path", if isPublic taskSession || Flag.toBool LogPrintSource logPrintFlag then blobPath else "<filtered>")
let blobFields = ("path", if isPublic taskSession || Flag.toBool LogPrintSource logPrintFlag then blobPath blob else "<filtered>")
let logFields = requestID' : isPublic' : blobFields : languageTag
let shouldFailForTesting = configFailParsingForTesting $ config taskSession
let shouldFailOnParsing = optionsFailOnParseError . configOptions $ config taskSession

2
src/Semantic/Task/Files.hs
View File

@ -23,8 +23,8 @@ import Control.Effect.Catch
import Control.Effect.Error
import Control.Effect.Sum
import Data.Blob
import Data.Blob.IO
import qualified Data.ByteString.Builder as B
import Data.File
import Data.Handle
import Data.Language
import Data.Project hiding (readFile)

5
src/Semantic/Util.hs
View File

@ -25,7 +25,8 @@ import Data.Abstract.Module
import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package
import Data.Abstract.Value.Concrete as Concrete
import Data.File
import Data.Blob
import Data.Blob.IO
import Data.Graph (topologicalSort)
import qualified Data.Language as Language
import Data.List (uncons)
@ -218,7 +219,7 @@ evaluateProject' session proxy parser paths = do
either (die . displayException) pure res
parseFile :: Parser term -> FilePath -> IO term
parseFile parser = runTask' . (parse parser <=< readBlob . file)
parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath)
runTask' :: TaskEff a -> IO a
runTask' task = runTaskWithOptions debugOptions task >>= either (die . displayException) pure

2
src/Semantic/UtilDisabled.hs
View File

@ -28,7 +28,7 @@ import Data.Abstract.Package
import Data.Abstract.Value.Concrete as Concrete
import Data.Abstract.Value.Type as Type
import Data.Blob
import Data.File
import Data.Blob.IO
import Data.Graph (topologicalSort)
import Data.Graph.ControlFlowVertex
import qualified Data.Language as Language

4
src/Tags/Taggable.hs
View File

@ -118,9 +118,9 @@ tagging :: (IsTaggable syntax)
=> Blob
-> Term syntax Location
-> Machine.Source Token
tagging Blob{..} term = pipe
tagging b term = pipe
where pipe = Machine.construct $ compile go
go = foldSubterms (descend blobLanguage) term
go = foldSubterms (descend (blobLanguage b)) term
descend ::
( Taggable (TermF syntax Location)

2
test/Data/Functor/Listable.hs
View File

@ -568,7 +568,7 @@ instance Listable Span where
tiers = cons2 Span
instance Listable Blob where
tiers = cons4 Blob
tiers = cons4 makeBlob
instance Listable BlobPair where
tiers = liftTiers tiers

4
test/Examples.hs
View File

@ -9,7 +9,7 @@ import qualified Data.ByteString as B
import Data.ByteString.Builder
import qualified Data.ByteString.Char8 as BC
import Data.Either
import Data.File (file)
import Data.Blob (fileForPath)
import Data.Flag
import Data.Foldable
import Data.List
@ -101,7 +101,7 @@ languages =
]
parseFilePath :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Member Files sig, Carrier sig m, MonadIO m) => FilePath -> m Bool
parseFilePath path = readBlob (file path) >>= parseTermBuilder @[] TermShow . pure >>= const (pure True)
parseFilePath path = readBlob (fileForPath path) >>= parseTermBuilder @[] TermShow . pure >>= const (pure True)
languagesDir :: FilePath
languagesDir = "vendor/haskell-tree-sitter/languages"

2
test/Rendering/TOC/Spec.hs
View File

@ -221,7 +221,7 @@ isMethodOrFunction a
| otherwise = False
blobsForPaths :: Both FilePath -> IO BlobPair
blobsForPaths = readFilePair . fmap ("test/fixtures" </>)
blobsForPaths = readFilePathPair . fmap ("test/fixtures" </>)
blankDiff :: Diff'
blankDiff = merge (Nothing, Nothing) (inject [ inserting (termIn Nothing (inject (Syntax.Identifier (name "\"a\"")))) ])

2
test/Reprinting/Spec.hs
View File

@ -67,5 +67,5 @@ spec = describe "reprinting" $ do
it "should be able to parse the output of a refactor" $ do
let (Just tagged) = rewrite (mark Unmodified tree) (topDownAny increaseNumbers)
let (Right printed) = runReprinter src defaultJSONPipeline tagged
tree' <- runTaskOrDie (parse jsonParser (Blob printed path Language.JSON mempty))
tree' <- runTaskOrDie (parse jsonParser (makeBlob printed path Language.JSON mempty))
length tree' `shouldSatisfy` (/= 0)

9
test/Semantic/Spec.hs
View File

@ -7,19 +7,22 @@ import System.Exit
import SpecHelpers
-- we need some lenses here, oof
setBlobLanguage :: Language -> Blob -> Blob
setBlobLanguage lang b = b { blobFile = (blobFile b) { fileLanguage = lang }}
spec :: Spec
spec = parallel $ do
describe "parseBlob" $ do
it "returns error if given an unknown language (json)" $ do
output <- fmap runBuilder . runTaskOrDie $ parseTermBuilder TermJSONTree [ methodsBlob { blobLanguage = Unknown } ]
output <- fmap runBuilder . runTaskOrDie $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ]
output `shouldBe` "{\"trees\":[{\"path\":\"methods.rb\",\"error\":\"NoLanguageForBlob \\\"methods.rb\\\"\",\"language\":\"Unknown\"}]}\n"
it "throws if given an unknown language for sexpression output" $ do
runTaskOrDie (parseTermBuilder TermSExpression [methodsBlob { blobLanguage = Unknown }]) `shouldThrow` (== ExitFailure 1)
runTaskOrDie (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob]) `shouldThrow` (== ExitFailure 1)
it "renders with the specified renderer" $ do
output <- fmap runBuilder . runTaskOrDie $ parseTermBuilder TermSExpression [methodsBlob]
output `shouldBe` "(Statements\n (Method\n (Empty)\n (Identifier)\n (Statements)))\n"
where
methodsBlob = Blob "def foo\nend\n" "methods.rb" Ruby mempty
methodsBlob = makeBlob "def foo\nend\n" "methods.rb" Ruby mempty

17
test/SpecHelpers.hs
View File

@ -6,7 +6,7 @@ module SpecHelpers
, diffFilePaths
, parseFilePath
, parseTestFile
, readFilePair
, readFilePathPair
, runTaskOrDie
, TaskSession(..)
, testEvaluating
@ -38,12 +38,11 @@ import Data.Abstract.Name as X
import Data.Abstract.Value.Concrete (Value(..), ValueError, runValueError)
import Data.Bifunctor (first)
import Data.Blob as X
import Data.Blob.IO as X
import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Project as X
import Data.Proxy as X
import qualified Data.File as F
import Data.File as X hiding (readFilePair)
import Data.Foldable (toList)
import Data.Functor.Listable as X
import Data.Language as X
@ -95,20 +94,20 @@ instance IsString Name where
-- | Returns an s-expression formatted diff for the specified FilePath pair.
diffFilePaths :: TaskSession -> Both FilePath -> IO ByteString
diffFilePaths session paths = readFilePair paths >>= runTask session . parseDiffBuilder @[] DiffSExpression . pure >>= either (die . displayException) (pure . runBuilder)
diffFilePaths session paths = readFilePathPair paths >>= runTask session . parseDiffBuilder @[] DiffSExpression . pure >>= either (die . displayException) (pure . runBuilder)
-- | Returns an s-expression parse tree for the specified FilePath.
parseFilePath :: TaskSession -> FilePath -> IO ByteString
parseFilePath session path = (fromJust <$> readBlobFromFile (file path)) >>= runTask session . parseTermBuilder @[] TermSExpression . pure >>= either (die . displayException) (pure . runBuilder)
parseFilePath session path = (fromJust <$> readBlobFromFile (fileForPath path)) >>= runTask session . parseTermBuilder @[] TermSExpression . pure >>= either (die . displayException) (pure . runBuilder)
-- | Read two files to a BlobPair.
readFilePair :: Both FilePath -> IO BlobPair
readFilePair paths = let paths' = fmap file paths in
runBothWith F.readFilePair paths'
readFilePathPair :: Both FilePath -> IO BlobPair
readFilePathPair paths = let paths' = fmap fileForPath paths in
runBothWith readFilePair paths'
parseTestFile :: Parser term -> FilePath -> IO (Blob, term)
parseTestFile parser path = runTaskOrDie $ do
blob <- readBlob (file path)
blob <- readBlob (fileForPath path)
term <- parse parser blob
pure (blob, term)