diff --git a/Cabal.hs b/Cabal.hs new file mode 100644 index 0000000..1cfd268 --- /dev/null +++ b/Cabal.hs @@ -0,0 +1,102 @@ +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