From 3c76ba412f85d2541412e0622de4f7889366657f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 29 Apr 2015 18:44:46 +0200 Subject: [PATCH] Start rolling ghc-modi into the ghc-mod executable --- elisp/ghc-process.el | 8 +- src/GHCMod.hs | 175 ++++++++--------------------- src/GHCModi.hs | 262 ++----------------------------------------- src/Misc.hs | 68 ----------- 4 files changed, 58 insertions(+), 455 deletions(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 00aed43..7b09a26 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -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) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index df1985b..8d54aab 100644 --- a/src/GHCMod.hs +++ b/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 diff --git a/src/GHCModi.hs b/src/GHCModi.hs index c9e958c..0238957 100644 --- a/src/GHCModi.hs +++ b/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 --- find --- info --- type --- lint [hlint options] --- the format of hlint options is [String] because they may contain --- spaces and also may contain spaces. --- boot --- browse [:] --- 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 diff --git a/src/Misc.hs b/src/Misc.hs index 21248ad..f7f622e 100644 --- a/src/Misc.hs +++ b/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