hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Supporting GHC 7.2.1!

Browse Source
This commit is contained in:
Kazu Yamamoto 2011-08-24 15:58:12 +09:00
parent ac09c56cfd
commit dbdcf9841e
6 changed files with 98 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
Cabal.hs
View File

@ -2,39 +2,40 @@
module Cabal (initializeGHC) where
import Control.Applicative hiding (many)
import CoreMonad
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 :: Options -> FilePath -> [String] -> Ghc FilePath
initializeGHC opt fileName ghcOptions = do
(owdir,mdirfile) <- getDirs
initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader)
initializeGHC opt fileName ghcOptions logging = do
(owdir,mdirfile) <- liftIO getDirs
case mdirfile of
Nothing -> do
initSession opt ghcOptions Nothing
return fileName
logReader <- initSession opt ghcOptions Nothing logging
return (fileName,logReader)
Just (cdir,cfile) -> do
midirs <- parseCabalFile cfile
changeToCabalDirectory cdir
let idirs = case midirs of
Nothing -> [cdir,owdir]
Just dirs -> dirs ++ [owdir]
initSession opt ghcOptions (Just idirs)
return (ajustFileName fileName owdir cdir)
file = ajustFileName fileName owdir cdir
logReader <- initSession opt ghcOptions (Just idirs) logging
return (file,logReader)
----------------------------------------------------------------
parseCabalFile :: FilePath -> Ghc (Maybe [String])
parseCabalFile file = H.liftIO $ do
parseCabalFile file = liftIO $ do
res <- run (enumFile file $$ iterParser findTarget)
case res of
Right x -> return x
@ -63,20 +64,20 @@ ajustFileName name olddir newdir
changeToCabalDirectory :: FilePath -> Ghc ()
changeToCabalDirectory dir = do
H.liftIO $ setCurrentDirectory dir
liftIO $ setCurrentDirectory dir
workingDirectoryChanged
getDirs :: Ghc (FilePath, Maybe (FilePath,FilePath))
getDirs :: IO (FilePath, Maybe (FilePath,FilePath))
getDirs = do
wdir <- H.liftIO $ getCurrentDirectory
wdir <- getCurrentDirectory
mcabdir <- cabalDir wdir
case mcabdir of
Nothing -> return (wdir,Nothing)
jdf -> return (wdir,jdf)
cabalDir :: FilePath -> Ghc (Maybe (FilePath,FilePath))
cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))
cabalDir dir = do
cnts <- H.liftIO $ getDirectoryContents dir
cnts <- getDirectoryContents dir
case filter isCabal cnts of
[] -> do
let dir' = takeDirectory dir

57
Check.hs
View File

@ -1,18 +1,10 @@
module Check (checkSyntax) where
import Bag
import Cabal
import Control.Applicative
import Data.IORef
import ErrUtils
import Exception
import FastString
import CoreMonad
import GHC
import HscTypes
import Outputable hiding (showSDoc)
import Prelude hiding (catch)
import Pretty
import System.FilePath
import Types
----------------------------------------------------------------
@ -24,49 +16,14 @@ checkSyntax opt file = unlines <$> check opt file
check :: Options -> String -> IO [String]
check opt fileName = withGHC $ do
file <- initializeGHC opt fileName options
(file,readLog) <- initializeGHC opt fileName options True
setTargetFile file
ref <- newRef []
loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref
clearWarnings
readRef ref
load LoadAllTargets -- `gcatch` handleParseError ref xxx
liftIO readLog
where
options = ["-Wall","-fno-warn-unused-do-bind"] ++ map ((++) "-i") (checkIncludes opt)
options = ["-Wall","-fno-warn-unused-do-bind"] ++ map ("-i" ++) (checkIncludes opt)
{-
handleParseError ref e = do
liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e
return Succeeded
newRef = liftIO . newIORef
readRef = liftIO . readIORef
----------------------------------------------------------------
refLogger :: IORef [String] -> WarnErrLogger
refLogger ref Nothing =
(errBagToStrList <$> getWarnings) >>= liftIO . writeIORef ref
refLogger ref (Just e) =
liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e
errBagToStrList :: Bag ErrMsg -> [String]
errBagToStrList = map showErrMsg . reverse . bagToList
----------------------------------------------------------------
showErrMsg :: ErrMsg -> String
showErrMsg err = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ msg ++ "\0" ++ ext
where
spn = head (errMsgSpans err)
file = takeFileName $ unpackFS (srcSpanFile spn)
line = show (srcSpanStartLine spn)
col = show (srcSpanStartCol spn)
msg = showSDoc (errMsgShortDoc err)
ext = showSDoc (errMsgExtraInfo err)
style :: PprStyle
style = mkUserStyle neverQualify AllTheWay
showSDoc :: SDoc -> String
--showSDoc d = map toNull . Pretty.showDocWith ZigZagMode $ d style
showSDoc d = map toNull . Pretty.showDocWith PageMode $ d style
where
toNull '\n' = '\0'
toNull x = x
-}

6
GHCMod.hs
View File

@ -62,7 +62,7 @@ argspec = [ Option "l" ["tolisp"]
(NoArg (\opts -> opts{ useUserPackageConf = False }))
"do not read the user package database"
, Option "i" ["include"]
(ReqArg (\i opts -> opts{ checkIncludes = i : (checkIncludes opts)}) "include")
(ReqArg (\i opts -> opts{ checkIncludes = i : checkIncludes opts }) "include")
"directory to include in search for modules"
]
@ -105,7 +105,7 @@ main = flip catches handlers $ do
where
handlers = [Handler handler1, Handler handler2]
handler1 :: ErrorCall -> IO ()
handler1 e = print e -- for debug
handler1 = print -- for debug
handler2 :: GHCModError -> IO ()
handler2 SafeList = printUsage
handler2 (NoSuchCommand cmd) = do
@ -117,7 +117,7 @@ main = flip catches handlers $ do
handler2 (FileNotExist file) = do
hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
printUsage
printUsage = hPutStrLn stderr $ "\n" ++ usageInfo usage argspec
printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec
withFile cmd file = do
exist <- doesFileExist file
if exist

