Ghc -> GhcMod: Browse, Check

Language/Haskell/GhcMod.hs

@@ -14,7 +14,7 @@ module Language.Haskell.GhcMod (
   , Expression
   -- * 'IO' utilities
   , bootInfo
-  , browseModule
+  , browse
   , checkSyntax
   , lintSyntax
   , expandTemplate

Language/Haskell/GhcMod/Boot.hs

@@ -20,7 +20,7 @@ boot = do
     mods  <- modules
     langs <- liftIO $ listLanguages opt
     flags <- liftIO $ listFlags opt
-    pre   <- concat <$> mapM (toGhcMod . browse opt) preBrowsedModules
+    pre   <- concat <$> mapM browse preBrowsedModules
     return $ mods ++ langs ++ flags ++ pre
 
 preBrowsedModules :: [String]

Language/Haskell/GhcMod/Browse.hs

@@ -1,6 +1,5 @@
 module Language.Haskell.GhcMod.Browse (
-    browseModule
+    browse
-  , browse
   , browseAll)
   where
 
@@ -16,6 +15,7 @@ import qualified GHC as G
 import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified)
 import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.Gap
+import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
 import Name (getOccString)
 import Outputable (ppr, Outputable)
@@ -27,28 +27,17 @@ import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
 -- | Getting functions, classes, etc from a module.
 --   If 'detailed' is 'True', their types are also obtained.
 --   If 'operators' is 'True', operators are also returned.
