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

Merge remote-tracking branch 'kazu/master'

Browse Source 
Conflicts:
	Language/Haskell/GhcMod.hs
	Language/Haskell/GhcMod/Check.hs
	Language/Haskell/GhcMod/FillSig.hs
	Language/Haskell/GhcMod/GHCApi.hs
	Language/Haskell/GhcMod/Ghc.hs
	src/GHCMod.hs
This commit is contained in:
Alejandro Serrano 2014-07-16 19:01:43 +02:00
commit 57bd408785
46 changed files with 932 additions and 726 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
.travis.yml
View File

@ -1,33 +1,25 @@
env:
- GHCVER=7.4.2
- GHCVER=7.6.3
- GHCVER=7.8.2
before_install:
- sudo add-apt-repository -y ppa:hvr/ghc
- sudo apt-get update
- sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy-1.19.3
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:/opt/happy/1.19.3/bin:$PATH
language: haskell
ghc:
- 7.4
- 7.6
- 7.8
install:
- cabal update
- cabal install --only-dependencies --enable-tests
- cabal install happy --constraint 'transformers <= 0.3.0.0'
- happy --version
- cabal install -j --only-dependencies --enable-tests
script:
- cabal check
- cabal sdist
- export SRC_TGZ="$PWD/dist/$(cabal info . | awk '{print $2 ".tar.gz";exit}')"
- rm -rf /tmp/test && mkdir -p /tmp/test
- cd /tmp/test
- tar -xf $SRC_TGZ && cd ghc-mod*/
- cabal configure --enable-tests
- cabal build
- cabal test
- cabal check
- cabal sdist
# The following scriptlet checks that the resulting source distribution can be built & installed
- export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}');
cd dist/;
if [ -f "$SRC_TGZ" ]; then
cabal install --enable-tests "$SRC_TGZ";
else
echo "expected '$SRC_TGZ' not found";
exit 1;
fi
matrix:
allow_failures:

29
Language/Haskell/GhcMod.hs
View File

@ -12,24 +12,25 @@ module Language.Haskell.GhcMod (
-- * Types
, ModuleString
, Expression
-- * 'IO' utilities
, bootInfo
, GhcPkgDb
-- * 'GhcMod' utilities
, boot
, browse
, check
, checkSyntax
, lintSyntax
, expandTemplate
, infoExpr
, typeExpr
, fillSig
, refineVar
, listModules
, listLanguages
, listFlags
, debugInfo
, rootInfo
, packageDoc
, expandTemplate
, findSymbol
, splitVar
, info
, lint
, pkgDoc
, rootInfo
, types
, splits
, sig
, modules
, languages
, flags
) where
import Language.Haskell.GhcMod.Boot

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

@ -1,27 +1,16 @@
module Language.Haskell.GhcMod.Boot where
import Control.Applicative ((<$>))
import CoreMonad (liftIO, liftIO)
import Control.Applicative
import Language.Haskell.GhcMod.Browse
import Language.Haskell.GhcMod.Flag
import Language.Haskell.GhcMod.Lang
import Language.Haskell.GhcMod.List
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
-- | Printing necessary information for front-end booting.
bootInfo :: Options -> IO String
bootInfo opt = runGhcMod opt $ boot
-- | Printing necessary information for front-end booting.
boot :: GhcMod String
boot = do
opt <- options
mods <- modules
langs <- liftIO $ listLanguages opt
flags <- liftIO $ listFlags opt
pre <- concat <$> mapM browse preBrowsedModules
return $ mods ++ langs ++ flags ++ pre
boot :: IOish m => GhcModT m String
boot = concat <$> sequence [modules, languages, flags,
concat <$> mapM browse preBrowsedModules]
preBrowsedModules :: [String]
preBrowsedModules = [

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

@ -10,10 +10,10 @@ import Data.List (sort)
import Data.Maybe (catMaybes)
import Exception (ghandle)
import FastString (mkFastString)
import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module)
import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)
import qualified GHC as G
import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified)
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Gap
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Convert
@ -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,13 +139,13 @@ 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
return $ concatMap (toNameModule dflag) (zip ms is)
toNameModule :: DynFlags -> (Module, Maybe ModuleInfo) -> [(String,String)]
toNameModule :: DynFlags -> (G.Module, Maybe ModuleInfo) -> [(String,String)]
toNameModule _ (_,Nothing) = []
toNameModule dflag (m,Just inf) = map (\name -> (toStr name, mdl)) names
where

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

@ -10,9 +10,10 @@ module Language.Haskell.GhcMod.CabalApi (
, cabalConfigDependencies
) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.CabalConfig
import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets, toModuleString)
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Types
import Control.Applicative ((<$>))
import qualified Control.Exception as E
@ -20,7 +21,6 @@ import Control.Monad (filterM)
import CoreMonad (liftIO)
import Data.Maybe (maybeToList)
import Data.Set (fromList, toList)
import Distribution.ModuleName (ModuleName,toFilePath)
import Distribution.Package (Dependency(Dependency)
, PackageName(PackageName))
import qualified Distribution.Package as C
@ -119,11 +119,7 @@ cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI
libBI = map P.libBuildInfo $ maybeToList $ P.library pd
execBI = map P.buildInfo $ P.executables pd
testBI = map P.testBuildInfo $ P.testSuites pd
#if __GLASGOW_HASKELL__ >= 704
benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd
#else
benchBI = []
#endif
benchBI = benchmarkBuildInfo pd
----------------------------------------------------------------
@ -172,16 +168,7 @@ cabalAllTargets pd = do
Just l -> P.libModules l
libTargets = map toModuleString lib
#if __GLASGOW_HASKELL__ >= 704
benchTargets = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd
#else
benchTargets = []
#endif
toModuleString :: ModuleName -> String
toModuleString mn = fromFilePath $ toFilePath mn
fromFilePath :: FilePath -> String
fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp
benchTargets = benchmarkTargets pd
getTestTarget :: TestSuite -> IO [String]
getTestTarget ts =

45
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -1,28 +1,24 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.CaseSplit (
splitVar
, splits
splits
) where
import CoreMonad (liftIO)
import Data.List (find, intercalate)
import qualified Data.Text as T
import qualified Data.Text.IO as T (readFile)
import qualified DataCon as Ty
import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import GHC (GhcMonad, LHsBind, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import qualified GHC as G
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Gap (HasType(..))
import Language.Haskell.GhcMod.Convert
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Convert
import MonadUtils (liftIO)
import Outputable (PprStyle)
import qualified Type as Ty
import qualified TyCon as Ty
import qualified DataCon as Ty
import qualified Type as Ty
----------------------------------------------------------------
-- CASE SPLITTING
@ -36,21 +32,11 @@ data SplitToTextInfo = SplitToTextInfo { sVarName :: String
}
-- | Splitting a variable in a equation.
splitVar :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> IO String
splitVar opt cradle file lineNo colNo = runGhcMod opt $ do
initializeFlagsWithCradle opt cradle
splits file lineNo colNo
-- | 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
@ -73,17 +59,12 @@ getSrcSpanTypeForSplit modSum lineNo colNo = do
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
let bs:_ = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)
match:_ = listifyParsedSpans pms (lineNo, colNo)
#if __GLASGOW_HASKELL__ < 708
:: [G.LMatch G.RdrName]
#else
:: [G.LMatch G.RdrName (LHsExpr G.RdrName)]
#endif
match:_ = listifyParsedSpans pms (lineNo, colNo) :: [Gap.GLMatch]
case varPat of
Nothing -> return Nothing
Just varPat' -> do
varT <- getType tcm varPat' -- Finally we get the type of the var
bsT <- getType tcm bs
varT <- Gap.getType tcm varPat' -- Finally we get the type of the var
bsT <- Gap.getType tcm bs
case (varT, bsT) of
(Just varT', Just (_,bsT')) ->
let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
@ -212,7 +193,7 @@ srcSpanDifference b v =
in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line
replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]
replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon
lengthDiff = length tycon' - length varname
tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'

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

@ -6,7 +6,7 @@ module Language.Haskell.GhcMod.Check (
) where
import Control.Applicative ((<$>))
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.DynFlags
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Logger
import Language.Haskell.GhcMod.Monad
@ -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,17 +30,19 @@ 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 . setNoMaxRelevantBindings) $ do
withLogger (setAllWaringFlags . setNoMaxRelevantBindings) $
setTargetFiles fileNames
----------------------------------------------------------------
-- | 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

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

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

7
Language/Haskell/GhcMod/Cradle.hs
View File

@ -1,5 +1,6 @@
module Language.Haskell.GhcMod.Cradle (
findCradle
, findCradle'
, findCradleWithoutSandbox
) where
@ -22,8 +23,10 @@ import System.FilePath ((</>), takeDirectory)
-- in a cabal directory.
findCradle :: IO Cradle
findCradle = do
wdir <- getCurrentDirectory
cabalCradle wdir ||> sandboxCradle wdir ||> plainCradle wdir
findCradle' =<< getCurrentDirectory
findCradle' :: FilePath -> IO Cradle
findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
cabalCradle :: FilePath -> IO Cradle
cabalCradle wdir = do

51
Language/Haskell/GhcMod/Debug.hs
View File

