github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-02 20:41:38 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into add-explicit-assignment-timeout

Browse Source
This commit is contained in:
Rick Winfrey 2018-10-25 14:34:22 -07:00 committed by GitHub
commit 9fc1a17ac6
29 changed files with 321 additions and 279 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
semantic.cabal
View File

@ -81,12 +81,14 @@ library
, Data.Diff
, Data.Duration
, Data.Error
, Data.File
, Data.Functor.Both
, Data.Functor.Classes.Generic
, Data.Graph
, Data.Graph.ControlFlowVertex
, Data.Graph.TermVertex
, Data.Graph.DiffVertex
, Data.Handle
, Data.History
, Data.JSON.Fields
, Data.Language
@ -196,6 +198,7 @@ library
, Semantic.REPL
, Semantic.Resolution
, Semantic.Task
, Semantic.Task.Files
, Semantic.Telemetry
, Semantic.Telemetry.AsyncQueue
, Semantic.Telemetry.Haystack

1
src/Control/Abstract/Evaluator.hs
View File

@ -25,7 +25,6 @@ import Control.Monad.Effect.Reader as X
import Control.Monad.Effect.Resumable as X
import Control.Monad.Effect.State as X
import Control.Monad.Effect.Trace as X
import Control.Monad.IO.Class
import Prologue hiding (MonadError(..))
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types.

33
src/Data/Blob.hs
View File

@ -1,27 +1,36 @@
{-# LANGUAGE DeriveAnyClass #-}
module Data.Blob
( Blob(..)
, Blobs(..)
, decodeBlobs
, nullBlob
, sourceBlob
, noLanguageForBlob
, BlobPair
, These(..)
, blobPairDiffing
, blobPairInserting
, blobPairDeleting
, decodeBlobPairs
, languageForBlobPair
, languageTagForBlobPair
, pathForBlobPair
, pathKeyForBlobPair
) where
import Prologue
import Proto3.Suite
import Prologue hiding (throwError)
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import Data.Aeson
import qualified Data.ByteString.Lazy as BL
import Proto3.Suite
import qualified Proto3.Wire.Decode as Decode
import qualified Proto3.Wire.Encode as Encode
import Data.JSON.Fields
import Data.Language
import Data.Source as Source
import qualified Proto3.Wire.Encode as Encode
import qualified Proto3.Wire.Decode as Decode
-- | The source, path, and language of a blob.
data Blob = Blob
@ -31,6 +40,9 @@ data Blob = Blob
}
deriving (Show, Eq, Generic, Message, Named)
newtype Blobs a = Blobs { blobs :: [a] }
deriving (Generic, FromJSON)
instance FromJSON Blob where
parseJSON = withObject "Blob" $ \b -> inferringLanguage
<$> b .: "content"
@ -48,6 +60,16 @@ inferringLanguage src pth lang
| knownLanguage lang = Blob src pth lang
| otherwise = Blob src pth (languageForFilePath pth)
decodeBlobs :: BL.ByteString -> Either String [Blob]
decodeBlobs = fmap blobs <$> eitherDecode
-- | An exception indicating that we’ve tried to diff or parse a blob of unknown language.
newtype NoLanguageForBlob = NoLanguageForBlob FilePath
deriving (Eq, Exception, Ord, Show, Typeable)
noLanguageForBlob :: Member (Exc SomeException) effs => FilePath -> Eff effs a
noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
-- | Represents a blobs suitable for diffing which can be either a blob to
-- delete, a blob to insert, or a pair of blobs to diff.
type BlobPair = Join These Blob
@ -117,3 +139,6 @@ pathKeyForBlobPair blobs = case bimap blobPath blobPath (runJoin blobs) of
instance ToJSONFields Blob where
toJSONFields Blob{..} = [ "path" .= blobPath, "language" .= blobLanguage ]
decodeBlobPairs :: BL.ByteString -> Either String [BlobPair]
decodeBlobPairs = fmap blobs <$> eitherDecode

66
src/Data/File.hs Normal file
View File

@ -0,0 +1,66 @@
{-# LANGUAGE RankNTypes #-}
module Data.File
( File (..)
, file
, toFile
, readBlobFromFile
, readBlobFromFile'
, readBlobsFromDir
, readFilePair
, maybeThese
) where
import Prologue
import qualified Data.ByteString as B
import System.FilePath.Glob
import System.FilePath.Posix
import Data.Blob
import Data.Language
import Data.Source
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
-- | Read a utf8-encoded file to a 'Blob'.
readBlobFromFile :: forall m. MonadIO m => File -> m (Maybe Blob)
readBlobFromFile (File "/dev/null" _) = pure Nothing
readBlobFromFile (File path language) = do
raw <- liftIO $ B.readFile path
pure . Just . sourceBlob path language . fromUTF8 $ raw
-- | Read a utf8-encoded file to a 'Blob', raising an IOError if it can't be found.
readBlobFromFile' :: MonadIO m => File -> m Blob
readBlobFromFile' file = do
maybeFile <- readBlobFromFile file
maybeM (Prelude.fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile
readBlobsFromDir :: MonadIO m => FilePath -> m [Blob]
readBlobsFromDir path = do
paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
let paths' = fmap (\p -> File p (languageForFilePath p)) paths
blobs <- traverse readBlobFromFile paths'
pure (catMaybes blobs)
readFilePair :: forall m. (MonadFail m, MonadIO m) => File -> File -> m BlobPair
readFilePair a b = Join <$> join (maybeThese <$> readBlobFromFile a <*> readBlobFromFile b)
maybeThese :: MonadFail m => Maybe a -> Maybe b -> m (These a b)
maybeThese a b = case (a, b) of
(Just a, Nothing) -> pure (This a)
(Nothing, Just b) -> pure (That b)
(Just a, Just b) -> pure (These a b)
_ -> Prologue.fail "expected file pair with content on at least one side"

60
src/Data/Handle.hs Normal file
View File

@ -0,0 +1,60 @@
{-# LANGUAGE GADTs #-}
module Data.Handle
( Handle (..)
, getHandle
, stdin
, stdout
, stderr
, readBlobsFromHandle
, readBlobPairsFromHandle
, readFromHandle
, openFileForReading
) where
import Prologue
import Data.Aeson
import qualified Data.ByteString.Lazy as BL
import System.Exit
import qualified System.IO as IO
import Data.Blob
data Handle mode where
ReadHandle :: IO.Handle -> Handle 'IO.ReadMode
WriteHandle :: IO.Handle -> Handle 'IO.WriteMode
deriving instance Eq (Handle mode)
deriving instance Show (Handle mode)
getHandle :: Handle mode -> IO.Handle
getHandle (ReadHandle handle) = handle
getHandle (WriteHandle handle) = handle
stdin :: Handle 'IO.ReadMode
stdin = ReadHandle IO.stdin
stdout :: Handle 'IO.WriteMode
stdout = WriteHandle IO.stdout
stderr :: Handle 'IO.WriteMode
stderr = WriteHandle IO.stderr
openFileForReading :: FilePath -> IO (Handle 'IO.ReadMode)
openFileForReading path = ReadHandle <$> IO.openFile path IO.ReadMode
-- | Read JSON encoded blobs from a handle.
readBlobsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob]
readBlobsFromHandle = fmap blobs <$> readFromHandle
-- | Read JSON encoded blob pairs from a handle.
readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
readBlobPairsFromHandle = fmap blobs <$> readFromHandle
readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a
readFromHandle (ReadHandle h) = do
input <- liftIO $ BL.hGetContents h
case eitherDecode input of
Left e -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
Right d -> pure d

34
src/Data/Project.hs
View File

@ -11,9 +11,7 @@ module Data.Project (
, projectName
, projectFiles
, readFile
-- * Files
, File (..)
, file
, readProjectFromPaths
) where
import Prelude hiding (readFile)
@ -22,10 +20,12 @@ import Prologue hiding (throwError)
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import Data.Blob
import Data.File
import Data.Language
import qualified Data.Text as T
import Proto3.Suite
import System.FilePath.Posix
import Semantic.IO
-- | A 'ProjectF' contains all the information that semantic needs
-- to execute an analysis, diffing, or graphing pass. It is higher-kinded
@ -73,20 +73,6 @@ projectExtensions = extensionsForLanguage . projectLanguage
projectFiles :: Project -> [File]
projectFiles = fmap toFile . projectBlobs
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
newtype ProjectException
= FileNotFound FilePath
deriving (Show, Eq, Typeable, Exception)
@ -102,3 +88,17 @@ readFile Project{..} f =
| p == "/dev/null" -> pure Nothing
| isJust candidate -> pure candidate
| otherwise -> throwError (SomeException (FileNotFound p))
readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
readProjectFromPaths maybeRoot path lang excludeDirs = do
isDir <- isDirectory path
let rootDir = if isDir
then fromMaybe path maybeRoot
else fromMaybe (takeDirectory path) maybeRoot
paths <- liftIO $ findFilesInDir rootDir exts excludeDirs
blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths
pure $ Project rootDir blobs lang excludeDirs
where
toFile path = File path lang
exts = extensionsForLanguage lang

1
src/Parsing/TreeSitter.hs
View File

@ -11,7 +11,6 @@ import qualified Control.Exception as Exc (bracket)
import Control.Monad.Effect
import Control.Monad.Effect.Resource
import Control.Monad.Effect.Trace
import Control.Monad.IO.Class
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Foreign
import Foreign.C.Types (CBool (..))

1
src/Prologue.hs
View File

@ -36,6 +36,7 @@ import Control.Arrow as X ((&&&), (***))
import Control.Monad as X hiding (fail, return)
import Control.Monad.Except as X (MonadError (..))
import Control.Monad.Fail as X (MonadFail (..))
import Control.Monad.IO.Class as X (MonadIO (..))
import Data.Algebra as X
import Data.Bifoldable as X
import Data.Bifunctor as X (Bifunctor (..))

1
src/Semantic/AST.hs
View File

@ -12,7 +12,6 @@ import Data.Blob
import Parsing.Parser
import Prologue hiding (MonadError(..))
import Rendering.JSON (renderJSONAST)
import Semantic.IO (noLanguageForBlob)
import Semantic.Task
import qualified Serializing.Format as F

9
src/Semantic/CLI.hs
View File

@ -6,10 +6,11 @@ module Semantic.CLI
, Parse.runParse
) where
import Control.Monad.IO.Class
import Data.Language (ensureLanguage)
import Data.File
import Data.Language (ensureLanguage, languageForFilePath)
import Data.List (intercalate, uncons)
import Data.List.Split (splitWhen)
import Data.Handle
import Data.Project
import Options.Applicative hiding (style)
import Prologue
@ -18,9 +19,9 @@ import qualified Semantic.AST as AST
import Semantic.Config
import qualified Semantic.Diff as Diff
import qualified Semantic.Graph as Graph
import Semantic.IO as IO
import qualified Semantic.Parse as Parse
import qualified Semantic.Task as Task
import Semantic.Task.Files
import qualified Semantic.Telemetry.Log as Log
import Semantic.Version
import System.FilePath
@ -118,7 +119,7 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g
<|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin."))
makeReadProjectFromPathsTask language maybePaths = do
paths <- maybeM (liftIO (many getLine)) maybePaths
blobs <- traverse IO.readBlob (flip File language <$> paths)
blobs <- traverse readBlobFromFile' (flip File language <$> paths)
pure $! Project (takeDirectory (maybe "/" fst (uncons paths))) blobs language []
readProjectRecursively = makeReadProjectRecursivelyTask
<$> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR"))

1
src/Semantic/Diff.hs
View File

@ -17,7 +17,6 @@ import Parsing.Parser
import Prologue hiding (MonadError(..))
import Rendering.Graph
import Rendering.Renderer
import Semantic.IO (noLanguageForBlob)
import Semantic.Telemetry as Stat
import Semantic.Task as Task
import Serializing.Format

1
src/Semantic/Distribute.hs
View File

@ -10,7 +10,6 @@ module Semantic.Distribute
import qualified Control.Concurrent.Async as Async
import Control.Parallel.Strategies
import Control.Monad.Effect
import Control.Monad.IO.Class
import Prologue hiding (MonadError (..))
-- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results.

1
src/Semantic/Env.hs
View File

@ -4,7 +4,6 @@ module Semantic.Env
, envLookupString
) where
import Control.Monad.IO.Class
import Prologue
import System.Environment
import Text.Read (readMaybe)

1
src/Semantic/Graph.hs
View File

@ -45,6 +45,7 @@ import Data.Abstract.Value.Concrete as Concrete
(Value, ValueError (..), runWhile, runBoolean, runFunction, runValueErrorWith)
import Data.Abstract.Value.Type as Type
import Data.Blob
import Data.File
import Data.Graph
import Data.Graph.ControlFlowVertex (VertexDeclarationStrategy, VertexDeclarationWithStrategy)
import Data.Language as Language

212
src/Semantic/IO.hs
View File

@ -1,117 +1,20 @@
{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Semantic.IO
( Destination(..)
, Files
, Handle(..)
, IO.IOMode(..)
, NoLanguageForBlob(..)
, Source(..)
, findFiles
, findFilesInDir
, getHandle
, isDirectory
, languageForFilePath
, noLanguageForBlob
, openFileForReading
, readBlob
, readBlobFromPath
, readBlobPairs
, readBlobPairsFromHandle
, readBlobs
, readBlobsFromDir
, readBlobsFromHandle
, decodeBlobPairs
, decodeBlobs
, readFile
, readFilePair
, readProject
, readProjectFromPaths
, rethrowing
, runFiles
, stderr
, stdin
, stdout
, write
) where
( isDirectory
, findFilesInDir
) where
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import Control.Monad.IO.Class
import Data.Aeson
import Data.Blob
import Data.Bool
import Data.Project hiding (readFile)
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as BL
import Data.Language
import Data.Source (fromUTF8)
import Prelude hiding (readFile)
import Prologue hiding (MonadError (..), fail)
import System.Directory (doesDirectoryExist)
import System.Directory.Tree (AnchoredDirTree (..))
import qualified System.Directory.Tree as Tree
import System.Directory.Tree (AnchoredDirTree(..))
import System.Exit
import System.FilePath
import System.FilePath.Glob
import qualified System.IO as IO
-- | Read a utf8-encoded file to a 'Blob'.
readFile :: forall m. MonadIO m => File -> m (Maybe Blob)
readFile (File "/dev/null" _) = pure Nothing
readFile (File path language) = do
raw <- liftIO $ B.readFile path
pure . Just . sourceBlob path language . fromUTF8 $ raw
readFilePair :: forall m. MonadIO m => File -> File -> m BlobPair
readFilePair a b = Join <$> join (maybeThese <$> readFile a <*> readFile b)
maybeThese :: Monad m => Maybe a -> Maybe b -> m (These a b)
maybeThese a b = case (a, b) of
(Just a, Nothing) -> pure (This a)
(Nothing, Just b) -> pure (That b)
(Just a, Just b) -> pure (These a b)
_ -> fail "expected file pair with content on at least one side"
newtype Blobs a = Blobs { blobs :: [a] }
deriving (Generic, FromJSON)
isDirectory :: MonadIO m => FilePath -> m Bool
isDirectory path = liftIO (doesDirectoryExist path)
decodeBlobPairs :: BL.ByteString -> Either String [BlobPair]
decodeBlobPairs = fmap blobs <$> eitherDecode
-- | Read JSON encoded blob pairs from a handle.
readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
readBlobPairsFromHandle = fmap blobs <$> readFromHandle
decodeBlobs :: BL.ByteString -> Either String [Blob]
decodeBlobs = fmap blobs <$> eitherDecode
-- | Read JSON encoded blobs from a handle.
readBlobsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob]
readBlobsFromHandle = fmap blobs <$> readFromHandle
readBlobFromPath :: MonadIO m => File -> m Blob
readBlobFromPath file = do
maybeFile <- readFile file
maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile
readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
readProjectFromPaths maybeRoot path lang excludeDirs = do
isDir <- isDirectory path
let rootDir = if isDir
then fromMaybe path maybeRoot
else fromMaybe (takeDirectory path) maybeRoot
paths <- liftIO $ findFilesInDir rootDir exts excludeDirs
blobs <- liftIO $ traverse (readBlobFromPath . toFile) paths
pure $ Project rootDir blobs lang excludeDirs
where
toFile path = File path lang
exts = extensionsForLanguage lang
-- Recursively find files in a directory.
findFilesInDir :: forall m. MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
findFilesInDir path exts excludeDirs = do
@ -135,106 +38,3 @@ findFilesInDir path exts excludeDirs = do
| n `elem` dirs = False
| otherwise = True
notIn _ _ = True
readBlobsFromDir :: MonadIO m => FilePath -> m [Blob]
readBlobsFromDir path = do
paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
let paths' = fmap (\p -> File p (languageForFilePath p)) paths
blobs <- traverse readFile paths'
pure (catMaybes blobs)
readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a
readFromHandle (ReadHandle h) = do
input <- liftIO $ BL.hGetContents h
case eitherDecode input of
Left e -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
Right d -> pure d
-- | An exception indicating that we’ve tried to diff or parse a blob of unknown language.
newtype NoLanguageForBlob = NoLanguageForBlob FilePath
deriving (Eq, Exception, Ord, Show, Typeable)
noLanguageForBlob :: Member (Exc SomeException) effs => FilePath -> Eff effs a
noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
readBlob :: Member Files effs => File -> Eff effs Blob
readBlob = send . Read . FromPath
-- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
readBlobs :: Member Files effs => Either (Handle 'IO.ReadMode) [File] -> Eff effs [Blob]
readBlobs (Left handle) = send (Read (FromHandle handle))
readBlobs (Right paths) = traverse (send . Read . FromPath) paths
-- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
readBlobPairs :: Member Files effs => Either (Handle 'IO.ReadMode) [Both File] -> Eff effs [BlobPair]
readBlobPairs (Left handle) = send (Read (FromPairHandle handle))
readBlobPairs (Right paths) = traverse (send . Read . FromPathPair) paths
readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project
readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
findFiles :: Member Files effs => FilePath -> [String] -> [FilePath] -> Eff effs [FilePath]
findFiles dir exts = send . FindFiles dir exts
-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
write :: Member Files effs => Destination -> B.Builder -> Eff effs ()
write dest = send . Write dest
data Handle mode where
ReadHandle :: IO.Handle -> Handle 'IO.ReadMode
WriteHandle :: IO.Handle -> Handle 'IO.WriteMode
deriving instance Eq (Handle mode)
deriving instance Show (Handle mode)
getHandle :: Handle mode -> IO.Handle
getHandle (ReadHandle handle) = handle
getHandle (WriteHandle handle) = handle
stdin :: Handle 'IO.ReadMode
stdin = ReadHandle IO.stdin
stdout :: Handle 'IO.WriteMode
stdout = WriteHandle IO.stdout
stderr :: Handle 'IO.WriteMode
stderr = WriteHandle IO.stderr
openFileForReading :: FilePath -> IO (Handle 'IO.ReadMode)
openFileForReading path = ReadHandle <$> IO.openFile path IO.ReadMode
data Source blob where
FromPath :: File -> Source Blob
FromHandle :: Handle 'IO.ReadMode -> Source [Blob]
FromPathPair :: Both File -> Source BlobPair
FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair]
data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
data Files (m :: * -> *) out where
Read :: Source out -> Files m out
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files m Project
FindFiles :: FilePath -> [String] -> [FilePath] -> Files m [FilePath]
Write :: Destination -> B.Builder -> Files m ()
instance PureEffect Files
instance Effect Files where
handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k)
handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k)
handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k)
handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k)
-- | Run a 'Files' effect in 'IO'.
runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, PureEffects effs) => Eff (Files ': effs) a -> Eff effs a
runFiles = interpret $ \ files -> case files of
Read (FromPath path) -> rethrowing (readBlobFromPath path)
Read (FromHandle handle) -> rethrowing (readBlobsFromHandle handle)
Read (FromPathPair paths) -> rethrowing (runBothWith readFilePair paths)
Read (FromPairHandle handle) -> rethrowing (readBlobPairsFromHandle handle)
ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
FindFiles dir exts excludeDirs -> rethrowing (findFilesInDir dir exts excludeDirs)
Write (ToPath path) builder -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))
Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder)

