module Language.Haskell.Modules.Internal
( runMonadClean
, modifyParams
, parseFileWithComments
, parseFile
, modulePath
, markForDelete
, Params(..)
, MonadClean(getParams, putParams)
, ModuleResult(..)
, doResult
) where
import Control.Applicative ((<$>))
import Control.Exception (SomeException, try)
import "MonadCatchIO-mtl" Control.Monad.CatchIO as IO (catch, MonadCatchIO, throw)
import Control.Monad.State (MonadState(get, put), StateT(runStateT))
import Control.Monad.Trans (liftIO, MonadIO)
import Data.Set (empty, insert, Set, toList)
import qualified Language.Haskell.Exts.Annotated as A (Module, parseFileWithComments, parseFileWithMode)
import Language.Haskell.Exts.Comments (Comment)
import Language.Haskell.Exts.Extension (Extension)
import qualified Language.Haskell.Exts.Parser as Exts (defaultParseMode, ParseMode(extensions), ParseResult)
import Language.Haskell.Exts.SrcLoc (SrcSpanInfo)
import qualified Language.Haskell.Exts.Syntax as S (ModuleName)
import Language.Haskell.Modules.Common (modulePathBase)
import Language.Haskell.Modules.Util.DryIO (createDirectoryIfMissing, MonadDryRun(..), removeFileIfPresent, replaceFile, tildeBackup)
import Language.Haskell.Modules.Util.QIO (MonadVerbosity(..), qPutStr, qPutStrLn, quietly)
import Language.Haskell.Modules.Util.Temp (withTempDirectory)
import Prelude hiding (writeFile)
import System.Directory (doesFileExist, getCurrentDirectory, removeFile)
import System.FilePath ((</>), dropExtension, takeDirectory)
import System.IO.Error (isDoesNotExistError)
data Params
= Params
{ scratchDir :: FilePath
, dryRun :: Bool
, verbosity :: Int
, extensions :: [Extension]
, hsFlags :: [String]
, sourceDirs :: [FilePath]
, moduVerse :: Maybe (Set S.ModuleName)
, junk :: Set FilePath
, removeEmptyImports :: Bool
, testMode :: Bool
} deriving (Eq, Ord, Show)
class (MonadIO m, MonadCatchIO m, Functor m) => MonadClean m where
getParams :: m Params
putParams :: Params -> m ()
modifyParams :: MonadClean m => (Params -> Params) -> m ()
modifyParams f = getParams >>= putParams . f
instance (MonadCatchIO m, Functor m) => MonadClean (StateT Params m) where
getParams = get
putParams = put
instance MonadClean m => MonadVerbosity m where
getVerbosity = getParams >>= return . verbosity
putVerbosity v = modifyParams (\ p -> p {verbosity = v})
instance MonadClean m => MonadDryRun m where
dry = getParams >>= return . dryRun
putDry x = modifyParams (\ p -> p {dryRun = x})
runMonadClean :: MonadCatchIO m => StateT Params m a -> m a
runMonadClean action =
withTempDirectory "." "scratch" $ \ scratch ->
do (result, params) <- runStateT action (Params {scratchDir = scratch,
dryRun = False,
verbosity = 0,
hsFlags = [],
extensions = Exts.extensions Exts.defaultParseMode,
sourceDirs = ["."],
moduVerse = Nothing,
junk = empty,
removeEmptyImports = True,
testMode = False})
mapM_ (\ x -> liftIO (try (removeFile x)) >>= \ (_ :: Either SomeException ()) -> return ()) (toList (junk params))
return result
parseFileWithComments :: MonadClean m => FilePath -> m (Exts.ParseResult (A.Module SrcSpanInfo, [Comment]))
parseFileWithComments path =
do exts <- getParams >>= return . extensions
liftIO (A.parseFileWithComments (Exts.defaultParseMode {Exts.extensions = exts}) path)
parseFile :: MonadClean m => FilePath -> m (Exts.ParseResult (A.Module SrcSpanInfo))
parseFile path =
do exts <- getParams >>= return . extensions
liftIO (A.parseFileWithMode (Exts.defaultParseMode {Exts.extensions = exts}) path)
findSourcePath :: MonadClean m => FilePath -> m FilePath
findSourcePath path =
findFile =<< (sourceDirs <$> getParams)
where
findFile (dir : dirs) =
do let x = dir </> path
exists <- liftIO $ doesFileExist x
if exists then return x else findFile dirs
findFile [] =
do
here <- liftIO getCurrentDirectory
dirs <- sourceDirs <$> getParams
liftIO . throw . userError $ "findSourcePath failed, cwd=" ++ here ++ ", dirs=" ++ show dirs ++ ", path=" ++ path
modulePath :: MonadClean m => S.ModuleName -> m FilePath
modulePath name =
findSourcePath (modulePathBase name) `catch` (\ (_ :: IOError) -> makePath)
where
makePath =
do dirs <- sourceDirs <$> getParams
case dirs of
[] -> return (modulePathBase name)
(d : _) -> return $ d </> modulePathBase name
markForDelete :: MonadClean m => FilePath -> m ()
markForDelete x = modifyParams (\ p -> p {junk = insert x (junk p)})
data ModuleResult
= Unchanged S.ModuleName
| Removed S.ModuleName
| Modified S.ModuleName String
| Created S.ModuleName String
deriving (Show, Eq, Ord)
doResult :: MonadClean m => ModuleResult -> m ModuleResult
doResult x@(Unchanged _name) =
do quietly (qPutStrLn ("unchanged: " ++ show _name))
return x
doResult x@(Removed name) =
do path <- modulePath name
removeFileIfPresent path `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return () else throw e)
return x
doResult x@(Modified name text) =
do path <- modulePath name
qPutStr ("catModules: modifying " ++ show path)
quietly (qPutStr (" new text: " ++ show text))
qPutStr "\n"
replaceFile tildeBackup path text
return x
doResult x@(Created name text) =
do path <- modulePath name
qPutStr ("catModules: creating " ++ show path)
quietly (qPutStr (" containing " ++ show text))
qPutStr "\n"
createDirectoryIfMissing True (takeDirectory . dropExtension $ path)
replaceFile tildeBackup path text
return x