github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 18:06:14 +03:00
Code Issues Projects Releases Wiki Activity

let's try to build an MVP without optparse-applicative

Browse Source
This commit is contained in:
Ayman Nadeem 2019-10-01 15:38:57 -04:00
parent 308172d2f1
commit 29d795b0be
1 changed files with 2 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
semantic-ast/src/CLI.hs
View File

@ -40,111 +40,5 @@ instance Exception SignalException
main :: IO ()
main = do
installSignalHandlers
(options, task) <- customExecParser (prefs showHelpOnEmpty) arguments
config <- defaultConfig options
res <- withTelemetry config $ \ (TelemetryQueues logger statter _) ->
Task.runTask (Task.TaskSession config "-" (optionsLogPathsOnError options) logger statter) task
either (die . displayException) pure res
-- | 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.
arguments :: ParserInfo (Options, Task.TaskEff ())
arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsParser)) description
where
version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program")
versionString = "semantic version " <> buildVersion <> " (" <> buildSHA <> ")"
description = fullDesc <> header "semantic -- Semantic (syntax-aware) diffs, program analysis toolkit"
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.")
failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.")
failOnParseError <- switch (long "fail-on-parse-error" <> help "Fail on tree-sitter parse errors.")
logPathsOnError <- switch (long "log-paths" <> help "Log source paths on parse and assignment error.")
pure $ Options logLevel logPathsOnError (Flag.flag FailOnWarning failOnWarning) (Flag.flag FailOnParseError failOnParseError)
parseCommand :: Mod CommandFields (Task.TaskEff Builder)
parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
where
parseArgumentsParser = do
languageModes <- Language.PerLanguageModes
<$> option auto ( long "python-mode"
<> help "The AST representation to use for Python sources"
<> metavar "ALaCarte|Precise"
<> value Language.ALaCarte
<> showDefault)
renderer
<- flag (parseTermBuilder TermSExpression)
(parseTermBuilder TermSExpression)
( long "sexpression"
<> help "Output s-expression parse trees (default)")
<|> flag' (parseTermBuilder TermJSONTree)
( long "json"
<> help "Output JSON parse trees")
<|> flag' (parseTermBuilder TermJSONGraph)
( long "json-graph"
<> help "Output JSON adjacency list")
<|> flag' (parseSymbolsBuilder JSON)
( long "symbols"
<> long "json-symbols"
<> help "Output JSON symbol list")
<|> flag' (parseSymbolsBuilder Proto)
( long "proto-symbols"
<> help "Output protobufs symbol list")
<|> flag' (parseTermBuilder TermDotGraph)
( long "dot"
<> help "Output DOT graph parse trees")
<|> flag' (parseTermBuilder TermShow)
( long "show"
<> help "Output using the Show instance (debug only, format subject to change without notice)")
<|> flag' (parseTermBuilder TermQuiet)
( long "quiet"
<> help "Don't produce output, but show timing stats")
filesOrStdin <- FilesFromGitRepo
<$> option str (long "gitDir" <> help "A .git directory to read from")
<*> option shaReader (long "sha" <> help "The commit SHA1 to read from")
<*> ( ExcludePaths <$> many (option str (long "exclude" <> short 'x' <> help "Paths to exclude"))
<|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin")
<|> IncludePaths <$> many (option str (long "only" <> help "Only include the specified paths"))
<|> IncludePathsFromHandle <$> flag' stdin (long "only-stdin" <> help "Include only the paths given to stdin"))
<|> FilesFromPaths <$> some (argument filePathReader (metavar "FILES..."))
<|> pure (FilesFromHandle stdin)
pure $ Task.readBlobs filesOrStdin >>= runReader languageModes . renderer
tsParseCommand :: Mod CommandFields (Task.TaskEff Builder)
tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Generate raw tree-sitter parse trees 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")
<|> flag' AST.Quiet (long "quiet" <> help "Don't produce output, but show timing stats")
<|> flag' AST.Show (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
filesOrStdin <- FilesFromGitRepo
<$> option str (long "gitDir" <> help "A .git directory to read from")
<*> option shaReader (long "sha" <> help "The commit SHA1 to read from")
<*> ( ExcludePaths <$> many (option str (long "exclude" <> short 'x' <> help "Paths to exclude"))
<|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin")
<|> IncludePaths <$> many (option str (long "only" <> help "Only include the specified paths"))
<|> IncludePathsFromHandle <$> flag' stdin (long "only-stdin" <> help "Include only the paths given to stdin"))
<|> FilesFromPaths <$> some (argument filePathReader (metavar "FILES..."))
<|> pure (FilesFromHandle stdin)
pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format
shaReader :: ReadM Git.OID
shaReader = eitherReader parseSha
where parseSha arg = if length arg == 40 || arg == "HEAD"
then Right (Git.OID (T.pack arg))
else Left (arg <> " is not a valid sha1")
filePathReader :: ReadM File
filePathReader = fileForPath <$> str
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)
findOption options value = maybe "" fst (find ((== value) . snd) options)
args <- getArgs
parseByteString getArgs