21
Info.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE CPP #-}
module Info where
import Cabal
@ -15,6 +17,10 @@ import StringBuffer
import System.Time
import Types
#if __GLASGOW_HASKELL__ >= 702
import CoreMonad
#endif
type Expression = String
type ModuleString = String
@ -68,19 +74,18 @@ pprInfo pefas (thing, fixity, insts)
----------------------------------------------------------------
inModuleContext
:: Options -> FilePath -> ModuleString -> Ghc String -> IO String
inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> IO String
inModuleContext opt fileName modstr action = withGHC valid
where
valid = do
file <- initializeGHC opt fileName ["-w"]
(file,_) <- initializeGHC opt fileName ["-w"] False
setTargetFile file
loadWithLogger (\_ -> return ()) LoadAllTargets
load LoadAllTargets
mif setContextFromTarget action invalid
invalid = do
initializeGHC opt fileName ["-w"]
initializeGHC opt fileName ["-w"] False
setTargetBuffer
loadWithLogger defaultWarnErrLogger LoadAllTargets
load LoadAllTargets
mif setContextFromTarget action (return errorMessage)
setTargetBuffer = do
modgraph <- depanal [mkModuleName modstr] True
@ -88,7 +93,11 @@ inModuleContext opt fileName modstr action = withGHC valid
map ms_imps modgraph ++ map ms_srcimps modgraph
moddef = "module " ++ sanitize modstr ++ " where"
header = moddef : imports
#if __GLASGOW_HASKELL__ >= 702
importsBuf = stringToStringBuffer . unlines $ header
#else
importsBuf <- liftIO . stringToStringBuffer . unlines $ header
#endif
clkTime <- liftIO getClockTime
setTargets [Target (TargetModule $ mkModuleName modstr) True (Just (importsBuf, clkTime))]
mif m t e = m >>= \ok -> if ok then t else e

2
Lint.hs
View File

@ -8,7 +8,7 @@ import Types
lintSyntax :: Options -> String -> IO String
lintSyntax opt file = pretty <$> lint opt file
where
pretty = unlines . map (concat . intersperse "\0" . lines)
pretty = unlines . map (intercalate "\0" . lines)
lint :: Options -> String -> IO [String]
lint opt file = map show <$> hlint ([file, "--quiet"] ++ hlintOpts opt)

63
Types.hs
View File

@ -1,10 +1,20 @@
{-# LANGUAGE CPP #-}
module Types where
import Control.Applicative
import Control.Monad
import CoreMonad
import Data.IORef
import DynFlags
import ErrUtils
import Exception
import FastString
import GHC
import GHC.Paths (libdir)
import Outputable
import System.FilePath
import Pretty
----------------------------------------------------------------
@ -29,12 +39,14 @@ initSession0 :: Options -> Ghc [PackageId]
initSession0 opt = getSessionDynFlags >>=
setSessionDynFlags . setPackageConfFlags opt
initSession :: Options -> [String] -> Maybe [FilePath] -> Ghc [PackageId]
initSession opt cmdOpts midirs = do
initSession :: Options -> [String] -> Maybe [FilePath] -> Bool -> Ghc LogReader
initSession opt cmdOpts midirs logging = do
dflags <- getSessionDynFlags
let opts = map noLoc cmdOpts
(dflags',_,_) <- parseDynamicFlags dflags opts
setSessionDynFlags $ setPackageConfFlags opt $ setFlags dflags' midirs
(dflags'',readLog) <- liftIO . setLogger logging . setPackageConfFlags opt . setFlags dflags' $ midirs
setSessionDynFlags dflags''
return readLog
----------------------------------------------------------------
@ -57,9 +69,48 @@ setPackageConfFlags
= flagset { extraPkgConfs = extra', flags = flags' }
where
extra' = confs ++ extra
flags' = if useUser
then origFlags
else filter (/=Opt_ReadUserPackageConf) origFlags
flags' = if useUser then
origFlags
else
filter (/=Opt_ReadUserPackageConf) origFlags
----------------------------------------------------------------
type LogReader = IO [String]
setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)
setLogger False df = return (newdf, undefined)
where
newdf = df { log_action = \_ _ _ _ -> return () }
setLogger True df = do
ref <- newIORef [] :: IO (IORef [String])
let newdf = df { log_action = appendLog ref }
return (newdf, reverse <$> readIORef ref)
where
appendLog ref _ src _ msg = modifyIORef ref (\ls -> ppMsg src msg : ls)
ppMsg :: SrcSpan -> Message -> String
#if __GLASGOW_HASKELL__ >= 702
ppMsg (UnhelpfulSpan _) _ = undefined
ppMsg (RealSrcSpan src) msg
#else
ppMsg src msg
#endif
= file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ cts ++ "\0" -- xxx
where
file = takeFileName $ unpackFS (srcSpanFile src)
line = show (srcSpanStartLine src)
col = show (srcSpanStartCol src)
cts = showMsg msg
style :: PprStyle
style = mkUserStyle neverQualify AllTheWay
showMsg :: SDoc -> String
showMsg d = map toNull . Pretty.showDocWith PageMode $ d style
where
toNull '\n' = '\0'
toNull x = x
----------------------------------------------------------------