Fix #242, ghcPkgList(Ex) on NixOS

Language/Haskell/GhcMod/GhcPkg.hs

@@ -12,19 +12,25 @@ module Language.Haskell.GhcMod.GhcPkg (
   , getPackageDbStack
   ) where
 
-import Config (cProjectVersionInt) -- ghc version
+import Config (cProjectVersionInt,cProjectVersion,cTargetPlatformString)
-import Control.Applicative ((<$>))
+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
+    df <- getDynFlags
-  where
+    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 :: String -> [(FilePath, [Package])]
-parseGhcPkgOutput [] = []
+parseGhcPkgOutput p =
-parseGhcPkgOutput (l:ls) =
+    case P.readP_to_S ghcPkgOutputP p of
-    parseGhcPkgOutput ls ++ case l of
+      (a, rest):_  | all isSpace rest -> a
-      [] -> []
+      res@(a,reset):_ -> error $ "parseGhcPkgOutput: " ++ show a ++ "\nwith rest:```" ++ reset ++ "```\n\nwhole result: " ++ show res
-      h:_ | isSpace h -> maybeToList $ packageLine l
+      _ -> error $ "parseGhcPkgOutput: failed to parse output!\n\n" ++ p
-          | 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
 
 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

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

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
+        it "find a config file and extracts packages" $
-            sdb <- getSandboxDb "test/data/check-packageid"
+           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")]