@ -1,55 +1,42 @@
module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where
import Control.Applicative ((<$>))
import Control.Exception.IOChoice ((||>))
import CoreMonad (liftIO)
import Data.List (intercalate)
import Data.Maybe (fromMaybe, isJust, fromJust)
import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.GHCApi
import Data.Maybe (isJust, fromJust)
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Internal
----------------------------------------------------------------
-- | Obtaining debug information.
debugInfo :: Options
-> Cradle
-> IO String
debugInfo opt cradle = convert opt <$> do
debugInfo :: IOish m => GhcModT m String
debugInfo = cradle >>= \c -> convert' =<< do
CompilerOptions gopts incDir pkgs <-
if cabal then
liftIO (fromCabalFile ||> return simpleCompilerOption)
if isJust $ cradleCabalFile c then
(fromCabalFile c ||> simpleCompilerOption)
else
return simpleCompilerOption
mglibdir <- liftIO getSystemLibDir
simpleCompilerOption
return [
"Root directory: " ++ rootDir
, "Current directory: " ++ currentDir
, "Cabal file: " ++ cabalFile
"Root directory: " ++ cradleRootDir c
, "Current directory: " ++ cradleCurrentDir c
, "Cabal file: " ++ show (cradleCabalFile c)
, "GHC options: " ++ unwords gopts
, "Include directories: " ++ unwords incDir
, "Dependent packages: " ++ intercalate ", " (map showPkg pkgs)
, "System libraries: " ++ fromMaybe "" mglibdir
, "System libraries: " ++ ghcLibDir
]
where
currentDir = cradleCurrentDir cradle
mCabalFile = cradleCabalFile cradle
rootDir = cradleRootDir cradle
cabal = isJust mCabalFile
cabalFile = fromMaybe "" mCabalFile
origGopts = ghcOpts opt
simpleCompilerOption = CompilerOptions origGopts [] []
fromCabalFile = do
pkgDesc <- parseCabalFile file
getCompilerOptions origGopts cradle pkgDesc
where
file = fromJust mCabalFile
simpleCompilerOption = options >>= \op ->
return $ CompilerOptions (ghcOpts op) [] []
fromCabalFile c = options >>= \opts -> liftIO $ do
pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile c
getCompilerOptions (ghcOpts opts) c pkgDesc
----------------------------------------------------------------
-- | Obtaining root information.
rootInfo :: Options
-> Cradle
-> IO String
rootInfo opt cradle = return $ convert opt $ cradleRootDir cradle
rootInfo :: IOish m => GhcModT m String
rootInfo = convert' =<< cradleRootDir <$> cradle

155
Language/Haskell/GhcMod/DynFlags.hs Normal file
View File

@ -0,0 +1,155 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.DynFlags where
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types
import Control.Applicative ((<$>))
import Control.Monad (forM, void, (>=>))
import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
import qualified GHC as G
import GhcMonad
import GHC.Paths (libdir)
import DynFlags (ExtensionFlag(..), xopt)
import System.IO.Unsafe (unsafePerformIO)
data Build = CabalPkg | SingleFile deriving Eq
setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
-- Fast
-- Friendly to foreign export
-- Not friendly to Template Haskell
-- Uses small memory
setModeSimple :: DynFlags -> DynFlags
setModeSimple df = df {
ghcMode = CompManager
, ghcLink = NoLink
, hscTarget = HscNothing
, optLevel = 0
}
-- Slow
-- Not friendly to foreign export
-- Friendly to Template Haskell
-- Uses large memory
setModeIntelligent :: DynFlags -> DynFlags
setModeIntelligent df = df {
ghcMode = CompManager
, ghcLink = LinkInMemory
, hscTarget = HscInterpreted
, optLevel = 0
}
setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags
setIncludeDirs idirs df = df { importPaths = idirs }
setBuildEnv :: Build -> DynFlags -> DynFlags
setBuildEnv build = setHideAllPackages build . setCabalPackage build
-- At the moment with this option set ghc only prints different error messages,
-- suggesting the user to add a hidden package to the build-depends in his cabal
-- file for example
setCabalPackage :: Build -> DynFlags -> DynFlags
setCabalPackage CabalPkg df = Gap.setCabalPkg df
setCabalPackage _ df = df
-- | Enable hiding of all package not explicitly exposed (like Cabal does)
setHideAllPackages :: Build -> DynFlags -> DynFlags
setHideAllPackages CabalPkg df = Gap.setHideAllPackages df
setHideAllPackages _ df = df
-- | Parse command line ghc options and add them to the 'DynFlags' passed
addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags
addCmdOpts cmdOpts df =
tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
where
tfst (a,_,_) = a
----------------------------------------------------------------
-- | Set the files as targets and load them.
setTargetFiles :: (GhcMonad m) => [FilePath] -> m ()
setTargetFiles files = do
targets <- forM files $ \file -> G.guessTarget file Nothing
G.setTargets targets
xs <- G.depanal [] False
-- FIXME, checking state
loadTargets $ needsFallback xs
where
loadTargets False = do
-- Reporting error A and error B
void $ G.load LoadAllTargets
mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph
-- Reporting error B and error C
mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss
-- Error B duplicates. But we cannot ignore both error reportings,
-- sigh. So, the logger makes log messages unique by itself.
loadTargets True = do
df <- G.getSessionDynFlags
void $ G.setSessionDynFlags (setModeIntelligent df)
void $ G.load LoadAllTargets
needsFallback :: G.ModuleGraph -> Bool
needsFallback = any (hasTHorQQ . G.ms_hspp_opts)
where
hasTHorQQ :: DynFlags -> Bool
hasTHorQQ dflags = any (`xopt` dflags) [Opt_TemplateHaskell, Opt_QuasiQuotes]
----------------------------------------------------------------
-- | Return the 'DynFlags' currently in use in the GHC session.
getDynamicFlags :: IO DynFlags
getDynamicFlags = do
G.runGhc (Just libdir) G.getSessionDynFlags
withDynFlags :: GhcMonad m
=> (DynFlags -> DynFlags)
-> m a
-> m a
withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body)
where
setup = do
dflags <- G.getSessionDynFlags
void $ G.setSessionDynFlags (setFlags dflags)
return dflags
teardown = void . G.setSessionDynFlags
withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a
withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)
where
setup = do
dflags <- G.getSessionDynFlags >>= addCmdOpts flags
void $ G.setSessionDynFlags dflags
return dflags
teardown = void . G.setSessionDynFlags
----------------------------------------------------------------
-- | Set 'DynFlags' equivalent to "-w:".
setNoWaringFlags :: DynFlags -> DynFlags
setNoWaringFlags df = df { warningFlags = Gap.emptyWarnFlags}
-- | Set 'DynFlags' equivalent to "-Wall".
setAllWaringFlags :: DynFlags -> DynFlags
setAllWaringFlags df = df { warningFlags = allWarningFlags }
allWarningFlags :: Gap.WarnFlags
allWarningFlags = unsafePerformIO $ do
G.runGhc (Just libdir) $ do
df <- G.getSessionDynFlags
df' <- addCmdOpts ["-Wall"] df
return $ G.warningFlags df'
----------------------------------------------------------------
-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
setNoMaxRelevantBindings :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
#else
setNoMaxRelevantBindings = id
#endif

91
Language/Haskell/GhcMod/FillSig.hs
View File

