Merge branch 'master' into release
Conflicts: elisp/ghc.el ghc-mod.cabal
This commit is contained in:
Daniel Gröber
commit
be1185fc58
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 {
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
108
Language/Haskell/GhcMod/PathsAndFiles.hs
Normal file
108
Language/Haskell/GhcMod/PathsAndFiles.hs
Normal 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"
|
||||
@ -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
|
||||
|
||||
89
Language/Haskell/GhcMod/World.hs
Normal file
89
Language/Haskell/GhcMod/World.hs
Normal 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
|
||||
@ -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
|
||||
|
||||
203
src/GHCMod.hs
203
src/GHCMod.hs
@ -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)]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
Loading…
Reference in New Issue
Block a user