1
src/Semantic/Parse.hs
View File

@ -19,7 +19,6 @@ import Rendering.Graph
import Rendering.JSON (SomeJSON (..))
import qualified Rendering.JSON as JSON
import Rendering.Renderer
import Semantic.IO (noLanguageForBlob)
import Semantic.Task
import Serializing.Format

8
src/Semantic/REPL.hs
View File

@ -6,7 +6,6 @@ module Semantic.REPL
import Control.Abstract hiding (Continue, List, string)
import Control.Monad.Effect.Resource
import Control.Monad.IO.Class
import Data.Abstract.Address.Precise as Precise
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable hiding (string)
@ -16,6 +15,7 @@ import Data.Abstract.Package
import Data.Abstract.Value.Concrete as Concrete
import Data.Blob (Blob(..))
import Data.Error (showExcerpt)
import Data.File (File (..), readBlobFromFile)
import Data.Graph (topologicalSort)
import Data.Language as Language
import Data.List (uncons)
@ -30,9 +30,9 @@ import Prologue hiding (throwError)
import Semantic.Config (logOptionsFromConfig)
import Semantic.Distribute
import Semantic.Graph
import Semantic.IO as IO
import Semantic.Resolution
import Semantic.Task hiding (Error)
import qualified Semantic.Task.Files as Files
import Semantic.Telemetry
import Semantic.Timeout
import Semantic.Telemetry.Log (LogOptions, Message(..), writeLogMessage)
@ -71,8 +71,8 @@ runREPL prefs settings = interpret $ \case
rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . IO.runFiles . runResolution . runTaskF $ do
blobs <- catMaybes <$> traverse IO.readFile (flip File (Language.reflect proxy) <$> paths)
repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . Files.runFiles . runResolution . runTaskF $ do
blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths)
package <- fmap (fmap quieterm) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
modules <- topologicalSort <$> runImportGraphToModules proxy (snd <$> package)
homeDir <- liftIO getHomeDirectory

