module Language.Haskell.Modules.Params
( Params(Params, dryRun, extraImports, hsFlags, junk, moduVerse,
removeEmptyImports, scratchDir, testMode, verbosity)
, CleanT
, MonadClean(getParams, putParams)
, modifyParams
, runCleanT
, markForDelete
, modifyRemoveEmptyImports
, modifyHsFlags
, modifyDryRun
, modifyTestMode
, extraImport
) where
import Control.Exception (SomeException, try)
import Control.Monad.Trans.Control as IO (MonadBaseControl)
import Control.Monad.State (MonadState(get, put), StateT(runStateT))
import Control.Monad.Trans (liftIO, MonadIO)
import Data.Map as Map (empty, Map, insertWith)
import Data.Set as Set (empty, insert, Set, singleton, toList, union)
import Language.Haskell.Exts.SrcLoc (SrcLoc(SrcLoc))
import Language.Haskell.Exts.Syntax as S (ImportDecl(..), ModuleName)
import Language.Haskell.Modules.ModuVerse (ModuVerse(..), moduVerseInit, ModuVerseState)
import Language.Haskell.Modules.Util.DryIO (MonadDryRun(..))
import Language.Haskell.Modules.Util.QIO (MonadVerbosity(..))
import Language.Haskell.Modules.Util.Temp (withTempDirectory)
import Prelude hiding (writeFile, writeFile)
import System.Directory (removeFile)
data Params
= Params
{ scratchDir :: FilePath
, dryRun :: Bool
, verbosity :: Int
, hsFlags :: [String]
, moduVerse :: ModuVerseState
, junk :: Set FilePath
, removeEmptyImports :: Bool
, extraImports :: Map S.ModuleName (Set S.ImportDecl)
, testMode :: Bool
} deriving (Eq, Ord, Show)
type CleanT m = StateT Params m
instance MonadClean m => ModuVerse m where
getModuVerse = getParams >>= return . moduVerse
modifyModuVerse f = modifyParams (\ p -> p {moduVerse = f (moduVerse p)})
class (MonadIO m, MonadBaseControl IO m, Functor m) => MonadClean m where
getParams :: m Params
putParams :: Params -> m ()
modifyParams :: MonadClean m => (Params -> Params) -> m ()
modifyParams f = getParams >>= putParams . f
instance (MonadIO m, MonadBaseControl IO m, Functor m) => MonadClean (CleanT 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})
runCleanT :: (MonadIO m, MonadBaseControl IO m) => CleanT m a -> m a
runCleanT action =
withTempDirectory "." "scratch" $ \ scratch ->
do (result, params) <- runStateT action (Params {scratchDir = scratch,
dryRun = False,
verbosity = 1,
hsFlags = [],
moduVerse = moduVerseInit,
junk = Set.empty,
removeEmptyImports = True,
extraImports = Map.empty,
testMode = False})
mapM_ (\ x -> liftIO (try (removeFile x)) >>= \ (_ :: Either SomeException ()) -> return ()) (toList (junk params))
return result
markForDelete :: MonadClean m => FilePath -> m ()
markForDelete x = modifyParams (\ p -> p {junk = insert x (junk p)})
modifyRemoveEmptyImports :: MonadClean m => (Bool -> Bool) -> m ()
modifyRemoveEmptyImports f = modifyParams (\ p -> p {removeEmptyImports = f (removeEmptyImports p)})
modifyHsFlags :: MonadClean m => ([String] -> [String]) -> m ()
modifyHsFlags f = modifyParams (\ p -> p {hsFlags = f (hsFlags p)})
modifyDryRun :: MonadClean m => (Bool -> Bool) -> m ()
modifyDryRun f = modifyParams (\ p -> p {dryRun = f (dryRun p)})
modifyTestMode :: MonadClean m => (Bool -> Bool) -> m ()
modifyTestMode f = modifyParams (\ p -> p {testMode = f (testMode p)})
extraImport :: MonadClean m => S.ModuleName -> S.ModuleName -> m ()
extraImport m i =
modifyParams (\ p -> p {extraImports = Map.insertWith (union) m (singleton im) (extraImports p)})
where im = ImportDecl { importLoc = SrcLoc "<unknown>.hs" 1 1
, importModule = i
, importQualified = False
, importSrc = False
, importPkg = Nothing
, importAs = Nothing
, importSpecs = Just (False, []) }