@ -1,10 +1,7 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP #-}
module Language.Haskell.GhcMod.FillSig (
fillSig
, sig
, refineVar
, refine
sig
) where
import Data.Char (isSymbol)
@ -12,23 +9,16 @@ import Data.List (find, intercalate)
import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import qualified GHC as G
import Language.Haskell.GhcMod.GHCApi
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Types
import MonadUtils (liftIO)
import CoreMonad (liftIO)
import Outputable (PprStyle)
import qualified Type as Ty
import qualified HsBinds as Ty
import qualified Class as Ty
#if __GLASGOW_HASKELL__ >= 706
import OccName (occName)
#else
import OccName (OccName)
import RdrName (rdrNameOcc)
#endif
import qualified Language.Haskell.Exts.Annotated as HE
----------------------------------------------------------------
@ -40,24 +30,14 @@ data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
| InstanceDecl SrcSpan G.Class
-- Signature for fallback operation via haskell-src-exts
data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
-- | Create a initial body from a signature.
fillSig :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> IO String
fillSig opt cradle file lineNo colNo = runGhcMod opt $ do
initializeFlagsWithCradle opt cradle
sig file lineNo colNo
-- | 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
@ -69,13 +49,13 @@ sig file lineNo colNo = ghandle handler body
InstanceDecl loc cls -> do
("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
(Ty.classMethods cls))
handler (SomeException _) = do
opt <- options
-- Code cannot be parsed by ghc module
-- Fallback: try to get information via haskell-src-exts
whenFound opt (getSignatureFromHE file lineNo colNo) $
\(HESignature loc names ty) ->
\(HESignature loc names ty) ->
("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
----------------------------------------------------------------
@ -94,32 +74,9 @@ getSignature modSum lineNo colNo = do
-- We found an instance declaration
TypecheckedModule{tm_renamed_source = Just tcs
,tm_checked_module_info = minfo} <- G.typecheckModule p
case listifyRenamedSpans tcs (lineNo, colNo) :: [G.LInstDecl G.Name] of
-- Instance declarations of sort 'instance F (G a)'
#if __GLASGOW_HASKELL__ >= 708
[L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty =
(L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] ->
#elif __GLASGOW_HASKELL__ >= 706
[L loc (G.ClsInstD
(L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)))) _ _ _)] ->
#else
[L loc (G.InstDecl
(L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)))) _ _ _)] ->
#endif
obtainClassInfo minfo clsName loc
-- Instance declarations of sort 'instance F G' (no variables)
#if __GLASGOW_HASKELL__ >= 708
[L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty =
(L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))}))] ->
#elif __GLASGOW_HASKELL__ >= 706
[L loc (G.ClsInstD
(L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)) _ _ _)] ->
#else
[L loc (G.InstDecl
(L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)) _ _ _)] ->
#endif
obtainClassInfo minfo clsName loc
_ -> return Nothing
case Gap.getClass $ listifyRenamedSpans tcs (lineNo, colNo) of
Just (clsName,loc) -> obtainClassInfo minfo clsName loc
Nothing -> return Nothing
_ -> return Nothing
where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo)
obtainClassInfo minfo clsName loc = do
@ -173,7 +130,7 @@ class FnArgsInfo ty name | ty -> name, name -> ty where
getFnArgs :: ty -> [FnArg]
instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
getFnName dflag style name = showOccName dflag style $ occName name
getFnName dflag style name = showOccName dflag style $ Gap.occName name
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy
getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy
getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
@ -184,11 +141,6 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
_ -> False
getFnArgs _ = []
#if __GLASGOW_HASKELL__ < 706
occName :: G.RdrName -> OccName
occName = rdrNameOcc
#endif
instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
getFnName _ _ (HE.Ident _ s) = s
getFnName _ _ (HE.Symbol _ s) = s
@ -229,23 +181,13 @@ isSymbolName [] = error "This should never happen"
-- REWRITE A HOLE / UNDEFINED VIA A FUNCTION
----------------------------------------------------------------
-- | Create a initial body from a signature.
refineVar :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> Expression -- ^ A Haskell expression.
-> IO String
refineVar opt cradle file lineNo colNo e = runGhcMod opt $ do
initializeFlagsWithCradle opt cradle
refine file lineNo colNo e
refine :: FilePath -- ^ A target file.
{-
refine :: IOish m
=> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> Expression -- ^ A Haskell expression.
-> GhcMod String
-> GhcModT m String
refine file lineNo colNo expr = ghandle handler body
where
body = inModuleContext file $ \dflag style -> do
@ -273,3 +215,4 @@ findVar modSum lineNo colNo = do
case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsExpr G.RdrName] of
(L loc (G.HsVar _)):_ -> return $ Just loc
_ -> return Nothing
-}

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

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

12
Language/Haskell/GhcMod/Flag.hs
View File

@ -2,12 +2,12 @@ module Language.Haskell.GhcMod.Flag where
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad
-- | Listing GHC flags. (e.g -fno-warn-orphans)
listFlags :: Options -> IO String
listFlags opt = return $ convert opt [ "-f" ++ prefix ++ option
| option <- Gap.fOptions
, prefix <- ["","no-"]
]
flags :: IOish m => GhcModT m String
flags = convert' [ "-f" ++ prefix ++ option
| option <- Gap.fOptions
, prefix <- ["","no-"]
]

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

@ -1,214 +1,87 @@
{-# LANGUAGE ScopedTypeVariables, RecordWildCards, CPP #-}
module Language.Haskell.GhcMod.GHCApi (
withGHC
, withGHC'
, initializeFlagsWithCradle
, setTargetFiles
, getDynamicFlags
, getSystemLibDir
, withDynFlags
, withCmdFlags
, setNoWaringFlags
, setAllWaringFlags
, setNoMaxRelevantBindings
ghcPkgDb
, package
, modules
, findModule
, moduleInfo
, localModuleInfo
, bindings
) where
import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Types
import Control.Applicative ((<$>))
import Control.Monad (forM, void)
import Data.Maybe (isJust, fromJust)
import Exception (ghandle, SomeException(..))
import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
import Distribution.Package (InstalledPackageId(..))
import qualified Data.Map as M
import GHC (DynFlags(..))
import qualified GHC as G
import GhcMonad
import GHC.Paths (libdir)
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types
import System.Exit (exitSuccess)
import System.IO (hPutStr, hPrint, stderr)
import System.IO.Unsafe (unsafePerformIO)
import qualified Packages as G
import qualified Module as G
import qualified OccName as G
----------------------------------------------------------------
-- get Packages,Modules,Bindings
-- | Obtaining the directory for system libraries.
getSystemLibDir :: IO (Maybe FilePath)
getSystemLibDir = return $ Just libdir
ghcPkgDb :: GhcMonad m => m PkgDb
ghcPkgDb = M.fromList <$>
maybe [] (map toKv . filterInternal) <$> pkgDatabase <$> G.getSessionDynFlags
where
toKv pkg = (fromInstalledPackageId $ G.installedPackageId pkg, pkg)
filterInternal =
filter ((/= InstalledPackageId "builtin_rts") . G.installedPackageId)
----------------------------------------------------------------
package :: G.PackageConfig -> Package
package = fromInstalledPackageId . G.installedPackageId
-- | Converting the 'Ghc' monad to the 'IO' monad.
withGHC :: FilePath -- ^ A target file displayed in an error message.
-> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities.
-> IO a
withGHC file body = ghandle ignore $ withGHC' body
where
ignore :: SomeException -> IO a
ignore e = do
hPutStr stderr $ file ++ ":0:0:Error:"
hPrint stderr e
exitSuccess
modules :: G.PackageConfig -> [ModuleString]
modules = map G.moduleNameString . G.exposedModules
withGHC' :: Ghc a -> IO a
withGHC' body = do
mlibdir <- getSystemLibDir
G.runGhc mlibdir $ do
dflags <- G.getSessionDynFlags
G.defaultCleanupHandler dflags body
----------------------------------------------------------------
importDirs :: [IncludeDir]
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
data Build = CabalPkg | SingleFile deriving Eq
-- | Initialize the 'DynFlags' relating to the compilation of a single
-- file or GHC session according to the 'Cradle' and 'Options'
-- provided.
initializeFlagsWithCradle :: GhcMonad m
=> Options
-> Cradle
-> m ()
initializeFlagsWithCradle opt cradle
| cabal = withCabal |||> withSandbox
| otherwise = withSandbox
where
mCradleFile = cradleCabalFile cradle
cabal = isJust mCradleFile
ghcopts = ghcOpts opt
withCabal = do
pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile
compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc
initSession CabalPkg opt compOpts
withSandbox = initSession SingleFile opt compOpts
where
pkgOpts = ghcDbStackOpts $ cradlePkgDbStack cradle
compOpts
| null pkgOpts = CompilerOptions ghcopts importDirs []
| otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []
wdir = cradleCurrentDir cradle
rdir = cradleRootDir cradle
----------------------------------------------------------------
initSession :: GhcMonad m
=> Build
-> Options
-> CompilerOptions
-> m ()
initSession build Options {..} CompilerOptions {..} = do
df <- G.getSessionDynFlags
void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions
$ setLinkerOptions
$ setIncludeDirs includeDirs
$ setBuildEnv build
$ setEmptyLogger
$ Gap.addPackageFlags depPackages df)
setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
----------------------------------------------------------------
-- we don't want to generate object code so we compile to bytecode
-- (HscInterpreted) which implies LinkInMemory
-- HscInterpreted
setLinkerOptions :: DynFlags -> DynFlags
setLinkerOptions df = df {
ghcLink = LinkInMemory
, hscTarget = HscInterpreted
}
setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags
setIncludeDirs idirs df = df { importPaths = idirs }
setBuildEnv :: Build -> DynFlags -> DynFlags
setBuildEnv build = setHideAllPackages build . setCabalPackage build
-- At the moment with this option set ghc only prints different error messages,
-- suggesting the user to add a hidden package to the build-depends in his cabal
-- file for example
setCabalPackage :: Build -> DynFlags -> DynFlags
setCabalPackage CabalPkg df = Gap.setCabalPkg df
setCabalPackage _ df = df
-- | Enable hiding of all package not explicitly exposed (like Cabal does)
setHideAllPackages :: Build -> DynFlags -> DynFlags
setHideAllPackages CabalPkg df = Gap.setHideAllPackages df
setHideAllPackages _ df = df
-- | Parse command line ghc options and add them to the 'DynFlags' passed
addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags
addCmdOpts cmdOpts df =
tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
where
tfst (a,_,_) = a
----------------------------------------------------------------
-- | Set the files as targets and load them.
setTargetFiles :: (GhcMonad m) => [FilePath] -> m ()
setTargetFiles files = do
targets <- forM files $ \file -> G.guessTarget file Nothing
G.setTargets targets
void $ G.load LoadAllTargets
----------------------------------------------------------------
-- | Return the 'DynFlags' currently in use in the GHC session.
getDynamicFlags :: IO DynFlags
getDynamicFlags = do
mlibdir <- getSystemLibDir
G.runGhc mlibdir G.getSessionDynFlags
withDynFlags :: GhcMonad m
=> (DynFlags -> DynFlags)
-> m a
-> m a
withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body)
where
setup = do
dflags <- G.getSessionDynFlags
void $ G.setSessionDynFlags (setFlags dflags)
return dflags
teardown = void . G.setSessionDynFlags
withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a
withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)
where
setup = do
dflags <- G.getSessionDynFlags >>= addCmdOpts flags
void $ G.setSessionDynFlags dflags
return dflags
teardown = void . G.setSessionDynFlags
----------------------------------------------------------------
-- | Set 'DynFlags' equivalent to "-w:".
setNoWaringFlags :: DynFlags -> DynFlags
setNoWaringFlags df = df { warningFlags = Gap.emptyWarnFlags}
-- | Set 'DynFlags' equivalent to "-Wall".
setAllWaringFlags :: DynFlags -> DynFlags
setAllWaringFlags df = df { warningFlags = allWarningFlags }
-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
setNoMaxRelevantBindings :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
#else
setNoMaxRelevantBindings = id
#endif
findModule :: ModuleString -> PkgDb -> [Package]
findModule m db = do
M.elems $ package `M.map` (containsModule `M.filter` db)
where
containsModule :: G.PackageConfig -> Bool
containsModule pkgConf =
G.mkModuleName m `elem` G.exposedModules pkgConf
allWarningFlags :: Gap.WarnFlags
allWarningFlags = unsafePerformIO $ do
mlibdir <- getSystemLibDir
G.runGhc mlibdir $ do
df <- G.getSessionDynFlags
df' <- addCmdOpts ["-Wall"] df
return $ G.warningFlags df'
ghcPkgId :: Package -> G.PackageId
ghcPkgId (name,_,_) =
-- TODO: Adding the package version too breaks 'findModule' for some reason
-- this isn't a big deal since in the common case where we're in a cabal
-- project we just use cabal's view of package dependencies anyways so we're
-- guaranteed to only have one version of each package exposed. However when
-- we're operating without a cabal project this will probaly cause trouble.
G.stringToPackageId name
type Binding = String
-- | @moduleInfo mpkg module@. @mpkg@ should be 'Nothing' iff. moduleInfo
-- should look for @module@ in the working directory.
--
-- To map a 'ModuleString' to a package see 'findModule'
moduleInfo :: GhcMonad m
=> Maybe Package
-> ModuleString
-> m (Maybe G.ModuleInfo)
moduleInfo mpkg mdl = do
let mdlName = G.mkModuleName mdl
mfsPkgId = G.packageIdFS . ghcPkgId <$> mpkg
loadLocalModule
G.findModule mdlName mfsPkgId >>= G.getModuleInfo
where
loadLocalModule = case mpkg of
Just _ -> return ()
Nothing -> setTargetFiles [mdl]
localModuleInfo :: GhcMonad m => ModuleString -> m (Maybe G.ModuleInfo)
localModuleInfo mdl = moduleInfo Nothing mdl
bindings :: G.ModuleInfo -> [Binding]
bindings minfo = do
map (G.occNameString . G.getOccName) $ G.modInfoExports minfo

