diff --git a/Cabal.hs b/Cabal.hs index 4404099..89c442b 100644 --- a/Cabal.hs +++ b/Cabal.hs @@ -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 diff --git a/Check.hs b/Check.hs index e0513fd..fb5940c 100644 --- a/Check.hs +++ b/Check.hs @@ -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 + -} \ No newline at end of file diff --git a/GHCMod.hs b/GHCMod.hs index f280ab5..707766e 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -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 diff --git a/Info.hs b/Info.hs index 5b652da..bb51aad 100644 --- a/Info.hs +++ b/Info.hs @@ -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 diff --git a/Lint.hs b/Lint.hs index 91a51d0..700c480 100644 --- a/Lint.hs +++ b/Lint.hs @@ -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) diff --git a/Types.hs b/Types.hs index c459c70..647dc34 100644 --- a/Types.hs +++ b/Types.hs @@ -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 ----------------------------------------------------------------