diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 0d93ecc..bcfd15b 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -16,6 +16,7 @@ module Language.Haskell.GhcMod ( , browseModule , checkSyntax , lintSyntax + , expandTemplate , infoExpr , typeExpr , listModules diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 5efc5bf..729c2ee 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -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. diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index 25d62ba..6ce7e83 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -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 diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs index 1b38a0d..acced15 100644 --- a/Language/Haskell/GhcMod/ErrMsg.hs +++ b/Language/Haskell/GhcMod/ErrMsg.hs @@ -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 ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 26ea8d1..e35604e 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -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'. diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index b4aa2c9..c9fb5a4 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 2203192..bae6573 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -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:) diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 1ef2339..f21fbac 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -26,6 +26,7 @@ module Language.Haskell.GhcMod.Internal ( , setTargetFiles , addTargetFiles , handleErrMsg + , withLogger -- * 'Ghc' Choice , (||>) , goNext diff --git a/Language/Haskell/GhcMod/List.hs b/Language/Haskell/GhcMod/List.hs index 30fa5c4..44188df 100644 --- a/Language/Haskell/GhcMod/List.hs +++ b/Language/Haskell/GhcMod/List.hs @@ -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. diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index f043c6c..0a57187 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -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" } diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 6807e33..17eb70a 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -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) diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 9404e3c..20d66bc 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -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 - when add $ addTargetFiles [file] - void $ G.load LoadAllTargets - ret <- liftIO readLog + ret <- withLogger opt $ do + when add $ addTargetFiles [file] + void $ G.load LoadAllTargets 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') ----------------------------------------------------------------