67
Language/Haskell/GhcMod/Gap.hs
View File

@ -33,6 +33,12 @@ module Language.Haskell.GhcMod.Gap (
, fileModSummary
, WarnFlags
, emptyWarnFlags
, benchmarkBuildInfo
, benchmarkTargets
, toModuleString
, GLMatch
, getClass
, occName
) where
import Control.Applicative hiding (empty)
@ -58,6 +64,7 @@ import StringBuffer
import TcType
import Var (varType)
import qualified Distribution.PackageDescription as P
import qualified InstEnv
import qualified Pretty
import qualified StringBuffer as SB
@ -76,10 +83,12 @@ import GHC hiding (ClsInst)
import GHC hiding (Instance)
import Control.Arrow hiding ((<+>))
import Data.Convertible
import RdrName (rdrNameOcc)
#endif
#if __GLASGOW_HASKELL__ >= 704
import qualified Data.IntSet as I (IntSet, empty)
import qualified Distribution.ModuleName as M (ModuleName,toFilePath)
#endif
----------------------------------------------------------------
@ -280,8 +289,10 @@ class HasType a where
instance HasType (LHsBind Id) where
#if __GLASGOW_HASKELL__ >= 708
getType _ (L spn FunBind{fun_matches = MG _ in_tys out_typ}) = return $ Just (spn, typ)
where typ = mkFunTys in_tys out_typ
getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ)
where in_tys = mg_arg_tys m
out_typ = mg_res_ty m
typ = mkFunTys in_tys out_typ
#else
getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)
#endif
@ -396,3 +407,55 @@ type WarnFlags = [WarningFlag]
emptyWarnFlags :: WarnFlags
emptyWarnFlags = []
#endif
----------------------------------------------------------------
----------------------------------------------------------------
benchmarkBuildInfo :: P.PackageDescription -> [P.BuildInfo]
#if __GLASGOW_HASKELL__ >= 704
benchmarkBuildInfo pd = map P.benchmarkBuildInfo $ P.benchmarks pd
#else
benchmarkBuildInfo pd = []
#endif
benchmarkTargets :: P.PackageDescription -> [String]
#if __GLASGOW_HASKELL__ >= 704
benchmarkTargets pd = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd
#else
benchmarkTargets = []
#endif
toModuleString :: M.ModuleName -> String
toModuleString mn = fromFilePath $ M.toFilePath mn
where
fromFilePath :: FilePath -> String
fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp
----------------------------------------------------------------
----------------------------------------------------------------
#if __GLASGOW_HASKELL__ >= 708
type GLMatch = LMatch RdrName (LHsExpr RdrName)
#else
type GLMatch = LMatch RdrName
#endif
getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)
#if __GLASGOW_HASKELL__ >= 708
-- Instance declarations of sort 'instance F (G a)'
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)
-- Instance declarations of sort 'instance F G' (no variables)
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)
#elif __GLASGOW_HASKELL__ >= 706
getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)
getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)
#else
getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)
getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)
#endif
getClass _ = Nothing
#if __GLASGOW_HASKELL__ < 706
occName :: RdrName -> OccName
occName = rdrNameOcc
#endif

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

@ -1,31 +1,10 @@
module Language.Haskell.GhcMod.Ghc (
-- * Converting the 'Ghc' monad to the 'IO' monad
withGHC
, withGHC'
-- * 'Ghc' utilities
, boot
, browse
, check
, info
, types
, splits
, sig
, refine
, modules
-- * 'SymMdlDb'
, Symbol
Symbol
, SymMdlDb
, getSymMdlDb
, lookupSym
, lookupSym'
) where
import Language.Haskell.GhcMod.Boot
import Language.Haskell.GhcMod.Browse
import Language.Haskell.GhcMod.Check
import Language.Haskell.GhcMod.Find
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Info
import Language.Haskell.GhcMod.List
import Language.Haskell.GhcMod.FillSig
import Language.Haskell.GhcMod.CaseSplit

37
Language/Haskell/GhcMod/Info.hs
View File

