Fix haddocks copy bug (#1105) (nearly)

src/Stack/Build/Haddock.hs

@@ -67,15 +67,16 @@ copyDepHaddocks :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadB
  -> Set (Path Abs Dir)
  -> m ()
 copyDepHaddocks envOverride wc bco pkgDbs pkgId extraDestDirs = do
- mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs $ packageIdentifierString pkgId
+ mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs pkgId
  case mpkgHtmlDir of
  Nothing -> return ()
  Just (_pkgId, pkgHtmlDir) -> do
- depGhcIds <- findGhcPkgDepends envOverride wc pkgDbs $ packageIdentifierString pkgId
+ depGhcIds <- findGhcPkgDepends envOverride wc pkgDbs (packageIdentifierName pkgId)
  forM_ depGhcIds $ copyDepWhenNeeded pkgHtmlDir
  where
  copyDepWhenNeeded pkgHtmlDir depGhcId = do
- mDepOrigDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs $ ghcPkgIdString depGhcId
+ let mdepPkgId = parsePackageIdentifierFromGhcPkgId depGhcId
+ mDepOrigDir <- (findGhcPkgHaddockHtml envOverride wc pkgDbs) =<< mdepPkgId
  case mDepOrigDir of
  Nothing -> return ()
  Just (depId, depOrigDir) -> do

src/Stack/GhcPkg.hs

@@ -25,7 +25,6 @@ module Stack.GhcPkg
  ,mkGhcPackagePath)
  where
 
-import Control.Applicative
 import Control.Monad
 import Control.Monad.Catch
 import Control.Monad.IO.Class
@@ -116,16 +115,16 @@ findGhcPkgField
  => EnvOverride
  -> WhichCompiler
  -> [Path Abs Dir] -- ^ package databases
- -> String -- ^ package identifier, or GhcPkgId
+ -> PackageName
  -> Text
  -> m (Maybe Text)
-findGhcPkgField menv wc pkgDbs name field = do
+findGhcPkgField menv wc pkgDbs pkgName field = do
  result <-
  ghcPkg
  menv
  wc
  pkgDbs
- ["field", "--simple-output", name, T.unpack field]
+ ["field", "--simple-output", packageNameString pkgName, T.unpack field]
  return $
  case result of
  Left{} -> Nothing
@@ -142,7 +141,7 @@ findGhcPkgId :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m,
  -> PackageName
  -> m (Maybe GhcPkgId)
 findGhcPkgId menv wc pkgDbs name = do
- mpid <- findGhcPkgField menv wc pkgDbs (packageNameString name) "id"
+ mpid <- findGhcPkgField menv wc pkgDbs name "id"
  case mpid of
  Just !pid -> return (parseGhcPkgId (T.encodeUtf8 pid))
  _ -> return Nothing
@@ -155,7 +154,7 @@ findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatc
  -> PackageName
  -> m (Maybe Version)
 findGhcPkgVersion menv wc pkgDbs name = do
- mv <- findGhcPkgField menv wc pkgDbs (packageNameString name) "version"
+ mv <- findGhcPkgField menv wc pkgDbs name "version"
  case mv of
  Just !v -> return (parseVersion (T.encodeUtf8 v))
  _ -> return Nothing
@@ -165,17 +164,12 @@ findGhcPkgHaddockHtml :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, Monad
  => EnvOverride
  -> WhichCompiler
  -> [Path Abs Dir] -- ^ package databases
- -> String -- ^ PackageIdentifier or GhcPkgId
+ -> PackageIdentifier
  -> m (Maybe (PackageIdentifier, Path Abs Dir))
-findGhcPkgHaddockHtml menv wc pkgDbs ghcPkgId = do
- mpath <- findGhcPkgField menv wc pkgDbs ghcPkgId "haddock-html"
- mid <- findGhcPkgField menv wc pkgDbs ghcPkgId "id"
- mversion <- findGhcPkgField menv wc pkgDbs ghcPkgId "version"
- let mpkgId = PackageIdentifier
- <$> (mid >>= parsePackageName . T.encodeUtf8)
- <*> (mversion >>= parseVersion . T.encodeUtf8)
- case (,) <$> mpath <*> mpkgId of
- Just (path0, pkgId) -> do
+findGhcPkgHaddockHtml menv wc pkgDbs pkgId = do
+ mpath <- findGhcPkgField menv wc pkgDbs (packageIdentifierName pkgId) "haddock-html"
+ case mpath of
+ Just path0 -> do
  let path = T.unpack path0
  exists <- liftIO $ doesDirectoryExist path
  path' <- if exists
@@ -195,37 +189,33 @@ findTransitiveGhcPkgDepends
  -> m (Set PackageIdentifier)
 findTransitiveGhcPkgDepends menv wc pkgDbs pkgId0 =
  liftM (Set.fromList . Map.elems)
