new include scheme.

This commit is contained in:
Kazu Yamamoto 2011-05-24 16:00:47 +09:00
parent 8bb0c27b0b
commit 783e4a4e4c
4 changed files with 34 additions and 24 deletions

View File

@ -1,6 +1,7 @@
module Check (checkSyntax) where module Check (checkSyntax) where
import Bag import Bag
import Cabal
import Control.Applicative import Control.Applicative
import Data.IORef import Data.IORef
import ErrUtils import ErrUtils
@ -9,9 +10,9 @@ import FastString
import GHC import GHC
import HscTypes import HscTypes
import Outputable hiding (showSDoc) import Outputable hiding (showSDoc)
import Prelude hiding (catch)
import Pretty import Pretty
import Types import Types
import Prelude hiding (catch)
---------------------------------------------------------------- ----------------------------------------------------------------
@ -23,12 +24,24 @@ checkSyntax _ file = unlines <$> check file
check :: String -> IO [String] check :: String -> IO [String]
check fileName = withGHC $ do check fileName = withGHC $ do
ref <- newRef [] ref <- newRef []
initSession ["-Wall","-fno-warn-unused-do-bind"] (owdir,mdirfile) <- getDirs
setTargetFile fileName case mdirfile of
Nothing -> do
initSession options Nothing
setTargetFile 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)
setTargetFile (ajustFileName fileName owdir cdir)
loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref
clearWarnings clearWarnings
readRef ref readRef ref
where where
options = ["-Wall","-fno-warn-unused-do-bind"]
handleParseError ref e = do handleParseError ref e = do
liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e
return Succeeded return Succeeded
@ -66,4 +79,4 @@ showSDoc :: SDoc -> String
showSDoc d = map toNull . Pretty.showDocWith PageMode $ d style showSDoc d = map toNull . Pretty.showDocWith PageMode $ d style
where where
toNull '\n' = '\0' toNull '\n' = '\0'
toNull x = x toNull x = x

View File

@ -71,12 +71,12 @@ inModuleContext :: FilePath -> ModuleString -> Ghc String -> IO String
inModuleContext fileName modstr action = withGHC valid inModuleContext fileName modstr action = withGHC valid
where where
valid = do valid = do
initSession ["-w"] initSession ["-w"] Nothing
setTargetFile fileName setTargetFile fileName
loadWithLogger (\_ -> return ()) LoadAllTargets loadWithLogger (\_ -> return ()) LoadAllTargets
mif setContextFromTarget action invalid mif setContextFromTarget action invalid
invalid = do invalid = do
initSession ["-w"] initSession ["-w"] Nothing
setTargetBuffer setTargetBuffer
loadWithLogger defaultWarnErrLogger LoadAllTargets loadWithLogger defaultWarnErrLogger LoadAllTargets
mif setContextFromTarget action (return errorMessage) mif setContextFromTarget action (return errorMessage)

View File

@ -25,27 +25,23 @@ withGHC body = ghandle ignore $ runGhc (Just libdir) body
initSession0 :: Ghc [PackageId] initSession0 :: Ghc [PackageId]
initSession0 = getSessionDynFlags >>= setSessionDynFlags initSession0 = getSessionDynFlags >>= setSessionDynFlags
initSession :: [String] -> Ghc [PackageId] initSession :: [String] -> Maybe [FilePath] -> Ghc [PackageId]
initSession cmdOpts = do initSession cmdOpts midirs = do
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
let opts = map noLoc cmdOpts let opts = map noLoc cmdOpts
(dflags',_,_) <- parseDynamicFlags dflags opts (dflags',_,_) <- parseDynamicFlags dflags opts
setSessionDynFlags $ setFlags dflags' setSessionDynFlags $ setFlags dflags' midirs
---------------------------------------------------------------- ----------------------------------------------------------------
setFlags :: DynFlags -> DynFlags setFlags :: DynFlags -> Maybe [FilePath] -> DynFlags
setFlags d = d { setFlags d midirs = maybe d' (\x -> d' { importPaths = x }) midirs
importPaths = importPaths d ++ importDirs where
, packageFlags = ghcPackage : packageFlags d d' = d {
, ghcLink = NoLink packageFlags = ghcPackage : packageFlags d
-- GHC.desugarModule does not produces the pattern warnings, why? , ghcLink = NoLink
-- , hscTarget = HscNothing , hscTarget = HscInterpreted
, hscTarget = HscInterpreted }
}
importDirs :: [String]
importDirs = ["..","../..","../../..","../../../..","../../../../.."]
ghcPackage :: PackageFlag ghcPackage :: PackageFlag
ghcPackage = ExposePackage "ghc" ghcPackage = ExposePackage "ghc"

View File

@ -23,14 +23,15 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
ghc-flymake.el ghc-command.el ghc-info.el ghc-flymake.el ghc-command.el ghc-info.el
Executable ghc-mod Executable ghc-mod
Main-Is: GHCMod.hs 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) if impl(ghc >= 6.12)
GHC-Options: -Wall -fno-warn-unused-do-bind GHC-Options: -Wall -fno-warn-unused-do-bind
else else
GHC-Options: -Wall 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, process, directory, filepath, old-time,
hlint >= 1.7.1 hlint >= 1.7.1,
attoparsec, enumerator, attoparsec-enumerator
Source-Repository head Source-Repository head
Type: git Type: git
Location: git://github.com/kazu-yamamoto/ghc-mod.git Location: git://github.com/kazu-yamamoto/ghc-mod.git