Merge pull request #223 from DanielG/dev

More refactoring of package handling

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)
+                           , PackageName(PackageName))
-                           , PackageIdentifier(pkgName))
+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
+    depPkgs ps = attachPackageIds ps
-                   $ removeThem problematicPackages
+                   $ removeThem (problematicPackages ++ [thisPkg])
-                   $ removeMe cfile
-                   $ filter (`elem` ps) -- remove packages not available in any
-                                        -- package dbs
                    $ 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
+attachPackageIds pkgs = catMaybes . fmap (flip lookup3 pkgs)
-  where
+
-    attachId x = case lookup x pkgs of
+lookup3 :: Eq a => a -> [(a,b,c)] -> Maybe (a,b,c)
-      Nothing -> (x, Nothing)
+lookup3 _ [] = Nothing
-      Just p -> (x, p)
+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 pkg = ExposePackageId $ showPkgId pkg
-    expose (_, Just pid) = ExposePackageId pid
 
 ----------------------------------------------------------------
 ----------------------------------------------------------------

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.Exception (SomeException(..))
 import qualified Control.Exception as E
-import Data.Char (isSpace)
+import Data.Char (isSpace,isAlphaNum)
-import Data.List (isPrefixOf)
+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,64 @@ 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
+    p <- choice [ (Hidden,) <$> between (char '(') (char ')') packageP
+                , (Broken,) <$> between (char '{') (char '}') packageP
+                , (Normal,) <$> packageP ]
+    eof
+    return p
+
+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.
+-- | A package version.
-type Package    = (PackageBaseName, Maybe String)
+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

ghc-mod.cabal

@@ -27,7 +27,7 @@ Extra-Source-Files:     ChangeLog
 			test/data/*.cabal
                         test/data/*.hs
                         test/data/cabal.sandbox.config.in
-                        test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/dummy
+                        test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf
                         test/data/broken-cabal/*.cabal
                         test/data/broken-sandbox/*.cabal
                         test/data/broken-sandbox/cabal.sandbox.config

test/CabalApiSpec.hs

@@ -38,8 +38,10 @@ spec = do
                       , includeDirs = map (toRelativeDir dir) (includeDirs res)
                       }
                 if ghcVersion < 706
-                  then res' `shouldBe` CompilerOptions {ghcOptions = ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = [("Cabal", Nothing), ("base", Nothing) , ("template-haskell", Nothing)]}
+                  then ghcOptions res' `shouldBe` ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]
-                  else res' `shouldBe` CompilerOptions {ghcOptions = ["-global-package-db", "-no-user-package-db","-package-db",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = [("Cabal", Nothing), ("base", Nothing) , ("template-haskell", Nothing)]}
+                  else ghcOptions res' `shouldBe` ["-global-package-db", "-no-user-package-db","-package-db",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]
+                includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"]
+                depPackages res' `shouldSatisfy` (("Cabal", "1.18.1.3", "2b161c6bf77657aa17e1681d83cb051b")`elem`)
 
 
     describe "cabalDependPackages" $ do

test/CradleSpec.hs

@@ -22,7 +22,6 @@ spec = do
                   , cradleRootDir    = curDir
                   , cradleCabalFile  = Nothing
                   , cradlePkgDbStack = [GlobalDb]
-                  , cradlePackages   = []
                   }
         it "finds a cabal file and a sandbox" $ do
             cwd <- getCurrentDirectory
@@ -33,7 +32,6 @@ spec = do
                   , cradleRootDir    = "test" </> "data"
                   , cradleCabalFile  = Just ("test" </> "data" </> "cabalapi.cabal")
                   , cradlePkgDbStack = [GlobalDb, PackageDb (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")]
-                  , cradlePackages   = []
                   }
         it "works even if a sandbox config file is broken" $ do
             withDirectory "test/data/broken-sandbox" $ \dir -> do
@@ -43,7 +41,6 @@ spec = do
                   , cradleRootDir    = "test" </> "data" </> "broken-sandbox"
                   , cradleCabalFile  = Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
                   , cradlePkgDbStack = [GlobalDb, UserDb]
-                  , cradlePackages   = []
                   }
 
 relativeCradle :: FilePath -> Cradle -> Cradle

test/GhcPkgSpec.hs

@@ -23,5 +23,6 @@ spec = do
 
     describe "getPackageDbPackages" $ do
         it "find a config file and extracts packages" $ do
-            pkgs <- getPackageDbPackages "test/data/check-packageid"
+            sdb <- getSandboxDb "test/data/check-packageid"
-            pkgs `shouldSatisfy` (\x -> length x >= 1)
+            pkgs <- ghcPkgListEx [PackageDb sdb]
+            pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")]

test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf

@@ -0,0 +1,4 @@
+name: Cabal
+version: 1.18.1.3
+id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b
+exposed: True

test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/dummy

@@ -1 +0,0 @@
-dummy

test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf

@@ -1,37 +1,4 @@
 name: template-haskell
 version: 2.8.0.0
 id: template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c
-license: BSD3
-copyright:
-maintainer: libraries@haskell.org
-stability:
-homepage:
-package-url:
-synopsis:
-description: Facilities for manipulating Haskell source code using Template Haskell.
-category:
-author:
 exposed: True
-exposed-modules: Language.Haskell.TH.Syntax
-                 Language.Haskell.TH.PprLib Language.Haskell.TH.Ppr
-                 Language.Haskell.TH.Lib Language.Haskell.TH.Quote
-                 Language.Haskell.TH
-hidden-modules:
-trusted: False
-import-dirs: /usr/lib64/ghc-7.6.3/template-haskell-2.8.0.0
-library-dirs: /usr/lib64/ghc-7.6.3/template-haskell-2.8.0.0
-hs-libraries: HStemplate-haskell-2.8.0.0
-extra-libraries:
-extra-ghci-libraries:
-include-dirs:
-includes:
-depends: base-4.6.0.1-2bc8d09dc7b7883c4b97d1eb4a9d4ac8
-         containers-0.5.0.0-120bacdd7a06bf9f1f601811aa72d6c3
-         pretty-1.1.1.0-65070790589ca7952412e425f427ac56
-hugs-options:
-cc-options:
-ld-options:
-framework-dirs:
-frameworks:
-haddock-interfaces: /usr/share/doc/ghc-7.6.3/html/libraries/template-haskell-2.8.0.0/template-haskell.haddock
-haddock-html: /usr/share/doc/ghc-7.6.3/html/libraries/template-haskell-2.8.0.0