diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 937cd87852..e34aada8dc 100644 --- a/src/Stack/Build/Haddock.hs +++ b/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 diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index dd1e659cc8..06ddf56e74 100644 --- a/src/Stack/GhcPkg.hs +++ b/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 [] diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 4878d805b5..ed7086f3dd 100644 --- a/src/Stack/Solver.hs +++ b/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) diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs index e08692f376..d6209984e6 100644 --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -5,7 +5,7 @@ -- | A ghc-pkg id. module Stack.Types.GhcPkgId - (GhcPkgId + (GhcPkgId(..) ,ghcPkgIdParser ,parseGhcPkgId ,ghcPkgIdString) diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index ad4892b82a..ebb90ad7d6 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/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 =