@ -1,7 +1,5 @@
module Language.Haskell.GhcMod.Info (
infoExpr
, info
, typeExpr
info
, types
) where
@ -13,7 +11,6 @@ import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
import qualified GHC as G
import Language.Haskell.GhcMod.Doc (showPage)
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Gap (HasType(..))
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad
@ -24,19 +21,10 @@ import Language.Haskell.GhcMod.Convert
----------------------------------------------------------------
-- | Obtaining information of a target expression. (GHCi's info:)
infoExpr :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> Expression -- ^ A Haskell expression.
-> IO String
infoExpr opt cradle file expr = runGhcMod opt $ do
initializeFlagsWithCradle opt cradle
info file expr
-- | 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
@ -49,21 +37,11 @@ info file expr = do
----------------------------------------------------------------
-- | Obtaining type of a target expression. (GHCi's type:)
typeExpr :: Options
-> Cradle
-> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> IO String
typeExpr opt cradle file lineNo colNo = runGhcMod opt $ do
initializeFlagsWithCradle opt cradle
types file lineNo colNo
-- | 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
@ -85,4 +63,3 @@ getSrcSpanType modSum lineNo colNo = do
ets <- mapM (getType tcm) es
pts <- mapM (getType tcm) ps
return $ catMaybes $ concat [ets, bts, pts]

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

@ -16,11 +16,10 @@ module Language.Haskell.GhcMod.Internal (
, cabalDependPackages
, cabalSourceDirs
, cabalAllTargets
-- * GHC.Paths
, ghcLibDir
-- * IO
, getSystemLibDir
, getDynamicFlags
-- * Initializing 'DynFlags'
, initializeFlagsWithCradle
-- * Targets
, setTargetFiles
-- * Logging
@ -35,8 +34,14 @@ module Language.Haskell.GhcMod.Internal (
, (|||>)
) where
import GHC.Paths (libdir)
import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.Logger
import Language.Haskell.GhcMod.Types
-- | Obtaining the directory for ghc system libraries.
ghcLibDir :: FilePath
ghcLibDir = libdir

6
Language/Haskell/GhcMod/Lang.hs
View File

@ -1,10 +1,10 @@
module Language.Haskell.GhcMod.Lang where
import DynFlags (supportedLanguagesAndExtensions)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
-- | Listing language extensions.
listLanguages :: Options -> IO String
listLanguages opt = return $ convert opt supportedLanguagesAndExtensions
languages :: IOish m => GhcModT m String
languages = convert' supportedLanguagesAndExtensions

22
Language/Haskell/GhcMod/Lint.hs
View File

@ -1,19 +1,21 @@
module Language.Haskell.GhcMod.Lint where
import Control.Applicative ((<$>))
import Control.Exception (handle, SomeException(..))
import Exception (ghandle)
import Control.Exception (SomeException(..))
import CoreMonad (liftIO)
import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad
import Language.Haskell.HLint (hlint)
-- | Checking syntax of a target file using hlint.
-- Warnings and errors are returned.
lintSyntax :: Options
-> FilePath -- ^ A target file.
-> IO String
lintSyntax opt file = handle handler $ pack <$> hlint (file : "--quiet" : hopts)
where
pack = convert opt . map (init . show) -- init drops the last \n.
hopts = hlintOpts opt
lint :: IOish m
=> FilePath -- ^ A target file.
-> GhcModT m String
lint file = do
opt <- options
ghandle handler . pack =<< (liftIO $ hlint $ file : "--quiet" : hlintOpts opt)
where
pack = convert' . map (init . show) -- init drops the last \n.
handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"

9
Language/Haskell/GhcMod/List.hs
View File

@ -1,4 +1,4 @@
module Language.Haskell.GhcMod.List (listModules, modules) where
module Language.Haskell.GhcMod.List (modules) where
import Control.Applicative ((<$>))
import Control.Exception (SomeException(..))
@ -6,18 +6,13 @@ import Data.List (nub, sort)
import qualified GHC as G
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Types
import Packages (pkgIdMap, exposedModules, sourcePackageId, display)
import UniqFM (eltsUFM)
----------------------------------------------------------------
-- | Listing installed modules.
listModules :: Options -> Cradle -> IO String
listModules opt _ = runGhcMod opt $ modules
-- | Listing installed modules.
modules :: GhcMod String
modules :: IOish m => GhcModT m String
modules = do
opt <- options
convert opt . (arrange opt) <$> (getModules `G.gcatch` handler)

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

@ -6,7 +6,7 @@ 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)
@ -17,11 +17,10 @@ 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 Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags)
import qualified Language.Haskell.GhcMod.Gap as Gap
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)
@ -29,35 +28,46 @@ import System.FilePath (normalise)
type Builder = [String] -> [String]
newtype LogRef = LogRef (IORef Builder)
data Log = Log [String] Builder
newtype LogRef = LogRef (IORef Log)
emptyLog :: Log
emptyLog = Log [] id
newLogRef :: IO LogRef
newLogRef = LogRef <$> newIORef id
newLogRef = LogRef <$> newIORef emptyLog
readAndClearLogRef :: LogRef -> GhcMod String
readAndClearLogRef :: IOish m => LogRef -> GhcModT m String
readAndClearLogRef (LogRef ref) = do
b <- liftIO $ readIORef ref
liftIO $ writeIORef ref id
Log _ b <- liftIO $ readIORef ref
liftIO $ writeIORef ref emptyLog
convert' (b [])
appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef df (LogRef ref) _ sev src style msg = do
let !l = ppMsg src sev df style msg
modifyIORef ref (\b -> b . (l:))
appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update
where
l = ppMsg src sev df style msg
update lg@(Log ls b)
| l `elem` ls = lg
| otherwise = Log (l:ls) (b . (l:))
----------------------------------------------------------------
-- | 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
withDynFlags (setLogger logref . setDF) $ do
withCmdFlags wflags $ do body *> (Right <$> readAndClearLogRef logref)
withCmdFlags wflags $ do
body
Right <$> readAndClearLogRef logref
where
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
@ -65,7 +75,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

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

