diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2014-10-30 v5.2.0.0 + * Return type of `loadSymbolDb` is now in GhcModT + * Function `dumpSymbol` now takes the path of the target directory + * Fix #387, Pattern match failure in GhcPkg + * Fix #386, `ghc-mod version` should not check `cabal configure` + * Fix #391, Error on command `-g` when used before command despite + --help output saying this is valid + * Fix formatting of `ghc-version` constant in the elisp code. in + version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0". + 2014-10-04 v5.1.1.0 * Handle various consistency related issues: #222, #224, #326, #332 * Add `isOutdated` to Language.Haskell.GhcMod diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -2,6 +2,7 @@ findCradle , findCradle' , findCradleWithoutSandbox + , cleanupCradle ) where import Language.Haskell.GhcMod.Types @@ -12,9 +13,11 @@ 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 + ---------------------------------------------------------------- -- | Finding 'Cradle'. @@ -27,13 +30,26 @@ 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 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 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -17,7 +17,6 @@ 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 @@ --------------------------------------------------------------- -- | 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 @@ -- 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 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -16,16 +16,19 @@ 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 @@ 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 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -244,6 +244,9 @@ , gmCradle = c } +cleanupGhcModEnv :: GhcModEnv -> IO () +cleanupGhcModEnv env = cleanupCradle $ gmCradle env + -- | Run a @GhcModT m@ computation. runGhcModT :: IOish m => Options @@ -251,11 +254,13 @@ -> 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/Monad.hs-boot b/Language/Haskell/GhcMod/Monad.hs-boot new file mode 100644 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad.hs-boot @@ -0,0 +1,21 @@ +{-# LANGUAGE RoleAnnotations #-} + +module Language.Haskell.GhcMod.Monad where + +import DynFlags (HasDynFlags) +import Control.Monad.IO.Class (MonadIO) +import Control.Applicative (Applicative) + +data GhcModT m a +type role GhcMod nominal + +data GhcModEnv +data GhcModState +type GhcModWriter = () + +instance Functor GhcMod +instance Applicative GhcMod +instance Monad GhcMod + +instance HasDynFlags GhcMod +instance MonadIO GhcMod diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -19,9 +19,10 @@ -- | 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 @@ -- | If 'True', 'browse' will return fully qualified name , qualified :: Bool , hlintOpts :: [String] - } + } deriving (Show) -- | A default 'Options'. @@ -65,6 +66,8 @@ 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 --- 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 = 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 @@ # else getExecutablePath' = return "" # endif +#else +ghcModExecutable = return "dist/build/ghc-mod/ghc-mod" +#endif diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -28,7 +28,7 @@ (< emacs-minor-version minor))) (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "v5.1.1.0") +(defconst ghc-version "5.2.0.0") ;; (eval-when-compile ;; (require 'haskell-mode)) diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 5.1.1.0 +Version: 5.2.0.0 Author: Kazu Yamamoto Daniel Gröber Alejandro Serrano @@ -109,6 +109,7 @@ , pretty , process , syb + , temporary , time , transformers , transformers-base @@ -212,6 +213,7 @@ , pretty , process , syb + , temporary , time , transformers , transformers-base diff --git a/src/GHCMod.hs b/src/GHCMod.hs --- 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 @@ 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 @@ | 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 @@ -- 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 @@ 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