{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TemplateHaskell #-}

module Stack.Init

( findCabalFiles

, initProject

, InitOpts (..)

, initOptsParser

, readResolver

) where

import Control.Exception (assert)

import Control.Exception.Enclosed (handleIO, catchAny)

import Control.Monad (liftM, when)

import Control.Monad.Catch (MonadMask, throwM)

import Control.Monad.IO.Class

import Control.Monad.Logger

import Control.Monad.Reader (MonadReader)

import Control.Monad.Trans.Control (MonadBaseControl)

import qualified Data.IntMap as IntMap

import Data.List (sort)

import Data.List (isSuffixOf)

import Data.Map (Map)

import qualified Data.Map as Map

import Data.Maybe (mapMaybe)

import Data.Monoid

import Data.Set (Set)

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

import Options.Applicative

import Options.Applicative.Types (readerAsk)

import Path

import Path.Find

import Path.IO

import Stack.BuildPlan

import Stack.Constants

import Stack.Package

import Stack.Solver

import Stack.Types

import System.Directory (getDirectoryContents)

findCabalFiles :: MonadIO m => Path Abs Dir -> m [Path Abs File]

findCabalFiles dir =

liftIO $ findFiles dir isCabal (not . isIgnored)

where

isCabal path = ".cabal" `isSuffixOf` toFilePath path

isIgnored path = toFilePath (dirname path) `Set.member` ignoredDirs

-- | Special directories that we don't want to traverse for .cabal files

ignoredDirs :: Set FilePath

ignoredDirs = Set.fromList

[ ".git"

, "dist"

, ".stack-work"

]

-- | Generate stack.yaml

initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)

=> InitOpts

-> m ()

initProject initOpts = do

currDir <- getWorkingDir

let dest = currDir </> stackDotYaml

dest' = toFilePath dest

exists <- fileExists dest

when exists $ error "Refusing to overwrite existing stack.yaml, please delete before running stack init"

cabalfps <- findCabalFiles currDir

$logInfo $ "Writing default config file to: " <> T.pack dest'

$logInfo $ "Basing on cabal files:"

mapM_ (\path -> $logInfo $ "- " <> T.pack (toFilePath path)) cabalfps

$logInfo ""

when (null cabalfps) $ error "In order to init, you should have an existing .cabal file. Please try \"stack new\" instead"

gpds <- mapM readPackageUnresolved cabalfps

(r, flags, extraDeps) <- getDefaultResolver cabalfps gpds initOpts

let p = Project

{ projectPackages = pkgs

, projectExtraDeps = extraDeps

, projectFlags = flags

, projectResolver = r

}

pkgs = map toPkg cabalfps

toPkg fp = 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

, peSubdirs = []

}

$logInfo $ "Selected resolver: " <> renderResolver r

liftIO $ Yaml.encodeFile dest' p

$logInfo $ "Wrote project config to: " <> T.pack dest'

getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)

=> m (Maybe Snapshots)

getSnapshots' =

liftM Just 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 " https://github.com/commercialhaskell/stack/wiki/stack.yaml"

$logError ""

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

return Nothing

-- | Get the default resolver value

getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)

=> [Path Abs File] -- ^ cabal files

-> [C.GenericPackageDescription] -- ^ cabal descriptions

-> InitOpts

-> m (Resolver, Map PackageName (Map FlagName Bool), Map PackageName Version)

getDefaultResolver cabalfps gpds initOpts = do

case ioMethod initOpts of

MethodSnapshot snapPref -> do

msnapshots <- getSnapshots'

names <-

case msnapshots of

Nothing -> return []

Just snapshots -> getRecommendedSnapshots snapshots snapPref

mpair <- findBuildPlan gpds names

case mpair of

Just (snap, flags) ->

return (ResolverSnapshot snap, flags, Map.empty)

Nothing -> throwM $ NoMatchingSnapshot names

MethodResolver resolver -> do

mpair <-

case resolver of

ResolverSnapshot name -> findBuildPlan gpds [name]

ResolverGhc _ -> return Nothing

case mpair of

Just (snap, flags) ->

return (ResolverSnapshot snap, flags, Map.empty)

Nothing -> return (resolver, Map.empty, Map.empty)

MethodSolver -> do

(ghcVersion, extraDeps) <- cabalSolver (map parent cabalfps) []

return

( ResolverGhc ghcVersion

, Map.filter (not . Map.null) $ fmap snd extraDeps

, fmap fst extraDeps

)

getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)

=> Snapshots

-> SnapPref

-> m [SnapName]

getRecommendedSnapshots snapshots pref = 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 (reverse . sort . 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

data InitOpts = InitOpts

{ ioMethod :: !Method

-- ^ Preferred snapshots

}

data SnapPref = PrefNone | PrefLTS | PrefNightly

-- | Method of initializing

data Method = MethodSnapshot SnapPref | MethodResolver Resolver | MethodSolver

initOptsParser :: Parser InitOpts

initOptsParser =

InitOpts <$> method

where

method = solver

<|> (MethodResolver <$> resolver)

<|> (MethodSnapshot <$> snapPref)

solver =

flag' MethodSolver

(long "solver" <>

help "Use a dependency solver to determine dependencies")

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 readResolver

(long "resolver" <>

metavar "RESOLVER" <>

help "Use the given resolver, even if not all dependencies are met")

readResolver :: ReadM Resolver

readResolver = do

s <- readerAsk

case parseResolver $ T.pack s of

Left e -> readerError $ show e

Right x -> return x

-- | Same semantics as @nub@, but more efficient by using the @Ord@ constraint.

nubOrd :: Ord a => [a] -> [a]

nubOrd =

go Set.empty

where

go _ [] = []

go s (x:xs)

| x `Set.member` s = go s xs

| otherwise = x : go (Set.insert x s) xs