Optparse-applicative

This commit is contained in:
Nikolay Yakimov 2015-12-05 23:55:12 +03:00
parent bff86be69f
commit ad16b739eb
11 changed files with 534 additions and 505 deletions

View File

@ -12,7 +12,7 @@ import Language.Haskell.GhcMod.Modules
boot :: IOish m => GhcModT m String boot :: IOish m => GhcModT m String
boot = concat <$> sequence ms boot = concat <$> sequence ms
where where
ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules] ms = [modules False, languages, flags, concat <$> mapM (browse (BrowseOpts False False False)) preBrowsedModules]
preBrowsedModules :: [String] preBrowsedModules :: [String]
preBrowsedModules = [ preBrowsedModules = [

View File

@ -1,5 +1,6 @@
module Language.Haskell.GhcMod.Browse ( module Language.Haskell.GhcMod.Browse (
browse browse,
BrowseOpts(..)
) where ) where
import Control.Applicative import Control.Applicative
@ -14,7 +15,6 @@ import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified) import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
import Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logging
import Name (getOccString) import Name (getOccString)
import Outputable import Outputable
@ -25,13 +25,20 @@ import Prelude
---------------------------------------------------------------- ----------------------------------------------------------------
data BrowseOpts = BrowseOpts {
optBrowseOperators :: Bool
, optBrowseDetailed :: Bool
, optBrowseQualified :: Bool
}
-- | Getting functions, classes, etc from a module. -- | Getting functions, classes, etc from a module.
-- If 'detailed' is 'True', their types are also obtained. -- If 'detailed' is 'True', their types are also obtained.
-- If 'operators' is 'True', operators are also returned. -- If 'operators' is 'True', operators are also returned.
browse :: forall m. IOish m browse :: forall m. IOish m
=> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude") => BrowseOpts
-> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")
-> GhcModT m String -> GhcModT m String
browse pkgmdl = do browse opts pkgmdl = do
convert' . sort =<< go convert' . sort =<< go
where where
-- TODO: Add API to Gm.Target to check if module is home module without -- TODO: Add API to Gm.Target to check if module is home module without
@ -43,13 +50,11 @@ browse pkgmdl = do
gmLog GmException "browse" $ showDoc ex gmLog GmException "browse" $ showDoc ex
goPkgModule = do goPkgModule = do
opt <- options
runGmPkgGhc $ runGmPkgGhc $
processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid
goHomeModule = runGmlT [Right mdlname] $ do goHomeModule = runGmlT [Right mdlname] $ do
opt <- options processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing
processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing
tryModuleInfo m = fromJust <$> G.getModuleInfo m tryModuleInfo m = fromJust <$> G.getModuleInfo m
@ -80,31 +85,31 @@ isNotOp (h:_) = isAlpha h || (h == '_')
isNotOp _ = error "isNotOp" isNotOp _ = error "isNotOp"
processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m) processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
=> Options -> ModuleInfo -> m [String] => BrowseOpts -> ModuleInfo -> m [String]
processExports opt minfo = do processExports opt minfo = do
let let
removeOps removeOps
| optOperators opt = id | optBrowseOperators opt = id
| otherwise = filter (isNotOp . getOccString) | otherwise = filter (isNotOp . getOccString)
mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m) showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m)
=> Options -> ModuleInfo -> Name -> m String => BrowseOpts -> ModuleInfo -> Name -> m String
showExport opt minfo e = do showExport opt minfo e = do
mtype' <- mtype mtype' <- mtype
return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
where where
mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optQualified opt mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt
mtype :: m (Maybe String) mtype :: m (Maybe String)
mtype mtype
| optDetailed opt = do | optBrowseDetailed opt = do
tyInfo <- G.modInfoLookupName minfo e tyInfo <- G.modInfoLookupName minfo e
-- If nothing found, load dependent module and lookup global -- If nothing found, load dependent module and lookup global
tyResult <- maybe (inOtherModule e) (return . Just) tyInfo tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
return $ do return $ do
typeName <- tyResult >>= showThing dflag typeName <- tyResult >>= showThing dflag
(" :: " ++ typeName) `justIf` optDetailed opt (" :: " ++ typeName) `justIf` optBrowseDetailed opt
| otherwise = return Nothing | otherwise = return Nothing
formatOp nm formatOp nm
| null nm = error "formatOp" | null nm = error "formatOp"

View File

@ -5,22 +5,23 @@ import Control.Exception (SomeException(..))
import Language.Haskell.GhcMod.Logger (checkErrorPrefix) import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
import Language.Haskell.HLint (hlint) import Language.Haskell.HLint (hlint)
import Language.Haskell.GhcMod.Utils (withMappedFile) import Language.Haskell.GhcMod.Utils (withMappedFile)
import Data.List (stripPrefix) import Data.List (stripPrefix)
data LintOpts = LintOpts { optLintHlintOpts :: [String] }
-- | Checking syntax of a target file using hlint. -- | Checking syntax of a target file using hlint.
-- Warnings and errors are returned. -- Warnings and errors are returned.
lint :: IOish m lint :: IOish m
=> FilePath -- ^ A target file. => LintOpts
-> FilePath -- ^ A target file.
-> GhcModT m String -> GhcModT m String
lint file = do lint opt file =
opt <- options
withMappedFile file $ \tempfile -> withMappedFile file $ \tempfile ->
liftIO (hlint $ tempfile : "--quiet" : optHlintOpts opt) liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt)
>>= mapM (replaceFileName tempfile) >>= mapM (replaceFileName tempfile)
>>= ghandle handler . pack >>= ghandle handler . pack
where where

View File

@ -14,13 +14,12 @@ import qualified GHC as G
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Listing installed modules. -- | Listing installed modules.
modules :: (IOish m, Gm m) => m String modules :: (IOish m, Gm m) => Bool -> m String
modules = do modules detailed = do
Options { optDetailed } <- options
df <- runGmPkgGhc G.getSessionDynFlags df <- runGmPkgGhc G.getSessionDynFlags
let mns = listVisibleModuleNames df let mns = listVisibleModuleNames df
pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns) pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns)
convert' $ nub [ if optDetailed then pkg ++ " " ++ mn else mn convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn
| (mn, pkgs) <- pmnss, pkg <- pkgs ] | (mn, pkgs) <- pmnss, pkg <- pkgs ]
where where
modulePkg df = lookupModulePackageInAllPackages df modulePkg df = lookupModulePackageInAllPackages df

View File

@ -102,13 +102,6 @@ data Options = Options {
, optPrograms :: Programs , optPrograms :: Programs
-- | GHC command line options set on the @ghc-mod@ command line -- | GHC command line options set on the @ghc-mod@ command line
, optGhcUserOptions :: [GHCOption] , optGhcUserOptions :: [GHCOption]
-- | If 'True', 'browse' also returns operators.
, optOperators :: Bool
-- | If 'True', 'browse' also returns types.
, optDetailed :: Bool
-- | If 'True', 'browse' will return fully qualified name
, optQualified :: Bool
, optHlintOpts :: [String]
, optFileMappings :: [(FilePath, Maybe FilePath)] , optFileMappings :: [(FilePath, Maybe FilePath)]
} deriving (Show) } deriving (Show)
@ -128,10 +121,6 @@ defaultOptions = Options {
, stackProgram = "stack" , stackProgram = "stack"
} }
, optGhcUserOptions = [] , optGhcUserOptions = []
, optOperators = False
, optDetailed = False
, optQualified = False
, optHlintOpts = []
, optFileMappings = [] , optFileMappings = []
} }

View File

@ -188,6 +188,10 @@ Executable ghc-mod
Default-Language: Haskell2010 Default-Language: Haskell2010
Main-Is: GHCMod.hs Main-Is: GHCMod.hs
Other-Modules: Paths_ghc_mod Other-Modules: Paths_ghc_mod
, GHCMod.Options
, GHCMod.Options.Commands
, GHCMod.Version
, GHCMod.Options.DocUtils
GHC-Options: -Wall -fno-warn-deprecations -threaded GHC-Options: -Wall -fno-warn-deprecations -threaded
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src HS-Source-Dirs: src
@ -201,6 +205,8 @@ Executable ghc-mod
, mtl < 2.3 && >= 2.0 , mtl < 2.3 && >= 2.0
, ghc < 7.11 , ghc < 7.11
, fclabels ==2.0.* , fclabels ==2.0.*
, optparse-applicative ==0.11.*
, ansi-wl-pprint ==0.6.*
, ghc-mod , ghc-mod
Executable ghc-modi Executable ghc-modi

View File

