Formatting

This commit is contained in:
Nikolay Yakimov 2015-12-06 19:22:21 +03:00
parent c8440a5c4d
commit d255da0c89
3 changed files with 244 additions and 239 deletions

View File

@ -9,21 +9,25 @@ import Language.Haskell.GhcMod.Types
import Control.Arrow import Control.Arrow
import GHCMod.Options.Commands import GHCMod.Options.Commands
import GHCMod.Version import GHCMod.Version
import GHCMod.Options.DocUtils
parseArgs :: IO (Options, GhcModCommands) parseArgs :: IO (Options, GhcModCommands)
parseArgs = parseArgs =
execParser opts execParser opts
where where
opts = info (argAndCmdSpec <**> helpVersion) opts = info (argAndCmdSpec <**> helpVersion)
( fullDesc $$ fullDesc
<> header "ghc-mod: Happy Haskell Programming" ) ## header "ghc-mod: Happy Haskell Programming"
helpVersion :: Parser (a -> a) helpVersion :: Parser (a -> a)
helpVersion = helpVersion =
helper <*> helper
abortOption (InfoMsg ghcModVersion) <*> abortOption (InfoMsg ghcModVersion)
(long "version" <> help "Print the version of the program.") <*> $$ long "version"
argument r (value id <> metavar "") ## help "Print the version of the program."
<*> argument r
$$ value id
## metavar ""
where where
r :: ReadM (a -> a) r :: ReadM (a -> a)
r = do r = do
@ -44,92 +48,81 @@ getLogLevel = toEnum . min 7
logLevelParser :: Parser GmLogLevel logLevelParser :: Parser GmLogLevel
logLevelParser = logLevelParser =
getLogLevel <$> getLogLevel
( <$> silentSwitch
silentSwitch <|> logLevelSwitch <|> logLevelOption <||> logLevelSwitch
) <||> logLevelOption
where where
logLevelOption = logLevelOption =
option int ( option int
long "verbose" <> $$ long "verbose"
metavar "LEVEL" <> ## metavar "LEVEL"
value 4 <> ## value 4
showDefault <> ## showDefault
help "Set log level. (0-7)" ## help "Set log level. (0-7)"
)
logLevelSwitch = logLevelSwitch =
(4+) . length <$> many (flag' () ( (4+) . length <$> many $$ flag' ()
short 'v' <> $$ short 'v'
help "Increase log level" ## help "Increase log level"
)) silentSwitch = flag' 0
silentSwitch = flag' 0 ( $$ long "silent"
long "silent" <> ## short 's'
short 's' <> ## help "Be silent, set log level to 0"
help "Be silent, set log level to 0"
)
outputOptsSpec :: Parser OutputOpts outputOptsSpec :: Parser OutputOpts
outputOptsSpec = OutputOpts <$> outputOptsSpec = OutputOpts
logLevelParser <*> <$> logLevelParser
flag PlainStyle LispStyle ( <*> flag PlainStyle LispStyle
long "tolisp" <> $$ long "tolisp"
short 'l' <> ## short 'l'
help "Format output as an S-Expression" ## help "Format output as an S-Expression"
) <*> <*> LineSeparator <$$> strOption
(LineSeparator <$> strOption ( $$ long "boundary"
long "boundary" <> ## long "line-separator"
long "line-separator" <> ## short 'b'
short 'b' <> ## metavar "SEP"
metavar "SEP" <> ## value "\0"
value "\0" <> ## showDefault
showDefault <> ## help "Output line separator"
help "Output line separator" <*> optional $$ splitOn ',' <$$> strOption
)) <*> $$ long "line-prefix"
optional (splitOn ',' <$> strOption ( ## metavar "OUT,ERR"
long "line-prefix" <> ## help "Output prefixes"
metavar "OUT,ERR" <>
help "Output prefixes"
))
programsArgSpec :: Parser Programs programsArgSpec :: Parser Programs
programsArgSpec = Programs <$> programsArgSpec = Programs
strOption ( <$> strOption
long "with-ghc" <> $$ long "with-ghc"
value "ghc" <> ## value "ghc"
showDefault <> ## showDefault
help "GHC executable to use" ## help "GHC executable to use"
) <*> <*> strOption
strOption ( $$ long "with-ghc-pkg"
long "with-ghc-pkg" <> ## value "ghc-pkg"
value "ghc-pkg" <> ## showDefault
showDefault <> ## help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
help "ghc-pkg executable to use (only needed when guessing from GHC path fails)" <*> strOption
) <*> $$ long "with-cabal"
strOption ( ## value "cabal"
long "with-cabal" <> ## showDefault
value "cabal" <> ## help "cabal-install executable to use"
showDefault <> <*> strOption
help "cabal-install executable to use" $$ long "with-stack"
) <*> ## value "stack"
strOption ( ## showDefault
long "with-stack" <> ## help "stack executable to use"
value "stack" <>
showDefault <>
help "stack executable to use"
)
globalArgSpec :: Parser Options globalArgSpec :: Parser Options
globalArgSpec = Options <$> globalArgSpec = Options
outputOptsSpec <*> -- optOutput <$> outputOptsSpec
programsArgSpec <*> -- optPrograms <*> programsArgSpec
many (strOption ( -- optGhcUserOptions <*> many $$ strOption
long "ghcOpt" <> $$ long "ghcOpt"
long "ghc-option" <> ## long "ghc-option"
short 'g' <> ## short 'g'
metavar "OPT" <> ## metavar "OPT"
help "Option to be passed to GHC" ## help "Option to be passed to GHC"
)) <*> <*> many fileMappingSpec
many fileMappingSpec -- optFileMappings = []
where where
{- {-
File map docs: File map docs:
@ -166,9 +159,8 @@ globalArgSpec = Options <$>
mapped. Works exactly the same as `unmap-file` interactive command mapped. Works exactly the same as `unmap-file` interactive command
-} -}
fileMappingSpec = fileMappingSpec =
getFileMapping . splitOn '=' <$> strOption ( getFileMapping . splitOn '=' <$> strOption
long "map-file" <> $$ long "map-file"
metavar "MAPPING" <> ## metavar "MAPPING"
help "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" ## help "Redirect one file to another, --map-file \"file1.hs=file2.hs\""
)
getFileMapping = second (\i -> if null i then Nothing else Just i) getFileMapping = second (\i -> if null i then Nothing else Just i)

