diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 767889606..91f682a83 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -6,8 +6,9 @@ module Semantic.CLI , Parse.runParse ) where +import Control.Monad.IO.Class import Data.Language (ensureLanguage) -import Data.List (intercalate) +import Data.List (intercalate, uncons) import Data.List.Split (splitWhen) import Data.Project import Options.Applicative hiding (style) @@ -22,6 +23,7 @@ import qualified Semantic.Parse as Parse import qualified Semantic.Task as Task import qualified Semantic.Telemetry.Log as Log import Semantic.Version +import System.FilePath import Serializing.Format hiding (Options) import Text.Read @@ -38,19 +40,23 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar versionString = "semantic version " <> buildVersion <> " (" <> buildSHA <> ")" description = fullDesc <> header "semantic -- Parse and diff semantically" - optionsParser = do - logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)] - (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") - requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id") - failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.") - pure $ Options logLevel requestId failOnWarning +optionsParser :: Parser Options +optionsParser = do + logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)] + (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") + requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id") + failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.") + pure $ Options logLevel requestId failOnWarning - argumentsParser = do - subparser <- hsubparser (diffCommand <> parseCommand <> tsParseCommand <> graphCommand) - output <- ToPath <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout) - pure $ subparser >>= Task.write output +argumentsParser :: Parser (Task.TaskEff ()) +argumentsParser = do + subparser <- hsubparser (diffCommand <> parseCommand <> tsParseCommand <> graphCommand) + output <- ToPath <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout) + pure $ subparser >>= Task.write output - diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths")) +diffCommand :: Mod CommandFields (Task.TaskEff Builder) +diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths")) + where diffArgumentsParser = do renderer <- flag (Diff.runDiff SExpressionDiffRenderer) (Diff.runDiff SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)") <|> flag' (Diff.runDiff JSONDiffRenderer) (long "json" <> help "Output JSON diff trees") @@ -60,7 +66,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar filesOrStdin <- Right <$> some (both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin) pure $ Task.readBlobPairs filesOrStdin >>= renderer - parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)")) +parseCommand :: Mod CommandFields (Task.TaskEff Builder) +parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)")) + where parseArgumentsParser = do renderer <- flag (Parse.runParse SExpressionTermRenderer) (Parse.runParse SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)") <|> flag' (Parse.runParse JSONTermRenderer) (long "json" <> help "Output JSON parse trees") @@ -74,7 +82,12 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) pure $ Task.readBlobs filesOrStdin >>= renderer - tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)")) + -- Example: semantic parse --symbols --fields=symbol,path,language,kind,line,span + symbolFieldsReader = eitherReader (Right . parseSymbolFields) + +tsParseCommand :: Mod CommandFields (Task.TaskEff Builder) +tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)")) + where tsParseArgumentsParser = do format <- flag AST.SExpression AST.SExpression (long "sexpression" <> help "Output s-expression ASTs (default)") <|> flag' AST.JSON (long "json" <> help "Output JSON ASTs") @@ -82,32 +95,45 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format - graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module")) - graphArgumentsParser = do - graphType <- flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)") - <|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph") - let style = Graph.style - includePackages <- switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module") - serializer <- flag (Task.serialize (DOT style)) (Task.serialize (DOT style)) (long "dot" <> help "Output in DOT graph format (default)") - <|> flag' (Task.serialize JSON) (long "json" <> help "Output JSON graph") - <|> flag' (Task.serialize Show) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)") - rootDir <- rootDirectoryOption - excludeDirs <- excludeDirsOption - File{..} <- argument filePathReader (metavar "DIR:LANGUAGE | FILE") - pure $ Task.readProject rootDir filePath fileLanguage excludeDirs >>= Graph.runGraph graphType includePackages >>= serializer +graphCommand :: Mod CommandFields (Task.TaskEff Builder) +graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module")) + where + graphArgumentsParser = makeGraphTask + <$> graphType + <*> switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module") + <*> serializer + <*> (readProjectFromPaths <|> readProjectRecursively) + graphType = flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)") + <|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph") + serializer = flag (Task.serialize (DOT Graph.style)) (Task.serialize (DOT Graph.style)) (long "dot" <> help "Output in DOT graph format (default)") + <|> flag' (Task.serialize JSON) (long "json" <> help "Output JSON graph") + <|> flag' (Task.serialize Show) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)") + readProjectFromPaths = makeReadProjectFromPathsTask + <$> option auto (long "language" <> help "The language for the analysis.") + <*> ( Just <$> some (strArgument (metavar "FILES...")) + <|> 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) + 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")) + <*> many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) + <*> argument filePathReader (metavar "DIR:LANGUAGE | FILE") + makeReadProjectRecursivelyTask rootDir excludeDirs File{..} = Task.readProject rootDir filePath fileLanguage excludeDirs + makeGraphTask graphType includePackages serializer projectTask = projectTask >>= Graph.runGraph graphType includePackages >>= serializer - rootDirectoryOption = optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) - excludeDirsOption = many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) - filePathReader = eitherReader parseFilePath +filePathReader :: ReadM File +filePathReader = eitherReader parseFilePath + where parseFilePath arg = case splitWhen (== ':') arg of - [a, b] | (Just lang) <- readMaybe b >>= ensureLanguage -> Right (File a lang) - | (Just lang) <- readMaybe a >>= ensureLanguage -> Right (File b lang) + [a, b] | Just lang <- readMaybe b >>= ensureLanguage -> Right (File a lang) + | Just lang <- readMaybe a >>= ensureLanguage -> Right (File b lang) [path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path) (ensureLanguage (languageForFilePath path)) args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE") +options :: Eq a => [(String, a)] -> Mod OptionFields a -> Parser a +options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options))) + where optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options) - options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options))) findOption options value = maybe "" fst (find ((== value) . snd) options) - - -- Example: semantic parse --symbols --fields=symbol,path,language,kind,line,span - symbolFieldsReader = eitherReader (Right . parseSymbolFields)