ghc-mod/Cabal.hs
2012-02-06 18:07:32 +09:00

94 lines
3.0 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Cabal (initializeGHC) where
import Control.Applicative
import Control.Monad
import CoreMonad
import Data.List
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse (readPackageDescription)
import Distribution.Verbosity (silent)
import ErrMsg
import GHC
import System.Directory
import System.FilePath
import Types
----------------------------------------------------------------
importDirs :: [String]
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader)
initializeGHC opt fileName ghcOptions logging = do
(owdir,mdirfile) <- liftIO getDirs
case mdirfile of
Nothing -> do
logReader <- initSession opt ghcOptions importDirs logging
return (fileName,logReader)
Just (cdir,cfile) -> do
midirs <- parseCabalFile cfile
changeToCabalDirectory cdir
let idirs = case midirs of
[] -> [cdir,owdir]
dirs -> dirs ++ [owdir]
file = ajustFileName fileName owdir cdir
logReader <- initSession opt ghcOptions idirs logging
return (file,logReader)
----------------------------------------------------------------
parseCabalFile :: FilePath -> Ghc [String]
parseCabalFile file = do
cabal <- liftIO $ readPackageDescription silent file
return $ fromLibrary cabal ||| fromExecutable cabal
where
[] ||| y = y
x ||| _ = x
fromLibrary c = case condLibrary c of
Nothing -> []
Just lib -> libHsSourceDir lib
libHsSourceDir = hsSourceDirs . libBuildInfo . condTreeData
fromExecutable = execHsSrouceDir . condExecutables
execHsSrouceDir [] = []
execHsSrouceDir (x:_) = hsSourceDirs . buildInfo . condTreeData . snd $ x
----------------------------------------------------------------
ajustFileName :: FilePath -> FilePath -> FilePath -> FilePath
ajustFileName name olddir newdir
| olen == nlen = name
| otherwise = drop (nlen+1) olddir </> name
where
olen = length olddir
nlen = length newdir
changeToCabalDirectory :: FilePath -> Ghc ()
changeToCabalDirectory dir = do
liftIO $ setCurrentDirectory dir
workingDirectoryChanged
getDirs :: IO (FilePath, Maybe (FilePath,FilePath))
getDirs = do
wdir <- getCurrentDirectory
mcabdir <- cabalDir wdir
case mcabdir of
Nothing -> return (wdir,Nothing)
jdf -> return (wdir,jdf)
cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))
cabalDir dir = do
cnts <- (filter isCabal <$> getDirectoryContents dir)
>>= filterM (\file -> doesFileExist (dir </> file))
case cnts of
[] -> do
let dir' = takeDirectory dir
if dir' == dir
then return Nothing
else cabalDir dir'
cfile:_ -> return (Just (dir,dir </> cfile))
where
isCabal name = ".cabal" `isSuffixOf` name
&& length name > 6