- (go (packageIdentifierString pkgId0) Map.empty)
+ (go (packageIdentifierName pkgId0) Map.empty)
  where
- go pkgId res = do
- deps <- findGhcPkgDepends menv wc pkgDbs pkgId
+ go pkgName res = do
+ deps <- findGhcPkgDepends menv wc pkgDbs pkgName
  loop deps res
  loop [] res = return res
  loop (dep:deps) res = do
  if Map.member dep res
  then loop deps res
  else do
- let pkgId = ghcPkgIdString dep
- mname <- findGhcPkgField menv wc pkgDbs pkgId "name"
- mversion <- findGhcPkgField menv wc pkgDbs pkgId "version"
- let mident = do
- name <- mname >>= parsePackageName . T.encodeUtf8
- version <- mversion >>= parseVersion . T.encodeUtf8
- Just $ PackageIdentifier name version
- res' = maybe id (Map.insert dep) mident res
- res'' <- go pkgId res'
- -- FIXME is the Map.union actually necessary?
- loop deps (Map.union res res'')
+ case parsePackageIdentifierFromGhcPkgId dep of
+ Just pkgId -> do
+ res' <- go (packageIdentifierName pkgId) (Map.insert dep pkgId res)
+ -- FIXME is the Map.union actually necessary?
+ loop deps (Map.union res res')
+ Nothing ->
+ loop deps res
 
 -- | Get the dependencies of the package.
 findGhcPkgDepends :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
  => EnvOverride
  -> WhichCompiler
  -> [Path Abs Dir] -- ^ package databases
- -> String -- ^ package identifier or GhcPkgId
+ -> PackageName
  -> m [GhcPkgId]
-findGhcPkgDepends menv wc pkgDbs pkgId = do
- mdeps <- findGhcPkgField menv wc pkgDbs pkgId "depends"
+findGhcPkgDepends menv wc pkgDbs pkgName = do
+ mdeps <- findGhcPkgField menv wc pkgDbs pkgName "depends"
  case mdeps of
  Just !deps -> return (mapMaybe (parseGhcPkgId . T.encodeUtf8) (T.words deps))
  _ -> return []

src/Stack/Solver.hs

@@ -120,10 +120,9 @@ cabalSolver wc cabalfps constraints userFlags cabalArgs = withSystemTempDirector
  parseLine t0 = maybe (Left t0) Right $ do
  -- get rid of (new package) and (latest: ...) bits
  ident':flags' <- Just $ T.words $ T.takeWhile (/= '(') t0
- PackageIdentifier name version <-
- parsePackageIdentifierFromString $ T.unpack ident'
+ let mpkgId = parsePackageIdentifierFromString $ T.unpack ident'
  flags <- mapM parseFlag flags'
- Just (name, (version, Map.fromList flags))
+ liftA (\(PackageIdentifier n v) -> (n, (v, Map.fromList flags))) mpkgId
  parseFlag t0 = do
  flag <- parseFlagNameFromString $ T.unpack t1
  return (flag, enabled)

src/Stack/Types/GhcPkgId.hs

@@ -5,7 +5,7 @@
 -- | A ghc-pkg id.
 
 module Stack.Types.GhcPkgId
- (GhcPkgId
+ (GhcPkgId(..)
  ,ghcPkgIdParser
  ,parseGhcPkgId
  ,ghcPkgIdString)

src/Stack/Types/PackageIdentifier.hs

@@ -11,6 +11,7 @@ module Stack.Types.PackageIdentifier
  ,toTuple
  ,fromTuple
  ,parsePackageIdentifier
+ ,parsePackageIdentifierFromGhcPkgId
  ,parsePackageIdentifierFromString
  ,packageIdentifierVersion
  ,packageIdentifierName
@@ -35,6 +36,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import GHC.Generics
 import Prelude hiding (FilePath)
+import Stack.Types.GhcPkgId
 import Stack.Types.PackageName
 import Stack.Types.Version
 
@@ -102,6 +104,13 @@ parsePackageIdentifier x = go x
  either (const (throwM (PackageIdentifierParseFail x))) return .
  parseOnly (packageIdentifierParser <* endOfInput)
 
+-- | Parse a package identifier from a ghc-pkg id.
+parsePackageIdentifierFromGhcPkgId :: MonadThrow m => GhcPkgId -> m PackageIdentifier
+parsePackageIdentifierFromGhcPkgId (GhcPkgId bs) = go bs
+ where go =
+ either (const (throwM (PackageIdentifierParseFail bs))) return .
+ parseOnly (packageIdentifierParser <* char8 '-')
+
 -- | Migration function.
 parsePackageIdentifierFromString :: MonadThrow m => String -> m PackageIdentifier
 parsePackageIdentifierFromString =