diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 601b6c5..0ce414d 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -14,7 +14,7 @@ module Language.Haskell.GhcMod ( , Expression -- * 'IO' utilities , bootInfo - , browseModule + , browse , checkSyntax , lintSyntax , expandTemplate diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs index 38f6ac4..8cdfeb1 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ b/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] diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 2026cd8..717ea6b 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/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 - -> Cradle - -> ModuleString -- ^ A module name. (e.g. \"Data.List\") - -> IO String -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 +browse :: ModuleString -- ^ A module name. (e.g. \"Data.List\") + -> GhcMod String +browse pkgmdl = do + opt <- options 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 opt minfo = mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo - where +processExports :: ModuleInfo -> GhcMod [String] +processExports minfo = do + 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 diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index b720f8d..a3ddf08 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/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 - -> Cradle - -> [FilePath] -- ^ The target files. - -> IO String -checkSyntax _ _ [] = return "" -checkSyntax opt cradle files = withGHC sessionName $ do - initializeFlagsWithCradle opt cradle - either id id <$> check opt files +checkSyntax :: [FilePath] -- ^ The target files. + -> GhcMod String +checkSyntax [] = return "" +checkSyntax files = withErrorHandler sessionName $ do + either id id <$> check 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 - -> [FilePath] -- ^ The target files. - -> Ghc (Either String String) -check opt fileNames = withLogger opt setAllWaringFlags $ +check :: [FilePath] -- ^ The target files. + -> GhcMod (Either String String) +check fileNames = do + opt <- options + toGhcMod $ withLogger opt setAllWaringFlags $ do setTargetFiles fileNames ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 58fc3c6..d49c693 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/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) - where - a' cradle = (toGhcMod $ initializeFlagsWithCradle opt cradle) >> a + (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 + 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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 265be66..2cc02a8 100644 --- a/src/GHCMod.hs +++ b/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 - "check" -> checkSyntax opt cradle remainingArgs + "browse" -> runGhcMod opt $ concat <$> mapM browse remainingArgs + "check" -> runGhcMod opt $ checkSyntax remainingArgs "expand" -> expandTemplate opt cradle remainingArgs "debug" -> debugInfo opt cradle "info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3 diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 3695b21..7aadb4c 100644 --- a/src/GHCModi.hs +++ b/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) -checkStx opt set file = do - set' <- newFileSet set file + -> GhcMod (String, Bool, Set FilePath) +checkStx _ set file = do + 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 - -> Set FilePath +browseIt :: Set FilePath -> ModuleString - -> Ghc (String, Bool, Set FilePath) -browseIt opt set mdl = do - ret <- browse opt mdl + -> GhcMod (String, Bool, Set FilePath) +browseIt set mdl = do + ret <- browse mdl return (ret, True, set) diff --git a/test/BrowseSpec.hs b/test/BrowseSpec.hs index 6b44600..9a0d87d 100644 --- a/test/BrowseSpec.hs +++ b/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 <- lines <$> browseModule defaultOptions cradle "Data.Map" + syms <- runD $ lines <$> browse "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 <- lines <$> browseModule defaultOptions { detailed = True } cradle "Data.Either" + syms <- run defaultOptions { detailed = True } + $ 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 <- lines <$> browseModule defaultOptions cradle "Baz" + syms <- runID $ lines <$> browse "Baz" syms `shouldContain` ["baz"] diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index 27fbbfb..f2ff7e9 100644 --- a/test/CheckSpec.hs +++ b/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 <- checkSyntax defaultOptions cradle ["main.hs"] + res <- runID $ checkSyntax ["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 <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"] + res <- runID $ checkSyntax ["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 <- checkSyntax defaultOptions cradle ["Mutual1.hs"] + res <- runID $ checkSyntax ["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 <- checkSyntax defaultOptions cradle ["Baz.hs"] + res <- runID $ checkSyntax ["Baz.hs"] res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`) context "without errors" $ do diff --git a/test/TestUtils.hs b/test/TestUtils.hs new file mode 100644 index 0000000..acb6e21 --- /dev/null +++ b/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