3
src/Semantic/Resolution.hs
View File

@ -10,12 +10,13 @@ import Control.Monad.Effect
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
import Data.Language
import Prologue
import Semantic.IO
import Semantic.Task.Files
import System.FilePath.Posix

18
src/Semantic/Task.hs
View File

@ -5,12 +5,12 @@ module Semantic.Task
, Level(..)
, RAlgebra
-- * I/O
, IO.readBlob
, IO.readBlobs
, IO.readBlobPairs
, IO.readProject
, IO.findFiles
, IO.write
, Files.readBlob
, Files.readBlobs
, Files.readBlobPairs
, Files.readProject
, Files.findFiles
, Files.write
-- * Module Resolution
, resolutionMap
, Resolution
@ -83,8 +83,8 @@ import Parsing.TreeSitter
import Prologue hiding (MonadError (..), project)
import Semantic.Config
import Semantic.Distribute
import qualified Semantic.Task.Files as Files
import Semantic.Timeout
import qualified Semantic.IO as IO
import Semantic.Resolution
import Semantic.Telemetry
import Serializing.Format hiding (Options)
@ -93,7 +93,7 @@ import System.Exit (die)
-- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
type TaskEff = Eff '[ Task
, Resolution
, IO.Files
, Files.Files
, Reader Config
, Trace
, Telemetry
@ -159,7 +159,7 @@ runTaskWithConfig options logger statter task = do
. runTelemetry logger statter
. runTraceInTelemetry
. runReader options
. IO.runFiles
. Files.runFiles
. runResolution
. runTaskF
run task

