From f0bfcb88115bc1f78553aa4fbbcd25f3aadf7e05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 12 Jul 2014 11:16:16 +0200 Subject: [PATCH] Use GhcModT everywhere and remove the GhcMod alias Not doing this makes having GhcModT pretty pointless as users of the library wouldn't be able to use custom inner monads as evey function for dealing with GhcModT's would be constraint to (GhcModT IO) thus only allowing IO as the inner monad. --- Language/Haskell/GhcMod/Boot.hs | 2 +- Language/Haskell/GhcMod/Browse.hs | 15 ++++---- Language/Haskell/GhcMod/CaseSplit.hs | 5 +-- Language/Haskell/GhcMod/Check.hs | 20 ++++++----- Language/Haskell/GhcMod/Convert.hs | 2 +- Language/Haskell/GhcMod/Debug.hs | 4 +-- Language/Haskell/GhcMod/FillSig.hs | 5 +-- Language/Haskell/GhcMod/Find.hs | 4 +-- Language/Haskell/GhcMod/Flag.hs | 2 +- Language/Haskell/GhcMod/Info.hs | 10 +++--- Language/Haskell/GhcMod/Lang.hs | 2 +- Language/Haskell/GhcMod/Lint.hs | 5 +-- Language/Haskell/GhcMod/List.hs | 2 +- Language/Haskell/GhcMod/Logger.hs | 11 +++--- Language/Haskell/GhcMod/Monad.hs | 35 +++++++------------ Language/Haskell/GhcMod/PkgDoc.hs | 2 +- ghc-mod.cabal | 5 +++ src/GHCMod.hs | 4 +-- src/GHCModi.hs | 51 ++++++++++++++++------------ test/TestUtils.hs | 12 ++++--- 20 files changed, 106 insertions(+), 92 deletions(-) diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs index fd9345c..a95429c 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ b/Language/Haskell/GhcMod/Boot.hs @@ -8,7 +8,7 @@ import Language.Haskell.GhcMod.List import Language.Haskell.GhcMod.Monad -- | Printing necessary information for front-end booting. -boot :: GhcMod String +boot :: IOish m => GhcModT m String boot = concat <$> sequence [modules, languages, flags, concat <$> mapM browse preBrowsedModules] diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 72419b8..aa0d1df 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -28,8 +28,9 @@ 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. -browse :: ModuleString -- ^ A module name. (e.g. \"Data.List\") - -> GhcMod String +browse :: IOish m + => ModuleString -- ^ A module name. (e.g. \"Data.List\") + -> GhcModT m String browse pkgmdl = convert' . sort =<< (listExports =<< getModule) where (mpkg,mdl) = splitPkgMdl pkgmdl @@ -61,7 +62,7 @@ splitPkgMdl pkgmdl = case break (==':') pkgmdl of (mdl,"") -> (Nothing,mdl) (pkg,_:mdl) -> (Just pkg,mdl) -processExports :: ModuleInfo -> GhcMod [String] +processExports :: IOish m => ModuleInfo -> GhcModT m [String] processExports minfo = do opt <- options let @@ -70,13 +71,13 @@ processExports minfo = do | otherwise = filter (isAlpha . head . getOccString) mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo -showExport :: Options -> ModuleInfo -> Name -> GhcMod String +showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m 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 :: IOish m => GhcModT m (Maybe String) mtype | detailed opt = do tyInfo <- G.modInfoLookupName minfo e @@ -91,7 +92,7 @@ showExport opt minfo e = do | isAlpha n = nm | otherwise = "(" ++ nm ++ ")" formatOp "" = error "formatOp" - inOtherModule :: Name -> GhcMod (Maybe TyThing) + inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing) inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm justIf :: a -> Bool -> Maybe a justIf x True = Just x @@ -138,7 +139,7 @@ showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr ---------------------------------------------------------------- -- | Browsing all functions in all system/user modules. -browseAll :: DynFlags -> GhcMod [(String,String)] +browseAll :: IOish m => DynFlags -> GhcModT m [(String,String)] browseAll dflag = do ms <- G.packageDbModules True is <- mapM G.getModuleInfo ms diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index ce6faee..706d18d 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -33,10 +33,11 @@ data SplitToTextInfo = SplitToTextInfo { sVarName :: String } -- | Splitting a variable in a equation. -splits :: FilePath -- ^ A target file. +splits :: IOish m + => FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. - -> GhcMod String + -> GhcModT m String splits file lineNo colNo = ghandle handler body where body = inModuleContext file $ \dflag style -> do diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index 736c42f..66c7b71 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -15,8 +15,9 @@ import Language.Haskell.GhcMod.Monad -- | Checking syntax of a target file using GHC. -- Warnings and errors are returned. -checkSyntax :: [FilePath] -- ^ The target files. - -> GhcMod String +checkSyntax :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m String checkSyntax [] = return "" checkSyntax files = withErrorHandler sessionName $ do either id id <$> check files @@ -29,8 +30,9 @@ checkSyntax files = withErrorHandler sessionName $ do -- | Checking syntax of a target file using GHC. -- Warnings and errors are returned. -check :: [FilePath] -- ^ The target files. - -> GhcMod (Either String String) +check :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m (Either String String) check fileNames = do withLogger setAllWaringFlags $ do setTargetFiles fileNames @@ -38,8 +40,9 @@ check fileNames = do ---------------------------------------------------------------- -- | Expanding Haskell Template. -expandTemplate :: [FilePath] -- ^ The target files. - -> GhcMod String +expandTemplate :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m String expandTemplate [] = return "" expandTemplate files = withErrorHandler sessionName $ do either id id <$> expand files @@ -51,7 +54,8 @@ expandTemplate files = withErrorHandler sessionName $ do ---------------------------------------------------------------- -- | Expanding Haskell Template. -expand :: [FilePath] -- ^ The target files. - -> GhcMod (Either String String) +expand :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m (Either String String) expand fileNames = withLogger (Gap.setDumpSplices . setNoWaringFlags) $ setTargetFiles fileNames diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index e348eca..ee1398b 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -23,7 +23,7 @@ inter :: Char -> [Builder] -> Builder inter _ [] = id inter c bs = foldr1 (\x y -> x . (c:) . y) bs -convert' :: ToString a => a -> GhcMod String +convert' :: (ToString a, IOish m) => a -> GhcModT m String convert' x = flip convert x <$> options convert :: ToString a => Options -> a -> String diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 2278ad2..994411d 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -12,7 +12,7 @@ import Language.Haskell.GhcMod.Internal ---------------------------------------------------------------- -- | Obtaining debug information. -debugInfo :: GhcMod String +debugInfo :: IOish m => GhcModT m String debugInfo = cradle >>= \c -> convert' =<< do CompilerOptions gopts incDir pkgs <- if isJust $ cradleCabalFile c then @@ -38,5 +38,5 @@ debugInfo = cradle >>= \c -> convert' =<< do ---------------------------------------------------------------- -- | Obtaining root information. -rootInfo :: GhcMod String +rootInfo :: IOish m => GhcModT m String rootInfo = convert' =<< cradleRootDir <$> cradle diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 7cb2dc9..fc12384 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -38,10 +38,11 @@ data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName) data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo) -- | Create a initial body from a signature. -sig :: FilePath -- ^ A target file. +sig :: IOish m + => FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. - -> GhcMod String + -> GhcModT m String sig file lineNo colNo = ghandle handler body where body = inModuleContext file $ \dflag style -> do diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 850d5df..d414e40 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -31,11 +31,11 @@ type Symbol = String newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString]) -- | Finding modules to which the symbol belong. -findSymbol :: Symbol -> GhcMod String +findSymbol :: IOish m => Symbol -> GhcModT m String findSymbol sym = convert' =<< lookupSym sym <$> getSymMdlDb -- | Creating 'SymMdlDb'. -getSymMdlDb :: GhcMod SymMdlDb +getSymMdlDb :: IOish m => GhcModT m SymMdlDb getSymMdlDb = do sm <- G.getSessionDynFlags >>= browseAll #if MIN_VERSION_containers(0,5,0) diff --git a/Language/Haskell/GhcMod/Flag.hs b/Language/Haskell/GhcMod/Flag.hs index 74319e8..5fc3e2b 100644 --- a/Language/Haskell/GhcMod/Flag.hs +++ b/Language/Haskell/GhcMod/Flag.hs @@ -6,7 +6,7 @@ import Language.Haskell.GhcMod.Monad -- | Listing GHC flags. (e.g -fno-warn-orphans) -flags :: GhcMod String +flags :: IOish m => GhcModT m String flags = convert' [ "-f" ++ prefix ++ option | option <- Gap.fOptions , prefix <- ["","no-"] diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 8b4afec..b58b53f 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -21,9 +21,10 @@ import Language.Haskell.GhcMod.Convert ---------------------------------------------------------------- -- | Obtaining information of a target expression. (GHCi's info:) -info :: FilePath -- ^ A target file. +info :: IOish m + => FilePath -- ^ A target file. -> Expression -- ^ A Haskell expression. - -> GhcMod String + -> GhcModT m String info file expr = do opt <- options convert opt <$> ghandle handler body @@ -36,10 +37,11 @@ info file expr = do ---------------------------------------------------------------- -- | Obtaining type of a target expression. (GHCi's type:) -types :: FilePath -- ^ A target file. +types :: IOish m + => FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. - -> GhcMod String + -> GhcModT m String types file lineNo colNo = do opt <- options convert opt <$> ghandle handler body diff --git a/Language/Haskell/GhcMod/Lang.hs b/Language/Haskell/GhcMod/Lang.hs index 071e178..badecbd 100644 --- a/Language/Haskell/GhcMod/Lang.hs +++ b/Language/Haskell/GhcMod/Lang.hs @@ -6,5 +6,5 @@ import Language.Haskell.GhcMod.Monad -- | Listing language extensions. -languages :: GhcMod String +languages :: IOish m => GhcModT m String languages = convert' supportedLanguagesAndExtensions diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs index ede48c2..cfa915f 100644 --- a/Language/Haskell/GhcMod/Lint.hs +++ b/Language/Haskell/GhcMod/Lint.hs @@ -11,8 +11,9 @@ import Language.Haskell.HLint (hlint) -- | Checking syntax of a target file using hlint. -- Warnings and errors are returned. -lint :: FilePath -- ^ A target file. - -> GhcMod String +lint :: IOish m + => FilePath -- ^ A target file. + -> GhcModT m String lint file = do opt <- options ghandle handler . pack =<< (liftIO $ hlint $ file : "--quiet" : hlintOpts opt) diff --git a/Language/Haskell/GhcMod/List.hs b/Language/Haskell/GhcMod/List.hs index be0b4c7..ec93ae3 100644 --- a/Language/Haskell/GhcMod/List.hs +++ b/Language/Haskell/GhcMod/List.hs @@ -13,7 +13,7 @@ import UniqFM (eltsUFM) ---------------------------------------------------------------- -- | Listing installed modules. -modules :: GhcMod String +modules :: IOish m => GhcModT m String modules = do opt <- options convert opt . (arrange opt) <$> (getModules `G.gcatch` handler) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 5d16788..2d7121e 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -34,7 +34,7 @@ newtype LogRef = LogRef (IORef Builder) newLogRef :: IO LogRef newLogRef = LogRef <$> newIORef id -readAndClearLogRef :: LogRef -> GhcMod String +readAndClearLogRef :: IOish m => LogRef -> GhcModT m String readAndClearLogRef (LogRef ref) = do b <- liftIO $ readIORef ref liftIO $ writeIORef ref id @@ -50,9 +50,10 @@ appendLogRef df (LogRef ref) _ sev src style msg = do -- | Set the session flag (e.g. "-Wall" or "-w:") then -- executes a body. Logged messages are returned as 'String'. -- Right is success and Left is failure. -withLogger :: (DynFlags -> DynFlags) - -> GhcMod () - -> GhcMod (Either String String) +withLogger :: IOish m + => (DynFlags -> DynFlags) + -> GhcModT m () + -> GhcModT m (Either String String) withLogger setDF body = ghandle sourceError $ do logref <- liftIO $ newLogRef wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options @@ -65,7 +66,7 @@ withLogger setDF body = ghandle sourceError $ do ---------------------------------------------------------------- -- | Converting 'SourceError' to 'String'. -sourceError :: SourceError -> GhcMod (Either String String) +sourceError :: IOish m => SourceError -> GhcModT m (Either String String) sourceError err = do dflags <- G.getSessionDynFlags style <- toGhcMod getStyle diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index bf92caa..8b69921 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -4,13 +4,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.Monad ( - GhcMod - , GhcModT + GhcModT + , IOish , GhcModEnv(..) , GhcModWriter , GhcModState(..) - , runGhcMod' - , runGhcMod , runGhcModT' , runGhcModT , newGhcModEnv @@ -60,7 +58,8 @@ import Control.Monad.Base (MonadBase, liftBase) import Control.Monad.Reader.Class import Control.Monad.State.Class import Control.Monad.Trans.Class -import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, control, liftBaseOp, liftBaseOp_) +import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, + control, liftBaseOp, liftBaseOp_) import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST) import Control.Monad.Writer.Class @@ -87,7 +86,7 @@ type GhcModWriter = () ---------------------------------------------------------------- -type GhcMod a = GhcModT IO a +type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m) newtype GhcModT m a = GhcModT { unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a @@ -155,7 +154,7 @@ initSession build Options {..} CompilerOptions {..} = do ---------------------------------------------------------------- -runGhcModT' :: (MonadIO m, MonadBaseControl IO m) +runGhcModT' :: IOish m => GhcModEnv -> GhcModState -> GhcModT m a @@ -174,7 +173,7 @@ newGhcModEnv opt dir = do , gmCradle = c } -runGhcModT :: (MonadIO m, MonadBaseControl IO m) => Options -> GhcModT m a -> m a +runGhcModT :: IOish m => Options -> GhcModT m a -> m a runGhcModT opt action = do env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory (a,(_,_)) <- runGhcModT' env defaultState $ do @@ -183,41 +182,31 @@ runGhcModT opt action = do initializeFlagsWithCradle opt (gmCradle env) action return a - -runGhcMod' :: GhcModEnv - -> GhcModState - -> GhcModT IO a - -> IO (a,(GhcModState, GhcModWriter)) -runGhcMod' = runGhcModT' - -runGhcMod :: Options -> GhcMod a -> IO a -runGhcMod = runGhcModT ---------------------------------------------------------------- -withErrorHandler :: String -> GhcMod a -> GhcMod a +withErrorHandler :: IOish m => String -> GhcModT m a -> GhcModT m a withErrorHandler label = ghandle ignore where - ignore :: SomeException -> GhcMod a + ignore :: IOish m => SomeException -> GhcModT m a ignore e = liftIO $ do hPutStr stderr $ label ++ ":0:0:Error:" hPrint stderr e exitSuccess -- | This is only a transitional mechanism don't use it for new code. -toGhcMod :: (Functor m, MonadIO m) => Ghc a -> GhcModT m a +toGhcMod :: IOish m => Ghc a -> GhcModT m a toGhcMod a = do s <- gmGhcSession <$> ask liftIO $ unGhc a $ Session s ---------------------------------------------------------------- -options :: GhcMod Options +options :: IOish m => GhcModT m Options options = gmOptions <$> ask -cradle :: GhcMod Cradle +cradle :: IOish m => GhcModT m Cradle cradle = gmCradle <$> ask - instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where liftBase = GhcModT . liftBase diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index 02f882a..b29e172 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -9,7 +9,7 @@ import Control.Applicative ((<$>)) import System.Process (readProcess) -- | Obtaining the package name and the doc path of a module. -pkgDoc :: String -> GhcMod String +pkgDoc :: IOish m => String -> GhcModT m String pkgDoc mdl = cradle >>= \c -> liftIO $ do pkg <- trim <$> readProcess "ghc-pkg" (toModuleOpts c) [] if pkg == "" then diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 8273417..f154bcb 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -51,6 +51,7 @@ Extra-Source-Files: ChangeLog Library Default-Language: Haskell2010 GHC-Options: -Wall + Extensions: ConstraintKinds, FlexibleContexts Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Ghc Language.Haskell.GhcMod.Monad @@ -117,6 +118,7 @@ Executable ghc-mod Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod GHC-Options: -Wall + Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 , directory @@ -130,6 +132,7 @@ Executable ghc-modi Main-Is: GHCModi.hs Other-Modules: Paths_ghc_mod GHC-Options: -Wall + Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 , containers @@ -143,12 +146,14 @@ Test-Suite doctest Default-Language: Haskell2010 HS-Source-Dirs: test Ghc-Options: -threaded -Wall + Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs Build-Depends: base , doctest >= 0.9.3 Test-Suite spec Default-Language: Haskell2010 + Extensions: ConstraintKinds, FlexibleContexts Main-Is: Main.hs Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 2856a87..8424a3d 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -111,7 +111,7 @@ main = flip E.catches handlers $ do nArgs n f = if length remainingArgs == n then f else E.throw (ArgumentsMismatch cmdArg0) - res <- runGhcMod opt $ case cmdArg0 of + res <- runGhcModT opt $ case cmdArg0 of "list" -> modules "lang" -> languages "flag" -> flags @@ -152,7 +152,7 @@ main = flip E.catches handlers $ do hPutStrLn stderr $ "\"" ++ file ++ "\" not found" printUsage printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec - withFile :: (FilePath -> GhcMod a) -> FilePath -> GhcMod a + withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a withFile cmd file = do exist <- liftIO $ doesFileExist file if exist diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 39449b4..d67a58d 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -101,8 +101,8 @@ main = E.handle cmdHandler $ -- c = cradle0 { cradleCurrentDir = rootdir } TODO: ????? setCurrentDirectory rootdir mvar <- liftIO newEmptyMVar - void $ forkIO $ runGhcMod opt $ setupDB mvar - runGhcMod opt $ loop S.empty mvar + void $ forkIO $ runGhcModT opt $ setupDB mvar + runGhcModT opt $ loop S.empty mvar where -- this is just in case. -- If an error is caught here, it is a bug of GhcMod library. @@ -116,7 +116,7 @@ replace (x:xs) = x : replace xs ---------------------------------------------------------------- -setupDB :: MVar SymMdlDb -> GhcMod () +setupDB :: IOish m => MVar SymMdlDb -> GhcModT m () setupDB mvar = ghandle handler $ do liftIO . putMVar mvar =<< getSymMdlDb where @@ -124,7 +124,7 @@ setupDB mvar = ghandle handler $ do ---------------------------------------------------------------- -loop :: Set FilePath -> MVar SymMdlDb -> GhcMod () +loop :: IOish m => Set FilePath -> MVar SymMdlDb -> GhcModT m () loop set mvar = do cmdArg <- liftIO getLine let (cmd,arg') = break (== ' ') cmdArg @@ -152,9 +152,10 @@ loop set mvar = do ---------------------------------------------------------------- -checkStx :: Set FilePath +checkStx :: IOish m + => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) checkStx set file = do set' <- toGhcMod $ newFileSet set file let files = S.toList set' @@ -191,17 +192,17 @@ isSameMainFile file (Just x) ---------------------------------------------------------------- -findSym :: Set FilePath -> String -> MVar SymMdlDb - -> GhcMod (String, Bool, Set FilePath) +findSym :: IOish m => Set FilePath -> String -> MVar SymMdlDb + -> GhcModT m (String, Bool, Set FilePath) findSym set sym mvar = do db <- liftIO $ readMVar mvar opt <- options let ret = lookupSym' opt sym db return (ret, True, set) -lintStx :: Set FilePath +lintStx :: IOish m => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) lintStx set optFile = do ret <- local env' $ lint file return (ret, True, set) @@ -228,36 +229,40 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of ---------------------------------------------------------------- -showInfo :: Set FilePath +showInfo :: IOish m + => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) showInfo set fileArg = do let [file, expr] = words fileArg set' <- newFileSet set file ret <- info file expr return (ret, True, set') -showType :: Set FilePath +showType :: IOish m + => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) showType set fileArg = do let [file, line, column] = words fileArg set' <- newFileSet set file ret <- types file (read line) (read column) return (ret, True, set') -doSplit :: Set FilePath +doSplit :: IOish m + => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) doSplit set fileArg = do let [file, line, column] = words fileArg set' <- newFileSet set file ret <- splits file (read line) (read column) return (ret, True, set') -doSig :: Set FilePath +doSig :: IOish m + => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) doSig set fileArg = do let [file, line, column] = words fileArg set' <- newFileSet set file @@ -266,15 +271,17 @@ doSig set fileArg = do ---------------------------------------------------------------- -bootIt :: Set FilePath - -> GhcMod (String, Bool, Set FilePath) +bootIt :: IOish m + => Set FilePath + -> GhcModT m (String, Bool, Set FilePath) bootIt set = do ret <- boot return (ret, True, set) -browseIt :: Set FilePath +browseIt :: IOish m + => Set FilePath -> ModuleString - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) browseIt set mdl = do ret <- browse mdl return (ret, True, set) diff --git a/test/TestUtils.hs b/test/TestUtils.hs index acb6e21..c9ed00f 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -12,14 +12,14 @@ module TestUtils ( import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types -isolateCradle :: GhcMod a -> GhcMod a +isolateCradle :: IOish m => GhcModT m a -> GhcModT m 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 +runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a +runIsolatedGhcMod opt action = runGhcModT opt $ isolateCradle action -- | Run GhcMod in isolated cradle with default options runID = runIsolatedGhcMod defaultOptions @@ -28,7 +28,9 @@ runID = runIsolatedGhcMod defaultOptions runI = runIsolatedGhcMod -- | Run GhcMod -run = runGhcMod +run :: Options -> GhcModT IO a -> IO a +run = runGhcModT -- | Run GhcMod with default options -runD = runGhcMod defaultOptions +runD :: GhcModT IO a -> IO a +runD = runGhcModT defaultOptions