ghc-mod/Language/Haskell/GhcMod/PathsAndFiles.hs

250 lines
7.9 KiB
Haskell
Raw Normal View History

2015-03-03 19:28:34 +00:00
-- 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/>.
2014-11-01 21:02:47 +00:00
module Language.Haskell.GhcMod.PathsAndFiles where
import Config (cProjectVersion)
2014-11-01 21:02:47 +00:00
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Maybe
2014-11-01 21:02:47 +00:00
import Data.List
import Data.Char
import Data.Maybe
import Data.Traversable (traverse)
import System.Directory
import System.FilePath
import System.IO.Unsafe
2014-11-01 21:02:47 +00:00
import Language.Haskell.GhcMod.Types
2015-03-04 20:48:21 +00:00
import Language.Haskell.GhcMod.Monad.Types
2014-11-01 21:02:47 +00:00
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Read
import Language.Haskell.GhcMod.Utils hiding (dropWhileEnd)
2014-11-01 21:02:47 +00:00
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
2014-11-01 21:02:47 +00:00
-- | @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'
2014-11-02 23:45:27 +00:00
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
2014-11-01 21:02:47 +00:00
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
2014-11-02 23:45:27 +00:00
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
2014-11-01 21:02:47 +00:00
2014-11-02 23:04:15 +00:00
where
isSandboxConfig = (=="cabal.sandbox.config")
2014-11-01 21:02:47 +00:00
zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as
2014-11-01 21:02:47 +00:00
-- | @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)
2014-11-01 21:02:47 +00:00
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
2014-11-01 21:02:47 +00:00
-- | 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
2014-11-01 21:02:47 +00:00
ghcSandboxPkgDbDir :: String
ghcSandboxPkgDbDir =
cabalBuildPlatform ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d"
cabalBuildPlatform :: String
cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $
readLibExecProcess' "cabal-helper-wrapper" ["print-build-platform"]
2014-11-01 21:02:47 +00:00
packageCache :: String
packageCache = "package.cache"
cabalHelperCache ::
FilePath -> [String] -> Cached [String] [Maybe GmCabalHelperResponse]
cabalHelperCache cabalHelperExe cmds = Cached {
inputFiles = [cabalHelperExe, setupConfigPath],
inputData = cmds,
cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper"
}
2015-02-07 22:52:26 +00:00
-- | Filename of the symbol table cache file.
symbolCache :: Cradle -> FilePath
symbolCache crdl = cradleTempDir crdl </> symbolCacheFile
symbolCacheFile :: String
symbolCacheFile = "ghc-mod.symbol-cache"