@ -1,29 +1,54 @@
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses, RankNTypes, TypeFamilies #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad (
GhcMod
, runGhcMod
, liftGhcMod
, GhcModT
, IOish
, GhcModEnv(..)
, GhcModWriter
, GhcModState(..)
, runGhcMod'
, runGhcMod
, runGhcModT'
, runGhcModT
, newGhcModEnv
, withErrorHandler
, toGhcMod
, options
, cradle
, Options(..)
, defaultOptions
, module Control.Monad.Reader.Class
, module Control.Monad.Writer.Class
, module Control.Monad.State.Class
) where
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.GHCApi
#if __GLASGOW_HASKELL__ < 708
-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
-- classes before ghc 7.8
#define DIFFERENT_MONADIO 1
-- RWST doen't have a MonadIO instance before ghc 7.8
#define MONADIO_INSTANCES 1
#endif
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.CabalApi
import qualified Language.Haskell.GhcMod.Gap as Gap
import DynFlags
import Exception
import GHC
import qualified GHC as G
import GHC.Paths (libdir)
import GhcMonad
#if __GLASGOW_HASKELL__ <= 702
@ -36,23 +61,33 @@ import HscTypes
-- So, RWST automatically becomes an instance of MonadIO.
import MonadUtils
#if __GLASGOW_HASKELL__ < 708
-- To make RWST an instance of MonadIO.
#if DIFFERENT_MONADIO
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.IO.Class
import Data.Monoid (Monoid)
#endif
import Control.Monad (liftM)
import Control.Monad.Base (MonadBase,liftBase)
import Control.Applicative (Alternative)
import Control.Monad (MonadPlus, liftM, void)
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.RWS.Lazy (RWST(..),runRWST)
import Control.Monad.Trans.Class
#if __GLASGOW_HASKELL__ < 708
import Control.Monad.Trans.Maybe
#endif
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST)
import Control.Monad.Writer.Class
import Control.Monad.Error (Error(..), ErrorT(..), MonadError)
import Data.Maybe (fromJust, isJust)
import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import System.Exit (exitSuccess)
import System.IO (hPutStr, hPrint, stderr)
import System.Directory (getCurrentDirectory)
----------------------------------------------------------------
@ -62,102 +97,268 @@ data GhcModEnv = GhcModEnv {
, gmCradle :: Cradle
}
data GhcModState = GhcModState
data GhcModState = GhcModState deriving (Eq,Show,Read)
defaultState :: GhcModState
defaultState = GhcModState
type GhcModWriter = ()
data GhcModError = GMENoMsg
| GMEString String
| GMECabal
| GMEGhc
deriving (Eq,Show,Read)
instance Error GhcModError where
noMsg = GMENoMsg
strMsg = GMEString
----------------------------------------------------------------
newtype GhcMod a = GhcMod {
unGhcMod :: RWST GhcModEnv GhcModWriter GhcModState IO a
type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m)
type GhcMod a = GhcModT (ErrorT GhcModError IO) a
newtype GhcModT m a = GhcModT {
unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a
} deriving (Functor
,Applicative
,Monad
,MonadIO
,MonadReader GhcModEnv
,MonadWriter GhcModWriter
,MonadState GhcModState
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadIO
#if DIFFERENT_MONADIO
, Control.Monad.IO.Class.MonadIO
#endif
, MonadReader GhcModEnv
, MonadWriter GhcModWriter
, MonadState GhcModState
, MonadTrans
)
#if __GLASGOW_HASKELL__ < 708
deriving instance MonadError GhcModError m => MonadError GhcModError (GhcModT m)
#if MONADIO_INSTANCES
instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
-- liftIO :: MonadIO m => IO a -> m a
liftIO = lift . liftIO
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
liftIO = lift . liftIO
instance (MonadIO m) => MonadIO (MaybeT m) where
liftIO = lift . liftIO
#endif
----------------------------------------------------------------
runGhcMod' :: GhcModEnv
-> GhcModState
-> GhcMod a
-> IO (a,(GhcModState, GhcModWriter))
runGhcMod' r s a = do
(a', s',w) <- runRWST (unGhcMod $ initGhcMonad (Just libdir) >> a) r s
return (a',(s',w))
-- | Initialize the 'DynFlags' relating to the compilation of a single
-- file or GHC session according to the 'Cradle' and 'Options'
-- provided.
initializeFlagsWithCradle :: GhcMonad m
=> Options
-> Cradle
-> m ()
initializeFlagsWithCradle opt c
| cabal = withCabal |||> withSandbox
| otherwise = withSandbox
where
mCradleFile = cradleCabalFile c
cabal = isJust mCradleFile
ghcopts = ghcOpts opt
withCabal = do
pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile
compOpts <- liftIO $ getCompilerOptions ghcopts c pkgDesc
initSession CabalPkg opt compOpts
withSandbox = initSession SingleFile opt compOpts
where
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
pkgOpts = ghcDbStackOpts $ cradlePkgDbStack c
compOpts
| null pkgOpts = CompilerOptions ghcopts importDirs []
| otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []
wdir = cradleCurrentDir c
rdir = cradleRootDir c
runGhcMod :: Options -> GhcMod a -> IO a
runGhcMod opt action = do
session <- newIORef (error "empty session")
cradle <- findCradle
let env = GhcModEnv { gmGhcSession = session
, gmOptions = opt
, gmCradle = cradle }
(a,(_,_)) <- runGhcMod' env defaultState $ do
dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do
toGhcMod $ initializeFlagsWithCradle opt cradle
action
return a
initSession :: GhcMonad m
=> Build
-> Options
-> CompilerOptions
-> m ()
initSession build Options {..} CompilerOptions {..} = do
df <- G.getSessionDynFlags
void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions
$ setModeSimple
$ setIncludeDirs includeDirs
$ setBuildEnv build
$ setEmptyLogger
$ Gap.addPackageFlags depPackages df)
----------------------------------------------------------------
withErrorHandler :: String -> GhcMod a -> GhcMod a
newGhcModEnv :: Options -> FilePath -> IO GhcModEnv
newGhcModEnv opt dir = do
session <- newIORef (error "empty session")
c <- findCradle' dir
return GhcModEnv {
gmGhcSession = session
, gmOptions = opt
, gmCradle = c
}
-- | Run a @GhcModT m@ computation, i.e. one with a custom underlying monad.
--
-- You probably don't want this, look at 'runGhcMod' instead.
runGhcModT :: IOish m => Options -> GhcModT m a -> m a
runGhcModT opt action = do
env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
(a,(_,_)) <- runGhcModT' env defaultState $ do
dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do
initializeFlagsWithCradle opt (gmCradle env)
action
return a
-- | Run a computation inside @GhcModT@ providing the RWST environment and
-- initial state. This is a low level function, use it only if you know what to
-- do with 'GhcModEnv' and 'GhcModState'.
--
-- You should probably look at 'runGhcModT' instead.
runGhcModT' :: IOish m
=> GhcModEnv
-> GhcModState
-> GhcModT m a
-> m (a,(GhcModState, GhcModWriter))
runGhcModT' r s a = do
(a',s',w) <- runRWST (unGhcModT $ initGhcMonad (Just libdir) >> a) r s
return (a',(s',w))
-- | Run a 'GhcMod' computation. If you want an underlying monad other than
-- 'ErrorT e IO' you should look at 'runGhcModT'
runGhcMod :: Options
-> GhcMod a
-> IO (Either GhcModError a)
runGhcMod o a =
runErrorT $ runGhcModT o a
liftErrorT :: IOish m => GhcModT m a -> GhcModT (ErrorT GhcModError m) a
liftErrorT action =
GhcModT $ RWST $ \e s -> ErrorT $ Right <$> (runRWST $ unGhcModT action) e s
-- | Lift @(GhcModT IO)@ into @GhcMod@, which is an alias for @GhcModT (ErrorT
-- GhcModError IO)@.
liftGhcMod :: GhcModT IO a -> GhcMod a
liftGhcMod = liftErrorT
----------------------------------------------------------------
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
toGhcMod :: Ghc a -> GhcMod a
-- | This is only a transitional mechanism don't use it for new code.
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
instance MonadBase IO GhcMod where
liftBase = GhcMod . liftBase
cradle :: IOish m => GhcModT m Cradle
cradle = gmCradle <$> ask
instance MonadBaseControl IO GhcMod where
newtype StM GhcMod a = StGhcMod {
unStGhcMod :: StM (RWST GhcModEnv () GhcModState IO) a }
instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
liftBase = GhcModT . liftBase
liftBaseWith f = GhcMod . liftBaseWith $ \runInBase ->
f $ liftM StGhcMod . runInBase . unGhcMod
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
newtype StM (GhcModT m) a = StGhcMod {
unStGhcMod :: StM (RWST GhcModEnv GhcModWriter GhcModState m) a }
restoreM = GhcMod . restoreM . unStGhcMod
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
f $ liftM StGhcMod . runInBase . unGhcModT
restoreM = GhcModT . restoreM . unStGhcMod
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
instance GhcMonad GhcMod where
getSession = liftIO . readIORef . gmGhcSession =<< ask
setSession a = liftIO . flip writeIORef a . gmGhcSession =<< ask
-- GHC cannot prove the following instances to be decidable automatically using
-- the FlexibleContexts extension as they violate the second Paterson Condition,
-- namely that: The assertion has fewer constructors and variables (taken
-- together and counting repetitions) than the head. Specifically the
-- @MonadBaseControl IO m@ constraint is causing this violation.
--
-- Proof of termination:
--
-- Assuming all constraints containing the variable `m' exist and are decidable
-- we show termination by manually replacing the current set of constraints with
-- their own set of constraints and show that this, after a finite number of
-- steps, results in the empty set, i.e. not having to check any more
-- constraints.
--
-- We start by setting the constraints to be those immediate constraints of the
-- instance declaration which cannot be proven decidable automatically for the
-- type under consideration.
--
-- @
-- { MonadBaseControl IO m }
-- @
--
-- Classes used:
--
-- * @class MonadBase b m => MonadBaseControl b m@
--
-- @
-- { MonadBase IO m }
-- @
--
-- Classes used:
--
-- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@
--
-- @
-- { Applicative IO, Applicative m, Monad IO, Monad m }
-- @
--
-- Classes used:
--
-- * @class Monad m@
-- * @class Applicative f => Functor f@
--
-- @
-- { Functor m }
-- @
--
-- Classes used:
--
-- * @class Functor f@
--
-- @
-- { }
-- @
-- ∎
instance (Functor m, MonadIO m, MonadBaseControl IO m)
=> GhcMonad (GhcModT m) where
getSession = (liftIO . readIORef) . gmGhcSession =<< ask
setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask
#if __GLASGOW_HASKELL__ >= 706
instance HasDynFlags GhcMod where
instance (Functor m, MonadIO m, MonadBaseControl IO m)
=> HasDynFlags (GhcModT m) where
getDynFlags = getSessionDynFlags
#endif
instance ExceptionMonad GhcMod where
instance (MonadIO m, MonadBaseControl IO m)
=> ExceptionMonad (GhcModT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)

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

@ -1,30 +1,26 @@
module Language.Haskell.GhcMod.PkgDoc (packageDoc) where
module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where
import CoreMonad (liftIO)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Monad
import Control.Applicative ((<$>))
import System.Process (readProcess)
-- | Obtaining the package name and the doc path of a module.
packageDoc :: Options
-> Cradle
-> ModuleString
-> IO String
packageDoc _ cradle mdl = pkgDoc cradle mdl
pkgDoc :: Cradle -> String -> IO String
pkgDoc cradle mdl = do
pkg <- trim <$> readProcess "ghc-pkg" toModuleOpts []
pkgDoc :: IOish m => String -> GhcModT m String
pkgDoc mdl = cradle >>= \c -> liftIO $ do
pkg <- trim <$> readProcess "ghc-pkg" (toModuleOpts c) []
if pkg == "" then
return "\n"
else do
htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg) []
htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg c) []
let ret = pkg ++ " " ++ drop 14 htmlpath
return ret
where
toModuleOpts = ["find-module", mdl, "--simple-output"]
++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)
toDocDirOpts pkg = ["field", pkg, "haddock-html"]
++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)
toModuleOpts c = ["find-module", mdl, "--simple-output"]
++ ghcPkgDbStackOpts (cradlePkgDbStack c)
toDocDirOpts pkg c = ["field", pkg, "haddock-html"]
++ ghcPkgDbStackOpts (cradlePkgDbStack c)
trim = takeWhile (`notElem` " \n")

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

@ -13,7 +13,7 @@ import GhcMonad
import qualified GHC as G
import GHC.SYB.Utils (Stage(..), everythingStaged)
import Language.Haskell.GhcMod.Doc (showOneLine, getStyle)
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
import qualified Language.Haskell.GhcMod.Gap as Gap
import Outputable (PprStyle)

9
Language/Haskell/GhcMod/Types.hs
View File

@ -1,6 +1,9 @@
module Language.Haskell.GhcMod.Types where
import Data.List (intercalate)
import qualified Data.Map as M
import PackageConfig (PackageConfig)
-- | Output style.
data OutputStyle = LispStyle -- ^ S expression style.
@ -87,12 +90,18 @@ showPkg (n,v,_) = intercalate "-" [n,v]
showPkgId :: Package -> String
showPkgId (n,v,i) = intercalate "-" [n,v,i]
-- | Collection of packages
type PkgDb = (M.Map Package PackageConfig)
-- | Haskell expression.
type Expression = String
-- | Module name.
type ModuleString = String
-- | A Module
type Module = [String]
-- | Option information for GHC
data CompilerOptions = CompilerOptions {
ghcOptions :: [GHCOption] -- ^ Command line options

2
elisp/ghc-comp.el
View File

@ -168,7 +168,7 @@ unloaded modules are loaded")
(ghc-reset-window-configuration)
(ghc-save-window-configuration)
(with-output-to-temp-buffer ghc-completion-buffer-name
(display-completion-list list pattern))))))))
(display-completion-list list))))))))
(defun ghc-save-window-configuration ()
(unless (get-buffer-window ghc-completion-buffer-name)

11
elisp/ghc.el
View File

@ -28,7 +28,7 @@
(< emacs-minor-version minor)))
(error "ghc-mod requires at least Emacs %d.%d" major minor)))
(defconst ghc-version "4.1.0")
(defconst ghc-version "5.0.0")
;; (eval-when-compile
;; (require 'haskell-mode))
@ -121,13 +121,14 @@
(defun ghc-debug ()
(interactive)
(let ((el-path (locate-file "ghc.el" load-path))
(ghc-path (executable-find "ghc"))
(ghc-path (executable-find "ghc")) ;; FIXME
(ghc-mod-path (executable-find ghc-module-command))
(ghc-modi-path (executable-find ghc-interactive-command))
(el-ver ghc-version)
(ghc-ver (ghc-run-ghc-mod '("--version") "ghc"))
(ghc-mod-ver (ghc-run-ghc-mod '("version")))
(ghc-modi-ver (ghc-run-ghc-mod '("version") ghc-interactive-command)))
(ghc-modi-ver (ghc-run-ghc-mod '("version") ghc-interactive-command))
(path (getenv "PATH")))
(switch-to-buffer (get-buffer-create "**GHC Debug**"))
(erase-buffer)
(insert "Path: check if you are using intended programs.\n")
@ -139,6 +140,8 @@
(insert (format "\t ghc.el version %s\n" el-ver))
(insert (format "\t %s\n" ghc-mod-ver))
(insert (format "\t%s\n" ghc-modi-ver))
(insert (format "\t%s\n" ghc-ver))))
(insert (format "\t%s\n" ghc-ver))
(insert "\nEnvironment variables:\n")
(insert (format "\tPATH=%s\n" path))))
(provide 'ghc)

15
ghc-mod.cabal
View File

@ -1,5 +1,5 @@
Name: ghc-mod
Version: 4.1.0
Version: 5.0.0
Author: Kazu Yamamoto <kazu@iij.ad.jp>
Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>
License: BSD3
@ -51,6 +51,7 @@ Extra-Source-Files: ChangeLog
Library
Default-Language: Haskell2010
GHC-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
Exposed-Modules: Language.Haskell.GhcMod
Language.Haskell.GhcMod.Ghc
Language.Haskell.GhcMod.Monad
@ -67,6 +68,7 @@ Library
Language.Haskell.GhcMod.Convert
Language.Haskell.GhcMod.Debug
Language.Haskell.GhcMod.Doc
Language.Haskell.GhcMod.DynFlags
Language.Haskell.GhcMod.FillSig
Language.Haskell.GhcMod.Find
Language.Haskell.GhcMod.Flag
@ -100,7 +102,7 @@ Library
, time
, transformers
, transformers-base
, mtl
, mtl >= 2.0
, monad-control
, split
, haskell-src-exts
@ -116,10 +118,12 @@ Executable ghc-mod
Main-Is: GHCMod.hs
Other-Modules: Paths_ghc_mod
GHC-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src
Build-Depends: base >= 4.0 && < 5
, directory
, filepath
, mtl >= 2.0
, ghc
, ghc-mod
@ -128,6 +132,7 @@ Executable ghc-modi
Main-Is: GHCModi.hs
Other-Modules: Paths_ghc_mod
GHC-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src
Build-Depends: base >= 4.0 && < 5
, containers
@ -140,13 +145,15 @@ Test-Suite doctest
Type: exitcode-stdio-1.0
Default-Language: Haskell2010
HS-Source-Dirs: test
Ghc-Options: -threaded -Wall
Ghc-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
Main-Is: doctests.hs
Build-Depends: base
, doctest >= 0.9.3
Test-Suite spec
Default-Language: Haskell2010
Default-Extensions: ConstraintKinds, FlexibleContexts
Main-Is: Main.hs
Hs-Source-Dirs: test, .
Type: exitcode-stdio-1.0
@ -178,7 +185,7 @@ Test-Suite spec
, time
, transformers
, transformers-base
, mtl
, mtl >= 2.0
, monad-control
, hspec >= 1.8.2
, split

41
src/GHCMod.hs
View File

@ -5,6 +5,7 @@ module Main where
import Config (cProjectVersion)
import Control.Applicative ((<$>))
import Control.Exception (Exception, Handler(..), ErrorCall(..))
import CoreMonad (liftIO)
import qualified Control.Exception as E
import Data.Typeable (Typeable)
import Data.Version (showVersion)
@ -103,7 +104,6 @@ main = flip E.catches handlers $ do
-- #endif
args <- getArgs
let (opt,cmdArg) = parseArgs argspec args
cradle <- findCradle
let cmdArg0 = cmdArg !. 0
cmdArg1 = cmdArg !. 1
cmdArg3 = cmdArg !. 3
@ -113,24 +113,24 @@ main = flip E.catches handlers $ do
nArgs n f = if length remainingArgs == n
then f
else E.throw (ArgumentsMismatch cmdArg0)
res <- case cmdArg0 of
"list" -> listModules opt cradle
"lang" -> listLanguages opt
"flag" -> listFlags opt
"browse" -> runGhcMod opt $ concat <$> mapM browse remainingArgs
"check" -> runGhcMod opt $ checkSyntax 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)
"split" -> nArgs 4 $ splitVar opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
"sig" -> nArgs 4 $ fillSig opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
"refine" -> nArgs 5 $ refineVar opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5
"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
"boot" -> bootInfo opt
res <- runGhcModT opt $ case cmdArg0 of
"list" -> modules
"lang" -> languages
"flag" -> flags
"browse" -> concat <$> mapM browse remainingArgs
"check" -> checkSyntax remainingArgs
"expand" -> expandTemplate remainingArgs
"debug" -> debugInfo
"info" -> nArgs 3 info cmdArg1 cmdArg3
"type" -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4)
"split" -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4)
"sig" -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4)
--"refine" -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5
"find" -> nArgs 1 $ findSymbol cmdArg1
"lint" -> nArgs 1 $ withFile lint cmdArg1
"root" -> rootInfo
"doc" -> nArgs 1 $ pkgDoc cmdArg1
"boot" -> boot
"version" -> return progVersion
"help" -> return $ O.usageInfo usage argspec
cmd -> E.throw (NoSuchCommand cmd)
@ -155,8 +155,9 @@ main = flip E.catches handlers $ do
hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
printUsage
printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec
withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a
withFile cmd file = do
exist <- doesFileExist file
exist <- liftIO $ doesFileExist file
if exist
then cmd file
else E.throw (FileNotExist file)

92
src/GHCModi.hs
View File

@ -31,12 +31,12 @@ import Data.Set (Set)
import qualified Data.Set as S
import Data.Typeable (Typeable)
import Data.Version (showVersion)
import Exception (ghandle)
import GHC (GhcMonad)
import qualified GHC as G
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Ghc
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Internal
import Paths_ghc_mod
import System.Console.GetOpt
import System.Directory (setCurrentDirectory)
@ -98,12 +98,11 @@ main = E.handle cmdHandler $
go (opt,_) = E.handle someHandler $ do
cradle0 <- findCradle
let rootdir = cradleRootDir cradle0
cradle = cradle0 { cradleCurrentDir = rootdir }
-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
setCurrentDirectory rootdir
mvar <- liftIO newEmptyMVar
mlibdir <- getSystemLibDir
void $ forkIO $ setupDB cradle mlibdir opt mvar
run cradle mlibdir opt $ loop opt 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.
@ -117,36 +116,28 @@ replace (x:xs) = x : replace xs
----------------------------------------------------------------
run :: Cradle -> Maybe FilePath -> Options -> GhcMod a -> IO a
run _ _ opt body = runGhcMod opt $ do
dflags <- G.getSessionDynFlags
G.defaultCleanupHandler dflags body
----------------------------------------------------------------
setupDB :: Cradle -> Maybe FilePath -> Options -> MVar SymMdlDb -> IO ()
setupDB cradle mlibdir opt mvar = E.handle handler $ do
db <- run cradle mlibdir opt getSymMdlDb
putMVar mvar db
setupDB :: IOish m => MVar SymMdlDb -> GhcModT m ()
setupDB mvar = ghandle handler $ do
liftIO . putMVar mvar =<< getSymMdlDb
where
handler (SomeException _) = return () -- fixme: put emptyDb?
----------------------------------------------------------------
loop :: Options -> Set FilePath -> MVar SymMdlDb -> GhcMod ()
loop opt set mvar = do
loop :: IOish m => Set FilePath -> MVar SymMdlDb -> GhcModT m ()
loop set mvar = do
cmdArg <- liftIO getLine
let (cmd,arg') = break (== ' ') cmdArg
arg = dropWhile (== ' ') arg'
(ret,ok,set') <- case cmd of
"check" -> checkStx opt set arg
"check" -> checkStx set arg
"find" -> findSym set arg mvar
"lint" -> toGhcMod $ lintStx opt set arg
"lint" -> lintStx set arg
"info" -> showInfo set arg
"type" -> showType set arg
"split" -> doSplit set arg
"sig" -> doSig set arg
"refine" -> doRefine set arg
-- "refine" -> doRefine set arg
"boot" -> bootIt set
"browse" -> browseIt set arg
"quit" -> return ("quit", False, set)
@ -158,15 +149,15 @@ loop opt set mvar = do
else do
liftIO $ putStrLn $ "NG " ++ replace ret
liftIO $ hFlush stdout
when ok $ loop opt set' mvar
when ok $ loop set' mvar
----------------------------------------------------------------
checkStx :: Options
-> Set FilePath
checkStx :: IOish m
=> Set FilePath
-> FilePath
-> GhcMod (String, Bool, Set FilePath)
checkStx _ set file = do
-> GhcModT m (String, Bool, Set FilePath)
checkStx set file = do
set' <- toGhcMod $ newFileSet set file
let files = S.toList set'
eret <- check files
@ -202,24 +193,25 @@ 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 :: GhcMonad m
=> Options -> Set FilePath -> FilePath
-> m (String, Bool, Set FilePath)
lintStx opt set optFile = liftIO $ do
ret <-lintSyntax opt' file
lintStx :: IOish m => Set FilePath
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
lintStx set optFile = do
ret <- local env' $ lint file
return (ret, True, set)
where
(opts,file) = parseLintOptions optFile
hopts = if opts == "" then [] else read opts
opt' = opt { hlintOpts = hopts }
env' e = e { gmOptions = opt' $ gmOptions e }
opt' o = o { hlintOpts = hopts }
-- |
-- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"
@ -238,42 +230,47 @@ 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
ret <- sig file (read line) (read column)
return (ret, True, set')
{-
doRefine :: Set FilePath
-> FilePath
-> GhcMod (String, Bool, Set FilePath)
@ -282,18 +279,21 @@ doRefine set fileArg = do
set' <- newFileSet set file
ret <- rewrite file (read line) (read column) expr
return (ret, True, set')
-}
----------------------------------------------------------------
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)

14
test/BrowseSpec.hs
View File

@ -10,25 +10,25 @@ import Dir
spec :: Spec
spec = do
describe "browse" $ do
it "lists up symbols in the module" $ do
describe "browse Data.Map" $ do
it "contains at least `differenceWithKey'" $ do
syms <- runD $ lines <$> browse "Data.Map"
syms `shouldContain` ["differenceWithKey"]
describe "browse -d" $ do
it "lists up symbols with type info in the module" $ do
describe "browse -d Data.Either" $ do
it "contains functions (e.g. `either') including their type signature" $ do
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
it "contains type constructors (e.g. `Left') including their type signature" $ do
cradle <- findCradle
syms <- run defaultOptions { detailed = True}
$ lines <$> browse "Data.Either"
syms `shouldContain` ["Left :: a -> Either a b"]
describe "browse local" $ do
it "lists symbols in a local module" $ do
describe "`browse' in a project directory" $ do
it "lists symbols defined in a a local module (e.g. `Baz.baz)" $ do
withDirectory_ "test/data" $ do
syms <- runID $ lines <$> browse "Baz"
syms `shouldContain` ["baz"]

