From cd9f59e98867d288c73b375236d39810d54b2feb Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Tue, 22 Nov 2022 15:29:11 +0000 Subject: [PATCH 1/3] Add --resolver-file to specify contents of resolver (fixes #4) --- src/cabal2stack.hs | 59 ++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 57 insertions(+), 2 deletions(-) diff --git a/src/cabal2stack.hs b/src/cabal2stack.hs index 59efb35..51c093c 100644 --- a/src/cabal2stack.hs +++ b/src/cabal2stack.hs @@ -36,6 +36,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T +import qualified Data.Text.Read as TR import qualified Data.YAML as Y import qualified Options.Applicative as O import qualified System.Process as Proc @@ -58,13 +59,19 @@ main = do S packages _pkgVers extraDeps flags gitPackages <- processUnits (P.pjUnits plan) + resolverFile <- maybe (pure (ResolverFile [])) getResolverContents optsResolverFile + let resolverContents = Set.fromList (map resolverPackageName (resolverFilePackages resolverFile)) + let stackYaml0 :: StackYaml stackYaml0 = StackYaml { syResolver = maybe (ResolverPkg $ P.pjCompilerId plan) (NamedResolver . T.pack) optsResolver , sySystemGHC = optsSystemGHC , syAllowNewer = optsAllowNewer , syPackages = Set.map (makeRelative cwd) packages - , syExtraDeps = Set.fromList [ P.PkgId pn ver | (pn, ver) <- Map.toList extraDeps ] + , syExtraDeps = Set.fromList [ pkgid | (pn, ver) <- Map.toList extraDeps + , let pkgid = P.PkgId pn ver + , not (pkgid `Set.member` resolverContents) + ] , syFlags = flags , syGitPackages = gitPackages } @@ -82,7 +89,8 @@ main = do data Opts = Opts { optsSystemGHC :: !Bool , optsAllowNewer :: !Bool - , optsResolver :: !(Maybe String) + , optsResolver :: !(Maybe String) -- ^ Name of the resolver, e.g. "lts-20.1" + , optsResolverFile :: !(Maybe FilePath) -- ^ Contents of the resolver as a YAML file , optsPlanJson :: !(Maybe FilePath) , optsOutput :: !FilePath } @@ -102,6 +110,8 @@ optsP = do optsResolver <- optional $ O.strOption (O.long "resolver" <> O.metavar "[LTS-version | nightly-yyyy-mm-dd]" <> O.help "Use provided resolver") + optsResolverFile <- optional $ O.strOption (O.long "resolver-file" <> O.metavar "PATH" <> O.help "Use contents of resolver from YAML file") + optsPlanJson <- optional $ O.strOption (O.long "plan-json" <> O.metavar "PATH" <> O.help "Use provided plan.json") optsOutput <- O.strOption (O.short 'o' <> O.long "output" <> O.metavar "PATH" <> O.value "stack.yaml" <> O.help "Output location") @@ -264,6 +274,51 @@ instance Y.ToYAML StackYaml where | GitRepo l t d <- Set.toList syGitPackages ] + +------------------------------------------------------------------------------- +-- resolvers +------------------------------------------------------------------------------- + +data ResolverFile = + ResolverFile + { resolverFilePackages :: [ResolverPackage] + } + +instance Y.FromYAML ResolverFile where + parseYAML = Y.withMap "ResolverFile" $ \m -> ResolverFile + <$> m Y..: "packages" + +data ResolverPackage = + ResolverPackage + { resolverPackageName :: P.PkgId } + +instance Y.FromYAML ResolverPackage where + parseYAML = Y.withMap "ResolverPackage" $ \m -> ResolverPackage + <$> (parsePackageName =<< m Y..: "hackage") + +parsePackageName :: Text -> Y.Parser P.PkgId +parsePackageName s = do + nm <- maybe (fail "bad package name") pure $ T.stripSuffix "-" nmdash + vs <- mapM read_digit vers + pure $ P.PkgId (P.PkgName nm) (P.Ver vs) + where + -- Ignore the pantry key + (t, _) = T.breakOn "@" s + (nmdash, ver) = T.breakOnEnd "-" t + vers = T.splitOn "." ver + + read_digit d = case TR.decimal d of + Right (n, _) -> pure n + Left err -> fail ("read_digit: " ++ err) + +getResolverContents :: FilePath -> IO ResolverFile +getResolverContents fp = do + b <- LBS.readFile fp + case Y.decode1 b of + Left (pos,x) -> hPutStrLn stderr (fp ++ ":" ++ Y.prettyPosWithSource pos b " error" ++ x) >> exitFailure + Right rf -> pure $ rf + + ------------------------------------------------------------------------------- -- utilities ------------------------------------------------------------------------------- From 823912c10563257469f1a6dc7b8d6de4266b905d Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Tue, 22 Nov 2022 15:30:14 +0000 Subject: [PATCH 2/3] WIP: pick up flags from resolver file The problem with this is that the file doesn't include flags which still have their default values, yet the plan contains them (and doesn't have an indication that they are still the default). --- src/cabal2stack.hs | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/src/cabal2stack.hs b/src/cabal2stack.hs index 51c093c..344b251 100644 --- a/src/cabal2stack.hs +++ b/src/cabal2stack.hs @@ -4,11 +4,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wwarn=orphans #-} module Main (main) where import Control.Applicative (optional, (<**>), (<|>)) @@ -59,7 +62,7 @@ main = do S packages _pkgVers extraDeps flags gitPackages <- processUnits (P.pjUnits plan) - resolverFile <- maybe (pure (ResolverFile [])) getResolverContents optsResolverFile + resolverFile <- maybe (pure (ResolverFile [] mempty)) getResolverContents optsResolverFile let resolverContents = Set.fromList (map resolverPackageName (resolverFilePackages resolverFile)) let stackYaml0 :: StackYaml @@ -72,7 +75,7 @@ main = do , let pkgid = P.PkgId pn ver , not (pkgid `Set.member` resolverContents) ] - , syFlags = flags + , syFlags = flags `diffFlags` resolverFileFlags resolverFile , syGitPackages = gitPackages } @@ -82,6 +85,13 @@ main = do "-" -> LBS.putStr (Y.encode [stackYaml]) _ -> LBS.writeFile optsOutput (Y.encode [stackYaml]) + +diffFlags :: Map P.PkgName (Map P.FlagName Bool) + -> Map P.PkgName (Map P.FlagName Bool) + -> Map P.PkgName (Map P.FlagName Bool) +diffFlags = Map.differenceWith (\fs gs -> Just (Map.difference fs gs)) + + ------------------------------------------------------------------------------- -- options ------------------------------------------------------------------------------- @@ -282,11 +292,16 @@ instance Y.ToYAML StackYaml where data ResolverFile = ResolverFile { resolverFilePackages :: [ResolverPackage] + , resolverFileFlags :: Map P.PkgName (Map P.FlagName Bool) } +deriving instance Y.FromYAML P.PkgName +deriving instance Y.FromYAML P.FlagName + instance Y.FromYAML ResolverFile where parseYAML = Y.withMap "ResolverFile" $ \m -> ResolverFile <$> m Y..: "packages" + <*> m Y..: "flags" data ResolverPackage = ResolverPackage From 0b0e4a675110e881a3fc5aef3a0cb42484f66130 Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Tue, 22 Nov 2022 15:32:32 +0000 Subject: [PATCH 3/3] Revert "WIP: pick up flags from resolver file" This reverts commit 823912c10563257469f1a6dc7b8d6de4266b905d. --- src/cabal2stack.hs | 19 ++----------------- 1 file changed, 2 insertions(+), 17 deletions(-) diff --git a/src/cabal2stack.hs b/src/cabal2stack.hs index 344b251..51c093c 100644 --- a/src/cabal2stack.hs +++ b/src/cabal2stack.hs @@ -4,14 +4,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wwarn=orphans #-} module Main (main) where import Control.Applicative (optional, (<**>), (<|>)) @@ -62,7 +59,7 @@ main = do S packages _pkgVers extraDeps flags gitPackages <- processUnits (P.pjUnits plan) - resolverFile <- maybe (pure (ResolverFile [] mempty)) getResolverContents optsResolverFile + resolverFile <- maybe (pure (ResolverFile [])) getResolverContents optsResolverFile let resolverContents = Set.fromList (map resolverPackageName (resolverFilePackages resolverFile)) let stackYaml0 :: StackYaml @@ -75,7 +72,7 @@ main = do , let pkgid = P.PkgId pn ver , not (pkgid `Set.member` resolverContents) ] - , syFlags = flags `diffFlags` resolverFileFlags resolverFile + , syFlags = flags , syGitPackages = gitPackages } @@ -85,13 +82,6 @@ main = do "-" -> LBS.putStr (Y.encode [stackYaml]) _ -> LBS.writeFile optsOutput (Y.encode [stackYaml]) - -diffFlags :: Map P.PkgName (Map P.FlagName Bool) - -> Map P.PkgName (Map P.FlagName Bool) - -> Map P.PkgName (Map P.FlagName Bool) -diffFlags = Map.differenceWith (\fs gs -> Just (Map.difference fs gs)) - - ------------------------------------------------------------------------------- -- options ------------------------------------------------------------------------------- @@ -292,16 +282,11 @@ instance Y.ToYAML StackYaml where data ResolverFile = ResolverFile { resolverFilePackages :: [ResolverPackage] - , resolverFileFlags :: Map P.PkgName (Map P.FlagName Bool) } -deriving instance Y.FromYAML P.PkgName -deriving instance Y.FromYAML P.FlagName - instance Y.FromYAML ResolverFile where parseYAML = Y.withMap "ResolverFile" $ \m -> ResolverFile <$> m Y..: "packages" - <*> m Y..: "flags" data ResolverPackage = ResolverPackage