From e5c6d3e4728ab2ed245a3432b91f44b7df9468fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 10 May 2014 13:51:35 +0200 Subject: [PATCH 1/7] Start migrating Ghc -> GhcMod monad --- Language/Haskell/GhcMod/Boot.hs | 18 ++++++++--------- Language/Haskell/GhcMod/List.hs | 17 ++++++++-------- Language/Haskell/GhcMod/Monad.hs | 4 ++++ src/GHCMod.hs | 2 +- src/GHCModi.hs | 33 ++++++++++++++++---------------- 5 files changed, 37 insertions(+), 37 deletions(-) diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs index cba7341..38f6ac4 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ b/Language/Haskell/GhcMod/Boot.hs @@ -2,27 +2,25 @@ module Language.Haskell.GhcMod.Boot where import Control.Applicative ((<$>)) import CoreMonad (liftIO, liftIO) -import GHC (Ghc) import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Flag -import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.List +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types -- | Printing necessary information for front-end booting. -bootInfo :: Options -> Cradle -> IO String -bootInfo opt cradle = withGHC' $ do - initializeFlagsWithCradle opt cradle - boot opt +bootInfo :: Options -> IO String +bootInfo opt = runGhcMod opt $ boot -- | Printing necessary information for front-end booting. -boot :: Options -> Ghc String -boot opt = do - mods <- modules opt +boot :: GhcMod String +boot = do + opt <- options + mods <- modules langs <- liftIO $ listLanguages opt flags <- liftIO $ listFlags opt - pre <- concat <$> mapM (browse opt) preBrowsedModules + pre <- concat <$> mapM (toGhcMod . browse opt) preBrowsedModules return $ mods ++ langs ++ flags ++ pre preBrowsedModules :: [String] diff --git a/Language/Haskell/GhcMod/List.hs b/Language/Haskell/GhcMod/List.hs index b2ce287..e7565e9 100644 --- a/Language/Haskell/GhcMod/List.hs +++ b/Language/Haskell/GhcMod/List.hs @@ -3,9 +3,8 @@ module Language.Haskell.GhcMod.List (listModules, modules) where import Control.Applicative ((<$>)) import Control.Exception (SomeException(..)) import Data.List (nub, sort) -import GHC (Ghc) import qualified GHC as G -import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Packages (pkgIdMap, exposedModules, sourcePackageId, display) import UniqFM (eltsUFM) @@ -14,13 +13,13 @@ import UniqFM (eltsUFM) -- | Listing installed modules. listModules :: Options -> Cradle -> IO String -listModules opt cradle = withGHC' $ do - initializeFlagsWithCradle opt cradle - modules opt +listModules opt _ = runGhcMod opt $ modules -- | Listing installed modules. -modules :: Options -> Ghc String -modules opt = convert opt . arrange <$> (getModules `G.gcatch` handler) +modules :: GhcMod String +modules = do + opt <- options + convert opt . (arrange opt) <$> (getModules `G.gcatch` handler) where getModules = getExposedModules <$> G.getSessionDynFlags getExposedModules = concatMap exposedModules' @@ -29,8 +28,8 @@ modules opt = convert opt . arrange <$> (getModules `G.gcatch` handler) map G.moduleNameString (exposedModules p) `zip` repeat (display $ sourcePackageId p) - arrange = nub . sort . map dropPkgs - dropPkgs (name, pkg) + arrange opt = nub . sort . map (dropPkgs opt) + dropPkgs opt (name, pkg) | detailed opt = name ++ " " ++ pkg | otherwise = name handler (SomeException _) = return [] diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 5cfa8c1..58fc3c6 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -8,6 +8,7 @@ module Language.Haskell.GhcMod.Monad ( , runGhcMod' , runGhcMod , toGhcMod + , options , module Control.Monad.Reader.Class , module Control.Monad.Writer.Class , module Control.Monad.State.Class @@ -99,6 +100,9 @@ toGhcMod a = do s <- gmGhcSession <$> ask liftIO $ unGhc a $ Session s +options :: GhcMod Options +options = gmOptions <$> ask + instance MonadBase IO GhcMod where liftBase = GhcMod . liftBase diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 98b2563..265be66 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -122,7 +122,7 @@ main = flip E.catches handlers $ do "lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1 "root" -> rootInfo opt cradle "doc" -> nArgs 1 $ packageDoc opt cradle cmdArg1 - "boot" -> bootInfo opt cradle + "boot" -> bootInfo opt "version" -> return progVersion "help" -> return $ O.usageInfo usage argspec cmd -> E.throw (NoSuchCommand cmd) diff --git a/src/GHCModi.hs b/src/GHCModi.hs index aba6609..3695b21 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -35,6 +35,7 @@ import GHC (Ghc) import qualified GHC as G import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Ghc +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Internal import Paths_ghc_mod import System.Console.GetOpt @@ -116,9 +117,8 @@ replace (x:xs) = x : replace xs ---------------------------------------------------------------- -run :: Cradle -> Maybe FilePath -> Options -> Ghc a -> IO a -run cradle mlibdir opt body = G.runGhc mlibdir $ do - initializeFlagsWithCradle opt cradle +run :: Cradle -> Maybe FilePath -> Options -> GhcMod a -> IO a +run _ _ opt body = runGhcMod opt $ do dflags <- G.getSessionDynFlags G.defaultCleanupHandler dflags body @@ -126,26 +126,26 @@ run cradle mlibdir opt body = G.runGhc mlibdir $ do 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 (toGhcMod getSymMdlDb) putMVar mvar db where handler (SomeException _) = return () -- fixme: put emptyDb? ---------------------------------------------------------------- -loop :: Options -> Set FilePath -> MVar SymMdlDb -> Ghc () +loop :: Options -> Set FilePath -> MVar SymMdlDb -> GhcMod () 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 - "find" -> findSym opt set arg mvar - "lint" -> lintStx opt set arg - "info" -> showInfo opt set arg - "type" -> showType opt set arg - "boot" -> bootIt opt set - "browse" -> browseIt opt set arg + "check" -> toGhcMod $ 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 "quit" -> return ("quit", False, set) "" -> return ("quit", False, set) _ -> return ([], True, set) @@ -255,11 +255,10 @@ showType opt set fileArg = do ---------------------------------------------------------------- -bootIt :: Options - -> Set FilePath - -> Ghc (String, Bool, Set FilePath) -bootIt opt set = do - ret <- boot opt +bootIt :: Set FilePath + -> GhcMod (String, Bool, Set FilePath) +bootIt set = do + ret <- boot return (ret, True, set) browseIt :: Options From f1535efcf2191f60cad83c34dc788042650a6648 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 10 May 2014 15:10:34 +0200 Subject: [PATCH 2/7] Ghc -> GhcMod: Browse, Check --- Language/Haskell/GhcMod.hs | 2 +- Language/Haskell/GhcMod/Boot.hs | 2 +- Language/Haskell/GhcMod/Browse.hs | 33 +++++++++++------------------- Language/Haskell/GhcMod/Check.hs | 23 ++++++++++----------- Language/Haskell/GhcMod/Monad.hs | 26 +++++++++++++++++++---- src/GHCMod.hs | 5 +++-- src/GHCModi.hs | 21 +++++++++---------- test/BrowseSpec.hs | 20 +++++++++--------- test/CheckSpec.hs | 13 +++++------- test/TestUtils.hs | 34 +++++++++++++++++++++++++++++++ 10 files changed, 109 insertions(+), 70 deletions(-) create mode 100644 test/TestUtils.hs 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 From ebfb740a2ebd7ee539d8bb139421a430f18a1381 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 12 May 2014 00:40:00 +0200 Subject: [PATCH 3/7] Move `convert` to it's own module. --- Language/Haskell/GhcMod/Browse.hs | 1 + Language/Haskell/GhcMod/Convert.hs | 103 +++++++++++++++++++++++++++++ Language/Haskell/GhcMod/Debug.hs | 1 + Language/Haskell/GhcMod/Find.hs | 1 + Language/Haskell/GhcMod/Flag.hs | 1 + Language/Haskell/GhcMod/Info.hs | 1 + Language/Haskell/GhcMod/Lang.hs | 1 + Language/Haskell/GhcMod/Lint.hs | 1 + Language/Haskell/GhcMod/List.hs | 1 + Language/Haskell/GhcMod/Logger.hs | 3 +- Language/Haskell/GhcMod/Types.hs | 94 -------------------------- ghc-mod.cabal | 1 + 12 files changed, 114 insertions(+), 95 deletions(-) create mode 100644 Language/Haskell/GhcMod/Convert.hs diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 717ea6b..74c5163 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -16,6 +16,7 @@ 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.Convert import Language.Haskell.GhcMod.Types import Name (getOccString) import Outputable (ppr, Outputable) diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs new file mode 100644 index 0000000..339be0f --- /dev/null +++ b/Language/Haskell/GhcMod/Convert.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Language.Haskell.GhcMod.Convert where + +import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Types + +import Control.Applicative ((<$>)) + +type Builder = String -> String + +-- | +-- +-- >>> replace '"' "\\\"" "foo\"bar" "" +-- "foo\\\"bar" +replace :: Char -> String -> String -> Builder +replace _ _ [] = id +replace c cs (x:xs) + | x == c = (cs ++) . replace c cs xs + | otherwise = (x :) . replace c cs xs + +inter :: Char -> [Builder] -> Builder +inter _ [] = id +inter c bs = foldr1 (\x y -> x . (c:) . y) bs + +convert' :: ToString a => a -> GhcMod String +convert' x = flip convert x <$> options + +convert :: ToString a => Options -> a -> String +convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n" +convert opt@Options { outputStyle = PlainStyle } x + | str == "\n" = "" + | otherwise = str + where + str = toPlain opt x "\n" + +class ToString a where + toLisp :: Options -> a -> Builder + toPlain :: Options -> a -> Builder + +lineSep :: Options -> String +lineSep opt = lsep + where + LineSeparator lsep = lineSeparator opt + +-- | +-- +-- >>> toLisp defaultOptions "fo\"o" "" +-- "\"fo\\\"o\"" +-- >>> toPlain defaultOptions "foo" "" +-- "foo" +instance ToString String where + toLisp opt = quote opt + toPlain opt = replace '\n' (lineSep opt) + +-- | +-- +-- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] "" +-- "(\"foo\" \"bar\" \"ba\\\"z\")" +-- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" +-- "foo\nbar\nbaz" +instance ToString [String] where + toLisp opt = toSexp1 opt + toPlain opt = inter '\n' . map (toPlain opt) + +-- | +-- +-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] +-- >>> toLisp defaultOptions inp "" +-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))" +-- >>> toPlain defaultOptions inp "" +-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" +instance ToString [((Int,Int,Int,Int),String)] where + toLisp opt = toSexp2 . map toS + where + toS x = ('(' :) . tupToString opt x . (')' :) + toPlain opt = inter '\n' . map (tupToString opt) + +toSexp1 :: Options -> [String] -> Builder +toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) + +toSexp2 :: [Builder] -> Builder +toSexp2 ss = ('(' :) . (inter ' ' ss) . (')' :) + +tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder +tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :) + . (show b ++) . (' ' :) + . (show c ++) . (' ' :) + . (show d ++) . (' ' :) + . quote opt s -- fixme: quote is not necessary + +quote :: Options -> String -> Builder +quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++) + where + lsep = lineSep opt + quote' [] = [] + quote' (x:xs) + | x == '\n' = lsep ++ quote' xs + | x == '\\' = "\\\\" ++ quote' xs + | x == '"' = "\\\"" ++ quote' xs + | otherwise = x : quote' xs + +---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index cfa0a35..8de00dc 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -7,6 +7,7 @@ import Data.List (intercalate) import Data.Maybe (fromMaybe, isJust, fromJust) import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Types ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 63e5d77..f5ee9ba 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -9,6 +9,7 @@ import GHC (Ghc) import qualified GHC as G import Language.Haskell.GhcMod.Browse (browseAll) import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Types #ifndef MIN_VERSION_containers diff --git a/Language/Haskell/GhcMod/Flag.hs b/Language/Haskell/GhcMod/Flag.hs index cfd4e8a..ff00fde 100644 --- a/Language/Haskell/GhcMod/Flag.hs +++ b/Language/Haskell/GhcMod/Flag.hs @@ -1,6 +1,7 @@ module Language.Haskell.GhcMod.Flag where import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Types -- | Listing GHC flags. (e.g -fno-warn-orphans) diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 25dc417..0159fa5 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -25,6 +25,7 @@ import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Gap (HasType(..), setDeferTypeErrors) import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Convert import Outputable (PprStyle) import TcHsSyn (hsPatType) diff --git a/Language/Haskell/GhcMod/Lang.hs b/Language/Haskell/GhcMod/Lang.hs index 858d1b2..1ddc59a 100644 --- a/Language/Haskell/GhcMod/Lang.hs +++ b/Language/Haskell/GhcMod/Lang.hs @@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Lang where import DynFlags (supportedLanguagesAndExtensions) import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Convert -- | Listing language extensions. diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs index 49a54f4..23515be 100644 --- a/Language/Haskell/GhcMod/Lint.hs +++ b/Language/Haskell/GhcMod/Lint.hs @@ -3,6 +3,7 @@ module Language.Haskell.GhcMod.Lint where import Control.Applicative ((<$>)) import Control.Exception (handle, SomeException(..)) import Language.Haskell.GhcMod.Logger (checkErrorPrefix) +import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Types import Language.Haskell.HLint (hlint) diff --git a/Language/Haskell/GhcMod/List.hs b/Language/Haskell/GhcMod/List.hs index e7565e9..5fcf32a 100644 --- a/Language/Haskell/GhcMod/List.hs +++ b/Language/Haskell/GhcMod/List.hs @@ -5,6 +5,7 @@ import Control.Exception (SomeException(..)) import Data.List (nub, sort) import qualified GHC as G import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Types import Packages (pkgIdMap, exposedModules, sourcePackageId, display) import UniqFM (eltsUFM) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 5654cf1..9039382 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -19,7 +19,8 @@ import HscTypes (SourceError, srcErrorMessages) import Language.Haskell.GhcMod.Doc (showPage, getStyle) import Language.Haskell.GhcMod.GHCApi (withDynFlags, withCmdFlags) import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Types (Options(..), convert) +import Language.Haskell.GhcMod.Convert (convert) +import Language.Haskell.GhcMod.Types (Options(..)) import Outputable (PprStyle, SDoc) import System.FilePath (normalise) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 59f7ab1..b8bb908 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} - module Language.Haskell.GhcMod.Types where import Data.List (intercalate) @@ -39,98 +37,6 @@ defaultOptions = Options { ---------------------------------------------------------------- -type Builder = String -> String - --- | --- --- >>> replace '"' "\\\"" "foo\"bar" "" --- "foo\\\"bar" -replace :: Char -> String -> String -> Builder -replace _ _ [] = id -replace c cs (x:xs) - | x == c = (cs ++) . replace c cs xs - | otherwise = (x :) . replace c cs xs - -inter :: Char -> [Builder] -> Builder -inter _ [] = id -inter c bs = foldr1 (\x y -> x . (c:) . y) bs - -convert :: ToString a => Options -> a -> String -convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n" -convert opt@Options { outputStyle = PlainStyle } x - | str == "\n" = "" - | otherwise = str - where - str = toPlain opt x "\n" - -class ToString a where - toLisp :: Options -> a -> Builder - toPlain :: Options -> a -> Builder - -lineSep :: Options -> String -lineSep opt = lsep - where - LineSeparator lsep = lineSeparator opt - --- | --- --- >>> toLisp defaultOptions "fo\"o" "" --- "\"fo\\\"o\"" --- >>> toPlain defaultOptions "foo" "" --- "foo" -instance ToString String where - toLisp opt = quote opt - toPlain opt = replace '\n' (lineSep opt) - --- | --- --- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] "" --- "(\"foo\" \"bar\" \"ba\\\"z\")" --- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" --- "foo\nbar\nbaz" -instance ToString [String] where - toLisp opt = toSexp1 opt - toPlain opt = inter '\n' . map (toPlain opt) - --- | --- --- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] --- >>> toLisp defaultOptions inp "" --- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))" --- >>> toPlain defaultOptions inp "" --- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" -instance ToString [((Int,Int,Int,Int),String)] where - toLisp opt = toSexp2 . map toS - where - toS x = ('(' :) . tupToString opt x . (')' :) - toPlain opt = inter '\n' . map (tupToString opt) - -toSexp1 :: Options -> [String] -> Builder -toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) - -toSexp2 :: [Builder] -> Builder -toSexp2 ss = ('(' :) . (inter ' ' ss) . (')' :) - -tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder -tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :) - . (show b ++) . (' ' :) - . (show c ++) . (' ' :) - . (show d ++) . (' ' :) - . quote opt s -- fixme: quote is not necessary - -quote :: Options -> String -> Builder -quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++) - where - lsep = lineSep opt - quote' [] = [] - quote' (x:xs) - | x == '\n' = lsep ++ quote' xs - | x == '\\' = "\\\\" ++ quote' xs - | x == '"' = "\\\"" ++ quote' xs - | otherwise = x : quote' xs - ----------------------------------------------------------------- - -- | The environment where this library is used. data Cradle = Cradle { -- | The directory where this library is executed. diff --git a/ghc-mod.cabal b/ghc-mod.cabal index bfc2659..81ec2e9 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -61,6 +61,7 @@ Library Language.Haskell.GhcMod.CabalConfig Language.Haskell.GhcMod.Cabal16 Language.Haskell.GhcMod.Cabal18 + Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Cradle Language.Haskell.GhcMod.Debug From 80e2761f2fd1a5e6ef3df0b6b8466be681fa5a6d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 14 May 2014 18:05:40 +0200 Subject: [PATCH 4/7] Ghc->GhcMod: finish Browse, Check --- Language/Haskell/GhcMod/Browse.hs | 15 +++++------ Language/Haskell/GhcMod/Check.hs | 25 +++++++----------- Language/Haskell/GhcMod/Find.hs | 13 +++++---- Language/Haskell/GhcMod/GHCApi.hs | 21 ++++++++------- Language/Haskell/GhcMod/Logger.hs | 44 ++++++++++++++++--------------- ghc-mod.cabal | 2 +- src/GHCMod.hs | 4 +-- src/GHCModi.hs | 13 ++++----- test/CheckSpec.hs | 3 +-- 9 files changed, 68 insertions(+), 72 deletions(-) diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 74c5163..49798db 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -10,7 +10,7 @@ import Data.List (sort) import Data.Maybe (catMaybes) import Exception (ghandle) import FastString (mkFastString) -import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module) +import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module) import qualified GHC as G import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified) import Language.Haskell.GhcMod.GHCApi @@ -30,9 +30,7 @@ import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) -- If 'operators' is 'True', operators are also returned. browse :: ModuleString -- ^ A module name. (e.g. \"Data.List\") -> GhcMod String -browse pkgmdl = do - opt <- options - convert opt . sort <$> (getModule >>= listExports) +browse pkgmdl = convert' . sort =<< (listExports =<< getModule) where (mpkg,mdl) = splitPkgMdl pkgmdl mdlname = G.mkModuleName mdl @@ -70,14 +68,15 @@ processExports minfo = do removeOps | operators opt = id | otherwise = filter (isAlpha . head . getOccString) - mapM (toGhcMod . showExport opt minfo) $ removeOps $ G.modInfoExports minfo + mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo -showExport :: Options -> ModuleInfo -> Name -> Ghc String +showExport :: Options -> ModuleInfo -> Name -> GhcMod String showExport opt minfo e = do mtype' <- mtype return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] where mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt + mtype :: GhcMod (Maybe String) mtype | detailed opt = do tyInfo <- G.modInfoLookupName minfo e @@ -92,7 +91,7 @@ showExport opt minfo e = do | isAlpha n = nm | otherwise = "(" ++ nm ++ ")" formatOp "" = error "formatOp" - inOtherModule :: Name -> Ghc (Maybe TyThing) + inOtherModule :: Name -> GhcMod (Maybe TyThing) inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm justIf :: a -> Bool -> Maybe a justIf x True = Just x @@ -139,7 +138,7 @@ showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr ---------------------------------------------------------------- -- | Browsing all functions in all system/user modules. -browseAll :: DynFlags -> Ghc [(String,String)] +browseAll :: DynFlags -> GhcMod [(String,String)] browseAll dflag = do ms <- G.packageDbModules True is <- mapM G.getModuleInfo ms diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index a3ddf08..48dacc3 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -6,12 +6,10 @@ module Language.Haskell.GhcMod.Check ( ) where import Control.Applicative ((<$>)) -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 ---------------------------------------------------------------- @@ -34,21 +32,17 @@ checkSyntax files = withErrorHandler sessionName $ do check :: [FilePath] -- ^ The target files. -> GhcMod (Either String String) check fileNames = do - opt <- options - toGhcMod $ withLogger opt setAllWaringFlags $ do + withLogger setAllWaringFlags $ do setTargetFiles fileNames ---------------------------------------------------------------- -- | Expanding Haskell Template. -expandTemplate :: Options - -> Cradle - -> [FilePath] -- ^ The target files. - -> IO String -expandTemplate _ _ [] = return "" -expandTemplate opt cradle files = withGHC sessionName $ do - initializeFlagsWithCradle opt cradle - either id id <$> expand opt files +expandTemplate :: [FilePath] -- ^ The target files. + -> GhcMod String +expandTemplate [] = return "" +expandTemplate files = withErrorHandler sessionName $ do + either id id <$> expand files where sessionName = case files of [file] -> file @@ -57,8 +51,7 @@ expandTemplate opt cradle files = withGHC sessionName $ do ---------------------------------------------------------------- -- | Expanding Haskell Template. -expand :: Options - -> [FilePath] -- ^ The target files. - -> Ghc (Either String String) -expand opt fileNames = withLogger opt (Gap.setDumpSplices . setNoWaringFlags) $ +expand :: [FilePath] -- ^ The target files. + -> GhcMod (Either String String) +expand fileNames = withLogger (Gap.setDumpSplices . setNoWaringFlags) $ setTargetFiles fileNames diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index f5ee9ba..740f0ce 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -9,6 +9,7 @@ import GHC (Ghc) import qualified GHC as G import Language.Haskell.GhcMod.Browse (browseAll) import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Types @@ -32,13 +33,11 @@ type Symbol = String newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString]) -- | Finding modules to which the symbol belong. -findSymbol :: Options -> Cradle -> Symbol -> IO String -findSymbol opt cradle sym = withGHC' $ do - initializeFlagsWithCradle opt cradle - lookupSym opt sym <$> getSymMdlDb +findSymbol :: Symbol -> GhcMod String +findSymbol sym = convert' =<< lookupSym sym <$> getSymMdlDb -- | Creating 'SymMdlDb'. -getSymMdlDb :: Ghc SymMdlDb +getSymMdlDb :: GhcMod SymMdlDb getSymMdlDb = do sm <- G.getSessionDynFlags >>= browseAll #if MIN_VERSION_containers(0,5,0) @@ -53,5 +52,5 @@ getSymMdlDb = do tieup x = (head (map fst x), map snd x) -- | Looking up 'SymMdlDb' with 'Symbol' to find modules. -lookupSym :: Options -> Symbol -> SymMdlDb -> String -lookupSym opt sym (SymMdlDb db) = convert opt $ fromMaybe [] (M.lookup sym db) +lookupSym :: Symbol -> SymMdlDb -> [ModuleString] +lookupSym sym (SymMdlDb db) = fromMaybe [] (M.lookup sym db) diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index e30b3b0..e12df43 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -164,22 +164,25 @@ getDynamicFlags = do mlibdir <- getSystemLibDir G.runGhc mlibdir G.getSessionDynFlags -withDynFlags :: (DynFlags -> DynFlags) -> Ghc a -> Ghc a -withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body) +withDynFlags :: GhcMonad m + => (DynFlags -> DynFlags) + -> m a + -> m a +withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body) where setup = do - dflag <- G.getSessionDynFlags - void $ G.setSessionDynFlags (setFlag dflag) - return dflag + dflags <- G.getSessionDynFlags + void $ G.setSessionDynFlags (setFlags dflags) + return dflags teardown = void . G.setSessionDynFlags -withCmdFlags :: [GHCOption] -> Ghc a -> Ghc a +withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) where setup = do - dflag <- G.getSessionDynFlags >>= addCmdOpts flags - void $ G.setSessionDynFlags dflag - return dflag + dflags <- G.getSessionDynFlags >>= addCmdOpts flags + void $ G.setSessionDynFlags dflags + return dflags teardown = void . G.setSessionDynFlags ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 9039382..dfe0363 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -6,20 +6,21 @@ module Language.Haskell.GhcMod.Logger ( ) where import Bag (Bag, bagToList) -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>),(*>)) import CoreMonad (liftIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo) import Exception (ghandle) -import GHC (Ghc, DynFlags, SrcSpan, Severity(SevError)) +import 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, withCmdFlags) import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Convert (convert) +import Language.Haskell.GhcMod.Convert (convert') +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types (Options(..)) import Outputable (PprStyle, SDoc) import System.FilePath (normalise) @@ -33,11 +34,11 @@ newtype LogRef = LogRef (IORef Builder) newLogRef :: IO LogRef newLogRef = LogRef <$> newIORef id -readAndClearLogRef :: Options -> LogRef -> IO String -readAndClearLogRef opt (LogRef ref) = do - b <- readIORef ref - writeIORef ref id - return $! convert opt (b []) +readAndClearLogRef :: LogRef -> GhcMod String +readAndClearLogRef (LogRef ref) = do + b <- liftIO $ readIORef ref + liftIO $ writeIORef ref id + convert' (b []) appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () appendLogRef df (LogRef ref) _ sev src style msg = do @@ -47,28 +48,29 @@ appendLogRef df (LogRef ref) _ sev src style msg = do ---------------------------------------------------------------- -- | Set the session flag (e.g. "-Wall" or "-w:") then --- executes a body. Log messages are returned as 'String'. +-- executes a body. Logged messages are returned as 'String'. -- Right is success and Left is failure. -withLogger :: Options -> (DynFlags -> DynFlags) -> Ghc () -> Ghc (Either String String) -withLogger opt setDF body = ghandle (sourceError opt) $ do +withLogger :: (DynFlags -> DynFlags) + -> GhcMod () + -> GhcMod (Either String String) +withLogger setDF body = ghandle sourceError $ do logref <- liftIO $ newLogRef + wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options withDynFlags (setLogger logref . setDF) $ do - withCmdFlags wflags $ do - body - liftIO $ Right <$> readAndClearLogRef opt logref + withCmdFlags wflags $ do body *> (Right <$> readAndClearLogRef logref) where setLogger logref df = Gap.setLogAction df $ appendLogRef df logref - wflags = filter ("-fno-warn" `isPrefixOf`) $ ghcOpts opt + ---------------------------------------------------------------- -- | Converting 'SourceError' to 'String'. -sourceError :: Options -> SourceError -> Ghc (Either String String) -sourceError opt err = do - dflag <- G.getSessionDynFlags - style <- getStyle - let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err - return (Left ret) +sourceError :: SourceError -> GhcMod (Either String String) +sourceError err = do + dflags <- G.getSessionDynFlags + style <- toGhcMod getStyle + ret <- convert' $ (errBagToStrList dflags style . srcErrorMessages $ err) + return $ Left ret errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 81ec2e9..cbe746e 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -53,6 +53,7 @@ Library GHC-Options: -Wall Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Ghc + Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.Internal Other-Modules: Language.Haskell.GhcMod.Boot @@ -61,7 +62,6 @@ Library Language.Haskell.GhcMod.CabalConfig Language.Haskell.GhcMod.Cabal16 Language.Haskell.GhcMod.Cabal18 - Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Cradle Language.Haskell.GhcMod.Debug diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 2cc02a8..0fce421 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -115,11 +115,11 @@ main = flip E.catches handlers $ do "flag" -> listFlags opt "browse" -> runGhcMod opt $ concat <$> mapM browse remainingArgs "check" -> runGhcMod opt $ checkSyntax remainingArgs - "expand" -> expandTemplate opt cradle remainingArgs + "expand" -> runGhcMod opt $ expandTemplate remainingArgs "debug" -> debugInfo opt cradle "info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3 "type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) - "find" -> nArgs 1 $ findSymbol opt cradle cmdArg1 + "find" -> runGhcMod opt $ nArgs 1 $ findSymbol cmdArg1 "lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1 "root" -> rootInfo opt cradle "doc" -> nArgs 1 $ packageDoc opt cradle cmdArg1 diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 7aadb4c..f2dc7b2 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -35,6 +35,7 @@ import GHC (Ghc) import qualified GHC as G import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Ghc +import Language.Haskell.GhcMod.Convert (convert') import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Internal import Paths_ghc_mod @@ -126,7 +127,7 @@ run _ _ opt body = runGhcMod opt $ do setupDB :: Cradle -> Maybe FilePath -> Options -> MVar SymMdlDb -> IO () setupDB cradle mlibdir opt mvar = E.handle handler $ do - db <- run cradle mlibdir opt (toGhcMod getSymMdlDb) + db <- run cradle mlibdir opt getSymMdlDb putMVar mvar db where handler (SomeException _) = return () -- fixme: put emptyDb? @@ -140,7 +141,7 @@ loop opt set mvar = do arg = dropWhile (== ' ') arg' (ret,ok,set') <- case cmd of "check" -> checkStx opt set arg - "find" -> toGhcMod $ findSym opt set arg mvar + "find" -> findSym set arg mvar "lint" -> toGhcMod $ lintStx opt set arg "info" -> toGhcMod $ showInfo opt set arg "type" -> toGhcMod $ showType opt set arg @@ -199,11 +200,11 @@ isSameMainFile file (Just x) ---------------------------------------------------------------- -findSym :: Options -> Set FilePath -> String -> MVar SymMdlDb - -> Ghc (String, Bool, Set FilePath) -findSym opt set sym mvar = do +findSym :: Set FilePath -> String -> MVar SymMdlDb + -> GhcMod (String, Bool, Set FilePath) +findSym set sym mvar = do db <- liftIO $ readMVar mvar - let ret = lookupSym opt sym db + ret <- convert' $ lookupSym sym db return (ret, True, set) lintStx :: Options -> Set FilePath -> FilePath diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index f2ff7e9..71709c8 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -35,6 +35,5 @@ spec = do context "without errors" $ do it "doesn't output empty line" $ do withDirectory_ "test/data/ghc-mod-check/Data" $ do - cradle <- findCradleWithoutSandbox - res <- checkSyntax defaultOptions cradle ["Foo.hs"] + res <- runID $ checkSyntax ["Foo.hs"] res `shouldBe` "" From 8324dd96aef5e6c4931ea1a9fabda70b1c712b69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 14 May 2014 18:54:56 +0200 Subject: [PATCH 5/7] Don't expose `Convert` --- Language/Haskell/GhcMod/Convert.hs | 2 +- Language/Haskell/GhcMod/Find.hs | 5 +++-- Language/Haskell/GhcMod/Ghc.hs | 1 + ghc-mod.cabal | 2 +- src/GHCModi.hs | 4 ++-- 5 files changed, 8 insertions(+), 6 deletions(-) diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 339be0f..4a422ce 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} -module Language.Haskell.GhcMod.Convert where +module Language.Haskell.GhcMod.Convert (convert, convert') where import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 740f0ce..850d5df 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -5,10 +5,8 @@ module Language.Haskell.GhcMod.Find where import Data.Function (on) import Data.List (groupBy, sort) import Data.Maybe (fromMaybe) -import GHC (Ghc) import qualified GHC as G import Language.Haskell.GhcMod.Browse (browseAll) -import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Types @@ -54,3 +52,6 @@ getSymMdlDb = do -- | Looking up 'SymMdlDb' with 'Symbol' to find modules. lookupSym :: Symbol -> SymMdlDb -> [ModuleString] lookupSym sym (SymMdlDb db) = fromMaybe [] (M.lookup sym db) + +lookupSym' :: Options -> Symbol -> SymMdlDb -> String +lookupSym' opt sym db = convert opt $ lookupSym sym db diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index 1f47599..540a29a 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -14,6 +14,7 @@ module Language.Haskell.GhcMod.Ghc ( , SymMdlDb , getSymMdlDb , lookupSym + , lookupSym' ) where import Language.Haskell.GhcMod.Boot diff --git a/ghc-mod.cabal b/ghc-mod.cabal index cbe746e..1a09bfd 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -53,7 +53,6 @@ Library GHC-Options: -Wall Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Ghc - Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.Internal Other-Modules: Language.Haskell.GhcMod.Boot @@ -64,6 +63,7 @@ Library Language.Haskell.GhcMod.Cabal18 Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Cradle + Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Debug Language.Haskell.GhcMod.Doc Language.Haskell.GhcMod.Find diff --git a/src/GHCModi.hs b/src/GHCModi.hs index f2dc7b2..139ef1c 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -35,7 +35,6 @@ import GHC (Ghc) import qualified GHC as G import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Ghc -import Language.Haskell.GhcMod.Convert (convert') import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Internal import Paths_ghc_mod @@ -204,7 +203,8 @@ findSym :: Set FilePath -> String -> MVar SymMdlDb -> GhcMod (String, Bool, Set FilePath) findSym set sym mvar = do db <- liftIO $ readMVar mvar - ret <- convert' $ lookupSym sym db + opt <- options + let ret = lookupSym' opt sym db return (ret, True, set) lintStx :: Options -> Set FilePath -> FilePath From 814ea60552131e8c174ce15b35bba67b471e9946 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 14 May 2014 20:55:54 +0200 Subject: [PATCH 6/7] `Types` doesn't export `convert` anymore --- Language/Haskell/GhcMod/Gap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 1ceb355..03d9c9b 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -45,7 +45,7 @@ import ErrUtils import FastString import HscTypes import Language.Haskell.GhcMod.GHCChoice -import Language.Haskell.GhcMod.Types hiding (convert) +import Language.Haskell.GhcMod.Types import NameSet import Outputable import PprTyThing From 2b4f780296f31cb117b9891de59bf6d021182a9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 14 May 2014 20:56:14 +0200 Subject: [PATCH 7/7] Add `TestUtils` to `other-modules` --- ghc-mod.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 1a09bfd..7699634 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -156,6 +156,7 @@ Test-Suite spec LintSpec ListSpec GhcPkgSpec + TestUtils Build-Depends: base >= 4.0 && < 5 , containers , deepseq