1
1
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:
Timothy Clem 2017-11-08 15:30:34 -08:00
parent 0b3568aaba
commit 9b7b22e0a5
4 changed files with 15 additions and 21 deletions

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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)