diff --git a/doc/GUIDE.md b/doc/GUIDE.md index d460ed06c1..2f5e453ae4 100644 --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -630,225 +630,420 @@ using [Yesod](http://www.yesodweb.com/). To get the code, we'll use the `stack unpack` command: ``` -michael@d30748af6d3d:~$ stack unpack yackage-0.8.0 -yackage-0.8.0: download -Unpacked yackage-0.8.0 to /home/michael/yackage-0.8.0/ -michael@d30748af6d3d:~$ cd yackage-0.8.0/ +cueball:~$ stack unpack yackage-0.8.0 +Unpacked yackage-0.8.0 to /var/home/harendra/yackage-0.8.0/ +cueball:~$ cd yackage-0.8.0/ ``` +### stack init This new directory does not have a stack.yaml file, so we need to make one first. We could do it by hand, but let's be lazy instead with the `stack init` command: ``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack init -Writing default config file to: /home/michael/yackage-0.8.0/stack.yaml -Basing on cabal files: -- /home/michael/yackage-0.8.0/yackage.cabal +cueball:~/yackage-0.8.0$ stack init +Using cabal packages: +- yackage.cabal -Checking against build plan lts-3.2 -Selected resolver: lts-3.2 -Wrote project config to: /home/michael/yackage-0.8.0/stack.yaml -michael@d30748af6d3d:~/yackage-0.8.0$ cat stack.yaml -flags: - yackage: - upload: true -packages: -- '.' -extra-deps: [] -resolver: lts-3.2 +Selecting the best among 6 snapshots... + +* Matches lts-4.1 + +Selected resolver: lts-4.1 +Initialising configuration using resolver: lts-4.1 +Total number of user packages considered: 1 +Writing configuration to file: stack.yaml +All done. ``` stack init does quite a few things for you behind the scenes: -* Creates a list of snapshots that would be good candidates. - * The basic algorithm here is to prefer options in this order: - * Snapshots for which you've already built some packages (to - increase sharing of binary package databases, as we'll discuss later) - * Recent snapshots - * LTS - * These preferences can be tweaked with command line flags (see `stack init - --help`). * Finds all of the .cabal files in your current directory and subdirectories (unless you use `--ignore-subdirs`) and determines the packages and versions they require -* Finds a combination of snapshot and package flags that allows everything to - compile +* Finds the best combination of snapshot and package flags that allows everything to + compile with minimum external dependencies +* It tries to look for the best matching snapshot from latest LTS, latest + nightly, other LTS versions in that order Assuming it finds a match, it will write your stack.yaml file, and everything -will work. Given that LTS Haskell and Stackage Nightly have ~1400 of the most -common Haskell packages, this will often be enough. However, let's simulate a -failure by adding acme-missiles to our build-depends and re-initing: +will work. + +#### External Dependencies + +Given that LTS Haskell and Stackage Nightly have ~1400 of the most common +Haskell packages, this will often be enough to build most packages. However, +at times, you may find that not all dependencies required may be available in +the Stackage snapshots. + +Let's simulate an unsatisfied dependency by adding acme-missiles to our +build-depends and re-initing: ``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack init --force -Writing default config file to: /home/michael/yackage-0.8.0/stack.yaml -Basing on cabal files: -- /home/michael/yackage-0.8.0/yackage.cabal +cueball:~/yackage-0.8.0$ stack init --force +Using cabal packages: +- yackage.cabal -Checking against build plan lts-3.2 +Selecting the best among 6 snapshots... -* Build plan did not match your requirements: +* Partially matches lts-4.1 acme-missiles not found - - yackage requires -any + - yackage requires -any + - yackage flags: upload = True -Checking against build plan lts-3.1 - -* Build plan did not match your requirements: +* Partially matches nightly-2016-01-16 acme-missiles not found - - yackage requires -any + - yackage requires -any + - yackage flags: upload = True +* Partially matches lts-3.22 + acme-missiles not found + - yackage requires -any + - yackage flags: upload = True -Checking against build plan nightly-2015-08-26 +. +. +. -* Build plan did not match your requirements: +Selected resolver: lts-4.1 +Resolver 'lts-4.1' does not have all the packages to match your requirements. acme-missiles not found - - yackage requires -any + - yackage requires -any + - yackage flags: upload = True +However, you can try '--solver' to use external packages. +``` -Checking against build plan lts-2.22 +stack has tested six different snapshots, and in every case discovered that +acme-missiles is not available. In the end it suggested that you use the +`--solver` command line switch if you want to use packages outside Stackage. So +let's give it a try: -* Build plan did not match your requirements: - acme-missiles not found - - yackage requires -any - warp version 3.0.13.1 found - - yackage requires >=3.1 +``` +cueball:~/yackage-0.8.0$ stack init --force --solver +Using cabal packages: +- yackage.cabal +Selecting the best among 6 snapshots... + +* Partially matches lts-4.1 + acme-missiles not found + - yackage requires -any + - yackage flags: upload = True -There was no snapshot found that matched the package bounds in your .cabal files. -Please choose one of the following commands to get started. +. +. +. - stack init --resolver lts-3.2 - stack init --resolver lts-3.1 - stack init --resolver nightly-2015-08-26 - stack init --resolver lts-2.22 +Selected resolver: lts-4.1 +*** Resolver lts-4.1 will need external packages: + acme-missiles not found + - yackage requires -any + - yackage flags: upload = True -You'll then need to add some extra-deps. See the -[stack.yaml documentation](yaml_configuration.html#extra-deps). +Using resolver: lts-4.1 +Using compiler: ghc-7.10.3 +Asking cabal to calculate a build plan... +Trying with packages from lts-4.1 as hard constraints... +Successfully determined a build plan with 3 external dependencies. +Initialising configuration using resolver: lts-4.1 +Total number of user packages considered: 1 +Warning! 3 external dependencies were added. +Overwriting existing configuration file: stack.yaml +All done. +``` -You can also try falling back to a dependency solver with: +As you can verify by viewing stack.yaml, three external dependencies were added +by stack init: - stack init --solver +``` +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: +- acme-missiles-0.3 +- text-1.2.2.0 +- yaml-0.8.15.2 ``` -stack has tested four different snapshots, and in every case discovered that -acme-missiles is not available. Also, when testing lts-2.22, it found that the -warp version provided was too old for yackage. So, what do we do? +Of course, you could have added the external dependencies by manually editing +stack.yaml but stack init does the hard work for you. -The recommended approach is: pick a resolver, and fix the problem. Again, -following the advice mentioned above, default to LTS if you don't have a -preference. In this case, the newest LTS listed is lts-3.2. Let's pick that. -stack has told us the correct command to do this. We'll just remove our old -stack.yaml first and then run it: +#### Excluded Packages + +Sometimes multiple packages in your project may have conflicting requirements. +In that case `stack init` will fail, so what do you do? + +You could manually create stack.yaml by omitting some packages to resolve the +conflict. Alternatively you can ask `stack init` to do that for you by +specifying `--omit-packages` flag on the command line. Let's see how that +works. + +To simulate a conflict we will use acme-missiles-0.3 in yackage and we will +also copy yackage.cabal to another directory and change the name of the file +and package to yackage-test. In this new package we will use acme-missiles-0.2 +instead. Let's see what happens when we run solver: ``` -michael@d30748af6d3d:~/yackage-0.8.0$ rm stack.yaml -michael@d30748af6d3d:~/yackage-0.8.0$ stack init --resolver lts-3.2 -Writing default config file to: /home/michael/yackage-0.8.0/stack.yaml -Basing on cabal files: -- /home/michael/yackage-0.8.0/yackage.cabal +cueball:~/yackage-0.8.0$ stack init --force --solver --omit-packages +Using cabal packages: +- yackage.cabal +- example/yackage-test.cabal -Checking against build plan lts-3.2 +Selecting the best among 6 snapshots... -* Build plan did not match your requirements: +* Partially matches lts-4.2 acme-missiles not found - - yackage requires -any + - yackage requires ==0.3 + - yackage-test requires ==0.2 + - yackage flags: upload = True + - yackage-test flags: upload = True +. +. +. + +*** Failed to arrive at a workable build plan. +*** Ignoring package: yackage-test +*** Resolver lts-4.2 will need external packages: + acme-missiles not found + - yackage requires ==0.3 + - yackage flags: upload = True +Using resolver: lts-4.2 +Using compiler: ghc-7.10.3 +Asking cabal to calculate a build plan... +Trying with packages from lts-4.2 as hard constraints... +Successfully determined a build plan with 3 external dependencies. +Initialising configuration using resolver: lts-4.2 +Total number of user packages considered: 2 +Warning! Ignoring 1 packages due to dependency conflicts: + - "example/yackage-test.cabal" -Selected resolver: lts-3.2 -Wrote project config to: /home/michael/yackage-0.8.0/stack.yaml +Warning! 3 external dependencies were added. +Overwriting existing configuration file: stack.yaml +All done. ``` -As you may guess, `stack build` will now fail due to the missing acme-missiles. -Toward the end of the error message, it says the familiar: +Looking at `stack.yaml`, you will see that the excluded packages have been +commented out: ``` -Recommended action: try adding the following to your extra-deps in /home/michael/yackage-0.8.0/stack.yaml -- acme-missiles-0.3 +# Local packages, usually specified by relative directory name +packages: +- '.' +# The following packages have been ignored due to incompatibility with the resolver compiler or dependency conflicts with other packages +#- example/ ``` -If you're following along at home, try making the necessary stack.yaml -modification to get things building. +In case wrong packages are excluded you can uncomment the right one and comment +the other one. -### Alternative solution: dependency solving +Packages may get excluded due to conflicting requirements among user packages +or due to conflicting requirements between a user package and the resolver +compiler. If all of the packages have a conflict with the compiler then all of +them may get commented out. -There's another solution to consider for missing dependencies. At the end -of the previous error message, it said: +When packages are commented out you will see a warning every time you run a +command which needs the config file. The warning can be disabled by editing the +config file and removing it. -``` -You may also want to try the 'stack solver' command -``` +#### Using a specific resolver -This approach uses a full-blown dependency solver to look at all upstream -package versions available and compare them to your snapshot selection and -version ranges in your .cabal file. In order to use this feature, you'll need -the cabal executable available. Let's build that with: +Sometimes you may want to use a specific resolver for your project instead of +`stack init` picking one for you. You can do that by using `stack init +--resolver `. -``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack build cabal-install -random-1.1: download -mtl-2.2.1: download -network-2.6.2.1: download -old-locale-1.0.0.7: download -random-1.1: configure -random-1.1: build -# ... -cabal-install-1.22.6.0: download -cabal-install-1.22.6.0: configure -cabal-install-1.22.6.0: build -cabal-install-1.22.6.0: install -Completed all 10 actions. -``` +You can also init with a compiler resolver if you do not want to use a +snapshot. That will result in all of your project's dependencies being put +under the `extra-deps` section. + +#### Installing the compiler + +You can install the required compiler if not already installed by using the +`--install-ghc` flag with the `stack init` command. + +#### Miscellaneous and diagnostics + +_Duplicate package names_: If multiple packages under the directory tree have +same name, stack init will report those and automatically ignore one of them. -Now we can use `stack solver`: +_Ignore subdirectories_: By default stack init searches all the subdirectories +for .cabal files. If you do not want that then you can use `--ignore-subdirs` +command line switch. + +_Cabal warnings_: stack init will show warnings if there were issues in reading +a cabal package file. You may want to pay attention to the warnings as +sometimes they may result in incomprehensible errors later on during dependency +solving. + +_Packages with no names_: If the `Name` field in a cabal file is empty or not +present then stack init will refuse to continue. + +_Cabal install errors_: stack init uses `cabal-install` to determine external +dependencies. When cabal-install encounters errors, cabal errors are displayed +as is by stack init for diagnostics. + +_User warnings_: When packages are excluded or external dependencies added +stack will show warnings every time configuration file is loaded. You can +suppress the warnings by editing the config file and removing the warnings from +it. You may see something like this: ``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack solver -This command is not guaranteed to give you a perfect build plan -It's possible that even with the changes generated below, you will still need to do some manual tweaking -Asking cabal to calculate a build plan, please wait -extra-deps: -- acme-missiles-0.3 +cueball:~/yackage-0.8.0$ stack build +Warning: Some packages were found to be incompatible with the resolver and have been left commented out in the packages section. +Warning: Specified resolver could not satisfy all dependencies. Some external packages have been added as dependencies. +You can suppress this message by removing it from stack.yaml + ``` +### stack solver + +While `stack init` is used to create stack configuration file from existing +cabal files, `stack solver` can be used to fine tune or fix an existing stack +configuration file. + +`stack solver` uses the existing file as a constraint. For example it will +use only those packages specified in the existing config file or use existing +external dependencies as constraints to figure out other dependencies. -And if we're exceptionally lazy, we can ask stack to modify our stack.yaml file -for us: +Let's try `stack solver` to verify the config that we generated earlier with +`stack init`: ``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack solver --modify-stack-yaml -This command is not guaranteed to give you a perfect build plan -It's possible that even with the changes generated below, you will still need to do some manual tweaking -Asking cabal to calculate a build plan, please wait -extra-deps: -- acme-missiles-0.3 -Updated /home/michael/yackage-0.8.0/stack.yaml +cueball:~/yackage-0.8.0$ stack solver +Using configuration file: stack.yaml +The following packages are missing from the config: +- example/yackage-test.cabal + +Using cabal packages: +- yackage.cabal + +Using resolver: lts-4.2 +Using compiler: ghc-7.10.3 +Asking cabal to calculate a build plan... +Trying with packages from lts-4.2 and 3 external packages as hard constraints... +Successfully determined a build plan with 3 external dependencies. +No changes needed to stack.yaml ``` -With that change, `stack build` will now run. +It says there are no changes needed to your config. Notice that it also reports +`example/yackage-test.cabal` as missing from the config. It was purposely +omitted by `stack init` to resolve a conflict. -NOTE: You should probably back up your stack.yaml before doing this, such as -committing to Git/Mercurial/Darcs. +Sometimes `stack init` may not be able to give you a perfect configuration. In +that case, you can tweak the configuration file as per your requirements and then +run `stack solver`, it will check the file and suggest or apply any fixes +needed. + +For example, if `stack init` ignored certain packages due to name conflicts or +dependency conflicts, the choice that `stack init` made may not be the correct +one. In that case you can revert the choice and use solver to fix things. -There's one final approach to mention: skipping the snapshot entirely and just -using dependency solving. You can do this with the `--solver` flag to `init`. -This is not a commonly used workflow with stack, as you end up with a large -number of extra-deps and no guarantee that the packages will compile together. -For those interested, however, the option is available. You need to make sure -you have both the ghc and cabal commands on your PATH. An easy way to do this -is to use the `stack exec` command: +Let's try commenting out `.` and uncommenting `examples/` in our previously +generated `stack.yaml` and then run `stack solver`: ``` -michael@d30748af6d3d:~/yackage-0.8.0$ stack exec -- stack init --solver --force -Writing default config file to: /home/michael/yackage-0.8.0/stack.yaml -Basing on cabal files: -- /home/michael/yackage-0.8.0/yackage.cabal +cueball:~/yackage-0.8.0$ stack solver + +Using configuration file: stack.yaml +The following packages are missing from the config: +- yackage.cabal + +Using cabal packages: +- example/yackage-test.cabal -Asking cabal to calculate a build plan, please wait -Selected resolver: ghc-7.10 -Wrote project config to: /home/michael/yackage-0.8.0/stack.yaml +. +. +. + +Retrying with packages from lts-4.2 and 3 external packages as preferences... +Successfully determined a build plan with 5 external dependencies. + +The following changes will be made to stack.yaml: +* Resolver is lts-4.2 +* Dependencies to be added + extra-deps: + - acme-missiles-0.2 + - email-validate-2.2.0 + - tar-0.5.0.1 + +* Dependencies to be deleted + extra-deps: + - acme-missiles-0.3 + +To automatically update stack.yaml, rerun with '--update-config' ``` +Due to the change that we made, solver suggested some new dependencies. +By default it does not make changes to the config. As it suggested you can use +`--update-config` to make changes to the config. + +NOTE: You should probably back up your stack.yaml before doing this, such as +committing to Git/Mercurial/Darcs. + +Sometimes, you may want to use specific versions of certain packages for your +project. To do that you can fix those versions by specifying them in the +extra-deps section and then use `stack solver` to figure out whether it is +feasible to use those or what other dependencies are needed as a result. + +If you want to change the resolver for your project, you can run `stack solver +--resolver ` and it will figure out the changes needed for you. + +Let's see what happens if we change the resolver to lts-2.22: + +``` +cueball:~/yackage-0.8.0$ stack solver --resolver lts-2.22 +Using configuration file: stack.yaml +The following packages are missing from the config: +- yackage.cabal + +Using cabal packages: +- example/yackage-test.cabal + +Using resolver: lts-2.22 +Using compiler: ghc-7.8.4 + +. +. +. + +Retrying with packages from lts-2.22 and 3 external packages as preferences... +Successfully determined a build plan with 19 external dependencies. + +The following changes will be made to stack.yaml: +* Resolver is lts-2.22 +* Flags to be added + flags: + - old-locale: true + +* Dependencies to be added + extra-deps: + - acme-missiles-0.2 + - aeson-0.10.0.0 + - aeson-compat-0.3.0.0 + - attoparsec-0.13.0.1 + - conduit-extra-1.1.9.2 + - email-validate-2.2.0 + - hex-0.1.2 + - http-api-data-0.2.2 + - http2-1.1.0 + - persistent-2.2.4 + - persistent-template-2.1.5 + - primitive-0.6.1.0 + - tar-0.5.0.1 + - unix-time-0.3.6 + - vector-0.11.0.0 + - wai-extra-3.0.14 + - warp-3.1.3.1 + +* Dependencies to be deleted + extra-deps: + - acme-missiles-0.3 + +To automatically update stack.yaml, rerun with '--update-config' +``` + +As you can see, it automatically suggested changes in `extra-deps` due to the +change of resolver. + ## Different databases Time to take a short break from hands-on examples and discuss a little diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index 4c8659d9a9..72ec1df390 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -128,6 +128,28 @@ You can also specify `entrypoints`. By default all your executables are placed in `/usr/local/bin`, but you can specify a list using `executables` to only add some. +### user-message + +A user-message is inserted by `stack init` when it omits packages or adds +external dependencies. For example: + +```yaml +user-message: ! 'Warning: Some packages were found to be incompatible with the resolver + and have been left commented out in the packages section. + + Warning: Specified resolver could not satisfy all dependencies. Some external packages + have been added as dependencies. + + You can suppress this message by removing it from stack.yaml + +' +``` + +This messages is displayed every time the config is loaded by stack and serves +as a reminder for the user to review the configuration and make any changes if +needed. The user can delete this message if the generated configuration is +acceptable. + ## Non-project config Non-project config options may go in the global config (`/etc/stack/config.yaml`) or the user config (`~/.stack/config.yaml`). diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 7d13365ccf..e5c56a8da3 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -10,10 +10,14 @@ -- snapshot. module Stack.BuildPlan - ( gpdPackages - , BuildPlanException (..) + ( BuildPlanException (..) , BuildPlanCheck (..) , checkSnapBuildPlan + , DepError(..) + , DepErrors + , gpdPackageDeps + , gpdPackages + , gpdPackageName , MiniBuildPlan(..) , MiniPackageInfo(..) , loadMiniBuildPlan @@ -23,8 +27,7 @@ module Stack.BuildPlan , ToolMap , getToolMap , shadowMiniBuildPlan - , showCompilerErrors - , showDepErrors + , showItems , parseCustomMiniBuildPlan ) where @@ -652,6 +655,36 @@ data BuildPlanCheck = | BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors CompilerVersion +-- Greater means a better plan +instance Ord BuildPlanCheck where + BuildPlanCheckPartial _ e1 `compare` BuildPlanCheckPartial _ e2 = + compare (Map.size e1) (Map.size e2) + + BuildPlanCheckFail _ e1 _ `compare` BuildPlanCheckFail _ e2 _ = + let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e)) + in compare (numUserPkgs e1) (numUserPkgs e2) + + BuildPlanCheckOk {} `compare` BuildPlanCheckOk {} = EQ + BuildPlanCheckOk {} `compare` BuildPlanCheckPartial {} = GT + BuildPlanCheckOk {} `compare` BuildPlanCheckFail {} = GT + BuildPlanCheckPartial {} `compare` BuildPlanCheckFail {} = GT + _ `compare` _ = LT + +instance Eq BuildPlanCheck where + BuildPlanCheckOk {} == BuildPlanCheckOk {} = True + BuildPlanCheckPartial _ e1 == BuildPlanCheckPartial _ e2 = + Map.size e1 == Map.size e2 + BuildPlanCheckFail _ e1 _ == BuildPlanCheckFail _ e2 _ = + let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e)) + in numUserPkgs e1 == numUserPkgs e2 + + _ == _ = False + +instance Show BuildPlanCheck where + show BuildPlanCheckOk {} = "" + show (BuildPlanCheckPartial f e) = T.unpack $ showDepErrors f e + show (BuildPlanCheckFail f e c) = T.unpack $ showCompilerErrors f e c + -- | Check a set of 'GenericPackageDescription's and a set of flags against a -- given snapshot. Returns how well the snapshot satisfies the dependencies of -- the packages. @@ -697,67 +730,67 @@ selectBestSnapshot , MonadBaseControl IO m) => [GenericPackageDescription] -> [SnapName] - -> m (Maybe SnapName) + -> m (SnapName, BuildPlanCheck) selectBestSnapshot gpds snaps = do $logInfo $ "Selecting the best among " <> T.pack (show (length snaps)) <> " snapshots...\n" loop Nothing snaps where - loop Nothing [] = return Nothing - loop (Just (snap, _)) [] = return $ Just snap + loop Nothing [] = error "Bug: in best snapshot selection" + loop (Just pair) [] = return pair loop bestYet (snap:rest) = do result <- checkSnapBuildPlan gpds Nothing snap reportResult result snap + let new = (snap, result) case result of - BuildPlanCheckFail _ _ _ -> loop bestYet rest - BuildPlanCheckOk _ -> return $ Just snap - BuildPlanCheckPartial _ e -> do - case bestYet of - Nothing -> loop (Just (snap, e)) rest - Just prev -> - loop (Just (betterSnap prev (snap, e))) rest - - betterSnap (s1, e1) (s2, e2) - | (Map.size e1) <= (Map.size e2) = (s1, e1) - | otherwise = (s2, e2) - - reportResult (BuildPlanCheckOk _) snap = do - $logInfo $ "* Selected " <> renderSnapName snap + BuildPlanCheckOk {} -> return new + _ -> case bestYet of + Nothing -> loop (Just new) rest + Just old -> loop (Just (betterSnap old new)) rest + + betterSnap (s1, r1) (s2, r2) + | r1 <= r2 = (s1, r1) + | otherwise = (s2, r2) + + reportResult BuildPlanCheckOk {} snap = do + $logInfo $ "* Matches " <> renderSnapName snap $logInfo "" - reportResult (BuildPlanCheckPartial f errs) snap = do + reportResult r@BuildPlanCheckPartial {} snap = do $logWarn $ "* Partially matches " <> renderSnapName snap - $logWarn $ indent $ showDepErrors f errs + $logWarn $ indent $ T.pack $ show r - reportResult (BuildPlanCheckFail f errs compiler) snap = do + reportResult r@BuildPlanCheckFail {} snap = do $logWarn $ "* Rejected " <> renderSnapName snap - $logWarn $ indent $ showCompilerErrors f errs compiler + $logWarn $ indent $ T.pack $ show r indent t = T.unlines $ fmap (" " <>) (T.lines t) +showItems :: Show a => [a] -> Text +showItems items = T.concat (map formatItem items) + where + formatItem item = T.concat + [ " - " + , T.pack $ show item + , "\n" + ] + +showMapPackages :: Map PackageName a -> Text +showMapPackages mp = showItems $ Map.keys mp + showCompilerErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> CompilerVersion -> Text showCompilerErrors flags errs compiler = - -- TODO print the package filename to enable quick mapping for the user T.concat [ compilerVersionText compiler , " cannot be used for these packages:\n" - , T.concat (map formatError (Map.toList errs)) + , showMapPackages $ Map.unions (Map.elems (fmap deNeededBy errs)) , showDepErrors flags errs -- TODO only in debug mode ] - where - formatError (_, DepError _ neededBy) = T.concat $ - map formatItem (Map.toList neededBy) - - formatItem (user, _) = T.concat - [ " - " - , T.pack $ packageNameString user - , "\n" - ] showDepErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> Text showDepErrors flags errs = diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 3ef8e8d3ab..f0795befc1 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -374,6 +374,11 @@ loadConfig configArgs mstackYaml mresolver = do (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = False}}) extraConfigs0 mproject <- loadProjectConfig mstackYaml + + let printUserMessage (p, _, _) = + maybe (return ()) ($logWarn . T.pack) (projectUserMsg p) + maybe (return ()) printUserMessage mproject + let mproject' = (\(project, stackYaml, _) -> (project, stackYaml)) <$> mproject config <- configFromConfigMonoid stackRoot userConfigPath mresolver mproject' $ mconcat $ case mproject of @@ -435,7 +440,8 @@ loadBuildConfig mproject config mresolver mcompiler = do $logInfo ("Writing implicit global project config file to: " <> T.pack dest') $logInfo "Note: You can change the snapshot via the resolver field there." let p = Project - { projectPackages = mempty + { projectUserMsg = Nothing + , projectPackages = mempty , projectExtraDeps = mempty , projectFlags = mempty , projectResolver = r diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index c71ecda940..e8c69ccced 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -5,28 +5,28 @@ module Stack.Init ( initProject , InitOpts (..) - , SnapPref (..) - , Method (..) ) where import Control.Exception (assert) -import Control.Exception.Enclosed (catchAny, handleIO) -import Control.Monad (liftM, when) +import Control.Exception.Enclosed (catchAny) +import Control.Monad (when) import Control.Monad.Catch (MonadMask, throwM) import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (MonadReader) +import Control.Monad.Reader (asks, MonadReader) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Char8 as BC +import Data.Function (on) import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap import qualified Data.Foldable as F -import Data.List (sortBy) +import Data.List (intersect, maximumBy) import Data.List.Extra (nubOrd) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (fromJust) import Data.Monoid import qualified Data.Text as T import qualified Data.Yaml as Yaml @@ -40,10 +40,10 @@ import Stack.Solver import Stack.Types import Stack.Types.Internal ( HasTerminal, HasReExec , HasLogLevel) -import System.Directory ( getDirectoryContents - , makeRelativeToCurrentDirectory) +import System.Directory (makeRelativeToCurrentDirectory) import Stack.Config ( getSnapshots , makeConcreteResolver) +import qualified System.FilePath as FP -- | Generate stack.yaml initProject @@ -53,8 +53,9 @@ initProject , HasTerminal env) => Path Abs Dir -> InitOpts + -> Maybe AbstractResolver -> m () -initProject currDir initOpts = do +initProject currDir initOpts mresolver = do let dest = currDir stackDotYaml dest' = toFilePath dest @@ -69,57 +70,114 @@ initProject currDir initOpts = do let noPkgMsg = "In order to init, you should have an existing .cabal \ \file. Please try \"stack new\" instead." - dupPkgFooter = "You have the following options:\n" - <> "- Use '--ignore-subdirs' command line switch to ignore " - <> "packages in subdirectories. You can init subdirectories as " - <> "independent projects.\n" - <> "- Put selected packages in the stack config file " - <> "and then use 'stack solver' command to automatically resolve " - <> "dependencies and update the config file." - cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir - gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter + (bundle, dupPkgs) <- cabalPackagesCheck cabalfps noPkgMsg Nothing + + (r, flags, extraDeps, rbundle) <- getDefaultResolver dest initOpts + mresolver bundle + + let ignored = Map.difference bundle rbundle + dupPkgMsg + | (dupPkgs /= []) = + "Warning: Some packages were found to have names conflicting \ + \with others and have been commented out in the \ + \packages section.\n" + | otherwise = "" + + missingPkgMsg + | (Map.size ignored > 0) = + "Warning: Some packages were found to be incompatible with \ + \the resolver and have been left commented out in the \ + \packages section.\n" + | otherwise = "" + + extraDepMsg + | (Map.size extraDeps > 0) = + "Warning: Specified resolver could not satisfy all \ + \dependencies. Some external packages have been added \ + \as dependencies.\n" + | otherwise = "" + + makeUserMsg msgs = + let msg = concat msgs + in if msg /= "" then + msg <> "You can suppress this message by removing it from \ + \stack.yaml\n" + else "" - (r, flags, extraDeps) <- - getDefaultResolver dest (map parent cabalfps) gpds initOpts - let p = Project - { projectPackages = pkgs + userMsg = makeUserMsg [dupPkgMsg, missingPkgMsg, extraDepMsg] + + gpds = Map.elems $ fmap snd rbundle + p = Project + { projectUserMsg = if userMsg == "" then Nothing else Just userMsg + , projectPackages = pkgs , projectExtraDeps = extraDeps , projectFlags = removeSrcPkgDefaultFlags gpds flags , projectResolver = r , projectCompiler = Nothing , projectExtraPackageDBs = [] } - pkgs = map toPkg cabalfps - toPkg fp = PackageEntry + + makeRelDir dir = + case stripDir currDir dir of + Nothing + | currDir == dir -> "." + | otherwise -> assert False $ toFilePath dir + Just rel -> toFilePath rel + + makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath + + pkgs = map toPkg $ Map.elems (fmap (parent . fst) rbundle) + toPkg dir = PackageEntry { peValidWanted = Nothing , peExtraDepMaybe = Nothing - , peLocation = PLFilePath $ - case stripDir currDir $ parent fp of - Nothing - | currDir == parent fp -> "." - | otherwise -> assert False $ toFilePath $ parent fp - Just rel -> toFilePath rel + , peLocation = PLFilePath $ makeRelDir dir , peSubdirs = [] } + indent t = T.unlines $ fmap (" " <>) (T.lines t) $logInfo $ "Initialising configuration using resolver: " <> resolverName r + $logInfo $ "Total number of user packages considered: " + <> (T.pack $ show $ (Map.size bundle + length dupPkgs)) + + when (dupPkgs /= []) $ do + $logWarn $ "Warning! Ignoring " + <> (T.pack $ show $ length dupPkgs) + <> " duplicate packages:" + rels <- mapM makeRel dupPkgs + $logWarn $ indent $ showItems rels + + when (Map.size ignored > 0) $ do + $logWarn $ "Warning! Ignoring " + <> (T.pack $ show $ Map.size ignored) + <> " packages due to dependency conflicts:" + rels <- mapM makeRel (Map.elems (fmap fst ignored)) + $logWarn $ indent $ showItems $ rels + + when (Map.size extraDeps > 0) $ do + $logWarn $ "Warning! " <> (T.pack $ show $ Map.size extraDeps) + <> " external dependencies were added." $logInfo $ (if exists then "Overwriting existing configuration file: " else "Writing configuration to file: ") <> T.pack reldest - liftIO $ L.writeFile dest' $ B.toLazyByteString $ renderStackYaml p + liftIO $ L.writeFile dest' + $ B.toLazyByteString + $ renderStackYaml p + (Map.elems $ fmap (makeRelDir . parent . fst) ignored) + (map (makeRelDir . parent) dupPkgs) $logInfo "All done." -- | Render a stack.yaml file with comments, see: -- https://github.com/commercialhaskell/stack/issues/226 -renderStackYaml :: Project -> B.Builder -renderStackYaml p = +renderStackYaml :: Project -> [FilePath] -> [FilePath] -> B.Builder +renderStackYaml p ignoredPackages dupPackages = case Yaml.toJSON p of Yaml.Object o -> renderObject o _ -> assert False $ B.byteString $ Yaml.encode p where renderObject o = + B.byteString "# This file was automatically generated by stack init\n" <> B.byteString "# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html\n\n" <> F.foldMap (goComment o) comments <> goOthers (o `HM.difference` HM.fromList comments) <> @@ -139,21 +197,39 @@ renderStackYaml p = \# compiler-check: newer-minor\n" comments = - [ ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)") + [ ("user-message", "A message to be displayed to the user. Used when autogenerated config ignored some packages or added extra deps.") + , ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)") , ("packages", "Local packages, usually specified by relative directory name") , ("extra-deps", "Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)") , ("flags", "Override default flag values for local packages and extra-deps") , ("extra-package-dbs", "Extra package databases containing global packages") ] + commentedPackages = + let ignoredComment = "# The following packages have been ignored \ + \due to incompatibility with the resolver compiler or \ + \dependency conflicts with other packages" + dupComment = "# The following packages have been ignored due \ + \to package name conflict with other packages" + in commentPackages ignoredComment ignoredPackages + <> commentPackages dupComment dupPackages + + commentPackages comment pkgs + | pkgs /= [] = + B.byteString (BC.pack $ comment ++ "\n") + <> (B.byteString $ BC.pack $ concat + $ (map (\x -> "#- " ++ x ++ "\n") pkgs) ++ ["\n"]) + | otherwise = "" + goComment o (name, comment) = case HM.lookup name o of - Nothing -> assert False mempty + Nothing -> assert (name == "user-message") mempty Just v -> B.byteString "# " <> B.byteString comment <> B.byteString "\n" <> B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <> + if (name == "packages") then commentedPackages else "" <> B.byteString "\n" goOthers o @@ -161,9 +237,9 @@ renderStackYaml p = | otherwise = assert False $ B.byteString $ Yaml.encode o getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m) - => m (Maybe Snapshots) + => m Snapshots getSnapshots' = - liftM Just getSnapshots `catchAny` \e -> do + getSnapshots `catchAny` \e -> do $logError $ "Unable to download snapshot list, and therefore could " <> "not generate a stack.yaml file automatically" @@ -178,7 +254,7 @@ getSnapshots' = $logError " http://docs.haskellstack.org/en/stable/yaml_configuration.html" $logError "" $logError $ "Exception was: " <> T.pack (show e) - return Nothing + error "" -- | Get the default resolver value getDefaultResolver @@ -187,114 +263,186 @@ getDefaultResolver , HasHttpManager env , HasLogLevel env , HasReExec env , HasTerminal env) => Path Abs File -- ^ stack.yaml - -> [Path Abs Dir] -- ^ cabal dirs - -> [C.GenericPackageDescription] -- ^ cabal descriptions -> InitOpts + -> Maybe AbstractResolver + -> Map PackageName (Path Abs File, C.GenericPackageDescription) + -- ^ Src package name: cabal dir, cabal package description -> m ( Resolver , Map PackageName (Map FlagName Bool) - , Map PackageName Version) -getDefaultResolver stackYaml cabalDirs gpds initOpts = do - resolver <- getResolver (ioMethod initOpts) - result <- checkResolverSpec gpds Nothing resolver + , Map PackageName Version + , Map PackageName (Path Abs File, C.GenericPackageDescription)) + -- ^ ( Resolver + -- , Flags for src packages and extra deps + -- , Extra dependencies + -- , Src packages actually considered) +getDefaultResolver stackYaml initOpts mresolver bundle = + maybe selectSnapResolver makeConcreteResolver mresolver + >>= getWorkingResolverPlan stackYaml initOpts bundle + where + -- TODO support selecting best across regular and custom snapshots + selectSnapResolver = do + let gpds = Map.elems (fmap snd bundle) + snaps <- getSnapshots' >>= getRecommendedSnapshots + (s, r) <- selectBestSnapshot gpds snaps + case r of + BuildPlanCheckFail {} | not (omitPackages initOpts) + -> throwM (NoMatchingSnapshot snaps) + _ -> return $ ResolverSnapshot s - case result of - BuildPlanCheckOk f-> return (resolver, f, Map.empty) - BuildPlanCheckPartial f e - | needSolver resolver initOpts -> solve (resolver, f) - | otherwise -> - throwM $ ResolverPartial resolver (showDepErrors f e) - BuildPlanCheckFail f e c -> - throwM $ ResolverMismatch resolver (showCompilerErrors f e c) +getWorkingResolverPlan + :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m + , MonadReader env m, HasConfig env , HasGHCVariant env + , HasHttpManager env , HasLogLevel env , HasReExec env + , HasTerminal env) + => Path Abs File -- ^ stack.yaml + -> InitOpts + -> Map PackageName (Path Abs File, C.GenericPackageDescription) + -- ^ Src package name: cabal dir, cabal package description + -> Resolver + -> m ( Resolver + , Map PackageName (Map FlagName Bool) + , Map PackageName Version + , Map PackageName (Path Abs File, C.GenericPackageDescription)) + -- ^ ( Resolver + -- , Flags for src packages and extra deps + -- , Extra dependencies + -- , Src packages actually considered) +getWorkingResolverPlan stackYaml initOpts bundle resolver = do + $logInfo $ "Selected resolver: " <> resolverName resolver + go bundle + where + go info = do + eres <- checkBundleResolver stackYaml initOpts info resolver + -- if some packages failed try again using the rest + case eres of + Right (f, edeps)-> return (resolver, f, edeps, info) + Left ignored + | Map.null available -> do + $logWarn "*** Could not find a working plan for any of \ + \the user packages.\nProceeding to create a \ + \config anyway." + return (resolver, Map.empty, Map.empty, Map.empty) + | otherwise -> do + when ((Map.size available) == (Map.size info)) $ + error "Bug: No packages to ignore" + if length ignored > 1 then do + $logWarn "*** Ignoring packages:" + $logWarn $ indent $ showItems ignored + else + $logWarn $ "*** Ignoring package: " + <> (T.pack $ packageNameString (head ignored)) + + go available + where + indent t = T.unlines $ fmap (" " <>) (T.lines t) + isAvailable k _ = not (k `elem` ignored) + available = Map.filterWithKey isAvailable info + +checkBundleResolver + :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m + , MonadReader env m, HasConfig env , HasGHCVariant env + , HasHttpManager env , HasLogLevel env , HasReExec env + , HasTerminal env) + => Path Abs File -- ^ stack.yaml + -> InitOpts + -> Map PackageName (Path Abs File, C.GenericPackageDescription) + -- ^ Src package name: cabal dir, cabal package description + -> Resolver + -> m (Either [PackageName] ( Map PackageName (Map FlagName Bool) + , Map PackageName Version)) +checkBundleResolver stackYaml initOpts bundle resolver = do + result <- checkResolverSpec gpds Nothing resolver + case result of + BuildPlanCheckOk f -> return $ Right (f, Map.empty) + BuildPlanCheckPartial f _ + | needSolver resolver initOpts -> do + $logWarn $ "*** Resolver " <> resolverName resolver + <> " will need external packages: " + $logWarn $ indent $ T.pack $ show result + solve f + | otherwise -> throwM $ ResolverPartial resolver (show result) + BuildPlanCheckFail _ e _ + | (omitPackages initOpts) -> do + $logWarn $ "*** Resolver compiler mismatch: " + <> resolverName resolver + $logWarn $ indent $ T.pack $ show result + let failed = Map.unions (Map.elems (fmap deNeededBy e)) + return $ Left (Map.keys failed) + | otherwise -> throwM $ ResolverMismatch resolver (show result) where - solve (res, f) = do - let srcConstraints = mergeConstraints (gpdPackages gpds) f - mresolver <- solveResolverSpec stackYaml cabalDirs - (res, srcConstraints, Map.empty) - case mresolver of - Just (src, ext) -> do - return (res, fmap snd (Map.union src ext), fmap fst ext) - Nothing - | forceOverwrite initOpts -> do - $logWarn "\nSolver could not arrive at a workable build \ - \plan.\nProceeding to create a config with an \ - \incomplete plan anyway..." - return (res, f, Map.empty) + indent t = T.unlines $ fmap (" " <>) (T.lines t) + gpds = Map.elems (fmap snd bundle) + solve flags = do + let cabalDirs = map parent (Map.elems (fmap fst bundle)) + srcConstraints = mergeConstraints (gpdPackages gpds) flags + + eresult <- solveResolverSpec stackYaml cabalDirs + (resolver, srcConstraints, Map.empty) + case eresult of + Right (src, ext) -> + return $ Right (fmap snd (Map.union src ext), fmap fst ext) + Left packages + | omitPackages initOpts, srcpkgs /= []-> do + pkg <- findOneIndependent srcpkgs flags + return $ Left [pkg] | otherwise -> throwM (SolverGiveUp giveUpMsg) + where srcpkgs = intersect (Map.keys bundle) packages + + -- among a list of packages find one on which none among the rest of the + -- packages depend. This package is a good candidate to be removed from + -- the list of packages when there is conflict in dependencies among this + -- set of packages. + findOneIndependent packages flags = do + platform <- asks (configPlatform . getConfig) + (compiler, _) <- getResolverConstraints stackYaml resolver + let getGpd pkg = snd (fromJust (Map.lookup pkg bundle)) + getFlags pkg = fromJust (Map.lookup pkg flags) + deps pkg = gpdPackageDeps (getGpd pkg) compiler platform + (getFlags pkg) + allDeps = concat $ map (Map.keys . deps) packages + isIndependent pkg = not $ pkg `elem` allDeps + + -- prefer to reject packages in deeper directories + path pkg = fst (fromJust (Map.lookup pkg bundle)) + pathlen = length . FP.splitPath . toFilePath . path + maxPathlen = maximumBy (compare `on` pathlen) + + return $ maxPathlen (filter isIndependent packages) giveUpMsg = concat - [ " - Use '--ignore-subdirs' to skip packages in subdirectories.\n" - , " - Update external packages with 'stack update' and try again.\n" - , " - Use '--force' to create an initial " - , toFilePath stackDotYaml <> ", tweak it and run 'stack solver':\n" - , " - Remove any unnecessary packages.\n" + [ " - Use '--omit-packages to exclude conflicting package(s).\n" + , " - Tweak the generated " + , toFilePath stackDotYaml <> " and then run 'stack solver':\n" , " - Add any missing remote packages.\n" , " - Add extra dependencies to guide solver.\n" + , " - Update external packages with 'stack update' and try again.\n" ] - -- TODO support selecting best across regular and custom snapshots - getResolver (MethodSnapshot snapPref) = selectSnapResolver snapPref - getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver - - selectSnapResolver snapPref = do - msnaps <- getSnapshots' - snaps <- maybe (error "No snapshots to select from.") - (getRecommendedSnapshots snapPref) - msnaps - selectBestSnapshot gpds snaps - >>= maybe (throwM (NoMatchingSnapshot snaps)) - (return . ResolverSnapshot) - needSolver _ (InitOpts {useSolver = True}) = True needSolver (ResolverCompiler _) _ = True needSolver _ _ = False getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) - => SnapPref - -> Snapshots + => Snapshots -> m [SnapName] -getRecommendedSnapshots pref snapshots = do - -- Get the most recent LTS and Nightly in the snapshots directory and - -- prefer them over anything else, since odds are high that something - -- already exists for them. - existing <- - liftM (sortBy (flip compare) . mapMaybe (parseSnapName . T.pack)) $ - snapshotsDir >>= - liftIO . handleIO (const $ return []) - . getDirectoryContents . toFilePath - let isLTS LTS{} = True - isLTS Nightly{} = False - isNightly Nightly{} = True - isNightly LTS{} = False - - names = nubOrd $ concat - [ take 2 $ filter isLTS existing - , take 2 $ filter isNightly existing - , map (uncurry LTS) - (take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots) - , [Nightly $ snapshotsNightly snapshots] - ] - - namesLTS = filter isLTS names - namesNightly = filter isNightly names - - case pref of - PrefNone -> return names - PrefLTS -> return $ namesLTS ++ namesNightly - PrefNightly -> return $ namesNightly ++ namesLTS +getRecommendedSnapshots snapshots = do + -- in order - Latest LTS, Latest Nightly, all LTS most recent first + return $ nubOrd $ concat + [ map (uncurry LTS) + (take 1 $ reverse $ IntMap.toList $ snapshotsLts snapshots) + , [Nightly $ snapshotsNightly snapshots] + , map (uncurry LTS) + (drop 1 $ reverse $ IntMap.toList $ snapshotsLts snapshots) + ] data InitOpts = InitOpts - { ioMethod :: !Method - -- ^ Use solver - , useSolver :: Bool - -- ^ Preferred snapshots + { useSolver :: Bool + -- ^ Use solver to determine required external dependencies + , omitPackages :: Bool + -- ^ Exclude conflicting or incompatible user packages , forceOverwrite :: Bool - -- ^ Overwrite existing files + -- ^ Overwrite existing stack.yaml , includeSubDirs :: Bool -- ^ If True, include all .cabal files found in any sub directories } - -data SnapPref = PrefNone | PrefLTS | PrefNightly - --- | Method of initializing -data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 4851771498..d272cc8adc 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -68,9 +68,12 @@ data BuildCommand deriving (Eq) -- | Allows adjust global options depending on their context +-- Note: This was being used to remove ambibuity between the local and global +-- implementation of stack init --resolver option. Now that stack init has no +-- local --resolver this is not being used anymore but the code is kept for any +-- similar future use cases. data GlobalOptsContext = OuterGlobalOpts -- ^ Global options before subcommand name - | InitCmdGlobalOpts -- ^ Global options following 'stack init' | OtherCmdGlobalOpts -- ^ Global options following any other subcommand deriving (Show, Eq) @@ -637,11 +640,7 @@ globalOptsParser kind defLogLevel = optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*> logLevelOptsParser hide0 defLogLevel <*> configOptsParser hide0 <*> - (if kind == InitCmdGlobalOpts - -- The 'stack init' command has its own '--resolver' option, and having a global - -- one causes ambiguity, so disable it. - then pure Nothing - else optional (abstractResolverOptsParser hide0)) <*> + optional (abstractResolverOptsParser hide0) <*> optional (compilerOptsParser hide0) <*> maybeBoolFlags "terminal" @@ -670,33 +669,18 @@ globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts initOptsParser :: Parser InitOpts initOptsParser = - InitOpts <$> method <*> solver <*> overwrite <*> fmap not ignoreSubDirs + InitOpts <$> solver <*> omitPackages + <*> overwrite <*> fmap not ignoreSubDirs where ignoreSubDirs = switch (long "ignore-subdirs" <> help "Do not search for .cabal files in sub directories") overwrite = switch (long "force" <> - help "Force overwriting an existing stack.yaml or \ - \creating a stack.yaml with incomplete config.") + help "Force overwriting an existing stack.yaml") + omitPackages = switch (long "omit-packages" <> + help "Exclude conflicting or incompatible user packages") solver = switch (long "solver" <> help "Use a dependency solver to determine extra dependencies") - method = (MethodResolver <$> resolver) - <|> (MethodSnapshot <$> snapPref) - - snapPref = - flag' PrefLTS - (long "prefer-lts" <> - help "Prefer LTS snapshots over Nightly snapshots") <|> - flag' PrefNightly - (long "prefer-nightly" <> - help "Prefer Nightly snapshots over LTS snapshots") <|> - pure PrefNone - - resolver = option readAbstractResolver - (long "resolver" <> - metavar "RESOLVER" <> - help "Use the specified resolver") - -- | Parser for a logging level. logLevelOptsParser :: Bool -> Maybe LogLevel -> Parser (Maybe LogLevel) logLevelOptsParser hide defLogLevel = diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 672878e847..eb383d0bd9 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -6,6 +6,7 @@ module Stack.Solver ( checkResolverSpec , cabalPackagesCheck , findCabalFiles + , getResolverConstraints , mergeConstraints , solveExtraDeps , solveResolverSpec @@ -22,11 +23,14 @@ import Control.Monad.Trans.Control import Data.Aeson.Extended (object, (.=), toJSON, logJSONWarnings) import qualified Data.ByteString as S import Data.Either +import Data.Function (on) import qualified Data.HashMap.Strict as HashMap -import Data.List ((\\), isSuffixOf, intercalate) +import Data.List ( (\\), isSuffixOf, intercalate + , minimumBy) import Data.List.Extra (groupSortOn) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (catMaybes, isNothing, mapMaybe) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set @@ -37,7 +41,9 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Encoding (decodeUtf8With) import qualified Data.Yaml as Yaml +import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C +import qualified Distribution.Text as C import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.Find (findFiles) @@ -71,7 +77,7 @@ cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, Mo -> ConstraintSpec -- ^ src constraints -> ConstraintSpec -- ^ dep constraints -> [String] -- ^ additional arguments - -> m (Maybe ConstraintSpec) + -> m (Either [PackageName] ConstraintSpec) cabalSolver menv cabalfps constraintType srcConstraints depConstraints cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do @@ -103,22 +109,52 @@ cabalSolver menv cabalfps constraintType toConstraintArgs (flagConstraints constraintType) ++ fmap toFilePath cabalfps - catch (liftM Just (readProcessStdout (Just tmpdir) menv "cabal" args)) + catch (liftM Right (readProcessStdout (Just tmpdir) menv "cabal" args)) (\ex -> case ex of - ReadProcessException _ _ _ err -> do - let errMsg = decodeUtf8With lenientDecode err - if LT.isInfixOf "Could not resolve dependencies" errMsg - then do - $logInfo "Attempt failed." - $logInfo "\n>>>> Cabal errors begin" - $logInfo $ LT.toStrict errMsg - <> "<<<< Cabal errors end\n" - return Nothing - else throwM ex + ReadProcessException _ _ _ err -> return $ Left err _ -> throwM ex) - >>= maybe (return Nothing) parseCabalOutput + >>= either parseCabalErrors parseCabalOutput where + errCheck = T.isInfixOf "Could not resolve dependencies" + + parseCabalErrors err = do + let errExit e = error $ "Could not parse cabal-install errors:\n" + ++ (T.unpack e) + msg = LT.toStrict $ decodeUtf8With lenientDecode err + + if errCheck msg then do + $logInfo "Attempt failed." + $logInfo "\n>>>> Cabal errors begin" + $logInfo $ msg <> "<<<< Cabal errors end\n" + let pkgs = parseConflictingPkgs msg + mPkgNames = map (C.simpleParse . T.unpack) pkgs + pkgNames = map (fromCabalPackageName . C.pkgName) + (catMaybes mPkgNames) + + when (any isNothing mPkgNames) $ do + $logInfo $ "*** Only some package names could be parsed: " <> + (T.pack (intercalate ", " (map show pkgNames))) + error $ T.unpack $ + "*** User packages involved in cabal failure: " + <> (T.intercalate ", " $ parseConflictingPkgs msg) + + if pkgNames /= [] then do + return $ Left pkgNames + else errExit msg + else errExit msg + + parseConflictingPkgs msg = + let ls = dropWhile (not . errCheck) $ T.lines msg + select s = ((T.isPrefixOf "trying:" s) + || (T.isPrefixOf "next goal:" s)) + && (T.isSuffixOf "(user goal)" s) + pkgName = (take 1) + . T.words + . (T.drop 1) + . (T.dropWhile (/= ':')) + in concat $ map pkgName (filter select ls) + parseCabalOutput bs = do let ls = drop 1 $ dropWhile (not . T.isPrefixOf "In order, ") @@ -126,7 +162,7 @@ cabalSolver menv cabalfps constraintType $ decodeUtf8 bs (errs, pairs) = partitionEithers $ map parseLine ls if null errs - then return $ Just (Map.fromList pairs) + then return $ Right (Map.fromList pairs) else error $ "Could not parse cabal-install output: " ++ show errs parseLine t0 = maybe (Left t0) Right $ do @@ -274,6 +310,9 @@ setupCabalEnv compiler = do \This is most likely a bug." return menv +-- | Merge two separate maps, one defining constraints on package versions and +-- the other defining package flagmap, into a single map of version and flagmap +-- tuples. mergeConstraints :: Map PackageName v -> Map PackageName (Map p f) @@ -295,6 +334,17 @@ diffConstraints (v, f) (v', f') | (v == v') && (f == f') = Nothing | otherwise = Just (v, f) +-- | Given a resolver, user package constraints (versions and flags) and extra +-- dependency constraints determine what extra dependencies are required +-- outside the resolver snapshot and the specified extra dependencies. + +-- First it tries by using the snapshot and the input extra dependencies +-- as hard constraints, if no solution is arrived at by using hard +-- constraints it then tries using them as soft constraints or preferences. + +-- It returns either conflicting packages when no solution is arrived at +-- or the solution in terms of src package flag settings and extra +-- dependencies. solveResolverSpec :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m , MonadReader env m, HasConfig env , HasGHCVariant env @@ -307,14 +357,14 @@ solveResolverSpec , ConstraintSpec) -- ^ ( resolver -- , src package constraints -- , extra dependency constraints ) - -> m (Maybe ( ConstraintSpec - , ConstraintSpec)) -- ^ ( resulting src package specs - -- , resulting external package specs ) + -> m (Either [PackageName] (ConstraintSpec , ConstraintSpec)) + -- ^ (Conflicting packages + -- (resulting src package specs, external dependency specs)) solveResolverSpec stackYaml cabalDirs (resolver, srcConstraints, extraConstraints) = do $logInfo $ "Using resolver: " <> resolverName resolver - (compilerVer, snapConstraints) <- getResolverConstraints resolver + (compilerVer, snapConstraints) <- getResolverConstraints stackYaml resolver menv <- setupCabalEnv compilerVer let -- Note - The order in Map.union below is important. @@ -340,15 +390,15 @@ solveResolverSpec stackYaml cabalDirs unless (Map.null depOnlyConstraints) ($logInfo $ "Trying with " <> srcNames <> " as hard constraints...") - mdeps <- solver Constraint - mdeps' <- case mdeps of - Nothing | not (Map.null depOnlyConstraints) -> do + eresult <- solver Constraint + eresult' <- case eresult of + Left _ | not (Map.null depOnlyConstraints) -> do $logInfo $ "Retrying with " <> srcNames <> " as preferences..." solver Preference - _ -> return mdeps + _ -> return eresult - case mdeps' of - Just deps -> do + case eresult' of + Right deps -> do let -- All src package constraints returned by cabal. -- Flags may have changed. @@ -367,33 +417,45 @@ solveResolverSpec stackYaml cabalDirs <> T.pack (show $ Map.size external) <> " external dependencies." - return $ Just (srcs, external) - Nothing -> do - $logInfo $ "Failed to arrive at a workable build plan using " - <> resolverName resolver <> " resolver." - return Nothing + return $ Right (srcs, external) + Left x -> do + $logInfo $ "*** Failed to arrive at a workable build plan." + return $ Left x + +-- | Given a resolver (snpashot, compiler or custom resolver) +-- return the compiler version, package versions and packages flags +-- for that resolver. +getResolverConstraints + :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m + , MonadReader env m, HasConfig env , HasGHCVariant env + , HasHttpManager env , HasLogLevel env , HasReExec env + , HasTerminal env) + => Path Abs File + -> Resolver + -> m (CompilerVersion, + Map PackageName (Version, Map FlagName Bool)) +getResolverConstraints stackYaml resolver + | ResolverSnapshot snapName <- resolver = do + mbp <- loadMiniBuildPlan snapName + return (mbpCompilerVersion mbp, mbpConstraints mbp) + | ResolverCustom _ url <- resolver = do + -- FIXME instead of passing the stackYaml dir we should maintain + -- the file URL in the custom resolver always relative to stackYaml. + mbp <- parseCustomMiniBuildPlan stackYaml url + return (mbpCompilerVersion mbp, mbpConstraints mbp) + | ResolverCompiler compiler <- resolver = + return (compiler, Map.empty) + | otherwise = error "Not reached" where mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi) mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp) - getResolverConstraints (ResolverSnapshot snapName) = do - mbp <- loadMiniBuildPlan snapName - return (mbpCompilerVersion mbp, mbpConstraints mbp) +-- | Given a bundle of user packages, flag constraints on those packages and a +-- resolver, determine if the resolver fully, partially or fails to satisfy the +-- dependencies of the user packages. - getResolverConstraints (ResolverCompiler compiler) = - return (compiler, Map.empty) - - -- FIXME instead of passing the stackYaml dir we should maintain - -- the file URL in the custom resolver always relative to stackYaml. - getResolverConstraints (ResolverCustom _ url) = do - mbp <- parseCustomMiniBuildPlan stackYaml url - return (mbpCompilerVersion mbp, mbpConstraints mbp) - --- | Given a bundle of packages and a resolver, check the resolver with respect --- to the packages and return how well the resolver satisfies the depndencies --- of the packages. If 'flags' is passed as 'Nothing' then flags are chosen +-- If the package flags are passed as 'Nothing' then flags are chosen -- automatically. - checkResolverSpec :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m , HasHttpManager env, HasConfig env, HasGHCVariant env @@ -405,10 +467,12 @@ checkResolverSpec checkResolverSpec gpds flags resolver = do case resolver of ResolverSnapshot name -> checkSnapBuildPlan gpds flags name - ResolverCompiler _ -> return $ BuildPlanCheckPartial Map.empty Map.empty + ResolverCompiler {} -> return $ BuildPlanCheckPartial Map.empty Map.empty -- TODO support custom resolver for stack init - ResolverCustom _ _ -> return $ BuildPlanCheckPartial Map.empty Map.empty + ResolverCustom {} -> return $ BuildPlanCheckPartial Map.empty Map.empty +-- | Finds all files with a .cabal extension under a given directory. +-- Subdirectories can be included depending on the @recurse@ parameter. findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File] findCabalFiles recurse dir = liftIO $ findFiles dir isCabal (\subdir -> recurse && not (isIgnored subdir)) @@ -426,9 +490,13 @@ ignoredDirs = Set.fromList , ".stack-work" ] --- | Do some basic checks on a list of cabal file paths to be used for creating --- stack config, print some informative and error messages and if all is ok --- return @GenericPackageDescription@ list. +-- | Perform some basic checks on a list of cabal files to be used for creating +-- stack config. It checks for duplicate package names, package name and +-- cabal file name mismatch and reports any issues related to those. + +-- If no error occurs it returns filepath and @GenericPackageDescription@s +-- pairs as well as any filenames for duplicate packages not included in the +-- pairs. cabalPackagesCheck :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m , MonadReader env m, HasConfig env , HasGHCVariant env @@ -436,9 +504,10 @@ cabalPackagesCheck , HasTerminal env) => [Path Abs File] -> String - -> String - -> m [C.GenericPackageDescription] -cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do + -> Maybe String + -> m ( Map PackageName (Path Abs File, C.GenericPackageDescription) + , [Path Abs File]) +cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do when (null cabalfps) $ error noPkgMsg @@ -446,20 +515,53 @@ cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do $logInfo $ "Using cabal packages:" $logInfo $ T.pack (formatGroup relpaths) - when (dupGroups relpaths /= []) $ - error $ "Duplicate cabal package names cannot be used in a single " - <> "stack project. Following duplicates were found:\n" - <> intercalate "\n" (dupGroups relpaths) - <> "\n" - <> dupPkgFooter - - (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) + (warnings, gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings - return gpds - where - groups = filter ((> 1) . length) . groupSortOn (FP.takeFileName) - dupGroups = (map formatGroup) . groups + -- package name cannot be empty or missing otherwise + -- it will result in cabal solver failure. + -- stack requires packages name to match the cabal file name + -- Just the latter check is enough to cover both the cases + + let packages = zip cabalfps gpds + getNameMismatchPkg (fp, gpd) + | (show . gpdPackageName) gpd /= (FP.takeBaseName . toFilePath) fp + = Just fp + | otherwise = Nothing + nameMismatchPkgs = mapMaybe getNameMismatchPkg packages + + when (nameMismatchPkgs /= []) $ do + rels <- mapM makeRel nameMismatchPkgs + error $ "Package name as defined in the .cabal file must match the \ + \.cabal file name.\n\ + \Please fix the following packages and try again:\n" + <> (formatGroup rels) + + let dupGroups = filter ((> 1) . length) + . groupSortOn (gpdPackageName . snd) + dupAll = concat $ dupGroups packages + + -- Among duplicates prefer to include the ones in upper level dirs + pathlen = length . FP.splitPath . toFilePath . fst + getmin = minimumBy (compare `on` pathlen) + dupSelected = map getmin (dupGroups packages) + dupIgnored = dupAll \\ dupSelected + unique = packages \\ dupIgnored + + when (dupIgnored /= []) $ do + dups <- mapM (mapM (makeRel . fst)) (dupGroups packages) + $logWarn $ T.pack $ + "Following packages have duplicate package names:\n" + <> intercalate "\n" (map formatGroup dups) + case dupErrMsg of + Nothing -> $logWarn $ T.pack $ + "Packages with duplicate names will be ignored.\n" + <> "Packages in upper level directories will be preferred.\n" + Just msg -> error msg + + return (Map.fromList + $ map (\(file, gpd) -> ((gpdPackageName gpd),(file, gpd))) unique + , map fst dupIgnored) makeRel :: (MonadIO m) => Path Abs File -> m FilePath makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath @@ -478,17 +580,15 @@ reportMissingCabalFiles cabalfps includeSubdirs = do $logWarn $ "The following packages are missing from the config:" $logWarn $ T.pack (formatGroup relpaths) --- | Solver can be thought of as a counterpart of init. init creates a --- stack.yaml whereas solver verifies or fixes an existing one. It can verify --- the dependencies of the packages and determine if any extra-dependecies --- outside the snapshots are needed. --- -- TODO Currently solver uses a stack.yaml in the parent chain when there is -- no stack.yaml in the current directory. It should instead look for a -- stack yaml only in the current directory and suggest init if there is -- none available. That will make the behavior consistent with init and provide -- a correct meaning to a --ignore-subdirs option if implemented. +-- | Verify the combination of resolver, package flags and extra +-- dependencies in an existing stack.yaml and suggest changes in flags or +-- extra dependencies so that the specified packages can be compiled. solveExtraDeps :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m , MonadReader env m, HasConfig env , HasEnvConfig env, HasGHCVariant env @@ -513,13 +613,13 @@ solveExtraDeps modStackYaml = do \entries from '" <> relStackYaml <> "'." cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs) - gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter - -- TODO when solver supports --ignore-subdirs option pass that as the -- second argument here. reportMissingCabalFiles cabalfps True + (bundle, _) <- cabalPackagesCheck cabalfps noPkgMsg (Just dupPkgFooter) - let oldFlags = bcFlags bconfig + let gpds = Map.elems $ fmap snd bundle + oldFlags = bcFlags bconfig oldExtraVersions = bcExtraDeps bconfig resolver = bcResolver bconfig oldSrcs = gpdPackages gpds @@ -533,11 +633,14 @@ solveExtraDeps modStackYaml = do resultSpecs <- case resolverResult of BuildPlanCheckOk flags -> return $ Just ((mergeConstraints oldSrcs flags), Map.empty) - BuildPlanCheckPartial _ _ -> - solveResolverSpec stackYaml cabalDirs + BuildPlanCheckPartial {} -> do + eres <- solveResolverSpec stackYaml cabalDirs (resolver, srcConstraints, extraConstraints) - BuildPlanCheckFail f e c -> - throwM $ ResolverMismatch resolver (showCompilerErrors f e c) + -- TODO Solver should also use the init code to ignore incompatible + -- packages + return $ either (const Nothing) Just eres + BuildPlanCheckFail {} -> + throwM $ ResolverMismatch resolver (show resolverResult) (srcs, edeps) <- case resultSpecs of Nothing -> throwM (SolverGiveUp giveUpMsg) @@ -568,7 +671,6 @@ solveExtraDeps modStackYaml = do -- TODO print whether resolver changed from previous $logInfo $ "* Resolver is " <> resolverName resolver - -- TODO indent the yaml output printFlags newFlags "* Flags to be added" printDeps newVersions "* Dependencies to be added" diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 8c6b02cf6d..688d1623a5 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -604,7 +604,10 @@ instance FromJSON (PackageLocation, [JSONWarning]) where -- | A project is a collection of packages. We can have multiple stack.yaml -- files, but only one of them may contain project information. data Project = Project - { projectPackages :: ![PackageEntry] + { projectUserMsg :: !(Maybe String) + -- ^ A warning message to display to the user when the auto generated + -- config may have issues. + , projectPackages :: ![PackageEntry] -- ^ Components of the package list , projectExtraDeps :: !(Map PackageName Version) -- ^ Components of the package list referring to package/version combos, @@ -622,12 +625,13 @@ data Project = Project instance ToJSON Project where toJSON p = object $ (maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p)) + ((maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p)) [ "packages" .= projectPackages p , "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p) , "flags" .= projectFlags p , "resolver" .= projectResolver p , "extra-package-dbs" .= projectExtraPackageDBs p - ] + ]) -- | How we resolve which dependencies to install given a set of packages. data Resolver @@ -1076,8 +1080,8 @@ data ConfigException | UnexpectedTarballContents [Path Abs Dir] [Path Abs File] | BadStackVersionException VersionRange | NoMatchingSnapshot [SnapName] - | ResolverMismatch Resolver Text - | ResolverPartial Resolver Text + | ResolverMismatch Resolver String + | ResolverPartial Resolver String | NoSuchDirectory FilePath | ParseGHCVariantException String deriving Typeable @@ -1123,23 +1127,23 @@ instance Show ConfigException where , unlines $ map (\name -> " - " <> T.unpack (renderSnapName name)) names , "\nYou can try the following options:\n" - , " - Exclude mismatching package(s) and build the rest.\n" - , " - Use '--ignore-subdirs' to exclude subdirectories.\n" - , " - Manually create a config, then use 'stack solver'\n" + , " - Use '--omit-packages to exclude mismatching package(s).\n" , " - Use '--resolver' to specify a matching snapshot/resolver\n" - , " - Use a custom snapshot having the right compiler.\n" ] show (ResolverMismatch resolver errDesc) = concat - [ "Selected resolver '" + [ "Resolver '" , T.unpack (resolverName resolver) - , "' does not have a matching compiler to build your package(s).\n" - , T.unpack errDesc + , "' does not have a matching compiler to build some or all of your " + , "package(s).\n" + , errDesc + , "\nHowever, you can try '--omit-packages to exclude mismatching " + , "package(s)." ] show (ResolverPartial resolver errDesc) = concat - [ "Selected resolver '" + [ "Resolver '" , T.unpack (resolverName resolver) , "' does not have all the packages to match your requirements.\n" - , T.unpack $ T.unlines $ fmap (" " <>) (T.lines errDesc) + , unlines $ fmap (" " <>) (lines errDesc) , "\nHowever, you can try '--solver' to use external packages." ] show (NoSuchDirectory dir) = concat @@ -1373,10 +1377,12 @@ instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warning flags <- o ..:? "flags" ..!= mempty resolver <- jsonSubWarnings (o ..: "resolver") compiler <- o ..:? "compiler" + msg <- o ..:? "user-message" config <- parseConfigMonoidJSON o extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] let project = Project - { projectPackages = dirs + { projectUserMsg = msg + , projectPackages = dirs , projectExtraDeps = extraDeps , projectFlags = flags , projectResolver = resolver diff --git a/src/main/Main.hs b/src/main/Main.hs index d00a57e1e6..010100853f 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -235,11 +235,9 @@ commandLineHandler progName isInterpreter = complicatedOptions "List the templates available for `stack new'." templatesCmd (pure ()) - addCommand "init" + addCommand' "init" "Initialize a stack project based on one or more cabal packages" - globalFooter initCmd - (globalOpts InitCmdGlobalOpts) initOptsParser addCommand' "solver" "Use a dependency solver to try and determine missing extra-deps" @@ -1183,15 +1181,14 @@ withMiniConfigAndLock go inner = initCmd :: InitOpts -> GlobalOpts -> IO () initCmd initOpts go = do pwd <- getWorkingDir - withMiniConfigAndLock go (initProject pwd initOpts) + withMiniConfigAndLock go (initProject pwd initOpts (globalResolver go)) -- | Create a project directory structure and initialize the stack config. newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO () newCmd (newOpts,initOpts) go@GlobalOpts{..} = do withMiniConfigAndLock go $ do dir <- new newOpts - initProject dir initOpts - + initProject dir initOpts globalResolver -- | List the available templates. templatesCmd :: () -> GlobalOpts -> IO ()