Merge branch 'master' into release

Conflicts:
	elisp/ghc.el
	ghc-mod.cabal
This commit is contained in:
Daniel Gröber 2014-11-02 19:08:04 +01:00
commit be1185fc58
14 changed files with 504 additions and 270 deletions

View File

@ -6,17 +6,15 @@ 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.PathsAndFiles
import Language.Haskell.GhcMod.Read
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
import qualified Language.Haskell.GhcMod.Cabal16 as C16
import qualified Language.Haskell.GhcMod.Cabal18 as C18
@ -27,32 +25,19 @@ import qualified Language.Haskell.GhcMod.Cabal21 as C21
#endif
import Control.Applicative ((<$>))
import Control.Monad (unless, void, mplus)
import Control.Monad (void, mplus, when)
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except ()
#else
import Control.Monad.Error ()
#endif
import Data.Maybe ()
import Data.Set ()
import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)
import Distribution.Package (InstalledPackageId(..)
, PackageIdentifier(..)
, PackageName(..))
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
----------------------------------------------------------------
@ -66,9 +51,8 @@ getConfig :: (IOish m, MonadError GhcModError m)
=> Cradle
-> m CabalConfig
getConfig cradle = do
world <- liftIO $ getCurrentWorld cradle
let valid = isSetupConfigValid world
unless valid configure
outOfDate <- liftIO $ isSetupConfigOutOfDate cradle
when outOfDate configure
liftIO (readFile file) `tryFix` \_ ->
configure `modifyError'` GMECabalConfigure
where
@ -78,14 +62,6 @@ getConfig cradle = do
configure :: (IOish m, MonadError GhcModError m) => m ()
configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
setupConfigFile :: Cradle -> FilePath
setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
setupConfigPath :: FilePath
setupConfigPath = localBuildInfoFile defaultDistPref
-- | Get list of 'Package's needed by all components of the current package
cabalConfigDependencies :: (IOish m, MonadError GhcModError m)
=> Cradle
@ -193,57 +169,3 @@ 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

View File

@ -5,17 +5,14 @@ module Language.Haskell.GhcMod.Cradle (
, cleanupCradle
) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Control.Applicative ((<$>))
import qualified Control.Exception as E
import Control.Exception.IOChoice ((||>))
import Control.Monad (filterM)
import Data.List (isSuffixOf)
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive)
import System.FilePath ((</>), takeDirectory)
import System.IO.Temp
import System.Directory (getCurrentDirectory, removeDirectoryRecursive)
import System.FilePath (takeDirectory)
----------------------------------------------------------------
@ -30,38 +27,31 @@ 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
Just cabalFile <- findCabalFiles wdir
let cabalDir = takeDirectory cabalFile
pkgDbStack <- getPackageDbStack cabalDir
tmpDir <- newTempDir cabalDir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = rdir
, cradleRootDir = cabalDir
, cradleTempDir = tmpDir
, cradleCabalFile = Just cfile
, cradleCabalFile = Just cabalFile
, cradlePkgDbStack = pkgDbStack
}
sandboxCradle :: FilePath -> IO Cradle
sandboxCradle wdir = do
rdir <- getSandboxDir wdir
pkgDbStack <- getPackageDbStack rdir
tmpDir <- newTempDir rdir
Just sbDir <- getSandboxDb wdir
pkgDbStack <- getPackageDbStack sbDir
tmpDir <- newTempDir sbDir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = rdir
, cradleRootDir = sbDir
, cradleTempDir = tmpDir
, cradleCabalFile = Nothing
, cradlePkgDbStack = pkgDbStack
@ -83,48 +73,3 @@ findCradleWithoutSandbox :: IO Cradle
findCradleWithoutSandbox = do
cradle <- findCradle
return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME
----------------------------------------------------------------
cabalSuffix :: String
cabalSuffix = ".cabal"
cabalSuffixLength :: Int
cabalSuffixLength = length cabalSuffix
-- Finding a Cabal file up to the root directory
-- Input: a directly to investigate
-- Output: (the path to the directory containing a Cabal file
-- ,the path to the Cabal file)
cabalDir :: FilePath -> IO (FilePath,FilePath)
cabalDir dir = do
cnts <- getCabalFiles dir
case cnts of
[] | dir' == dir -> E.throwIO $ userError "cabal files not found"
| otherwise -> cabalDir dir'
cfile:_ -> return (dir,dir </> cfile)
where
dir' = takeDirectory dir
getCabalFiles :: FilePath -> IO [FilePath]
getCabalFiles dir = getFiles >>= filterM doesCabalFileExist
where
isCabal name = cabalSuffix `isSuffixOf` name
&& length name > cabalSuffixLength
getFiles = filter isCabal <$> getDirectoryContents dir
doesCabalFileExist file = doesFileExist $ dir </> file
----------------------------------------------------------------
getSandboxDir :: FilePath -> IO FilePath
getSandboxDir dir = do
exist <- doesFileExist sfile
if exist then
return dir
else if dir == dir' then
E.throwIO $ userError "sandbox not found"
else
getSandboxDir dir'
where
sfile = dir </> "cabal.sandbox.config"
dir' = takeDirectory dir

