hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into release

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
Language/Haskell/GhcMod/CabalConfig.hs
View File

@ -6,17 +6,15 @@ module Language.Haskell.GhcMod.CabalConfig (
CabalConfig CabalConfig
, cabalConfigDependencies , cabalConfigDependencies
, cabalConfigFlags , cabalConfigFlags
, setupConfigFile
, World
, getCurrentWorld
, isWorldChanged
) where ) where
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Read
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
import qualified Language.Haskell.GhcMod.Cabal16 as C16 import qualified Language.Haskell.GhcMod.Cabal16 as C16
import qualified Language.Haskell.GhcMod.Cabal18 as C18 import qualified Language.Haskell.GhcMod.Cabal18 as C18
@ -27,32 +25,19 @@ import qualified Language.Haskell.GhcMod.Cabal21 as C21
#endif #endif
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (unless, void, mplus) import Control.Monad (void, mplus, when)
#if MIN_VERSION_mtl(2,2,1) #if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except () import Control.Monad.Except ()
#else #else
import Control.Monad.Error () import Control.Monad.Error ()
#endif #endif
import Data.Maybe ()
import Data.Set ()
import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)
import Distribution.Package (InstalledPackageId(..) import Distribution.Package (InstalledPackageId(..)
, PackageIdentifier(..) , PackageIdentifier(..)
, PackageName(..)) , PackageName(..))
import Distribution.PackageDescription (FlagAssignment) import Distribution.PackageDescription (FlagAssignment)
import Distribution.Simple.BuildPaths (defaultDistPref)
import Distribution.Simple.Configure (localBuildInfoFile)
import Distribution.Simple.LocalBuildInfo (ComponentName) import Distribution.Simple.LocalBuildInfo (ComponentName)
import Data.Traversable (traverse)
import MonadUtils (liftIO) 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 => Cradle
-> m CabalConfig -> m CabalConfig
getConfig cradle = do getConfig cradle = do
world <- liftIO $ getCurrentWorld cradle outOfDate <- liftIO $ isSetupConfigOutOfDate cradle
let valid = isSetupConfigValid world when outOfDate configure
unless valid configure
liftIO (readFile file) `tryFix` \_ -> liftIO (readFile file) `tryFix` \_ ->
configure `modifyError'` GMECabalConfigure configure `modifyError'` GMECabalConfigure
where where
@ -78,14 +62,6 @@ getConfig cradle = do
configure :: (IOish m, MonadError GhcModError m) => m () configure :: (IOish m, MonadError GhcModError m) => m ()
configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] 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 -- | Get list of 'Package's needed by all components of the current package
cabalConfigDependencies :: (IOish m, MonadError GhcModError m) cabalConfigDependencies :: (IOish m, MonadError GhcModError m)
=> Cradle => Cradle
@ -193,57 +169,3 @@ extractField config field =
case extractParens <$> find (field `isPrefixOf`) (tails config) of case extractParens <$> find (field `isPrefixOf`) (tails config) of
Just f -> Right f Just f -> Right f
Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config) 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

85
Language/Haskell/GhcMod/Cradle.hs
View File

@ -5,17 +5,14 @@ module Language.Haskell.GhcMod.Cradle (
, cleanupCradle , cleanupCradle
) where ) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg 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.Exception.IOChoice ((||>))
import Control.Monad (filterM) import System.Directory (getCurrentDirectory, removeDirectoryRecursive)
import Data.List (isSuffixOf) import System.FilePath (takeDirectory)
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive)
import System.FilePath ((</>), takeDirectory)
import System.IO.Temp
---------------------------------------------------------------- ----------------------------------------------------------------
@ -30,38 +27,31 @@ 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 :: Cradle -> IO ()
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
cabalCradle :: FilePath -> IO Cradle cabalCradle :: FilePath -> IO Cradle
cabalCradle wdir = do cabalCradle wdir = do
(rdir,cfile) <- cabalDir wdir Just cabalFile <- findCabalFiles wdir
pkgDbStack <- getPackageDbStack rdir let cabalDir = takeDirectory cabalFile
tmpDir <- newTempDir rdir pkgDbStack <- getPackageDbStack cabalDir
tmpDir <- newTempDir cabalDir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = rdir , cradleRootDir = cabalDir
, cradleTempDir = tmpDir , cradleTempDir = tmpDir
, cradleCabalFile = Just cfile , cradleCabalFile = Just cabalFile
, cradlePkgDbStack = pkgDbStack , cradlePkgDbStack = pkgDbStack
} }
sandboxCradle :: FilePath -> IO Cradle sandboxCradle :: FilePath -> IO Cradle
sandboxCradle wdir = do sandboxCradle wdir = do
rdir <- getSandboxDir wdir Just sbDir <- getSandboxDb wdir
pkgDbStack <- getPackageDbStack rdir pkgDbStack <- getPackageDbStack sbDir
tmpDir <- newTempDir rdir tmpDir <- newTempDir sbDir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = rdir , cradleRootDir = sbDir
, cradleTempDir = tmpDir , cradleTempDir = tmpDir
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePkgDbStack = pkgDbStack , cradlePkgDbStack = pkgDbStack
@ -83,48 +73,3 @@ findCradleWithoutSandbox :: IO Cradle
findCradleWithoutSandbox = do findCradleWithoutSandbox = do
cradle <- findCradle cradle <- findCradle
return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME 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