85
src/Semantic/Task/Files.hs Normal file
View File

@ -0,0 +1,85 @@
{-# LANGUAGE GADTs, KindSignatures, TypeOperators #-}
module Semantic.Task.Files
( Files
, Destination (..)
, Source (..)
, runFiles
, readBlob
, readBlobs
, readBlobPairs
, readProject
, findFiles
, write
, Handle (..)
) where
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import qualified Data.ByteString.Builder as B
import Data.Blob
import Data.File
import Data.Handle
import Data.Language
import Data.Project hiding (readFile)
import Prelude hiding (readFile)
import Prologue hiding (MonadError (..), fail)
import Semantic.IO
import qualified System.IO as IO
data Source blob where
FromPath :: File -> Source Blob
FromHandle :: Handle 'IO.ReadMode -> Source [Blob]
FromPathPair :: Both File -> Source BlobPair
FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair]
data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
data Files (m :: * -> *) out where
Read :: Source out -> Files m out
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files m Project
FindFiles :: FilePath -> [String] -> [FilePath] -> Files m [FilePath]
Write :: Destination -> B.Builder -> Files m ()
instance PureEffect Files
instance Effect Files where
handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k)
handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k)
handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k)
handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k)
-- | Run a 'Files' effect in 'IO'.
runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, PureEffects effs) => Eff (Files ': effs) a -> Eff effs a
runFiles = interpret $ \ files -> case files of
Read (FromPath path) -> rethrowing (readBlobFromFile' path)
Read (FromHandle handle) -> rethrowing (readBlobsFromHandle handle)
Read (FromPathPair paths) -> rethrowing (runBothWith readFilePair paths)
Read (FromPairHandle handle) -> rethrowing (readBlobPairsFromHandle handle)
ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
FindFiles dir exts excludeDirs -> rethrowing (findFilesInDir dir exts excludeDirs)
Write (ToPath path) builder -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))
Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder)
readBlob :: Member Files effs => File -> Eff effs Blob
readBlob = send . Read . FromPath
-- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
readBlobs :: Member Files effs => Either (Handle 'IO.ReadMode) [File] -> Eff effs [Blob]
readBlobs (Left handle) = send (Read (FromHandle handle))
readBlobs (Right paths) = traverse (send . Read . FromPath) paths
-- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
readBlobPairs :: Member Files effs => Either (Handle 'IO.ReadMode) [Both File] -> Eff effs [BlobPair]
readBlobPairs (Left handle) = send (Read (FromPairHandle handle))
readBlobPairs (Right paths) = traverse (send . Read . FromPathPair) paths
readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project
readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
findFiles :: Member Files effs => FilePath -> [String] -> [FilePath] -> Eff effs [FilePath]
findFiles dir exts = send . FindFiles dir exts
-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
write :: Member Files effs => Destination -> B.Builder -> Eff effs ()
write dest = send . Write dest

1
src/Semantic/Telemetry/Log.hs
View File

@ -8,7 +8,6 @@ module Semantic.Telemetry.Log
, writeLogMessage
) where
import Control.Monad.IO.Class
import Data.Error (withSGRCode)
import Data.List (intersperse)
import qualified Data.Time.Format as Time

1
src/Semantic/Telemetry/Stat.hs
View File

@ -27,7 +27,6 @@ module Semantic.Telemetry.Stat
) where
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as B
import Data.List (intercalate)
import Data.List.Split (splitOneOf)

