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

Ghc -> GhcMod: Browse, Check

Browse Source
This commit is contained in:
Daniel Gröber 2014-05-10 15:10:34 +02:00
parent e5c6d3e472
commit f1535efcf2
10 changed files with 109 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Language/Haskell/GhcMod.hs
View File

@ -14,7 +14,7 @@ module Language.Haskell.GhcMod (
, Expression
-- * 'IO' utilities
, bootInfo
, browseModule
, browse
, checkSyntax
, lintSyntax
, expandTemplate

2
Language/Haskell/GhcMod/Boot.hs
View File

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

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

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

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

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

26
Language/Haskell/GhcMod/Monad.hs
View File

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

5
src/GHCMod.hs
View File

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

21
src/GHCModi.hs
View File

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

20
test/BrowseSpec.hs
View File

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

13
test/CheckSpec.hs
View File

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

34
test/TestUtils.hs Normal file
View File

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