Merge remote-tracking branch 'kazu/master'
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
commit
57bd408785
36
.travis.yml
36
.travis.yml
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 = [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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-"]
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
11
elisp/ghc.el
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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,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` ""
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
|
|
|||
|
|
@ -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` ""
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted
|
||||
|
||||
module Info () where
|
||||
|
||||
fib :: Int -> Int
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted
|
||||
|
||||
module Mutual1 where
|
||||
|
||||
import Mutual2
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ main :: IO ()
|
|||
main = doctest [
|
||||
"-package"
|
||||
, "ghc"
|
||||
, "-XConstraintKinds", "-XFlexibleContexts"
|
||||
, "-idist/build/autogen/"
|
||||
, "-optP-include"
|
||||
, "-optPdist/build/autogen/cabal_macros.h"
|
||||
|
|
|
|||
Loading…
Reference in New Issue