diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index c956b4e..112528a 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Cradle ( findCradle , findCradle' , findCradleWithoutSandbox + , cleanupCradle ) where import Language.Haskell.GhcMod.Types @@ -12,8 +13,10 @@ import qualified Control.Exception as E import Control.Exception.IOChoice ((||>)) import Control.Monad (filterM) import Data.List (isSuffixOf) -import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist) +import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive) import System.FilePath ((), takeDirectory) +import System.IO.Temp + ---------------------------------------------------------------- @@ -27,13 +30,26 @@ findCradle = findCradle' =<< getCurrentDirectory findCradle' :: FilePath -> IO Cradle findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir +newTempDir :: FilePath -> IO FilePath +newTempDir dir = + flip createTempDirectory uniqPathName =<< getTemporaryDirectory + where + uniqPathName = "ghc-mod" ++ map escapeSlash dir + escapeSlash '/' = '-' + escapeSlash c = c + +cleanupCradle :: Cradle -> IO () +cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl + cabalCradle :: FilePath -> IO Cradle cabalCradle wdir = do (rdir,cfile) <- cabalDir wdir pkgDbStack <- getPackageDbStack rdir + tmpDir <- newTempDir rdir return Cradle { cradleCurrentDir = wdir , cradleRootDir = rdir + , cradleTempDir = tmpDir , cradleCabalFile = Just cfile , cradlePkgDbStack = pkgDbStack } @@ -42,17 +58,22 @@ sandboxCradle :: FilePath -> IO Cradle sandboxCradle wdir = do rdir <- getSandboxDir wdir pkgDbStack <- getPackageDbStack rdir + tmpDir <- newTempDir rdir return Cradle { cradleCurrentDir = wdir , cradleRootDir = rdir + , cradleTempDir = tmpDir , cradleCabalFile = Nothing , cradlePkgDbStack = pkgDbStack } plainCradle :: FilePath -> IO Cradle -plainCradle wdir = return Cradle { +plainCradle wdir = do + tmpDir <- newTempDir wdir + return Cradle { cradleCurrentDir = wdir , cradleRootDir = wdir + , cradleTempDir = tmpDir , cradleCabalFile = Nothing , cradlePkgDbStack = [GlobalDb, UserDb] } diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index addbc36..5967128 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -17,7 +17,6 @@ module Language.Haskell.GhcMod.Find import Control.Applicative ((<$>)) import Control.Monad (when, void) -import Control.Monad.Error.Class import Data.Function (on) import Data.List (groupBy, sort) import Data.Maybe (fromMaybe) @@ -87,10 +86,11 @@ lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db --------------------------------------------------------------- -- | Loading a file and creates 'SymbolDb'. -loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb +loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do ghcMod <- liftIO ghcModExecutable - file <- chop <$> readProcess' ghcMod ["dumpsym"] + tmpdir <- liftIO . getPackageCachePath =<< cradle + file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir] !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) return $ SymbolDb { table = db @@ -110,10 +110,8 @@ loadSymbolDb = do -- if the file does not exist or is invalid. -- The file name is printed. -dumpSymbol :: IOish m => GhcModT m String -dumpSymbol = do - crdl <- cradle - dir <- liftIO $ getPackageCachePath crdl +dumpSymbol :: IOish m => FilePath -> GhcModT m String +dumpSymbol dir = do let cache = dir symbolCache pkgdb = dir packageCache diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index c0cb2c2..a0c9bff 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -16,16 +16,19 @@ module Language.Haskell.GhcMod.GhcPkg ( import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) import Control.Applicative ((<$>)) import Control.Exception (SomeException(..)) +import Control.Monad import qualified Control.Exception as E import Data.Char (isSpace) import Data.List (isPrefixOf, intercalate) import Data.List.Split (splitOn) +import Data.Maybe 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 (()) +import qualified Data.Traversable as T ghcVersion :: Int ghcVersion = read cProjectVersionInt @@ -117,12 +120,14 @@ 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 + let mu = listToMaybe $ filter (/= GlobalDb) $ cradlePkgDbStack crdl + mdb <- join <$> resolvePath `T.traverse` mu + let dir = case mdb of + Just db -> db + Nothing -> cradleTempDir crdl + return dir --- Copied from ghc module `Packages' unfortunately it's not exported :/ resolvePath :: GhcPkgDb -> IO (Maybe FilePath) diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 5fe33b8..4d26280 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -244,6 +244,9 @@ newGhcModEnv opt dir = do , gmCradle = c } +cleanupGhcModEnv :: GhcModEnv -> IO () +cleanupGhcModEnv env = cleanupCradle $ gmCradle env + -- | Run a @GhcModT m@ computation. runGhcModT :: IOish m => Options @@ -251,11 +254,13 @@ runGhcModT :: IOish m -> m (Either GhcModError a, GhcModLog) runGhcModT opt action = do env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory - first (fst <$>) <$> (runGhcModT' env defaultState $ do + r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do dflags <- getSessionDynFlags defaultCleanupHandler dflags $ do initializeFlagsWithCradle opt (gmCradle env) action) + liftBase $ cleanupGhcModEnv env + return r -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT -- computation. Note that if the computation that returned @result@ modified the diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index ba681bf..46b7a35 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -19,9 +19,10 @@ type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m) -- | Output style. data OutputStyle = LispStyle -- ^ S expression style. | PlainStyle -- ^ Plain textstyle. + deriving (Show) -- | The type for line separator. Historically, a Null string is used. -newtype LineSeparator = LineSeparator String +newtype LineSeparator = LineSeparator String deriving (Show) data Options = Options { outputStyle :: OutputStyle @@ -40,7 +41,7 @@ data Options = Options { -- | If 'True', 'browse' will return fully qualified name , qualified :: Bool , hlintOpts :: [String] - } + } deriving (Show) -- | A default 'Options'. @@ -65,6 +66,8 @@ data Cradle = Cradle { cradleCurrentDir :: FilePath -- | The project root directory. , cradleRootDir :: FilePath + -- | Per-Project temporary directory + , cradleTempDir :: FilePath -- | The file name of the found cabal file. , cradleCabalFile :: Maybe FilePath -- | Package database stack diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 88c09c4..57b24bc 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -1,16 +1,15 @@ {-# 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) import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode) -import System.FilePath (takeDirectory) -import System.Environment #ifndef SPEC -import System.FilePath (()) +import Control.Applicative ((<$>)) +import System.Environment +import System.FilePath ((),takeDirectory) #endif -- dropWhileEnd is not provided prior to base 4.5.0.0. @@ -56,11 +55,6 @@ ghcModExecutable :: IO FilePath 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 getExecutablePath' :: IO FilePath # if __GLASGOW_HASKELL__ >= 706 @@ -68,3 +62,6 @@ ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when # else getExecutablePath' = return "" # endif +#else +ghcModExecutable = return "dist/build/ghc-mod/ghc-mod" +#endif diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 4f35713..91b95e1 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -109,6 +109,7 @@ Library , pretty , process , syb + , temporary , time , transformers , transformers-base @@ -212,6 +213,7 @@ Test-Suite spec , pretty , process , syb + , temporary , time , transformers , transformers-base diff --git a/hcar-ghc-mod.tex b/hcar-ghc-mod.tex index 9c847da..ea738ca 100644 --- a/hcar-ghc-mod.tex +++ b/hcar-ghc-mod.tex @@ -1,40 +1,25 @@ % ghcmodHappyHaskellProgram-Kg.tex \begin{hcarentry}[updated]{ghc-mod --- Happy Haskell Programming} -\report{Kazu Yamamoto}%05/14 +\report{Kazu Yamamoto}%11/14 \status{open source, actively developed} \makeheader -{\tt ghc-mod} is a package to enrich Haskell programming on editors including Emacs, Vim and Sublime. The {\tt ghc-mod} package on Hackage includes the {\tt ghc-mod} command, new {\tt ghc-modi} command and Emacs front-end. +For a long time, Kazu Yamamoto was the only active developer of ghc-mod, now two +new developers have joined: -Emacs front-end provides the following features: +Alejandro Serrano merged the results of his Google Summer of Code project. He +implemented case splitting and sophisticated typed hole handling. Daniel Gröber +brushed up the internal code and introduced the GhcModT monad now used +throughout the exported API. As a result the API of \texttt{ghc-mod} drastically +changed with version 5.0.0. -\begin{description} -\item[Completion] You can complete a name of keyword, module, class, function, types, language extensions, etc. +\texttt{ghc-modi} used to suffer from various consistency related issues +triggered by changes in the environment, for instance: changing file names of +modules, adding dependencies to the cabal file and installing new libraries. +\texttt{ghc-modi} v5.1.1 or later handles changes in the environment by +restarting the GHC session when this is detected. -\item[Code template] You can insert a code template according to the position of the cursor. For instance, {\tt import Foo (bar)} is inserted if {\tt bar} is missing. - -\item[Syntax check] Code lines with error messages are automatically highlighted. You can display the error message of the current line in another window. {\tt hlint} %\cref{hlint} -can be used instead of GHC to check Haskell syntax. - -\item[Document browsing] You can browse the module document of the current line either locally or on Hackage. - -\item[Expression type] You can display the type/information of the expression on the cursor. -\end{description} - -\noindent -There are two Vim plugins: -\begin{itemize} -\item ghcmod-vim -\item syntastic -\end{itemize} - -\noindent -Here are new features: -\begin{itemize} -\item New {\tt ghc-modi} command provides a persistent session to make response time drastically faster. So, now you can use Emacs front-end without stress. -\item Emacs front-end provides a way to solve the import hell. -\item GHC 7.8 is supported. -\end{itemize} +Kazu stepped down as release manager and Daniel took over. \FurtherReading \url{http://www.mew.org/~kazu/proj/ghc-mod/en/} diff --git a/src/GHCMod.hs b/src/GHCMod.hs index ea63107..510a6d2 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -3,7 +3,6 @@ module Main where import Config (cProjectVersion) -import Control.Arrow import Control.Applicative import Control.Exception (Exception, Handler(..), catches, throw) import Data.Typeable (Typeable) @@ -295,13 +294,13 @@ main = handler $ do hSetEncoding stdout utf8 args <- getArgs - let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args - _realGhcArgs = filter (/="--ghc-mod") ghcArgs + -- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args + -- _realGhcArgs = filter (/="--ghc-mod") ghcArgs - (globalOptions,_cmdArgs) = parseGlobalArgs modArgs + -- (globalOptions,_cmdArgs) = parseGlobalArgs modArgs - stripSeperator ("--":rest) = rest - stripSeperator l = l + -- stripSeperator ("--":rest) = rest + -- stripSeperator l = l case args of _ @@ -323,10 +322,15 @@ main = handler $ do | otherwise -> do - (res, _) <- runGhcModT globalOptions $ commands args - case res of - Right s -> putStr s - Left e -> exitError $ render (gmeDoc e) + let (globalOptions,cmdArgs) = parseGlobalArgs args + res <- simpleCommands cmdArgs + putStr =<< case res of + Just s -> return s + Nothing -> do + (res',_) <- runGhcModT globalOptions $ ghcCommands cmdArgs + case res' of + Right s -> return s + Left e -> exitError $ render (gmeDoc e) -- Obtain ghc options by letting ourselfs be executed by -- @cabal repl@ @@ -339,14 +343,19 @@ main = handler $ do -- rawSystem "cabal" cabalArgs >>= exitWith -commands :: IOish m => [String] -> GhcModT m String -commands [] = fatalError "No command given (try --help)\n" -commands (cmd:args) = fn args +simpleCommands :: [String] -> IO (Maybe String) +simpleCommands [] = return Nothing +simpleCommands (cmd:_) = return $ case cmd of + _ | cmd == "help" || cmd == "--help" -> Just usage + "version" -> Just progVersion + _ -> Nothing + +ghcCommands :: IOish m => [String] -> GhcModT m String +ghcCommands [] = fatalError "No command given (try --help)\n" +ghcCommands (cmd:args) = fn args where fn = case cmd of _ | cmd == "list" || cmd == "modules" -> modulesCmd - _ | cmd == "help" || cmd == "--help" -> const $ return usage - "version" -> const $ return progVersion "lang" -> languagesCmd "flag" -> flagsCmd "browse" -> browseCmd @@ -400,9 +409,9 @@ flagsCmd = withParseCmd [] $ \[] -> flags debugInfoCmd = withParseCmd [] $ \[] -> debugInfo rootInfoCmd = withParseCmd [] $ \[] -> rootInfo -- internal -dumpSymbolCmd = withParseCmd [] $ \[] -> dumpSymbol bootCmd = withParseCmd [] $ \[] -> boot +dumpSymbolCmd = withParseCmd [] $ \[tmpdir] -> dumpSymbol tmpdir findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl lintCmd = withParseCmd s $ \[file] -> lint file diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index dbad36d..60ae5ac 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -17,31 +17,27 @@ spec = do withDirectory_ "/" $ do curDir <- stripLastDot <$> canonicalizePath "/" res <- findCradle - res `shouldBe` Cradle { - cradleCurrentDir = curDir - , cradleRootDir = curDir - , cradleCabalFile = Nothing - , cradlePkgDbStack = [GlobalDb,UserDb] - } + cradleCurrentDir res `shouldBe` curDir + cradleRootDir res `shouldBe` curDir + cradleCabalFile res `shouldBe` Nothing + cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb] + it "finds a cabal file and a sandbox" $ do cwd <- getCurrentDirectory withDirectory "test/data/subdir1/subdir2" $ \dir -> do res <- relativeCradle dir <$> findCradle - res `shouldBe` Cradle { - cradleCurrentDir = "test" "data" "subdir1" "subdir2" - , cradleRootDir = "test" "data" - , cradleCabalFile = Just ("test" "data" "cabalapi.cabal") - , cradlePkgDbStack = [GlobalDb, PackageDb (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")] - } + cradleCurrentDir res `shouldBe` "test" "data" "subdir1" "subdir2" + cradleRootDir res `shouldBe` "test" "data" + cradleCabalFile res `shouldBe` Just ("test" "data" "cabalapi.cabal") + cradlePkgDbStack res `shouldBe` [GlobalDb, PackageDb (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")] + it "works even if a sandbox config file is broken" $ do withDirectory "test/data/broken-sandbox" $ \dir -> do res <- relativeCradle dir <$> findCradle - res `shouldBe` Cradle { - cradleCurrentDir = "test" "data" "broken-sandbox" - , cradleRootDir = "test" "data" "broken-sandbox" - , cradleCabalFile = Just ("test" "data" "broken-sandbox" "dummy.cabal") - , cradlePkgDbStack = [GlobalDb, UserDb] - } + cradleCurrentDir res `shouldBe` "test" "data" "broken-sandbox" + cradleRootDir res `shouldBe` "test" "data" "broken-sandbox" + cradleCabalFile res `shouldBe` Just ("test" "data" "broken-sandbox" "dummy.cabal") + cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb] relativeCradle :: FilePath -> Cradle -> Cradle relativeCradle dir cradle = cradle {