More refactoring of package handling

- 'GhcPkg' now parses 'ghc-pkg -v list' output directly to also get the
  package-id

- Remove unused field 'cradlePackages' in Cradle

- Remove 'getPackageDbPackages' and use 'ghcPkgListEx' instead

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)
 
 ----------------------------------------------------------------
 

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]}
 
 ----------------------------------------------------------------
 

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

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
 
 ----------------------------------------------------------------
 ----------------------------------------------------------------

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

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