ghc-mod/src/GHCMod.hs

169 lines
6.0 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
2010-04-30 07:27:10 +00:00
import Control.Applicative
2010-06-14 06:38:56 +00:00
import Control.Exception
import Data.Typeable
2011-12-26 08:08:00 +00:00
import Data.Version
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod
2011-12-26 08:08:00 +00:00
import Paths_ghc_mod
2010-06-14 06:38:56 +00:00
import Prelude
2010-01-06 05:38:06 +00:00
import System.Console.GetOpt
2010-05-06 04:14:17 +00:00
import System.Directory
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
----------------------------------------------------------------
ghcOptHelp :: String
ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "
2010-01-06 05:38:06 +00:00
usage :: String
2011-12-26 08:08:00 +00:00
usage = "ghc-mod version " ++ showVersion version ++ "\n"
2010-01-06 05:38:06 +00:00
++ "Usage:\n"
++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l]\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] <module> [<module> ...]\n"
++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFile>\n"
2012-02-27 02:23:56 +00:00
++ "\t ghc-mod expand" ++ ghcOptHelp ++ "<HaskellFile>\n"
2013-03-05 07:25:37 +00:00
++ "\t ghc-mod debug" ++ ghcOptHelp ++ "<HaskellFile>\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"
2011-01-27 05:29:39 +00:00
++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
2010-05-04 03:47:55 +00:00
++ "\t ghc-mod boot\n"
2010-01-06 05:38:06 +00:00
++ "\t ghc-mod help\n"
----------------------------------------------------------------
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"]
(ReqArg (\g opts -> opts { ghcOpts = g : ghcOpts opts }) "ghcOpt")
2011-10-20 02:24:25 +00:00
"GHC options"
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 "s" ["sandbox"]
(ReqArg (\s opts -> opts { sandbox = Just s }) "path")
"specify cabal-dev sandbox (default 'cabal-dev`)"
, 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
= case getOpt Permute spec argv of
2012-03-11 07:40:52 +00:00
(o,n,[] ) -> (foldr id defaultOptions o, n)
2010-06-14 06:38:56 +00:00
(_,_,errs) -> throw (CmdArg errs)
----------------------------------------------------------------
data GHCModError = SafeList
| NoSuchCommand String
| CmdArg [String]
| FileNotExist String deriving (Show, Typeable)
instance Exception GHCModError
2010-01-06 05:38:06 +00:00
----------------------------------------------------------------
main :: IO ()
2010-06-14 05:42:17 +00:00
main = flip 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
2013-03-04 09:11:09 +00:00
(strVer,ver) <- getGHCVersion
cradle <- findCradle (sandbox opt') strVer
let opt = adjustOpts opt' cradle ver
2013-03-04 00:09:13 +00:00
cmdArg0 = cmdArg !. 0
cmdArg1 = cmdArg !. 1
cmdArg2 = cmdArg !. 2
cmdArg3 = cmdArg !. 3
cmdArg4 = cmdArg !. 4
res <- case cmdArg0 of
2013-05-20 02:29:44 +00:00
"browse" -> concat <$> mapM (browseModule opt) (tail cmdArg)
"list" -> listModules opt
"check" -> checkSyntax opt cradle cmdArg1
"expand" -> checkSyntax opt { expandSplice = True } cradle cmdArg1
"debug" -> debugInfo opt cradle strVer cmdArg1
2013-05-20 05:28:56 +00:00
"type" -> typeExpr opt cradle cmdArg1 cmdArg2 (read cmdArg3) (read cmdArg4)
"info" -> infoExpr opt cradle cmdArg1 cmdArg2 cmdArg3
2013-03-04 00:09:13 +00:00
"lint" -> withFile (lintSyntax opt) cmdArg1
2010-04-02 05:40:06 +00:00
"lang" -> listLanguages opt
"flag" -> listFlags opt
2010-05-04 03:47:55 +00:00
"boot" -> do
2013-05-20 02:29:44 +00:00
mods <- listModules opt
2010-05-04 03:47:55 +00:00
langs <- listLanguages opt
flags <- listFlags opt
2013-05-20 02:29:44 +00:00
pre <- concat <$> mapM (browseModule opt) preBrowsedModules
return $ mods ++ langs ++ flags ++ pre
"help" -> return $ usageInfo usage argspec
2010-06-14 06:38:56 +00:00
cmd -> throw (NoSuchCommand cmd)
2010-03-11 13:39:07 +00:00
putStr res
2010-01-06 05:38:06 +00:00
where
2013-08-23 02:30:07 +00:00
handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
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 (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
2011-08-24 06:58:12 +00:00
printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec
2010-05-06 06:29:55 +00:00
withFile cmd file = do
exist <- doesFileExist file
if exist
then cmd file
2010-06-14 06:38:56 +00:00
else throw (FileNotExist file)
2013-03-04 00:09:13 +00:00
xs !. idx
2010-06-14 06:38:56 +00:00
| length xs <= idx = throw SafeList
| otherwise = xs !! idx
2013-03-04 09:11:09 +00:00
adjustOpts opt cradle ver = case mPkgConf of
2013-03-02 07:14:55 +00:00
Nothing -> opt
2013-03-04 09:11:09 +00:00
Just pkgConf -> opt {
ghcOpts = ghcPackageConfOptions ver pkgConf ++ ghcOpts opt
}
2013-03-02 07:14:55 +00:00
where
2013-03-04 09:11:09 +00:00
mPkgConf = cradlePackageConf cradle
2010-01-06 05:38:06 +00:00
2012-01-23 09:30:07 +00:00
----------------------------------------------------------------
preBrowsedModules :: [String]
preBrowsedModules = [
"Prelude"
, "Control.Applicative"
, "Control.Monad"
, "Control.Exception"
, "Data.Char"
, "Data.List"
, "Data.Maybe"
, "System.IO"
]
2013-03-04 09:11:09 +00:00
ghcPackageConfOptions :: Int -> String -> [String]
ghcPackageConfOptions ver file
| ver >= 706 = ["-package-db", file, "-no-user-package-db"]
2013-03-04 09:11:09 +00:00
| otherwise = ["-package-conf", file, "-no-user-package-conf"]