@ -2,14 +2,10 @@
module Main where module Main where
import Config (cProjectVersion)
import Control.Category import Control.Category
import Control.Applicative import Control.Applicative
import Control.Arrow
import Control.Monad import Control.Monad
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.Version (showVersion)
import Data.Label
import Data.List import Data.List
import Data.List.Split import Data.List.Split
import Data.Char (isSpace) import Data.Char (isSpace)
@ -19,261 +15,23 @@ import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Paths_ghc_mod
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O
import System.FilePath ((</>)) import System.FilePath ((</>))
import System.Directory (setCurrentDirectory, getAppUserDataDirectory, import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
removeDirectoryRecursive) removeDirectoryRecursive)
import System.Environment (getArgs) -- import System.Environment (getArgs)
import System.IO import System.IO
import System.Exit import System.Exit
import Text.PrettyPrint import Text.PrettyPrint hiding ((<>))
import Prelude hiding ((.)) import Prelude hiding ((.))
import GHCMod.Options
import Misc import Misc
progVersion :: String -> String
progVersion pf =
"ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "
++ cProjectVersion ++ "\n"
ghcModVersion :: String
ghcModVersion = progVersion ""
ghcModiVersion :: String
ghcModiVersion = progVersion "i"
optionUsage :: (String -> String) -> [OptDescr a] -> [String]
optionUsage indent opts = concatMap optUsage opts
where
optUsage (Option so lo dsc udsc) =
[ intercalate ", " $ addLabel `map` allFlags
, indent $ udsc
, ""
]
where
allFlags = shortFlags ++ longFlags
shortFlags = (('-':) . return) `map` so :: [String]
longFlags = ("--"++) `map` lo
addLabel f@('-':'-':_) = f ++ flagLabel "="
addLabel f@('-':_) = f ++ flagLabel " "
addLabel _ = undefined
flagLabel s =
case dsc of
NoArg _ -> ""
ReqArg _ label -> s ++ label
OptArg _ label -> s ++ "["++label++"]"
-- TODO: Generate the stuff below automatically
usage :: String
usage =
"Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\
\*Global Options (OPTIONS)*\n\
\ Global options can be specified before and after the command and\n\
\ interspersed with command specific options\n\
\\n"
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
"*Commands*\n\
\ - version\n\
\ Print the version of the program.\n\
\\n\
\ - help\n\
\ Print this help message.\n\
\\n\
\ - list [FLAGS...] | modules [FLAGS...]\n\
\ List all visible modules.\n\
\ Flags:\n\
\ -d\n\
\ Print package modules belong to.\n\
\\n\
\ - lang\n\
\ List all known GHC language extensions.\n\
\\n\
\ - flag\n\
\ List GHC -f<bla> flags.\n\
\\n\
\ - browse [FLAGS...] [PACKAGE:]MODULE...\n\
\ List symbols in a module.\n\
\ Flags:\n\
\ -o\n\
\ Also print operators.\n\
\ -d\n\
\ Print symbols with accompanying signatures.\n\
\ -q\n\
\ Qualify symbols.\n\
\\n\
\ - check FILE...\n\
\ Load the given files using GHC and report errors/warnings, but\n\
\ don't produce output files.\n\
\\n\
\ - expand FILE...\n\
\ Like `check' but also pass `-ddump-splices' to GHC.\n\
\\n\
\ - info FILE [MODULE] EXPR\n\
\ Look up an identifier in the context of FILE (like ghci's `:info')\n\
\ MODULE is completely ignored and only allowed for backwards\n\
\ compatibility.\n\
\\n\
\ - type FILE [MODULE] LINE COL\n\
\ Get the type of the expression under (LINE,COL).\n\
\\n\
\ - split FILE [MODULE] LINE COL\n\
\ Split a function case by examining a type's constructors.\n\
\\n\
\ For example given the following code snippet:\n\
\\n\
\ f :: [a] -> a\n\
\ f x = _body\n\
\\n\
\ would be replaced by:\n\
\\n\
\ f :: [a] -> a\n\
\ f [] = _body\n\
\ f (x:xs) = _body\n\
\\n\
\ (See https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\
\\n\
\ - sig FILE MODULE LINE COL\n\
\ Generate initial code given a signature.\n\
\\n\
\ For example when (LINE,COL) is on the signature in the following\n\
\ code snippet:\n\
\\n\
\ func :: [a] -> Maybe b -> (a -> b) -> (a,b)\n\
\\n\
\ ghc-mod would add the following on the next line:\n\
\\n\
\ func x y z f = _func_body\n\
\\n\
\ (See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\
\\n\
\ - refine FILE MODULE LINE COL EXPR\n\
\ Refine the typed hole at (LINE,COL) given EXPR.\n\
\\n\
\ For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\n\
\ -> [a]' and (LINE,COL) is on the hole `_body' in the following\n\
\ code snippet:\n\
\\n\
\ filterNothing :: [Maybe a] -> [a]\n\
\ filterNothing xs = _body\n\
\\n\
\ ghc-mod changes the code to get a value of type `[a]', which\n\
\ results in:\n\
\\n\
\ filterNothing xs = filter _body_1 _body_2\n\
\\n\
\ (See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)\n\
\\n\
\ - auto FILE MODULE LINE COL\n\
\ Try to automatically fill the contents of a hole.\n\
\\n\
\ - find SYMBOL\n\
\ List all modules that define SYMBOL.\n\
\\n\
\ - lint FILE\n\
\ Check files using `hlint'.\n\
\ Flags:\n\
\ -h\n\
\ Option to be passed to hlint.\n\
\\n\
\ - root\n\
\ Try to find the project directory. For Cabal projects this is the\n\
\ directory containing the cabal file, for projects that use a cabal\n\
\ sandbox but have no cabal file this is the directory containing the\n\
\ cabal.sandbox.config file and otherwise this is the current\n\
\ directory.\n\
\\n\
\ - doc MODULE\n\
\ Try finding the html documentation directory for the given MODULE.\n\
\\n\
\ - debug\n\
\ Print debugging information. Please include the output in any bug\n\
\ reports you submit.\n\
\\n\
\ - debugComponent [MODULE_OR_FILE...]\n\
\ Debugging information related to cabal component resolution.\n\
\\n\
\ - boot\n\
\ Internal command used by the emacs frontend.\n\
\\n\
\ - legacy-interactive\n\
\ ghc-modi compatibility mode.\n"
where
indent = (" "++)
cmdUsage :: String -> String -> String
cmdUsage cmd realUsage =
let
-- Find command head
a = dropWhile (not . isCmdHead) $ lines realUsage
-- Take til the end of the current command block
b = flip takeWhile a $ \l ->
all isSpace l || (isIndented l && (isCmdHead l || isNotCmdHead l))
-- Drop extra newline from the end
c = dropWhileEnd (all isSpace) b
isIndented = (" " `isPrefixOf`)
isNotCmdHead = ( not . (" - " `isPrefixOf`))
containsAnyCmdHead s = ((" - ") `isInfixOf` s)
containsCurrCmdHead s = ((" - " ++ cmd) `isInfixOf` s)
isCmdHead s =
containsAnyCmdHead s &&
or [ containsCurrCmdHead s
, any (cmd `isPrefixOf`) (splitOn " | " s)
]
unindent (' ':' ':' ':' ':l) = l
unindent l = l
in unlines $ unindent <$> c
ghcModStyle :: Style ghcModStyle :: Style
ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 } ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
---------------------------------------------------------------- ----------------------------------------------------------------
option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
option s l udsc dsc = Option s l dsc udsc
reqArg :: String -> (String -> a) -> ArgDescr a
reqArg udsc dsc = ReqArg dsc udsc
optArg :: String -> (Maybe String -> a) -> ArgDescr a
optArg udsc dsc = OptArg dsc udsc
intToLogLevel :: Int -> GmLogLevel
intToLogLevel = toEnum
globalArgSpec :: [OptDescr (Options -> Either [String] Options)]
globalArgSpec =
[ option "v" ["verbose"] "Increase or set log level. (0-7)" $
optArg "LEVEL" $ \ml o -> Right $ case ml of
Nothing ->
modify (lOoptLogLevel . lOptOutput) increaseLogLevel o
Just l ->
set (lOoptLogLevel . lOptOutput) (toEnum $ min 7 $ read l) o
, option "s" [] "Be silent, set log level to 0" $
NoArg $ \o -> Right $ set (lOoptLogLevel . lOptOutput) (toEnum 0) o
, option "l" ["tolisp"] "Format output as an S-Expression" $
NoArg $ \o -> Right $ set (lOoptStyle . lOptOutput) LispStyle o
, option "b" ["boundary", "line-seperator"] "Output line separator"$
reqArg "SEP" $ \s o -> Right $ set (lOoptLineSeparator . lOptOutput) (LineSeparator s) o
, option "" ["line-prefix"] "Output line separator"$
reqArg "OUT,ERR" $ \s o -> let
[out, err] = splitOn "," s
in Right $ set (lOoptLinePrefix . lOptOutput) (Just (out, err)) o
, option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
reqArg "OPT" $ \g o -> Right $
o { optGhcUserOptions = g : optGhcUserOptions o }
{- {-
File map docs: File map docs:
@ -308,59 +66,6 @@ Exposed functions:
first argument, and removes any temporary files created when file was first argument, and removes any temporary files created when file was
mapped. Works exactly the same as `unmap-file` interactive command mapped. Works exactly the same as `unmap-file` interactive command
-} -}
, option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $
reqArg "OPT" $ \g o ->
let m = case second (drop 1) $ span (/='=') g of
(s,"") -> (s, Nothing)
(f,t) -> (f, Just t)
in
Right $ o { optFileMappings = m : optFileMappings o }
, option "" ["with-ghc"] "GHC executable to use" $
reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lOptPrograms) p o
, option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $
reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lOptPrograms) p o
, option "" ["with-cabal"] "cabal-install executable to use" $
reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lOptPrograms) p o
, option "" ["with-stack"] "stack executable to use" $
reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lOptPrograms) p o
, option "" ["version"] "print version information" $
NoArg $ \_ -> Left ["version"]
, option "" ["help"] "print this help message" $
NoArg $ \_ -> Left ["help"]
]
parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
parseGlobalArgs argv
= case O.getOpt' RequireOrder globalArgSpec argv of
(o,r,u,[]) -> case foldr (=<<) (Right defaultOptions) o of
Right o' -> Right (o', u ++ r)
Left c -> Right (defaultOptions, c)
(_,_,u,e) -> Left $ InvalidCommandLine $ Right $
"Parsing command line options failed: "
++ concat (e ++ map errUnrec u)
where
errUnrec :: String -> String
errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
parseCommandArgs :: [OptDescr (Options -> Either [String] Options)]
-> [String]
-> Options
-> (Options, [String])
parseCommandArgs spec argv opts
= case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of
(o,r,[]) -> case foldr (=<<) (Right opts) o of
Right o' -> (o', r)
Left c -> (defaultOptions, c)
(_,_,errs) ->
fatalError $ "Parsing command options failed: " ++ concat errs
---------------------------------------------------------------- ----------------------------------------------------------------
@ -381,38 +86,21 @@ handler = flip gcatches $
[ GHandler $ \(FatalError msg) -> exitError msg [ GHandler $ \(FatalError msg) -> exitError msg
, GHandler $ \e@(ExitSuccess) -> throw e , GHandler $ \e@(ExitSuccess) -> throw e
, GHandler $ \e@(ExitFailure _) -> throw e , GHandler $ \e@(ExitFailure _) -> throw e
, GHandler $ \(InvalidCommandLine e) -> do
case e of
Left cmd ->
exitError $ "Usage for `"++cmd++"' command:\n\n"
++ (cmdUsage cmd usage) ++ "\n"
++ "ghc-mod: Invalid command line form."
Right msg -> exitError $ "ghc-mod: " ++ msg
, GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e
] ]
main :: IO () main :: IO ()
main = do main = do
hSetEncoding stdout utf8 hSetEncoding stdout utf8
args <- getArgs parseArgs >>= \res@(globalOptions, _) ->
case parseGlobalArgs args of catches (progMain res) [
Left e -> throw e
Right res@(globalOptions,_) -> catches (progMain res) [
Handler $ \(e :: GhcModError) -> Handler $ \(e :: GhcModError) ->
runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e) runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
] ]
progMain :: (Options,[String]) -> IO () progMain :: (Options, GhcModCommands) -> IO ()
progMain (globalOptions,cmdArgs) = runGmOutT globalOptions $ progMain (globalOptions, commands) = runGmOutT globalOptions $
case globalCommands cmdArgs of wrapGhcCommands globalOptions commands
Just s -> gmPutStr s
Nothing -> wrapGhcCommands globalOptions cmdArgs
globalCommands :: [String] -> Maybe String
globalCommands (cmd:_)
| cmd == "help" = Just usage
| cmd == "version" = Just ghcModVersion
globalCommands _ = Nothing
-- ghc-modi -- ghc-modi
legacyInteractive :: IOish m => GhcModT m () legacyInteractive :: IOish m => GhcModT m ()
@ -464,22 +152,20 @@ legacyInteractiveLoop symdbreq world = do
args = dropWhileEnd isSpace `map` args' args = dropWhileEnd isSpace `map` args'
res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of
"check" -> checkSyntaxCmd [arg] "check" -> checkSyntax [arg]
"lint" -> lintCmd [arg]
"find" -> do "find" -> do
db <- getDb symdbreq >>= checkDb symdbreq db <- getDb symdbreq >>= checkDb symdbreq
lookupSymbol arg db lookupSymbol arg db
"info" -> infoCmd [head args, concat $ tail args'] "info" -> info (head args) $ Expression $ concat $ tail args'
"type" -> typesCmd args "type" -> locArgs types args
"split" -> splitsCmd args "split" -> locArgs splits args
"sig" -> sigCmd args "sig" -> locArgs sig args
"auto" -> autoCmd args "auto" -> locArgs auto args
"refine" -> refineCmd args "refine" -> locArgs' refine args
"boot" -> bootCmd [] "boot" -> boot
"browse" -> browseCmd args
"map-file" -> liftIO getFileSourceFromStdin "map-file" -> liftIO getFileSourceFromStdin
>>= loadMappedFileSource arg >>= loadMappedFileSource arg
@ -501,6 +187,10 @@ legacyInteractiveLoop symdbreq world = do
, GHandler $ \e@(ExitFailure _) -> throw e , GHandler $ \e@(ExitFailure _) -> throw e
, GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return "" , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""
] ]
locArgs a (f:l:c:_) = a f (read l) (read c)
locArgs _ _ = throw $ InvalidCommandLine $ Left "Invalid command line"
locArgs' a (f:l:c:xs) = a f (read l) (read c) (Expression $ concat xs)
locArgs' _ _ = throw $ InvalidCommandLine $ Left "Invalid command line"
getFileSourceFromStdin :: IO String getFileSourceFromStdin :: IO String
getFileSourceFromStdin = do getFileSourceFromStdin = do
@ -514,15 +204,14 @@ getFileSourceFromStdin = do
else return [] else return []
-- Someone please already rewrite the cmdline parsing code *weep* :'( -- Someone please already rewrite the cmdline parsing code *weep* :'(
wrapGhcCommands :: (IOish m, GmOut m) => Options -> [String] -> m () wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
wrapGhcCommands _opts [] = fatalError "No command given (try --help)" wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo
wrapGhcCommands _opts ("root":_) = gmPutStr =<< rootInfo wrapGhcCommands opts cmd = do
wrapGhcCommands opts args = do
handleGmError $ runGhcModT opts $ handler $ do handleGmError $ runGhcModT opts $ handler $ do
forM_ (reverse $ optFileMappings opts) $ forM_ (reverse $ optFileMappings opts) $
uncurry loadMMappedFiles uncurry loadMMappedFiles
ghcCommands args gmPutStr =<< ghcCommands cmd
where where
handleGmError action = do handleGmError action = do
(e, _l) <- liftIO . evaluate =<< action (e, _l) <- liftIO . evaluate =<< action
@ -538,34 +227,31 @@ wrapGhcCommands opts args = do
loadMappedFileSource from src loadMappedFileSource from src
ghcCommands :: IOish m => [String] -> GhcModT m () ghcCommands :: IOish m => GhcModCommands -> GhcModT m String
ghcCommands [] = fatalError "No command given (try --help)" -- ghcCommands cmd = action args
ghcCommands (cmd:args) = gmPutStr =<< action args ghcCommands (CmdLang) = languages
where ghcCommands (CmdFlag) = flags
action = case cmd of ghcCommands (CmdDebug) = debugInfo
_ | cmd == "list" || cmd == "modules" -> modulesCmd ghcCommands (CmdDebugComponent ts) = componentInfo ts
"lang" -> languagesCmd ghcCommands (CmdBoot) = boot
"flag" -> flagsCmd -- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""
"browse" -> browseCmd -- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands
"check" -> checkSyntaxCmd ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
"expand" -> expandTemplateCmd ghcCommands (CmdModules detail) = modules detail
"debug" -> debugInfoCmd ghcCommands (CmdDumpSym tmpdir) = dumpSymbol tmpdir
"debug-component" -> componentInfoCmd ghcCommands (CmdFind symb) = findSymbol symb
"info" -> infoCmd ghcCommands (CmdDoc m) = pkgDoc m
"type" -> typesCmd ghcCommands (CmdLint opts file) = lint opts file
"split" -> splitsCmd ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms
"sig" -> sigCmd ghcCommands (CmdCheck files) = checkSyntax files
"refine" -> refineCmd ghcCommands (CmdExpand files) = expandTemplate files
"auto" -> autoCmd ghcCommands (CmdInfo file symb) = info file $ Expression symb
"find" -> findSymbolCmd ghcCommands (CmdType file (line, col)) = types file line col
"lint" -> lintCmd ghcCommands (CmdSplit file (line, col)) = splits file line col
-- "root" -> rootInfoCmd ghcCommands (CmdSig file (line, col)) = sig file line col
"doc" -> pkgDocCmd ghcCommands (CmdAuto file (line, col)) = auto file line col
"dumpsym" -> dumpSymbolCmd ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr
"boot" -> bootCmd ghcCommands _ = fatalError "Unknown command"
"legacy-interactive" -> legacyInteractiveCmd
-- "nuke-caches" -> nukeCachesCmd
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
newtype FatalError = FatalError String deriving (Show, Typeable) newtype FatalError = FatalError String deriving (Show, Typeable)
instance Exception FatalError instance Exception FatalError
@ -580,114 +266,11 @@ exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
fatalError :: String -> a fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
withParseCmd :: IOish m
=> [OptDescr (Options -> Either [String] Options)]
-> ([String] -> GhcModT m a)
-> [String]
-> GhcModT m a
withParseCmd spec action args = do
(opts', rest) <- parseCommandArgs spec args <$> options
withOptions (const opts') $ action rest
withParseCmd' :: (IOish m, ExceptionMonad m)
=> String
-> [OptDescr (Options -> Either [String] Options)]
-> ([String] -> GhcModT m a)
-> [String]
-> GhcModT m a
withParseCmd' cmd spec action args =
catchArgs cmd $ withParseCmd spec action args
catchArgs :: (Monad m, ExceptionMonad m) => String -> m a -> m a catchArgs :: (Monad m, ExceptionMonad m) => String -> m a -> m a
catchArgs cmd action = catchArgs cmd action =
action `gcatch` \(PatternMatchFail _) -> action `gcatch` \(PatternMatchFail _) ->
throw $ InvalidCommandLine (Left cmd) throw $ InvalidCommandLine (Left cmd)
modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
refineCmd, autoCmd, findSymbolCmd, lintCmd, pkgDocCmd,
dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd
:: IOish m => [String] -> GhcModT m String
modulesCmd = withParseCmd' "modules" s $ \[] -> modules
where s = modulesArgSpec
languagesCmd = withParseCmd' "lang" [] $ \[] -> languages
flagsCmd = withParseCmd' "flag" [] $ \[] -> flags
debugInfoCmd = withParseCmd' "debug" [] $ \[] -> debugInfo
componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts
-- internal
bootCmd = withParseCmd' "boot" [] $ \[] -> boot
nukeCachesCmd = withParseCmd' "nuke-caches" [] $ \[] -> nukeCaches >> return ""
dumpSymbolCmd = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir
findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym
pkgDocCmd = withParseCmd' "doc" [] $ \[mdl] -> pkgDoc mdl
lintCmd = withParseCmd' "lint" s $ \[file] -> lint file
where s = hlintArgSpec
browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls
where s = browseArgSpec
checkSyntaxCmd = withParseCmd [] $ checkAction checkSyntax
expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate
typesCmd = withParseCmd [] $ locAction "type" types
splitsCmd = withParseCmd [] $ locAction "split" splits
sigCmd = withParseCmd [] $ locAction "sig" sig
autoCmd = withParseCmd [] $ locAction "auto" auto
refineCmd = withParseCmd [] $ locAction' "refine" refine
infoCmd = withParseCmd [] $ action
where action [file,_,expr] = info file $ Expression expr
action [file,expr] = info file $ Expression expr
action _ = throw $ InvalidCommandLine (Left "info")
legacyInteractiveCmd = withParseCmd [] go
where
go [] =
legacyInteractive >> return ""
go ("help":[]) =
return usage
go ("version":[]) =
return ghcModiVersion
go _ = throw $ InvalidCommandLine (Left "legacy-interactive")
checkAction :: ([t] -> a) -> [t] -> a
checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.")
checkAction action files = action files
locAction :: String -> (String -> Int -> Int -> a) -> [String] -> a
locAction _ action [file,_,line,col] = action file (read line) (read col)
locAction _ action [file, line,col] = action file (read line) (read col)
locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd)
locAction' :: String -> (String -> Int -> Int -> Expression -> a) -> [String] -> a
locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr)
locAction' _ action [f, line,col,expr] = action f (read line) (read col) (Expression expr)
locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
modulesArgSpec :: [OptDescr (Options -> Either [String] Options)]
modulesArgSpec =
[ option "d" ["detailed"] "Print package modules belong to." $
NoArg $ \o -> Right $ o { optDetailed = True }
]
hlintArgSpec :: [OptDescr (Options -> Either [String] Options)]
hlintArgSpec =
[ option "h" ["hlintOpt"] "Option to be passed to hlint" $
reqArg "hlintOpt" $ \h o -> Right $ o { optHlintOpts = h : optHlintOpts o }
]
browseArgSpec :: [OptDescr (Options -> Either [String] Options)]
browseArgSpec =
[ option "o" ["operators"] "Also print operators." $
NoArg $ \o -> Right $ o { optOperators = True }
, option "d" ["detailed"] "Print symbols with accompanying signature." $
NoArg $ \o -> Right $ o { optDetailed = True }
, option "q" ["qualified"] "Qualify symbols" $
NoArg $ \o -> Right $ o { optQualified = True }
]
nukeCaches :: IOish m => GhcModT m () nukeCaches :: IOish m => GhcModT m ()
nukeCaches = do nukeCaches = do
chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"

185
src/GHCMod/Options.hs Normal file
View File

@ -0,0 +1,185 @@
module GHCMod.Options (
parseArgs,
parseCommandsFromList,
GhcModCommands(..)
) where
import Options.Applicative
import Options.Applicative.Types
import Language.Haskell.GhcMod.Types
import Control.Arrow
import GHCMod.Options.Commands
import GHCMod.Version
parseArgs :: IO (Options, GhcModCommands)
parseArgs =
execParser opts
where
opts = info (argAndCmdSpec <**> helpVersion)
( fullDesc
<> header "ghc-mod: Happy Haskell Programming" )
parseCommandsFromList :: [String] -> Either String GhcModCommands
parseCommandsFromList args =
case execParserPure (prefs idm) (info commandsSpec idm) args of
Success a -> Right a
Failure h -> Left $ show h
CompletionInvoked _ -> error "WTF"
helpVersion :: Parser (a -> a)
helpVersion =
helper <*>
abortOption (InfoMsg ghcModVersion)
(long "version" <> help "Print the version of the program.") <*>
argument r (value id <> metavar "")
where
r :: ReadM (a -> a)
r = do
v <- readerAsk
case v of
"help" -> readerAbort ShowHelpText
"version" -> readerAbort $ InfoMsg ghcModVersion
_ -> return id
argAndCmdSpec :: Parser (Options, GhcModCommands)
argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec
splitOn :: Eq a => a -> [a] -> ([a], [a])
splitOn c = second (drop 1) . break (==c)
getLogLevel :: Int -> GmLogLevel
getLogLevel = toEnum . min 7
logLevelParser :: Parser GmLogLevel
logLevelParser =
getLogLevel <$>
(
silentSwitch <|> logLevelSwitch <|> logLevelOption
)
where
logLevelOption =
option int (
long "verbose" <>
short 'v' <>
metavar "LEVEL" <>
value 4 <>
showDefault <>
help "Set log level. (0-7)"
)
logLevelSwitch =
(4+) . length <$> many (flag' () (
long "verbose" <>
short 'v' <>
help "Increase log level"
))
silentSwitch = (\v -> if v then 0 else 4) <$>
switch (
long "silent" <>
short 's' <>
help "Be silent, set log level to 0"
)
outputOptsSpec :: Parser OutputOpts
outputOptsSpec = OutputOpts <$>
logLevelParser <*>
flag PlainStyle LispStyle (
long "tolisp" <>
short 'l' <>
help "Format output as an S-Expression"
) <*>
(LineSeparator <$> strOption (
long "boundary" <>
long "line-separator" <>
short 'b' <>
metavar "SEP" <>
value "\0" <>
showDefault <>
help "Output line separator"
)) <*>
optional (splitOn ',' <$> strOption (
long "line-prefix" <>
metavar "OUT,ERR" <>
help "Output prefixes"
))
programsArgSpec :: Parser Programs
programsArgSpec = Programs <$>
strOption (
long "with-ghc" <>
value "ghc" <>
showDefault <>
help "GHC executable to use"
) <*>
strOption (
long "with-ghc-pkg" <>
value "ghc-pkg" <>
showDefault <>
help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
) <*>
strOption (
long "with-cabal" <>
value "cabal" <>
showDefault <>
help "cabal-install executable to use"
) <*>
strOption (
long "with-stack" <>
value "stack" <>
showDefault <>
help "stack executable to use"
)
globalArgSpec :: Parser Options
globalArgSpec = Options <$>
outputOptsSpec <*> -- optOutput
programsArgSpec <*> -- optPrograms
many (strOption ( -- optGhcUserOptions
long "ghcOpt" <>
long "ghc-option" <>
short 'g' <>
metavar "OPT" <>
help "Option to be passed to GHC"
)) <*>
many fileMappingSpec -- optFileMappings = []
where
{-
File map docs:
CLI options:
* `--map-file "file1.hs=file2.hs"` can be used to tell
ghc-mod that it should take source code for `file1.hs` from `file2.hs`.
`file1.hs` can be either full path, or path relative to project root.
`file2.hs` has to be either relative to project root,
or full path (preferred).
* `--map-file "file.hs"` can be used to tell ghc-mod that it should take
source code for `file.hs` from stdin. File end marker is `\EOT\n`,
i.e. `\x04\x0A`. `file.hs` may or may not exist, and should be
either full path, or relative to project root.
Interactive commands:
* `map-file file.hs` -- tells ghc-modi to read `file.hs` source from stdin.
Works the same as second form of `--map-file` CLI option.
* `unmap-file file.hs` -- unloads previously mapped file, so that it's
no longer mapped. `file.hs` can be full path or relative to
project root, either will work.
Exposed functions:
* `loadMappedFile :: FilePath -> FilePath -> GhcModT m ()` -- maps `FilePath`,
given as first argument to take source from `FilePath` given as second
argument. Works exactly the same as first form of `--map-file`
CLI option.
* `loadMappedFileSource :: FilePath -> String -> GhcModT m ()` -- maps
`FilePath`, given as first argument to have source as given
by second argument. Works exactly the same as second form of `--map-file`
CLI option, sans reading from stdin.
* `unloadMappedFile :: FilePath -> GhcModT m ()` -- unmaps `FilePath`, given as
first argument, and removes any temporary files created when file was
mapped. Works exactly the same as `unmap-file` interactive command
-}
fileMappingSpec =
getFileMapping . splitOn '=' <$> strOption (
long "map-file" <>
metavar "MAPPING" <>
help "Redirect one file to another, --map-file \"file1.hs=file2.hs\""
)
getFileMapping = second (\i -> if null i then Nothing else Just i)

View File

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

View File

@ -0,0 +1,14 @@
module GHCMod.Options.DocUtils (
module PP,
desc,
code
) where
import Options.Applicative
import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<>), (<$>), int)
desc :: [Doc] -> InfoMod a
desc = footerDoc . Just . indent 2 . vsep
code :: [String] -> Doc
code x = vsep [line, indent 4 $ vsep $ map text x, line]

16
src/GHCMod/Version.hs Normal file
View File

@ -0,0 +1,16 @@
module GHCMod.Version where
import Paths_ghc_mod
import Data.Version (showVersion)
import Config (cProjectVersion)
progVersion :: String -> String
progVersion pf =
"ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "
++ cProjectVersion ++ "\n"
ghcModVersion :: String
ghcModVersion = progVersion ""
ghcModiVersion :: String
ghcModiVersion = progVersion "i"