-browseModule :: Options
+browse :: ModuleString -- ^ A module name. (e.g. \"Data.List\")
-             -> Cradle
+       -> GhcMod String
-             -> ModuleString -- ^ A module name. (e.g. \"Data.List\")
+browse pkgmdl = do
-             -> IO String
+    opt <- options
-browseModule opt cradle pkgmdl = withGHC' $ do
-    initializeFlagsWithCradle opt cradle
-    browse opt pkgmdl
-
--- | Getting functions, classes, etc from a module.
---   If 'detailed' is 'True', their types are also obtained.
---   If 'operators' is 'True', operators are also returned.
-browse :: Options
-       -> ModuleString -- ^ A module name. (e.g. \"Data.List\")
-       -> Ghc String
-browse opt pkgmdl = do
     convert opt . sort <$> (getModule >>= listExports)
   where
     (mpkg,mdl) = splitPkgMdl pkgmdl
     mdlname = G.mkModuleName mdl
     mpkgid = mkFastString <$> mpkg
     listExports Nothing       = return []
-    listExports (Just mdinfo) = processExports opt mdinfo
+    listExports (Just mdinfo) = processExports mdinfo
     -- findModule works only for package modules, moreover,
     -- you cannot load a package module. On the other hand,
     -- to browse a local module you need to load it first.
@@ -73,12 +62,14 @@ splitPkgMdl pkgmdl = case break (==':') pkgmdl of
     (mdl,"")    -> (Nothing,mdl)
     (pkg,_:mdl) -> (Just pkg,mdl)
 
-processExports :: Options -> ModuleInfo -> Ghc [String]
+processExports :: ModuleInfo -> GhcMod [String]
-processExports opt minfo = mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
+processExports minfo = do
-  where
+  opt <- options
+  let
     removeOps
       | operators opt = id
       | otherwise = filter (isAlpha . head . getOccString)
+  mapM (toGhcMod . showExport opt minfo) $ removeOps $ G.modInfoExports minfo
 
 showExport :: Options -> ModuleInfo -> Name -> Ghc String
 showExport opt minfo e = do

Language/Haskell/GhcMod/Check.hs

@@ -10,20 +10,18 @@ import GHC (Ghc)
 import Language.Haskell.GhcMod.GHCApi
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Logger
+import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
 
 ----------------------------------------------------------------
 
 -- | Checking syntax of a target file using GHC.
 --   Warnings and errors are returned.
-checkSyntax :: Options
+checkSyntax :: [FilePath]  -- ^ The target files.
-            -> Cradle
+            -> GhcMod String
-            -> [FilePath]  -- ^ The target files.
+checkSyntax [] = return ""
-            -> IO String
+checkSyntax files = withErrorHandler sessionName $ do
-checkSyntax _   _      []    = return ""
+    either id id <$> check files
-checkSyntax opt cradle files = withGHC sessionName $ do
-    initializeFlagsWithCradle opt cradle
-    either id id <$> check opt files
   where
     sessionName = case files of
       [file] -> file
@@ -33,10 +31,11 @@ checkSyntax opt cradle files = withGHC sessionName $ do
 
 -- | Checking syntax of a target file using GHC.
 --   Warnings and errors are returned.
-check :: Options
+check :: [FilePath]  -- ^ The target files.
-      -> [FilePath]  -- ^ The target files.
+      -> GhcMod (Either String String)
-      -> Ghc (Either String String)
+check fileNames = do
-check opt fileNames = withLogger opt setAllWaringFlags $
+  opt <- options
+  toGhcMod $ withLogger opt setAllWaringFlags $ do
     setTargetFiles fileNames
 
 ----------------------------------------------------------------

Language/Haskell/GhcMod/Monad.hs

@@ -7,6 +7,7 @@ module Language.Haskell.GhcMod.Monad (
  , GhcModState(..)
  , runGhcMod'
  , runGhcMod
+ , withErrorHandler
  , toGhcMod
  , options
  , module Control.Monad.Reader.Class
@@ -47,6 +48,10 @@ import Control.Monad.Reader.Class
 import Control.Monad.Writer.Class
 import Control.Monad.State.Class
 
+import System.IO (hPutStr, hPrint, stderr)
+import System.Exit (exitSuccess)
+
+
 data GhcModEnv = GhcModEnv {
       gmGhcSession :: !(IORef HscEnv)
     , gmOptions    :: Options
@@ -84,16 +89,29 @@ runGhcMod' r s a = do
   (a', s',w) <- runRWST (unGhcMod $ initGhcMonad (Just libdir) >> a) r s
   return (a',(s',w))
 
+
 runGhcMod :: Options -> GhcMod a -> IO a
-runGhcMod opt a = do
+runGhcMod opt action = do
     session <- newIORef (error "empty session")
     cradle <- findCradle
     let env = GhcModEnv { gmGhcSession = session
                         , gmOptions = opt
                         , gmCradle = cradle }
-    fst <$> runGhcMod' env defaultState (a' cradle)
+    (a,(_,_)) <- runGhcMod' env defaultState $ do
+        dflags <- getSessionDynFlags
+        defaultCleanupHandler dflags $ do
+            toGhcMod $ initializeFlagsWithCradle opt cradle
+            action
+    return a
+
+withErrorHandler :: String -> GhcMod a -> GhcMod a
+withErrorHandler label = ghandle ignore
   where
-    a' cradle = (toGhcMod $ initializeFlagsWithCradle opt cradle) >> a
+    ignore :: SomeException -> GhcMod a
+    ignore e = liftIO $ do
+        hPutStr stderr $ label ++ ":0:0:Error:"
+        hPrint stderr e
+        exitSuccess
 
 toGhcMod :: Ghc a -> GhcMod a
 toGhcMod a = do

src/GHCMod.hs

@@ -9,6 +9,7 @@ import qualified Control.Exception as E
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
 import Language.Haskell.GhcMod
+import Language.Haskell.GhcMod.Monad
 import Paths_ghc_mod
 import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
 import qualified System.Console.GetOpt as O
@@ -112,8 +113,8 @@ main = flip E.catches handlers $ do
       "list"    -> listModules opt cradle
       "lang"    -> listLanguages opt
       "flag"    -> listFlags opt
-      "browse"  -> concat <$> mapM (browseModule opt cradle) remainingArgs
+      "browse"  -> runGhcMod opt $ concat <$> mapM browse remainingArgs
-      "check"   -> checkSyntax opt cradle remainingArgs
+      "check"   -> runGhcMod opt $ checkSyntax remainingArgs
       "expand"  -> expandTemplate opt cradle remainingArgs
       "debug"   -> debugInfo opt cradle
       "info"    -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3

src/GHCModi.hs

@@ -139,13 +139,13 @@ loop opt set mvar = do
     let (cmd,arg') = break (== ' ') cmdArg
         arg = dropWhile (== ' ') arg'
     (ret,ok,set') <- case cmd of
-        "check"  -> toGhcMod $ checkStx opt set arg
+        "check"  -> checkStx opt set arg
         "find"   -> toGhcMod $ findSym  opt set arg mvar
         "lint"   -> toGhcMod $ lintStx  opt set arg
         "info"   -> toGhcMod $ showInfo opt set arg
         "type"   -> toGhcMod $ showType opt set arg
         "boot"   -> bootIt set
-        "browse" -> toGhcMod $ browseIt opt set arg
+        "browse" -> browseIt set arg
         "quit"   -> return ("quit", False, set)
         ""       -> return ("quit", False, set)
         _        -> return ([], True, set)
@@ -162,11 +162,11 @@ loop opt set mvar = do
 checkStx :: Options
          -> Set FilePath
          -> FilePath
-         -> Ghc (String, Bool, Set FilePath)
+         -> GhcMod (String, Bool, Set FilePath)
-checkStx opt set file = do
+checkStx _ set file = do
-    set' <- newFileSet set file
+    set' <- toGhcMod $ newFileSet set file
     let files = S.toList set'
-    eret <- check opt files
+    eret <- check files
     case eret of
         Right ret -> return (ret, True, set')
         Left ret  -> return (ret, True, set) -- fxime: set
@@ -261,10 +261,9 @@ bootIt set = do
     ret <- boot
     return (ret, True, set)
 
-browseIt :: Options
+browseIt :: Set FilePath
-         -> Set FilePath
          -> ModuleString
-         -> Ghc (String, Bool, Set FilePath)
+         -> GhcMod (String, Bool, Set FilePath)
-browseIt opt set mdl = do
+browseIt set mdl = do
-    ret <- browse opt mdl
+    ret <- browse mdl
     return (ret, True, set)

test/BrowseSpec.hs

@@ -5,30 +5,30 @@ import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Cradle
 import Test.Hspec
 
+import TestUtils
 import Dir
 
 spec :: Spec
 spec = do
-    describe "browseModule" $ do
+    describe "browse" $ do
         it "lists up symbols in the module" $ do
-            cradle <- findCradle
+            syms <- runD $ lines <$> browse "Data.Map"
-            syms <- lines <$> browseModule defaultOptions cradle "Data.Map"
             syms `shouldContain` ["differenceWithKey"]
 
-    describe "browseModule -d" $ do
+    describe "browse -d" $ do
         it "lists up symbols with type info in the module" $ do
-            cradle <- findCradle
+            syms <- run defaultOptions { detailed = True }
-            syms <- lines <$> browseModule defaultOptions { detailed = True } cradle "Data.Either"
+                    $ lines <$> browse "Data.Either"
             syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"]
 
         it "lists up data constructors with type info in the module" $ do
             cradle <- findCradle
-            syms <- lines <$> browseModule defaultOptions { detailed = True} cradle "Data.Either"
+            syms <- run defaultOptions { detailed = True}
+                    $ lines <$> browse "Data.Either"
             syms `shouldContain` ["Left :: a -> Either a b"]
 
-    describe "browseModule local" $ do
+    describe "browse local" $ do
         it "lists symbols in a local module" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
+                syms <- runID $ lines <$> browse "Baz"
-                syms <- lines <$> browseModule defaultOptions cradle "Baz"
                 syms `shouldContain` ["baz"]

test/CheckSpec.hs

@@ -6,6 +6,7 @@ import Language.Haskell.GhcMod.Cradle
 import System.FilePath
 import Test.Hspec
 
+import TestUtils
 import Dir
 
 spec :: Spec
@@ -13,26 +14,22 @@ spec = do
     describe "checkSyntax" $ do
         it "can check even if an executable depends on its library" $ do
             withDirectory_ "test/data/ghc-mod-check" $ do
-                cradle <- findCradleWithoutSandbox
+                res <- runID $ checkSyntax ["main.hs"]
-                res <- checkSyntax defaultOptions cradle ["main.hs"]
                 res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n"
 
         it "can check even if a test module imports another test module located at different directory" $ do
             withDirectory_ "test/data/check-test-subdir" $ do
-                cradle <- findCradleWithoutSandbox
+                res <- runID $ checkSyntax ["test/Bar/Baz.hs"]
-                res <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"]
                 res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`)
 
         it "can detect mutually imported modules" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
+                res <- runID $ checkSyntax ["Mutual1.hs"]
-                res <- checkSyntax defaultOptions cradle ["Mutual1.hs"]
                 res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)
 
         it "can check a module using QuasiQuotes" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
+                res <- runID $ checkSyntax ["Baz.hs"]
-                res <- checkSyntax defaultOptions cradle ["Baz.hs"]
                 res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)
 
         context "without errors" $ do

test/TestUtils.hs

@@ -0,0 +1,34 @@
+module TestUtils (
+    run
+  , runD
+  , runI
+  , runID
+  , runIsolatedGhcMod
+  , isolateCradle
+  , module Language.Haskell.GhcMod.Monad
+  , module Language.Haskell.GhcMod.Types
+  ) where
+
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Types
+
+isolateCradle :: GhcMod a -> GhcMod a
+isolateCradle action =
+    local modifyEnv  $ action
+ where
+    modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
+
+runIsolatedGhcMod :: Options -> GhcMod a -> IO a
+runIsolatedGhcMod opt action = runGhcMod opt $ isolateCradle action
+
+-- | Run GhcMod in isolated cradle with default options
+runID = runIsolatedGhcMod defaultOptions
+
+-- | Run GhcMod in isolated cradle
+runI = runIsolatedGhcMod
+
+-- | Run GhcMod
+run = runGhcMod
+
+-- | Run GhcMod with default options
+runD = runGhcMod defaultOptions