diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 9a6e732..6c1f5b8 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -1,8 +1,6 @@ {-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-} module Language.Haskell.GhcMod.GhcPkg ( - ghcPkgList - , ghcPkgListEx - , ghcPkgDbOpt + ghcPkgDbOpt , ghcPkgDbStackOpts , ghcDbStackOpts , ghcDbOpt @@ -12,26 +10,17 @@ module Language.Haskell.GhcMod.GhcPkg ( , getPackageDbStack ) where -import Config (cProjectVersionInt,cProjectVersion,cTargetPlatformString) -import DynFlags (DynFlags(..), systemPackageConfig,getDynFlags) -import Exception (handleIO) -import CoreMonad (liftIO) -import Control.Applicative ((<$>),(<*>),(*>)) +import Config (cProjectVersionInt) +import Control.Applicative ((<$>)) import Control.Exception (SomeException(..)) -import Control.Monad (void) import qualified Control.Exception as E -import Data.Char (isSpace,isAlphaNum) +import Data.Char (isSpace) import Data.List (isPrefixOf, intercalate) import Data.List.Split (splitOn) -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 System.Directory (getAppUserDataDirectory,doesDirectoryExist) -import Text.ParserCombinators.ReadP (ReadP, char, satisfy, between, sepBy1, many1, manyTill, skipMany, skipSpaces, string, choice) -import qualified Text.ParserCombinators.ReadP as P ghcVersion :: Int ghcVersion = read cProjectVersionInt @@ -65,43 +54,6 @@ 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] -> GhcMod [PackageBaseName] -ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs - where fst3 (x,_,_) = x - -ghcPkgListEx :: [GhcPkgDb] -> GhcMod [Package] -ghcPkgListEx dbs = do - 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 -> [(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 InstalledPackageId pkg = pid @@ -116,59 +68,6 @@ 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 ':') - void $ char '\n' - return p - -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 ] - void $ char '\n' - 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 -> [String] diff --git a/Language/Haskell/GhcMod/Monad.hs-boot b/Language/Haskell/GhcMod/Monad.hs-boot deleted file mode 100644 index 5f80fc3..0000000 --- a/Language/Haskell/GhcMod/Monad.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -{-# 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 07f6dea..1859829 100644 --- a/test/GhcPkgSpec.hs +++ b/test/GhcPkgSpec.hs @@ -1,18 +1,11 @@ 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 import System.FilePath (()) import Test.Hspec -import Dir - spec :: Spec spec = do describe "getSandboxDb" $ do @@ -23,10 +16,3 @@ spec = do it "throws an error if a config file is broken" $ do getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException - - describe "getPackageDbPackages" $ do - it "find a config file and extracts packages" $ - runGhcMod defaultOptions $ do - sdb <- liftIO $ getSandboxDb "test/data/check-packageid" - pkgs <- ghcPkgListEx [PackageDb sdb] - liftIO $ pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")]