module HsDev.Tools.ClearImports (
dumpMinimalImports, waitImports, cleanTmpImports,
findMinimalImports,
groupImports, splitImport,
clearImports
) where
import Control.Arrow
import Control.Concurrent (threadDelay)
import Control.Exception
import Control.Monad.Error
import Data.Char
import Data.List
import System.Directory
import System.FilePath
import qualified Language.Haskell.Exts as Exts
import GHC
import GHC.Paths (libdir)
import HsDev.Util
dumpMinimalImports :: [String] -> FilePath -> ErrorT String IO String
dumpMinimalImports opts f = do
cur <- liftE getCurrentDirectory
file <- liftE $ canonicalizePath f
m <- liftE $ Exts.parseFile file
mname <- case m of
Exts.ParseFailed loc err -> throwError $
"Failed to parse file at " ++
Exts.prettyPrint loc ++ ":" ++ err
Exts.ParseOk (Exts.Module _ (Exts.ModuleName mname) _ _ _ _ _) -> return mname
void $ liftE $ runGhc (Just libdir) $ do
df <- getSessionDynFlags
let
df' = df {
ghcLink = NoLink,
hscTarget = HscNothing,
dumpDir = Just cur,
stubDir = Just cur,
objectDir = Just cur,
hiDir = Just cur }
(df'', _, _) <- parseDynamicFlags df' (map noLoc ("-ddump-minimal-imports" : opts))
_ <- setSessionDynFlags df''
defaultCleanupHandler df'' $ do
t <- guessTarget file Nothing
setTargets [t]
load LoadAllTargets
length mname `seq` return mname
waitImports :: FilePath -> IO [String]
waitImports f = retry 1000 $ do
is <- liftM lines $ readFile f
length is `seq` return is
cleanTmpImports :: FilePath -> IO ()
cleanTmpImports dir = do
dumps <- liftM (map (dir </>) . filter ((== ".imports") . takeExtension)) $ getDirectoryContents dir
forM_ dumps $ handle ignoreIO' . retry 1000 . removeFile
where
ignoreIO' :: IOException -> IO ()
ignoreIO' _ = return ()
findMinimalImports :: [String] -> FilePath -> ErrorT String IO [String]
findMinimalImports opts f = do
file <- liftE $ canonicalizePath f
mname <- dumpMinimalImports opts file
is <- liftE $ waitImports (mname <.> "imports")
tmp <- liftE getCurrentDirectory
liftE $ cleanTmpImports tmp
return is
groupImports :: [String] -> [[String]]
groupImports = unfoldr getPack where
getPack [] = Nothing
getPack (s:ss) = Just $ first (s:) $ break (null . takeWhile isSpace) ss
splitImport :: [String] -> (String, String)
splitImport = splitBraces . unwords . map trim where
cut = twice $ reverse . drop 1
twice f = f . f
splitBraces = (trim *** (trim . cut)) . break (== '(')
clearImports :: [String] -> FilePath -> ErrorT String IO [(String, String)]
clearImports opts = liftM (map splitImport . groupImports) . findMinimalImports opts
retry :: (MonadPlus m, MonadIO m) => Int -> m a -> m a
retry dt act = msum $ act : repeat ((liftIO (threadDelay dt) >>) act)