20
Language/Haskell/GhcMod/Error.hs
View File

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

4
Language/Haskell/GhcMod/Find.hs
View File

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

81
Language/Haskell/GhcMod/GhcPkg.hs
View File

@ -6,63 +6,34 @@ module Language.Haskell.GhcMod.GhcPkg (
, ghcDbOpt , ghcDbOpt
, fromInstalledPackageId , fromInstalledPackageId
, fromInstalledPackageId' , fromInstalledPackageId'
, getSandboxDb
, getPackageDbStack , getPackageDbStack
, getPackageCachePath , getPackageCachePaths
, packageCache
, packageConfDir
) where ) where
import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception (SomeException(..)) import Data.List (intercalate)
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.List.Split (splitOn)
import Data.Maybe import Data.Maybe
import Distribution.Package (InstalledPackageId(..)) import Distribution.Package (InstalledPackageId(..))
import Exception (handleIO) import Exception (handleIO)
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
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
-- | 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 getPackageDbStack :: FilePath -- ^ Project Directory (where the
-- cabal.sandbox.config file would be if it -- cabal.sandbox.config file would be if it
-- exists) -- exists)
-> IO [GhcPkgDb] -> IO [GhcPkgDb]
getPackageDbStack cdir = getPackageDbStack cdir = do
(getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db]) mSDir <- getSandboxDb cdir
`E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb] 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 getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath]
packageConfDir = "package.conf.d" 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 :/ --- Copied from ghc module `Packages' unfortunately it's not exported :/
resolvePath :: GhcPkgDb -> IO (Maybe FilePath) resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath)
resolvePath (PackageDb name) = return $ Just name resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg
resolvePath UserDb = handleIO (\_ -> return Nothing) $ do resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do
appdir <- getAppUserDataDirectory "ghc" appdir <- getAppUserDataDirectory "ghc"
let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion) let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
pkgconf = dir </> packageConfDir pkgconf = dir </> "package.conf.d"
exist <- doesDirectoryExist pkgconf exist <- doesDirectoryExist pkgconf
return $ if exist then Just pkgconf else Nothing return $ if exist then Just pkgconf else Nothing
where where
[target_arch,_,target_os] = splitOn "-" cTargetPlatformString [target_arch,_,target_os] = splitOn "-" cTargetPlatformString
resolvePath _ = error "GlobalDb cannot be used in resolvePath" resolvePackageConfig _ (PackageDb name) = return $ Just name

4
Language/Haskell/GhcMod/Internal.hs
View File

@ -52,13 +52,12 @@ module Language.Haskell.GhcMod.Internal (
-- * World -- * World
, World , World
, getCurrentWorld , getCurrentWorld
, isWorldChanged , didWorldChange
) where ) where
import GHC.Paths (libdir) import GHC.Paths (libdir)
import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.CabalConfig
import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.GHCChoice
@ -67,6 +66,7 @@ import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
-- | Obtaining the directory for ghc system libraries. -- | Obtaining the directory for ghc system libraries.
ghcLibDir :: FilePath ghcLibDir :: FilePath

