Add nuke-caches command
This commit is contained in:
parent
bad431a758
commit
d863e90775
@ -11,13 +11,16 @@ import Data.Version (showVersion)
|
|||||||
import Data.List
|
import Data.List
|
||||||
import Data.List.Split
|
import Data.List.Split
|
||||||
import Data.Char (isSpace)
|
import Data.Char (isSpace)
|
||||||
|
import Data.Maybe
|
||||||
import Exception
|
import Exception
|
||||||
import Language.Haskell.GhcMod
|
import Language.Haskell.GhcMod
|
||||||
import Language.Haskell.GhcMod.Internal
|
import Language.Haskell.GhcMod.Internal
|
||||||
import Paths_ghc_mod
|
import Paths_ghc_mod
|
||||||
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
|
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
|
||||||
import qualified System.Console.GetOpt as O
|
import qualified System.Console.GetOpt as O
|
||||||
import System.Directory (setCurrentDirectory)
|
import System.FilePath ((</>))
|
||||||
|
import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
|
||||||
|
removeDirectoryRecursive)
|
||||||
import System.Environment (getArgs)
|
import System.Environment (getArgs)
|
||||||
import System.Exit (exitFailure)
|
import System.Exit (exitFailure)
|
||||||
import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush)
|
import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush)
|
||||||
@ -439,10 +442,9 @@ ghcCommands (cmd:args) = do
|
|||||||
"dumpsym" -> dumpSymbolCmd
|
"dumpsym" -> dumpSymbolCmd
|
||||||
"boot" -> bootCmd
|
"boot" -> bootCmd
|
||||||
"legacy-interactive" -> legacyInteractiveCmd
|
"legacy-interactive" -> legacyInteractiveCmd
|
||||||
|
"nuke-caches" -> nukeCachesCmd
|
||||||
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
|
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
newtype FatalError = FatalError String deriving (Show, Typeable)
|
newtype FatalError = FatalError String deriving (Show, Typeable)
|
||||||
instance Exception FatalError
|
instance Exception FatalError
|
||||||
|
|
||||||
@ -482,7 +484,7 @@ catchArgs cmd action =
|
|||||||
modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
|
modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
|
||||||
debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
|
debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
|
||||||
refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd,
|
refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd,
|
||||||
dumpSymbolCmd, bootCmd, legacyInteractiveCmd
|
dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd
|
||||||
:: IOish m => [String] -> GhcModT m String
|
:: IOish m => [String] -> GhcModT m String
|
||||||
|
|
||||||
modulesCmd = withParseCmd' "modules" s $ \[] -> modules
|
modulesCmd = withParseCmd' "modules" s $ \[] -> modules
|
||||||
@ -494,6 +496,7 @@ rootInfoCmd = withParseCmd' "root" [] $ \[] -> rootInfo
|
|||||||
componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts
|
componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts
|
||||||
-- internal
|
-- internal
|
||||||
bootCmd = withParseCmd' "boot" [] $ \[] -> boot
|
bootCmd = withParseCmd' "boot" [] $ \[] -> boot
|
||||||
|
nukeCachesCmd = withParseCmd' "nuke-caches" [] $ \[] -> nukeCaches >> return ""
|
||||||
|
|
||||||
dumpSymbolCmd = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir
|
dumpSymbolCmd = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir
|
||||||
findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym
|
findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym
|
||||||
@ -555,3 +558,16 @@ browseArgSpec =
|
|||||||
, option "q" ["qualified"] "Qualify symbols" $
|
, option "q" ["qualified"] "Qualify symbols" $
|
||||||
NoArg $ \o -> o { qualified = True }
|
NoArg $ \o -> o { qualified = True }
|
||||||
]
|
]
|
||||||
|
|
||||||
|
nukeCaches :: IOish m => GhcModT m ()
|
||||||
|
nukeCaches = do
|
||||||
|
chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
|
||||||
|
c <- cradle
|
||||||
|
|
||||||
|
when (isJust $ cradleCabalFile c) $ do
|
||||||
|
let root = cradleRootDir c
|
||||||
|
when (isJust $ cradleCabalFile c) $
|
||||||
|
liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> "dist"]
|
||||||
|
|
||||||
|
trySome :: IO a -> IO (Either SomeException a)
|
||||||
|
trySome = try
|
||||||
|
Loading…
Reference in New Issue
Block a user