mirror of
https://github.com/github/semantic.git
synced 2025-01-03 04:51:57 +03:00
Rework option handling for generating tags
Command is now `semantic parse --tags`
This commit is contained in:
parent
0b3568aaba
commit
9b7b22e0a5
@ -1,8 +1,10 @@
|
|||||||
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables, TupleSections #-}
|
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables, TupleSections #-}
|
||||||
module Files
|
module Files
|
||||||
( readFile
|
( readFile
|
||||||
|
, isDirectory
|
||||||
, readBlobPairsFromHandle
|
, readBlobPairsFromHandle
|
||||||
, readBlobsFromHandle
|
, readBlobsFromHandle
|
||||||
|
, readBlobsFromPaths
|
||||||
, readBlobsFromDir
|
, readBlobsFromDir
|
||||||
, languageForFilePath
|
, languageForFilePath
|
||||||
) where
|
) where
|
||||||
@ -27,6 +29,7 @@ import System.Exit
|
|||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO (Handle)
|
import System.IO (Handle)
|
||||||
import System.FilePath.Glob
|
import System.FilePath.Glob
|
||||||
|
import System.Directory (doesDirectoryExist)
|
||||||
import Text.Read
|
import Text.Read
|
||||||
|
|
||||||
-- | Read a utf8-encoded file to a 'Blob'.
|
-- | Read a utf8-encoded file to a 'Blob'.
|
||||||
@ -36,6 +39,9 @@ readFile path language = do
|
|||||||
raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe B.ByteString))
|
raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe B.ByteString))
|
||||||
pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw)
|
pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw)
|
||||||
|
|
||||||
|
isDirectory :: MonadIO m => FilePath -> m Bool
|
||||||
|
isDirectory path = liftIO (doesDirectoryExist path) >>= pure
|
||||||
|
|
||||||
-- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported.
|
-- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported.
|
||||||
languageForFilePath :: FilePath -> Maybe Language
|
languageForFilePath :: FilePath -> Maybe Language
|
||||||
languageForFilePath = languageForType . takeExtension
|
languageForFilePath = languageForType . takeExtension
|
||||||
@ -53,6 +59,9 @@ readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob]
|
|||||||
readBlobsFromHandle = fmap toBlobs . readFromHandle
|
readBlobsFromHandle = fmap toBlobs . readFromHandle
|
||||||
where toBlobs BlobParse{..} = fmap toBlob blobs
|
where toBlobs BlobParse{..} = fmap toBlob blobs
|
||||||
|
|
||||||
|
readBlobsFromPaths :: MonadIO m => [(FilePath, Maybe Language)] -> m [Blob.Blob]
|
||||||
|
readBlobsFromPaths = traverse (uncurry Files.readFile)
|
||||||
|
|
||||||
readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
|
readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
|
||||||
readBlobsFromDir path = do
|
readBlobsFromDir path = do
|
||||||
paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.go|.py]") path)
|
paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.go|.py]") path)
|
||||||
|
@ -2,7 +2,6 @@
|
|||||||
module Semantic
|
module Semantic
|
||||||
( parseBlobs
|
( parseBlobs
|
||||||
, parseBlob
|
, parseBlob
|
||||||
, generateTags
|
|
||||||
, diffBlobPairs
|
, diffBlobPairs
|
||||||
, diffBlobPair
|
, diffBlobPair
|
||||||
, diffTermPair
|
, diffTermPair
|
||||||
@ -44,9 +43,6 @@ import Semantic.Stat as Stat
|
|||||||
parseBlobs :: Output output => TermRenderer output -> [Blob] -> Task ByteString
|
parseBlobs :: Output output => TermRenderer output -> [Blob] -> Task ByteString
|
||||||
parseBlobs renderer = fmap toOutput . distributeFoldMap (parseBlob renderer) . filter blobExists
|
parseBlobs renderer = fmap toOutput . distributeFoldMap (parseBlob renderer) . filter blobExists
|
||||||
|
|
||||||
generateTags :: [Blob] -> Task ByteString
|
|
||||||
generateTags = fmap toOutput . distributeFoldMap (parseBlob TagsTermRenderer) . filter blobExists
|
|
||||||
|
|
||||||
-- | A task to parse a 'Blob' and render the resulting 'Term'.
|
-- | A task to parse a 'Blob' and render the resulting 'Term'.
|
||||||
parseBlob :: TermRenderer output -> Blob -> Task output
|
parseBlob :: TermRenderer output -> Blob -> Task output
|
||||||
parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of
|
parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of
|
||||||
|
@ -5,7 +5,6 @@ module Semantic.Task
|
|||||||
, RAlgebra
|
, RAlgebra
|
||||||
, Differ
|
, Differ
|
||||||
, readBlobs
|
, readBlobs
|
||||||
, readProject
|
|
||||||
, readBlobPairs
|
, readBlobPairs
|
||||||
, writeToOutput
|
, writeToOutput
|
||||||
, writeLog
|
, writeLog
|
||||||
@ -33,6 +32,7 @@ import Control.Parallel.Strategies
|
|||||||
import qualified Control.Concurrent.Async as Async
|
import qualified Control.Concurrent.Async as Async
|
||||||
import Control.Monad.Free.Freer
|
import Control.Monad.Free.Freer
|
||||||
import Data.Blob
|
import Data.Blob
|
||||||
|
import Data.Bool
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import Data.Diff
|
import Data.Diff
|
||||||
import qualified Data.Error as Error
|
import qualified Data.Error as Error
|
||||||
@ -60,7 +60,6 @@ import Semantic.Queue
|
|||||||
|
|
||||||
data TaskF output where
|
data TaskF output where
|
||||||
ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob]
|
ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob]
|
||||||
ReadProject :: FilePath -> TaskF [Blob]
|
|
||||||
ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob]
|
ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob]
|
||||||
WriteToOutput :: Either Handle FilePath -> B.ByteString -> TaskF ()
|
WriteToOutput :: Either Handle FilePath -> B.ByteString -> TaskF ()
|
||||||
WriteLog :: Level -> String -> [(String, String)] -> TaskF ()
|
WriteLog :: Level -> String -> [(String, String)] -> TaskF ()
|
||||||
@ -92,9 +91,6 @@ type Renderer i o = i -> o
|
|||||||
readBlobs :: Either Handle [(FilePath, Maybe Language)] -> Task [Blob]
|
readBlobs :: Either Handle [(FilePath, Maybe Language)] -> Task [Blob]
|
||||||
readBlobs from = ReadBlobs from `Then` return
|
readBlobs from = ReadBlobs from `Then` return
|
||||||
|
|
||||||
readProject :: FilePath -> Task [Blob]
|
|
||||||
readProject dir = ReadProject dir `Then` return
|
|
||||||
|
|
||||||
-- | 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.
|
-- | 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 :: Either Handle [Both (FilePath, Maybe Language)] -> Task [Both Blob]
|
readBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Task [Both Blob]
|
||||||
readBlobPairs from = ReadBlobPairs from `Then` return
|
readBlobPairs from = ReadBlobPairs from `Then` return
|
||||||
@ -180,8 +176,9 @@ runTaskWithOptions options task = do
|
|||||||
where
|
where
|
||||||
go :: Task a -> IO (Either SomeException a)
|
go :: Task a -> IO (Either SomeException a)
|
||||||
go = iterFreerA (\ task yield -> case task of
|
go = iterFreerA (\ task yield -> case task of
|
||||||
ReadBlobs source -> (either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source >>= yield) `catchError` (pure . Left . toException)
|
ReadBlobs (Left handle) -> (Files.readBlobsFromHandle handle >>= yield) `catchError` (pure . Left . toException)
|
||||||
ReadProject dir -> Files.readBlobsFromDir dir >>= yield
|
ReadBlobs (Right paths@[(path, Nothing)]) -> (Files.isDirectory path >>= bool (Files.readBlobsFromPaths paths) (Files.readBlobsFromDir path) >>= yield) `catchError` (pure . Left . toException)
|
||||||
|
ReadBlobs (Right paths) -> (Files.readBlobsFromPaths paths >>= yield) `catchError` (pure . Left . toException)
|
||||||
ReadBlobPairs source -> (either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield) `catchError` (pure . Left . toException)
|
ReadBlobPairs source -> (either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield) `catchError` (pure . Left . toException)
|
||||||
WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield
|
WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield
|
||||||
WriteLog level message pairs -> queueLogMessage logger level message pairs >>= yield
|
WriteLog level message pairs -> queueLogMessage logger level message pairs >>= yield
|
||||||
|
@ -23,7 +23,7 @@ import qualified Paths_semantic_diff as Library (version)
|
|||||||
import qualified Semantic.Task as Task
|
import qualified Semantic.Task as Task
|
||||||
import qualified Semantic.Log as Log
|
import qualified Semantic.Log as Log
|
||||||
import System.IO (Handle, stdin, stdout)
|
import System.IO (Handle, stdin, stdout)
|
||||||
import qualified Semantic (parseBlobs, generateTags, diffBlobPairs)
|
import qualified Semantic (parseBlobs, diffBlobPairs)
|
||||||
import Text.Read
|
import Text.Read
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
@ -35,11 +35,6 @@ runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Ta
|
|||||||
runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.Task ByteString
|
runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.Task ByteString
|
||||||
runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
|
runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
|
||||||
|
|
||||||
runTags :: Either Handle FilePath -> Task.Task ByteString
|
|
||||||
runTags handleOrPath = case handleOrPath of
|
|
||||||
(Left handle) -> (Semantic.generateTags <=< Task.readBlobs) (Left handle)
|
|
||||||
Right path -> (Semantic.generateTags <=< Task.readProject) path
|
|
||||||
|
|
||||||
-- | A parser for the application's command-line arguments.
|
-- | A parser for the application's command-line arguments.
|
||||||
--
|
--
|
||||||
-- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout.
|
-- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout.
|
||||||
@ -61,7 +56,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
|
|||||||
<*> pure Log.logfmtFormatter -- Formatter
|
<*> pure Log.logfmtFormatter -- Formatter
|
||||||
<*> pure 0 -- ProcessID
|
<*> pure 0 -- ProcessID
|
||||||
argumentsParser = (. Task.writeToOutput) . (>>=)
|
argumentsParser = (. Task.writeToOutput) . (>>=)
|
||||||
<$> hsubparser (diffCommand <> parseCommand <> tagsCommand)
|
<$> hsubparser (diffCommand <> parseCommand)
|
||||||
<*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout")
|
<*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout")
|
||||||
<|> pure (Left stdout) )
|
<|> pure (Left stdout) )
|
||||||
|
|
||||||
@ -86,9 +81,6 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
|
|||||||
<*> ( Right <$> some (argument filePathReader (metavar "FILES..."))
|
<*> ( Right <$> some (argument filePathReader (metavar "FILES..."))
|
||||||
<|> pure (Left stdin) )
|
<|> pure (Left stdin) )
|
||||||
|
|
||||||
tagsCommand = command "tags" (info tagsArgumentsParser (progDesc "Print tags for project"))
|
|
||||||
tagsArgumentsParser = runTags <$> ( Right <$> argument str (metavar "PROJECT") <|> pure (Left stdin) )
|
|
||||||
|
|
||||||
filePathReader = eitherReader parseFilePath
|
filePathReader = eitherReader parseFilePath
|
||||||
parseFilePath arg = case splitWhen (== ':') arg of
|
parseFilePath arg = case splitWhen (== ':') arg of
|
||||||
[a, b] | Just lang <- readMaybe a -> Right (b, Just lang)
|
[a, b] | Just lang <- readMaybe a -> Right (b, Just lang)
|
||||||
|
Loading…
Reference in New Issue
Block a user