ghc-mod/src/GHCMod.hs

188 lines
7.5 KiB
Haskell
Raw Normal View History

2010-06-14 06:38:56 +00:00
{-# LANGUAGE DeriveDataTypeable #-}
2010-01-06 05:38:06 +00:00
module Main where
2014-04-25 13:03:09 +00:00
import Config (cProjectVersion)
2014-03-27 05:46:33 +00:00
import Control.Applicative ((<$>))
import Control.Exception (Exception, Handler(..), ErrorCall(..))
import CoreMonad (liftIO)
2014-03-27 05:46:33 +00:00
import qualified Control.Exception as E
import Data.Typeable (Typeable)
import Data.Version (showVersion)
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod
2011-12-26 08:08:00 +00:00
import Paths_ghc_mod
2014-03-27 05:46:33 +00:00
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O
import System.Directory (doesFileExist)
2010-03-11 10:03:17 +00:00
import System.Environment (getArgs)
2013-08-23 02:30:07 +00:00
import System.Exit (exitFailure)
2013-03-29 12:58:55 +00:00
import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)
2010-01-06 05:38:06 +00:00
----------------------------------------------------------------
2014-04-25 13:03:09 +00:00
progVersion :: String
progVersion = "ghc-mod version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
ghcOptHelp :: String
ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "
2010-01-06 05:38:06 +00:00
usage :: String
2014-04-25 13:03:09 +00:00
usage = progVersion
2010-01-06 05:38:06 +00:00
++ "Usage:\n"
2013-10-28 08:22:18 +00:00
++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l] [-d]\n"
2011-01-27 05:29:39 +00:00
++ "\t ghc-mod lang [-l]\n"
++ "\t ghc-mod flag [-l]\n"
++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [<package>:]<module> [[<package>:]<module> ...]\n"
++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFiles...>\n"
++ "\t ghc-mod expand" ++ ghcOptHelp ++ "<HaskellFiles...>\n"
2014-04-21 02:31:15 +00:00
++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\n"
++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
2012-02-13 04:23:04 +00:00
++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ "\t ghc-mod split" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ "\t ghc-mod sig" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
2014-07-16 16:20:52 +00:00
++ "\t ghc-mod refine" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n"
2014-08-01 15:08:23 +00:00
++ "\t ghc-mod auto" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
2014-04-24 12:08:45 +00:00
++ "\t ghc-mod find <symbol>\n"
2011-01-27 05:29:39 +00:00
++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
2014-04-21 02:22:39 +00:00
++ "\t ghc-mod root\n"
2014-03-31 02:38:07 +00:00
++ "\t ghc-mod doc <module>\n"
2014-03-27 07:23:27 +00:00
++ "\t ghc-mod boot\n"
2014-04-25 05:09:32 +00:00
++ "\t ghc-mod version\n"
2010-01-06 05:38:06 +00:00
++ "\t ghc-mod help\n"
++ "\n"
2014-04-23 13:57:29 +00:00
++ "<module> for \"info\" and \"type\" is not used, anything is OK.\n"
++ "It is necessary to maintain backward compatibility.\n"
2010-01-06 05:38:06 +00:00
----------------------------------------------------------------
argspec :: [OptDescr (Options -> Options)]
2010-04-23 09:09:38 +00:00
argspec = [ Option "l" ["tolisp"]
(NoArg (\opts -> opts { outputStyle = LispStyle }))
2010-01-06 05:38:06 +00:00
"print as a list of Lisp"
, Option "h" ["hlintOpt"]
(ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt")
2011-10-20 02:24:25 +00:00
"hlint options"
, Option "g" ["ghcOpt"]
2014-08-13 16:40:01 +00:00
(ReqArg (\g opts -> opts { ghcUserOptions = g : ghcUserOptions opts }) "ghcOpt")
2011-10-20 02:24:25 +00:00
"GHC options"
2014-08-14 03:03:59 +00:00
, Option "v" ["verbose"]
(NoArg (\opts -> opts { ghcUserOptions = "-v" : ghcUserOptions opts }))
"verbose"
2011-01-27 05:29:39 +00:00
, Option "o" ["operators"]
(NoArg (\opts -> opts { operators = True }))
"print operators, too"
, Option "d" ["detailed"]
(NoArg (\opts -> opts { detailed = True }))
"print detailed info"
, Option "q" ["qualified"]
(NoArg (\opts -> opts { qualified = True }))
"show qualified names"
, Option "b" ["boundary"]
(ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")
"specify line separator (default is Nul string)"
2010-01-06 05:38:06 +00:00
]
parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
parseArgs spec argv
2014-03-27 05:46:33 +00:00
= case O.getOpt Permute spec argv of
2012-03-11 07:40:52 +00:00
(o,n,[] ) -> (foldr id defaultOptions o, n)
2014-03-27 05:46:33 +00:00
(_,_,errs) -> E.throw (CmdArg errs)
2010-06-14 06:38:56 +00:00
----------------------------------------------------------------
data GHCModError = SafeList
| ArgumentsMismatch String
2010-06-14 06:38:56 +00:00
| NoSuchCommand String
| CmdArg [String]
| FileNotExist String deriving (Show, Typeable)
instance Exception GHCModError
2010-01-06 05:38:06 +00:00
----------------------------------------------------------------
main :: IO ()
2014-03-27 05:46:33 +00:00
main = flip E.catches handlers $ do
-- #if __GLASGOW_HASKELL__ >= 611
2013-03-29 12:58:55 +00:00
hSetEncoding stdout utf8
-- #endif
2010-01-06 05:38:06 +00:00
args <- getArgs
let (opt,cmdArg) = parseArgs argspec args
let cmdArg0 = cmdArg !. 0
2013-03-04 00:09:13 +00:00
cmdArg1 = cmdArg !. 1
cmdArg3 = cmdArg !. 3
cmdArg4 = cmdArg !. 4
2014-07-16 16:20:52 +00:00
cmdArg5 = cmdArg !. 5
remainingArgs = tail cmdArg
nArgs :: Int -> a -> a
nArgs n f = if length remainingArgs == n
then f
else E.throw (ArgumentsMismatch cmdArg0)
2014-07-22 17:45:48 +00:00
(res, _) <- runGhcModT opt $ case cmdArg0 of
"list" -> modules
"lang" -> languages
"flag" -> flags
"browse" -> concat <$> mapM browse remainingArgs
"check" -> checkSyntax remainingArgs
"expand" -> expandTemplate remainingArgs
"debug" -> debugInfo
"info" -> nArgs 3 info cmdArg1 cmdArg3
"type" -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4)
"split" -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4)
"sig" -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4)
2014-07-17 04:59:10 +00:00
"refine" -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5
2014-08-01 15:08:23 +00:00
"auto" -> nArgs 4 $ auto cmdArg1 (read cmdArg3) (read cmdArg4)
"find" -> nArgs 1 $ findSymbol cmdArg1
"lint" -> nArgs 1 $ withFile lint cmdArg1
"root" -> rootInfo
"doc" -> nArgs 1 $ pkgDoc cmdArg1
"dumpsym" -> dumpSymbol
"boot" -> boot
2014-04-25 13:03:09 +00:00
"version" -> return progVersion
2014-04-25 05:09:32 +00:00
"help" -> return $ O.usageInfo usage argspec
cmd -> E.throw (NoSuchCommand cmd)
2014-07-22 17:45:48 +00:00
case res of
Right s -> putStr s
Left (GMENoMsg) ->
hPutStrLn stderr "Unknown error"
Left (GMEString msg) ->
hPutStrLn stderr msg
Left (GMECabalConfigure msg) ->
hPutStrLn stderr $ "cabal configure failed: " ++ show msg
Left (GMECabalFlags msg) ->
hPutStrLn stderr $ "retrieval of the cabal configuration flags failed: " ++ show msg
Left (GMEProcess cmd msg) ->
hPutStrLn stderr $
"launching operating system process `"++c++"` failed: " ++ show msg
where c = unwords cmd
2010-01-06 05:38:06 +00:00
where
2013-08-23 02:30:07 +00:00
handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
2014-03-27 07:28:27 +00:00
handleThenExit handler e = handler e >> exitFailure
2010-06-14 06:38:56 +00:00
handler1 :: ErrorCall -> IO ()
2011-08-24 06:58:12 +00:00
handler1 = print -- for debug
2010-06-14 06:38:56 +00:00
handler2 :: GHCModError -> IO ()
handler2 SafeList = printUsage
handler2 (ArgumentsMismatch cmd) = do
hPutStrLn stderr $ "\"" ++ cmd ++ "\": Arguments did not match"
printUsage
2010-06-14 06:38:56 +00:00
handler2 (NoSuchCommand cmd) = do
hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"
printUsage
handler2 (CmdArg errs) = do
mapM_ (hPutStr stderr) errs
printUsage
handler2 (FileNotExist file) = do
hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
printUsage
2014-03-27 05:46:33 +00:00
printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec
withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a
2010-05-06 06:29:55 +00:00
withFile cmd file = do
exist <- liftIO $ doesFileExist file
2010-05-06 06:29:55 +00:00
if exist
then cmd file
2014-03-27 05:46:33 +00:00
else E.throw (FileNotExist file)
2013-03-04 00:09:13 +00:00
xs !. idx
2014-03-27 05:46:33 +00:00
| length xs <= idx = E.throw SafeList
2010-06-14 06:38:56 +00:00
| otherwise = xs !! idx