1
1
mirror of https://github.com/github/semantic.git synced 2024-11-23 08:27:56 +03:00

🔥 pathtype.

This commit is contained in:
Rob Rix 2022-07-15 15:35:29 -04:00
parent a507b45e9f
commit b8d050579d
No known key found for this signature in database
GPG Key ID: 2BE643E01DC032AE
30 changed files with 109 additions and 161 deletions

View File

@ -76,7 +76,6 @@ library
, filepath
, fused-effects ^>= 1.1
, hashable
, pathtype ^>= 0.8.1
, semantic-source ^>= 0.2
, text ^>= 1.2.3.1
, transformers ^>= 0.5

View File

@ -8,13 +8,11 @@ module Analysis.Blob
, nullBlob
) where
import Analysis.File as A
import Analysis.Reference as A
import Data.Aeson
import Source.Language as Language
import Source.Source as Source
import qualified System.Path as Path
import qualified System.Path.PartClass as Path.PartClass
import Analysis.File as A
import Analysis.Reference as A
import Data.Aeson
import Source.Language as Language
import Source.Source as Source
-- | The source, path information, and language of a file read from disk.
data Blob = Blob
@ -25,27 +23,27 @@ data Blob = Blob
instance FromJSON Blob where
parseJSON = withObject "Blob" $ \b -> do
src <- b .: "content"
Right pth <- fmap Path.parse (b .: "path")
pth <- b .: "path"
lang <- b .: "language"
let lang' = if knownLanguage lang then lang else Language.forPath pth
pure (fromSource (pth :: Path.AbsRelFile) lang' src)
pure (fromSource pth lang' src)
-- | Create a Blob from a provided path, language, and UTF-8 source.
-- The resulting Blob's span is taken from the 'totalSpan' of the source.
fromSource :: Path.PartClass.AbsRel ar => Path.File ar -> Language -> Source -> Blob
fromSource :: FilePath -> Language -> Source -> Blob
fromSource filepath language source
= Blob source (A.File (A.Reference (Path.toAbsRel filepath) (totalSpan source)) language)
= Blob source (A.File (A.Reference filepath (totalSpan source)) language)
blobLanguage :: Blob -> Language
blobLanguage = A.fileBody . blobFile
blobPath :: Blob -> Path.AbsRelFile
blobPath :: Blob -> FilePath
blobPath = A.refPath . A.fileRef . blobFile
-- | Show FilePath for error or json outputs.
blobFilePath :: Blob -> String
blobFilePath = Path.toString . blobPath
blobFilePath = blobPath
nullBlob :: Blob -> Bool
nullBlob = Source.null . blobSource

View File

@ -14,8 +14,6 @@ import Data.Maybe (fromJust, listToMaybe)
import GHC.Stack
import Source.Language as Language
import Source.Span
import qualified System.Path as Path
import qualified System.Path.PartClass as Path.PartClass
-- Files
@ -29,10 +27,10 @@ data File a = File
-- Constructors
fromBody :: HasCallStack => a -> File a
fromBody body = File (A.Reference (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc)) body where
fromBody body = File (A.Reference (srcLocFile srcLoc) (spanFromSrcLoc srcLoc)) body where
srcLoc = snd (fromJust (listToMaybe (getCallStack callStack)))
fromPath :: Path.PartClass.AbsRel ar => Path.File ar -> File Language
fromPath :: FilePath -> File Language
fromPath p = File (A.fromPath p) (Language.forPath p)

View File

@ -13,7 +13,7 @@ import Data.Foldable (foldl')
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified System.Path as Path
import System.FilePath as Path
data Module a = Module
{ body :: Map.Map Name a -> a
@ -50,7 +50,7 @@ instance Monoid (ModuleSet a) where
fromList :: [File (Module a)] -> ModuleSet a
fromList = ModuleSet . Map.fromList . map (\ (File ref mod) -> (refName ref, mod))
where
refName (Reference path _) = name (Text.pack (Path.toString (Path.takeBaseName path)))
refName (Reference path _) = name (Text.pack (Path.takeBaseName path))
link :: ModuleSet a -> Module a -> Module a
link (ModuleSet ms) m = Module body' (imports m Set.\\ Map.keysSet ms) (exports m) unknown' where

View File

@ -12,19 +12,19 @@ import Analysis.File
import Data.Text (Text)
import qualified Data.Text as T
import Source.Language
import qualified System.Path as Path
import System.FilePath (takeFileName)
-- | A 'Project' contains all the information that semantic needs
-- to execute an analysis, diffing, or graphing pass.
data Project = Project
{ projectRootDir :: Path.AbsRelDir
{ projectRootDir :: FilePath
, projectBlobs :: [Blob]
, projectLanguage :: Language
, projectExcludeDirs :: [Path.AbsRelDir]
, projectExcludeDirs :: [FilePath]
} deriving (Eq, Show)
projectName :: Project -> Text
projectName = T.pack . maybe "" Path.toString . Path.takeDirName . projectRootDir
projectName = T.pack . takeFileName . projectRootDir
projectExtensions :: Project -> [String]
projectExtensions = extensionsForLanguage . projectLanguage

View File

@ -6,13 +6,11 @@ module Analysis.Reference
) where
import Source.Span
import System.Path as Path
import System.Path.PartClass as Path.PartClass
-- Reference
data Reference = Reference
{ refPath :: Path.AbsRelFile
{ refPath :: FilePath
, refSpan :: Span
}
deriving (Eq, Ord, Show)
@ -20,5 +18,5 @@ data Reference = Reference
-- Constructors
fromPath :: Path.PartClass.AbsRel ar => Path.File ar -> Reference
fromPath p = Reference (Path.toAbsRel p) (point (Pos 0 0))
fromPath :: FilePath -> Reference
fromPath p = Reference p (point (Pos 0 0))

View File

@ -55,7 +55,6 @@ import qualified Data.Vector as V
import qualified Source.Source as Source
import Source.Span
import System.FilePath
import qualified System.Path as Path
data Term
= Var Name
@ -140,7 +139,7 @@ parseFile path = do
case (A.eitherDecodeWith A.json' (A.iparse parseGraph) contents) of
Left (_, err) -> throwError err
Right (_, Nothing) -> throwError "no root node found"
Right (_, Just root) -> pure (sourceContents, File (Reference (Path.absRel sourcePath) span) root)
Right (_, Just root) -> pure (sourceContents, File (Reference sourcePath span) root)
where
decrSpan (Span (Pos sl sc) (Pos el ec)) = Span (Pos (sl - 1) (sc - 1)) (Pos (el - 1) (ec - 1))

View File

@ -73,7 +73,6 @@ library
, filepath ^>= 1.4.1
, fused-effects ^>= 1.1
, Glob ^>= 0.10.0
, pathtype ^>= 0.8.1
, semantic-source ^>= 0.2
, tasty ^>= 1.2.3
, tasty-hunit ^>= 0.10.0.2

View File

@ -7,29 +7,28 @@ module AST.TestHelpers
, testCorpus
) where
import Control.Applicative
import Control.Monad
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.ByteString.Char8 as Attoparsec
import Data.ByteString (ByteString, readFile)
import Data.ByteString.Char8 (pack, unpack)
import Data.Either
import Data.Functor
import Prelude hiding (takeWhile)
import System.Exit (exitFailure)
import System.Path ((</>))
import qualified System.Path as Path
import qualified System.Path.Directory as Path
import System.FilePath.Glob
import Test.Tasty
import Test.Tasty.HUnit
import Control.Applicative
import Control.Monad
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.ByteString.Char8 as Attoparsec
import Data.ByteString (ByteString, readFile)
import Data.ByteString.Char8 (pack, unpack)
import Data.Either
import Data.Functor
import Prelude hiding (takeWhile)
import System.Directory
import System.Exit (exitFailure)
import System.FilePath
import System.FilePath.Glob
import Test.Tasty
import Test.Tasty.HUnit
testCorpus :: (ByteString -> IO (Either String (t a))) -> Path.AbsRelFile -> IO TestTree
testCorpus :: (ByteString -> IO (Either String (t a))) -> FilePath -> IO TestTree
testCorpus parse path = do
xs <- parseCorpusFile path
case xs of
Left e -> print ("Failed to parse corpus: " <> show (Path.toString path) <> " " <> "Error: " <> show e) *> exitFailure
Right xs -> testGroup (Path.toString path) <$> traverse corpusTestCase xs
Left e -> print ("Failed to parse corpus: " <> show path <> " " <> "Error: " <> show e) *> exitFailure
Right xs -> testGroup path <$> traverse corpusTestCase xs
where
corpusTestCase (CorpusExample name code) = testCase name . either (errMsg code) pass <$> parse code
pass = const (pure ())
@ -38,31 +37,28 @@ testCorpus parse path = do
-- Depending on whether these tests are invoked via cabal run or cabal test,
-- we might be in a project subdirectory or not, so let's make sure we're
-- in project subdirectories as needed.
findCorpus :: Path.RelDir -> IO Path.RelDir
findCorpus :: FilePath -> IO FilePath
findCorpus p = do
cwd <- Path.getCurrentDirectory
if Path.takeDirName cwd == Just (Path.relDir "haskell-tree-sitter")
cwd <- getCurrentDirectory
if takeFileName cwd == "haskell-tree-sitter"
then pure p
else pure (Path.relDir ".." </> p)
else pure (".." </> p)
-- The path is expected to be relative to the language project.
readCorpusFiles :: Path.RelDir -> IO [Path.RelFile]
readCorpusFiles :: FilePath -> IO [FilePath]
readCorpusFiles parent = do
dir <- findCorpus parent
files <- globDir1 (compile "**/*.txt") (Path.toString dir)
pure (Path.relPath <$> files)
globDir1 (compile "**/*.txt") dir
readCorpusFiles' :: Path.AbsRelDir -> IO [Path.AbsRelFile]
readCorpusFiles' dir = do
files <- globDir1 (compile "**/*.txt") (Path.toString dir)
pure (Path.file <$> files)
readCorpusFiles' :: FilePath -> IO [FilePath]
readCorpusFiles' = globDir1 (compile "**/*.txt")
data CorpusExample = CorpusExample { name :: String, code :: ByteString }
deriving (Eq, Show)
parseCorpusFile :: Path.AbsRelFile -> IO (Either String [CorpusExample])
parseCorpusFile :: FilePath -> IO (Either String [CorpusExample])
parseCorpusFile path = do
c <- Data.ByteString.readFile (Path.toString path)
c <- Data.ByteString.readFile path
pure $ parseOnly corpusParser c
corpusParser :: Parser [CorpusExample]

View File

@ -13,9 +13,8 @@ where
import Control.Concurrent
import GHC.Stack
import System.FilePath
import System.IO
import qualified System.Path as Path
import System.Path ((</>))
#if BAZEL_BUILD
import qualified Bazel.Runfiles as Bazel
@ -29,13 +28,13 @@ type HasFixture =
create :: IO Bazel.Runfiles
create = Bazel.create
root :: HasFixture => Path.AbsRelDir
root :: HasFixture => FilePath
root = Path.absRel (Bazel.rlocation ?runfiles ".")
absRelFile :: (HasFixture) => String -> Path.AbsRelFile
absRelFile :: (HasFixture) => String -> FilePath
absRelFile x = Path.toAbsRel (root </> Path.relDir "semantic" </> ?project </> Path.relFile x)
absRelDir :: HasFixture => String -> Path.AbsRelDir
absRelDir :: HasFixture => String -> FilePath
absRelDir x = Path.toAbsRel (root </> Path.relDir "semantic" </> ?project </> Path.relDir x)
#else
@ -46,11 +45,11 @@ type HasFixture = HasCallStack
create :: IO ()
create = pure ()
absRelFile :: String -> Path.AbsRelFile
absRelFile x = Path.absRel "semantic" </> Path.relFile x
absRelFile :: String -> FilePath
absRelFile x = "semantic" </> x
absRelDir :: String -> Path.AbsRelDir
absRelDir x = Path.absRel "semantic" </> Path.relDir x
absRelDir :: String -> FilePath
absRelDir x = "semantic" </> x
#endif

View File

@ -71,7 +71,6 @@ test-suite test
main-is: PreciseTest.hs
build-depends:
, base
, pathtype ^>= 0.8.1
, semantic-ast
, semantic-codeql
, tasty

View File

@ -71,7 +71,6 @@ test-suite test
main-is: PreciseTest.hs
build-depends:
, base
, pathtype ^>= 0.8.1
, semantic-ast
, semantic-go
, tasty

View File

@ -71,7 +71,6 @@ test-suite test
main-is: PreciseTest.hs
build-depends:
, base
, pathtype ^>= 0.8.1
, semantic-ast
, semantic-java
, tasty

View File

@ -68,7 +68,6 @@ test-suite test
main-is: PreciseTest.hs
build-depends:
, base
, pathtype ^>= 0.8.1
, semantic-ast
, semantic-json
, tasty

View File

@ -84,7 +84,6 @@ library
-- , containers ^>= 0.6
-- , directory ^>= 1.3.3
-- , exceptions ^>= 0.10.2
-- , pathtype ^>= 0.8.1
-- , pretty-show ^>= 1.9.5
-- , process ^>= 1.6.5
-- , resourcet ^>= 1.2.2
@ -112,7 +111,6 @@ library
-- , semantic-python
-- -- , semantic-scope-graph
-- , bytestring
-- , pathtype
-- , tasty
-- , tasty-hunit
@ -124,7 +122,6 @@ test-suite test
main-is: PreciseTest.hs
build-depends:
, base
, pathtype ^>= 0.8.1
, semantic-ast
, semantic-python
, tasty

View File

@ -1,31 +1,29 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeApplications #-}
module Parsing (benchmarks) where
import AST.Unmarshal
import Control.Monad
import qualified Data.ByteString as B
import Data.Foldable
import Gauge
import System.Exit (die)
import System.FilePath.Glob
import qualified System.Path as Path
import Language.Ruby
import qualified Language.Ruby.AST as Rb
import AST.Unmarshal
import System.Exit (die)
import System.FilePath.Glob
benchmarks :: Benchmark
benchmarks = bgroup "parsing" [ rubyBenchmarks ]
rubyBenchmarks :: Benchmark
rubyBenchmarks = bench "ruby" $ parseAllFiles dir "*.rb"
where dir = Path.relDir "../semantic/tmp/ruby-examples/ruby_spec/command_line"
where dir = "../semantic/tmp/ruby-examples/ruby_spec/command_line"
parseAllFiles :: Path.RelDir -> String -> Benchmarkable
parseAllFiles :: FilePath -> String -> Benchmarkable
parseAllFiles dir glob = nfIO $ do
files <- globDir1 (compile glob) (Path.toString dir)
let paths = Path.relFile <$> files
when (null paths) (die $ "No files found in " <> (Path.toString dir))
paths <- globDir1 (compile glob) dir
when (null paths) (die $ "No files found in " <> dir)
for_ paths $ \ file -> do
-- print (Path.toString file)
contents <- B.readFile (Path.toString file)
contents <- B.readFile file
either die pure =<< parseByteString @Rb.Program @() tree_sitter_ruby contents

View File

@ -71,7 +71,6 @@ test-suite test
main-is: PreciseTest.hs
build-depends:
, base
, pathtype ^>= 0.8.1
, semantic-ast
, semantic-ruby
, tasty
@ -89,7 +88,6 @@ executable benchmarks
, bytestring
, gauge ^>= 0.2.5
, Glob
, pathtype ^>= 0.8.1
, semantic-ast
, semantic-ruby

View File

@ -70,7 +70,6 @@ test-suite test
main-is: Test.hs
build-depends:
, base
, pathtype ^>= 0.8.1
, semantic-ast
, semantic-rust
, tasty

View File

@ -14,7 +14,6 @@ import Data.Maybe
import Data.Semilattice.Lower
import Data.Text (Text)
import GHC.Stack
import qualified System.Path as Path
data Module body = Module { moduleInfo :: ModuleInfo, moduleBody :: body }
deriving (Eq, Foldable, Functor, Ord, Traversable)
@ -23,20 +22,20 @@ instance Show body => Show (Module body) where
showsPrec d Module{..} = showsBinaryWith showsPrec showsPrec "Module" d (modulePath moduleInfo) moduleBody
type ModulePath = Path.AbsRelFile
type ModulePath = FilePath
data ModuleInfo = ModuleInfo { modulePath :: ModulePath, moduleLanguage :: Text, moduleOid :: Text }
deriving (Eq, Ord)
instance Lower ModuleInfo where
lowerBound = ModuleInfo (Path.toAbsRel Path.emptyFile) "Unknown" mempty
lowerBound = ModuleInfo "" "Unknown" mempty
instance Show ModuleInfo where
showsPrec d = showsUnaryWith showsPrec "ModuleInfo" d . modulePath
moduleInfoFromSrcLoc :: SrcLoc -> ModuleInfo
moduleInfoFromSrcLoc loc = ModuleInfo (Path.absRel $ srcLocModule loc) "Unknown" mempty
moduleInfoFromSrcLoc loc = ModuleInfo (srcLocModule loc) "Unknown" mempty
-- | Produce 'ModuleInfo' from the top location on the Haskell call stack (i.e. the file where the call to 'moduleInfoFromCallStack' was made).
moduleInfoFromCallStack :: HasCallStack => ModuleInfo
moduleInfoFromCallStack = maybe (ModuleInfo (Path.absRel "?") "Unknown" mempty) (moduleInfoFromSrcLoc . snd) (listToMaybe (getCallStack callStack))
moduleInfoFromCallStack = maybe (ModuleInfo "?" "Unknown" mempty) (moduleInfoFromSrcLoc . snd) (listToMaybe (getCallStack callStack))

View File

@ -71,7 +71,6 @@ test-suite test
main-is: PreciseTest.hs
build-depends:
, base
, pathtype ^>= 0.8.1
, semantic-ast
, semantic-tsx
, tasty

View File

@ -71,7 +71,6 @@ test-suite test
main-is: PreciseTest.hs
build-depends:
, base
, pathtype ^>= 0.8.1
, semantic-ast
, semantic-typescript
, tasty

View File

@ -122,7 +122,6 @@ library
, network >= 2.8 && < 3.2
, network-uri ^>= 2.6.1.0
, optparse-applicative >= 0.14.3 && < 0.16
, pathtype ^>= 0.8.1
, pretty-show ^>= 1.9.5
, proto-lens >= 0.5 && < 0.8
, semantic-analysis ^>= 0
@ -183,7 +182,6 @@ test-suite test
, hspec >= 2.6 && <3
, hspec-expectations ^>= 0.8.2
, network >= 2.8 && < 3.2
, pathtype ^>= 0.8.1
, semantic
, semantic-analysis
, semantic-ast
@ -208,7 +206,6 @@ test-suite parse-examples
, fused-effects ^>= 1.1
, Glob
, lens >= 4.17 && < 5.2
, pathtype ^>= 0.8.1
, process ^>= 1.6.3.0
, semantic
, semantic-analysis ^>= 0
@ -230,7 +227,6 @@ benchmark benchmarks
, fused-effects ^>= 1.1
, gauge ^>= 0.2.5
, Glob
, pathtype ^>= 0.8.1
, semantic
, semantic-analysis ^>= 0
, semantic-proto

View File

@ -31,12 +31,12 @@ import Data.Aeson
import Data.Bifunctor
import qualified Data.ByteString.Lazy as BL
import Data.Edit
import Data.List (stripPrefix)
import Data.Maybe.Exts
import Data.Module
import Data.List (stripPrefix)
import GHC.Generics (Generic)
import Source.Language as Language
import qualified System.Path as Path
import qualified System.FilePath as Path
newtype Blobs a = Blobs { blobs :: [a] }
@ -46,10 +46,10 @@ decodeBlobs :: BL.ByteString -> Either String [Blob]
decodeBlobs = fmap blobs <$> eitherDecode
-- | An exception indicating that weve tried to diff or parse a blob of unknown language.
newtype NoLanguageForBlob = NoLanguageForBlob Path.AbsRelFile
newtype NoLanguageForBlob = NoLanguageForBlob FilePath
deriving (Eq, Exception, Ord, Show)
noLanguageForBlob :: Has (Error SomeException) sig m => Path.AbsRelFile -> m a
noLanguageForBlob :: Has (Error SomeException) sig m => FilePath -> m a
noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
-- | Construct a 'Module' for a 'Blob' and @term@, relative to some root 'FilePath'.
@ -58,16 +58,17 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo
-> 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 b = Module info
where root = maybe (Path.takeDirectory $ blobPath b) Path.absRel rootDir
where root = fromMaybe (Path.takeDirectory $ blobPath b) rootDir
info = ModuleInfo (dropRelative root (blobPath b)) (languageToText (blobLanguage b)) mempty
dropRelative :: Path.AbsRelDir -> Path.AbsRelFile -> Path.AbsRelFile
dropRelative :: FilePath -> FilePath -> FilePath
dropRelative a' b' = case as `stripPrefix` bs of
Just rs | ra == rb -> Path.toAbsRel $ (foldl (Path.</>) Path.currentDir rs) Path.</> bf
_ -> b'
where (ra, as, _) = Path.splitPath $ Path.normalise a'
(rb, bs, _) = Path.splitPath $ Path.normalise $ Path.takeDirectory b'
Just rs | ra == rb -> foldl (Path.</>) "." rs Path.</> bf
_ -> b'
where (ra, as) = splitPath $ Path.normalise a'
(rb, bs) = splitPath $ Path.normalise $ Path.takeDirectory b'
bf = Path.takeFileName b'
splitPath p = (Path.isAbsolute p, Path.splitDirectories p)
-- | 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.
@ -87,7 +88,7 @@ languageForBlobPair = mergeEdit combine . bimap blobLanguage blobLanguage where
| a == Unknown || b == Unknown = Unknown
| otherwise = b
pathForBlobPair :: BlobPair -> Path.AbsRelFile
pathForBlobPair :: BlobPair -> FilePath
pathForBlobPair = blobPath . mergeEdit (const id)
languageTagForBlobPair :: BlobPair -> [(String, String)]

View File

@ -21,25 +21,16 @@ import Semantic.IO
import Source.Language
import qualified Source.Source as Source
import Source.Span
import qualified System.Path as Path
-- | Deprecated: this has very weird semantics.
readProjectFromPaths :: MonadIO m
=> Maybe Path.AbsRelDir -- ^ An optional root directory for the project
-> Path.AbsRelFileDir -- ^ A file or directory to parse. Passing a file path loads all files in that file's parent directory.
=> Maybe FilePath -- ^ An optional root directory for the project
-> FilePath -- ^ A file or directory to parse. Passing a file path loads all files in that file's parent directory.
-> Language
-> [Path.AbsRelDir] -- ^ Directories to exclude.
-> [FilePath] -- ^ Directories to exclude.
-> m Project
readProjectFromPaths maybeRoot path lang excludeDirs = do
let rootDir :: Path.AbsRelDir
rootDir = case maybeRoot >>= Path.fromAbsRel of
-- If we were provided a root directory, use that.
Just root -> root
Nothing -> case Path.fileFromFileDir path of
-- If we weren't and the path is a file, drop its file name.
Just fp -> Path.takeDirectory fp
-- Otherwise, load from the path.
Nothing -> Path.dirFromFileDir path
let rootDir = fromMaybe path maybeRoot
paths <- liftIO $ findFilesInDir rootDir exts excludeDirs
blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths
@ -51,9 +42,9 @@ readProjectFromPaths maybeRoot path lang excludeDirs = do
-- | Read a utf8-encoded file to a 'Blob'.
readBlobFromFile :: MonadIO m => File Language -> m (Maybe Blob)
readBlobFromFile (File (Reference (Path.toString -> "/dev/null") _) _) = pure Nothing
readBlobFromFile (File (Reference "/dev/null" _) _) = pure Nothing
readBlobFromFile file@(File (Reference path _) _language) = do
raw <- liftIO $ B.readFile (Path.toString path)
raw <- liftIO $ B.readFile path
let newblob = Blob (Source.fromUTF8 raw) file
pure . Just $ newblob
@ -64,7 +55,7 @@ readBlobFromFile' file = do
maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile
-- | Read a blob from the provided absolute or relative path , failing if it can't be found.
readBlobFromPath :: (MonadFail m, MonadIO m) => Path.AbsRelFile -> m Blob
readBlobFromPath :: (MonadFail m, MonadIO m) => FilePath -> m Blob
readBlobFromPath = readBlobFromFile' . File.fromPath
readFilePair :: MonadIO m => File Language -> File Language -> m BlobPair

View File

@ -20,11 +20,10 @@ module Data.Handle
import Control.Exception (Exception, throw)
import Control.Monad.IO.Class
import Data.Aeson
import Data.Blob
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified System.IO as IO
import qualified System.Path as Path
import Data.Blob
data Handle mode where
ReadHandle :: IO.Handle -> Handle 'IO.ReadMode
@ -46,8 +45,8 @@ stdout = WriteHandle IO.stdout
stderr :: Handle 'IO.WriteMode
stderr = WriteHandle IO.stderr
openFileForReading :: Path.AbsRelFile -> IO (Handle 'IO.ReadMode)
openFileForReading path = ReadHandle <$> IO.openFile (Path.toString path) IO.ReadMode
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]

View File

@ -12,7 +12,6 @@ import Analysis.File
import Analysis.Reference
import Control.Lens
import qualified Data.Blob as Data
import Data.Either
import Data.ProtoLens (defMessage)
import qualified Data.Text as T
import Data.Text.Lens
@ -22,7 +21,6 @@ import qualified Source.Language as Data
import qualified Source.Range as Source
import qualified Source.Source as Source (fromText, toText, totalSpan)
import qualified Source.Span as Source
import qualified System.Path as Path
-- | An @APIBridge x y@ instance describes an isomorphism between @x@ and @y@.
-- This is suitable for types such as 'Pos' which are representationally equivalent
@ -80,7 +78,7 @@ instance APIBridge API.Blob Data.Blob where
& P.language .~ (bridging # Data.blobLanguage b)
apiBlobToBlob blob =
let src = blob ^. content.to Source.fromText
pth = fromRight (Path.toAbsRel Path.emptyFile) (blob ^. path._Text.to Path.parse)
pth = blob ^. path._Text
in Data.Blob
{ blobSource = src
, blobFile = File (Reference pth (Source.totalSpan src)) (blob ^. language.bridging)

View File

@ -20,8 +20,6 @@ import Semantic.Version
import Serializing.Format
import qualified Source.Language as Language
import System.Exit (die)
import qualified System.Path as Path
import qualified System.Path.PartClass as Path.PartClass
import Control.Concurrent (mkWeakThreadId, myThreadId)
import Proto.Semantic_JSON ()
@ -112,10 +110,10 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa
filePathReader :: ReadM (File.File Language.Language)
filePathReader = File.fromPath <$> path
path :: (Path.PartClass.FileDir fd) => ReadM (Path.AbsRel fd)
path = eitherReader Path.parse
path :: ReadM FilePath
path = eitherReader Right
pathOption :: Path.PartClass.FileDir fd => Mod OptionFields (Path.AbsRel fd) -> Parser (Path.AbsRel fd)
pathOption :: Mod OptionFields FilePath -> Parser FilePath
pathOption = option path
options :: Eq a => [(String, a)] -> Mod OptionFields a -> Parser a

View File

@ -13,22 +13,20 @@ import Control.Monad.IO.Class
import System.Directory.Tree (AnchoredDirTree (..))
import qualified System.Directory.Tree as Tree
import System.FilePath
import qualified System.Path as Path
import qualified System.Path.PartClass as Path.PartClass
pathIsMinified :: FilePath -> Bool
pathIsMinified = isExtensionOf ".min.js"
-- Recursively find files in a directory.
findFilesInDir :: (Path.PartClass.AbsRel ar, MonadIO m) => Path.Dir ar -> [String] -> [Path.Dir ar] -> m [Path.File ar]
findFilesInDir :: MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
findFilesInDir path exts excludeDirs = do
_:/dir <- liftIO $ Tree.build (Path.toString path)
_:/dir <- liftIO $ Tree.build path
pure $ (onlyFiles . Tree.filterDir (withExtensions exts) . Tree.filterDir (notIn excludeDirs)) dir
where
-- Build a list of only FilePath's (remove directories and failures)
onlyFiles (Tree.Dir _ fs) = concatMap onlyFiles fs
onlyFiles (Tree.Failed _ _) = []
onlyFiles (Tree.File _ f) = [Path.file f]
onlyFiles (Tree.File _ f) = [f]
-- Predicate for Files with one of the extensions in 'exts'.
withExtensions exts (Tree.File n _)
@ -40,6 +38,6 @@ findFilesInDir path exts excludeDirs = do
-- Predicate for contents NOT in a directory
notIn dirs (Tree.Dir n _)
| (x:_) <- n, x == '.' = False -- Don't include directories that start with '.'.
| Path.dir n `elem` dirs = False
| n `elem` dirs = False
| otherwise = True
notIn _ _ = True

View File

@ -36,9 +36,7 @@ import Data.Handle
import Prelude hiding (readFile)
import Semantic.IO
import Source.Language (Language)
import qualified System.IO as IO hiding (withBinaryFile)
import qualified System.Path as Path
import qualified System.Path.IO as IO (withBinaryFile)
import qualified System.IO as IO
data Source blob where
FromPath :: File Language -> Source Blob
@ -46,13 +44,13 @@ data Source blob where
FromPathPair :: File Language -> File Language -> Source BlobPair
FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair]
data Destination = ToPath Path.AbsRelFile | ToHandle (Handle 'IO.WriteMode)
data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
data Files (m :: * -> *) k where
Read :: Source a -> Files m a
ReadProject :: Maybe Path.AbsRelDir -> Path.AbsRelFileDir -> Language -> [Path.AbsRelDir] -> Files m Project
FindFiles :: Path.AbsRelDir -> [String] -> [Path.AbsRelDir] -> Files m [Path.AbsRelFile]
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files m Project
FindFiles :: FilePath -> [String] -> [FilePath] -> Files m [FilePath]
Write :: Destination -> B.Builder -> Files m ()
@ -93,10 +91,10 @@ readBlobPairs :: Has Files sig m => Either (Handle 'IO.ReadMode) [(File Language
readBlobPairs (Left handle) = send (Read (FromPairHandle handle))
readBlobPairs (Right paths) = traverse (send . Read . uncurry FromPathPair) paths
readProject :: Has Files sig m => Maybe Path.AbsRelDir -> Path.AbsRelFileDir -> Language -> [Path.AbsRelDir] -> m Project
readProject :: Has Files sig m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs)
findFiles :: Has Files sig m => Path.AbsRelDir -> [String] -> [Path.AbsRelDir] -> m [Path.AbsRelFile]
findFiles :: Has Files sig m => FilePath -> [String] -> [FilePath] -> m [FilePath]
findFiles dir exts paths = send (FindFiles dir exts paths)
-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.

View File

@ -4,7 +4,6 @@
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-exported-signatures -Wno-partial-type-signatures -O0 #-}
module Semantic.Util
( parseFile
@ -25,14 +24,13 @@ import Semantic.Task
import qualified Source.Language as Language
import Source.Span (Pos (..), point)
import System.Exit (die)
import qualified System.Path as Path
parseFile, parseFileQuiet :: Parser term -> FilePath -> IO term
parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath)
parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath)
fileForPath :: FilePath -> File Language.Language
fileForPath (Path.absRel -> p) = File (Reference p (point (Pos 1 1))) (Language.forPath p)
fileForPath p = File (Reference p (point (Pos 1 1))) (Language.forPath p)
runTask', runTaskQuiet :: ParseC TaskC a -> IO a
runTask' task = runTaskWithOptions debugOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure