packages feed

ghc-mod 5.2.0.0 → 5.2.1.0

raw patch · 17 files changed

+535/−296 lines, 17 filesdep ~ghcdep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc, mtl

API changes (from Hackage documentation)

- Language.Haskell.GhcMod.Internal: isWorldChanged :: World -> Cradle -> IO Bool
+ Language.Haskell.GhcMod: GMEIOException :: IOException -> GhcModError
+ Language.Haskell.GhcMod: GMENoCabalFile :: GhcModError
+ Language.Haskell.GhcMod: GMETooManyCabalFiles :: [FilePath] -> GhcModError
+ Language.Haskell.GhcMod.Internal: didWorldChange :: World -> Cradle -> IO Bool

Files

ChangeLog view
@@ -1,3 +1,8 @@+2014-11-02 v5.2.1.0+        * Fix `newTempDir` on Windows+        * GhcModT's liftIO instance now converts GhcMOdError exceptions+          into monadic failures+ 2014-10-30 v5.2.0.0         * Return type of `loadSymbolDb` is now in GhcModT         * Function `dumpSymbol` now takes the path of the target directory
Language/Haskell/GhcMod/CabalConfig.hs view
@@ -6,17 +6,15 @@     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,33 +25,20 @@ #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- ----------------------------------------------------------------  -- | 'Show'ed cabal 'LocalBuildInfo' string@@ -66,9 +51,8 @@           => 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 @@    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 @@     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
Language/Haskell/GhcMod/Cradle.hs view
@@ -5,17 +5,14 @@   , 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' :: 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 = 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
Language/Haskell/GhcMod/Error.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-} module Language.Haskell.GhcMod.Error (     GhcModError(..)   , gmeDoc@@ -10,6 +10,8 @@   ) where  import Control.Monad.Error (MonadError(..), Error(..))+import Data.List+import Data.Typeable import Exception import Text.PrettyPrint @@ -18,6 +20,8 @@                  | 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,8 +29,13 @@                  | 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     strMsg = GMEString@@ -37,6 +46,8 @@         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 @@     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
Language/Haskell/GhcMod/Find.hs view
@@ -22,10 +22,10 @@ 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 @@ 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 {
Language/Haskell/GhcMod/GhcPkg.hs view
@@ -6,63 +6,34 @@   , 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 @@  ---------------------------------------------------------------- -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-    appdir <- getAppUserDataDirectory "ghc"-    let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)-        pkgconf = dir </> packageConfDir-    exist <- doesDirectoryExist pkgconf-    return $ if exist then Just pkgconf else Nothing-  where+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 </> "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
Language/Haskell/GhcMod/Internal.hs view
@@ -52,13 +52,12 @@   -- * 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.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
Language/Haskell/GhcMod/Monad.hs view
@@ -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 Data.Maybe (fromJust, isJust) import Data.IORef (IORef, readIORef, writeIORef, newIORef) import System.Directory (getCurrentDirectory)-import System.IO.Error (tryIOError)  ---------------------------------------------------------------- @@ -154,12 +154,29 @@  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
+ Language/Haskell/GhcMod/PathsAndFiles.hs view
@@ -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"
Language/Haskell/GhcMod/Utils.hs view
@@ -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, pathSeparators)+import System.IO.Temp (createTempDirectory) #ifndef SPEC import Control.Applicative ((<$>)) import System.Environment@@ -47,6 +52,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'.
+ Language/Haskell/GhcMod/World.hs view
@@ -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
elisp/ghc.el view
@@ -28,7 +28,7 @@ 	       (< emacs-minor-version minor)))       (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "5.2.0.0")+(defconst ghc-version "5.2.1.0")  ;; (eval-when-compile ;;  (require 'haskell-mode))
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name:                   ghc-mod-Version:                5.2.0.0+Version:                5.2.1.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp>                         Daniel Gröber <dxld@darkboxed.org>                         Alejandro Serrano <trupill@gmail.com>@@ -88,12 +88,14 @@                         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 @@   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 @@   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
src/GHCMod.hs view
@@ -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 "-                       ++ cProjectVersion ++ "\n"+    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 @@             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 @@  \\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 @@  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 @@                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 @@     = 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 $ \(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 @@     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 @@     --     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 @@             | 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 @@                -- rawSystem "cabal" cabalArgs >>= exitWith -simpleCommands :: [String] -> IO (Maybe String)-simpleCommands []      = return Nothing-simpleCommands (cmd:_) = return $ case cmd of-    _ | cmd == "help" || cmd == "--help"  -> Just usage-    "version" -> Just progVersion-    _         -> Nothing ++-- 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+    _ | 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 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)]
src/GHCModi.hs view
@@ -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 @@     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
− test/GhcPkgSpec.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE CPP #-}-module GhcPkgSpec where--import Language.Haskell.GhcMod.GhcPkg-#if __GLASGOW_HASKELL__ <= 706-import Language.Haskell.GhcMod.Types-#endif--import System.Directory-import System.FilePath ((</>))-import Test.Hspec--spec :: Spec-spec = do-    describe "getSandboxDb" $ do--- ghc < 7.8-#if __GLASGOW_HASKELL__ <= 706-        it "does include a sandbox with ghc < 7.8" $ do-            cwd <- getCurrentDirectory-            getPackageDbStack "test/data/" `shouldReturn` [GlobalDb, PackageDb $ cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]-#endif--        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")--        it "throws an error if the sandbox config file is broken" $ do-            getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException
+ test/PathsAndFilesSpec.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+module PathsAndFilesSpec where++import Language.Haskell.GhcMod.PathsAndFiles+#if __GLASGOW_HASKELL__ <= 706+import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.GhcPkg+#endif++import System.Directory+import System.FilePath ((</>))+import Test.Hspec++spec :: Spec+spec = do+    describe "getSandboxDb" $ do+-- ghc < 7.8+#if __GLASGOW_HASKELL__ <= 706+        it "does include a sandbox with ghc < 7.8" $ do+            cwd <- getCurrentDirectory+            getPackageDbStack "test/data/" `shouldReturn` [GlobalDb, PackageDb $ cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]+#endif++        it "can parse a config file and extract the sandbox package-db" $ do+            cwd <- getCurrentDirectory+            pkgDb <- getSandboxDb "test/data/"+            pkgDb `shouldBe` Just (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")++        it "returns Nothing if the sandbox config file is broken" $ do+            getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing