To break cyclic import, this patch makes GhcPkg.hs independent from Monad.hs(refactoring for #244)
This removes `ghcPkgList`, `ghcPkgListEx` and `ghcPkgDbOpt`. I'm not sure this is a right way to do.
This commit is contained in:
Kazu Yamamoto
parent
f199ea9e2e
commit
8561e7b656
@ -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]
|
||||
|
||||
@ -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
|
||||
@ -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")]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user