diff --git a/Cabal.hs b/Cabal.hs new file mode 100644 --- /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 diff --git a/Check.hs b/Check.hs --- a/Check.hs +++ b/Check.hs @@ -1,6 +1,7 @@ module Check (checkSyntax) where import Bag +import Cabal import Control.Applicative import Data.IORef import ErrUtils @@ -9,9 +10,10 @@ import GHC import HscTypes import Outputable hiding (showSDoc) +import Prelude hiding (catch) import Pretty +import System.FilePath import Types -import Prelude hiding (catch) ---------------------------------------------------------------- @@ -22,13 +24,14 @@ check :: String -> IO [String] check fileName = withGHC $ do + file <- initializeGHC fileName options + setTargetFile file ref <- newRef [] - initSession ["-Wall","-fno-warn-unused-do-bind"] - setTargetFile fileName loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref clearWarnings readRef ref where + options = ["-Wall","-fno-warn-unused-do-bind"] handleParseError ref e = do liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e return Succeeded @@ -52,7 +55,7 @@ showErrMsg err = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ msg ++ "\0" ++ ext where spn = head (errMsgSpans err) - file = unpackFS (srcSpanFile spn) + file = takeFileName $ unpackFS (srcSpanFile spn) line = show (srcSpanStartLine spn) col = show (srcSpanStartCol spn) msg = showSDoc (errMsgShortDoc err) diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -21,7 +21,7 @@ ---------------------------------------------------------------- usage :: String -usage = "ghc-mod version 0.5.5\n" +usage = "ghc-mod version 0.6.0\n" ++ "Usage:\n" ++ "\t ghc-mod list [-l]\n" ++ "\t ghc-mod lang [-l]\n" diff --git a/Info.hs b/Info.hs --- a/Info.hs +++ b/Info.hs @@ -1,18 +1,19 @@ module Info where +import Cabal import Control.Applicative hiding (empty) +import Control.Exception import Control.Monad +import Data.List import Data.Maybe import GHC +import HscTypes +import NameSet import Outputable import PprTyThing -import Types -import NameSet -import HscTypes -import Data.List -import Control.Exception import StringBuffer import System.Time +import Types type Expression = String type ModuleString = String @@ -71,12 +72,12 @@ inModuleContext fileName modstr action = withGHC valid where valid = do - initSession ["-w"] - setTargetFile fileName + file <- initializeGHC fileName ["-w"] + setTargetFile file loadWithLogger (\_ -> return ()) LoadAllTargets mif setContextFromTarget action invalid invalid = do - initSession ["-w"] + initializeGHC fileName ["-w"] setTargetBuffer loadWithLogger defaultWarnErrLogger LoadAllTargets mif setContextFromTarget action (return errorMessage) diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -25,27 +25,23 @@ initSession0 :: Ghc [PackageId] initSession0 = getSessionDynFlags >>= setSessionDynFlags -initSession :: [String] -> Ghc [PackageId] -initSession cmdOpts = do +initSession :: [String] -> Maybe [FilePath] -> Ghc [PackageId] +initSession cmdOpts midirs = do dflags <- getSessionDynFlags let opts = map noLoc cmdOpts (dflags',_,_) <- parseDynamicFlags dflags opts - setSessionDynFlags $ setFlags dflags' + setSessionDynFlags $ setFlags dflags' midirs ---------------------------------------------------------------- -setFlags :: DynFlags -> DynFlags -setFlags d = d { - importPaths = importPaths d ++ importDirs - , packageFlags = ghcPackage : packageFlags d - , ghcLink = NoLink --- GHC.desugarModule does not produces the pattern warnings, why? --- , hscTarget = HscNothing - , hscTarget = HscInterpreted - } - -importDirs :: [String] -importDirs = ["..","../..","../../..","../../../..","../../../../.."] +setFlags :: DynFlags -> Maybe [FilePath] -> DynFlags +setFlags d midirs = maybe d' (\x -> d' { importPaths = x }) midirs + where + d' = d { + packageFlags = ghcPackage : packageFlags d + , ghcLink = NoLink + , hscTarget = HscInterpreted + } ghcPackage :: PackageFlag ghcPackage = ExposePackage "ghc" diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -16,7 +16,7 @@ ;;; Code: -(defconst ghc-version "0.5.5") +(defconst ghc-version "0.6.0") ;; (eval-when-compile ;; (require 'haskell-mode)) diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 0.5.5 +Version: 0.6.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -23,14 +23,15 @@ ghc-flymake.el ghc-command.el ghc-info.el Executable ghc-mod Main-Is: GHCMod.hs - Other-Modules: List Browse Check Info Lang Lint Types + Other-Modules: List Browse Cabal Check Info Lang Lint Types if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else GHC-Options: -Wall - Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, + Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, transformers, process, directory, filepath, old-time, - hlint >= 1.7.1 + hlint >= 1.7.1, + attoparsec, enumerator, attoparsec-enumerator Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git