diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index a5d7b24..fe98321 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -1,6 +1,5 @@ module Language.Haskell.GhcMod.Check (checkSyntax, check) where -import Control.Applicative ((<$>)) import Control.Monad (void) import CoreMonad (liftIO) import GHC (Ghc, LoadHowMuch(LoadAllTargets)) @@ -18,7 +17,7 @@ checkSyntax :: Options -> [FilePath] -- ^ The target files. -> IO String checkSyntax _ _ [] = error "ghc-mod: checkSyntax: No files given" -checkSyntax opt cradle files = convert opt <$> withGHC sessionName (check opt cradle files) +checkSyntax opt cradle files = withGHC sessionName (check opt cradle files) where sessionName = case files of [file] -> file @@ -31,9 +30,9 @@ checkSyntax opt cradle files = convert opt <$> withGHC sessionName (check opt cr check :: Options -> Cradle -> [FilePath] -- ^ The target files. - -> Ghc [String] + -> Ghc String check _ _ [] = error "ghc-mod: check: No files given" -check opt cradle fileNames = checkIt `G.gcatch` handleErrMsg ls +check opt cradle fileNames = checkIt `G.gcatch` handleErrMsg opt where checkIt = do (readLog,_) <- initializeFlagsWithCradle opt cradle options True @@ -43,4 +42,3 @@ check opt cradle fileNames = checkIt `G.gcatch` handleErrMsg ls options | expandSplice opt = "-w:" : ghcOpts opt | otherwise = "-Wall" : ghcOpts opt - ls = lineSeparator opt diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs index 06712b5..50c9f69 100644 --- a/Language/Haskell/GhcMod/ErrMsg.hs +++ b/Language/Haskell/GhcMod/ErrMsg.hs @@ -17,14 +17,14 @@ import qualified GHC as G import HscTypes (SourceError, srcErrorMessages) import Language.Haskell.GhcMod.Doc (showPage, getStyle) import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Types (LineSeparator(..)) +import Language.Haskell.GhcMod.Types (LineSeparator(..), Options(..), convert) import Outputable (PprStyle, SDoc) import System.FilePath (normalise) ---------------------------------------------------------------- -- | A means to read the log. -type LogReader = IO [String] +type LogReader = IO String ---------------------------------------------------------------- @@ -35,11 +35,11 @@ newtype LogRef = LogRef (IORef Builder) newLogRef :: IO LogRef newLogRef = LogRef <$> newIORef id -readAndClearLogRef :: LogRef -> IO [String] -readAndClearLogRef (LogRef ref) = do +readAndClearLogRef :: Options -> LogRef -> IO String +readAndClearLogRef opt (LogRef ref) = do b <- readIORef ref writeIORef ref id - return $! b [] + return $! convert opt (b []) appendLogRef :: DynFlags -> LineSeparator -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () appendLogRef df ls (LogRef ref) _ sev src style msg = do @@ -48,23 +48,28 @@ appendLogRef df ls (LogRef ref) _ sev src style msg = do ---------------------------------------------------------------- -setLogger :: Bool -> DynFlags -> LineSeparator -> IO (DynFlags, LogReader) +setLogger :: Bool -> DynFlags -> Options -> IO (DynFlags, LogReader) setLogger False df _ = return (newdf, undefined) where newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return () -setLogger True df ls = do +setLogger True df opt = do logref <- newLogRef let newdf = Gap.setLogAction df $ appendLogRef df ls logref - return (newdf, readAndClearLogRef logref) + return (newdf, readAndClearLogRef opt logref) + where + ls = lineSeparator opt ---------------------------------------------------------------- -- | Converting 'SourceError' to 'String'. -handleErrMsg :: LineSeparator -> SourceError -> Ghc [String] -handleErrMsg ls err = do +handleErrMsg :: Options -> SourceError -> Ghc String +handleErrMsg opt err = do dflag <- G.getSessionDynFlags style <- getStyle - return . errBagToStrList dflag ls style . srcErrorMessages $ err + let ret = convert opt . errBagToStrList dflag ls style . srcErrorMessages $ err + return ret + where + ls = lineSeparator opt errBagToStrList :: DynFlags -> LineSeparator -> PprStyle -> Bag ErrMsg -> [String] errBagToStrList dflag ls style = map (ppErrMsg dflag ls style) . reverse . bagToList diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index 7d54c96..fcc6867 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -113,12 +113,11 @@ initSession build opt compOpts logging = do cmdOpts = ghcOptions compOpts idirs = includeDirs compOpts depPkgs = depPackages compOpts - ls = lineSeparator opt setupDynamicFlags df0 = do df1 <- modifyFlagsWithOpts df0 cmdOpts let df2 = modifyFlags df1 idirs depPkgs (expandSplice opt) build df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt - liftIO $ setLogger logging df3 ls + liftIO $ setLogger logging df3 opt ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index 00b476e..0e927b5 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -6,14 +6,12 @@ module Language.Haskell.GhcMod.Ghc ( , browse , check , info - , typeOf + , types , modules - , lint ) where import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Check import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Info -import Language.Haskell.GhcMod.Lint import Language.Haskell.GhcMod.List diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 825d1ae..5e398ec 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -5,7 +5,7 @@ module Language.Haskell.GhcMod.Info ( infoExpr , info , typeExpr - , typeOf + , types ) where import Control.Applicative ((<$>)) @@ -13,7 +13,7 @@ import Control.Monad (void) import CoreMonad (liftIO) import CoreUtils (exprType) import Data.Function (on) -import Data.Generics hiding (typeOf) +import Data.Generics import Data.List (sortBy) import Data.Maybe (catMaybes, fromMaybe) import Data.Ord as O @@ -72,17 +72,17 @@ typeExpr :: Options -> Int -- ^ Column number. -> IO String typeExpr opt cradle file lineNo colNo = withGHCDummyFile $ - inModuleContext opt cradle file (typeOf opt file lineNo colNo) errmsg + inModuleContext opt cradle file (types opt file lineNo colNo) errmsg where errmsg = convert opt ([] :: [((Int,Int,Int,Int),String)]) -- | Obtaining type of a target expression. (GHCi's type:) -typeOf :: Options - -> FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> Ghc String -typeOf opt file lineNo colNo = do +types :: Options + -> FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> Ghc String +types opt file lineNo colNo = do modSum <- Gap.setCtx file (dflag, style) <- getFlagStyle srcSpanTypes <- getSrcSpanType modSum lineNo colNo diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs index 2b8af52..6336844 100644 --- a/Language/Haskell/GhcMod/Lint.hs +++ b/Language/Haskell/GhcMod/Lint.hs @@ -10,15 +10,8 @@ import Language.Haskell.HLint (hlint) lintSyntax :: Options -> FilePath -- ^ A target file. -> IO String -lintSyntax opt file = pack <$> lint hopts file +lintSyntax opt file = pack . map show <$> hlint (file : "--quiet" : hopts) where LineSeparator lsep = lineSeparator opt pack = convert opt . map (intercalate lsep . lines) hopts = hlintOpts opt - --- | Checking syntax of a target file using hlint. --- Warnings and errors are returned. -lint :: [String] - -> FilePath -- ^ A target file. - -> IO [String] -lint hopts file = map show <$> hlint (file : "--quiet" : hopts) diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 505eabd..21d8074 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -56,7 +56,7 @@ import System.IO (hFlush,stdout) ---------------------------------------------------------------- type DB = Map String [String] -type Logger = IO [String] +type Logger = IO String ---------------------------------------------------------------- @@ -119,12 +119,11 @@ main = handle [GE.Handler cmdHandler, GE.Handler someHandler] $ cradle0 <- findCradle let rootdir = cradleRootDir cradle0 cradle = cradle0 { cradleCurrentDir = rootdir } - ls = lineSeparator opt setCurrentDirectory rootdir mvar <- liftIO newEmptyMVar mlibdir <- getSystemLibDir void $ forkIO $ setupDB cradle mlibdir opt mvar - run cradle mlibdir opt $ loop opt S.empty ls mvar + run cradle mlibdir opt $ loop opt S.empty mvar ---------------------------------------------------------------- @@ -148,17 +147,17 @@ setupDB cradle mlibdir opt mvar = E.handle handler $ do ---------------------------------------------------------------- -loop :: Options -> Set FilePath -> LineSeparator -> MVar DB -> Logger -> Ghc () -loop opt set ls mvar readLog = do +loop :: Options -> Set FilePath -> MVar DB -> Logger -> Ghc () +loop opt set mvar readLog = do cmdArg <- liftIO getLine let (cmd,arg') = break (== ' ') cmdArg arg = dropWhile (== ' ') arg' (ret,ok,set') <- case cmd of - "check" -> checkStx opt set ls readLog arg - "find" -> findSym opt set mvar arg - "lint" -> lintStx opt set ls arg - "info" -> showInfo opt set ls readLog arg - "type" -> showType opt set ls readLog arg + "check" -> checkStx opt set arg readLog + "find" -> findSym opt set arg mvar + "lint" -> lintStx opt set arg + "info" -> showInfo opt set arg readLog + "type" -> showType opt set arg readLog _ -> return ([], False, set) let put = case outputStyle opt of LispStyle -> putStr @@ -166,17 +165,16 @@ loop opt set ls mvar readLog = do liftIO $ put ret liftIO $ putStrLn $ if ok then "OK" else "NG" liftIO $ hFlush stdout - when ok $ loop opt set' ls mvar readLog + when ok $ loop opt set' mvar readLog ---------------------------------------------------------------- checkStx :: Options -> Set FilePath - -> LineSeparator - -> Logger -> FilePath + -> Logger -> Ghc (String, Bool, Set FilePath) -checkStx opt set ls readLog file = do +checkStx opt set file readLog = do let add = not $ S.member file set GE.ghandle handler $ do mdel <- removeMainTarget @@ -192,8 +190,7 @@ checkStx opt set ls readLog file = do where handler :: SourceError -> Ghc (String, Bool, Set FilePath) handler err = do - errmsgs <- handleErrMsg ls err - let ret = convert opt errmsgs + ret <- handleErrMsg opt err return (ret, False, set) removeMainTarget = do mx <- find isMain <$> G.getModuleGraph @@ -212,22 +209,22 @@ checkStx opt set ls readLog file = do return $ Just mainfile isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main" -findSym :: Options -> Set FilePath -> MVar DB -> String +findSym :: Options -> Set FilePath -> String -> MVar DB -> Ghc (String, Bool, Set FilePath) -findSym opt set mvar sym = do +findSym opt set sym mvar = do db <- liftIO $ readMVar mvar let ret = convert opt $ fromMaybe [] (M.lookup sym db) return (ret, True, set) -lintStx :: Options -> Set FilePath -> LineSeparator -> FilePath +lintStx :: Options -> Set FilePath -> FilePath -> Ghc (String, Bool, Set FilePath) -lintStx opt set (LineSeparator lsep) optFile = liftIO $ E.handle handler $ do - msgs <- map (intercalate lsep . lines) <$> lint hopts file - let ret = convert opt msgs +lintStx opt set optFile = liftIO $ E.handle handler $ do + ret <-lintSyntax opt' file return (ret, True, set) where (opts,file) = parseLintOptions optFile hopts = if opts == "" then [] else read opts + opt' = opt { hlintOpts = hopts } -- let's continue the session handler (SomeException e) = do print e @@ -250,26 +247,24 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of showInfo :: Options -> Set FilePath - -> LineSeparator - -> Logger -> FilePath + -> Logger -> Ghc (String, Bool, Set FilePath) -showInfo opt set ls readLog fileArg = do +showInfo opt set fileArg readLog = do let [file, expr] = words fileArg - (_, _, set') <- checkStx opt set ls readLog file + (_, _, set') <- checkStx opt set file readLog ret <- info opt file expr _ <- liftIO readLog return (ret, True, set') showType :: Options -> Set FilePath - -> LineSeparator - -> Logger -> FilePath + -> Logger -> Ghc (String, Bool, Set FilePath) -showType opt set ls readLog fileArg = do +showType opt set fileArg readLog = do let [file, line, column] = words fileArg - (_, _, set') <- checkStx opt set ls readLog file - ret <- typeOf opt file (read line) (read column) + (_, _, set') <- checkStx opt set file readLog + ret <- types opt file (read line) (read column) _ <- liftIO readLog return (ret, True, set')