From 48c9fbb3f00e4742bdbe01b0caba0a201ba85883 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Tue, 20 Oct 2015 19:18:15 +0200 Subject: [PATCH 1/6] Bunch of trace statements (and "id" -> "name") --- src/Stack/Build/Haddock.hs | 7 ++++++- src/Stack/GhcPkg.hs | 9 +++++++-- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 937cd87852..35bf02d510 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -29,6 +29,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T +import Debug.Trace import Path import Path.IO import Prelude @@ -45,7 +46,7 @@ import System.Process.Read -- | Determine whether we should haddock for a package. shouldHaddockPackage :: BuildOpts -> Set PackageName -> PackageName -> Bool shouldHaddockPackage bopts wanted name = - if Set.member name wanted + trace "shouldHaddockPackage" $ if Set.member name wanted then boptsHaddock bopts else shouldHaddockDeps bopts @@ -67,7 +68,11 @@ copyDepHaddocks :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadB -> Set (Path Abs Dir) -> m () copyDepHaddocks envOverride wc bco pkgDbs pkgId extraDestDirs = do + let f = "copyDepHaddocks: " + traceM $ f ++ "begin" mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs $ packageIdentifierString pkgId + traceM "mpkgHtmlDir:" + traceShowM mpkgHtmlDir case mpkgHtmlDir of Nothing -> return () Just (_pkgId, pkgHtmlDir) -> do diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index dd1e659cc8..4088e82e3f 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -41,6 +41,7 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Debug.Trace import Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir) import Path.Extra (toFilePathNoTrailingSep) import Path.IO (dirExists, createTree) @@ -168,16 +169,20 @@ findGhcPkgHaddockHtml :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, Monad -> String -- ^ PackageIdentifier or GhcPkgId -> m (Maybe (PackageIdentifier, Path Abs Dir)) findGhcPkgHaddockHtml menv wc pkgDbs ghcPkgId = do + traceM $ unwords ["findGhcPkgHaddockHtml:", show pkgDbs, ghcPkgId] mpath <- findGhcPkgField menv wc pkgDbs ghcPkgId "haddock-html" - mid <- findGhcPkgField menv wc pkgDbs ghcPkgId "id" + mname <- findGhcPkgField menv wc pkgDbs ghcPkgId "name" mversion <- findGhcPkgField menv wc pkgDbs ghcPkgId "version" + traceM $ unwords $ map show [mpath, mname, mversion] let mpkgId = PackageIdentifier - <$> (mid >>= parsePackageName . T.encodeUtf8) + <$> (mname >>= parsePackageName . T.encodeUtf8) <*> (mversion >>= parseVersion . T.encodeUtf8) + traceShowM mpkgId case (,) <$> mpath <*> mpkgId of Just (path0, pkgId) -> do let path = T.unpack path0 exists <- liftIO $ doesDirectoryExist path + traceShowM exists path' <- if exists then liftIO $ canonicalizePath path else return path From a7c37a68a27b9d55d4f15d94d22ce498b0c7836f Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Tue, 20 Oct 2015 13:20:10 +0200 Subject: [PATCH 2/6] Add parsePackageIdentifierFromGhcPkgId --- src/Stack/Types/GhcPkgId.hs | 2 +- src/Stack/Types/PackageIdentifier.hs | 9 +++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) 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 = From af742a2b51af4676c788013df43c473c6cfbf42d Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Tue, 20 Oct 2015 20:36:23 +0200 Subject: [PATCH 3/6] Wild retyping --- src/Stack/Build/Haddock.hs | 7 +++-- src/Stack/GhcPkg.hs | 61 ++++++++++++++++---------------------- 2 files changed, 29 insertions(+), 39 deletions(-) diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 35bf02d510..5baeddc053 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -70,17 +70,18 @@ copyDepHaddocks :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadB copyDepHaddocks envOverride wc bco pkgDbs pkgId extraDestDirs = do let f = "copyDepHaddocks: " traceM $ f ++ "begin" - mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs $ packageIdentifierString pkgId + mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs pkgId traceM "mpkgHtmlDir:" traceShowM mpkgHtmlDir 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 + depPkgId <- parsePackageIdentifierFromGhcPkgId depGhcId + mDepOrigDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs depPkgId case mDepOrigDir of Nothing -> return () Just (depId, depOrigDir) -> do diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 4088e82e3f..c1a4a16088 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 @@ -117,16 +116,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 @@ -143,7 +142,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 @@ -156,7 +155,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 @@ -166,20 +165,14 @@ 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 - traceM $ unwords ["findGhcPkgHaddockHtml:", show pkgDbs, ghcPkgId] - mpath <- findGhcPkgField menv wc pkgDbs ghcPkgId "haddock-html" - mname <- findGhcPkgField menv wc pkgDbs ghcPkgId "name" - mversion <- findGhcPkgField menv wc pkgDbs ghcPkgId "version" - traceM $ unwords $ map show [mpath, mname, mversion] - let mpkgId = PackageIdentifier - <$> (mname >>= parsePackageName . T.encodeUtf8) - <*> (mversion >>= parseVersion . T.encodeUtf8) - traceShowM mpkgId - case (,) <$> mpath <*> mpkgId of - Just (path0, pkgId) -> do +findGhcPkgHaddockHtml menv wc pkgDbs pkgId = do + traceM $ unwords ["findGhcPkgHaddockHtml:", show pkgDbs, show pkgId] + mpath <- findGhcPkgField menv wc pkgDbs (packageIdentifierName pkgId) "haddock-html" + traceShowM mpath + case mpath of + Just path0 -> do let path = T.unpack path0 exists <- liftIO $ doesDirectoryExist path traceShowM exists @@ -200,37 +193,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 [] From 9747351a4455ee541305375b64faef34aaa6be7f Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Tue, 20 Oct 2015 20:56:01 +0200 Subject: [PATCH 4/6] Parse safely --- src/Stack/Build/Haddock.hs | 4 ++-- src/Stack/Fetch.hs | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 5baeddc053..328f4e1009 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -80,8 +80,8 @@ copyDepHaddocks envOverride wc bco pkgDbs pkgId extraDestDirs = do forM_ depGhcIds $ copyDepWhenNeeded pkgHtmlDir where copyDepWhenNeeded pkgHtmlDir depGhcId = do - depPkgId <- parsePackageIdentifierFromGhcPkgId depGhcId - mDepOrigDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs depPkgId + let mdepPkgId = parsePackageIdentifierFromGhcPkgId depGhcId + mDepOrigDir <- (findGhcPkgHaddockHtml envOverride wc pkgDbs) =<< mdepPkgId case mDepOrigDir of Nothing -> return () Just (depId, depOrigDir) -> do diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index b82ed84c30..ebd70393ed 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -61,6 +61,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Typeable (Typeable) import Data.Word (Word64) +import Debug.Trace import Network.HTTP.Download import Path import Path.IO (dirExists, createTree) @@ -134,6 +135,7 @@ unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpM -> [String] -- ^ names or identifiers -> m () unpackPackages menv dest input = do + traceM "unpackPackages" dest' <- liftIO (canonicalizePath dest) >>= parseAbsDir (names, idents) <- case partitionEithers $ map parse input of ([], x) -> return $ partitionEithers x From fb7f6bb3164cb7e2a0810eec90d5693160ca9e94 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Tue, 20 Oct 2015 21:04:49 +0200 Subject: [PATCH 5/6] Remove trace statements --- src/Stack/Build/Haddock.hs | 7 +------ src/Stack/Fetch.hs | 2 -- src/Stack/GhcPkg.hs | 4 ---- 3 files changed, 1 insertion(+), 12 deletions(-) diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 328f4e1009..e34aada8dc 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -29,7 +29,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import Debug.Trace import Path import Path.IO import Prelude @@ -46,7 +45,7 @@ import System.Process.Read -- | Determine whether we should haddock for a package. shouldHaddockPackage :: BuildOpts -> Set PackageName -> PackageName -> Bool shouldHaddockPackage bopts wanted name = - trace "shouldHaddockPackage" $ if Set.member name wanted + if Set.member name wanted then boptsHaddock bopts else shouldHaddockDeps bopts @@ -68,11 +67,7 @@ copyDepHaddocks :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadB -> Set (Path Abs Dir) -> m () copyDepHaddocks envOverride wc bco pkgDbs pkgId extraDestDirs = do - let f = "copyDepHaddocks: " - traceM $ f ++ "begin" mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs pkgId - traceM "mpkgHtmlDir:" - traceShowM mpkgHtmlDir case mpkgHtmlDir of Nothing -> return () Just (_pkgId, pkgHtmlDir) -> do diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index ebd70393ed..b82ed84c30 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -61,7 +61,6 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Typeable (Typeable) import Data.Word (Word64) -import Debug.Trace import Network.HTTP.Download import Path import Path.IO (dirExists, createTree) @@ -135,7 +134,6 @@ unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpM -> [String] -- ^ names or identifiers -> m () unpackPackages menv dest input = do - traceM "unpackPackages" dest' <- liftIO (canonicalizePath dest) >>= parseAbsDir (names, idents) <- case partitionEithers $ map parse input of ([], x) -> return $ partitionEithers x diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index c1a4a16088..06ddf56e74 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -40,7 +40,6 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Debug.Trace import Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir) import Path.Extra (toFilePathNoTrailingSep) import Path.IO (dirExists, createTree) @@ -168,14 +167,11 @@ findGhcPkgHaddockHtml :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, Monad -> PackageIdentifier -> m (Maybe (PackageIdentifier, Path Abs Dir)) findGhcPkgHaddockHtml menv wc pkgDbs pkgId = do - traceM $ unwords ["findGhcPkgHaddockHtml:", show pkgDbs, show pkgId] mpath <- findGhcPkgField menv wc pkgDbs (packageIdentifierName pkgId) "haddock-html" - traceShowM mpath case mpath of Just path0 -> do let path = T.unpack path0 exists <- liftIO $ doesDirectoryExist path - traceShowM exists path' <- if exists then liftIO $ canonicalizePath path else return path From 6cf25babab412213d874d90ceed2193599ef89d2 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Tue, 20 Oct 2015 21:29:08 +0200 Subject: [PATCH 6/6] More safe parsing --- src/Stack/Solver.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) 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)