diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index 7b34123..3e8623c 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -16,12 +16,12 @@ import Control.Applicative ((<$>)) import Control.Exception (throwIO) import Control.Monad (filterM) import CoreMonad (liftIO) -import Data.Maybe (maybeToList) +import Data.Maybe (maybeToList, catMaybes) import Data.Set (fromList, toList) import Distribution.ModuleName (ModuleName,toFilePath) import Distribution.Package (Dependency(Dependency) - , PackageName(PackageName) - , PackageIdentifier(pkgName)) + , PackageName(PackageName)) +import qualified Distribution.Package as C import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable) import qualified Distribution.PackageDescription as P import Distribution.PackageDescription.Configuration (finalizePackageDescription) @@ -45,30 +45,22 @@ getCompilerOptions :: [GHCOption] -> IO CompilerOptions getCompilerOptions ghcopts cradle pkgDesc = do gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos - dbPkgs <- getPackageDbPackages rdir + dbPkgs <- ghcPkgListEx (cradlePkgDbStack cradle) return $ CompilerOptions gopts idirs (depPkgs dbPkgs) where wdir = cradleCurrentDir cradle rdir = cradleRootDir cradle Just cfile = cradleCabalFile cradle - pkgs = cradlePackages cradle + thisPkg = dropExtension $ takeFileName cfile buildInfos = cabalAllBuildInfo pkgDesc idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos - depPkgs ps = attachPackageIds pkgs - $ removeThem problematicPackages - $ removeMe cfile - $ filter (`elem` ps) -- remove packages not available in any - -- package dbs + depPkgs ps = attachPackageIds ps + $ removeThem (problematicPackages ++ [thisPkg]) $ cabalDependPackages buildInfos ---------------------------------------------------------------- -- Dependent packages -removeMe :: FilePath -> [PackageBaseName] -> [PackageBaseName] -removeMe cabalfile = filter (/= me) - where - me = dropExtension $ takeFileName cabalfile - removeThem :: [PackageBaseName] -> [PackageBaseName] -> [PackageBaseName] removeThem badpkgs = filter (`notElem` badpkgs) @@ -78,11 +70,13 @@ problematicPackages = [ ] attachPackageIds :: [Package] -> [PackageBaseName] -> [Package] -attachPackageIds pkgs = map attachId - where - attachId x = case lookup x pkgs of - Nothing -> (x, Nothing) - Just p -> (x, p) +attachPackageIds pkgs = catMaybes . fmap (flip lookup3 pkgs) + +lookup3 :: Eq a => a -> [(a,b,c)] -> Maybe (a,b,c) +lookup3 _ [] = Nothing +lookup3 k (t@(a,_,_):ls) + | k == a = Just t + | otherwise = lookup3 k ls ---------------------------------------------------------------- -- Include directories for modules @@ -114,7 +108,7 @@ parseCabalFile file = do toPkgDesc cid = finalizePackageDescription [] (const True) buildPlatform cid [] nullPkg pd = name == "" where - PackageName name = pkgName (P.package pd) + PackageName name = C.pkgName (P.package pd) ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 71dcbb6..1e6e594 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -34,7 +34,6 @@ cabalCradle wdir = do , cradleRootDir = rdir , cradleCabalFile = Just cfile , cradlePkgDbStack = pkgDbStack - , cradlePackages = [] } sandboxCradle :: FilePath -> IO Cradle @@ -46,7 +45,6 @@ sandboxCradle wdir = do , cradleRootDir = rdir , cradleCabalFile = Nothing , cradlePkgDbStack = pkgDbStack - , cradlePackages = [] } plainCradle :: FilePath -> IO Cradle @@ -55,14 +53,13 @@ plainCradle wdir = return Cradle { , cradleRootDir = wdir , cradleCabalFile = Nothing , cradlePkgDbStack = [GlobalDb] - , cradlePackages = [] } -- Just for testing findCradleWithoutSandbox :: IO Cradle findCradleWithoutSandbox = do cradle <- findCradle - return cradle { cradlePkgDbStack = [GlobalDb], cradlePackages = [] } + return cradle { cradlePkgDbStack = [GlobalDb]} ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index bb6d7b4..6eb9403 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -40,7 +40,7 @@ debug opt cradle fileName = do , "Cabal file: " ++ cabalFile , "GHC options: " ++ unwords gopts , "Include directories: " ++ unwords incDir - , "Dependent packages: " ++ intercalate ", " (map fst pkgs) + , "Dependent packages: " ++ intercalate ", " (map showPkg pkgs) , "System libraries: " ++ fromMaybe "" mglibdir ] where diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index c1d62a5..3e30f5b 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -244,8 +244,7 @@ addDevPkgs df pkgs = df'' df'' = df' { packageFlags = map expose pkgs ++ packageFlags df } - expose (pkg, Nothing) = ExposePackage pkg - expose (_, Just pid) = ExposePackageId pid + expose pkg = ExposePackageId $ showPkgId pkg ---------------------------------------------------------------- ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index bf59984..278d2e3 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -1,24 +1,26 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-} module Language.Haskell.GhcMod.GhcPkg ( ghcPkgList + , ghcPkgListEx , ghcPkgDbOpt , ghcPkgDbStackOpts , ghcDbStackOpts , ghcDbOpt , getSandboxDb , getPackageDbStack - , getPackageDbPackages ) where import Config (cProjectVersionInt) -- ghc version -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*)) import Control.Exception (SomeException(..)) import qualified Control.Exception as E -import Data.Char (isSpace) -import Data.List (isPrefixOf) +import Data.Char (isSpace,isAlphaNum) +import Data.List (isPrefixOf, intercalate) +import Data.Maybe (listToMaybe, maybeToList) import Language.Haskell.GhcMod.Types import System.FilePath (()) import System.Process (readProcess) +import Text.ParserCombinators.ReadP ghcVersion :: Int ghcVersion = read cProjectVersionInt @@ -47,18 +49,6 @@ getSandboxDbDir sconf = do dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] --- | Get a list of packages from the global, user or cabal sandbox package --- database. --- --- If a sandbox exists this will return packages from the global package db --- and the sandbox, otherwise packages from the global and user package db are --- returned. -getPackageDbPackages :: FilePath -- ^ Project Directory (where the - -- cabal.sandbox.config file would be if it - -- exists) - -> IO [PackageBaseName] -getPackageDbPackages cdir = ghcPkgList =<< getPackageDbStack cdir - getPackageDbStack :: FilePath -- ^ Project Directory (where the -- cabal.sandbox.config file would be if it -- exists) @@ -68,11 +58,62 @@ getPackageDbStack cdir = `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb] --- | List packages in one or more ghc package stores +-- | List packages in one or more ghc package store ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName] -ghcPkgList dbs = words <$> readProcess "ghc-pkg" opts "" +ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs + where fst3 (x,_,_) = x + +ghcPkgListEx :: [GhcPkgDb] -> IO [Package] +ghcPkgListEx dbs = do + output <- readProcess "ghc-pkg" opts "" +-- hPutStrLn stderr output + return $ parseGhcPkgOutput $ lines output where - opts = ["--simple-output", "--names-only", "list"] ++ ghcPkgDbStackOpts dbs + opts = ["list", "-v"] ++ ghcPkgDbStackOpts dbs + +parseGhcPkgOutput :: [String] -> [Package] +parseGhcPkgOutput [] = [] +parseGhcPkgOutput (l:ls) = + parseGhcPkgOutput ls ++ case l of + [] -> [] + h:_ | isSpace h -> maybeToList $ packageLine l + | otherwise -> [] + +packageLine :: String -> Maybe Package +packageLine l = + case listToMaybe $ readP_to_S packageLineP l of + Just ((Normal,p),_) -> Just p + _ -> Nothing + +data PackageState = Normal | Hidden | Broken deriving (Eq,Show) + +packageLineP :: ReadP (PackageState, Package) +packageLineP = do + skipSpaces + choice [ (Hidden,) <$> between (char '(') (char ')') packageP + , (Broken,) <$> between (char '{') (char '}') packageP + , (Normal,) <$> packageP ] <* eof + +packageP :: ReadP (PackageBaseName, PackageVersion, PackageId) +packageP = do + pkgSpec@(name,ver) <- packageSpecP + skipSpaces + i <- between (char '(') (char ')') $ packageIdSpecP pkgSpec + return (name,ver,i) + +packageSpecP :: ReadP (PackageBaseName,PackageVersion) +packageSpecP = do + fs <- many1 packageCompCharP `sepBy1` char '-' + return (intercalate "-" (init fs), last fs) + +packageIdSpecP :: (PackageBaseName,PackageVersion) -> ReadP PackageId +packageIdSpecP (name,ver) = do + string name >> char '-' >> string ver >> char '-' >> return () + many1 (satisfy isAlphaNum) + +packageCompCharP :: ReadP Char +packageCompCharP = + satisfy $ \c -> isAlphaNum c || c `elem` "_-." -- | Get options needed to add a list of package dbs to ghc-pkg's db stack ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index a55bf6c..a88595c 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -2,6 +2,8 @@ module Language.Haskell.GhcMod.Types where +import Data.List + -- | Output style. data OutputStyle = LispStyle -- ^ S expression style. | PlainStyle -- ^ Plain textstyle. @@ -90,8 +92,6 @@ data Cradle = Cradle { , cradleCabalFile :: Maybe FilePath -- | Package database stack , cradlePkgDbStack :: [GhcPkgDb] - -- | Package dependencies - , cradlePackages :: [Package] } deriving (Eq, Show) ---------------------------------------------------------------- @@ -108,8 +108,29 @@ type IncludeDir = FilePath -- | A package name. type PackageBaseName = String --- | A package name and its ID. -type Package = (PackageBaseName, Maybe String) +-- | A package version. +type PackageVersion = String + +-- | A package id. +type PackageId = String + +-- | A package's name, verson and id. +type Package = (PackageBaseName, PackageVersion, PackageId) + +pkgName :: Package -> PackageBaseName +pkgName (n,_,_) = n + +pkgVer :: Package -> PackageVersion +pkgVer (_,v,_) = v + +pkgId :: Package -> PackageId +pkgId (_,_,i) = i + +showPkg :: Package -> String +showPkg (n,v,_) = intercalate "-" [n,v] + +showPkgId :: Package -> String +showPkgId (n,v,i) = intercalate "-" [n,v,i] -- | Haskell expression. type Expression = String