{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TemplateHaskell #-}

module Stack.Init

( initProject

, InitOpts (..)

) where

import Control.Exception (assert)

import Control.Exception.Enclosed (catchAny)

import Control.Monad

import Control.Monad.Catch (MonadMask, throwM)

import Control.Monad.IO.Class

import Control.Monad.Logger

import Control.Monad.Reader (MonadReader, asks)

import Control.Monad.Trans.Control (MonadBaseControl)

import qualified Data.ByteString.Builder as B

import qualified Data.ByteString.Char8 as BC

import qualified Data.ByteString.Lazy as L

import qualified Data.Foldable as F

import Data.Function (on)

import qualified Data.HashMap.Strict as HM

import qualified Data.IntMap as IntMap

import Data.List ( intercalate, intersect

, maximumBy)

import Data.List.NonEmpty (NonEmpty(..))

import qualified Data.List.NonEmpty as NonEmpty

import Data.Map (Map)

import qualified Data.Map as Map

import Data.Maybe

import Data.Monoid

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 Network.HTTP.Client.Conduit (HasHttpManager)

import Path

import Path.IO

import qualified Paths_stack as Meta

import Stack.BuildPlan

import Stack.Config (getSnapshots,

makeConcreteResolver)

import Stack.Constants

import Stack.Solver

import Stack.Types

import Stack.Types.Internal (HasLogLevel, HasReExec,

HasTerminal)

import qualified System.FilePath as FP

-- | Generate stack.yaml

initProject

:: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m

, MonadReader env m, HasConfig env , HasGHCVariant env

, HasHttpManager env , HasLogLevel env , HasReExec env

, HasTerminal env)

=> WhichSolverCmd

-> Path Abs Dir

-> InitOpts

-> Maybe AbstractResolver

-> m ()

initProject whichCmd currDir initOpts mresolver = do

let dest = currDir </> stackDotYaml

reldest <- toFilePath `liftM` makeRelativeToCurrentDir dest

exists <- doesFileExist dest

when (not (forceOverwrite initOpts) && exists) $ do

error ("Stack configuration file " <> reldest <>

" exists, use 'stack solver' to fix the existing config file or \

\'--force' to overwrite it.")

dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts)

let noPkgMsg = "In order to init, you should have an existing .cabal \

\file. Please try \"stack new\" instead."

find = findCabalFiles (includeSubDirs initOpts)

dirs' = if null dirs then [currDir] else dirs

$logInfo "Looking for .cabal or package.yaml files to use to init the project."

cabalfps <- liftM concat $ mapM find dirs'

(bundle, dupPkgs) <- cabalPackagesCheck cabalfps noPkgMsg Nothing

(r, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts

mresolver bundle

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 suppress this message by removing it from \

\stack.yaml\n"

else ""

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 = PackageFlags (removeSrcPkgDefaultFlags gpds flags)

, projectResolver = r

, projectCompiler = Nothing

, projectExtraPackageDBs = []

}

makeRelDir dir =

case stripDir currDir dir of

Nothing

| currDir == dir -> "."

| otherwise -> assert False $ toFilePath dir

Just rel -> toFilePath rel

makeRel = fmap toFilePath . makeRelativeToCurrentDir

pkgs = map toPkg $ Map.elems (fmap (parent . fst) rbundle)

toPkg dir = PackageEntry

{ peExtraDep = False

, 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 (toFilePath 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 -> [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 `HM.difference` HM.fromList comments)

<> B.byteString footerHelp

goComment o (name, comment) =

case HM.lookup name o of

Nothing -> assert (name == "user-message") mempty

Just v ->

B.byteString comment <>

B.byteString "\n" <>

B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <>

if (name == "packages") then commentedPackages else "" <>

B.byteString "\n"

commentHelp = BC.pack . intercalate "\n" . map ("# " ++)

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

| HM.null o = mempty

| otherwise = assert False $ B.byteString $ Yaml.encode o

-- Per Section Help

comments =

[ ("user-message" , userMsgHelp)

, ("resolver" , resolverHelp)

, ("packages" , packageHelp)

, ("extra-deps" , "# Dependency packages to be pulled from upstream that are not in the resolver\n# (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")

]

-- 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:"

, "http://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"

, "resolver: ghcjs-0.1.0_ghc-7.10.2"

, "resolver:"

, " name: custom-snapshot"

, " location: \"./custom-snapshot.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"

, "- location:"

, " git: https://github.com/commercialhaskell/stack.git"

, " commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a"

, "- location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a"

, " extra-dep: true"

, " subdirs:"

, " - auto-update"

, " - wai"

, ""

, "A package marked 'extra-dep: true' will only be built if demanded by a"

, "non-dependency (i.e. a user package), and its test suites and benchmarks"

, "will not be run. This is useful for tweaking upstream packages."

]

footerHelp =

let major = toCabalVersion

$ toMajorVersion $ fromCabalVersion Meta.version

in 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 major) ++ "\""

, ""

, "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' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)

=> m Snapshots

getSnapshots' =

getSnapshots `catchAny` \e -> do

$logError $

"Unable to download snapshot list, and therefore could " <>

"not generate a stack.yaml file automatically"

$logError $

"This sometimes happens due to missing Certificate Authorities " <>

"on your system. For more information, see:"

$logError ""

$logError " https://github.com/commercialhaskell/stack/issues/234"

$logError ""

$logError "You can try again, or create your stack.yaml file by hand. See:"

$logError ""

$logError " http://docs.haskellstack.org/en/stable/yaml_configuration/"

$logError ""

$logError $ "Exception was: " <> T.pack (show e)

error ""

-- | Get the default resolver value

getDefaultResolver

:: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m

, MonadReader env m, HasConfig env , HasGHCVariant env

, HasHttpManager env , HasLogLevel env , HasReExec env

, HasTerminal env)

=> WhichSolverCmd

-> Path Abs File -- ^ stack.yaml

-> 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

, Map PackageName (Path Abs File, C.GenericPackageDescription))

-- ^ ( Resolver

-- , Flags for src packages and extra deps

-- , Extra dependencies

-- , Src packages actually considered)

getDefaultResolver whichCmd stackYaml initOpts mresolver bundle =

maybe selectSnapResolver makeConcreteResolver mresolver

>>= getWorkingResolverPlan whichCmd stackYaml initOpts bundle

where

-- TODO support selecting best across regular and custom snapshots

selectSnapResolver = do

let gpds = Map.elems (fmap snd bundle)

snaps <- fmap getRecommendedSnapshots getSnapshots'

(s, r) <- selectBestSnapshot gpds snaps

case r of

BuildPlanCheckFail {} | not (omitPackages initOpts)

-> throwM (NoMatchingSnapshot whichCmd snaps)

_ -> return $ ResolverSnapshot s

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)

=> WhichSolverCmd

-> 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 whichCmd stackYaml initOpts bundle resolver = do

$logInfo $ "Selected resolver: " <> resolverName resolver

go bundle

where

go info = do

eres <- checkBundleResolver whichCmd 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)

=> WhichSolverCmd

-> 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 whichCmd stackYaml initOpts bundle resolver = do

result <- checkResolverSpec gpds Nothing resolver

case result of

BuildPlanCheckOk f -> return $ Right (f, Map.empty)

BuildPlanCheckPartial f e

| needSolver resolver initOpts -> do

warnPartial result

solve f

| omitPackages initOpts -> do

warnPartial result

$logWarn "*** Omitting packages with unsatisfied dependencies"

return $ Left $ failedUserPkgs e

| otherwise -> throwM $ ResolverPartial whichCmd resolver (show result)

BuildPlanCheckFail _ e _

| omitPackages initOpts -> do

$logWarn $ "*** Resolver compiler mismatch: "

<> resolverName resolver

$logWarn $ indent $ T.pack $ show result

return $ Left $ failedUserPkgs e

| otherwise -> throwM $ ResolverMismatch whichCmd resolver (show result)

where

indent t = T.unlines $ fmap (" " <>) (T.lines t)

warnPartial res = do

$logWarn $ "*** Resolver " <> resolverName resolver

<> " will need external packages: "

$logWarn $ indent $ T.pack $ show res

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

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 '--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"

]

needSolver _ (InitOpts {useSolver = True}) = True

needSolver (ResolverCompiler _) _ = True

needSolver _ _ = False

getRecommendedSnapshots :: Snapshots -> (NonEmpty SnapName)

getRecommendedSnapshots snapshots =

-- in order - Latest LTS, Latest Nightly, all LTS most recent first

case NonEmpty.nonEmpty ltss of

Just (mostRecent :| older)

-> mostRecent :| (nightly : older)

Nothing

-> nightly :| []

where

ltss = map (uncurry LTS) (IntMap.toDescList $ snapshotsLts snapshots)

nightly = Nightly (snapshotsNightly snapshots)

data InitOpts = InitOpts

{ searchDirs :: ![T.Text]

-- ^ List of sub directories to search for .cabal files

, useSolver :: Bool

-- ^ Use solver to determine required external dependencies

, 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

}