hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Ghc->GhcMod: finish Browse, Check

Browse Source
This commit is contained in:
Daniel Gröber
2014-05-14 18:05:40 +02:00
parent ebfb740a2e
commit 80e2761f2f
9 changed files with 68 additions and 72 deletions
Download Patch File Download Diff File Expand all files Collapse all files

15
Language/Haskell/GhcMod/Browse.hs
View File

@@ -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

25
Language/Haskell/GhcMod/Check.hs
View File

@@ -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

13
Language/Haskell/GhcMod/Find.hs
View File

@@ -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)

21
Language/Haskell/GhcMod/GHCApi.hs
View File

@@ -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
----------------------------------------------------------------

44
Language/Haskell/GhcMod/Logger.hs
View File

@@ -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