Merge branch 'master' (early part) into release

Conflicts:
	Language/Haskell/GhcMod/Utils.hs
This commit is contained in:
Daniel Gröber 2014-10-30 01:12:28 +01:00
commit ceeea5d19f
10 changed files with 109 additions and 88 deletions

View File

@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Cradle (
findCradle findCradle
, findCradle' , findCradle'
, findCradleWithoutSandbox , findCradleWithoutSandbox
, cleanupCradle
) where ) where
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
@ -12,8 +13,10 @@ import qualified Control.Exception as E
import Control.Exception.IOChoice ((||>)) import Control.Exception.IOChoice ((||>))
import Control.Monad (filterM) import Control.Monad (filterM)
import Data.List (isSuffixOf) import Data.List (isSuffixOf)
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist) import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive)
import System.FilePath ((</>), takeDirectory) import System.FilePath ((</>), takeDirectory)
import System.IO.Temp
---------------------------------------------------------------- ----------------------------------------------------------------
@ -27,13 +30,26 @@ findCradle = findCradle' =<< getCurrentDirectory
findCradle' :: FilePath -> IO Cradle findCradle' :: FilePath -> IO Cradle
findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir 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 :: FilePath -> IO Cradle
cabalCradle wdir = do cabalCradle wdir = do
(rdir,cfile) <- cabalDir wdir (rdir,cfile) <- cabalDir wdir
pkgDbStack <- getPackageDbStack rdir pkgDbStack <- getPackageDbStack rdir
tmpDir <- newTempDir rdir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = rdir , cradleRootDir = rdir
, cradleTempDir = tmpDir
, cradleCabalFile = Just cfile , cradleCabalFile = Just cfile
, cradlePkgDbStack = pkgDbStack , cradlePkgDbStack = pkgDbStack
} }
@ -42,17 +58,22 @@ sandboxCradle :: FilePath -> IO Cradle
sandboxCradle wdir = do sandboxCradle wdir = do
rdir <- getSandboxDir wdir rdir <- getSandboxDir wdir
pkgDbStack <- getPackageDbStack rdir pkgDbStack <- getPackageDbStack rdir
tmpDir <- newTempDir rdir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = rdir , cradleRootDir = rdir
, cradleTempDir = tmpDir
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePkgDbStack = pkgDbStack , cradlePkgDbStack = pkgDbStack
} }
plainCradle :: FilePath -> IO Cradle plainCradle :: FilePath -> IO Cradle
plainCradle wdir = return Cradle { plainCradle wdir = do
tmpDir <- newTempDir wdir
return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = wdir , cradleRootDir = wdir
, cradleTempDir = tmpDir
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePkgDbStack = [GlobalDb, UserDb] , cradlePkgDbStack = [GlobalDb, UserDb]
} }

View File

@ -17,7 +17,6 @@ module Language.Haskell.GhcMod.Find
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (when, void) import Control.Monad (when, void)
import Control.Monad.Error.Class
import Data.Function (on) import Data.Function (on)
import Data.List (groupBy, sort) import Data.List (groupBy, sort)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -87,10 +86,11 @@ lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
--------------------------------------------------------------- ---------------------------------------------------------------
-- | Loading a file and creates 'SymbolDb'. -- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb loadSymbolDb :: IOish m => GhcModT m SymbolDb
loadSymbolDb = do loadSymbolDb = do
ghcMod <- liftIO ghcModExecutable 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) !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
return $ SymbolDb { return $ SymbolDb {
table = db table = db
@ -110,10 +110,8 @@ loadSymbolDb = do
-- if the file does not exist or is invalid. -- if the file does not exist or is invalid.
-- The file name is printed. -- The file name is printed.
dumpSymbol :: IOish m => GhcModT m String dumpSymbol :: IOish m => FilePath -> GhcModT m String
dumpSymbol = do dumpSymbol dir = do
crdl <- cradle
dir <- liftIO $ getPackageCachePath crdl
let cache = dir </> symbolCache let cache = dir </> symbolCache
pkgdb = dir </> packageCache pkgdb = dir </> packageCache

View File

@ -16,16 +16,19 @@ module Language.Haskell.GhcMod.GhcPkg (
import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception (SomeException(..)) import Control.Exception (SomeException(..))
import Control.Monad
import qualified Control.Exception as E import qualified Control.Exception as E
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.List (isPrefixOf, intercalate) import Data.List (isPrefixOf, intercalate)
import Data.List.Split (splitOn) import Data.List.Split (splitOn)
import Data.Maybe
import Distribution.Package (InstalledPackageId(..)) import Distribution.Package (InstalledPackageId(..))
import Exception (handleIO) import Exception (handleIO)
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import System.Directory (doesDirectoryExist, getAppUserDataDirectory) import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
import System.FilePath ((</>)) import System.FilePath ((</>))
import qualified Data.Traversable as T
ghcVersion :: Int ghcVersion :: Int
ghcVersion = read cProjectVersionInt ghcVersion = read cProjectVersionInt
@ -117,12 +120,14 @@ packageCache = "package.cache"
packageConfDir :: String packageConfDir :: String
packageConfDir = "package.conf.d" packageConfDir = "package.conf.d"
-- fixme: error handling
getPackageCachePath :: Cradle -> IO FilePath getPackageCachePath :: Cradle -> IO FilePath
getPackageCachePath crdl = do getPackageCachePath crdl = do
let u:_ = filter (/= GlobalDb) $ cradlePkgDbStack crdl let mu = listToMaybe $ filter (/= GlobalDb) $ cradlePkgDbStack crdl
Just db <- resolvePath u mdb <- join <$> resolvePath `T.traverse` mu
return db let dir = case mdb of
Just db -> db
Nothing -> cradleTempDir crdl
return dir
--- Copied from ghc module `Packages' unfortunately it's not exported :/ --- Copied from ghc module `Packages' unfortunately it's not exported :/
resolvePath :: GhcPkgDb -> IO (Maybe FilePath) resolvePath :: GhcPkgDb -> IO (Maybe FilePath)

View File

@ -244,6 +244,9 @@ newGhcModEnv opt dir = do
, gmCradle = c , gmCradle = c
} }
cleanupGhcModEnv :: GhcModEnv -> IO ()
cleanupGhcModEnv env = cleanupCradle $ gmCradle env
-- | Run a @GhcModT m@ computation. -- | Run a @GhcModT m@ computation.
runGhcModT :: IOish m runGhcModT :: IOish m
=> Options => Options
@ -251,11 +254,13 @@ runGhcModT :: IOish m
-> m (Either GhcModError a, GhcModLog) -> m (Either GhcModError a, GhcModLog)
runGhcModT opt action = do runGhcModT opt action = do
env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
first (fst <$>) <$> (runGhcModT' env defaultState $ do r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do defaultCleanupHandler dflags $ do
initializeFlagsWithCradle opt (gmCradle env) initializeFlagsWithCradle opt (gmCradle env)
action) action)
liftBase $ cleanupGhcModEnv env
return r
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
-- computation. Note that if the computation that returned @result@ modified the -- computation. Note that if the computation that returned @result@ modified the

View File

