![Daniel Gröber](/assets/img/avatar_default.png)
This turned out to be quite involved but save for this huge commit it's actually quite awesome and squashes quite a few bugs and nasty problems (hopefully). Most importantly we now have native cabal component support without the user having to do anything to get it! To do this we traverse imports starting from each component's entrypoints (library modules or Main source file for executables) and use this information to find which component's options each module will build with. Under the assumption that these modules have to build with every component they're used in we can now just pick one. Quite a few internal assumptions have been invalidated by this change. Most importantly the runGhcModT* family of cuntions now change the current working directory to `cradleRootDir`.
249 lines
7.8 KiB
Haskell
249 lines
7.8 KiB
Haskell
-- ghc-mod: Making Haskell development *more* fun
|
|
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
|
--
|
|
-- This program is free software: you can redistribute it and/or modify
|
|
-- it under the terms of the GNU Affero General Public License as published by
|
|
-- the Free Software Foundation, either version 3 of the License, or
|
|
-- (at your option) any later version.
|
|
--
|
|
-- This program is distributed in the hope that it will be useful,
|
|
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
-- GNU Affero General Public License for more details.
|
|
--
|
|
-- You should have received a copy of the GNU Affero General Public License
|
|
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
module Language.Haskell.GhcMod.PathsAndFiles where
|
|
|
|
import Config (cProjectVersion)
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.List
|
|
import Data.Char
|
|
import Data.Maybe
|
|
import Data.Traversable (traverse)
|
|
import Types
|
|
import System.Directory
|
|
import System.FilePath
|
|
import System.IO.Unsafe
|
|
|
|
import Language.Haskell.GhcMod.Types
|
|
import Language.Haskell.GhcMod.Error
|
|
import Language.Haskell.GhcMod.Read
|
|
import Language.Haskell.GhcMod.Utils hiding (dropWhileEnd)
|
|
import qualified Language.Haskell.GhcMod.Utils as U
|
|
|
|
-- | Guaranteed to be a path to a directory with no trailing slash.
|
|
type DirPath = FilePath
|
|
|
|
-- | Guaranteed to be the name of a file only (no slashes).
|
|
type FileName = String
|
|
|
|
data Cached d a = Cached {
|
|
inputFiles :: [FilePath],
|
|
inputData :: d,
|
|
cacheFile :: FilePath
|
|
}
|
|
|
|
newtype UnString = UnString { unString :: String }
|
|
|
|
instance Show UnString where
|
|
show = unString
|
|
|
|
instance Read UnString where
|
|
readsPrec _ = \str -> [(UnString str, "")]
|
|
|
|
-- |
|
|
--
|
|
-- >>> any (Just 3 <) [Just 1, Nothing, Just 2]
|
|
-- False
|
|
--
|
|
-- >>> any (Just 0 <) [Just 1, Nothing, Just 2]
|
|
-- True
|
|
--
|
|
-- >>> any (Just 0 <) [Nothing]
|
|
-- False
|
|
--
|
|
-- >>> any (Just 0 <) []
|
|
-- False
|
|
cached :: forall a d. (Read a, Show a, Eq d, Read d, Show d)
|
|
=> DirPath -> Cached d a -> IO a -> IO a
|
|
cached dir Cached {..} ma = do
|
|
ins <- (maybeTimeFile . (dir </>)) `mapM` inputFiles
|
|
c <- maybeTimeFile (dir </> cacheFile)
|
|
if any (c<) ins || isNothing c
|
|
then writeCache
|
|
else maybe ma return =<< readCache
|
|
where
|
|
maybeTimeFile :: FilePath -> IO (Maybe TimedFile)
|
|
maybeTimeFile f = traverse timeFile =<< mightExist f
|
|
|
|
writeCache = do
|
|
a <- ma
|
|
writeFile (dir </> cacheFile) $ unlines [show inputData, show a]
|
|
return a
|
|
|
|
readCache :: IO (Maybe a)
|
|
readCache = runMaybeT $ do
|
|
hdr:c:_ <- lines <$> liftIO (readFile $ dir </> cacheFile)
|
|
if inputData /= read hdr
|
|
then liftIO $ writeCache
|
|
else MaybeT $ return $ readMaybe c
|
|
|
|
-- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent
|
|
-- directories. The first parent directory containing more than one cabal file
|
|
-- is assumed to be the project directory. If only one cabal file exists in this
|
|
-- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'
|
|
-- or 'GMETooManyCabalFiles'
|
|
findCabalFile :: FilePath -> IO (Maybe FilePath)
|
|
findCabalFile dir = do
|
|
-- List of directories and all cabal file candidates
|
|
dcs <- findFileInParentsP isCabalFile dir :: IO ([(DirPath, [FileName])])
|
|
let css = uncurry appendDir `map` dcs :: [[FilePath]]
|
|
case find (not . null) css of
|
|
Nothing -> return Nothing
|
|
Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs
|
|
Just (a:_) -> return (Just a)
|
|
Just [] -> error "findCabalFile"
|
|
where
|
|
appendDir :: DirPath -> [FileName] -> [FilePath]
|
|
appendDir d fs = (d </>) `map` fs
|
|
|
|
-- |
|
|
-- >>> isCabalFile "/home/user/.cabal"
|
|
-- False
|
|
isCabalFile :: FilePath -> Bool
|
|
isCabalFile f = takeExtension' f == ".cabal"
|
|
|
|
-- |
|
|
-- >>> takeExtension' "/some/dir/bla.cabal"
|
|
-- ".cabal"
|
|
--
|
|
-- >>> takeExtension' "some/reldir/bla.cabal"
|
|
-- ".cabal"
|
|
--
|
|
-- >>> takeExtension' "bla.cabal"
|
|
-- ".cabal"
|
|
--
|
|
-- >>> takeExtension' ".cabal"
|
|
-- ""
|
|
takeExtension' :: FilePath -> String
|
|
takeExtension' p =
|
|
if takeFileName p == takeExtension p
|
|
then "" -- just ".cabal" is not a valid cabal file
|
|
else takeExtension p
|
|
|
|
-- | @findFileInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all
|
|
-- it's parent directories.
|
|
findFileInParentsP :: (FilePath -> Bool) -> FilePath
|
|
-> IO [(DirPath, [FileName])]
|
|
findFileInParentsP p dir =
|
|
getFilesP p `zipMapM` parents dir
|
|
|
|
-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.
|
|
getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName]
|
|
getFilesP p dir = filterM p' =<< getDirectoryContents dir
|
|
where
|
|
p' fn = do
|
|
(p fn && ) <$> doesFileExist (dir </> fn)
|
|
|
|
findCabalSandboxDir :: FilePath -> IO (Maybe FilePath)
|
|
findCabalSandboxDir dir = do
|
|
dss <- findFileInParentsP isSandboxConfig dir
|
|
return $ case find (not . null . snd) $ dss of
|
|
Just (sbDir, _:_) -> Just sbDir
|
|
_ -> Nothing
|
|
|
|
where
|
|
isSandboxConfig = (=="cabal.sandbox.config")
|
|
|
|
zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
|
|
zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as
|
|
|
|
-- | @parents dir@. Returns all parent directories of @dir@ including @dir@.
|
|
--
|
|
-- Examples
|
|
--
|
|
-- >>> parents "foo"
|
|
-- ["foo"]
|
|
--
|
|
-- >>> parents "/foo"
|
|
-- ["/foo","/"]
|
|
--
|
|
-- >>> parents "/foo/bar"
|
|
-- ["/foo/bar","/foo","/"]
|
|
--
|
|
-- >>> parents "foo/bar"
|
|
-- ["foo/bar","foo"]
|
|
parents :: FilePath -> [FilePath]
|
|
parents "" = []
|
|
parents dir' =
|
|
let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir'
|
|
in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir
|
|
where
|
|
parents' :: [String] -> [FilePath]
|
|
parents' [] | isAbsolute dir' = "":[]
|
|
parents' [] = []
|
|
parents' dir = [joinPath dir] ++ parents' (init dir)
|
|
|
|
----------------------------------------------------------------
|
|
|
|
-- | Get path to sandbox config file
|
|
getSandboxDb :: FilePath -- ^ Path to the cabal package root directory
|
|
-- (containing the @cabal.sandbox.config@ file)
|
|
-> IO (Maybe GhcPkgDb)
|
|
getSandboxDb d = do
|
|
mConf <- traverse readFile =<< U.mightExist (d </> "cabal.sandbox.config")
|
|
return $ PackageDb . fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)
|
|
|
|
where
|
|
fixPkgDbVer dir =
|
|
case takeFileName dir == ghcSandboxPkgDbDir of
|
|
True -> dir
|
|
False -> takeDirectory dir </> ghcSandboxPkgDbDir
|
|
|
|
-- | Extract the sandbox package db directory from the cabal.sandbox.config file.
|
|
-- Exception is thrown if the sandbox config file is broken.
|
|
extractSandboxDbDir :: String -> Maybe FilePath
|
|
extractSandboxDbDir conf = extractValue <$> parse conf
|
|
where
|
|
key = "package-db:"
|
|
keyLen = length key
|
|
|
|
parse = listToMaybe . filter (key `isPrefixOf`) . lines
|
|
extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
|
|
|
|
setupConfigFile :: Cradle -> FilePath
|
|
setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
|
|
|
|
-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
|
|
setupConfigPath :: FilePath
|
|
setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref
|
|
|
|
ghcSandboxPkgDbDir :: String
|
|
ghcSandboxPkgDbDir =
|
|
cabalBuildPlatform ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d"
|
|
|
|
cabalBuildPlatform :: String
|
|
cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $
|
|
readLibExecProcess' "cabal-helper-wrapper" ["print-build-platform"]
|
|
|
|
packageCache :: String
|
|
packageCache = "package.cache"
|
|
|
|
cabalHelperCache :: [String] -> Cached [String] [Maybe GmCabalHelperResponse]
|
|
cabalHelperCache cmds = Cached {
|
|
inputFiles = [setupConfigPath],
|
|
inputData = cmds,
|
|
cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper"
|
|
}
|
|
|
|
-- | Filename of the symbol table cache file.
|
|
symbolCache :: Cradle -> FilePath
|
|
symbolCache crdl = cradleTempDir crdl </> symbolCacheFile
|
|
|
|
symbolCacheFile :: String
|
|
symbolCacheFile = "ghc-mod.symbol-cache"
|