6
src/Semantic/Util.hs
View File

@ -18,6 +18,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.Graph (topologicalSort)
import qualified Data.Language as Language
import Data.List (uncons)
@ -28,7 +29,6 @@ import Parsing.Parser
import Prologue hiding (weaken)
import Semantic.Config
import Semantic.Graph
import Semantic.IO as IO
import Semantic.Task
import Semantic.Telemetry (LogQueue, StatQueue)
import System.Exit (die)
@ -75,7 +75,7 @@ typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Langu
typecheckRubyFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Ruby) rubyParser
callGraphProject parser proxy opts paths = runTaskWithOptions opts $ do
blobs <- catMaybes <$> traverse readFile (flip File (Language.reflect proxy) <$> paths)
blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths)
package <- fmap snd <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
modules <- topologicalSort <$> runImportGraphToModules proxy package
x <- runCallGraph proxy False modules package
@ -92,7 +92,7 @@ evaluateProject proxy parser paths = withOptions debugOptions $ \ config logger
data TaskConfig = TaskConfig Config LogQueue StatQueue
evaluateProject' (TaskConfig config logger statter) proxy parser paths = either (die . displayException) pure <=< runTaskWithConfig config logger statter $ do
blobs <- catMaybes <$> traverse readFile (flip File (Language.reflect proxy) <$> paths)
blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths)
package <- fmap (quieterm . snd) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
modules <- topologicalSort <$> runImportGraphToModules proxy package
trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)

