ghc-mod 0.6.0 → 0.6.1
raw patch · 12 files changed
+202/−118 lines, 12 files
Files
- Browse.hs +4/−4
- Cabal.hs +18/−29
- Check.hs +11/−55
- ErrMsg.hs +85/−0
- GHCMod.hs +16/−4
- Info.hs +22/−12
- Lint.hs +1/−1
- List.hs +4/−4
- Types.hs +25/−5
- elisp/ghc-flymake.el +13/−1
- elisp/ghc.el +1/−1
- ghc-mod.cabal +2/−2
Browse.hs view
@@ -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
Cabal.hs view
@@ -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
Check.hs view
@@ -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)
+ ErrMsg.hs view
@@ -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
GHCMod.hs view
@@ -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] <module> [<module> ...]\n"- ++ "\t ghc-mod check <HaskellFile>\n"+ ++ "\t ghc-mod check [-i inc] <HaskellFile>\n" ++ "\t ghc-mod type <HaskellFile> <module> <expression>\n" ++ "\t ghc-mod info <HaskellFile> <module> <expression>\n" ++ "\t ghc-mod lint [-h opt] <HaskellFile>\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
Info.hs view
@@ -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
Lint.hs view
@@ -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)
List.hs view
@@ -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
Types.hs view
@@ -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 ----------------------------------------------------------------
elisp/ghc-flymake.el view
@@ -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)
elisp/ghc.el view
@@ -16,7 +16,7 @@ ;;; Code: -(defconst ghc-version "0.6.0")+(defconst ghc-version "0.6.1") ;; (eval-when-compile ;; (require 'haskell-mode))
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 0.6.0+Version: 0.6.1 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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