Cleanup project type handling

This commit is contained in:
Daniel Gröber 2015-08-12 09:25:13 +02:00
parent a94d8977a9
commit 28f06e035d
7 changed files with 33 additions and 36 deletions

View File

@ -3,6 +3,7 @@
module Language.Haskell.GhcMod (
-- * Cradle
Cradle(..)
, ProjectType(..)
, findCradle
-- * Options
, Options(..)

View File

@ -29,7 +29,7 @@ findCradle = findCradle' =<< getCurrentDirectory
findCradle' :: FilePath -> IO Cradle
findCradle' dir = run $ do
(customCradle dir `mplus` cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir)
(cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir)
where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
findSpecCradle :: FilePath -> IO Cradle
@ -53,17 +53,6 @@ fillTempDir crdl = do
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
return crdl { cradleTempDir = tmpDir }
customCradle :: FilePath -> MaybeT IO Cradle
customCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = cabalDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile
}
cabalCradle :: FilePath -> MaybeT IO Cradle
cabalCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir
@ -71,7 +60,8 @@ cabalCradle wdir = do
let cabalDir = takeDirectory cabalFile
return Cradle {
cradleCurrentDir = wdir
cradleProjectType = CabalProject
, cradleCurrentDir = wdir
, cradleRootDir = cabalDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile
@ -81,7 +71,8 @@ sandboxCradle :: FilePath -> MaybeT IO Cradle
sandboxCradle wdir = do
sbDir <- MaybeT $ findCabalSandboxDir wdir
return Cradle {
cradleCurrentDir = wdir
cradleProjectType = SandboxProject
, cradleCurrentDir = wdir
, cradleRootDir = sbDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
@ -90,7 +81,8 @@ sandboxCradle wdir = do
plainCradle :: FilePath -> MaybeT IO Cradle
plainCradle wdir = do
return $ Cradle {
cradleCurrentDir = wdir
cradleProjectType = PlainProject
, cradleCurrentDir = wdir
, cradleRootDir = wdir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing

View File

@ -26,9 +26,9 @@ debugInfo = do
Cradle {..} <- cradle
cabal <-
case cradleCabalFile of
Just _ -> cabalDebug
Nothing -> return []
case cradleProjectType of
CabalProject -> cabalDebug
_ -> return []
pkgOpts <- packageGhcOptions

View File

@ -61,14 +61,14 @@ ghcDbOpt (PackageDb pkgDb)
getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]
getPackageCachePaths sysPkgCfg = do
crdl <- cradle
pkgDbStack <- if isJust $ cradleCabalFile crdl
then do
getPackageDbStack
else do
mdb <- liftIO $ getSandboxDb $ cradleRootDir crdl
return $ case mdb of
Just db -> [db]
Nothing -> [GlobalDb, UserDb]
pkgDbStack <- case cradleProjectType crdl of
PlainProject ->
return [GlobalDb, UserDb]
SandboxProject -> do
Just db <- liftIO $ getSandboxDb $ cradleRootDir crdl
return $ [GlobalDb, db]
CabalProject ->
getPackageDbStack
catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack

View File

@ -176,9 +176,9 @@ targetGhcOptions :: forall m. IOish m
targetGhcOptions crdl sefnmn = do
when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"
case cradleCabalFile crdl of
Just _ -> cabalOpts crdl
Nothing -> sandboxOpts crdl
case cradleProjectType crdl of
CabalProject -> cabalOpts crdl
_ -> sandboxOpts crdl
where
zipMap f l = l `zip` (f `map` l)
@ -288,10 +288,11 @@ packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
=> m [GHCOption]
packageGhcOptions = do
crdl <- cradle
case cradleCabalFile crdl of
Just _ -> getGhcMergedPkgOptions
Nothing -> sandboxOpts crdl
case cradleProjectType crdl of
CabalProject -> getGhcMergedPkgOptions
_ -> sandboxOpts crdl
-- also works for plain projects!
sandboxOpts :: MonadIO m => Cradle -> m [String]
sandboxOpts crdl = do
pkgDbStack <- liftIO $ getSandboxPackageDbStack $ cradleRootDir crdl

View File

@ -109,10 +109,14 @@ defaultOptions = Options {
----------------------------------------------------------------
data ProjectType = CabalProject | SandboxProject | PlainProject
deriving (Eq, Show)
-- | The environment where this library is used.
data Cradle = Cradle {
cradleProjectType:: ProjectType
-- | The directory where this library is executed.
cradleCurrentDir :: FilePath
, cradleCurrentDir :: FilePath
-- | The project root directory.
, cradleRootDir :: FilePath
-- | Per-Project temporary directory

View File

@ -589,10 +589,9 @@ nukeCaches = do
chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
c <- cradle
when (isJust $ cradleCabalFile c) $ do
when (cradleProjectType c == CabalProject) $ do
let root = cradleRootDir c
when (isJust $ cradleCabalFile c) $
liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> "dist"]
liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> "dist"]
trySome :: IO a -> IO (Either SomeException a)
trySome = try