View File

@ -1,4 +1,4 @@
{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-}
module Language.Haskell.GhcMod.Error (
GhcModError(..)
, gmeDoc
@ -10,6 +10,8 @@ module Language.Haskell.GhcMod.Error (
) where
import Control.Monad.Error (MonadError(..), Error(..))
import Data.List
import Data.Typeable
import Exception
import Text.PrettyPrint
@ -18,6 +20,8 @@ data GhcModError = GMENoMsg
| GMEString String
-- ^ Some Error with a message. These are produced mostly by
-- 'fail' calls on GhcModT.
| GMEIOException IOException
-- ^ IOExceptions captured by GhcModT's MonadIO instance
| GMECabalConfigure GhcModError
-- ^ Configuring a cabal project failed.
| GMECabalFlags GhcModError
@ -25,7 +29,12 @@ data GhcModError = GMENoMsg
| GMEProcess [String] GhcModError
-- ^ Launching an operating system process failed. The first
-- field is the command.
deriving (Eq,Show)
| GMENoCabalFile
| GMETooManyCabalFiles [FilePath]
-- ^ No or too many cabal files found.
deriving (Eq,Show,Typeable)
instance Exception GhcModError
instance Error GhcModError where
noMsg = GMENoMsg
@ -37,6 +46,8 @@ gmeDoc e = case e of
text "Unknown error"
GMEString msg ->
text msg
GMEIOException ioe ->
text $ show ioe
GMECabalConfigure msg ->
text "cabal configure failed: " <> gmeDoc msg
GMECabalFlags msg ->
@ -44,6 +55,11 @@ gmeDoc e = case e of
GMEProcess cmd msg ->
text ("launching operating system process `"++unwords cmd++"` failed: ")
<> gmeDoc msg
GMENoCabalFile ->
text "No cabal file found."
GMETooManyCabalFiles cfs ->
text $ "Multiple cabal files found. Possible cabal files: \""
++ intercalate "\", \"" cfs ++"\"."
modifyError :: MonadError e m => (e -> e) -> m a -> m a
modifyError f action = action `catchError` \e -> throwError $ f e

View File

@ -22,10 +22,10 @@ import Data.List (groupBy, sort)
import Data.Maybe (fromMaybe)
import qualified GHC as G
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.PathsAndFiles
import Name (getOccString)
import System.Directory (doesFileExist, getModificationTime)
import System.FilePath ((</>), takeDirectory)
@ -89,7 +89,7 @@ lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
loadSymbolDb :: IOish m => GhcModT m SymbolDb
loadSymbolDb = do
ghcMod <- liftIO ghcModExecutable
tmpdir <- liftIO . getPackageCachePath =<< cradle
tmpdir <- cradleTempDir <$> cradle
file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir]
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
return $ SymbolDb {

View File

@ -6,63 +6,34 @@ module Language.Haskell.GhcMod.GhcPkg (
, ghcDbOpt
, fromInstalledPackageId
, fromInstalledPackageId'
, getSandboxDb
, getPackageDbStack
, getPackageCachePath
, packageCache
, packageConfDir
, getPackageCachePaths
) where
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 (intercalate)
import Data.List.Split (splitOn)
import Data.Maybe
import Distribution.Package (InstalledPackageId(..))
import Exception (handleIO)
import Language.Haskell.GhcMod.PathsAndFiles
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
-- | Get path to sandbox package db
getSandboxDb :: FilePath -- ^ Path to the cabal package root directory
-- (containing the @cabal.sandbox.config@ file)
-> IO FilePath
getSandboxDb cdir = getSandboxDbDir (cdir </> "cabal.sandbox.config")
-- | Extract the sandbox package db directory from the cabal.sandbox.config file.
-- Exception is thrown if the sandbox config file is broken.
getSandboxDbDir :: FilePath -- ^ Path to the @cabal.sandbox.config@ file
-> IO FilePath
getSandboxDbDir sconf = do
-- Be strict to ensure that an error can be caught.
!path <- extractValue . parse <$> readFile sconf
return path
where
key = "package-db:"
keyLen = length key
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)
-> IO [GhcPkgDb]
getPackageDbStack cdir =
(getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])
`E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]
getPackageDbStack cdir = do
mSDir <- getSandboxDb cdir
return $ [GlobalDb] ++ case mSDir of
Nothing -> [UserDb]
Just db -> [PackageDb db]
----------------------------------------------------------------
@ -114,30 +85,22 @@ ghcDbOpt (PackageDb pkgDb)
----------------------------------------------------------------
packageCache :: String
packageCache = "package.cache"
packageConfDir :: String
packageConfDir = "package.conf.d"
getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath]
getPackageCachePaths sysPkgCfg crdl =
catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl
getPackageCachePath :: Cradle -> IO FilePath
getPackageCachePath crdl = do
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
-- TODO: use PkgConfRef
--- 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
resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath)
resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg
resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do
appdir <- getAppUserDataDirectory "ghc"
let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
pkgconf = dir </> packageConfDir
pkgconf = dir </> "package.conf.d"
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"
resolvePackageConfig _ (PackageDb name) = return $ Just name

View File

@ -52,13 +52,12 @@ module Language.Haskell.GhcMod.Internal (
-- * World
, World
, getCurrentWorld
, isWorldChanged
, didWorldChange
) 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
@ -67,6 +66,7 @@ import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
-- | Obtaining the directory for ghc system libraries.
ghcLibDir :: FilePath

View File

@ -1,6 +1,7 @@
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad (
@ -101,7 +102,6 @@ import Control.Monad.Journal.Class
import Data.Maybe (fromJust, isJust)
import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import System.Directory (getCurrentDirectory)
import System.IO.Error (tryIOError)
----------------------------------------------------------------
@ -154,12 +154,29 @@ newtype GhcModT m a = GhcModT {
instance MonadIO m => MonadIO (GhcModT m) where
liftIO action = do
res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ tryIOError action
res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action
case res of
Right a -> return a
Left e -> case show e of
"" -> throwError $ noMsg
msg -> throwError $ strMsg msg
Left e | isIOError e ->
throwError $ GMEIOException (fromEx e :: IOError)
Left e | isGhcModError e ->
throwError $ (fromEx e :: GhcModError)
Left e -> throw e
where
fromEx :: Exception e => SomeException -> e
fromEx = fromJust . fromException
isIOError se =
case fromException se of
Just (_ :: IOError) -> True
Nothing -> False
isGhcModError se =
case fromException se of
Just (_ :: GhcModError) -> True
Nothing -> False
instance MonadTrans (GhcModT) where
lift = GhcModT . lift . lift . lift . lift

View File

@ -0,0 +1,108 @@
{-# LANGUAGE BangPatterns, TupleSections #-}
module Language.Haskell.GhcMod.PathsAndFiles where
import Control.Applicative
import Control.Monad
import Data.List
import Data.Char
import Data.Maybe
import Data.Traversable (traverse)
import Language.Haskell.GhcMod.Types
import System.Directory
import System.FilePath
import Language.Haskell.GhcMod.Error
import qualified Language.Haskell.GhcMod.Utils as U
import Distribution.Simple.BuildPaths (defaultDistPref)
import Distribution.Simple.Configure (localBuildInfoFile)
-- | Guaranteed to be a path to a directory with no trailing slash.
type DirPath = FilePath
-- | Guaranteed to be the name of a file only (no slashes).
type FileName = String
-- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent
-- directories. The first parent directory containing more than one cabal file
-- is assumed to be the project directory. If only one cabal file exists in this
-- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'
-- or 'GMETooManyCabalFiles'
findCabalFiles :: FilePath -> IO (Maybe FilePath)
findCabalFiles directory = do
-- Look for cabal files in all parent directories of @dir@
dcs <- getCabalFiles `zipMapM` parents directory
-- Extract first non-empty list, which represents a directory with cabal
-- files.
case find (not . null) $ uncurry makeAbsolute `map` dcs of
Just [] -> throw $ GMENoCabalFile
Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs
a -> return $ head <$> a
-- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@.
getCabalFiles :: DirPath -> IO [FileName]
getCabalFiles dir =
filter ((==) ".cabal" . takeExtension) <$> getDirectoryContents dir
makeAbsolute :: DirPath -> [FileName] -> [FilePath]
makeAbsolute dir fs = (dir </>) `map` fs
zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
zipMapM f as = mapM (\a -> liftM (a,) $ f a) as
-- | @parents dir@. Returns all parent directories of @dir@ including @dir@.
--
-- Examples
--
-- >>> parents "foo"
-- ["foo"]
--
-- >>> parents "/foo"
-- ["/foo","/"]
--
-- >>> parents "/foo/bar"
-- ["/foo/bar","/foo","/"]
--
-- >>> parents "foo/bar"
-- ["foo/bar","foo"]
parents :: FilePath -> [FilePath]
parents "" = []
parents dir' =
let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir'
in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir
where
parents' :: [String] -> [FilePath]
parents' [] | isAbsolute dir' = "":[]
parents' [] = []
parents' dir = [joinPath dir] ++ parents' (init dir)
----------------------------------------------------------------
-- | Get path to sandbox config file
getSandboxDb :: FilePath -- ^ Path to the cabal package root directory
-- (containing the @cabal.sandbox.config@ file)
-> IO (Maybe FilePath)
getSandboxDb d = do
mConf <- traverse readFile =<< U.mightExist (d </> "cabal.sandbox.config")
return $ extractSandboxDbDir =<< mConf
-- | Extract the sandbox package db directory from the cabal.sandbox.config file.
-- Exception is thrown if the sandbox config file is broken.
extractSandboxDbDir :: String -> Maybe FilePath
extractSandboxDbDir conf = extractValue <$> parse conf
where
key = "package-db:"
keyLen = length key
parse = listToMaybe . filter (key `isPrefixOf`) . lines
extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
setupConfigFile :: Cradle -> FilePath
setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
setupConfigPath :: FilePath
setupConfigPath = localBuildInfoFile defaultDistPref
packageCache :: String
packageCache = "package.cache"

View File

@ -1,11 +1,16 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Utils where
import Control.Arrow
import Data.Char
import Language.Haskell.GhcMod.Error
import MonadUtils (MonadIO, liftIO)
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist)
import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode)
import System.Directory (getTemporaryDirectory)
import System.FilePath (splitDrive, joinDrive, pathSeparators)
import System.IO.Temp (createTempDirectory)
#ifndef SPEC
import Control.Applicative ((<$>))
import System.Environment
@ -48,6 +53,29 @@ withDirectory_ dir action =
gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
uniqTempDirName :: FilePath -> FilePath
uniqTempDirName dir =
uncurry (++)
$ map escapeDriveChar *** map escapePathChar
$ splitDrive dir
where
escapeDriveChar c
| isAlphaNum c = c
| otherwise = '-'
escapePathChar c
| c `elem` pathSeparators = '-'
| otherwise = c
newTempDir :: FilePath -> IO FilePath
newTempDir dir =
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
mightExist :: FilePath -> IO (Maybe FilePath)
mightExist f = do
exists <- doesFileExist f
return $ if exists then (Just f) else (Nothing)
-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
-- this is a guess but >=7.6 uses 'getExecutablePath'.
ghcModExecutable :: IO FilePath

View File

@ -0,0 +1,89 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.World where
{-(
, World
, getCurrentWorld
, isWorldChanged
) where
-}
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Control.Applicative (pure,(<$>),(<*>))
import Data.Maybe
import Data.Traversable (traverse)
import System.Directory (getModificationTime)
import System.FilePath ((</>))
import GHC.Paths (libdir)
#if __GLASGOW_HASKELL__ <= 704
import System.Time (ClockTime)
#else
import Data.Time (UTCTime)
#endif
#if __GLASGOW_HASKELL__ <= 704
type ModTime = ClockTime
#else
type ModTime = UTCTime
#endif
data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show)
instance Ord TimedFile where
compare (TimedFile _ a) (TimedFile _ b) = compare a b
timeFile :: FilePath -> IO TimedFile
timeFile f = TimedFile <$> pure f <*> getModificationTime f
data World = World {
worldPackageCaches :: [TimedFile]
, worldCabalFile :: Maybe TimedFile
, worldCabalConfig :: Maybe TimedFile
} deriving (Eq, Show)
timedPackageCache :: Cradle -> IO [TimedFile]
timedPackageCache crdl = do
fs <- mapM mightExist . map (</> packageCache)
=<< getPackageCachePaths libdir crdl
timeFile `mapM` catMaybes fs
getCurrentWorld :: Cradle -> IO World
getCurrentWorld crdl = do
pkgCaches <- timedPackageCache crdl
mCabalFile <- timeFile `traverse` cradleCabalFile crdl
mSetupConfig <- mightExist (setupConfigFile crdl)
mCabalConfig <- timeFile `traverse` mSetupConfig
return World {
worldPackageCaches = pkgCaches
, worldCabalFile = mCabalFile
, worldCabalConfig = mCabalConfig
}
didWorldChange :: World -> Cradle -> IO Bool
didWorldChange world crdl = do
(world /=) <$> getCurrentWorld crdl
-- * Neither file exists -> should return False:
-- @Nothing < Nothing = False@
-- (since we don't need to @cabal configure@ when no cabal file exists.)
--
-- * Cabal file doesn't exist (unlikely case) -> should return False
-- @Just cc < Nothing = False@
-- TODO: should we delete dist/setup-config?
--
-- * dist/setup-config doesn't exist yet -> should return True:
-- @Nothing < Just cf = True@
--
-- * Both files exist
-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@
isSetupConfigOutOfDate :: Cradle -> IO Bool
isSetupConfigOutOfDate crdl = do
world <- getCurrentWorld crdl
return $ worldCabalConfig world < worldCabalFile world

View File

@ -88,12 +88,14 @@ Library
Language.Haskell.GhcMod.Logger
Language.Haskell.GhcMod.Modules
Language.Haskell.GhcMod.Monad
Language.Haskell.GhcMod.PathsAndFiles
Language.Haskell.GhcMod.PkgDoc
Language.Haskell.GhcMod.Read
Language.Haskell.GhcMod.SrcUtils
Language.Haskell.GhcMod.Target
Language.Haskell.GhcMod.Types
Language.Haskell.GhcMod.Utils
Language.Haskell.GhcMod.World
Build-Depends: base >= 4.0 && < 5
, containers
, deepseq
@ -136,11 +138,13 @@ Executable ghc-mod
Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src
Build-Depends: base >= 4.0 && < 5
, async
, data-default
, directory
, filepath
, pretty
, process
, split
, mtl >= 2.0
, ghc
, ghc-mod
@ -185,18 +189,18 @@ Test-Suite spec
Hs-Source-Dirs: test, .
Ghc-Options: -Wall
Type: exitcode-stdio-1.0
Other-Modules: Dir
Spec
BrowseSpec
Other-Modules: BrowseSpec
CabalApiSpec
CheckSpec
Dir
FlagSpec
InfoSpec
LangSpec
LintSpec
ListSpec
MonadSpec
GhcPkgSpec
PathsAndFilesSpec
Spec
TestUtils
Build-Depends: base >= 4.0 && < 5
, containers

View File

@ -1,34 +1,47 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
module Main where
import Config (cProjectVersion)
import MonadUtils (liftIO)
import Control.Applicative
import Control.Exception (Exception, Handler(..), catches, throw)
import Control.Monad
import Control.Exception ( SomeException(..), fromException, Exception
, Handler(..), catches, throw)
import Data.Typeable (Typeable)
import Data.Version (showVersion)
import Data.Default
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Char (isSpace)
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
import Paths_ghc_mod
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O
import System.Environment (getArgs)
import System.Directory (setCurrentDirectory)
import System.Environment (getArgs,getProgName)
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8)
--import System.Process (rawSystem)
--import System.Exit (exitWith)
import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush)
import System.IO.Unsafe (unsafePerformIO)
import System.FilePath (takeFileName)
import System.Exit (ExitCode, exitSuccess)
import Text.PrettyPrint
----------------------------------------------------------------
import Misc
progVersion :: String
progVersion =
"ghc-mod version " ++ showVersion version ++ " compiled by GHC "
progName ++ " version " ++ showVersion version ++ " compiled by GHC "
++ cProjectVersion ++ "\n"
-- TODO: remove (ghc) version prefix!
progName :: String
progName = unsafePerformIO $ takeFileName <$> getProgName
optionUsage :: (String -> String) -> [OptDescr a] -> [String]
optionUsage indent opts = concatMap optUsage opts
where
@ -52,9 +65,15 @@ optionUsage indent opts = concatMap optUsage opts
ReqArg _ label -> s ++ label
OptArg _ label -> s ++ "["++label++"]"
-- TODO: Generate the stuff below automatically
usage :: String
usage =
case progName of
"ghc-modi" -> ghcModiUsage
_ -> ghcModUsage
-- TODO: Generate the stuff below automatically
ghcModUsage :: String
ghcModUsage =
"Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\
\*Global Options (OPTIONS)*\n\
\ Global options can be specified before and after the command and\n\
@ -62,7 +81,7 @@ usage =
\\n"
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
"*Commands*\n\
\ - version\n\
\ - version | --version\n\
\ Print the version of the program.\n\
\\n\
\ - help | --help\n\
@ -194,6 +213,23 @@ usage =
where
indent = (" "++)
ghcModiUsage :: String
ghcModiUsage =
"Usage: ghc-modi [OPTIONS...] COMMAND\n\
\*Options*\n"
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
"*Commands*\n\
\ - version | --version\n\
\ Print the version of the program.\n\
\\n\
\ - help | --help\n\
\ Print this help message.\n"
where
indent = (" "++)
cmdUsage :: String -> String -> String
cmdUsage cmd s =
let
@ -242,12 +278,13 @@ globalArgSpec =
reqArg "PROG" $ \p o -> o { cabalProgram = p }
]
parseGlobalArgs ::[String] -> (Options, [String])
parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
parseGlobalArgs argv
= case O.getOpt RequireOrder globalArgSpec argv of
(o,r,[] ) -> (foldr id defaultOptions o, r)
(_,_,errs) ->
fatalError $ "Parsing command line options failed: \n" ++ concat errs
(o,r,[] ) -> Right $ (foldr id defaultOptions o, r)
(_,_,errs) -> Left $ InvalidCommandLine $ Right $
"Parsing command line options failed: " ++ concat errs
parseCommandArgs :: [OptDescr (Options -> Options)]
-> [String]
@ -257,7 +294,7 @@ parseCommandArgs spec argv opts
= case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of
(o,r,[]) -> (foldr id opts o, r)
(_,_,errs) ->
fatalError $ "Parsing command options failed: \n" ++ concat errs
fatalError $ "Parsing command options failed: " ++ concat errs
----------------------------------------------------------------
@ -284,9 +321,9 @@ handler = flip catches $
, Handler $ \(InvalidCommandLine e) -> do
case e of
Left cmd ->
exitError $ (cmdUsage cmd usage)
++ "\nghc-mod: Invalid command line form."
Right msg -> exitError msg
exitError $ (cmdUsage cmd ghcModUsage) ++ "\n"
++ progName ++ ": Invalid command line form."
Right msg -> exitError $ progName ++ ": " ++ msg
]
main :: IO ()
@ -294,6 +331,20 @@ main = handler $ do
hSetEncoding stdout utf8
args <- getArgs
-- This doesn't handle --help and --version being given after any global
-- options. To do that we'd have to fiddle with getOpt.
case parseGlobalArgs args of
Left e -> case globalCommands args of
Just s -> putStr s
Nothing -> throw e
Right res@(_,cmdArgs) ->
case globalCommands cmdArgs of
Just s -> putStr s
Nothing -> progMain res
progMain :: (Options,[String]) -> IO ()
progMain (globalOptions,cmdArgs) = do
-- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
-- _realGhcArgs = filter (/="--ghc-mod") ghcArgs
@ -302,7 +353,11 @@ main = handler $ do
-- stripSeperator ("--":rest) = rest
-- stripSeperator l = l
case args of
case progName of
"ghc-modi" -> do
legacyInteractive globalOptions =<< emptyNewUnGetLine
_
-- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do
-- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith
@ -322,14 +377,9 @@ main = handler $ do
| otherwise -> do
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
(res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs
case res of
Right s -> putStr s
Left e -> exitError $ render (gmeDoc e)
-- Obtain ghc options by letting ourselfs be executed by
@ -343,15 +393,102 @@ main = handler $ do
-- rawSystem "cabal" cabalArgs >>= exitWith
simpleCommands :: [String] -> IO (Maybe String)
simpleCommands [] = return Nothing
simpleCommands (cmd:_) = return $ case cmd of
-- ghc-modi
legacyInteractive :: Options -> UnGetLine -> IO ()
legacyInteractive opt ref = flip catches handlers $ do
(res,_) <- runGhcModT opt $ do
symdbreq <- liftIO $ newSymDbReq opt
world <- liftIO . getCurrentWorld =<< cradle
legacyInteractiveLoop symdbreq ref world
case res of
Right () -> return ()
Left e -> putStrLn $ notGood $ render (gmeDoc e)
where
handlers = [ Handler $ \Restart -> legacyInteractive opt ref ]
isExitCodeException :: SomeException -> Bool
isExitCodeException e = isJust mExitCode
where
mExitCode :: Maybe ExitCode
mExitCode = fromException e
bug :: String -> IO ()
bug msg = do
putStrLn $ notGood $ "BUG: " ++ msg
exitFailure
notGood :: String -> String
notGood msg = "NG " ++ escapeNewlines msg
escapeNewlines :: String -> String
escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
replace :: String -> String -> String -> String
replace needle replacement = intercalate replacement . splitOn needle
legacyInteractiveLoop :: IOish m
=> SymDbReq -> UnGetLine -> World -> GhcModT m ()
legacyInteractiveLoop symdbreq ref world = do
liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
-- blocking
cmdArg <- liftIO $ getCommand ref
-- after blocking, we need to see if the world has changed.
changed <- liftIO . didWorldChange world =<< cradle
when changed $ do
liftIO $ ungetCommand ref cmdArg
throw Restart
liftIO . prepareAutogen =<< cradle
let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg
arg = concat args'
cmd = dropWhileEnd isSpace cmd'
args = dropWhileEnd isSpace `map` args'
res <- case dropWhileEnd isSpace cmd of
"check" -> checkSyntaxCmd [arg]
"lint" -> lintCmd [arg]
"find" -> do
db <- getDb symdbreq >>= checkDb symdbreq
lookupSymbol arg db
"info" -> infoCmd [head args, concat $ tail args']
"type" -> typesCmd args
"split" -> splitsCmd args
"sig" -> sigCmd args
"auto" -> autoCmd args
"refine" -> refineCmd args
"boot" -> bootCmd []
"browse" -> browseCmd args
"quit" -> liftIO $ exitSuccess
"" -> liftIO $ exitSuccess
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout
legacyInteractiveLoop symdbreq ref world
globalCommands :: [String] -> Maybe String
globalCommands [] = Nothing
globalCommands (cmd:_) = case cmd of
_ | cmd == "help" || cmd == "--help" -> Just usage
"version" -> Just progVersion
_ | cmd == "version" || cmd == "--version" -> Just progVersion
_ -> Nothing
ghcCommands :: IOish m => [String] -> GhcModT m String
ghcCommands [] = fatalError "No command given (try --help)\n"
ghcCommands [] = fatalError "No command given (try --help)"
ghcCommands (cmd:args) = fn args
where
fn = case cmd of
@ -387,7 +524,7 @@ exitError :: String -> IO a
exitError msg = hPutStrLn stderr msg >> exitFailure
fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
fatalError s = throw $ FatalError $ progName ++ ": " ++ s
withParseCmd :: IOish m
=> [OptDescr (Options -> Options)]

View File

@ -1,5 +1,9 @@
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
-- | WARNING
-- This program in the process of being deprecated, use `ghc-mod --interactive`
-- instead.
-- Commands:
-- check <file>
-- find <symbol>
@ -130,7 +134,7 @@ loop symdbreq ref world = do
cmdArg <- liftIO $ getCommand ref
-- after blocking, we need to see if the world has changed.
crdl <- cradle
changed <- liftIO $ isWorldChanged world crdl
changed <- liftIO $ didWorldChange world crdl
when changed $ do
liftIO $ ungetCommand ref cmdArg
E.throw Restart

View File

@ -1,9 +1,10 @@
{-# LANGUAGE CPP #-}
module GhcPkgSpec where
module PathsAndFilesSpec where
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
#if __GLASGOW_HASKELL__ <= 706
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
#endif
import System.Directory
@ -23,7 +24,7 @@ spec = do
it "can parse a config file and extract the sandbox package-db" $ do
cwd <- getCurrentDirectory
pkgDb <- getSandboxDb "test/data/"
pkgDb `shouldBe` (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")
pkgDb `shouldBe` Just (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")
it "throws an error if the sandbox config file is broken" $ do
getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException
it "returns Nothing if the sandbox config file is broken" $ do
getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing