Optparse-applicative
This commit is contained in:
Nikolay Yakimov
parent
bff86be69f
commit
ad16b739eb
@ -12,7 +12,7 @@ import Language.Haskell.GhcMod.Modules
|
||||
boot :: IOish m => GhcModT m String
|
||||
boot = concat <$> sequence ms
|
||||
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 = [
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Language.Haskell.GhcMod.Browse (
|
||||
browse
|
||||
browse,
|
||||
BrowseOpts(..)
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
@ -14,7 +15,6 @@ import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
|
||||
import Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Name (getOccString)
|
||||
import Outputable
|
||||
@ -25,13 +25,20 @@ import Prelude
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data BrowseOpts = BrowseOpts {
|
||||
optBrowseOperators :: Bool
|
||||
, optBrowseDetailed :: Bool
|
||||
, optBrowseQualified :: Bool
|
||||
}
|
||||
|
||||
-- | Getting functions, classes, etc from a module.
|
||||
-- If 'detailed' is 'True', their types are also obtained.
|
||||
-- If 'operators' is 'True', operators are also returned.
|
||||
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
|
||||
browse pkgmdl = do
|
||||
browse opts pkgmdl = do
|
||||
convert' . sort =<< go
|
||||
where
|
||||
-- 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
|
||||
|
||||
goPkgModule = do
|
||||
opt <- options
|
||||
runGmPkgGhc $
|
||||
processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid
|
||||
processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid
|
||||
|
||||
goHomeModule = runGmlT [Right mdlname] $ do
|
||||
opt <- options
|
||||
processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing
|
||||
processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing
|
||||
|
||||
tryModuleInfo m = fromJust <$> G.getModuleInfo m
|
||||
|
||||
@ -80,31 +85,31 @@ isNotOp (h:_) = isAlpha h || (h == '_')
|
||||
isNotOp _ = error "isNotOp"
|
||||
|
||||
processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
|
||||
=> Options -> ModuleInfo -> m [String]
|
||||
=> BrowseOpts -> ModuleInfo -> m [String]
|
||||
processExports opt minfo = do
|
||||
let
|
||||
removeOps
|
||||
| optOperators opt = id
|
||||
| optBrowseOperators opt = id
|
||||
| otherwise = filter (isNotOp . getOccString)
|
||||
mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
|
||||
|
||||
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
|
||||
mtype' <- mtype
|
||||
return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
|
||||
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
|
||||
| optDetailed opt = do
|
||||
| optBrowseDetailed opt = do
|
||||
tyInfo <- G.modInfoLookupName minfo e
|
||||
-- If nothing found, load dependent module and lookup global
|
||||
tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
|
||||
dflag <- G.getSessionDynFlags
|
||||
return $ do
|
||||
typeName <- tyResult >>= showThing dflag
|
||||
(" :: " ++ typeName) `justIf` optDetailed opt
|
||||
(" :: " ++ typeName) `justIf` optBrowseDetailed opt
|
||||
| otherwise = return Nothing
|
||||
formatOp nm
|
||||
| null nm = error "formatOp"
|
||||
|
||||
@ -5,22 +5,23 @@ import Control.Exception (SomeException(..))
|
||||
import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.HLint (hlint)
|
||||
|
||||
import Language.Haskell.GhcMod.Utils (withMappedFile)
|
||||
|
||||
import Data.List (stripPrefix)
|
||||
|
||||
data LintOpts = LintOpts { optLintHlintOpts :: [String] }
|
||||
|
||||
-- | Checking syntax of a target file using hlint.
|
||||
-- Warnings and errors are returned.
|
||||
lint :: IOish m
|
||||
=> FilePath -- ^ A target file.
|
||||
=> LintOpts
|
||||
-> FilePath -- ^ A target file.
|
||||
-> GhcModT m String
|
||||
lint file = do
|
||||
opt <- options
|
||||
lint opt file =
|
||||
withMappedFile file $ \tempfile ->
|
||||
liftIO (hlint $ tempfile : "--quiet" : optHlintOpts opt)
|
||||
liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt)
|
||||
>>= mapM (replaceFileName tempfile)
|
||||
>>= ghandle handler . pack
|
||||
where
|
||||
|
||||
@ -14,13 +14,12 @@ import qualified GHC as G
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Listing installed modules.
|
||||
modules :: (IOish m, Gm m) => m String
|
||||
modules = do
|
||||
Options { optDetailed } <- options
|
||||
modules :: (IOish m, Gm m) => Bool -> m String
|
||||
modules detailed = do
|
||||
df <- runGmPkgGhc G.getSessionDynFlags
|
||||
let mns = listVisibleModuleNames df
|
||||
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 ]
|
||||
where
|
||||
modulePkg df = lookupModulePackageInAllPackages df
|
||||
|
||||
@ -102,13 +102,6 @@ data Options = Options {
|
||||
, optPrograms :: Programs
|
||||
-- | GHC command line options set on the @ghc-mod@ command line
|
||||
, 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)]
|
||||
} deriving (Show)
|
||||
|
||||
@ -128,10 +121,6 @@ defaultOptions = Options {
|
||||
, stackProgram = "stack"
|
||||
}
|
||||
, optGhcUserOptions = []
|
||||
, optOperators = False
|
||||
, optDetailed = False
|
||||
, optQualified = False
|
||||
, optHlintOpts = []
|
||||
, optFileMappings = []
|
||||
}
|
||||
|
||||
|
||||
@ -188,6 +188,10 @@ Executable ghc-mod
|
||||
Default-Language: Haskell2010
|
||||
Main-Is: GHCMod.hs
|
||||
Other-Modules: Paths_ghc_mod
|
||||
, GHCMod.Options
|
||||
, GHCMod.Options.Commands
|
||||
, GHCMod.Version
|
||||
, GHCMod.Options.DocUtils
|
||||
GHC-Options: -Wall -fno-warn-deprecations -threaded
|
||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||
HS-Source-Dirs: src
|
||||
@ -201,6 +205,8 @@ Executable ghc-mod
|
||||
, mtl < 2.3 && >= 2.0
|
||||
, ghc < 7.11
|
||||
, fclabels ==2.0.*
|
||||
, optparse-applicative ==0.11.*
|
||||
, ansi-wl-pprint ==0.6.*
|
||||
, ghc-mod
|
||||
|
||||
Executable ghc-modi
|
||||
|
||||
523
src/GHCMod.hs
523
src/GHCMod.hs
@ -2,14 +2,10 @@
|
||||
|
||||
module Main where
|
||||
|
||||
import Config (cProjectVersion)
|
||||
import Control.Category
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import Control.Monad
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Version (showVersion)
|
||||
import Data.Label
|
||||
import Data.List
|
||||
import Data.List.Split
|
||||
import Data.Char (isSpace)
|
||||
@ -19,261 +15,23 @@ import Language.Haskell.GhcMod
|
||||
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
|
||||
import Language.Haskell.GhcMod.Types
|
||||
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.Directory (setCurrentDirectory, getAppUserDataDirectory,
|
||||
removeDirectoryRecursive)
|
||||
import System.Environment (getArgs)
|
||||
-- import System.Environment (getArgs)
|
||||
import System.IO
|
||||
import System.Exit
|
||||
import Text.PrettyPrint
|
||||
import Text.PrettyPrint hiding ((<>))
|
||||
import Prelude hiding ((.))
|
||||
import GHCMod.Options
|
||||
|
||||
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 { 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:
|
||||
|
||||
@ -308,59 +66,6 @@ Exposed functions:
|
||||
first argument, and removes any temporary files created when file was
|
||||
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 $ \e@(ExitSuccess) -> 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
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
hSetEncoding stdout utf8
|
||||
args <- getArgs
|
||||
case parseGlobalArgs args of
|
||||
Left e -> throw e
|
||||
Right res@(globalOptions,_) -> catches (progMain res) [
|
||||
Handler $ \(e :: GhcModError) ->
|
||||
runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
|
||||
]
|
||||
parseArgs >>= \res@(globalOptions, _) ->
|
||||
catches (progMain res) [
|
||||
Handler $ \(e :: GhcModError) ->
|
||||
runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
|
||||
]
|
||||
|
||||
progMain :: (Options,[String]) -> IO ()
|
||||
progMain (globalOptions,cmdArgs) = runGmOutT globalOptions $
|
||||
case globalCommands cmdArgs of
|
||||
Just s -> gmPutStr s
|
||||
Nothing -> wrapGhcCommands globalOptions cmdArgs
|
||||
|
||||
globalCommands :: [String] -> Maybe String
|
||||
globalCommands (cmd:_)
|
||||
| cmd == "help" = Just usage
|
||||
| cmd == "version" = Just ghcModVersion
|
||||
globalCommands _ = Nothing
|
||||
progMain :: (Options, GhcModCommands) -> IO ()
|
||||
progMain (globalOptions, commands) = runGmOutT globalOptions $
|
||||
wrapGhcCommands globalOptions commands
|
||||
|
||||
-- ghc-modi
|
||||
legacyInteractive :: IOish m => GhcModT m ()
|
||||
@ -464,22 +152,20 @@ legacyInteractiveLoop symdbreq world = do
|
||||
args = dropWhileEnd isSpace `map` args'
|
||||
|
||||
res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of
|
||||
"check" -> checkSyntaxCmd [arg]
|
||||
"lint" -> lintCmd [arg]
|
||||
"check" -> checkSyntax [arg]
|
||||
"find" -> do
|
||||
db <- getDb symdbreq >>= checkDb symdbreq
|
||||
lookupSymbol arg db
|
||||
|
||||
"info" -> infoCmd [head args, concat $ tail args']
|
||||
"type" -> typesCmd args
|
||||
"split" -> splitsCmd args
|
||||
"info" -> info (head args) $ Expression $ concat $ tail args'
|
||||
"type" -> locArgs types args
|
||||
"split" -> locArgs splits args
|
||||
|
||||
"sig" -> sigCmd args
|
||||
"auto" -> autoCmd args
|
||||
"refine" -> refineCmd args
|
||||
"sig" -> locArgs sig args
|
||||
"auto" -> locArgs auto args
|
||||
"refine" -> locArgs' refine args
|
||||
|
||||
"boot" -> bootCmd []
|
||||
"browse" -> browseCmd args
|
||||
"boot" -> boot
|
||||
|
||||
"map-file" -> liftIO getFileSourceFromStdin
|
||||
>>= loadMappedFileSource arg
|
||||
@ -495,12 +181,16 @@ legacyInteractiveLoop symdbreq world = do
|
||||
gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
|
||||
legacyInteractiveLoop symdbreq world'
|
||||
where
|
||||
interactiveHandlers =
|
||||
interactiveHandlers =
|
||||
[ GHandler $ \e@(FatalError _) -> throw e
|
||||
, GHandler $ \e@(ExitSuccess) -> throw e
|
||||
, GHandler $ \e@(ExitFailure _) -> throw e
|
||||
, 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 = do
|
||||
@ -514,15 +204,14 @@ getFileSourceFromStdin = do
|
||||
else return []
|
||||
|
||||
-- Someone please already rewrite the cmdline parsing code *weep* :'(
|
||||
wrapGhcCommands :: (IOish m, GmOut m) => Options -> [String] -> m ()
|
||||
wrapGhcCommands _opts [] = fatalError "No command given (try --help)"
|
||||
wrapGhcCommands _opts ("root":_) = gmPutStr =<< rootInfo
|
||||
wrapGhcCommands opts args = do
|
||||
wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
|
||||
wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo
|
||||
wrapGhcCommands opts cmd = do
|
||||
handleGmError $ runGhcModT opts $ handler $ do
|
||||
forM_ (reverse $ optFileMappings opts) $
|
||||
uncurry loadMMappedFiles
|
||||
|
||||
ghcCommands args
|
||||
gmPutStr =<< ghcCommands cmd
|
||||
where
|
||||
handleGmError action = do
|
||||
(e, _l) <- liftIO . evaluate =<< action
|
||||
@ -538,34 +227,31 @@ wrapGhcCommands opts args = do
|
||||
loadMappedFileSource from src
|
||||
|
||||
|
||||
ghcCommands :: IOish m => [String] -> GhcModT m ()
|
||||
ghcCommands [] = fatalError "No command given (try --help)"
|
||||
ghcCommands (cmd:args) = gmPutStr =<< action args
|
||||
where
|
||||
action = case cmd of
|
||||
_ | cmd == "list" || cmd == "modules" -> modulesCmd
|
||||
"lang" -> languagesCmd
|
||||
"flag" -> flagsCmd
|
||||
"browse" -> browseCmd
|
||||
"check" -> checkSyntaxCmd
|
||||
"expand" -> expandTemplateCmd
|
||||
"debug" -> debugInfoCmd
|
||||
"debug-component" -> componentInfoCmd
|
||||
"info" -> infoCmd
|
||||
"type" -> typesCmd
|
||||
"split" -> splitsCmd
|
||||
"sig" -> sigCmd
|
||||
"refine" -> refineCmd
|
||||
"auto" -> autoCmd
|
||||
"find" -> findSymbolCmd
|
||||
"lint" -> lintCmd
|
||||
-- "root" -> rootInfoCmd
|
||||
"doc" -> pkgDocCmd
|
||||
"dumpsym" -> dumpSymbolCmd
|
||||
"boot" -> bootCmd
|
||||
"legacy-interactive" -> legacyInteractiveCmd
|
||||
-- "nuke-caches" -> nukeCachesCmd
|
||||
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
|
||||
ghcCommands :: IOish m => GhcModCommands -> GhcModT m String
|
||||
-- ghcCommands cmd = action args
|
||||
ghcCommands (CmdLang) = languages
|
||||
ghcCommands (CmdFlag) = flags
|
||||
ghcCommands (CmdDebug) = debugInfo
|
||||
ghcCommands (CmdDebugComponent ts) = componentInfo ts
|
||||
ghcCommands (CmdBoot) = boot
|
||||
-- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""
|
||||
-- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands
|
||||
ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
|
||||
ghcCommands (CmdModules detail) = modules detail
|
||||
ghcCommands (CmdDumpSym tmpdir) = dumpSymbol tmpdir
|
||||
ghcCommands (CmdFind symb) = findSymbol symb
|
||||
ghcCommands (CmdDoc m) = pkgDoc m
|
||||
ghcCommands (CmdLint opts file) = lint opts file
|
||||
ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms
|
||||
ghcCommands (CmdCheck files) = checkSyntax files
|
||||
ghcCommands (CmdExpand files) = expandTemplate files
|
||||
ghcCommands (CmdInfo file symb) = info file $ Expression symb
|
||||
ghcCommands (CmdType file (line, col)) = types file line col
|
||||
ghcCommands (CmdSplit file (line, col)) = splits file line col
|
||||
ghcCommands (CmdSig file (line, col)) = sig file line col
|
||||
ghcCommands (CmdAuto file (line, col)) = auto file line col
|
||||
ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr
|
||||
ghcCommands _ = fatalError "Unknown command"
|
||||
|
||||
newtype FatalError = FatalError String deriving (Show, Typeable)
|
||||
instance Exception FatalError
|
||||
@ -580,114 +266,11 @@ exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
|
||||
fatalError :: String -> a
|
||||
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 cmd action =
|
||||
action `gcatch` \(PatternMatchFail _) ->
|
||||
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 = do
|
||||
chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
|
||||
|
||||
185
src/GHCMod/Options.hs
Normal file
185
src/GHCMod/Options.hs
Normal 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)
|
||||
231
src/GHCMod/Options/Commands.hs
Normal file
231
src/GHCMod/Options/Commands.hs
Normal 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"
|
||||
14
src/GHCMod/Options/DocUtils.hs
Normal file
14
src/GHCMod/Options/DocUtils.hs
Normal 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
16
src/GHCMod/Version.hs
Normal 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"
|
||||
Loading…
Reference in New Issue
Block a user