9
src/Semantic/Util/Rewriting.hs
View File

@ -12,9 +12,9 @@ import Text.Show.Pretty (pPrint)
import Control.Abstract.Matching
import Control.Rewriting hiding (fromMatcher, target)
import Data.Blob
import Data.File
import Data.History
import qualified Data.Language as Language
import Data.Project hiding (readFile)
import qualified Data.Source as Source
import qualified Data.Syntax.Literal as Literal
import Data.Term
@ -23,12 +23,11 @@ import Language.Python.PrettyPrint
import Language.Ruby.PrettyPrint
import Parsing.Parser
import Reprinting.Pipeline
import Semantic.IO as IO
import Semantic.Task
testPythonFile = do
let path = "test/fixtures/python/reprinting/function.py"
src <- blobSource <$> readBlobFromPath (File path Language.Python)
src <- blobSource <$> readBlobFromFile' (File path Language.Python)
tree <- parseFile' miniPythonParser path
pure (src, tree)
@ -50,7 +49,7 @@ testPythonPipeline''' = do
testRubyFile = do
let path = "test/fixtures/ruby/reprinting/infix.rb"
src <- blobSource <$> readBlobFromPath (File path Language.Ruby)
src <- blobSource <$> readBlobFromFile' (File path Language.Ruby)
tree <- parseFile' miniRubyParser path
pure (src, tree)
@ -74,7 +73,7 @@ printToTerm = either (putStrLn . show) (BC.putStr . Source.sourceBytes)
testJSONFile = do
let path = "test/fixtures/javascript/reprinting/map.json"
src <- blobSource <$> readBlobFromPath (File path Language.JSON)
src <- blobSource <$> readBlobFromFile' (File path Language.JSON)
tree <- parseFile' jsonParser path
pure (src, tree)

5
test/Examples.hs
View File

@ -8,10 +8,10 @@ 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.Foldable
import Data.List
import Data.Maybe
import Data.Project (file)
import Data.Quieterm
import Data.Typeable (cast)
import Data.Void
@ -21,6 +21,7 @@ import Semantic.Config (Config (..), Options (..), defaultOptions)
import qualified Semantic.IO as IO
import Semantic.Parse
import Semantic.Task
import Semantic.Task.Files
import Semantic.Util (TaskConfig (..))
import System.Directory
import System.Exit (die)
@ -99,7 +100,7 @@ languages =
-- , ("php", ".php") -- TODO: No parse-examples in tree-sitter yet
]
parseFilePath :: (Member (Exc SomeException) effs, Member Task effs, Member IO.Files effs) => FilePath -> Eff effs Bool
parseFilePath :: (Member (Exc SomeException) effs, Member Task effs, Member Files effs) => FilePath -> Eff effs Bool
parseFilePath path = readBlob (file path) >>= runParse' >>= const (pure True)
languagesDir :: FilePath

2
test/Graphing/Calls/Spec.hs
View File

@ -21,7 +21,7 @@ import Semantic.IO
callGraphPythonProject paths = runTaskWithOptions defaultOptions $ do
let proxy = Proxy @'Language.Python
let lang = Language.Python
blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths)
blobs <- catMaybes <$> traverse readBlobFromFile (flip File lang <$> paths)
package <- fmap snd <$> parsePackage pythonParser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang [])
modules <- topologicalSort <$> runImportGraphToModules proxy package
runCallGraph proxy False modules package

2
test/Reprinting/Spec.hs
View File

@ -29,7 +29,7 @@ spec = describe "reprinting" $ do
context "JSON" $ do
let path = "test/fixtures/javascript/reprinting/map.json"
(src, tree) <- runIO $ do
src <- blobSource <$> readBlobFromPath (File path Language.JSON)
src <- blobSource <$> readBlobFromFile' (File path Language.JSON)
tree <- parseFile jsonParser path
pure (src, tree)

10
test/Semantic/IO/Spec.hs
View File

@ -16,6 +16,8 @@ import qualified TreeSitter.Node as TS
import qualified TreeSitter.Parser as TS
import qualified TreeSitter.Tree as TS
import Data.Blob
import Data.Handle
import SpecHelpers hiding (readFile)
@ -23,17 +25,19 @@ spec :: Spec
spec = parallel $ do
describe "readFile" $ do
it "returns a blob for extant files" $ do
Just blob <- readFile (File "semantic.cabal" Unknown)
Just blob <- readBlobFromFile (File "semantic.cabal" Unknown)
blobPath blob `shouldBe` "semantic.cabal"
it "throws for absent files" $ do
readFile (File "this file should not exist" Unknown) `shouldThrow` anyIOException
readBlobFromFile (File "this file should not exist" Unknown) `shouldThrow` anyIOException
describe "readBlobPairsFromHandle" $ do
let a = sourceBlob "method.rb" Ruby "def foo; end"
let b = sourceBlob "method.rb" Ruby "def bar(x); end"
it "returns blobs for valid JSON encoded diff input" $ do
putStrLn "step 1"
blobs <- blobsFromFilePath "test/fixtures/cli/diff.json"
putStrLn "done"
blobs `shouldBe` [blobPairDiffing a b]
it "returns blobs when there's no before" $ do
@ -106,5 +110,7 @@ spec = parallel $ do
where blobsFromFilePath path = do
h <- openFileForReading path
putStrLn "got handle"
blobs <- readBlobPairsFromHandle h
putStrLn "got blobs"
pure blobs

6
test/SpecHelpers.hs
View File

@ -36,6 +36,8 @@ 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
@ -88,12 +90,12 @@ diffFilePaths (TaskConfig config logger statter) paths = readFilePair paths >>=
-- | Returns an s-expression parse tree for the specified FilePath.
parseFilePath :: TaskConfig -> FilePath -> IO ByteString
parseFilePath (TaskConfig config logger statter) path = (fromJust <$> IO.readFile (file path)) >>= runTaskWithConfig config logger statter . runParse SExpressionTermRenderer . pure >>= either (die . displayException) (pure . runBuilder)
parseFilePath (TaskConfig config logger statter) path = (fromJust <$> readBlobFromFile (file path)) >>= runTaskWithConfig config logger statter . runParse SExpressionTermRenderer . 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 IO.readFilePair paths'
runBothWith F.readFilePair paths'
type TestEvaluatingEffects term
= '[ Resumable (BaseError (ValueError term Precise))