cleaning up check, splice flag and logger.

This commit is contained in:
Kazu Yamamoto 2014-04-26 17:54:15 +09:00
parent 74cde29ae0
commit c45415a367
12 changed files with 88 additions and 88 deletions

View File

@ -16,6 +16,7 @@ module Language.Haskell.GhcMod (
, browseModule
, checkSyntax
, lintSyntax
, expandTemplate
, infoExpr
, typeExpr
, listModules

View File

@ -6,7 +6,6 @@ module Language.Haskell.GhcMod.Browse (
import Control.Applicative ((<$>))
import Control.Exception (SomeException(..))
import Control.Monad (void)
import Data.Char (isAlpha)
import Data.List (sort)
import Data.Maybe (catMaybes)
@ -33,7 +32,7 @@ browseModule :: Options
-> ModuleString -- ^ A module name. (e.g. \"Data.List\")
-> IO String
browseModule opt cradle pkgmdl = withGHC' $ do
void $ initializeFlagsWithCradle opt cradle [] False
initializeFlagsWithCradle opt cradle []
browse opt pkgmdl
-- | Getting functions, classes, etc from a module.

View File

@ -1,10 +1,15 @@
module Language.Haskell.GhcMod.Check (checkSyntax, check) where
module Language.Haskell.GhcMod.Check (
checkSyntax
, check
, expandTemplate
, expand
) where
import CoreMonad (liftIO)
import Exception (ghandle)
import GHC (Ghc)
import qualified GHC as G
import Language.Haskell.GhcMod.ErrMsg
import Language.Haskell.GhcMod.GHCApi
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types
----------------------------------------------------------------
@ -15,28 +20,51 @@ checkSyntax :: Options
-> Cradle
-> [FilePath] -- ^ The target files.
-> IO String
checkSyntax _ _ [] = error "ghc-mod: checkSyntax: No files given"
checkSyntax opt cradle files = withGHC sessionName (check opt cradle files)
checkSyntax _ _ [] = return ""
checkSyntax opt cradle files = withGHC sessionName $ do
initializeFlagsWithCradle opt cradle options
check opt files
where
sessionName = case files of
[file] -> file
_ -> "MultipleFiles"
options = "-Wall" : ghcOpts opt
----------------------------------------------------------------
-- | Checking syntax of a target file using GHC.
-- Warnings and errors are returned.
check :: Options
-> Cradle
-> [FilePath] -- ^ The target files.
-> Ghc String
check _ _ [] = error "ghc-mod: check: No files given"
check opt cradle fileNames = checkIt `G.gcatch` handleErrMsg opt
check opt fileNames = ghandle (handleErrMsg opt) $
withLogger opt $ setTargetFiles fileNames
----------------------------------------------------------------
-- | Expanding syntax of a target file using GHC.
-- Warnings and errors are returned.
expandTemplate :: Options
-> Cradle
-> [FilePath] -- ^ The target files.
-> IO String
expandTemplate _ _ [] = return ""
expandTemplate opt cradle files = withGHC sessionName $ do
initializeFlagsWithCradle opt cradle options
expand opt files
where
checkIt = do
(readLog,_) <- initializeFlagsWithCradle opt cradle options True
setTargetFiles fileNames
liftIO readLog
options
| expandSplice opt = "-w:" : ghcOpts opt
| otherwise = "-Wall" : ghcOpts opt
sessionName = case files of
[file] -> file
_ -> "MultipleFiles"
options = "-w:" : ghcOpts opt
----------------------------------------------------------------
-- | Expanding syntax of a target file using GHC.
-- Warnings and errors are returned.
expand :: Options
-> [FilePath] -- ^ The target files.
-> Ghc String
expand opt fileNames = ghandle (handleErrMsg opt) $
withDynFlags Gap.setDumpSplices $
withLogger opt $ setTargetFiles fileNames

View File

@ -2,13 +2,14 @@
module Language.Haskell.GhcMod.ErrMsg (
LogReader
, setLogger
, withLogger
, handleErrMsg
, checkErrorPrefix
) where
import Bag (Bag, bagToList)
import Control.Applicative ((<$>))
import CoreMonad (liftIO)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.Maybe (fromMaybe)
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
@ -16,6 +17,7 @@ import GHC (Ghc, DynFlags, SrcSpan, Severity(SevError))
import qualified GHC as G
import HscTypes (SourceError, srcErrorMessages)
import Language.Haskell.GhcMod.Doc (showPage, getStyle)
import Language.Haskell.GhcMod.GHCApi (withDynFlags)
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types (Options, convert)
import Outputable (PprStyle, SDoc)
@ -48,14 +50,12 @@ appendLogRef df (LogRef ref) _ sev src style msg = do
----------------------------------------------------------------
setLogger :: Bool -> DynFlags -> Options -> IO (DynFlags, LogReader)
setLogger False df _ = return (newdf, undefined)
where
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
setLogger True df opt = do
logref <- newLogRef
let newdf = Gap.setLogAction df $ appendLogRef df logref
return (newdf, readAndClearLogRef opt logref)
withLogger :: Options -> Ghc () -> Ghc String
withLogger opt body = do
logref <- liftIO $ newLogRef
withDynFlags (\df -> Gap.setLogAction df $ appendLogRef df logref) $ do
body
liftIO $ readAndClearLogRef opt logref
----------------------------------------------------------------

View File

@ -2,7 +2,6 @@
module Language.Haskell.GhcMod.Find where
import Control.Monad (void)
import Data.Function (on)
import Data.List (groupBy, sort)
import Data.Maybe (fromMaybe)
@ -34,7 +33,7 @@ newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString])
-- | Find modules to which the symbol belong.
findSymbol :: Options -> Cradle -> Symbol -> IO String
findSymbol opt cradle sym = withGHC' $ do
void $ initializeFlagsWithCradle opt cradle [] False
initializeFlagsWithCradle opt cradle []
lookupSym opt sym <$> getSymMdlDb
-- | Creating 'SymMdlDb'.

View File

@ -12,7 +12,6 @@ module Language.Haskell.GhcMod.GHCApi (
) where
import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.ErrMsg
import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.GhcPkg
@ -20,7 +19,6 @@ import Control.Applicative ((<$>))
import Control.Monad (forM, void, unless)
import CoreMonad (liftIO)
import Data.Maybe (isJust, fromJust)
import Distribution.PackageDescription (PackageDescription)
import Exception (ghandle, SomeException(..))
import GHC (Ghc, GhcMonad, DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
import qualified GHC as G
@ -75,9 +73,8 @@ initializeFlagsWithCradle :: GhcMonad m
=> Options
-> Cradle
-> [GHCOption]
-> Bool
-> m (LogReader, Maybe PackageDescription)
initializeFlagsWithCradle opt cradle ghcopts logging
-> m ()
initializeFlagsWithCradle opt cradle ghcopts
| cabal = withCabal |||> withSandbox
| otherwise = withSandbox
where
@ -86,11 +83,8 @@ initializeFlagsWithCradle opt cradle ghcopts logging
withCabal = do
pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile
compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc
logger <- initSession CabalPkg opt compOpts logging
return (logger, Just pkgDesc)
withSandbox = do
logger <- initSession SingleFile opt compOpts logging
return (logger, Nothing)
initSession CabalPkg opt compOpts
withSandbox = initSession SingleFile opt compOpts
where
pkgOpts = ghcDbStackOpts $ cradlePkgDbStack cradle
compOpts
@ -105,25 +99,18 @@ initSession :: GhcMonad m
=> Build
-> Options
-> CompilerOptions
-> Bool
-> m LogReader
initSession build opt compOpts logging = do
df <- initDynFlags build opt compOpts
(df', lg) <- liftIO $ setLogger logging df opt
_ <- G.setSessionDynFlags df'
return lg
initDynFlags :: GhcMonad m => Build -> Options -> CompilerOptions -> m DynFlags
initDynFlags build Options {..} CompilerOptions {..} = do
-> m ()
initSession build Options {..} CompilerOptions {..} = do
df <- G.getSessionDynFlags
_ <- G.setSessionDynFlags =<< (addCmdOpts ghcOptions
void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions
$ setLinkerOptions
$ setIncludeDirs includeDirs
$ setSplice expandSplice
$ setBuildEnv build
$ setEmptyLogger
$ Gap.addPackageFlags depPackages df)
G.getSessionDynFlags
setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
----------------------------------------------------------------
@ -142,12 +129,6 @@ setIncludeDirs idirs df = df { importPaths = idirs }
setBuildEnv :: Build -> DynFlags -> DynFlags
setBuildEnv build = setHideAllPackages build . setCabalPackage build
-- | Set option in 'DynFlags' to Expand template haskell if first argument is
-- True
setSplice :: Bool -> DynFlags -> DynFlags
setSplice False = id
setSplice True = Gap.setDumpSplices
-- At the moment with this option set ghc only prints different error messages,
-- suggesting the user to add a hidden package to the build-depends in his cabal
-- file for example

View File

@ -41,7 +41,7 @@ infoExpr :: Options
-> Expression -- ^ A Haskell expression.
-> IO String
infoExpr opt cradle file expr = withGHC' $ do
void $ initializeFlagsWithCradle opt cradle noWaringOptions False
initializeFlagsWithCradle opt cradle noWaringOptions
info opt file expr
-- | Obtaining information of a target expression. (GHCi's info:)
@ -79,7 +79,7 @@ typeExpr :: Options
-> Int -- ^ Column number.
-> IO String
typeExpr opt cradle file lineNo colNo = withGHC' $ do
void $ initializeFlagsWithCradle opt cradle noWaringOptions False
initializeFlagsWithCradle opt cradle noWaringOptions
types opt file lineNo colNo
-- | Obtaining type of a target expression. (GHCi's type:)

View File

@ -26,6 +26,7 @@ module Language.Haskell.GhcMod.Internal (
, setTargetFiles
, addTargetFiles
, handleErrMsg
, withLogger
-- * 'Ghc' Choice
, (||>)
, goNext

View File

@ -2,7 +2,6 @@ module Language.Haskell.GhcMod.List (listModules, modules) where
import Control.Applicative ((<$>))
import Control.Exception (SomeException(..))
import Control.Monad (void)
import Data.List (nub, sort)
import GHC (Ghc)
import qualified GHC as G
@ -16,7 +15,7 @@ import UniqFM (eltsUFM)
-- | Listing installed modules.
listModules :: Options -> Cradle -> IO String
listModules opt cradle = withGHC' $ do
void $ initializeFlagsWithCradle opt cradle [] False
initializeFlagsWithCradle opt cradle []
modules opt
-- | Listing installed modules.

View File

@ -21,8 +21,6 @@ data Options = Options {
, detailed :: Bool
-- | If 'True', 'browse' will return fully qualified name
, qualified :: Bool
-- | Whether or not Template Haskell should be expanded.
, expandSplice :: Bool
-- | Line separator string.
, lineSeparator :: LineSeparator
}
@ -36,7 +34,6 @@ defaultOptions = Options {
, operators = False
, detailed = False
, qualified = False
, expandSplice = False
, lineSeparator = LineSeparator "\0"
}

View File

@ -116,7 +116,7 @@ main = flip E.catches handlers $ do
"flag" -> listFlags opt
"browse" -> concat <$> mapM (browseModule opt cradle) remainingArgs
"check" -> checkSyntax opt cradle remainingArgs
"expand" -> checkSyntax opt { expandSplice = True } cradle remainingArgs
"expand" -> expandTemplate opt cradle remainingArgs
"debug" -> debugInfo opt cradle
"info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3
"type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)

View File

@ -119,34 +119,34 @@ replace (x:xs) = x : replace xs
----------------------------------------------------------------
run :: Cradle -> Maybe FilePath -> Options -> (Logger -> Ghc a) -> IO a
run :: Cradle -> Maybe FilePath -> Options -> Ghc a -> IO a
run cradle mlibdir opt body = G.runGhc mlibdir $ do
(readLog,_) <- initializeFlagsWithCradle opt cradle ["-Wall"] True
initializeFlagsWithCradle opt cradle ["-Wall"]
dflags <- G.getSessionDynFlags
G.defaultCleanupHandler dflags $ body readLog
G.defaultCleanupHandler dflags body
----------------------------------------------------------------
setupDB :: Cradle -> Maybe FilePath -> Options -> MVar SymMdlDb -> IO ()
setupDB cradle mlibdir opt mvar = E.handle handler $ do
db <- run cradle mlibdir opt $ \_ -> getSymMdlDb
db <- run cradle mlibdir opt getSymMdlDb
putMVar mvar db
where
handler (SomeException _) = return () -- fixme: put emptyDb?
----------------------------------------------------------------
loop :: Options -> Set FilePath -> MVar SymMdlDb -> Logger -> Ghc ()
loop opt set mvar readLog = do
loop :: Options -> Set FilePath -> MVar SymMdlDb -> Ghc ()
loop opt set mvar = do
cmdArg <- liftIO getLine
let (cmd,arg') = break (== ' ') cmdArg
arg = dropWhile (== ' ') arg'
(ret,ok,set') <- case cmd of
"check" -> checkStx opt set arg readLog
"check" -> checkStx opt set arg
"find" -> findSym opt set arg mvar
"lint" -> lintStx opt set arg
"info" -> showInfo opt set arg readLog
"type" -> showType opt set arg readLog
"info" -> showInfo opt set arg
"type" -> showType opt set arg
"boot" -> bootIt opt set
"browse" -> browseIt opt set arg
"quit" -> return ("quit", False, set)
@ -158,22 +158,21 @@ loop opt set mvar readLog = do
else do
liftIO $ putStrLn $ "NG " ++ replace ret
liftIO $ hFlush stdout
when ok $ loop opt set' mvar readLog
when ok $ loop opt set' mvar
----------------------------------------------------------------
checkStx :: Options
-> Set FilePath
-> FilePath
-> Logger
-> Ghc (String, Bool, Set FilePath)
checkStx opt set file readLog = do
checkStx opt set file = do
let add = not $ S.member file set
GE.ghandle handler $ do
mdel <- removeMainTarget
ret <- withLogger opt $ do
when add $ addTargetFiles [file]
void $ G.load LoadAllTargets
ret <- liftIO readLog
let set1 = if add then S.insert file set else set
set2 = case mdel of
Nothing -> set1
@ -238,25 +237,21 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
showInfo :: Options
-> Set FilePath
-> FilePath
-> Logger
-> Ghc (String, Bool, Set FilePath)
showInfo opt set fileArg readLog = do
showInfo opt set fileArg = do
let [file, expr] = words fileArg
(_, _, set') <- checkStx opt set file readLog
(_, _, set') <- checkStx opt set file
ret <- info opt file expr
_ <- liftIO readLog
return (ret, True, set')
showType :: Options
-> Set FilePath
-> FilePath
-> Logger
-> Ghc (String, Bool, Set FilePath)
showType opt set fileArg readLog = do
showType opt set fileArg = do
let [file, line, column] = words fileArg
(_, _, set') <- checkStx opt set file readLog
(_, _, set') <- checkStx opt set file
ret <- types opt file (read line) (read column)
_ <- liftIO readLog
return (ret, True, set')
----------------------------------------------------------------