ghc-mod/Cabal.hs

94 lines
2.9 KiB
Haskell
Raw Normal View History

2011-05-27 01:07:27 +00:00
{-# LANGUAGE OverloadedStrings #-}
2011-05-24 07:18:22 +00:00
module Cabal (initializeGHC) where
import Control.Applicative hiding (many)
2011-10-18 03:09:25 +00:00
import Control.Monad
2011-08-24 06:58:12 +00:00
import CoreMonad
2011-05-24 07:18:22 +00:00
import Data.Attoparsec.Char8
import Data.Attoparsec.Enumerator
import Data.Enumerator (run, ($$))
import Data.Enumerator.Binary (enumFile)
import Data.List
2011-08-24 07:50:26 +00:00
import ErrMsg
2011-05-24 07:18:22 +00:00
import GHC
import System.Directory
import System.FilePath
import Types
----------------------------------------------------------------
2011-08-24 06:58:12 +00:00
initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader)
initializeGHC opt fileName ghcOptions logging = do
(owdir,mdirfile) <- liftIO getDirs
2011-05-24 07:18:22 +00:00
case mdirfile of
Nothing -> do
2011-08-24 06:58:12 +00:00
logReader <- initSession opt ghcOptions Nothing logging
return (fileName,logReader)
2011-05-24 07:18:22 +00:00
Just (cdir,cfile) -> do
midirs <- parseCabalFile cfile
changeToCabalDirectory cdir
let idirs = case midirs of
Nothing -> [cdir,owdir]
Just dirs -> dirs ++ [owdir]
2011-08-24 06:58:12 +00:00
file = ajustFileName fileName owdir cdir
logReader <- initSession opt ghcOptions (Just idirs) logging
return (file,logReader)
2011-05-24 07:18:22 +00:00
----------------------------------------------------------------
parseCabalFile :: FilePath -> Ghc (Maybe [String])
2011-08-24 06:58:12 +00:00
parseCabalFile file = liftIO $ do
2011-05-24 07:18:22 +00:00
res <- run (enumFile file $$ iterParser findTarget)
case res of
Right x -> return x
Left e -> error (show e)
findTarget :: Parser (Maybe [String])
findTarget = Just <$> hs_source_dirs
<|> (anyChar >> findTarget)
<|> Nothing <$ endOfInput
hs_source_dirs :: Parser [String]
hs_source_dirs = do
2011-05-27 01:07:27 +00:00
stringCI "hs-source-dirs:"
2011-05-24 07:18:22 +00:00
many (char ' ')
sepBy1 (many . satisfy $ notInClass " ,\n") (many1 . satisfy $ inClass " ,")
----------------------------------------------------------------
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
2011-08-24 06:58:12 +00:00
liftIO $ setCurrentDirectory dir
2011-05-24 07:18:22 +00:00
workingDirectoryChanged
2011-08-24 06:58:12 +00:00
getDirs :: IO (FilePath, Maybe (FilePath,FilePath))
2011-05-24 07:18:22 +00:00
getDirs = do
2011-08-24 06:58:12 +00:00
wdir <- getCurrentDirectory
2011-05-24 07:18:22 +00:00
mcabdir <- cabalDir wdir
case mcabdir of
Nothing -> return (wdir,Nothing)
jdf -> return (wdir,jdf)
2011-08-24 06:58:12 +00:00
cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))
2011-05-24 07:18:22 +00:00
cabalDir dir = do
2011-10-18 03:09:25 +00:00
cnts <- (filter isCabal <$> getDirectoryContents dir)
>>= filterM doesFileExist
case cnts of
2011-05-24 07:18:22 +00:00
[] -> 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