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