@ -19,9 +19,10 @@ type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m)
-- | Output style. -- | Output style.
data OutputStyle = LispStyle -- ^ S expression style. data OutputStyle = LispStyle -- ^ S expression style.
| PlainStyle -- ^ Plain textstyle. | PlainStyle -- ^ Plain textstyle.
deriving (Show)
-- | The type for line separator. Historically, a Null string is used. -- | The type for line separator. Historically, a Null string is used.
newtype LineSeparator = LineSeparator String newtype LineSeparator = LineSeparator String deriving (Show)
data Options = Options { data Options = Options {
outputStyle :: OutputStyle outputStyle :: OutputStyle
@ -40,7 +41,7 @@ data Options = Options {
-- | If 'True', 'browse' will return fully qualified name -- | If 'True', 'browse' will return fully qualified name
, qualified :: Bool , qualified :: Bool
, hlintOpts :: [String] , hlintOpts :: [String]
} } deriving (Show)
-- | A default 'Options'. -- | A default 'Options'.
@ -65,6 +66,8 @@ data Cradle = Cradle {
cradleCurrentDir :: FilePath cradleCurrentDir :: FilePath
-- | The project root directory. -- | The project root directory.
, cradleRootDir :: FilePath , cradleRootDir :: FilePath
-- | Per-Project temporary directory
, cradleTempDir :: FilePath
-- | The file name of the found cabal file. -- | The file name of the found cabal file.
, cradleCabalFile :: Maybe FilePath , cradleCabalFile :: Maybe FilePath
-- | Package database stack -- | Package database stack

View File

@ -1,16 +1,15 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Utils where module Language.Haskell.GhcMod.Utils where
import Control.Applicative ((<$>))
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import MonadUtils (MonadIO, liftIO) import MonadUtils (MonadIO, liftIO)
import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.Exit (ExitCode(..)) import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode) import System.Process (readProcessWithExitCode)
import System.FilePath (takeDirectory)
import System.Environment
#ifndef SPEC #ifndef SPEC
import System.FilePath ((</>)) import Control.Applicative ((<$>))
import System.Environment
import System.FilePath ((</>),takeDirectory)
#endif #endif
-- dropWhileEnd is not provided prior to base 4.5.0.0. -- dropWhileEnd is not provided prior to base 4.5.0.0.
@ -56,11 +55,6 @@ ghcModExecutable :: IO FilePath
ghcModExecutable = do ghcModExecutable = do
dir <- getExecutablePath' dir <- getExecutablePath'
return $ dir </> "ghc-mod" 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 where
getExecutablePath' :: IO FilePath getExecutablePath' :: IO FilePath
# if __GLASGOW_HASKELL__ >= 706 # if __GLASGOW_HASKELL__ >= 706
@ -68,3 +62,6 @@ ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when
# else # else
getExecutablePath' = return "" getExecutablePath' = return ""
# endif # endif
#else
ghcModExecutable = return "dist/build/ghc-mod/ghc-mod"
#endif

View File

@ -109,6 +109,7 @@ Library
, pretty , pretty
, process , process
, syb , syb
, temporary
, time , time
, transformers , transformers
, transformers-base , transformers-base
@ -212,6 +213,7 @@ Test-Suite spec
, pretty , pretty
, process , process
, syb , syb
, temporary
, time , time
, transformers , transformers
, transformers-base , transformers-base

View File

@ -1,40 +1,25 @@
% ghcmodHappyHaskellProgram-Kg.tex % ghcmodHappyHaskellProgram-Kg.tex
\begin{hcarentry}[updated]{ghc-mod --- Happy Haskell Programming} \begin{hcarentry}[updated]{ghc-mod --- Happy Haskell Programming}
\report{Kazu Yamamoto}%05/14 \report{Kazu Yamamoto}%11/14
\status{open source, actively developed} \status{open source, actively developed}
\makeheader \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} \texttt{ghc-modi} used to suffer from various consistency related issues
\item[Completion] You can complete a name of keyword, module, class, function, types, language extensions, etc. 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. Kazu stepped down as release manager and Daniel took over.
\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}
\FurtherReading \FurtherReading
\url{http://www.mew.org/~kazu/proj/ghc-mod/en/} \url{http://www.mew.org/~kazu/proj/ghc-mod/en/}

View File

@ -3,7 +3,6 @@
module Main where module Main where
import Config (cProjectVersion) import Config (cProjectVersion)
import Control.Arrow
import Control.Applicative import Control.Applicative
import Control.Exception (Exception, Handler(..), catches, throw) import Control.Exception (Exception, Handler(..), catches, throw)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
@ -295,13 +294,13 @@ main = handler $ do
hSetEncoding stdout utf8 hSetEncoding stdout utf8
args <- getArgs args <- getArgs
let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args -- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
_realGhcArgs = filter (/="--ghc-mod") ghcArgs -- _realGhcArgs = filter (/="--ghc-mod") ghcArgs
(globalOptions,_cmdArgs) = parseGlobalArgs modArgs -- (globalOptions,_cmdArgs) = parseGlobalArgs modArgs
stripSeperator ("--":rest) = rest -- stripSeperator ("--":rest) = rest
stripSeperator l = l -- stripSeperator l = l
case args of case args of
_ _
@ -323,9 +322,14 @@ main = handler $ do
| otherwise -> do | otherwise -> do
(res, _) <- runGhcModT globalOptions $ commands args let (globalOptions,cmdArgs) = parseGlobalArgs args
case res of res <- simpleCommands cmdArgs
Right s -> putStr s 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) Left e -> exitError $ render (gmeDoc e)
-- Obtain ghc options by letting ourselfs be executed by -- Obtain ghc options by letting ourselfs be executed by
@ -339,14 +343,19 @@ main = handler $ do
-- rawSystem "cabal" cabalArgs >>= exitWith -- rawSystem "cabal" cabalArgs >>= exitWith
commands :: IOish m => [String] -> GhcModT m String simpleCommands :: [String] -> IO (Maybe String)
commands [] = fatalError "No command given (try --help)\n" simpleCommands [] = return Nothing
commands (cmd:args) = fn args 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 where
fn = case cmd of fn = case cmd of
_ | cmd == "list" || cmd == "modules" -> modulesCmd _ | cmd == "list" || cmd == "modules" -> modulesCmd
_ | cmd == "help" || cmd == "--help" -> const $ return usage
"version" -> const $ return progVersion
"lang" -> languagesCmd "lang" -> languagesCmd
"flag" -> flagsCmd "flag" -> flagsCmd
"browse" -> browseCmd "browse" -> browseCmd
@ -400,9 +409,9 @@ flagsCmd = withParseCmd [] $ \[] -> flags
debugInfoCmd = withParseCmd [] $ \[] -> debugInfo debugInfoCmd = withParseCmd [] $ \[] -> debugInfo
rootInfoCmd = withParseCmd [] $ \[] -> rootInfo rootInfoCmd = withParseCmd [] $ \[] -> rootInfo
-- internal -- internal
dumpSymbolCmd = withParseCmd [] $ \[] -> dumpSymbol
bootCmd = withParseCmd [] $ \[] -> boot bootCmd = withParseCmd [] $ \[] -> boot
dumpSymbolCmd = withParseCmd [] $ \[tmpdir] -> dumpSymbol tmpdir
findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym
pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl
lintCmd = withParseCmd s $ \[file] -> lint file lintCmd = withParseCmd s $ \[file] -> lint file

View File

@ -17,31 +17,27 @@ spec = do
withDirectory_ "/" $ do withDirectory_ "/" $ do
curDir <- stripLastDot <$> canonicalizePath "/" curDir <- stripLastDot <$> canonicalizePath "/"
res <- findCradle res <- findCradle
res `shouldBe` Cradle { cradleCurrentDir res `shouldBe` curDir
cradleCurrentDir = curDir cradleRootDir res `shouldBe` curDir
, cradleRootDir = curDir cradleCabalFile res `shouldBe` Nothing
, cradleCabalFile = Nothing cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb]
, cradlePkgDbStack = [GlobalDb,UserDb]
}
it "finds a cabal file and a sandbox" $ do it "finds a cabal file and a sandbox" $ do
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
withDirectory "test/data/subdir1/subdir2" $ \dir -> do withDirectory "test/data/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> findCradle res <- relativeCradle dir <$> findCradle
res `shouldBe` Cradle { cradleCurrentDir res `shouldBe` "test" </> "data" </> "subdir1" </> "subdir2"
cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2" cradleRootDir res `shouldBe` "test" </> "data"
, cradleRootDir = "test" </> "data" cradleCabalFile res `shouldBe` Just ("test" </> "data" </> "cabalapi.cabal")
, cradleCabalFile = Just ("test" </> "data" </> "cabalapi.cabal") cradlePkgDbStack res `shouldBe` [GlobalDb, PackageDb (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")]
, cradlePkgDbStack = [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 it "works even if a sandbox config file is broken" $ do
withDirectory "test/data/broken-sandbox" $ \dir -> do withDirectory "test/data/broken-sandbox" $ \dir -> do
res <- relativeCradle dir <$> findCradle res <- relativeCradle dir <$> findCradle
res `shouldBe` Cradle { cradleCurrentDir res `shouldBe` "test" </> "data" </> "broken-sandbox"
cradleCurrentDir = "test" </> "data" </> "broken-sandbox" cradleRootDir res `shouldBe` "test" </> "data" </> "broken-sandbox"
, cradleRootDir = "test" </> "data" </> "broken-sandbox" cradleCabalFile res `shouldBe` Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
, cradleCabalFile = Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal") cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb]
, cradlePkgDbStack = [GlobalDb, UserDb]
}
relativeCradle :: FilePath -> Cradle -> Cradle relativeCradle :: FilePath -> Cradle -> Cradle
relativeCradle dir cradle = cradle { relativeCradle dir cradle = cradle {