ghc-mod/src/GHCModi.hs

259 lines
8.3 KiB
Haskell
Raw Normal View History

{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
2014-03-25 02:14:25 +00:00
2014-03-27 01:34:43 +00:00
-- Commands:
-- check <file>
-- find <symbol>
2014-04-19 11:48:44 +00:00
-- info <file> <expr>
-- type <file> <line> <column>
2014-03-28 04:44:44 +00:00
-- lint [hlint options] <file>
-- the format of hlint options is [String] because they may contain
2014-04-21 08:33:53 +00:00
-- spaces and also <file> may contain spaces.
2014-04-21 07:30:31 +00:00
-- boot
-- browse [<package>:]<module>
2014-04-28 00:29:24 +00:00
-- quit
2014-03-27 01:34:43 +00:00
--
-- Session separators:
-- OK -- success
-- NG -- failure
2014-03-19 01:23:47 +00:00
module Main where
2014-04-25 13:03:09 +00:00
import Config (cProjectVersion)
2014-03-25 03:28:39 +00:00
import Control.Applicative ((<$>))
2014-09-22 12:32:57 +00:00
import Control.Exception (SomeException(..))
2014-03-27 05:55:24 +00:00
import qualified Control.Exception as E
import Control.Monad (when)
2014-03-27 06:08:07 +00:00
import CoreMonad (liftIO)
import Data.List (intercalate)
import Data.List.Split (splitOn)
2014-04-07 02:06:17 +00:00
import Data.Version (showVersion)
2014-03-19 01:23:47 +00:00
import Language.Haskell.GhcMod
2014-09-23 08:34:09 +00:00
import Language.Haskell.GhcMod.Internal
2014-04-07 02:06:17 +00:00
import Paths_ghc_mod
import System.Console.GetOpt
2014-09-22 12:32:57 +00:00
import System.Directory (setCurrentDirectory)
2014-04-07 02:06:17 +00:00
import System.Environment (getArgs)
import System.Exit (ExitCode, exitFailure)
import System.IO (hFlush,stdout)
2014-03-19 01:23:47 +00:00
2014-09-22 12:32:57 +00:00
import Misc
2014-08-13 06:21:13 +00:00
import Utils
2014-03-25 02:14:25 +00:00
----------------------------------------------------------------
2014-04-25 13:03:09 +00:00
progVersion :: String
progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
2014-04-07 02:06:17 +00:00
argspec :: [OptDescr (Options -> Options)]
argspec = [ Option "b" ["boundary"]
(ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")
"specify line separator (default is Nul string)"
2014-04-18 08:28:12 +00:00
, Option "l" ["tolisp"]
(NoArg (\opts -> opts { outputStyle = LispStyle }))
"print as a list of Lisp"
2014-04-10 13:21:30 +00:00
, Option "g" []
2014-08-13 16:40:01 +00:00
(ReqArg (\s opts -> opts { ghcUserOptions = s : ghcUserOptions opts }) "flag") "specify a ghc flag"
2014-04-07 02:06:17 +00:00
]
usage :: String
2014-04-25 13:03:09 +00:00
usage = progVersion
2014-04-07 02:06:17 +00:00
++ "Usage:\n"
2014-04-18 08:28:12 +00:00
++ "\t ghc-modi [-l] [-b sep] [-g flag]\n"
2014-04-25 05:09:32 +00:00
++ "\t ghc-modi version\n"
2014-04-07 02:06:17 +00:00
++ "\t ghc-modi help\n"
parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
parseArgs spec argv
= case getOpt Permute spec argv of
(o,n,[] ) -> (foldr id defaultOptions o, n)
2014-04-23 05:44:05 +00:00
(_,_,errs) -> E.throw (CmdArg errs)
2014-04-07 02:06:17 +00:00
----------------------------------------------------------------
2014-03-25 02:34:58 +00:00
-- Running two GHC monad threads disables the handling of
-- C-c since installSignalHandlers is called twice, sigh.
2014-03-19 01:23:47 +00:00
main :: IO ()
2014-04-23 05:44:05 +00:00
main = E.handle cmdHandler $
2014-04-07 02:06:17 +00:00
go =<< parseArgs argspec <$> getArgs
2014-03-19 01:23:47 +00:00
where
2014-04-23 05:44:05 +00:00
cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
go (_,"help":_) = putStr $ usageInfo usage argspec
2014-04-25 13:03:09 +00:00
go (_,"version":_) = putStr progVersion
go (opt,_) = emptyNewUnGetLine >>= run opt
run :: Options -> UnGetLine -> IO ()
run opt ref = flip E.catches handlers $ do
cradle0 <- findCradle
let rootdir = cradleRootDir cradle0
-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
setCurrentDirectory rootdir
prepareAutogen cradle0
-- Asynchronous db loading starts here.
symdbreq <- newSymDbReq opt
(res, _) <- runGhcModT opt $ do
crdl <- cradle
world <- liftIO $ getCurrentWorld crdl
loop symdbreq ref world
case res of
Right () -> return ()
Left (GMECabalConfigure msg) -> do
putStrLn $ notGood $ "cabal configure failed: " ++ show msg
exitFailure
Left e -> bug $ show e
where
-- this is just in case.
-- If an error is caught here, it is a bug of GhcMod library.
handlers = [ E.Handler (\(_ :: ExitCode) -> return ())
, E.Handler (\(_ :: Restart) -> run opt ref)
, E.Handler (\(SomeException e) -> bug $ show e) ]
bug :: String -> IO ()
bug msg = do
putStrLn $ notGood $ "BUG: " ++ msg
exitFailure
notGood :: String -> String
notGood msg = "NG " ++ escapeNewlines msg
escapeNewlines :: String -> String
escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
replace :: String -> String -> String -> String
replace needle replacement = intercalate replacement . splitOn needle
2014-03-20 08:40:06 +00:00
2014-03-25 02:14:25 +00:00
----------------------------------------------------------------
loop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m ()
loop symdbreq ref world = do
-- blocking
cmdArg <- liftIO $ getCommand ref
-- after blocking, we need to see if the world has changed.
crdl <- cradle
changed <- liftIO $ isWorldChanged world crdl
2014-09-22 12:32:57 +00:00
when changed $ do
liftIO $ ungetCommand ref cmdArg
E.throw Restart
cradle >>= liftIO . prepareAutogen
2014-03-24 08:32:06 +00:00
let (cmd,arg') = break (== ' ') cmdArg
arg = dropWhile (== ' ') arg'
(ret,ok) <- case cmd of
"check" -> checkStx arg
"find" -> findSym arg symdbreq
"lint" -> lintStx arg
"info" -> showInfo arg
"type" -> showType arg
"split" -> doSplit arg
"sig" -> doSig arg
"refine" -> doRefine arg
"auto" -> doAuto arg
"boot" -> bootIt
"browse" -> browseIt arg
"quit" -> return ("quit", False)
"" -> return ("quit", False)
_ -> return ([], True)
2014-04-25 02:08:29 +00:00
if ok then do
liftIO $ putStr ret
liftIO $ putStrLn "OK"
else do
liftIO $ putStrLn $ notGood ret
2014-03-24 08:32:06 +00:00
liftIO $ hFlush stdout
when ok $ loop symdbreq ref world
2014-03-24 08:32:06 +00:00
2014-03-25 02:14:25 +00:00
----------------------------------------------------------------
checkStx :: IOish m => FilePath -> GhcModT m (String, Bool)
checkStx file = do
eret <- check [file]
2014-04-28 04:52:28 +00:00
case eret of
Right ret -> return (ret, True)
Left ret -> return (ret, True)
2014-04-28 07:31:28 +00:00
----------------------------------------------------------------
2014-03-25 02:14:25 +00:00
findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
findSym sym symdbreq = do
db <- getDb symdbreq >>= checkDb symdbreq
2014-07-18 06:13:30 +00:00
ret <- lookupSymbol sym db
return (ret, True)
2014-03-27 01:34:43 +00:00
lintStx :: IOish m => FilePath -> GhcModT m (String, Bool)
lintStx optFile = do
ret <- withOptions changeOpt $ lint file
return (ret, True)
2014-03-27 01:34:43 +00:00
where
2014-04-19 12:23:01 +00:00
(opts,file) = parseLintOptions optFile
hopts = if opts == "" then [] else read opts
changeOpt o = o { hlintOpts = hopts }
2014-03-28 05:41:01 +00:00
-- |
-- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"
-- (["--ignore=Use camelCase", "--ignore=Eta reduce"], "file name")
-- >>> parseLintOptions "file name"
-- ([], "file name")
parseLintOptions :: String -> (String, String)
parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
("","") -> ([], optFile)
2014-03-28 06:03:41 +00:00
(opt',file') -> (opt', dropWhile (== ' ') file')
2014-03-28 05:41:01 +00:00
where
brk _ [] = ([],[])
brk p (x:xs')
| p x = ([x],xs')
| otherwise = let (ys,zs) = brk p xs' in (x:ys,zs)
2014-04-11 07:07:36 +00:00
2014-04-21 07:30:31 +00:00
----------------------------------------------------------------
showInfo :: IOish m => FilePath -> GhcModT m (String, Bool)
showInfo fileArg = do
2014-08-13 06:21:13 +00:00
let [file, expr] = splitN 2 fileArg
ret <- info file expr
return (ret, True)
2014-04-11 07:07:36 +00:00
showType :: IOish m => FilePath -> GhcModT m (String, Bool)
showType fileArg = do
2014-08-13 06:21:13 +00:00
let [file, line, column] = splitN 3 fileArg
ret <- types file (read line) (read column)
return (ret, True)
2014-04-21 07:30:31 +00:00
doSplit :: IOish m => FilePath -> GhcModT m (String, Bool)
doSplit fileArg = do
2014-08-13 06:21:13 +00:00
let [file, line, column] = splitN 3 fileArg
ret <- splits file (read line) (read column)
return (ret, True)
doSig :: IOish m => FilePath -> GhcModT m (String, Bool)
doSig fileArg = do
2014-08-13 06:21:13 +00:00
let [file, line, column] = splitN 3 fileArg
ret <- sig file (read line) (read column)
return (ret, True)
doRefine :: IOish m => FilePath -> GhcModT m (String, Bool)
doRefine fileArg = do
2014-08-13 06:21:13 +00:00
let [file, line, column, expr] = splitN 4 fileArg
2014-07-17 04:59:10 +00:00
ret <- refine file (read line) (read column) expr
return (ret, True)
2014-07-16 16:20:52 +00:00
doAuto :: IOish m => FilePath -> GhcModT m (String, Bool)
doAuto fileArg = do
2014-08-13 06:21:13 +00:00
let [file, line, column] = splitN 3 fileArg
2014-08-01 15:08:23 +00:00
ret <- auto file (read line) (read column)
return (ret, True)
2014-08-01 15:08:23 +00:00
2014-04-21 07:30:31 +00:00
----------------------------------------------------------------
bootIt :: IOish m => GhcModT m (String, Bool)
bootIt = do
2014-05-10 11:51:35 +00:00
ret <- boot
return (ret, True)
2014-04-21 08:33:53 +00:00
browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool)
browseIt mdl = do
let (det,rest') = break (== ' ') mdl
rest = dropWhile (== ' ') rest'
ret <- if det == "-d"
then withOptions setDetailed (browse rest)
else browse mdl
return (ret, True)
where
2014-09-16 07:07:17 +00:00
setDetailed opt = opt { detailed = True }