190 lines
7.5 KiB
Haskell
190 lines
7.5 KiB
Haskell
{-# LANGUAGE DeriveDataTypeable #-}
|
|
|
|
module Main where
|
|
|
|
import Config (cProjectVersion)
|
|
import Control.Applicative ((<$>))
|
|
import Control.Exception (Exception, Handler(..), ErrorCall(..))
|
|
import CoreMonad (liftIO)
|
|
import qualified Control.Exception as E
|
|
import Data.Typeable (Typeable)
|
|
import Data.Version (showVersion)
|
|
import Language.Haskell.GhcMod
|
|
import Paths_ghc_mod
|
|
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
|
|
import qualified System.Console.GetOpt as O
|
|
import System.Directory (doesFileExist)
|
|
import System.Environment (getArgs)
|
|
import System.Exit (exitFailure)
|
|
import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)
|
|
|
|
----------------------------------------------------------------
|
|
|
|
progVersion :: String
|
|
progVersion = "ghc-mod version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
|
|
|
|
ghcOptHelp :: String
|
|
ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "
|
|
|
|
usage :: String
|
|
usage = progVersion
|
|
++ "Usage:\n"
|
|
++ "\t ghc-mod list " ++ ghcOptHelp ++ "[-l] [-d]\n"
|
|
++ "\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"
|
|
++ "\t ghc-mod debug " ++ ghcOptHelp ++ "\n"
|
|
++ "\t ghc-mod info " ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
|
|
++ "\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"
|
|
++ "\t ghc-mod refine " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n"
|
|
++ "\t ghc-mod auto " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
|
|
++ "\t ghc-mod find <symbol>\n"
|
|
++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
|
|
++ "\t ghc-mod root\n"
|
|
++ "\t ghc-mod doc <module>\n"
|
|
++ "\t ghc-mod boot\n"
|
|
++ "\t ghc-mod version\n"
|
|
++ "\t ghc-mod help\n"
|
|
++ "\n"
|
|
++ "<module> for \"info\" and \"type\" is not used, anything is OK.\n"
|
|
++ "It is necessary to maintain backward compatibility.\n"
|
|
|
|
----------------------------------------------------------------
|
|
|
|
argspec :: [OptDescr (Options -> Options)]
|
|
argspec =
|
|
let option s l udsc dsc = Option s l dsc udsc
|
|
reqArg udsc dsc = ReqArg dsc udsc
|
|
in
|
|
[ option "l" ["tolisp"] "print as a list of Lisp" $
|
|
NoArg $ \o -> o { outputStyle = LispStyle }
|
|
|
|
, option "h" ["hlintOpt"] "hlint options" $
|
|
reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }
|
|
|
|
, option "g" ["ghcOpt"] "GHC options" $
|
|
reqArg "ghcOpt" $ \g o ->
|
|
o { ghcUserOptions = g : ghcUserOptions o }
|
|
|
|
, option "v" ["verbose"] "verbose" $
|
|
NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o }
|
|
|
|
, option "o" ["operators"] "print operators, too" $
|
|
NoArg $ \o -> o { operators = True }
|
|
|
|
, option "d" ["detailed"] "print detailed info" $
|
|
NoArg $ \o -> o { detailed = True }
|
|
|
|
, option "q" ["qualified"] "show qualified names" $
|
|
NoArg $ \o -> o { qualified = True }
|
|
|
|
, option "b" ["boundary"] "specify line separator (default is Nul string)"$
|
|
reqArg "sep" $ \s o -> o { lineSeparator = LineSeparator s }
|
|
]
|
|
|
|
parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
|
|
parseArgs spec argv
|
|
= case O.getOpt Permute spec argv of
|
|
(o,n,[] ) -> (foldr id defaultOptions o, n)
|
|
(_,_,errs) -> E.throw (CmdArg errs)
|
|
|
|
----------------------------------------------------------------
|
|
|
|
data GHCModError = SafeList
|
|
| ArgumentsMismatch String
|
|
| NoSuchCommand String
|
|
| CmdArg [String]
|
|
| FileNotExist String deriving (Show, Typeable)
|
|
|
|
instance Exception GHCModError
|
|
|
|
----------------------------------------------------------------
|
|
|
|
main :: IO ()
|
|
main = flip E.catches handlers $ do
|
|
hSetEncoding stdout utf8
|
|
args <- getArgs
|
|
let (opt,cmdArg) = parseArgs argspec args
|
|
let cmdArg0 = cmdArg !. 0
|
|
cmdArg1 = cmdArg !. 1
|
|
cmdArg3 = cmdArg !. 3
|
|
cmdArg4 = cmdArg !. 4
|
|
cmdArg5 = cmdArg !. 5
|
|
remainingArgs = tail cmdArg
|
|
nArgs :: Int -> a -> a
|
|
nArgs n f = if length remainingArgs == n
|
|
then f
|
|
else E.throw (ArgumentsMismatch cmdArg0)
|
|
(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)
|
|
"refine" -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5
|
|
"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
|
|
"version" -> return progVersion
|
|
"help" -> return $ O.usageInfo usage argspec
|
|
cmd -> E.throw (NoSuchCommand cmd)
|
|
|
|
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
|
|
|
|
where
|
|
handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
|
|
handleThenExit handler e = handler e >> exitFailure
|
|
handler1 :: ErrorCall -> IO ()
|
|
handler1 = print -- for debug
|
|
handler2 :: GHCModError -> IO ()
|
|
handler2 SafeList = printUsage
|
|
handler2 (ArgumentsMismatch cmd) = do
|
|
hPutStrLn stderr $ "\"" ++ cmd ++ "\": Arguments did not match"
|
|
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
|
|
printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec
|
|
withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a
|
|
withFile cmd file = do
|
|
exist <- liftIO $ doesFileExist file
|
|
if exist
|
|
then cmd file
|
|
else E.throw (FileNotExist file)
|
|
xs !. idx
|
|
| length xs <= idx = E.throw SafeList
|
|
| otherwise = xs !! idx
|