diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index d63e806..44fde2c 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -12,19 +12,25 @@ module Language.Haskell.GhcMod.GhcPkg ( , getPackageDbStack ) where -import Config (cProjectVersionInt) -- ghc version -import Control.Applicative ((<$>)) +import Config (cProjectVersionInt,cProjectVersion,cTargetPlatformString) +import DynFlags (DynFlags(..), systemPackageConfig,getDynFlags) +import Exception (handleIO) +import CoreMonad (liftIO) +import Control.Applicative ((<$>),(<*>),(<*),(*>)) import Control.Exception (SomeException(..)) +import Control.Monad (void) import qualified Control.Exception as E import Data.Char (isSpace,isAlphaNum) import Data.List (isPrefixOf, intercalate) import Data.List.Split (splitOn) -import Data.Maybe (listToMaybe, maybeToList) +import Data.Maybe (catMaybes) import Distribution.Package (InstalledPackageId(..)) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils +import {-# SOURCE #-} Language.Haskell.GhcMod.Monad import System.FilePath (()) -import Text.ParserCombinators.ReadP (ReadP, char, between, sepBy1, many1, string, choice, eof) +import System.Directory (getAppUserDataDirectory,doesDirectoryExist) +import Text.ParserCombinators.ReadP (ReadP, char, satisfy, between, sepBy1, many1, many, manyTill, skipMany, skipMany1, skipSpaces, string, choice, eof,(+++)) import qualified Text.ParserCombinators.ReadP as P ghcVersion :: Int @@ -59,31 +65,42 @@ getPackageDbStack cdir = (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db]) `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb] + + +-- Copied from ghc module `Packages' unfortunately it's not exported :/ +resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath) +resolvePackageDb df GlobalDb = return $ Just (systemPackageConfig df) +resolvePackageDb _ UserDb = handleIO (\_ -> return Nothing) $ do + appdir <- getAppUserDataDirectory "ghc" + let dir = appdir (target_os ++ '-':target_arch ++ '-':cProjectVersion) + pkgconf = dir "package.conf.d" + exist <- doesDirectoryExist pkgconf + return $ if exist then Just pkgconf else Nothing + where + [target_arch,_,target_os] = splitOn "-" cTargetPlatformString +resolvePackageDb _ (PackageDb name) = return $ Just name + + -- | List packages in one or more ghc package store -ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName] +ghcPkgList :: [GhcPkgDb] -> GhcMod [PackageBaseName] ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs where fst3 (x,_,_) = x -ghcPkgListEx :: [GhcPkgDb] -> IO [Package] +ghcPkgListEx :: [GhcPkgDb] -> GhcMod [Package] ghcPkgListEx dbs = do - parseGhcPkgOutput .lines <$> readProcess' "ghc-pkg" opts - where + df <- getDynFlags + out <- liftIO $ readProcess' "ghc-pkg" opts + rdbs <- catMaybes <$> mapM (liftIO . resolvePackageDb df) dbs + return $ concatMap snd $ filter ((`elem` rdbs) . fst) $ parseGhcPkgOutput out + where 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 $ P.readP_to_S packageLineP l of - Just ((Normal,p),_) -> Just p - Just ((Hidden,p),_) -> Just p - _ -> Nothing +parseGhcPkgOutput :: String -> [(FilePath, [Package])] +parseGhcPkgOutput p = + case P.readP_to_S ghcPkgOutputP p of + (a, rest):_ | all isSpace rest -> a + res@(a,reset):_ -> error $ "parseGhcPkgOutput: " ++ show a ++ "\nwith rest:```" ++ reset ++ "```\n\nwhole result: " ++ show res + _ -> error $ "parseGhcPkgOutput: failed to parse output!\n\n" ++ p fromInstalledPackageId' :: InstalledPackageId -> Maybe Package fromInstalledPackageId' pid = let @@ -99,21 +116,42 @@ fromInstalledPackageId pid = Nothing -> error $ "fromInstalledPackageId: `"++show pid++"' is not a valid package-id" +ghcPkgOutputP :: ReadP [(FilePath, [Package])] +ghcPkgOutputP = do + dbs <- ghcPkgOutputP' + return $ do + (path, ps) <- dbs + return (path,map snd $ filter ((`elem`[Normal,Hidden]) . fst) ps) + +ghcPkgOutputP' :: ReadP [(FilePath, [(PackageState, Package)])] +ghcPkgOutputP' = do + skipUseCacheLinesP *> (many1 $ (,) <$> pathLineP <*> many1 packageLineP) + where + skipUseCacheLinesP = skipMany $ do + void $ string "using cache:" + void $ manyTill (satisfy $ const True) (char '\n') + +pathLineP :: ReadP FilePath +pathLineP = do + p <- (:) <$> char '/' <*> manyTill (satisfy $ const True) (char ':') + char '\n' + return p + data PackageState = Normal | Hidden | Broken deriving (Eq,Show) packageLineP :: ReadP (PackageState, Package) packageLineP = do - P.skipSpaces + skipSpaces p <- choice [ (Hidden,) <$> between (char '(') (char ')') packageP , (Broken,) <$> between (char '{') (char '}') packageP , (Normal,) <$> packageP ] - eof + char '\n' return p packageP :: ReadP (PackageBaseName, PackageVersion, PackageId) packageP = do pkgSpec@(name,ver) <- packageSpecP - P.skipSpaces + skipSpaces i <- between (char '(') (char ')') $ packageIdSpecP pkgSpec return (name,ver,i) @@ -125,11 +163,11 @@ packageSpecP = do packageIdSpecP :: (PackageBaseName,PackageVersion) -> ReadP PackageId packageIdSpecP (name,ver) = do string name >> char '-' >> string ver >> char '-' >> return () - many1 (P.satisfy isAlphaNum) + many1 (satisfy isAlphaNum) packageCompCharP :: ReadP Char packageCompCharP = - P.satisfy $ \c -> isAlphaNum c || c `elem` "_-." + 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/Monad.hs-boot b/Language/Haskell/GhcMod/Monad.hs-boot new file mode 100644 index 0000000..5f80fc3 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE RoleAnnotations #-} +module Language.Haskell.GhcMod.Monad where + +import DynFlags (HasDynFlags) +import Control.Monad.IO.Class (MonadIO) +import Control.Applicative (Applicative) + +data GhcMod a +type role GhcMod nominal + +instance Functor GhcMod +instance Applicative GhcMod +instance Monad GhcMod + +instance HasDynFlags GhcMod +instance MonadIO GhcMod diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs index 6e80a03..07f6dea 100644 --- a/test/GhcPkgSpec.hs +++ b/test/GhcPkgSpec.hs @@ -2,6 +2,9 @@ module GhcPkgSpec where import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.Monad + +import CoreMonad (liftIO) import Control.Applicative import System.Directory @@ -22,7 +25,8 @@ spec = do getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException describe "getPackageDbPackages" $ do - it "find a config file and extracts packages" $ do - sdb <- getSandboxDb "test/data/check-packageid" + it "find a config file and extracts packages" $ + runGhcMod defaultOptions $ do + sdb <- liftIO $ getSandboxDb "test/data/check-packageid" pkgs <- ghcPkgListEx [PackageDb sdb] - pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")] + liftIO $ pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")]