cleaning up check, splice flag and logger.

Language/Haskell/GhcMod.hs

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

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.

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

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
 
 ----------------------------------------------------------------
 

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'.

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

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:)

Language/Haskell/GhcMod/Internal.hs

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

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.

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"
   }
 

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)

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')
 
 ----------------------------------------------------------------