View File

@ -39,127 +39,121 @@ data GhcModCommands =
commandsSpec :: Parser GhcModCommands commandsSpec :: Parser GhcModCommands
commandsSpec = commandsSpec =
hsubparser ( hsubparser
command "lang" ( $ command "lang"
info (pure CmdLang) $$ info (pure CmdLang)
(progDesc "List all known GHC language extensions")) $$ progDesc "List all known GHC language extensions"
<> command "flag" ( <> command "flag"
info (pure CmdFlag) $$ info (pure CmdFlag)
(progDesc "List GHC -f<foo> flags")) $$ progDesc "List GHC -f<foo> flags"
<> command "debug" ( <> command "debug"
info (pure CmdDebug) $$ info (pure CmdDebug)
(progDesc $$ progDesc
"Print debugging information. Please include the output in any bug\ "Print debugging information. Please include the output in any bug\
\ reports you submit")) \ reports you submit"
<> command "debug-component" ( <> command "debug-component"
info debugComponentArgSpec $$ info debugComponentArgSpec
(progDesc "Debugging information related to cabal component resolution")) $$ progDesc "Debugging information related to cabal component resolution"
<> command "boot" ( <> command "boot"
info (pure CmdBoot) $$ info (pure CmdBoot)
(progDesc "Internal command used by the emacs frontend")) $$ progDesc "Internal command used by the emacs frontend"
-- <> command "nuke-caches" ( -- <> command "nuke-caches" (
-- info (pure CmdNukeCaches) idm) -- info (pure CmdNukeCaches) idm)
<> command "root" ( <> command "root"
info (pure CmdRoot) $$ info (pure CmdRoot)
(progDesc $$ progDesc
"Try to find the project directory. For Cabal projects this is the\ "Try to find the project directory. For Cabal projects this is the\
\ directory containing the cabal file, for projects that use a cabal\ \ directory containing the cabal file, for projects that use a cabal\
\ sandbox but have no cabal file this is the directory containing the\ \ sandbox but have no cabal file this is the directory containing the\
\ cabal.sandbox.config file and otherwise this is the current\ \ cabal.sandbox.config file and otherwise this is the current\
\ directory" \ directory"
)) <> command "legacy-interactive"
<> command "legacy-interactive" ( $$ info (pure CmdLegacyInteractive)
info (pure CmdLegacyInteractive) $$ progDesc "ghc-modi compatibility mode"
(progDesc "ghc-modi compatibility mode")) <> command "list"
<> command "list" ( $$ info modulesArgSpec
info modulesArgSpec $$ progDesc "List all visible modules"
(progDesc "List all visible modules")) <> command "modules"
<> command "modules" ( $$ info modulesArgSpec
info modulesArgSpec $$ progDesc "List all visible modules"
(progDesc "List all visible modules")) <> command "dumpsym"
<> command "dumpsym" ( $$ info dumpSymArgSpec idm
info dumpSymArgSpec idm) <> command "find"
<> command "find" ( $$ info findArgSpec
info findArgSpec $$ progDesc "List all modules that define SYMBOL"
(progDesc "List all modules that define SYMBOL")) <> command "doc"
<> command "doc" ( $$ info docArgSpec
info docArgSpec $$ progDesc "Try finding the html documentation directory for the given MODULE"
(progDesc "Try finding the html documentation directory for the given MODULE")) <> command "lint"
<> command "lint" ( $$ info lintArgSpec
info lintArgSpec $$ progDesc "Check files using `hlint'"
(progDesc "Check files using `hlint'")) <> command "browse"
<> command "browse" ( $$ info browseArgSpec
info browseArgSpec $$ progDesc "List symbols in a module"
(progDesc "List symbols in a module")) <> command "check"
<> command "check" ( $$ info checkArgSpec
info checkArgSpec $$ progDesc "Load the given files using GHC and report errors/warnings,\
(progDesc "Load the given files using GHC and report errors/warnings,\ \ but don't produce output files"
\ but don't produce output files")) <> command "expand"
<> command "expand" ( $$ info expandArgSpec
info expandArgSpec $$ progDesc "Like `check' but also pass `-ddump-splices' to GHC"
(progDesc "Like `check' but also pass `-ddump-splices' to GHC")) <> command "info"
<> command "info" ( $$ info infoArgSpec
info infoArgSpec $$ progDesc
(progDesc
"Look up an identifier in the context of FILE (like ghci's `:info')\ "Look up an identifier in the context of FILE (like ghci's `:info')\
\ MODULE is completely ignored and only allowed for backwards\ \ MODULE is completely ignored and only allowed for backwards\
\ compatibility")) \ compatibility"
<> command "type" ( <> command "type"
info typeArgSpec $$ info typeArgSpec
(progDesc "Get the type of the expression under (LINE,COL)")) $$ progDesc "Get the type of the expression under (LINE,COL)"
<> command "split" ( <> command "split"
info splitArgSpec $$ info splitArgSpec
(progDesc $$ progDesc
"Split a function case by examining a type's constructors" "Split a function case by examining a type's constructors"
<> desc [ ## desc [
text "For example given the following code snippet:" text "For example given the following code snippet:"
, code [ , code [
"f :: [a] -> a" "f :: [a] -> a"
, "f x = _body" , "f x = _body"
] ]
, text "would be replaced by:" , text "would be replaced by:"
, code [ , code [
"f :: [a] -> a" "f :: [a] -> a"
, "f [] = _body" , "f [] = _body"
, "f (x:xs) = _body" , "f (x:xs) = _body"
] ]
, text "(See https://github.com/kazu-yamamoto/ghc-mod/pull/274)" , text "(See https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
])) ]
<> command "sig" ( <> command "sig"
info sigArgSpec $$ info sigArgSpec
(progDesc $$ progDesc "Generate initial code given a signature"
"Generate initial code given a signature" ## desc [
<> desc [ text "For example when (LINE,COL) is on the signature in the following\
text "For example when (LINE,COL) is on the signature in the following\ \ code snippet:"
\ code snippet:" , code ["func :: [a] -> Maybe b -> (a -> b) -> (a,b)"]
, code ["func :: [a] -> Maybe b -> (a -> b) -> (a,b)"] , text "ghc-mod would add the following on the next line:"
, text "ghc-mod would add the following on the next line:" , code ["func x y z f = _func_body"]
, code ["func x y z f = _func_body"] , text "(See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
, text "(See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)" ]
] <> command "auto"
)) $$ info autoArgSpec
<> command "auto" ( $$ progDesc "Try to automatically fill the contents of a hole"
info autoArgSpec <> command "refine"
(progDesc "Try to automatically fill the contents of a hole")) $$ info refineArgSpec
<> command "refine" ( $$ progDesc "Refine the typed hole at (LINE,COL) given EXPR"
info refineArgSpec ## desc [
(progDesc text "For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\
"Refine the typed hole at (LINE,COL) given EXPR" \ -> [a]' and (LINE,COL) is on the hole `_body' in the following\
<> desc [ \ code snippet:"
text "For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\ , code [
\ -> [a]' and (LINE,COL) is on the hole `_body' in the following\ "filterNothing :: [Maybe a] -> [a]"
\ code snippet:" , "filterNothing xs = _body"
, code [ ]
"filterNothing :: [Maybe a] -> [a]" , text "ghc-mod changes the code to get a value of type `[a]', which\
, "filterNothing xs = _body" \ results in:"
] , code [ "filterNothing xs = filter _body_1 _body_2" ]
, text "ghc-mod changes the code to get a value of type `[a]', which\ , text "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)"
\ results in:" ]
, code [ "filterNothing xs = filter _body_1 _body_2" ]
, text "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)"
]
))
)
strArg :: String -> Parser String strArg :: String -> Parser String
strArg = argument str . metavar strArg = argument str . metavar
@ -168,56 +162,54 @@ filesArgsSpec :: ([String] -> b) -> Parser b
filesArgsSpec x = x <$> some (strArg "FILES..") filesArgsSpec x = x <$> some (strArg "FILES..")
locArgSpec :: (String -> (Int, Int) -> b) -> Parser b locArgSpec :: (String -> (Int, Int) -> b) -> Parser b
locArgSpec x = x <$> locArgSpec x = x
strArg "FILE" <*> <$> strArg "FILE"
( (,) <$> <*> ( (,)
argument int (metavar "LINE") <*> <$> argument int (metavar "LINE")
argument int (metavar "COL") <*> argument int (metavar "COL")
) )
modulesArgSpec, dumpSymArgSpec, docArgSpec, findArgSpec, modulesArgSpec, dumpSymArgSpec, docArgSpec, findArgSpec,
lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec, lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec,
infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec, infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec,
sigArgSpec, refineArgSpec, debugComponentArgSpec :: Parser GhcModCommands sigArgSpec, refineArgSpec, debugComponentArgSpec :: Parser GhcModCommands
modulesArgSpec = CmdModules <$> modulesArgSpec = CmdModules
switch ( <$> switch
long "detailed" <> $$ long "detailed"
short 'd' <> ## short 'd'
help "Print package modules belong to" ## help "Print package modules belong to"
)
dumpSymArgSpec = CmdDumpSym <$> strArg "TMPDIR" dumpSymArgSpec = CmdDumpSym <$> strArg "TMPDIR"
findArgSpec = CmdFind <$> strArg "SYMBOL" findArgSpec = CmdFind <$> strArg "SYMBOL"
docArgSpec = CmdDoc <$> strArg "MODULE" docArgSpec = CmdDoc <$> strArg "MODULE"
lintArgSpec = CmdLint <$> lintArgSpec = CmdLint
(LintOpts <$> many (strOption ( <$> LintOpts <$$> many $$ strOption
long "hlintOpt" <> $$ long "hlintOpt"
short 'h' <> ## short 'h'
help "Option to be passed to hlint" ## help "Option to be passed to hlint"
))) <*> strArg "FILE" <*> strArg "FILE"
browseArgSpec = CmdBrowse <$> browseArgSpec = CmdBrowse
(BrowseOpts <$> <$> (BrowseOpts
switch ( <$> switch
long "operators" <> $$ long "operators"
short 'o' <> ## short 'o'
help "Also print operators" ## help "Also print operators"
) <*> -- optOperators = False <*> switch
switch ( $$ long "detailed"
long "detailed" <> ## short 'd'
short 'd' <> ## help "Print symbols with accompanying signature"
help "Print symbols with accompanying signature" <*> switch
) <*> -- optDetailed = False $$ long "qualified"
switch ( ## short 'q'
long "qualified" <> ## help "Qualify symbols"
short 'q' <> )
help "Qualify symbols" <*> some (strArg "MODULE")
)) <*> some (strArg "MODULE")
debugComponentArgSpec = filesArgsSpec CmdDebugComponent debugComponentArgSpec = filesArgsSpec CmdDebugComponent
checkArgSpec = filesArgsSpec CmdCheck checkArgSpec = filesArgsSpec CmdCheck
expandArgSpec = filesArgsSpec CmdExpand expandArgSpec = filesArgsSpec CmdExpand
infoArgSpec = CmdInfo <$> infoArgSpec = CmdInfo
strArg "FILE" <*> <$> strArg "FILE"
strArg "SYMBOL" <*> strArg "SYMBOL"
typeArgSpec = locArgSpec CmdType typeArgSpec = locArgSpec CmdType
autoArgSpec = locArgSpec CmdAuto autoArgSpec = locArgSpec CmdAuto
splitArgSpec = locArgSpec CmdSplit splitArgSpec = locArgSpec CmdSplit

View File

@ -1,14 +1,35 @@
module GHCMod.Options.DocUtils ( module GHCMod.Options.DocUtils (
module PP, module PP,
desc, desc,
code code,
($$),
(##),
(<$$>),
(<||>)
) where ) where
import Options.Applicative import Options.Applicative
import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<>), (<$>), int) import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<>), (<$>), (<$$>), int)
desc :: [Doc] -> InfoMod a desc :: [Doc] -> InfoMod a
desc = footerDoc . Just . indent 2 . vsep desc = footerDoc . Just . indent 2 . vsep
code :: [String] -> Doc code :: [String] -> Doc
code x = vsep [line, indent 4 $ vsep $ map text x, line] code x = vsep [line, indent 4 $ vsep $ map text x, line]
infixl 7 <||>
infixr 8 <$$>
infixr 8 $$
infixr 9 ##
($$) :: (a -> b) -> a -> b
($$) = ($)
(<||>) :: Alternative a => a b -> a b -> a b
(<||>) = (<|>)
(##) :: Monoid m => m -> m -> m
(##) = (<>)
(<$$>) :: Functor f => (a -> b) -> f a -> f b
(<$$>) = (<$>)