diff --git a/Browse.hs b/Browse.hs --- a/Browse.hs +++ b/Browse.hs @@ -10,7 +10,7 @@ ---------------------------------------------------------------- browseModule :: Options -> String -> IO String -browseModule opt mdlName = convert opt . format <$> browse mdlName +browseModule opt mdlName = convert opt . format <$> browse opt mdlName where format | operators opt = formatOps @@ -22,9 +22,9 @@ | otherwise = '(' : x ++ ")" formatOps' [] = error "formatOps'" -browse :: String -> IO [String] -browse mdlName = withGHC $ do - initSession0 +browse :: Options -> String -> IO [String] +browse opt mdlName = withGHC $ do + initSession0 opt maybeNamesToStrings <$> lookupModuleInfo where lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo diff --git a/Cabal.hs b/Cabal.hs --- a/Cabal.hs +++ b/Cabal.hs @@ -1,39 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} 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 ErrMsg 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 +initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader) +initializeGHC opt fileName ghcOptions logging = do + (owdir,mdirfile) <- liftIO getDirs case mdirfile of Nothing -> do - initSession options 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 options (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 @@ -46,21 +49,7 @@ 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 ':' + stringCI "hs-source-dirs:" many (char ' ') sepBy1 (many . satisfy $ notInClass " ,\n") (many1 . satisfy $ inClass " ,") @@ -76,20 +65,20 @@ 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 --- a/Check.hs +++ b/Check.hs @@ -1,72 +1,28 @@ module Check (checkSyntax) where -import Bag import Cabal import Control.Applicative -import Data.IORef -import ErrUtils +import CoreMonad +import ErrMsg import Exception -import FastString import GHC -import HscTypes -import Outputable hiding (showSDoc) import Prelude hiding (catch) -import Pretty -import System.FilePath import Types ---------------------------------------------------------------- checkSyntax :: Options -> String -> IO String -checkSyntax _ file = unlines <$> check file +checkSyntax opt file = unlines <$> check opt file ---------------------------------------------------------------- -check :: String -> IO [String] -check fileName = withGHC $ do - file <- initializeGHC fileName options - setTargetFile file - ref <- newRef [] - loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref - clearWarnings - readRef ref +check :: Options -> String -> IO [String] +check opt fileName = withGHC $ checkIt `gcatch` handleErrMsg where + checkIt = do + (file,readLog) <- initializeGHC opt fileName options True + setTargetFile file + load LoadAllTargets + liftIO readLog options = ["-Wall","-fno-warn-unused-do-bind"] - 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 + ++ map ("-i" ++) (checkIncludes opt) diff --git a/ErrMsg.hs b/ErrMsg.hs new file mode 100644 --- /dev/null +++ b/ErrMsg.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} + +module ErrMsg ( + LogReader + , setLogger + , handleErrMsg + ) where + +import Bag +import Control.Applicative +import Data.IORef +import DynFlags +import ErrUtils +import FastString +import GHC +import HscTypes +import Outputable +import System.FilePath + +#if __GLASGOW_HASKELL__ < 702 +import Pretty +#endif + +---------------------------------------------------------------- + +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) + +---------------------------------------------------------------- + +handleErrMsg :: SourceError -> Ghc [String] +handleErrMsg = return . errBagToStrList . srcErrorMessages + +errBagToStrList :: Bag ErrMsg -> [String] +errBagToStrList = map ppErrMsg . reverse . bagToList + +---------------------------------------------------------------- + +ppErrMsg :: ErrMsg -> String +ppErrMsg err = ppMsg spn msg ++ ext + where + spn = head (errMsgSpans err) + msg = errMsgShortDoc err + ext = showMsg (errMsgExtraInfo err) + +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" + 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 +#if __GLASGOW_HASKELL__ >= 702 +showMsg d = map toNull $ renderWithStyle d style +#else +showMsg d = map toNull . Pretty.showDocWith PageMode $ d style +#endif + where + toNull '\n' = '\0' + toNull x = x diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -21,12 +21,12 @@ ---------------------------------------------------------------- usage :: String -usage = "ghc-mod version 0.6.0\n" +usage = "ghc-mod version 0.6.1\n" ++ "Usage:\n" ++ "\t ghc-mod list [-l]\n" ++ "\t ghc-mod lang [-l]\n" ++ "\t ghc-mod browse [-l] [-o] [ ...]\n" - ++ "\t ghc-mod check \n" + ++ "\t ghc-mod check [-i inc] \n" ++ "\t ghc-mod type \n" ++ "\t ghc-mod info \n" ++ "\t ghc-mod lint [-h opt] \n" @@ -39,7 +39,10 @@ defaultOptions = Options { convert = toPlain , hlintOpts = [] + , checkIncludes = [] , operators = False + , packageConfs = [] + , useUserPackageConf = True } argspec :: [OptDescr (Options -> Options)] @@ -52,6 +55,15 @@ , Option "o" ["operators"] (NoArg (\opts -> opts { operators = True })) "print operators, too" + , Option "" ["package-conf"] + (ReqArg (\p opts -> opts { packageConfs = p : packageConfs opts }) "path") + "additional package database" + , Option "" ["no-user-package-conf"] + (NoArg (\opts -> opts{ useUserPackageConf = False })) + "do not read the user package database" + , Option "i" ["include"] + (ReqArg (\i opts -> opts{ checkIncludes = i : checkIncludes opts }) "include") + "directory to include in search for modules" ] parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) @@ -93,7 +105,7 @@ 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 @@ -105,7 +117,7 @@ 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 --- a/Info.hs +++ b/Info.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Info where import Cabal @@ -15,16 +17,20 @@ import System.Time import Types +#if __GLASGOW_HASKELL__ >= 702 +import CoreMonad +#endif + type Expression = String type ModuleString = String ---------------------------------------------------------------- typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String -typeExpr _ modstr expr file = (++ "\n") <$> typeOf file modstr expr +typeExpr opt modstr expr file = (++ "\n") <$> typeOf opt file modstr expr -typeOf :: FilePath -> ModuleString -> Expression -> IO String -typeOf fileName modstr expr = inModuleContext fileName modstr exprToType +typeOf :: Options -> FilePath -> ModuleString -> Expression -> IO String +typeOf opt fileName modstr expr = inModuleContext opt fileName modstr exprToType where exprToType = pretty <$> exprType expr pretty = showSDocForUser neverQualify . pprTypeForUser False @@ -32,10 +38,10 @@ ---------------------------------------------------------------- infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String -infoExpr _ modstr expr file = (++ "\n") <$> info file modstr expr +infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr -info :: FilePath -> ModuleString -> FilePath -> IO String -info fileName modstr expr = inModuleContext fileName modstr exprToInfo +info :: Options -> FilePath -> ModuleString -> FilePath -> IO String +info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo where exprToInfo = infoThing expr @@ -68,18 +74,18 @@ ---------------------------------------------------------------- -inModuleContext :: FilePath -> ModuleString -> Ghc String -> IO String -inModuleContext fileName modstr action = withGHC valid +inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> IO String +inModuleContext opt fileName modstr action = withGHC valid where valid = do - file <- initializeGHC fileName ["-w"] + (file,_) <- initializeGHC opt fileName ["-w"] False setTargetFile file - loadWithLogger (\_ -> return ()) LoadAllTargets + load LoadAllTargets mif setContextFromTarget action invalid invalid = do - initializeGHC 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 @@ -87,7 +93,11 @@ 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 --- a/Lint.hs +++ b/Lint.hs @@ -8,7 +8,7 @@ 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/List.hs b/List.hs --- a/List.hs +++ b/List.hs @@ -10,11 +10,11 @@ ---------------------------------------------------------------- listModules :: Options -> IO String -listModules opt = convert opt . nub . sort <$> list +listModules opt = convert opt . nub . sort <$> list opt -list :: IO [String] -list = withGHC $ do - initSession0 +list :: Options -> IO [String] +list opt = withGHC $ do + initSession0 opt getExposedModules <$> getSessionDynFlags where getExposedModules = map moduleNameString diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -1,7 +1,9 @@ module Types where import Control.Monad +import CoreMonad import DynFlags +import ErrMsg import Exception import GHC import GHC.Paths (libdir) @@ -11,7 +13,10 @@ data Options = Options { convert :: [String] -> String , hlintOpts :: [String] + , checkIncludes :: [String] , operators :: Bool + , packageConfs :: [FilePath] + , useUserPackageConf :: Bool } withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a) @@ -22,15 +27,18 @@ ---------------------------------------------------------------- -initSession0 :: Ghc [PackageId] -initSession0 = getSessionDynFlags >>= setSessionDynFlags +initSession0 :: Options -> Ghc [PackageId] +initSession0 opt = getSessionDynFlags >>= + setSessionDynFlags . setPackageConfFlags opt -initSession :: [String] -> Maybe [FilePath] -> Ghc [PackageId] -initSession 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 $ setFlags dflags' midirs + (dflags'',readLog) <- liftIO . setLogger logging . setPackageConfFlags opt . setFlags dflags' $ midirs + setSessionDynFlags dflags'' + return readLog ---------------------------------------------------------------- @@ -45,6 +53,18 @@ ghcPackage :: PackageFlag ghcPackage = ExposePackage "ghc" + +setPackageConfFlags :: Options -> DynFlags -> DynFlags +setPackageConfFlags + Options { packageConfs = confs, useUserPackageConf = useUser } + flagset@DynFlags { extraPkgConfs = extra, flags = origFlags } + = flagset { extraPkgConfs = extra', flags = flags' } + where + extra' = confs ++ extra + flags' = if useUser then + origFlags + else + filter (/=Opt_ReadUserPackageConf) origFlags ---------------------------------------------------------------- diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -16,6 +16,15 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defcustom ghc-flymake-check-includes nil + "list of directories to include when checking file" + :type '(repeat string) +;; :risky nil + :require 'ghc-flymake + :group 'ghc-flymake) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defconst ghc-error-buffer-name "*GHC Errors*") (defconst ghc-flymake-allowed-file-name-masks @@ -44,7 +53,10 @@ (if ghc-flymake-command (let ((hopts (ghc-mapconcat (lambda (x) (list "-h" x)) opts))) `(,@hopts "lint" ,file)) - (list "check" file))) + (if (null ghc-flymake-check-includes) + (list "check" file) + (let ((includes (ghc-mapconcat (lambda (x) (list "-i" x)) ghc-flymake-check-includes))) + `("check" ,@includes ,file))))) (defun ghc-flymake-toggle-command () (interactive) 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.6.0") +(defconst ghc-version "0.6.1") ;; (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.6.0 +Version: 0.6.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -23,7 +23,7 @@ ghc-flymake.el ghc-command.el ghc-info.el Executable ghc-mod Main-Is: GHCMod.hs - Other-Modules: List Browse Cabal Check Info Lang Lint Types + Other-Modules: List Browse Cabal Check Info Lang Lint Types ErrMsg if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else