Start rolling ghc-modi into the ghc-mod executable
This commit is contained in:
Daniel Gröber
parent
c45a7f4b52
commit
3c76ba412f
@ -20,7 +20,7 @@
|
||||
(defvar-local ghc-process-callback nil)
|
||||
(defvar-local ghc-process-hook nil)
|
||||
|
||||
(defvar ghc-interactive-command "ghc-modi")
|
||||
(defvar ghc-command "ghc-modi")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
@ -35,7 +35,7 @@
|
||||
(if hook1 (funcall hook1))
|
||||
(let* ((cbuf (current-buffer))
|
||||
(name ghc-process-process-name)
|
||||
(buf (get-buffer-create (concat " ghc-modi:" name)))
|
||||
(buf (get-buffer-create (concat " ghc-mod:" name)))
|
||||
(file (buffer-file-name))
|
||||
(cpro (get-process name)))
|
||||
(ghc-with-current-buffer buf
|
||||
@ -63,8 +63,8 @@
|
||||
(t cpro)))
|
||||
|
||||
(defun ghc-start-process (name buf)
|
||||
(let* ((opts (append '("-b" "\n" "-l") (ghc-make-ghc-options)))
|
||||
(pro (apply 'start-file-process name buf ghc-interactive-command opts)))
|
||||
(let* ((opts (append '("--legacy-interactive" "-b" "\n" "-l") (ghc-make-ghc-options)))
|
||||
(pro (apply 'start-file-process name buf ghc-command opts)))
|
||||
(set-process-filter pro 'ghc-process-filter)
|
||||
(set-process-sentinel pro 'ghc-process-sentinel)
|
||||
(set-process-query-on-exit-flag pro nil)
|
||||
|
||||
175
src/GHCMod.hs
175
src/GHCMod.hs
@ -30,16 +30,10 @@ import Text.PrettyPrint
|
||||
|
||||
import Misc
|
||||
|
||||
|
||||
|
||||
progVersion :: String
|
||||
progVersion =
|
||||
progName ++ " version " ++ showVersion version ++ " compiled by GHC "
|
||||
++ cProjectVersion ++ "\n"
|
||||
|
||||
-- TODO: remove (ghc) version prefix!
|
||||
progName :: String
|
||||
progName = unsafePerformIO $ takeFileName <$> getProgName
|
||||
"ghc-mod version " ++ showVersion version ++ " compiled by GHC "
|
||||
++ cProjectVersion ++ "\n"
|
||||
|
||||
optionUsage :: (String -> String) -> [OptDescr a] -> [String]
|
||||
optionUsage indent opts = concatMap optUsage opts
|
||||
@ -64,15 +58,9 @@ optionUsage indent opts = concatMap optUsage opts
|
||||
ReqArg _ label -> s ++ label
|
||||
OptArg _ label -> s ++ "["++label++"]"
|
||||
|
||||
-- TODO: Generate the stuff below automatically
|
||||
usage :: String
|
||||
usage =
|
||||
case progName of
|
||||
"ghc-modi" -> ghcModiUsage
|
||||
_ -> ghcModUsage
|
||||
|
||||
-- TODO: Generate the stuff below automatically
|
||||
ghcModUsage :: String
|
||||
ghcModUsage =
|
||||
"Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\
|
||||
\*Global Options (OPTIONS)*\n\
|
||||
\ Global options can be specified before and after the command and\n\
|
||||
@ -200,32 +188,12 @@ ghcModUsage =
|
||||
\ Debugging information related to cabal component resolution.\n\
|
||||
\\n\
|
||||
\ - boot\n\
|
||||
\ Internal command used by the emacs frontend.\n"
|
||||
-- "\n\
|
||||
-- \The following forms are supported so ghc-mod can be invoked by\n\
|
||||
-- \`cabal repl':\n\
|
||||
-- \\n\
|
||||
-- \ ghc-mod --make GHC_OPTIONS\n\
|
||||
-- \ Pass all options through to the GHC executable.\n\
|
||||
-- \\n\
|
||||
-- \ ghc-mod --interactive GHC_OPTIONS [--ghc-mod]\n\
|
||||
-- \ Start ghci emulation mode. GHC_OPTIONS are passed to the\n\
|
||||
-- \ GHC API. If `--ghc-mod' is given ghc-mod specific extensions\n\
|
||||
-- \ are enabled.\n"
|
||||
where
|
||||
indent = (" "++)
|
||||
|
||||
ghcModiUsage :: String
|
||||
ghcModiUsage =
|
||||
"Usage: ghc-modi [OPTIONS...] COMMAND\n\
|
||||
\*Options*\n"
|
||||
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
|
||||
"*Commands*\n\
|
||||
\ - version | --version\n\
|
||||
\ Print the version of the program.\n\
|
||||
\ Internal command used by the emacs frontend.\n\
|
||||
\\n\
|
||||
\ - help | --help\n\
|
||||
\ Print this help message.\n"
|
||||
\ - legacy-interactive [OPTIONS...]\n\
|
||||
\ ghc-modi compatibility mode.\n\
|
||||
\ *Options*\n"
|
||||
++ (unlines $ indent <$> optionUsage indent globalArgSpec)
|
||||
where
|
||||
indent = (" "++)
|
||||
|
||||
@ -255,6 +223,9 @@ cmdUsage cmd realUsage =
|
||||
unindent l = l
|
||||
in unlines $ unindent <$> c
|
||||
|
||||
ghcModStyle :: Style
|
||||
ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
|
||||
@ -280,7 +251,7 @@ globalArgSpec =
|
||||
, option "b" ["boundary"] "Output line separator"$
|
||||
reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s }
|
||||
|
||||
, option "g" ["ghcOpt"] "Option to be passed to GHC" $
|
||||
, option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
|
||||
reqArg "OPT" $ \g o ->
|
||||
o { ghcUserOptions = g : ghcUserOptions o }
|
||||
|
||||
@ -297,10 +268,14 @@ globalArgSpec =
|
||||
|
||||
parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
|
||||
parseGlobalArgs argv
|
||||
= case O.getOpt RequireOrder globalArgSpec argv of
|
||||
(o,r,[] ) -> Right $ (foldr id defaultOptions o, r)
|
||||
(_,_,errs) -> Left $ InvalidCommandLine $ Right $
|
||||
"Parsing command line options failed: " ++ concat errs
|
||||
= case O.getOpt' Permute globalArgSpec argv of
|
||||
(o,r,u,[]) -> Right $ (foldr id defaultOptions o, u ++ r)
|
||||
(_,_,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 -> Options)]
|
||||
-> [String]
|
||||
@ -322,8 +297,6 @@ data CmdError = UnknownCommand String
|
||||
|
||||
instance Exception CmdError
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data InteractiveOptions = InteractiveOptions {
|
||||
ghcModExtensions :: Bool
|
||||
}
|
||||
@ -338,9 +311,9 @@ handler = flip catches $
|
||||
case e of
|
||||
Left cmd ->
|
||||
exitError $ "Usage for `"++cmd++"' command:\n\n"
|
||||
++ (cmdUsage cmd ghcModUsage) ++ "\n"
|
||||
++ progName ++ ": Invalid command line form."
|
||||
Right msg -> exitError $ progName ++ ": " ++ msg
|
||||
++ (cmdUsage cmd usage) ++ "\n"
|
||||
++ "ghc-mod: Invalid command line form."
|
||||
Right msg -> exitError $ "ghc-mod: " ++ msg
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
@ -362,78 +335,19 @@ main = handler $ do
|
||||
|
||||
progMain :: (Options,[String]) -> IO ()
|
||||
progMain (globalOptions,cmdArgs) = do
|
||||
-- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
|
||||
-- _realGhcArgs = filter (/="--ghc-mod") ghcArgs
|
||||
|
||||
-- (globalOptions,_cmdArgs) = parseGlobalArgs modArgs
|
||||
|
||||
-- stripSeperator ("--":rest) = rest
|
||||
-- stripSeperator l = l
|
||||
|
||||
case progName of
|
||||
"ghc-modi" -> do
|
||||
legacyInteractive globalOptions =<< emptyNewUnGetLine
|
||||
|
||||
|
||||
_
|
||||
-- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do
|
||||
-- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith
|
||||
|
||||
-- | "--interactive" `elem` ghcArgs -> do
|
||||
-- let interactiveOptions = if "--ghc-mod" `elem` ghcArgs
|
||||
-- then def { ghcModExtensions = True }
|
||||
-- else def
|
||||
|
||||
-- -- TODO: pass ghcArgs' to ghc API
|
||||
-- putStrLn "\ninteractive\n"
|
||||
-- --print realGhcArgs
|
||||
-- (res, _) <- runGhcModT globalOptions $ undefined
|
||||
-- case res of
|
||||
-- Right s -> putStr s
|
||||
-- Left e -> exitError $ render (gmeDoc e)
|
||||
|
||||
|
||||
| otherwise -> do
|
||||
(res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs
|
||||
case res of
|
||||
Right s -> putStr s
|
||||
Left e -> exitError $
|
||||
renderStyle style { ribbonsPerLine = 1.2 } (gmeDoc e)
|
||||
|
||||
-- Obtain ghc options by letting ourselfs be executed by
|
||||
-- @cabal repl@
|
||||
-- TODO: need to do something about non-cabal projects
|
||||
-- exe <- ghcModExecutable
|
||||
-- let cabalArgs = ["repl", "-v0", "--with-ghc="++exe]
|
||||
-- ++ (("--ghc-option="++) `map` ("--ghc-mod":"--":args))
|
||||
|
||||
-- print cabalArgs
|
||||
|
||||
-- rawSystem "cabal" cabalArgs >>= exitWith
|
||||
|
||||
|
||||
|
||||
-- ghc-modi
|
||||
legacyInteractive :: Options -> UnGetLine -> IO ()
|
||||
legacyInteractive opt ref = flip catches handlers $ do
|
||||
(res,_) <- runGhcModT opt $ do
|
||||
symdbreq <- liftIO $ newSymDbReq opt
|
||||
world <- liftIO . getCurrentWorld =<< cradle
|
||||
legacyInteractiveLoop symdbreq ref world
|
||||
|
||||
(res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs
|
||||
case res of
|
||||
Right () -> return ()
|
||||
Left e -> putStrLn $ notGood $ render (gmeDoc e)
|
||||
|
||||
where
|
||||
handlers = [ Handler $ \Restart -> legacyInteractive opt ref ]
|
||||
|
||||
isExitCodeException :: SomeException -> Bool
|
||||
isExitCodeException e = isJust mExitCode
|
||||
where
|
||||
mExitCode :: Maybe ExitCode
|
||||
mExitCode = fromException e
|
||||
Left e -> exitError $ renderStyle ghcModStyle (gmeDoc e)
|
||||
|
||||
-- ghc-modi
|
||||
legacyInteractive :: IOish m => GhcModT m ()
|
||||
legacyInteractive =
|
||||
liftIO emptyNewUnGetLine >>= \ref -> do
|
||||
opt <- options
|
||||
symdbreq <- liftIO $ newSymDbReq opt
|
||||
world <- liftIO . getCurrentWorld =<< cradle
|
||||
legacyInteractiveLoop symdbreq ref world
|
||||
|
||||
bug :: String -> IO ()
|
||||
bug msg = do
|
||||
@ -449,7 +363,6 @@ escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
|
||||
replace :: String -> String -> String -> String
|
||||
replace needle replacement = intercalate replacement . splitOn needle
|
||||
|
||||
|
||||
legacyInteractiveLoop :: IOish m
|
||||
=> SymDbReq -> UnGetLine -> World -> GhcModT m ()
|
||||
legacyInteractiveLoop symdbreq ref world = do
|
||||
@ -465,8 +378,6 @@ legacyInteractiveLoop symdbreq ref world = do
|
||||
liftIO $ ungetCommand ref cmdArg
|
||||
throw Restart
|
||||
|
||||
liftIO . prepareAutogen =<< cradle
|
||||
|
||||
let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg
|
||||
arg = concat args'
|
||||
cmd = dropWhileEnd isSpace cmd'
|
||||
@ -497,7 +408,6 @@ legacyInteractiveLoop symdbreq ref world = do
|
||||
liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout
|
||||
legacyInteractiveLoop symdbreq ref world
|
||||
|
||||
|
||||
globalCommands :: [String] -> Maybe String
|
||||
globalCommands [] = Nothing
|
||||
globalCommands (cmd:_) = case cmd of
|
||||
@ -505,11 +415,12 @@ globalCommands (cmd:_) = case cmd of
|
||||
_ | cmd == "version" || cmd == "--version" -> Just progVersion
|
||||
_ -> Nothing
|
||||
|
||||
ghcCommands :: IOish m => [String] -> GhcModT m String
|
||||
ghcCommands :: IOish m => [String] -> GhcModT m ()
|
||||
ghcCommands [] = fatalError "No command given (try --help)"
|
||||
ghcCommands (cmd:args) = fn args
|
||||
ghcCommands (cmd:args) = do
|
||||
liftIO . putStr =<< action args
|
||||
where
|
||||
fn = case cmd of
|
||||
action = case cmd of
|
||||
_ | cmd == "list" || cmd == "modules" -> modulesCmd
|
||||
"lang" -> languagesCmd
|
||||
"flag" -> flagsCmd
|
||||
@ -530,8 +441,11 @@ ghcCommands (cmd:args) = fn args
|
||||
"doc" -> pkgDocCmd
|
||||
"dumpsym" -> dumpSymbolCmd
|
||||
"boot" -> bootCmd
|
||||
"legacy-interactive" -> legacyInteractiveCmd
|
||||
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
|
||||
|
||||
|
||||
|
||||
newtype FatalError = FatalError String deriving (Show, Typeable)
|
||||
instance Exception FatalError
|
||||
|
||||
@ -543,7 +457,7 @@ exitError :: String -> IO a
|
||||
exitError msg = hPutStrLn stderr (dropWhileEnd (=='\n') msg) >> exitFailure
|
||||
|
||||
fatalError :: String -> a
|
||||
fatalError s = throw $ FatalError $ progName ++ ": " ++ s
|
||||
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
|
||||
|
||||
withParseCmd :: IOish m
|
||||
=> [OptDescr (Options -> Options)]
|
||||
@ -569,8 +483,9 @@ catchArgs cmd action =
|
||||
throw $ InvalidCommandLine (Left cmd)
|
||||
|
||||
modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
|
||||
debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd,
|
||||
findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd
|
||||
debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
|
||||
refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd,
|
||||
dumpSymbolCmd, bootCmd, legacyInteractiveCmd
|
||||
:: IOish m => [String] -> GhcModT m String
|
||||
|
||||
modulesCmd = withParseCmd' "modules" s $ \[] -> modules
|
||||
@ -604,6 +519,8 @@ infoCmd = withParseCmd [] $ action
|
||||
action [file,expr] = info file expr
|
||||
action _ = throw $ InvalidCommandLine (Left "info")
|
||||
|
||||
legacyInteractiveCmd = withParseCmd [] $ \[] -> legacyInteractive >> return ""
|
||||
|
||||
checkAction :: ([t] -> a) -> [t] -> a
|
||||
checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.")
|
||||
checkAction action files = action files
|
||||
|
||||
262
src/GHCModi.hs
262
src/GHCModi.hs
@ -1,262 +1,16 @@
|
||||
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
|
||||
|
||||
-- | WARNING
|
||||
-- This program in the process of being deprecated, use `ghc-mod --interactive`
|
||||
-- instead.
|
||||
|
||||
-- Commands:
|
||||
-- check <file>
|
||||
-- find <symbol>
|
||||
-- info <file> <expr>
|
||||
-- type <file> <line> <column>
|
||||
-- lint [hlint options] <file>
|
||||
-- the format of hlint options is [String] because they may contain
|
||||
-- spaces and also <file> may contain spaces.
|
||||
-- boot
|
||||
-- browse [<package>:]<module>
|
||||
-- quit
|
||||
--
|
||||
-- Session separators:
|
||||
-- OK -- success
|
||||
-- NG -- failure
|
||||
-- This program is deprecated, use `ghc-mod legacy-interactive` instead.
|
||||
|
||||
module Main where
|
||||
|
||||
import Config (cProjectVersion)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Exception (SomeException(..))
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad (when)
|
||||
import CoreMonad (liftIO)
|
||||
import Data.List (intercalate)
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Version (showVersion)
|
||||
import Language.Haskell.GhcMod
|
||||
import Language.Haskell.GhcMod.Internal
|
||||
import Paths_ghc_mod
|
||||
import System.Console.GetOpt
|
||||
import System.Directory (setCurrentDirectory)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (ExitCode, exitFailure)
|
||||
import System.IO (hFlush,stdout)
|
||||
|
||||
import Misc
|
||||
import Utils
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
progVersion :: String
|
||||
progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
|
||||
|
||||
argspec :: [OptDescr (Options -> Options)]
|
||||
argspec = [ Option "b" ["boundary"]
|
||||
(ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")
|
||||
"specify line separator (default is Nul string)"
|
||||
, Option "l" ["tolisp"]
|
||||
(NoArg (\opts -> opts { outputStyle = LispStyle }))
|
||||
"print as a list of Lisp"
|
||||
, Option "g" []
|
||||
(ReqArg (\s opts -> opts { ghcUserOptions = s : ghcUserOptions opts }) "flag") "specify a ghc flag"
|
||||
]
|
||||
|
||||
usage :: String
|
||||
usage = progVersion
|
||||
++ "Usage:\n"
|
||||
++ "\t ghc-modi [-l] [-b sep] [-g flag]\n"
|
||||
++ "\t ghc-modi version\n"
|
||||
++ "\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)
|
||||
(_,_,errs) -> E.throw (CmdArg errs)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- Running two GHC monad threads disables the handling of
|
||||
-- C-c since installSignalHandlers is called twice, sigh.
|
||||
import System.Exit
|
||||
import System.Process
|
||||
import System.Environment
|
||||
|
||||
main :: IO ()
|
||||
main = E.handle cmdHandler $
|
||||
go =<< parseArgs argspec <$> getArgs
|
||||
where
|
||||
cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
|
||||
go (_,"help":_) = putStr $ usageInfo usage argspec
|
||||
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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
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 $ didWorldChange world crdl
|
||||
when changed $ do
|
||||
liftIO $ ungetCommand ref cmdArg
|
||||
E.throw Restart
|
||||
cradle >>= liftIO . prepareAutogen
|
||||
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)
|
||||
if ok then do
|
||||
liftIO $ putStr ret
|
||||
liftIO $ putStrLn "OK"
|
||||
else do
|
||||
liftIO $ putStrLn $ notGood ret
|
||||
liftIO $ hFlush stdout
|
||||
when ok $ loop symdbreq ref world
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
checkStx :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
checkStx file = do
|
||||
eret <- check [file]
|
||||
case eret of
|
||||
Right ret -> return (ret, True)
|
||||
Left ret -> return (ret, True)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
|
||||
findSym sym symdbreq = do
|
||||
db <- getDb symdbreq >>= checkDb symdbreq
|
||||
ret <- lookupSymbol sym db
|
||||
return (ret, True)
|
||||
|
||||
lintStx :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
lintStx optFile = do
|
||||
ret <- withOptions changeOpt $ lint file
|
||||
return (ret, True)
|
||||
where
|
||||
(opts,file) = parseLintOptions optFile
|
||||
hopts = if opts == "" then [] else read opts
|
||||
changeOpt o = o { hlintOpts = hopts }
|
||||
|
||||
-- |
|
||||
-- >>> 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)
|
||||
(opt',file') -> (opt', dropWhile (== ' ') file')
|
||||
where
|
||||
brk _ [] = ([],[])
|
||||
brk p (x:xs')
|
||||
| p x = ([x],xs')
|
||||
| otherwise = let (ys,zs) = brk p xs' in (x:ys,zs)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
showInfo :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
showInfo fileArg = do
|
||||
let [file, expr] = splitN 2 fileArg
|
||||
ret <- info file expr
|
||||
return (ret, True)
|
||||
|
||||
showType :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
showType fileArg = do
|
||||
let [file, line, column] = splitN 3 fileArg
|
||||
ret <- types file (read line) (read column)
|
||||
return (ret, True)
|
||||
|
||||
doSplit :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
doSplit fileArg = do
|
||||
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
|
||||
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
|
||||
let [file, line, column, expr] = splitN 4 fileArg
|
||||
ret <- refine file (read line) (read column) expr
|
||||
return (ret, True)
|
||||
|
||||
doAuto :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
doAuto fileArg = do
|
||||
let [file, line, column] = splitN 3 fileArg
|
||||
ret <- auto file (read line) (read column)
|
||||
return (ret, True)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
bootIt :: IOish m => GhcModT m (String, Bool)
|
||||
bootIt = do
|
||||
ret <- boot
|
||||
return (ret, True)
|
||||
|
||||
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
|
||||
setDetailed opt = opt { detailed = True }
|
||||
main = do
|
||||
args <- getArgs
|
||||
h <- spawnProcess "ghc-mod" $ ["legacy-interactive"] ++ args
|
||||
exitWith =<< waitForProcess h
|
||||
|
||||
68
src/Misc.hs
68
src/Misc.hs
@ -11,22 +11,14 @@ module Misc (
|
||||
, newSymDbReq
|
||||
, getDb
|
||||
, checkDb
|
||||
, prepareAutogen
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (Async, async, wait)
|
||||
import Control.Exception (Exception)
|
||||
import Control.Monad (unless, when)
|
||||
import CoreMonad (liftIO)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Typeable (Typeable)
|
||||
import System.Directory (doesDirectoryExist, getDirectoryContents)
|
||||
import System.IO (openBinaryFile, IOMode(..))
|
||||
import System.Process
|
||||
|
||||
import Language.Haskell.GhcMod
|
||||
import Language.Haskell.GhcMod.Internal
|
||||
@ -92,63 +84,3 @@ checkDb (SymDbReq ref act) db = do
|
||||
hoistGhcModT =<< liftIO (wait req)
|
||||
else
|
||||
return db
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
build :: IO ProcessHandle
|
||||
build = do
|
||||
#ifdef WINDOWS
|
||||
nul <- openBinaryFile "NUL" AppendMode
|
||||
#else
|
||||
nul <- openBinaryFile "/dev/null" AppendMode
|
||||
#endif
|
||||
(_, _, _, hdl) <- createProcess $ pro nul
|
||||
return hdl
|
||||
where
|
||||
pro nul = CreateProcess {
|
||||
cmdspec = RawCommand "cabal" ["build"]
|
||||
, cwd = Nothing
|
||||
, env = Nothing
|
||||
, std_in = Inherit
|
||||
, std_out = UseHandle nul
|
||||
, std_err = UseHandle nul
|
||||
, close_fds = False
|
||||
#if __GLASGOW_HASKELL__ >= 702
|
||||
, create_group = True
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 707
|
||||
, delegate_ctlc = False
|
||||
#endif
|
||||
}
|
||||
|
||||
autogen :: String
|
||||
autogen = "dist/build/autogen"
|
||||
|
||||
isAutogenPrepared :: IO Bool
|
||||
isAutogenPrepared = do
|
||||
exist <- doesDirectoryExist autogen
|
||||
if exist then do
|
||||
files <- filter ("." `isPrefixOf`) <$> getDirectoryContents autogen
|
||||
if length files >= 2 then
|
||||
return True
|
||||
else
|
||||
return False
|
||||
else
|
||||
return False
|
||||
|
||||
watch :: Int -> ProcessHandle -> IO ()
|
||||
watch 0 _ = return ()
|
||||
watch n hdl = do
|
||||
prepared <- isAutogenPrepared
|
||||
if prepared then
|
||||
interruptProcessGroupOf hdl
|
||||
else do
|
||||
threadDelay 100000
|
||||
watch (n - 1) hdl
|
||||
|
||||
prepareAutogen :: Cradle -> IO ()
|
||||
prepareAutogen crdl = when (isJust $ cradleCabalFile crdl) $ do
|
||||
prepared <- isAutogenPrepared
|
||||
unless prepared $ do
|
||||
hdl <- build
|
||||
watch 30 hdl
|
||||
|
||||
Loading…
Reference in New Issue
Block a user