Merge remote-tracking branch 'upstream/no-set'
Conflicts: Language/Haskell/GhcMod/Find.hs
This commit is contained in:
Daniel Gröber
commit
ab7059d5e4
@ -46,6 +46,7 @@ module Language.Haskell.GhcMod (
|
||||
, dumpSymbol
|
||||
-- * SymbolDb
|
||||
, loadSymbolDb
|
||||
, isOutdated
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.Boot
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RecordWildCards, CPP #-}
|
||||
|
||||
-- | This module facilitates extracting information from Cabal's on-disk
|
||||
-- 'LocalBuildInfo' (@dist/setup-config@).
|
||||
@ -6,13 +6,17 @@ module Language.Haskell.GhcMod.CabalConfig (
|
||||
CabalConfig
|
||||
, cabalConfigDependencies
|
||||
, cabalConfigFlags
|
||||
, setupConfigFile
|
||||
, World
|
||||
, getCurrentWorld
|
||||
, isWorldChanged
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Language.Haskell.GhcMod.Read
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
|
||||
import qualified Language.Haskell.GhcMod.Cabal16 as C16
|
||||
import qualified Language.Haskell.GhcMod.Cabal18 as C18
|
||||
@ -23,7 +27,7 @@ import qualified Language.Haskell.GhcMod.Cabal21 as C21
|
||||
#endif
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad (mplus)
|
||||
import Control.Monad (unless, void, mplus)
|
||||
#if MIN_VERSION_mtl(2,2,1)
|
||||
import Control.Monad.Except ()
|
||||
#else
|
||||
@ -39,9 +43,17 @@ import Distribution.PackageDescription (FlagAssignment)
|
||||
import Distribution.Simple.BuildPaths (defaultDistPref)
|
||||
import Distribution.Simple.Configure (localBuildInfoFile)
|
||||
import Distribution.Simple.LocalBuildInfo (ComponentName)
|
||||
import Data.Traversable (traverse)
|
||||
import MonadUtils (liftIO)
|
||||
import System.Directory (doesFileExist, getModificationTime)
|
||||
import System.FilePath ((</>))
|
||||
|
||||
#if __GLASGOW_HASKELL__ <= 704
|
||||
import System.Time (ClockTime)
|
||||
#else
|
||||
import Data.Time (UTCTime)
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | 'Show'ed cabal 'LocalBuildInfo' string
|
||||
@ -53,20 +65,26 @@ type CabalConfig = String
|
||||
getConfig :: (IOish m, MonadError GhcModError m)
|
||||
=> Cradle
|
||||
-> m CabalConfig
|
||||
getConfig cradle = liftIO (readFile path) `tryFix` \_ ->
|
||||
getConfig cradle = do
|
||||
world <- liftIO $ getCurrentWorld cradle
|
||||
let valid = isSetupConfigValid world
|
||||
unless valid configure
|
||||
liftIO (readFile file) `tryFix` \_ ->
|
||||
configure `modifyError'` GMECabalConfigure
|
||||
where
|
||||
file = setupConfigFile cradle
|
||||
prjDir = cradleRootDir cradle
|
||||
path = prjDir </> configPath
|
||||
|
||||
configure :: (IOish m, MonadError GhcModError m) => m ()
|
||||
configure =
|
||||
withDirectory_ prjDir $ readProcess' "cabal" ["configure"] >> return ()
|
||||
configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
|
||||
|
||||
|
||||
setupConfigFile :: Cradle -> FilePath
|
||||
setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
|
||||
|
||||
-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
|
||||
configPath :: FilePath
|
||||
configPath = localBuildInfoFile defaultDistPref
|
||||
setupConfigPath :: FilePath
|
||||
setupConfigPath = localBuildInfoFile defaultDistPref
|
||||
|
||||
-- | Get list of 'Package's needed by all components of the current package
|
||||
cabalConfigDependencies :: (IOish m, MonadError GhcModError m)
|
||||
@ -175,3 +193,57 @@ extractField config field =
|
||||
case extractParens <$> find (field `isPrefixOf`) (tails config) of
|
||||
Just f -> Right f
|
||||
Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
#if __GLASGOW_HASKELL__ <= 704
|
||||
type ModTime = ClockTime
|
||||
#else
|
||||
type ModTime = UTCTime
|
||||
#endif
|
||||
|
||||
data World = World {
|
||||
worldCabalFile :: Maybe FilePath
|
||||
, worldCabalFileModificationTime :: Maybe ModTime
|
||||
, worldPackageCache :: FilePath
|
||||
, worldPackageCacheModificationTime :: ModTime
|
||||
, worldSetupConfig :: FilePath
|
||||
, worldSetupConfigModificationTime :: Maybe ModTime
|
||||
} deriving (Show, Eq)
|
||||
|
||||
getCurrentWorld :: Cradle -> IO World
|
||||
getCurrentWorld crdl = do
|
||||
cachePath <- getPackageCachePath crdl
|
||||
let mCabalFile = cradleCabalFile crdl
|
||||
pkgCache = cachePath </> packageCache
|
||||
setupFile = setupConfigFile crdl
|
||||
mCabalFileMTime <- getModificationTime `traverse` mCabalFile
|
||||
pkgCacheMTime <- getModificationTime pkgCache
|
||||
exist <- doesFileExist setupFile
|
||||
mSeetupMTime <- if exist then
|
||||
Just <$> getModificationTime setupFile
|
||||
else
|
||||
return Nothing
|
||||
return $ World {
|
||||
worldCabalFile = mCabalFile
|
||||
, worldCabalFileModificationTime = mCabalFileMTime
|
||||
, worldPackageCache = pkgCache
|
||||
, worldPackageCacheModificationTime = pkgCacheMTime
|
||||
, worldSetupConfig = setupFile
|
||||
, worldSetupConfigModificationTime = mSeetupMTime
|
||||
}
|
||||
|
||||
isWorldChanged :: World -> Cradle -> IO Bool
|
||||
isWorldChanged world crdl = do
|
||||
world' <- getCurrentWorld crdl
|
||||
return (world /= world')
|
||||
|
||||
isSetupConfigValid :: World -> Bool
|
||||
isSetupConfigValid World{ worldSetupConfigModificationTime = Nothing, ..} = False
|
||||
isSetupConfigValid World{ worldSetupConfigModificationTime = Just mt, ..} =
|
||||
cond1 && cond2
|
||||
where
|
||||
cond1 = case worldCabalFileModificationTime of
|
||||
Nothing -> True
|
||||
Just mtime -> mtime <= mt
|
||||
cond2 = worldPackageCacheModificationTime <= mt
|
||||
|
||||
@ -8,9 +8,8 @@ module Language.Haskell.GhcMod.Check (
|
||||
import Control.Applicative ((<$>))
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.Logger
|
||||
import Language.Haskell.GhcMod.Monad (IOish, GhcModT, overrideGhcUserOptions)
|
||||
import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
|
||||
import Language.Haskell.GhcMod.Target (setTargetFiles)
|
||||
|
||||
----------------------------------------------------------------
|
||||
@ -30,10 +29,15 @@ checkSyntax files = either id id <$> check files
|
||||
check :: IOish m
|
||||
=> [FilePath] -- ^ The target files.
|
||||
-> GhcModT m (Either String String)
|
||||
{-
|
||||
check fileNames = overrideGhcUserOptions $ \ghcOpts -> do
|
||||
withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
|
||||
_ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
|
||||
setTargetFiles fileNames
|
||||
-}
|
||||
check fileNames =
|
||||
withLogger (setAllWarningFlags . setNoMaxRelevantBindings) $
|
||||
setTargetFiles fileNames
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE CPP, BangPatterns #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Find
|
||||
#ifndef SPEC
|
||||
@ -10,28 +10,26 @@ module Language.Haskell.GhcMod.Find
|
||||
, dumpSymbol
|
||||
, findSymbol
|
||||
, lookupSym
|
||||
, isOutdated
|
||||
)
|
||||
#endif
|
||||
where
|
||||
|
||||
import Config (cProjectVersion,cTargetPlatformString)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad (when, void)
|
||||
import Control.Monad.Error.Class
|
||||
import Data.Function (on)
|
||||
import Data.List (groupBy, sort)
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import DynFlags (DynFlags(..), systemPackageConfig)
|
||||
import Exception (handleIO)
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Name (getOccString)
|
||||
import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime)
|
||||
import System.FilePath ((</>))
|
||||
import System.Directory (doesFileExist, getModificationTime)
|
||||
import System.FilePath ((</>), takeDirectory)
|
||||
import System.IO
|
||||
|
||||
#ifndef MIN_VERSION_containers
|
||||
@ -51,8 +49,14 @@ import qualified Data.Map as M
|
||||
-- | Type of function and operation names.
|
||||
type Symbol = String
|
||||
-- | Database from 'Symbol' to \['ModuleString'\].
|
||||
newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])
|
||||
deriving (Show)
|
||||
data SymbolDb = SymbolDb {
|
||||
table :: Map Symbol [ModuleString]
|
||||
, packageCachePath :: FilePath
|
||||
, symbolDbCachePath :: FilePath
|
||||
} deriving (Show)
|
||||
|
||||
isOutdated :: SymbolDb -> IO Bool
|
||||
isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -65,12 +69,6 @@ symbolCacheVersion = 0
|
||||
symbolCache :: String
|
||||
symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"
|
||||
|
||||
packageCache :: String
|
||||
packageCache = "package.cache"
|
||||
|
||||
packageConfDir :: String
|
||||
packageConfDir = "package.conf.d"
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
|
||||
@ -84,19 +82,21 @@ lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
|
||||
lookupSymbol sym db = convert' $ lookupSym sym db
|
||||
|
||||
lookupSym :: Symbol -> SymbolDb -> [ModuleString]
|
||||
lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db
|
||||
lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
|
||||
|
||||
---------------------------------------------------------------
|
||||
|
||||
-- | Loading a file and creates 'SymbolDb'.
|
||||
loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb
|
||||
loadSymbolDb = SymbolDb <$> readSymbolDb
|
||||
|
||||
readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString])
|
||||
readSymbolDb = do
|
||||
loadSymbolDb = do
|
||||
ghcMod <- liftIO ghcModExecutable
|
||||
file <- chop <$> readProcess' ghcMod ["dumpsym"]
|
||||
M.fromAscList . map conv . lines <$> liftIO (readFile file)
|
||||
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
|
||||
return $ SymbolDb {
|
||||
table = db
|
||||
, packageCachePath = takeDirectory file </> packageCache
|
||||
, symbolDbCachePath = file
|
||||
}
|
||||
where
|
||||
conv :: String -> (Symbol,[ModuleString])
|
||||
conv = read
|
||||
@ -106,24 +106,18 @@ readSymbolDb = do
|
||||
----------------------------------------------------------------
|
||||
-- used 'ghc-mod dumpsym'
|
||||
|
||||
getSymbolCachePath :: IOish m => GhcModT m FilePath
|
||||
getSymbolCachePath = do
|
||||
u:_ <- filter (/= GlobalDb) . cradlePkgDbStack <$> cradle
|
||||
Just db <- (liftIO . flip resolvePackageDb u) =<< G.getSessionDynFlags
|
||||
return db
|
||||
`catchError` const (fail "Couldn't find non-global package database for symbol cache")
|
||||
|
||||
-- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file
|
||||
-- if the file does not exist or is invalid.
|
||||
-- The file name is printed.
|
||||
|
||||
dumpSymbol :: IOish m => GhcModT m String
|
||||
dumpSymbol = do
|
||||
dir <- getSymbolCachePath
|
||||
crdl <- cradle
|
||||
dir <- liftIO $ getPackageCachePath crdl
|
||||
let cache = dir </> symbolCache
|
||||
pkgdb = dir </> packageCache
|
||||
|
||||
create <- liftIO $ cache `isNewerThan` pkgdb
|
||||
create <- liftIO $ cache `isOlderThan` pkgdb
|
||||
when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
|
||||
return $ unlines [cache]
|
||||
|
||||
@ -134,15 +128,15 @@ writeSymbolCache cache sm =
|
||||
void . withFile cache WriteMode $ \hdl ->
|
||||
mapM (hPrint hdl) sm
|
||||
|
||||
isNewerThan :: FilePath -> FilePath -> IO Bool
|
||||
isNewerThan ref file = do
|
||||
exist <- doesFileExist ref
|
||||
isOlderThan :: FilePath -> FilePath -> IO Bool
|
||||
isOlderThan cache file = do
|
||||
exist <- doesFileExist cache
|
||||
if not exist then
|
||||
return True
|
||||
else do
|
||||
tRef <- getModificationTime ref
|
||||
tCache <- getModificationTime cache
|
||||
tFile <- getModificationTime file
|
||||
return $ tRef <= tFile -- including equal just in case
|
||||
return $ tCache <= tFile -- including equal just in case
|
||||
|
||||
-- | Browsing all functions in all system/user modules.
|
||||
getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]
|
||||
@ -171,16 +165,3 @@ collectModules :: [(Symbol,ModuleString)]
|
||||
collectModules = map tieup . groupBy ((==) `on` fst) . sort
|
||||
where
|
||||
tieup x = (head (map fst x), map snd x)
|
||||
|
||||
--- Copied from ghc module `Packages' unfortunately it's not exported :/
|
||||
resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath)
|
||||
resolvePackageDb df GlobalDb = return $ Just (systemPackageConfig df)
|
||||
resolvePackageDb _ (PackageDb name) = return $ Just name
|
||||
resolvePackageDb _ UserDb = handleIO (\_ -> return Nothing) $ do
|
||||
appdir <- getAppUserDataDirectory "ghc"
|
||||
let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
|
||||
pkgconf = dir </> packageConfDir
|
||||
exist <- doesDirectoryExist pkgconf
|
||||
return $ if exist then Just pkgconf else Nothing
|
||||
where
|
||||
[target_arch,_,target_os] = splitOn "-" cTargetPlatformString
|
||||
|
||||
@ -8,9 +8,12 @@ module Language.Haskell.GhcMod.GhcPkg (
|
||||
, fromInstalledPackageId'
|
||||
, getSandboxDb
|
||||
, getPackageDbStack
|
||||
, getPackageCachePath
|
||||
, packageCache
|
||||
, packageConfDir
|
||||
) where
|
||||
|
||||
import Config (cProjectVersionInt)
|
||||
import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Exception (SomeException(..))
|
||||
import qualified Control.Exception as E
|
||||
@ -18,8 +21,10 @@ import Data.Char (isSpace)
|
||||
import Data.List (isPrefixOf, intercalate)
|
||||
import Data.List.Split (splitOn)
|
||||
import Distribution.Package (InstalledPackageId(..))
|
||||
import Exception (handleIO)
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
|
||||
import System.FilePath ((</>))
|
||||
|
||||
ghcVersion :: Int
|
||||
@ -46,6 +51,8 @@ getSandboxDbDir sconf = do
|
||||
parse = head . filter (key `isPrefixOf`) . lines
|
||||
extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
getPackageDbStack :: FilePath -- ^ Project Directory (where the
|
||||
-- cabal.sandbox.config file would be if it
|
||||
-- exists)
|
||||
@ -54,6 +61,8 @@ getPackageDbStack cdir =
|
||||
(getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])
|
||||
`E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
fromInstalledPackageId' :: InstalledPackageId -> Maybe Package
|
||||
fromInstalledPackageId' pid = let
|
||||
InstalledPackageId pkg = pid
|
||||
@ -68,6 +77,8 @@ fromInstalledPackageId pid =
|
||||
Nothing -> error $
|
||||
"fromInstalledPackageId: `"++show pid++"' is not a valid package-id"
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Get options needed to add a list of package dbs to ghc-pkg's db stack
|
||||
ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
|
||||
-> [String]
|
||||
@ -78,6 +89,8 @@ ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
|
||||
-> [String]
|
||||
ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
ghcPkgDbOpt :: GhcPkgDb -> [String]
|
||||
ghcPkgDbOpt GlobalDb = ["--global"]
|
||||
ghcPkgDbOpt UserDb = ["--user"]
|
||||
@ -95,3 +108,31 @@ ghcDbOpt UserDb
|
||||
ghcDbOpt (PackageDb pkgDb)
|
||||
| ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]
|
||||
| otherwise = ["-no-user-package-db", "-package-db", pkgDb]
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
packageCache :: String
|
||||
packageCache = "package.cache"
|
||||
|
||||
packageConfDir :: String
|
||||
packageConfDir = "package.conf.d"
|
||||
|
||||
-- fixme: error handling
|
||||
getPackageCachePath :: Cradle -> IO FilePath
|
||||
getPackageCachePath crdl = do
|
||||
let u:_ = filter (/= GlobalDb) $ cradlePkgDbStack crdl
|
||||
Just db <- resolvePath u
|
||||
return db
|
||||
|
||||
--- Copied from ghc module `Packages' unfortunately it's not exported :/
|
||||
resolvePath :: GhcPkgDb -> IO (Maybe FilePath)
|
||||
resolvePath (PackageDb name) = return $ Just name
|
||||
resolvePath UserDb = handleIO (\_ -> return Nothing) $ do
|
||||
appdir <- getAppUserDataDirectory "ghc"
|
||||
let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
|
||||
pkgconf = dir </> packageConfDir
|
||||
exist <- doesDirectoryExist pkgconf
|
||||
return $ if exist then Just pkgconf else Nothing
|
||||
where
|
||||
[target_arch,_,target_os] = splitOn "-" cTargetPlatformString
|
||||
resolvePath _ = error "GlobalDb cannot be used in resolvePath"
|
||||
|
||||
@ -49,11 +49,16 @@ module Language.Haskell.GhcMod.Internal (
|
||||
, (||>)
|
||||
, goNext
|
||||
, runAnyOne
|
||||
-- * World
|
||||
, World
|
||||
, getCurrentWorld
|
||||
, isWorldChanged
|
||||
) where
|
||||
|
||||
import GHC.Paths (libdir)
|
||||
|
||||
import Language.Haskell.GhcMod.CabalApi
|
||||
import Language.Haskell.GhcMod.CabalConfig
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.GHCChoice
|
||||
|
||||
@ -200,11 +200,11 @@ initializeFlagsWithCradle opt c
|
||||
| cabal = withCabal
|
||||
| otherwise = withSandbox
|
||||
where
|
||||
mCradleFile = cradleCabalFile c
|
||||
cabal = isJust mCradleFile
|
||||
mCabalFile = cradleCabalFile c
|
||||
cabal = isJust mCabalFile
|
||||
ghcopts = ghcUserOptions opt
|
||||
withCabal = do
|
||||
pkgDesc <- parseCabalFile c $ fromJust mCradleFile
|
||||
pkgDesc <- parseCabalFile c $ fromJust mCabalFile
|
||||
compOpts <- getCompilerOptions ghcopts c pkgDesc
|
||||
initSession CabalPkg opt compOpts
|
||||
withSandbox = initSession SingleFile opt compOpts
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Language.Haskell.GhcMod.Utils where
|
||||
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import MonadUtils (MonadIO, liftIO)
|
||||
import System.Directory (getCurrentDirectory, setCurrentDirectory)
|
||||
@ -9,6 +9,7 @@ import System.Exit (ExitCode(..))
|
||||
import System.Process (readProcessWithExitCode)
|
||||
#ifndef SPEC
|
||||
import System.Environment
|
||||
import System.FilePath ((</>), takeDirectory)
|
||||
#endif
|
||||
|
||||
-- dropWhileEnd is not provided prior to base 4.5.0.0.
|
||||
@ -51,15 +52,18 @@ withDirectory_ dir action =
|
||||
-- this is a guess but >=7.6 uses 'getExecutablePath'.
|
||||
ghcModExecutable :: IO FilePath
|
||||
#ifndef SPEC
|
||||
ghcModExecutable = getExecutable'
|
||||
ghcModExecutable = do
|
||||
dir <- getExecutablePath'
|
||||
return $ dir </> "ghc-mod"
|
||||
#else
|
||||
ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when
|
||||
-- compiling spec
|
||||
return "dist/build/ghc-mod/ghc-mod"
|
||||
#endif
|
||||
where
|
||||
getExecutable' :: IO FilePath
|
||||
getExecutablePath' :: IO FilePath
|
||||
# if __GLASGOW_HASKELL__ >= 706
|
||||
getExecutable' = getExecutablePath
|
||||
getExecutablePath' = takeDirectory <$> getExecutablePath
|
||||
# else
|
||||
getExecutable' = getProgName
|
||||
# endif
|
||||
|
||||
#else
|
||||
ghcModExecutable = return "dist/build/ghc-mod/ghc-mod"
|
||||
getExecutablePath' = return ""
|
||||
# endif
|
||||
|
||||
@ -86,8 +86,8 @@ Library
|
||||
Language.Haskell.GhcMod.Lang
|
||||
Language.Haskell.GhcMod.Lint
|
||||
Language.Haskell.GhcMod.Logger
|
||||
Language.Haskell.GhcMod.Monad
|
||||
Language.Haskell.GhcMod.Modules
|
||||
Language.Haskell.GhcMod.Monad
|
||||
Language.Haskell.GhcMod.PkgDoc
|
||||
Language.Haskell.GhcMod.Read
|
||||
Language.Haskell.GhcMod.SrcUtils
|
||||
@ -148,8 +148,11 @@ Executable ghc-modi
|
||||
Default-Language: Haskell2010
|
||||
Main-Is: GHCModi.hs
|
||||
Other-Modules: Paths_ghc_mod
|
||||
Misc
|
||||
Utils
|
||||
GHC-Options: -Wall -threaded
|
||||
if os(windows)
|
||||
Cpp-Options: -DWINDOWS
|
||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||
HS-Source-Dirs: src
|
||||
Build-Depends: base >= 4.0 && < 5
|
||||
@ -157,7 +160,10 @@ Executable ghc-modi
|
||||
, containers
|
||||
, directory
|
||||
, filepath
|
||||
, old-time
|
||||
, process
|
||||
, split
|
||||
, time
|
||||
, ghc
|
||||
, ghc-mod
|
||||
|
||||
|
||||
223
src/GHCModi.hs
223
src/GHCModi.hs
@ -20,36 +20,27 @@ module Main where
|
||||
|
||||
import Config (cProjectVersion)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Concurrent.Async (Async, async, wait)
|
||||
import Control.Exception (SomeException(..), Exception)
|
||||
import Control.Exception (SomeException(..))
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad (when)
|
||||
import CoreMonad (liftIO)
|
||||
import Data.List (find, intercalate)
|
||||
import Data.List (intercalate)
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Version (showVersion)
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod
|
||||
import Language.Haskell.GhcMod.Internal
|
||||
import Paths_ghc_mod
|
||||
import System.Console.GetOpt
|
||||
import System.Directory (setCurrentDirectory)
|
||||
import System.Environment (getArgs)
|
||||
import System.IO (hFlush,stdout)
|
||||
import System.Exit (ExitCode, exitFailure)
|
||||
import System.IO (hFlush,stdout)
|
||||
|
||||
import Misc
|
||||
import Utils
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
type Logger = IO String
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
progVersion :: String
|
||||
progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
|
||||
|
||||
@ -79,13 +70,6 @@ parseArgs spec argv
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data GHCModiError = CmdArg [String]
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance Exception GHCModiError
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- Running two GHC monad threads disables the handling of
|
||||
-- C-c since installSignalHandlers is called twice, sigh.
|
||||
|
||||
@ -96,14 +80,21 @@ main = E.handle cmdHandler $
|
||||
cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
|
||||
go (_,"help":_) = putStr $ usageInfo usage argspec
|
||||
go (_,"version":_) = putStr progVersion
|
||||
go (opt,_) = flip E.catches handlers $ do
|
||||
go (opt,_) = emptyNewUnGetLine >>= run opt
|
||||
|
||||
run :: Options -> UnGetLine -> IO ()
|
||||
run opt ref = flip E.catches handlers $ do
|
||||
cradle0 <- findCradle
|
||||
let rootdir = cradleRootDir cradle0
|
||||
-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
|
||||
setCurrentDirectory rootdir
|
||||
symDb <- async $ runGhcModT opt loadSymbolDb
|
||||
(res, _) <- runGhcModT opt $ loop S.empty symDb
|
||||
|
||||
prepareAutogen cradle0
|
||||
-- Asynchronous db loading starts here.
|
||||
symdbreq <- newSymDbReq opt
|
||||
(res, _) <- runGhcModT opt $ do
|
||||
crdl <- cradle
|
||||
world <- liftIO $ getCurrentWorld crdl
|
||||
loop symdbreq ref world
|
||||
case res of
|
||||
Right () -> return ()
|
||||
Left (GMECabalConfigure msg) -> do
|
||||
@ -114,6 +105,7 @@ main = E.handle cmdHandler $
|
||||
-- this is just in case.
|
||||
-- If an error is caught here, it is a bug of GhcMod library.
|
||||
handlers = [ E.Handler (\(_ :: ExitCode) -> return ())
|
||||
, E.Handler (\(_ :: Restart) -> run opt ref)
|
||||
, E.Handler (\(SomeException e) -> bug $ show e) ]
|
||||
|
||||
bug :: String -> IO ()
|
||||
@ -132,91 +124,63 @@ replace needle replacement = intercalate replacement . splitOn needle
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
loop :: IOish m => Set FilePath -> SymDbReq -> GhcModT m ()
|
||||
loop set symDbReq = do
|
||||
cmdArg <- liftIO getLine
|
||||
loop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m ()
|
||||
loop symdbreq ref world = do
|
||||
-- blocking
|
||||
cmdArg <- liftIO $ getCommand ref
|
||||
-- after blocking, we need to see if the world has changed.
|
||||
crdl <- cradle
|
||||
changed <- liftIO $ isWorldChanged world crdl
|
||||
when changed $ do
|
||||
liftIO $ ungetCommand ref cmdArg
|
||||
E.throw Restart
|
||||
cradle >>= liftIO . prepareAutogen
|
||||
let (cmd,arg') = break (== ' ') cmdArg
|
||||
arg = dropWhile (== ' ') arg'
|
||||
(ret,ok,set') <- case cmd of
|
||||
"check" -> checkStx set arg
|
||||
"find" -> findSym set arg symDbReq
|
||||
"lint" -> lintStx set arg
|
||||
"info" -> showInfo set arg
|
||||
"type" -> showType set arg
|
||||
"split" -> doSplit set arg
|
||||
"sig" -> doSig set arg
|
||||
"refine" -> doRefine set arg
|
||||
"auto" -> doAuto set arg
|
||||
"boot" -> bootIt set
|
||||
"browse" -> browseIt set arg
|
||||
"quit" -> return ("quit", False, set)
|
||||
"" -> return ("quit", False, set)
|
||||
_ -> return ([], True, set)
|
||||
(ret,ok) <- case cmd of
|
||||
"check" -> checkStx arg
|
||||
"find" -> findSym arg symdbreq
|
||||
"lint" -> lintStx arg
|
||||
"info" -> showInfo arg
|
||||
"type" -> showType arg
|
||||
"split" -> doSplit arg
|
||||
"sig" -> doSig arg
|
||||
"refine" -> doRefine arg
|
||||
"auto" -> doAuto arg
|
||||
"boot" -> bootIt
|
||||
"browse" -> browseIt arg
|
||||
"quit" -> return ("quit", False)
|
||||
"" -> return ("quit", False)
|
||||
_ -> return ([], True)
|
||||
if ok then do
|
||||
liftIO $ putStr ret
|
||||
liftIO $ putStrLn "OK"
|
||||
else do
|
||||
liftIO $ putStrLn $ notGood ret
|
||||
liftIO $ hFlush stdout
|
||||
when ok $ loop set' symDbReq
|
||||
when ok $ loop symdbreq ref world
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
checkStx :: IOish m
|
||||
=> Set FilePath
|
||||
-> FilePath
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
checkStx set file = do
|
||||
set' <- newFileSet set file
|
||||
let files = S.toList set'
|
||||
eret <- check files
|
||||
checkStx :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
checkStx file = do
|
||||
eret <- check [file]
|
||||
case eret of
|
||||
Right ret -> return (ret, True, set')
|
||||
Left ret -> return (ret, True, set) -- fxime: set
|
||||
|
||||
newFileSet :: IOish m => Set FilePath -> FilePath -> GhcModT m (Set FilePath)
|
||||
newFileSet set file = do
|
||||
let set1
|
||||
| S.member file set = set
|
||||
| otherwise = S.insert file set
|
||||
mx <- isSameMainFile file <$> getModSummaryForMain
|
||||
return $ case mx of
|
||||
Nothing -> set1
|
||||
Just mainfile -> S.delete mainfile set1
|
||||
|
||||
getModSummaryForMain :: IOish m => GhcModT m (Maybe G.ModSummary)
|
||||
getModSummaryForMain = find isMain <$> G.getModuleGraph
|
||||
where
|
||||
isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"
|
||||
|
||||
isSameMainFile :: FilePath -> (Maybe G.ModSummary) -> Maybe FilePath
|
||||
isSameMainFile _ Nothing = Nothing
|
||||
isSameMainFile file (Just x)
|
||||
| mainfile == file = Nothing
|
||||
| otherwise = Just mainfile
|
||||
where
|
||||
mmainfile = G.ml_hs_file (G.ms_location x)
|
||||
-- G.ms_hspp_file x is a temporary file with CPP.
|
||||
-- this is a just fake.
|
||||
mainfile = fromMaybe (G.ms_hspp_file x) mmainfile
|
||||
Right ret -> return (ret, True)
|
||||
Left ret -> return (ret, True)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
type SymDbReq = Async (Either GhcModError SymbolDb, GhcModLog)
|
||||
|
||||
findSym :: IOish m => Set FilePath -> String -> SymDbReq
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
findSym set sym dbReq = do
|
||||
db <- hoistGhcModT =<< liftIO (wait dbReq)
|
||||
findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
|
||||
findSym sym symdbreq = do
|
||||
db <- getDb symdbreq >>= checkDb symdbreq
|
||||
ret <- lookupSymbol sym db
|
||||
return (ret, True, set)
|
||||
return (ret, True)
|
||||
|
||||
lintStx :: IOish m => Set FilePath
|
||||
-> FilePath
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
lintStx set optFile = do
|
||||
lintStx :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
lintStx optFile = do
|
||||
ret <- withOptions changeOpt $ lint file
|
||||
return (ret, True, set)
|
||||
return (ret, True)
|
||||
where
|
||||
(opts,file) = parseLintOptions optFile
|
||||
hopts = if opts == "" then [] else read opts
|
||||
@ -239,85 +203,56 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
showInfo :: IOish m
|
||||
=> Set FilePath
|
||||
-> FilePath
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
showInfo set fileArg = do
|
||||
showInfo :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
showInfo fileArg = do
|
||||
let [file, expr] = splitN 2 fileArg
|
||||
set' <- newFileSet set file
|
||||
ret <- info file expr
|
||||
return (ret, True, set')
|
||||
return (ret, True)
|
||||
|
||||
showType :: IOish m
|
||||
=> Set FilePath
|
||||
-> FilePath
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
showType set fileArg = do
|
||||
showType :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
showType fileArg = do
|
||||
let [file, line, column] = splitN 3 fileArg
|
||||
set' <- newFileSet set file
|
||||
ret <- types file (read line) (read column)
|
||||
return (ret, True, set')
|
||||
return (ret, True)
|
||||
|
||||
doSplit :: IOish m
|
||||
=> Set FilePath
|
||||
-> FilePath
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
doSplit set fileArg = do
|
||||
doSplit :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
doSplit fileArg = do
|
||||
let [file, line, column] = splitN 3 fileArg
|
||||
set' <- newFileSet set file
|
||||
ret <- splits file (read line) (read column)
|
||||
return (ret, True, set')
|
||||
return (ret, True)
|
||||
|
||||
doSig :: IOish m
|
||||
=> Set FilePath
|
||||
-> FilePath
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
doSig set fileArg = do
|
||||
doSig :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
doSig fileArg = do
|
||||
let [file, line, column] = splitN 3 fileArg
|
||||
set' <- newFileSet set file
|
||||
ret <- sig file (read line) (read column)
|
||||
return (ret, True, set')
|
||||
return (ret, True)
|
||||
|
||||
doRefine :: IOish m
|
||||
=> Set FilePath
|
||||
-> FilePath
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
doRefine set fileArg = do
|
||||
doRefine :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
doRefine fileArg = do
|
||||
let [file, line, column, expr] = splitN 4 fileArg
|
||||
set' <- newFileSet set file
|
||||
ret <- refine file (read line) (read column) expr
|
||||
return (ret, True, set')
|
||||
return (ret, True)
|
||||
|
||||
doAuto :: IOish m
|
||||
=> Set FilePath
|
||||
-> FilePath
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
doAuto set fileArg = do
|
||||
doAuto :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
doAuto fileArg = do
|
||||
let [file, line, column] = splitN 3 fileArg
|
||||
set' <- newFileSet set file
|
||||
ret <- auto file (read line) (read column)
|
||||
return (ret, True, set')
|
||||
return (ret, True)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
bootIt :: IOish m
|
||||
=> Set FilePath
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
bootIt set = do
|
||||
bootIt :: IOish m => GhcModT m (String, Bool)
|
||||
bootIt = do
|
||||
ret <- boot
|
||||
return (ret, True, set)
|
||||
return (ret, True)
|
||||
|
||||
browseIt :: IOish m
|
||||
=> Set FilePath
|
||||
-> ModuleString
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
browseIt set mdl = do
|
||||
browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool)
|
||||
browseIt mdl = do
|
||||
let (det,rest') = break (== ' ') mdl
|
||||
rest = dropWhile (== ' ') rest'
|
||||
ret <- if det == "-d"
|
||||
then withOptions setDetailed (browse rest)
|
||||
else browse mdl
|
||||
return (ret, True, set)
|
||||
return (ret, True)
|
||||
where
|
||||
setDetailed opt = opt { detailed = True }
|
||||
|
||||
154
src/Misc.hs
Normal file
154
src/Misc.hs
Normal file
@ -0,0 +1,154 @@
|
||||
{-# LANGUAGE DeriveDataTypeable, CPP #-}
|
||||
|
||||
module Misc (
|
||||
GHCModiError(..)
|
||||
, Restart(..)
|
||||
, UnGetLine
|
||||
, emptyNewUnGetLine
|
||||
, ungetCommand
|
||||
, getCommand
|
||||
, SymDbReq
|
||||
, newSymDbReq
|
||||
, getDb
|
||||
, checkDb
|
||||
, prepareAutogen
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (Async, async, wait)
|
||||
import Control.Exception (Exception)
|
||||
import Control.Monad (unless, when)
|
||||
import CoreMonad (liftIO)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Typeable (Typeable)
|
||||
import System.Directory (doesDirectoryExist, getDirectoryContents)
|
||||
import System.IO (openBinaryFile, IOMode(..))
|
||||
import System.Process
|
||||
|
||||
import Language.Haskell.GhcMod
|
||||
import Language.Haskell.GhcMod.Internal
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data GHCModiError = CmdArg [String] deriving (Show, Typeable)
|
||||
|
||||
instance Exception GHCModiError
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data Restart = Restart deriving (Show, Typeable)
|
||||
|
||||
instance Exception Restart
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
newtype UnGetLine = UnGetLine (IORef (Maybe String))
|
||||
|
||||
emptyNewUnGetLine :: IO UnGetLine
|
||||
emptyNewUnGetLine = UnGetLine <$> newIORef Nothing
|
||||
|
||||
ungetCommand :: UnGetLine -> String -> IO ()
|
||||
ungetCommand (UnGetLine ref) cmd = writeIORef ref (Just cmd)
|
||||
|
||||
getCommand :: UnGetLine -> IO String
|
||||
getCommand (UnGetLine ref) = do
|
||||
mcmd <- readIORef ref
|
||||
case mcmd of
|
||||
Nothing -> getLine
|
||||
Just cmd -> do
|
||||
writeIORef ref Nothing
|
||||
return cmd
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
|
||||
data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
|
||||
|
||||
newSymDbReq :: Options -> IO SymDbReq
|
||||
newSymDbReq opt = do
|
||||
let act = runGhcModT opt loadSymbolDb
|
||||
req <- async act
|
||||
ref <- newIORef req
|
||||
return $ SymDbReq ref act
|
||||
|
||||
getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb
|
||||
getDb (SymDbReq ref _) = do
|
||||
req <- liftIO $ readIORef ref
|
||||
-- 'wait' really waits for the asynchronous action at the fist time.
|
||||
-- Then it reads a cached value from the second time.
|
||||
hoistGhcModT =<< liftIO (wait req)
|
||||
|
||||
checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb
|
||||
checkDb (SymDbReq ref act) db = do
|
||||
outdated <- liftIO $ isOutdated db
|
||||
if outdated then do
|
||||
-- async and wait here is unnecessary because this is essentially
|
||||
-- synchronous. But Async can be used a cache.
|
||||
req <- liftIO $ async act
|
||||
liftIO $ writeIORef ref req
|
||||
hoistGhcModT =<< liftIO (wait req)
|
||||
else
|
||||
return db
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
build :: IO ProcessHandle
|
||||
build = do
|
||||
#ifdef WINDOWS
|
||||
nul <- openBinaryFile "NUL" AppendMode
|
||||
#else
|
||||
nul <- openBinaryFile "/dev/null" AppendMode
|
||||
#endif
|
||||
(_, _, _, hdl) <- createProcess $ pro nul
|
||||
return hdl
|
||||
where
|
||||
pro nul = CreateProcess {
|
||||
cmdspec = RawCommand "cabal" ["build"]
|
||||
, cwd = Nothing
|
||||
, env = Nothing
|
||||
, std_in = Inherit
|
||||
, std_out = UseHandle nul
|
||||
, std_err = UseHandle nul
|
||||
, close_fds = False
|
||||
#if __GLASGOW_HASKELL__ >= 702
|
||||
, create_group = True
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 707
|
||||
, delegate_ctlc = False
|
||||
#endif
|
||||
}
|
||||
|
||||
autogen :: String
|
||||
autogen = "dist/build/autogen"
|
||||
|
||||
isAutogenPrepared :: IO Bool
|
||||
isAutogenPrepared = do
|
||||
exist <- doesDirectoryExist autogen
|
||||
if exist then do
|
||||
files <- filter ("." `isPrefixOf`) <$> getDirectoryContents autogen
|
||||
if length files >= 2 then
|
||||
return True
|
||||
else
|
||||
return False
|
||||
else
|
||||
return False
|
||||
|
||||
watch :: Int -> ProcessHandle -> IO ()
|
||||
watch 0 _ = return ()
|
||||
watch n hdl = do
|
||||
prepared <- isAutogenPrepared
|
||||
if prepared then
|
||||
interruptProcessGroupOf hdl
|
||||
else do
|
||||
threadDelay 100000
|
||||
watch (n - 1) hdl
|
||||
|
||||
prepareAutogen :: Cradle -> IO ()
|
||||
prepareAutogen crdl = when (isJust $ cradleCabalFile crdl) $ do
|
||||
prepared <- isAutogenPrepared
|
||||
unless prepared $ do
|
||||
hdl <- build
|
||||
watch 30 hdl
|
||||
Loading…
Reference in New Issue
Block a user