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
Show Stats 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

2
ghc-mod.cabal
View File

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

4
src/GHCMod.hs
View File

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

13
src/GHCModi.hs
View File

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

3
test/CheckSpec.hs
View File

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