diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 16c9a6a..b356efa 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -46,6 +46,7 @@ module Language.Haskell.GhcMod ( , dumpSymbol -- * SymbolDb , loadSymbolDb + , isOutdated ) where import Language.Haskell.GhcMod.Boot diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs index 6a03e26..8f1474e 100644 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ b/Language/Haskell/GhcMod/CabalConfig.hs @@ -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` \_ -> - configure `modifyError'` GMECabalConfigure +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 diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index 86d50f0..ce8877f 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -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 ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 8f27a63..addbc36 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -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 diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 6c1f5b8..c0cb2c2 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -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" diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index a6454da..a75c00d 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index b9b8fe4..5fe33b8 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index a38b6c5..4ae27bc 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -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' - where - getExecutable' :: IO FilePath -# if __GLASGOW_HASKELL__ >= 706 - getExecutable' = getExecutablePath -# else - getExecutable' = getProgName -# endif - +ghcModExecutable = do + dir <- getExecutablePath' + return $ dir "ghc-mod" #else -ghcModExecutable = return "dist/build/ghc-mod/ghc-mod" +ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when + -- compiling spec + return "dist/build/ghc-mod/ghc-mod" #endif + where + getExecutablePath' :: IO FilePath +# if __GLASGOW_HASKELL__ >= 706 + getExecutablePath' = takeDirectory <$> getExecutablePath +# else + getExecutablePath' = return "" +# endif diff --git a/elisp/ghc-rewrite.el b/elisp/ghc-rewrite.el index 14432f9..e8087a9 100644 --- a/elisp/ghc-rewrite.el +++ b/elisp/ghc-rewrite.el @@ -125,8 +125,8 @@ (ghc-display nil (lambda () (insert "Possible completions:\n") - (mapc - (lambda (x) + (mapc + (lambda (x) (let* (; (ins1 (insert "- ")) (pos-begin (point)) (ins (insert x)) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index e81be62..2d324dc 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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 diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 45a9315..ace2526 100644 --- a/src/GHCModi.hs +++ b/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,25 +80,33 @@ 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 - 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 + go (opt,_) = emptyNewUnGetLine >>= run opt - case res of - Right () -> return () - Left (GMECabalConfigure msg) -> do - putStrLn $ notGood $ "cabal configure failed: " ++ show msg - exitFailure - Left e -> bug $ show e - where - -- 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 (\(SomeException e) -> bug $ show e) ] +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 + 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 + putStrLn $ notGood $ "cabal configure failed: " ++ show msg + exitFailure + Left e -> bug $ show e + where + -- 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 () bug msg = do @@ -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 } + setDetailed opt = opt { detailed = True } diff --git a/src/Misc.hs b/src/Misc.hs new file mode 100644 index 0000000..21248ad --- /dev/null +++ b/src/Misc.hs @@ -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