27
Language/Haskell/GhcMod/Monad.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} {-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad ( module Language.Haskell.GhcMod.Monad (
@ -101,7 +102,6 @@ import Control.Monad.Journal.Class
import Data.Maybe (fromJust, isJust) import Data.Maybe (fromJust, isJust)
import Data.IORef (IORef, readIORef, writeIORef, newIORef) import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import System.Directory (getCurrentDirectory) 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 instance MonadIO m => MonadIO (GhcModT m) where
liftIO action = do liftIO action = do
res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ tryIOError action res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action
case res of case res of
Right a -> return a Right a -> return a
Left e -> case show e of
"" -> throwError $ noMsg Left e | isIOError e ->
msg -> throwError $ strMsg msg 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 instance MonadTrans (GhcModT) where
lift = GhcModT . lift . lift . lift . lift lift = GhcModT . lift . lift . lift . lift

108
Language/Haskell/GhcMod/PathsAndFiles.hs Normal file
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"

30
Language/Haskell/GhcMod/Utils.hs
View File

@ -1,11 +1,16 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Utils where module Language.Haskell.GhcMod.Utils where
import Control.Arrow
import Data.Char
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, doesFileExist)
import System.Exit (ExitCode(..)) import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode) import System.Process (readProcessWithExitCode)
import System.Directory (getTemporaryDirectory)
import System.FilePath (splitDrive, joinDrive, pathSeparators)
import System.IO.Temp (createTempDirectory)
#ifndef SPEC #ifndef SPEC
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import System.Environment import System.Environment
@ -48,6 +53,29 @@ withDirectory_ dir action =
gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action) (\_ -> 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 -- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
-- this is a guess but >=7.6 uses 'getExecutablePath'. -- this is a guess but >=7.6 uses 'getExecutablePath'.
ghcModExecutable :: IO FilePath ghcModExecutable :: IO FilePath

89
Language/Haskell/GhcMod/World.hs Normal file
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

12
ghc-mod.cabal
View File

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

209
src/GHCMod.hs
View File

@ -1,33 +1,46 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
module Main where module Main where
import Config (cProjectVersion) import Config (cProjectVersion)
import MonadUtils (liftIO)
import Control.Applicative 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.Typeable (Typeable)
import Data.Version (showVersion) import Data.Version (showVersion)
import Data.Default import Data.Default
import Data.List import Data.List
import Data.List.Split
import Data.Maybe
import Data.Char (isSpace) import Data.Char (isSpace)
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.Internal
import Paths_ghc_mod import Paths_ghc_mod
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O 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.Exit (exitFailure)
import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8) import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush)
--import System.Process (rawSystem) import System.IO.Unsafe (unsafePerformIO)
--import System.Exit (exitWith) import System.FilePath (takeFileName)
import System.Exit (ExitCode, exitSuccess)
import Text.PrettyPrint import Text.PrettyPrint
---------------------------------------------------------------- import Misc
progVersion :: String progVersion :: String
progVersion = progVersion =
"ghc-mod version " ++ showVersion version ++ " compiled by GHC " progName ++ " version " ++ showVersion version ++ " compiled by GHC "
++ cProjectVersion ++ "\n" ++ cProjectVersion ++ "\n"
-- TODO: remove (ghc) version prefix!
progName :: String
progName = unsafePerformIO $ takeFileName <$> getProgName
optionUsage :: (String -> String) -> [OptDescr a] -> [String] optionUsage :: (String -> String) -> [OptDescr a] -> [String]
optionUsage indent opts = concatMap optUsage opts optionUsage indent opts = concatMap optUsage opts
@ -52,9 +65,15 @@ optionUsage indent opts = concatMap optUsage opts
ReqArg _ label -> s ++ label ReqArg _ label -> s ++ label
OptArg _ label -> s ++ "["++label++"]" OptArg _ label -> s ++ "["++label++"]"
-- TODO: Generate the stuff below automatically
usage :: String usage :: String
usage = usage =
case progName of
"ghc-modi" -> ghcModiUsage
_ -> ghcModUsage
-- TODO: Generate the stuff below automatically
ghcModUsage :: String
ghcModUsage =
"Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\ "Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\
\*Global Options (OPTIONS)*\n\ \*Global Options (OPTIONS)*\n\
\ Global options can be specified before and after the command and\n\ \ Global options can be specified before and after the command and\n\
@ -62,7 +81,7 @@ usage =
\\n" \\n"
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++ ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
"*Commands*\n\ "*Commands*\n\
\ - version\n\ \ - version | --version\n\
\ Print the version of the program.\n\ \ Print the version of the program.\n\
\\n\ \\n\
\ - help | --help\n\ \ - help | --help\n\
@ -194,6 +213,23 @@ usage =
where where
indent = (" "++) 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 :: String -> String -> String
cmdUsage cmd s = cmdUsage cmd s =
let let
@ -242,12 +278,13 @@ globalArgSpec =
reqArg "PROG" $ \p o -> o { cabalProgram = p } reqArg "PROG" $ \p o -> o { cabalProgram = p }
] ]
parseGlobalArgs ::[String] -> (Options, [String])
parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
parseGlobalArgs argv parseGlobalArgs argv
= case O.getOpt RequireOrder globalArgSpec argv of = case O.getOpt RequireOrder globalArgSpec argv of
(o,r,[] ) -> (foldr id defaultOptions o, r) (o,r,[] ) -> Right $ (foldr id defaultOptions o, r)
(_,_,errs) -> (_,_,errs) -> Left $ InvalidCommandLine $ Right $
fatalError $ "Parsing command line options failed: \n" ++ concat errs "Parsing command line options failed: " ++ concat errs
parseCommandArgs :: [OptDescr (Options -> Options)] parseCommandArgs :: [OptDescr (Options -> Options)]
-> [String] -> [String]
@ -257,7 +294,7 @@ parseCommandArgs spec argv opts
= case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of
(o,r,[]) -> (foldr id opts o, r) (o,r,[]) -> (foldr id opts o, r)
(_,_,errs) -> (_,_,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 , Handler $ \(InvalidCommandLine e) -> do
case e of case e of
Left cmd -> Left cmd ->
exitError $ (cmdUsage cmd usage) exitError $ (cmdUsage cmd ghcModUsage) ++ "\n"
++ "\nghc-mod: Invalid command line form." ++ progName ++ ": Invalid command line form."
Right msg -> exitError msg Right msg -> exitError $ progName ++ ": " ++ msg
] ]
main :: IO () main :: IO ()
@ -294,6 +331,20 @@ main = handler $ do
hSetEncoding stdout utf8 hSetEncoding stdout utf8
args <- getArgs 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 -- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
-- _realGhcArgs = filter (/="--ghc-mod") ghcArgs -- _realGhcArgs = filter (/="--ghc-mod") ghcArgs
@ -302,7 +353,11 @@ main = handler $ do
-- stripSeperator ("--":rest) = rest -- stripSeperator ("--":rest) = rest
-- stripSeperator l = l -- stripSeperator l = l
case args of case progName of
"ghc-modi" -> do
legacyInteractive globalOptions =<< emptyNewUnGetLine
_ _
-- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do -- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do
-- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith -- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith
@ -322,14 +377,9 @@ main = handler $ do
| otherwise -> do | otherwise -> do
let (globalOptions,cmdArgs) = parseGlobalArgs args (res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs
res <- simpleCommands cmdArgs case res of
putStr =<< case res of Right s -> putStr s
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
@ -343,15 +393,102 @@ main = handler $ do
-- rawSystem "cabal" cabalArgs >>= exitWith -- rawSystem "cabal" cabalArgs >>= exitWith
simpleCommands :: [String] -> IO (Maybe String)
simpleCommands [] = return Nothing
simpleCommands (cmd:_) = return $ case cmd of -- ghc-modi
_ | cmd == "help" || cmd == "--help" -> Just usage legacyInteractive :: Options -> UnGetLine -> IO ()
"version" -> Just progVersion legacyInteractive opt ref = flip catches handlers $ do
_ -> Nothing (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
_ | cmd == "version" || cmd == "--version" -> Just progVersion
_ -> Nothing
ghcCommands :: IOish m => [String] -> GhcModT m String 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 ghcCommands (cmd:args) = fn args
where where
fn = case cmd of fn = case cmd of
@ -387,7 +524,7 @@ exitError :: String -> IO a
exitError msg = hPutStrLn stderr msg >> exitFailure exitError msg = hPutStrLn stderr msg >> exitFailure
fatalError :: String -> a fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s fatalError s = throw $ FatalError $ progName ++ ": " ++ s
withParseCmd :: IOish m withParseCmd :: IOish m
=> [OptDescr (Options -> Options)] => [OptDescr (Options -> Options)]

6
src/GHCModi.hs
View File

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

11
test/GhcPkgSpec.hs → test/PathsAndFilesSpec.hs
View File

@ -1,9 +1,10 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module GhcPkgSpec where module PathsAndFilesSpec where
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.PathsAndFiles
#if __GLASGOW_HASKELL__ <= 706 #if __GLASGOW_HASKELL__ <= 706
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
#endif #endif
import System.Directory import System.Directory
@ -23,7 +24,7 @@ spec = do
it "can parse a config file and extract the sandbox package-db" $ do it "can parse a config file and extract the sandbox package-db" $ do
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
pkgDb <- getSandboxDb "test/data/" 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 it "returns Nothing if the sandbox config file is broken" $ do
getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing