Init.hs

{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module Stack.Init
  ( initProject
  , InitOpts (..)
  ) where

import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.Foldable as F
import qualified Data.IntMap as IntMap
import           Data.List.Extra ( groupSortOn )
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as C
import qualified Distribution.Text as C
import qualified Distribution.Version as C
import           Path
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.Find ( findFiles )
import           Path.IO hiding ( findFiles )
import qualified RIO.FilePath as FP
import           RIO.List ( (\\), intercalate, isSuffixOf, isPrefixOf )
import           RIO.List.Partial ( minimumBy )
import           Stack.BuildPlan
import           Stack.Config ( getSnapshots, makeConcreteResolver )
import           Stack.Constants
import           Stack.Prelude
import           Stack.SourceMap
import           Stack.Types.Config
import           Stack.Types.Resolver
import           Stack.Types.Version ( stackMajorVersion )

-- | Type representing exceptions thrown by functions exported by the
-- "Stack.Init" module.
data InitException
    = NoPackagesToIgnoreBug
    deriving (Show, Typeable)

instance Exception InitException where
    displayException NoPackagesToIgnoreBug = bugReport "[S-2747]"
        "No packages to ignore."

data InitPrettyException
    = SnapshotDownloadFailure SomeException
    | ConfigFileAlreadyExists FilePath
    | PackageNameInvalid [(Path Abs File, PackageName)]
    deriving (Show, Typeable)

instance Pretty InitPrettyException where
    pretty (ConfigFileAlreadyExists reldest) =
        "[S-8009]"
        <> line
        <> flow "Stack declined to create a project-level YAML configuration \
                \file."
        <> blankLine
        <> fillSep
             [ flow "The file"
             , style File (fromString reldest)
             , "already exists. To overwrite it, pass the flag"
             , style Shell "--force" <> "."
             ]
    pretty (PackageNameInvalid rels) =
        "[S-5267]"
        <> line
        <> flow "Stack did not create project-level YAML configuration, as \
                \(like Hackage) it requires a Cabal file name to match the \
                \package it defines."
        <> blankLine
        <> flow "Please rename the following Cabal files:"
        <> line
        <> bulletedList
             ( map
                 ( \(fp, name) -> fillSep
                     [ style File (pretty fp)
                     , "as"
                     , style
                         File
                         (fromString (packageNameString name) <> ".cabal")
                     ]
                 )
                 rels
             )
    pretty (SnapshotDownloadFailure e) =
        "[S-8332]"
        <> line
        <> flow "Stack failed to create project-level YAML configuration, as \
                \it was unable to download the index of available snapshots."
        <> blankLine
        <> fillSep
             [ flow "This sometimes happens because Certificate Authorities \
                    \are missing on your system. You can try the Stack command \
                    \again or manually create the configuration file. For help \
                    \about the content of Stack's YAML configuration files, \
                    \see (for the most recent release of Stack)"
             , style
                 Url
                 "http://docs.haskellstack.org/en/stable/yaml_configuration/"
               <> "."
             ]
        <> blankLine
        <> flow "While downloading the snapshot index, Stack encountered the \
                \following error:"
        <> blankLine
        <> string (displayException e)

instance Exception InitPrettyException

-- | Generate stack.yaml
initProject
    :: (HasConfig env, HasGHCVariant env)
    => Path Abs Dir
    -> InitOpts
    -> Maybe AbstractResolver
    -> RIO env ()
initProject currDir initOpts mresolver = do
    let dest = currDir </> stackDotYaml

    reldest <- toFilePath `liftM` makeRelativeToCurrentDir dest

    exists <- doesFileExist dest
    when (not (forceOverwrite initOpts) && exists) $
        throwIO $ PrettyException $ ConfigFileAlreadyExists reldest

    dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts)
    let find  = findCabalDirs (includeSubDirs initOpts)
        dirs' = if null dirs then [currDir] else dirs
    prettyInfo $
           fillSep
             [ flow "Looking for Cabal or"
             , style File "package.yaml"
             , flow "files to use to initialise Stack's project-level YAML \
                    \configuration file."
             ]
        <> line
    cabaldirs <- Set.toList . Set.unions <$> mapM find dirs'
    (bundle, dupPkgs)  <- cabalPackagesCheck cabaldirs
    let makeRelDir dir =
            case stripProperPrefix currDir dir of
                Nothing
                    | currDir == dir -> "."
                    | otherwise -> assert False $ toFilePathNoTrailingSep dir
                Just rel -> toFilePathNoTrailingSep rel
        fpToPkgDir fp =
            let absDir = parent fp
            in ResolvedPath (RelFilePath $ T.pack $ makeRelDir absDir) absDir
        pkgDirs = Map.map (fpToPkgDir . fst) bundle
    (snapshotLoc, flags, extraDeps, rbundle) <- getDefaultResolver initOpts mresolver pkgDirs

    let ignored = Map.difference bundle rbundle
        dupPkgMsg
            | dupPkgs /= [] =
                "Warning (added by new or init): 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 (added by new or init): 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 (added by new or init): 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 omit this message by removing it from " <>
                         "stack.yaml\n"
                 else ""

        userMsg = makeUserMsg [dupPkgMsg, missingPkgMsg, extraDepMsg]

        gpdByDir = Map.fromList [ (parent fp, gpd) | (fp, gpd) <- Map.elems bundle]
        gpds = Map.elems $
          Map.mapMaybe (flip Map.lookup gpdByDir . resolvedAbsolute) rbundle

    deps <- for (Map.toList extraDeps) $ \(n, v) ->
      PLImmutable . cplComplete <$>
      completePackageLocation (RPLIHackage (PackageIdentifierRevision n v CFILatest) Nothing)

    let p = Project
            { projectUserMsg = if userMsg == "" then Nothing else Just userMsg
            , projectPackages = resolvedRelative <$> Map.elems rbundle
            , projectDependencies = map toRawPL deps
            , projectFlags = removeSrcPkgDefaultFlags gpds flags
            , projectResolver = snapshotLoc
            , projectCompiler = Nothing
            , projectExtraPackageDBs = []
            , projectCurator = Nothing
            , projectDropPackages = mempty
            }

        makeRel = fmap toFilePath . makeRelativeToCurrentDir

    prettyInfo $
        fillSep
          [ flow "Initialising Stack's project-level YAML configuration file \
                 \using snapshot"
          , pretty (PrettyRawSnapshotLocation snapshotLoc) <> "."
          ]
    prettyInfo $
        let n = Map.size bundle + length dupPkgs
        in  fillSep
              [ "Considered"
              , fromString $ show n
              , "user"
              , if n == 1 then "package." else "packages."
              ]

    when (dupPkgs /= []) $ do
        rels <- mapM makeRel dupPkgs
        prettyWarn $
               fillSep
                 [ flow "Ignoring these"
                 , fromString $ show (length dupPkgs)
                 , flow "duplicate packages:"
                 ]
            <> line
            <> bulletedList (map (style File . fromString) rels)

    when (Map.size ignored > 0) $ do
        rels <- mapM makeRel (Map.elems (fmap fst ignored))
        prettyWarn $
               fillSep
                 [ flow "Ignoring these"
                 , fromString $ show (Map.size ignored)
                 , flow "packages due to dependency conflicts:"
                 ]
            <> line
            <> bulletedList (map (style File . fromString) rels)

    when (Map.size extraDeps > 0) $ do
        prettyWarn $
            fillSep
              [ fromString $ show (Map.size extraDeps)
              , flow "external dependencies were added."
              ]
    prettyInfo $
        fillSep
          [ flow $ if exists
                then "Overwriting existing configuration file"
                else "Writing configuration to"
          , style File (fromString reldest) <> "."
          ]
    writeBinaryFileAtomic dest
           $ renderStackYaml p
               (Map.elems $ fmap (makeRelDir . parent . fst) ignored)
               (map (makeRelDir . parent) dupPkgs)
    prettyInfo $
        flow "Stack's project-level YAML configuration file has been \
             \initialised."

-- | Render a stack.yaml file with comments, see:
-- https://github.com/commercialhaskell/stack/issues/226
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 headerHelp
        <> B.byteString "\n\n"
        <> F.foldMap (goComment o) comments
        <> goOthers (o `KeyMap.difference` KeyMap.fromList comments)
        <> B.byteString footerHelp
        <> "\n"

    goComment o (name, comment) =
        case (convert <$> KeyMap.lookup name o) <|> nonPresentValue name of
            Nothing -> assert (name == "user-message") mempty
            Just v ->
                B.byteString comment <>
                B.byteString "\n" <>
                v <>
                if name == "packages" then commentedPackages else "" <>
                B.byteString "\n"
      where
        convert v = B.byteString (Yaml.encode $ Yaml.object [(name, v)])

        -- Some fields in stack.yaml are optional and may not be
        -- generated. For these, we provided commented out dummy
        -- values to go along with the comments.
        nonPresentValue "extra-deps" = Just "# extra-deps: []\n"
        nonPresentValue "flags" = Just "# flags: {}\n"
        nonPresentValue "extra-package-dbs" = Just "# extra-package-dbs: []\n"
        nonPresentValue _ = Nothing

    commentLine l | null l = "#"
                  | otherwise = "# " ++ l
    commentHelp = BC.pack .  intercalate "\n" . map commentLine
    commentedPackages =
        let ignoredComment = commentHelp
                [ "The following packages have been ignored due to incompatibility with the"
                , "resolver compiler, dependency conflicts with other packages"
                , "or unsatisfied dependencies."
                ]
            dupComment = commentHelp
                [ "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 comment
            <> B.byteString "\n"
            <> B.byteString (BC.pack $ concat
                 $ map (\x -> "#- " ++ x ++ "\n") pkgs ++ ["\n"])
        | otherwise = ""

    goOthers o
        | KeyMap.null o = mempty
        | otherwise = assert False $ B.byteString $ Yaml.encode o

    -- Per Section Help
    comments =
        [ ("user-message"     , userMsgHelp)
        , ("resolver"         , resolverHelp)
        , ("packages"         , packageHelp)
        , ("extra-deps"       , extraDepsHelp)
        , ("flags"            , "# Override default flag values for local packages and extra-deps")
        , ("extra-package-dbs", "# Extra package databases containing global packages")
        ]

    -- Help strings
    headerHelp = commentHelp
        [ "This file was automatically generated by 'stack init'"
        , ""
        , "Some commonly used options have been documented as comments in this file."
        , "For advanced use and comprehensive documentation of the format, please see:"
        , "https://docs.haskellstack.org/en/stable/yaml_configuration/"
        ]

    resolverHelp = commentHelp
        [ "Resolver to choose a 'specific' stackage snapshot or a compiler version."
        , "A snapshot resolver dictates the compiler version and the set of packages"
        , "to be used for project dependencies. For example:"
        , ""
        , "resolver: lts-3.5"
        , "resolver: nightly-2015-09-21"
        , "resolver: ghc-7.10.2"
        , ""
        , "The location of a snapshot can be provided as a file or url. Stack assumes"
        , "a snapshot provided as a file might change, whereas a url resource does not."
        , ""
        , "resolver: ./custom-snapshot.yaml"
        , "resolver: https://example.com/snapshots/2018-01-01.yaml"
        ]

    userMsgHelp = commentHelp
        [ "A warning or info to be displayed to the user on config load." ]

    packageHelp = commentHelp
        [ "User packages to be built."
        , "Various formats can be used as shown in the example below."
        , ""
        , "packages:"
        , "- some-directory"
        , "- https://example.com/foo/bar/baz-0.0.2.tar.gz"
        , "  subdirs:"
        , "  - auto-update"
        , "  - wai"
        ]

    extraDepsHelp = commentHelp
        [ "Dependency packages to be pulled from upstream that are not in the resolver."
        , "These entries can reference officially published versions as well as"
        , "forks / in-progress versions pinned to a git hash. For example:"
        , ""
        , "extra-deps:"
        , "- acme-missiles-0.3"
        , "- git: https://github.com/commercialhaskell/stack.git"
        , "  commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a"
        , ""
        ]

    footerHelp = commentHelp
        [ "Control whether we use the GHC we find on the path"
        , "system-ghc: true"
        , ""
        , "Require a specific version of Stack, using version ranges"
        , "require-stack-version: -any # Default"
        , "require-stack-version: \""
          ++ C.display (C.orLaterVersion stackMajorVersion) ++ "\""
        , ""
        , "Override the architecture used by Stack, especially useful on Windows"
        , "arch: i386"
        , "arch: x86_64"
        , ""
        , "Extra directories used by Stack for building"
        , "extra-include-dirs: [/path/to/dir]"
        , "extra-lib-dirs: [/path/to/dir]"
        , ""
        , "Allow a newer minor version of GHC than the snapshot specifies"
        , "compiler-check: newer-minor"
        ]

getSnapshots' :: HasConfig env => RIO env Snapshots
getSnapshots' = catchAny
    getSnapshots
    (\e -> throwIO $ PrettyException $ SnapshotDownloadFailure e)

-- | Get the default resolver value
getDefaultResolver
    :: (HasConfig env, HasGHCVariant env)
    => InitOpts
    -> Maybe AbstractResolver
    -> Map PackageName (ResolvedPath Dir)
    -- ^ Src package name: cabal dir
    -> RIO env
         ( RawSnapshotLocation
         , Map PackageName (Map FlagName Bool)
         , Map PackageName Version
         , Map PackageName (ResolvedPath Dir))
       -- ^ ( Resolver
       --   , Flags for src packages and extra deps
       --   , Extra dependencies
       --   , Src packages actually considered)
getDefaultResolver initOpts mresolver pkgDirs = do
    (candidate, loc) <- case mresolver of
      Nothing -> selectSnapResolver
      Just ar -> do
        sl <- makeConcreteResolver ar
        c <- loadProjectSnapshotCandidate sl NoPrintWarnings False
        pure (c, sl)
    getWorkingResolverPlan initOpts pkgDirs candidate loc
    where
        -- TODO support selecting best across regular and custom snapshots
        selectSnapResolver = do
            snaps <- fmap getRecommendedSnapshots getSnapshots'
            (c, l, r) <- selectBestSnapshot (Map.elems pkgDirs) snaps
            case r of
                BuildPlanCheckFail {} | not (omitPackages initOpts)
                        -> throwM $ PrettyException $
                               NoMatchingSnapshot snaps
                _ -> pure (c, l)

getWorkingResolverPlan
    :: (HasConfig env, HasGHCVariant env)
    => InitOpts
    -> Map PackageName (ResolvedPath Dir)
    -- ^ Src packages: cabal dir
    -> SnapshotCandidate env
    -> RawSnapshotLocation
    -> RIO env
         ( RawSnapshotLocation
         , Map PackageName (Map FlagName Bool)
         , Map PackageName Version
         , Map PackageName (ResolvedPath Dir))
       -- ^ ( SnapshotDef
       --   , Flags for src packages and extra deps
       --   , Extra dependencies
       --   , Src packages actually considered)
getWorkingResolverPlan initOpts pkgDirs0 snapCandidate snapLoc = do
    prettyInfo $
        fillSep
          [ flow "Selected the snapshot"
          , pretty (PrettyRawSnapshotLocation snapLoc) <> "."
          ]
    go pkgDirs0
    where
        go pkgDirs = do
            eres <- checkBundleResolver initOpts snapLoc snapCandidate (Map.elems pkgDirs)
            -- if some packages failed try again using the rest
            case eres of
                Right (f, edeps)-> pure (snapLoc, f, edeps, pkgDirs)
                Left ignored
                    | Map.null available -> do
                        prettyWarn $
                            flow "Could not find a working plan for any of the \
                                 \user packages. Proceeding to create a YAML \
                                 \configuration file anyway."
                        pure (snapLoc, Map.empty, Map.empty, Map.empty)
                    | otherwise -> do
                        when (Map.size available == Map.size pkgDirs) $
                            throwM NoPackagesToIgnoreBug

                        if length ignored > 1
                          then
                            prettyWarn
                              (    flow "Ignoring the following packages:"
                                <> line
                                <> bulletedList
                                     ( map
                                           (fromString . packageNameString)
                                           ignored
                                     )
                              )
                          else
                            prettyWarn
                              ( fillSep
                                  [ flow "Ignoring package:"
                                  , fromString
                                        ( case ignored of
                                              [] -> throwM NoPackagesToIgnoreBug
                                              x:_ -> packageNameString x
                                        )
                                  ]
                              )
                        go available
                    where
                      isAvailable k _ = k `notElem` ignored
                      available       = Map.filterWithKey isAvailable pkgDirs

checkBundleResolver
    :: (HasConfig env, HasGHCVariant env)
    => InitOpts
    -> RawSnapshotLocation
    -> SnapshotCandidate env
    -> [ResolvedPath Dir]
    -- ^ Src package dirs
    -> RIO env
         (Either [PackageName] ( Map PackageName (Map FlagName Bool)
                               , Map PackageName Version))
checkBundleResolver initOpts snapshotLoc snapCandidate pkgDirs = do
    result <- checkSnapBuildPlan pkgDirs Nothing snapCandidate
    case result of
        BuildPlanCheckOk f -> pure $ Right (f, Map.empty)
        BuildPlanCheckPartial _f e -> do -- FIXME:qrilka unused f
            if omitPackages initOpts
                then do
                    warnPartial result
                    logWarn "*** Omitting packages with unsatisfied dependencies"
                    pure $ Left $ failedUserPkgs e
                else throwM $ PrettyException $
                         ResolverPartial snapshotLoc (show result)
        BuildPlanCheckFail _ e _
            | omitPackages initOpts -> do
                logWarn $ "*** Resolver compiler mismatch: "
                           <> display snapshotLoc
                logWarn $ display $ ind $ T.pack $ show result
                pure $ Left $ failedUserPkgs e
            | otherwise -> throwM $ PrettyException $
                               ResolverMismatch snapshotLoc (show result)
    where
      ind t  = T.unlines $ fmap ("    " <>) (T.lines t)
      warnPartial res = do
          logWarn $ "*** Resolver " <> display snapshotLoc
                      <> " will need external packages: "
          logWarn $ display $ ind $ T.pack $ show res

      failedUserPkgs e = Map.keys $ Map.unions (Map.elems (fmap deNeededBy e))

getRecommendedSnapshots :: Snapshots -> NonEmpty SnapName
getRecommendedSnapshots snapshots =
    -- in order - Latest LTS, Latest Nightly, all LTS most recent first
    case NonEmpty.nonEmpty supportedLtss of
        Just (mostRecent :| older)
            -> mostRecent :| (nightly : older)
        Nothing
            -> nightly :| []
  where
    ltss = map (uncurry LTS) (IntMap.toDescList $ snapshotsLts snapshots)
    supportedLtss = filter (>= minSupportedLts) ltss
    nightly = Nightly (snapshotsNightly snapshots)

-- |Yields the minimum LTS supported by Stack.
minSupportedLts :: SnapName
minSupportedLts = LTS 3 0 -- See https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md
                          -- under Stack version 2.1.1.

data InitOpts = InitOpts
    { searchDirs     :: ![T.Text]
    -- ^ List of sub directories to search for .cabal files
    , omitPackages   :: Bool
    -- ^ Exclude conflicting or incompatible user packages
    , forceOverwrite :: Bool
    -- ^ Overwrite existing stack.yaml
    , includeSubDirs :: Bool
    -- ^ If True, include all .cabal files found in any sub directories
    }

findCabalDirs
  :: HasConfig env
  => Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir))
findCabalDirs recurse dir =
    Set.fromList . map parent
    <$> liftIO (findFiles dir isHpackOrCabal subdirFilter)
  where
    subdirFilter subdir = recurse && not (isIgnored subdir)
    isHpack = (== "package.yaml")     . toFilePath . filename
    isCabal = (".cabal" `isSuffixOf`) . toFilePath
    isHpackOrCabal x = isHpack x || isCabal x

    isIgnored path = "." `isPrefixOf` dirName || dirName `Set.member` ignoredDirs
      where
        dirName = FP.dropTrailingPathSeparator (toFilePath (dirname path))

-- | Special directories that we don't want to traverse for .cabal files
ignoredDirs :: Set FilePath
ignoredDirs = Set.fromList
    [ "dist"
    ]

cabalPackagesCheck
    :: (HasConfig env, HasGHCVariant env)
     => [Path Abs Dir]
     -> RIO env
          ( Map PackageName (Path Abs File, C.GenericPackageDescription)
          , [Path Abs File])
cabalPackagesCheck cabaldirs = do
    when (null cabaldirs) $
      prettyWarn $
             fillSep
               [ flow "Stack did not find any local package directories. You may \
                      \want to create a package with"
               , style Shell (flow "stack new")
               , flow "instead."
               ]
          <> blankLine
          <> fillSep
               [ flow "Stack will create an empty project. If this is not what \
                      \you want, please delete the generated"
               , style File "stack.yaml"
               , "file."
               ]
    relpaths <- mapM prettyPath cabaldirs
    unless (null relpaths) $
        prettyInfo $
               flow "Using the Cabal packages:"
            <> line
            <> bulletedList (map (style File . fromString) relpaths)
            <> line

    -- A 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.
    ePackages <- for cabaldirs $ \dir -> do
        -- Pantry's 'loadCabalFilePath' throws 'MismatchedCabalName' (error
        -- [S-910]) if the Cabal file name does not match the package it
        -- defines.
        (gpdio, _name, cabalfp) <- loadCabalFilePath (Just stackProgName') dir
        eres <- liftIO $ try (gpdio YesPrintWarnings)
        case eres :: Either PantryException C.GenericPackageDescription of
            Right gpd -> pure $ Right (cabalfp, gpd)
            Left (MismatchedCabalName fp name) -> pure $ Left (fp, name)
            Left e -> throwIO e
    let (nameMismatchPkgs, packages) = partitionEithers ePackages
    when (nameMismatchPkgs /= []) $
        throwIO $ PrettyException $ PackageNameInvalid nameMismatchPkgs

    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 (prettyPath. fst)) (dupGroups packages)
        prettyWarn $
               flow "The following packages have duplicate package names:"
            <> line
            <> foldMap
                   ( \dup ->    bulletedList (map fromString dup)
                             <> line
                   )
                   dups
            <> line
            <> flow "Packages with duplicate names will be ignored. Packages \
                    \in upper level directories will be preferred."
            <> line

    pure (Map.fromList
            $ map (\(file, gpd) -> (gpdPackageName gpd,(file, gpd))) unique
           , map fst dupIgnored)

prettyPath ::
       (MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t))
    => Path r t
    -> m FilePath
prettyPath path = do
    eres <- liftIO $ try $ makeRelativeToCurrentDir path
    pure $ case eres of
        Left (_ :: PathException) -> toFilePath path
        Right res -> toFilePath res