12
test/CheckSpec.hs
View File

@ -12,28 +12,28 @@ import Dir
spec :: Spec
spec = do
describe "checkSyntax" $ do
it "can check even if an executable depends on its library" $ do
it "works even if an executable depends on the library defined in the same cabal file" $ do
withDirectory_ "test/data/ghc-mod-check" $ do
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
it "works even if a module imports another module from a different directory" $ do
withDirectory_ "test/data/check-test-subdir" $ do
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
it "detects cyclic imports" $ do
withDirectory_ "test/data" $ do
res <- runID $ checkSyntax ["Mutual1.hs"]
res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)
it "can check a module using QuasiQuotes" $ do
it "works with modules using QuasiQuotes" $ do
withDirectory_ "test/data" $ do
res <- runID $ checkSyntax ["Baz.hs"]
res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)
context "without errors" $ do
it "doesn't output empty line" $ do
context "when no errors are found" $ do
it "doesn't output an empty line" $ do
withDirectory_ "test/data/ghc-mod-check/Data" $ do
res <- runID $ checkSyntax ["Foo.hs"]
res `shouldBe` ""

9
test/FlagSpec.hs
View File

@ -3,10 +3,11 @@ module FlagSpec where
import Control.Applicative
import Language.Haskell.GhcMod
import Test.Hspec
import TestUtils
spec :: Spec
spec = do
describe "listFlags" $ do
it "lists up GHC flags" $ do
flags <- lines <$> listFlags defaultOptions
flags `shouldContain` ["-fno-warn-orphans"]
describe "flags" $ do
it "contains at least `-fno-warn-orphans'" $ do
f <- runD $ lines <$> flags
f `shouldContain` ["-fno-warn-orphans"]

