hasufell
/
ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #223 from DanielG/dev 

More refactoring of package handling
This commit is contained in:
Kazu Yamamoto 2014-04-18 11:20:54 +09:00
parent 68f64639dc bd2db5e98e
commit ffdad00950
13 changed files with 117 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
Language/Haskell/GhcMod/CabalApi.hs
View File

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

5
Language/Haskell/GhcMod/Cradle.hs
View File

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

2
Language/Haskell/GhcMod/Debug.hs
View File

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

3
Language/Haskell/GhcMod/Gap.hs
View File

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

81
Language/Haskell/GhcMod/GhcPkg.hs
View File

@ -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.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,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

29
Language/Haskell/GhcMod/Types.hs
View File

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

2
ghc-mod.cabal
View File

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

6
test/CabalApiSpec.hs
View File

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

3
test/CradleSpec.hs
View File

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

5
test/GhcPkgSpec.hs
View File

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

4
test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf Normal file
View File

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

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

@ -1 +0,0 @@
dummy

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

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