103 lines
3.0 KiB
Haskell
103 lines
3.0 KiB
Haskell
|
module Cabal (initializeGHC) where
|
||
|
|
|
||
|
|
import Control.Applicative hiding (many)
|
||
|
|
import Data.Attoparsec.Char8
|
||
|
|
import Data.Attoparsec.Enumerator
|
||
|
|
import Data.Enumerator (run, ($$))
|
||
|
|
import Data.Enumerator.Binary (enumFile)
|
||
|
|
import Data.List
|
||
|
|
import GHC
|
||
|
|
import qualified HscTypes as H
|
||
|
|
import System.Directory
|
||
|
|
import System.FilePath
|
||
|
|
import Types
|
||
|
|
|
||
|
|
----------------------------------------------------------------
|
||
|
|
|
||
|
|
initializeGHC :: FilePath -> [String] -> Ghc FilePath
|
||
|
|
initializeGHC fileName options = do
|
||
|
|
(owdir,mdirfile) <- getDirs
|
||
|
|
case mdirfile of
|
||
|
|
Nothing -> do
|
||
|
|
initSession options Nothing
|
||
|
|
return fileName
|
||
|
|
Just (cdir,cfile) -> do
|
||
|
|
midirs <- parseCabalFile cfile
|
||
|
|
changeToCabalDirectory cdir
|
||
|
|
let idirs = case midirs of
|
||
|
|
Nothing -> [cdir,owdir]
|
||
|
|
Just dirs -> dirs ++ [owdir]
|
||
|
|
initSession options (Just idirs)
|
||
|
|
return (ajustFileName fileName owdir cdir)
|
||
|
|
|
||
|
|
----------------------------------------------------------------
|
||
|
|
|
||
|
|
parseCabalFile :: FilePath -> Ghc (Maybe [String])
|
||
|
|
parseCabalFile file = H.liftIO $ do
|
||
|
|
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
|
||
|
|
satisfy $ inClass "hH"
|
||
|
|
satisfy $ inClass "sS"
|
||
|
|
char '-'
|
||
|
|
satisfy $ inClass "sS"
|
||
|
|
satisfy $ inClass "oO"
|
||
|
|
satisfy $ inClass "uU"
|
||
|
|
satisfy $ inClass "rR"
|
||
|
|
satisfy $ inClass "cC"
|
||
|
|
satisfy $ inClass "eE"
|
||
|
|
char '-'
|
||
|
|
satisfy $ inClass "dD"
|
||
|
|
satisfy $ inClass "iI"
|
||
|
|
satisfy $ inClass "rR"
|
||
|
|
satisfy $ inClass "sS"
|
||
|
|
char ':'
|
||
|
|
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
|
||
|
|
H.liftIO $ setCurrentDirectory dir
|
||
|
|
workingDirectoryChanged
|
||
|
|
|
||
|
|
getDirs :: Ghc (FilePath, Maybe (FilePath,FilePath))
|
||
|
|
getDirs = do
|
||
|
|
wdir <- H.liftIO $ getCurrentDirectory
|
||
|
|
mcabdir <- cabalDir wdir
|
||
|
|
case mcabdir of
|
||
|
|
Nothing -> return (wdir,Nothing)
|
||
|
|
jdf -> return (wdir,jdf)
|
||
|
|
|
||
|
|
cabalDir :: FilePath -> Ghc (Maybe (FilePath,FilePath))
|
||
|
|
cabalDir dir = do
|
||
|
|
cnts <- H.liftIO $ getDirectoryContents dir
|
||
|
|
case filter isCabal 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
|