31
test/GhcApiSpec.hs Normal file
View File

@ -0,0 +1,31 @@
module GhcApiSpec where
import Control.Applicative
import Control.Monad
import Data.List (sort)
import Language.Haskell.GhcMod.GHCApi
import Test.Hspec
import TestUtils
import CoreMonad (liftIO)
import Dir
spec :: Spec
spec = do
describe "findModule" $ do
it "finds Data.List in `base' and `haskell2010'"
$ withDirectory_ "test/data" $ runD $ do
pkgs <- findModule "Data.List" <$> ghcPkgDb
let pkgNames = pkgName `map` pkgs
liftIO $ pkgNames `shouldContain` ["base", "haskell2010"]
describe "moduleInfo" $ do
it "works for modules from global packages (e.g. base:Data.List)"
$ withDirectory_ "test/data" $ runD $ do
Just info <- moduleInfo (Just ("base","","")) "Data.List"
liftIO $ sort (bindings info) `shouldContain` ["++"]
it "works for local modules"
$ withDirectory_ "test/data" $ runD $ do
Just info <- moduleInfo Nothing "Baz"
liftIO $ bindings info `shouldContain` ["baz"]

4
test/GhcPkgSpec.hs
View File

@ -18,10 +18,10 @@ spec = do
getPackageDbStack "test/data/" `shouldReturn` [GlobalDb, PackageDb $ cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]
#endif
it "parses a config file and extracts sandbox package db" $ do
it "can parse a config file and extract the sandbox package-db" $ do
cwd <- getCurrentDirectory
pkgDb <- getSandboxDb "test/data/"
pkgDb `shouldBe` (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")
it "throws an error if a config file is broken" $ do
it "throws an error if the sandbox config file is broken" $ do
getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException

18
test/InfoSpec.hs
View File

@ -14,47 +14,47 @@ import System.Exit
import System.FilePath
import System.Process
import Test.Hspec
import TestUtils
import Dir
spec :: Spec
spec = do
describe "typeExpr" $ do
describe "types" $ do
it "shows types of the expression and its outers" $ do
withDirectory_ "test/data/ghc-mod-check" $ do
cradle <- findCradleWithoutSandbox
res <- typeExpr defaultOptions cradle "Data/Foo.hs" 9 5
res <- runD $ types "Data/Foo.hs" 9 5
res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
it "works with a module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox
res <- typeExpr defaultOptions cradle "Bar.hs" 5 1
res <- runD $ types "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
it "works with a module that imports another module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox
res <- typeExpr defaultOptions cradle "Main.hs" 3 8
res <- runD $ types "Main.hs" 3 8
res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
describe "infoExpr" $ do
describe "info" $ do
it "works for non-export functions" $ do
withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox
res <- infoExpr defaultOptions cradle "Info.hs" "fib"
res <- runD $ info "Info.hs" "fib"
res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
it "works with a module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox
res <- infoExpr defaultOptions cradle "Bar.hs" "foo"
res <- runD $ info "Bar.hs" "foo"
res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
it "works with a module that imports another module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox
res <- infoExpr defaultOptions cradle "Main.hs" "bar"
res <- runD $ info "Main.hs" "bar"
res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
it "doesn't fail on unicode output" $ do

7
test/LangSpec.hs
View File

@ -3,10 +3,11 @@ module LangSpec where
import Control.Applicative
import Language.Haskell.GhcMod
import Test.Hspec
import TestUtils
spec :: Spec
spec = do
describe "listLanguages" $ do
it "lists up language extensions" $ do
exts <- lines <$> listLanguages defaultOptions
describe "languages" $ do
it "contains at lest `OverloadedStrings'" $ do
exts <- runD $ lines <$> languages
exts `shouldContain` ["OverloadedStrings"]

13
test/LintSpec.hs
View File

@ -2,15 +2,16 @@ module LintSpec where
import Language.Haskell.GhcMod
import Test.Hspec
import TestUtils
spec :: Spec
spec = do
describe "lintSyntax" $ do
it "check syntax with HLint" $ do
res <- lintSyntax defaultOptions "test/data/hlint.hs"
describe "lint" $ do
it "can detect a redundant import" $ do
res <- runD $ lint "test/data/hlint.hs"
res `shouldBe` "test/data/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
context "without suggestions" $ do
it "doesn't output empty line" $ do
res <- lintSyntax defaultOptions "test/data/ghc-mod-check/Data/Foo.hs"
context "when no suggestions are given" $ do
it "doesn't output an empty line" $ do
res <- runD $ lint "test/data/ghc-mod-check/Data/Foo.hs"
res `shouldBe` ""

8
test/ListSpec.hs
View File

@ -3,11 +3,11 @@ module ListSpec where
import Control.Applicative
import Language.Haskell.GhcMod
import Test.Hspec
import TestUtils
spec :: Spec
spec = do
describe "listModules" $ do
it "lists up module names" $ do
cradle <- findCradle
modules <- lines <$> listModules defaultOptions cradle
describe "modules" $ do
it "contains at least `Data.Map'" $ do
modules <- runD $ lines <$> modules
modules `shouldContain` ["Data.Map"]

3
test/Main.hs
View File

@ -7,6 +7,7 @@ import System.Process
import Language.Haskell.GhcMod (debugInfo, defaultOptions, findCradle)
import Control.Exception as E
import TestUtils
main = do
let sandboxes = [ "test/data", "test/data/check-packageid"
@ -25,7 +26,7 @@ main = do
putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal
system "ghc --version"
(putStrLn =<< debugInfo defaultOptions =<< findCradle)
(putStrLn =<< runD debugInfo)
`E.catch` (\(_ :: E.SomeException) -> return () )
hspec spec

12
test/TestUtils.hs
View File

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

2
test/data/Info.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted
module Info () where
fib :: Int -> Int

2
test/data/Mutual1.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted
module Mutual1 where
import Mutual2

1
test/doctests.hs
View File

@ -6,6 +6,7 @@ main :: IO ()
main = doctest [
"-package"
, "ghc"
, "-XConstraintKinds", "-XFlexibleContexts"
, "-idist/build/autogen/"
, "-optP-include"
, "-optPdist/build/autogen/cabal_macros.h"