{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Create new a new project directory populated with a basic working
-- project.

module Stack.New
    ( new
    , NewOpts(..)
    , TemplateName
    , templatesHelp
    ) where

import           Stack.Prelude
import           Control.Monad.Trans.Writer.Strict
import           Data.ByteString.Builder (lazyByteString)
import qualified Data.ByteString.Lazy as LB
import           Data.Conduit
import           Data.List
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Encoding as TLE
import           Data.Time.Calendar
import           Data.Time.Clock
import           Network.HTTP.StackClient (VerifiedDownloadException (..), Request, HttpException,
                                           getResponseBody, httpLbs, mkDownloadRequest, parseRequest, parseUrlThrow,
                                           setForceDownload, setGithubHeaders, verifiedDownloadWithProgress)
import           Path
import           Path.IO
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Types.Config
import           Stack.Types.TemplateName
import           RIO.Process
import qualified Text.Mustache as Mustache
import qualified Text.Mustache.Render as Mustache
import           Text.ProjectTemplate

--------------------------------------------------------------------------------
-- Main project creation

-- | Options for creating a new project.
data NewOpts = NewOpts
    { NewOpts -> PackageName
newOptsProjectName  :: PackageName
    -- ^ Name of the project to create.
    , NewOpts -> Bool
newOptsCreateBare   :: Bool
    -- ^ Whether to create the project without a directory.
    , NewOpts -> Maybe TemplateName
newOptsTemplate     :: Maybe TemplateName
    -- ^ Name of the template to use.
    , NewOpts -> Map Text Text
newOptsNonceParams  :: Map Text Text
    -- ^ Nonce parameters specified just for this invocation.
    }

-- | Create a new project with the given options.
new :: HasConfig env => NewOpts -> Bool -> RIO env (Path Abs Dir)
new :: NewOpts -> Bool -> RIO env (Path Abs Dir)
new NewOpts
opts Bool
forceOverwrite = do
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NewOpts -> PackageName
newOptsProjectName NewOpts
opts PackageName -> Set PackageName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set PackageName
wiredInPackages) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      NewException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NewException -> RIO env ()) -> NewException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PackageName -> NewException
Can'tUseWiredInName (NewOpts -> PackageName
newOptsProjectName NewOpts
opts)
    Path Abs Dir
pwd <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
    Path Abs Dir
absDir <- if Bool
bare then Path Abs Dir -> RIO env (Path Abs Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs Dir
pwd
                      else do Path Rel Dir
relDir <- FilePath -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir (PackageName -> FilePath
packageNameString PackageName
project)
                              (Path Rel Dir -> Path Abs Dir)
-> RIO env (Path Rel Dir) -> RIO env (Path Abs Dir)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir
pwd Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (Path Rel Dir -> RIO env (Path Rel Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Rel Dir
relDir)
    Bool
exists <- Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
absDir
    Maybe TemplateName
configTemplate <- Getting (Maybe TemplateName) env (Maybe TemplateName)
-> RIO env (Maybe TemplateName)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe TemplateName) env (Maybe TemplateName)
 -> RIO env (Maybe TemplateName))
-> Getting (Maybe TemplateName) env (Maybe TemplateName)
-> RIO env (Maybe TemplateName)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Maybe TemplateName) Config)
-> env -> Const (Maybe TemplateName) env
forall env. HasConfig env => Lens' env Config
configL((Config -> Const (Maybe TemplateName) Config)
 -> env -> Const (Maybe TemplateName) env)
-> ((Maybe TemplateName
     -> Const (Maybe TemplateName) (Maybe TemplateName))
    -> Config -> Const (Maybe TemplateName) Config)
-> Getting (Maybe TemplateName) env (Maybe TemplateName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Maybe TemplateName)
-> SimpleGetter Config (Maybe TemplateName)
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Maybe TemplateName
configDefaultTemplate
    let template :: TemplateName
template = TemplateName -> Maybe TemplateName -> TemplateName
forall a. a -> Maybe a -> a
fromMaybe TemplateName
defaultTemplateName (Maybe TemplateName -> TemplateName)
-> Maybe TemplateName -> TemplateName
forall a b. (a -> b) -> a -> b
$ [Maybe TemplateName] -> Maybe TemplateName
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ Maybe TemplateName
cliOptionTemplate
                                                        , Maybe TemplateName
configTemplate
                                                        ]
    if Bool
exists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
bare
        then NewException -> RIO env (Path Abs Dir)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Path Abs Dir -> NewException
AlreadyExists Path Abs Dir
absDir)
        else do
            Text
templateText <- TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
forall env.
HasConfig env =>
TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
loadTemplate TemplateName
template (Path Abs Dir -> TemplateName -> TemplateFrom -> RIO env ()
forall (m :: * -> *) env b.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Path b Dir -> TemplateName -> TemplateFrom -> m ()
logUsing Path Abs Dir
absDir TemplateName
template)
            Map (Path Abs File) ByteString
files <-
                PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> RIO env (Map (Path Abs File) ByteString)
forall env.
HasConfig env =>
PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> RIO env (Map (Path Abs File) ByteString)
applyTemplate
                    PackageName
project
                    TemplateName
template
                    (NewOpts -> Map Text Text
newOptsNonceParams NewOpts
opts)
                    Path Abs Dir
absDir
                    Text
templateText
            Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
forceOverwrite Bool -> Bool -> Bool
&& Bool
bare) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Path Abs File] -> RIO env ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
[Path Abs File] -> m ()
checkForOverwrite (Map (Path Abs File) ByteString -> [Path Abs File]
forall k a. Map k a -> [k]
M.keys Map (Path Abs File) ByteString
files)
            Map (Path Abs File) ByteString -> RIO env ()
forall (m :: * -> *).
MonadIO m =>
Map (Path Abs File) ByteString -> m ()
writeTemplateFiles Map (Path Abs File) ByteString
files
            Path Abs Dir -> RIO env ()
forall env. HasConfig env => Path Abs Dir -> RIO env ()
runTemplateInits Path Abs Dir
absDir
            Path Abs Dir -> RIO env (Path Abs Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs Dir
absDir
  where
    cliOptionTemplate :: Maybe TemplateName
cliOptionTemplate = NewOpts -> Maybe TemplateName
newOptsTemplate NewOpts
opts
    project :: PackageName
project = NewOpts -> PackageName
newOptsProjectName NewOpts
opts
    bare :: Bool
bare = NewOpts -> Bool
newOptsCreateBare NewOpts
opts
    logUsing :: Path b Dir -> TemplateName -> TemplateFrom -> m ()
logUsing Path b Dir
absDir TemplateName
template TemplateFrom
templateFrom =
        let loading :: Utf8Builder
loading = case TemplateFrom
templateFrom of
                          TemplateFrom
LocalTemp -> Utf8Builder
"Loading local"
                          TemplateFrom
RemoteTemp -> Utf8Builder
"Downloading"
         in
        Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo
            (Utf8Builder
loading Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" template \"" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (TemplateName -> Text
templateName TemplateName
template) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
"\" to create project \"" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
packageNameString PackageName
project) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
"\" in " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             if Bool
bare then Utf8Builder
"the current directory"
                     else FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Rel Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path b Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path b Dir
absDir)) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
" ...")

data TemplateFrom = LocalTemp | RemoteTemp

-- | Download and read in a template's text content.
loadTemplate
    :: forall env. HasConfig env
    => TemplateName
    -> (TemplateFrom -> RIO env ())
    -> RIO env Text
loadTemplate :: TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
loadTemplate TemplateName
name TemplateFrom -> RIO env ()
logIt = do
    Path Abs Dir
templateDir <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs Dir) env (Path Abs Dir)
 -> RIO env (Path Abs Dir))
-> Getting (Path Abs Dir) env (Path Abs Dir)
-> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Path Abs Dir) Config)
-> env -> Const (Path Abs Dir) env
forall env. HasConfig env => Lens' env Config
configL((Config -> Const (Path Abs Dir) Config)
 -> env -> Const (Path Abs Dir) env)
-> ((Path Abs Dir -> Const (Path Abs Dir) (Path Abs Dir))
    -> Config -> Const (Path Abs Dir) Config)
-> Getting (Path Abs Dir) env (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Path Abs Dir) -> SimpleGetter Config (Path Abs Dir)
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
templatesDir
    case TemplateName -> TemplatePath
templatePath TemplateName
name of
        AbsPath Path Abs File
absFile -> TemplateFrom -> RIO env ()
logIt TemplateFrom
LocalTemp RIO env () -> RIO env Text -> RIO env Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Path Abs File -> RIO env Text
forall b. Path b File -> RIO env Text
loadLocalFile Path Abs File
absFile
        UrlPath FilePath
s -> FilePath -> Path Abs Dir -> RIO env Text
downloadFromUrl FilePath
s Path Abs Dir
templateDir
        RelPath FilePath
rawParam Path Rel File
relFile ->
            RIO env Text -> (NewException -> RIO env Text) -> RIO env Text
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
                (do Text
f <- Path Rel File -> RIO env Text
forall b. Path b File -> RIO env Text
loadLocalFile Path Rel File
relFile
                    TemplateFrom -> RIO env ()
logIt TemplateFrom
LocalTemp
                    Text -> RIO env Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
f)
                (\(NewException
e :: NewException) ->
                      case FilePath -> Maybe Request
relRequest FilePath
rawParam of
                        Just Request
req -> Request -> Path Abs File -> RIO env Text
downloadTemplate Request
req
                                                     (Path Abs Dir
templateDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile)
                        Maybe Request
Nothing -> NewException -> RIO env Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM NewException
e
                )
        RepoPath RepoTemplatePath
rtp -> do
            let url :: Text
url = RepoTemplatePath -> Text
urlFromRepoTemplatePath RepoTemplatePath
rtp
            FilePath -> Path Abs Dir -> RIO env Text
downloadFromUrl (Text -> FilePath
T.unpack Text
url) Path Abs Dir
templateDir
                            
  where
    loadLocalFile :: Path b File -> RIO env Text
    loadLocalFile :: Path b File -> RIO env Text
loadLocalFile Path b File
path = do
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Opening local template: \"" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path b File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b File
path)
                                                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\"")
        Bool
exists <- Path b File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
path
        if Bool
exists
            then FilePath -> RIO env Text
forall (m :: * -> *). MonadIO m => FilePath -> m Text
readFileUtf8 (Path b File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b File
path)
            else NewException -> RIO env Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> FilePath -> NewException
FailedToLoadTemplate TemplateName
name (Path b File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b File
path))
    relRequest :: String -> Maybe Request
    relRequest :: FilePath -> Maybe Request
relRequest FilePath
req = do
        RepoTemplatePath
rtp <- RepoService -> Text -> Maybe RepoTemplatePath
parseRepoPathWithService RepoService
defaultRepoService (FilePath -> Text
T.pack FilePath
req)
        let url :: Text
url = RepoTemplatePath -> Text
urlFromRepoTemplatePath RepoTemplatePath
rtp
        FilePath -> Maybe Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest (Text -> FilePath
T.unpack Text
url)
    downloadFromUrl :: String -> Path Abs Dir -> RIO env Text
    downloadFromUrl :: FilePath -> Path Abs Dir -> RIO env Text
downloadFromUrl FilePath
s Path Abs Dir
templateDir = do
        Request
req <- FilePath -> RIO env Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest FilePath
s
        let rel :: Path Rel File
rel = Path Rel File -> Maybe (Path Rel File) -> Path Rel File
forall a. a -> Maybe a -> a
fromMaybe Path Rel File
backupUrlRelPath (FilePath -> Maybe (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
s)
        Request -> Path Abs File -> RIO env Text
downloadTemplate Request
req (Path Abs Dir
templateDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
rel)
    downloadTemplate :: Request -> Path Abs File -> RIO env Text
    downloadTemplate :: Request -> Path Abs File -> RIO env Text
downloadTemplate Request
req Path Abs File
path = do
        let dReq :: DownloadRequest
dReq = Bool -> DownloadRequest -> DownloadRequest
setForceDownload Bool
True (DownloadRequest -> DownloadRequest)
-> DownloadRequest -> DownloadRequest
forall a b. (a -> b) -> a -> b
$ Request -> DownloadRequest
mkDownloadRequest Request
req
        TemplateFrom -> RIO env ()
logIt TemplateFrom
RemoteTemp
        RIO env ()
-> (VerifiedDownloadException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
          (RIO env Bool -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env Bool -> RIO env ()) -> RIO env Bool -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
            DownloadRequest
-> Path Abs File -> Text -> Maybe Int -> RIO env Bool
forall env.
HasTerm env =>
DownloadRequest
-> Path Abs File -> Text -> Maybe Int -> RIO env Bool
verifiedDownloadWithProgress DownloadRequest
dReq Path Abs File
path (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
path) Maybe Int
forall a. Maybe a
Nothing
          )
          (Path Abs File -> VerifiedDownloadException -> RIO env ()
useCachedVersionOrThrow Path Abs File
path)

        Path Abs File -> RIO env Text
forall b. Path b File -> RIO env Text
loadLocalFile Path Abs File
path
    useCachedVersionOrThrow :: Path Abs File -> VerifiedDownloadException -> RIO env ()
    useCachedVersionOrThrow :: Path Abs File -> VerifiedDownloadException -> RIO env ()
useCachedVersionOrThrow Path Abs File
path VerifiedDownloadException
exception = do
      Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path

      if Bool
exists
        then do Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Tried to download the template but an error was found."
                Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Using cached local version. It may not be the most recent version though."
        else NewException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> VerifiedDownloadException -> NewException
FailedToDownloadTemplate TemplateName
name VerifiedDownloadException
exception)

-- | Construct a URL for downloading from a repo.
urlFromRepoTemplatePath :: RepoTemplatePath -> Text
urlFromRepoTemplatePath :: RepoTemplatePath -> Text
urlFromRepoTemplatePath (RepoTemplatePath RepoService
Github Text
user Text
name) =
    [Text] -> Text
T.concat [Text
"https://raw.githubusercontent.com", Text
"/", Text
user, Text
"/stack-templates/master/", Text
name]
urlFromRepoTemplatePath (RepoTemplatePath RepoService
Gitlab Text
user Text
name) =
    [Text] -> Text
T.concat [Text
"https://gitlab.com",                Text
"/", Text
user, Text
"/stack-templates/raw/master/", Text
name]
urlFromRepoTemplatePath (RepoTemplatePath RepoService
Bitbucket Text
user Text
name) =
    [Text] -> Text
T.concat [Text
"https://bitbucket.org",             Text
"/", Text
user, Text
"/stack-templates/raw/master/", Text
name]

-- | Apply and unpack a template into a directory.
applyTemplate
    :: HasConfig env
    => PackageName
    -> TemplateName
    -> Map Text Text
    -> Path Abs Dir
    -> Text
    -> RIO env  (Map (Path Abs File) LB.ByteString)
applyTemplate :: PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> RIO env (Map (Path Abs File) ByteString)
applyTemplate PackageName
project TemplateName
template Map Text Text
nonceParams Path Abs Dir
dir Text
templateText = do
    Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
configL
    Text
currentYear <- do
      UTCTime
now <- IO UTCTime -> RIO env UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      let (Integer
year, Int
_, Int
_) = Day -> (Integer, Int, Int)
toGregorian (UTCTime -> Day
utctDay UTCTime
now)
      Text -> RIO env Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> RIO env Text) -> Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> (Integer -> FilePath) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> FilePath
forall a. Show a => a -> FilePath
show (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Integer
year
    let context :: Map Text Text
context = [Map Text Text] -> Map Text Text
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions [Map Text Text
nonceParams, Map Text Text
nameParams, Map Text Text
configParams, Map Text Text
yearParam]
          where
            nameAsVarId :: Text
nameAsVarId = Text -> Text -> Text -> Text
T.replace Text
"-" Text
"_" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
packageNameString PackageName
project
            nameAsModule :: Text
nameAsModule = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toTitle (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"-" Text
" " (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
packageNameString PackageName
project
            nameParams :: Map Text Text
nameParams = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Text
"name", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
packageNameString PackageName
project)
                                    , (Text
"name-as-varid", Text
nameAsVarId)
                                    , (Text
"name-as-module", Text
nameAsModule) ]
            configParams :: Map Text Text
configParams = Config -> Map Text Text
configTemplateParams Config
config
            yearParam :: Map Text Text
yearParam = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
M.singleton Text
"year" Text
currentYear
    Map FilePath ByteString
files :: Map FilePath LB.ByteString <-
        RIO env (Map FilePath ByteString)
-> (ProjectTemplateException -> RIO env (Map FilePath ByteString))
-> RIO env (Map FilePath ByteString)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (WriterT (Map FilePath ByteString) (RIO env) ()
-> RIO env (Map FilePath ByteString)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT (Map FilePath ByteString) (RIO env) ()
 -> RIO env (Map FilePath ByteString))
-> WriterT (Map FilePath ByteString) (RIO env) ()
-> RIO env (Map FilePath ByteString)
forall a b. (a -> b) -> a -> b
$ ConduitT () Void (WriterT (Map FilePath ByteString) (RIO env)) ()
-> WriterT (Map FilePath ByteString) (RIO env) ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (WriterT (Map FilePath ByteString) (RIO env)) ()
 -> WriterT (Map FilePath ByteString) (RIO env) ())
-> ConduitT
     () Void (WriterT (Map FilePath ByteString) (RIO env)) ()
-> WriterT (Map FilePath ByteString) (RIO env) ()
forall a b. (a -> b) -> a -> b
$
               ByteString
-> ConduitT
     () ByteString (WriterT (Map FilePath ByteString) (RIO env)) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Text -> ByteString
T.encodeUtf8 Text
templateText) ConduitT
  () ByteString (WriterT (Map FilePath ByteString) (RIO env)) ()
-> ConduitM
     ByteString Void (WriterT (Map FilePath ByteString) (RIO env)) ()
-> ConduitT
     () Void (WriterT (Map FilePath ByteString) (RIO env)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.|
               (FilePath
 -> ConduitM
      ByteString Void (WriterT (Map FilePath ByteString) (RIO env)) ())
-> (Text -> Text)
-> ConduitM
     ByteString Void (WriterT (Map FilePath ByteString) (RIO env)) ()
forall (m :: * -> *) o.
MonadThrow m =>
(FilePath -> ConduitM ByteString o m ())
-> (Text -> Text) -> ConduitM ByteString o m ()
unpackTemplate FilePath
-> ConduitM
     ByteString Void (WriterT (Map FilePath ByteString) (RIO env)) ()
forall (m :: * -> *).
MonadWriter (Map FilePath ByteString) m =>
FileReceiver m
receiveMem Text -> Text
forall a. a -> a
id
              )
              (\(ProjectTemplateException
e :: ProjectTemplateException) ->
                   NewException -> RIO env (Map FilePath ByteString)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> FilePath -> NewException
InvalidTemplate TemplateName
template (ProjectTemplateException -> FilePath
forall a. Show a => a -> FilePath
show ProjectTemplateException
e)))
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map FilePath ByteString -> Bool
forall k a. Map k a -> Bool
M.null Map FilePath ByteString
files) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         NewException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> FilePath -> NewException
InvalidTemplate TemplateName
template FilePath
"Template does not contain any files")

    let isPkgSpec :: FilePath -> Bool
isPkgSpec FilePath
f = FilePath
".cabal" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
f Bool -> Bool -> Bool
|| FilePath
f FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"package.yaml"
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any FilePath -> Bool
isPkgSpec ([FilePath] -> Bool)
-> (Map FilePath ByteString -> [FilePath])
-> Map FilePath ByteString
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FilePath ByteString -> [FilePath]
forall k a. Map k a -> [k]
M.keys (Map FilePath ByteString -> Bool)
-> Map FilePath ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ Map FilePath ByteString
files) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         NewException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> FilePath -> NewException
InvalidTemplate TemplateName
template FilePath
"Template does not contain a .cabal \
                                          \or package.yaml file")

    -- Apply Mustache templating to a single file within the project
    -- template.
    let applyMustache :: ByteString -> m ByteString
applyMustache ByteString
bytes
          -- Workaround for performance problems with mustache and
          -- large files, applies to Yesod templates with large
          -- bootstrap CSS files. See
          -- https://github.com/commercialhaskell/stack/issues/4133.
          | ByteString -> Int64
LB.length ByteString
bytes Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
50000
          , Right Text
text <- ByteString -> Either UnicodeException Text
TLE.decodeUtf8' ByteString
bytes = do
              let etemplateCompiled :: Either ParseError Template
etemplateCompiled = FilePath -> Text -> Either ParseError Template
Mustache.compileTemplate (Text -> FilePath
T.unpack (TemplateName -> Text
templateName TemplateName
template)) (Text -> Either ParseError Template)
-> Text -> Either ParseError Template
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
text
              Template
templateCompiled <- case Either ParseError Template
etemplateCompiled of
                Left ParseError
e -> NewException -> m Template
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NewException -> m Template) -> NewException -> m Template
forall a b. (a -> b) -> a -> b
$ TemplateName -> FilePath -> NewException
InvalidTemplate TemplateName
template (ParseError -> FilePath
forall a. Show a => a -> FilePath
show ParseError
e)
                Right Template
t -> Template -> m Template
forall (m :: * -> *) a. Monad m => a -> m a
return Template
t
              let ([SubstitutionError]
substitutionErrors, Text
applied) = Template -> Map Text Text -> ([SubstitutionError], Text)
forall k.
ToMustache k =>
Template -> k -> ([SubstitutionError], Text)
Mustache.checkedSubstitute Template
templateCompiled Map Text Text
context
                  missingKeys :: Set FilePath
missingKeys = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
S.fromList ([FilePath] -> Set FilePath) -> [FilePath] -> Set FilePath
forall a b. (a -> b) -> a -> b
$ (SubstitutionError -> [FilePath])
-> [SubstitutionError] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SubstitutionError -> [FilePath]
onlyMissingKeys [SubstitutionError]
substitutionErrors
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set FilePath -> Bool
forall a. Set a -> Bool
S.null Set FilePath
missingKeys)
                (Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> NewException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (PackageName
-> TemplateName -> Set FilePath -> Path Abs File -> NewException
MissingParameters PackageName
project TemplateName
template Set FilePath
missingKeys (Config -> Path Abs File
configUserConfigPath Config
config)) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"))
              ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
applied

          -- Too large or too binary
          | Bool
otherwise = ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bytes

    ([(Path Abs File, ByteString)] -> Map (Path Abs File) ByteString)
-> RIO env [(Path Abs File, ByteString)]
-> RIO env (Map (Path Abs File) ByteString)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
        [(Path Abs File, ByteString)] -> Map (Path Abs File) ByteString
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        (((FilePath, ByteString) -> RIO env (Path Abs File, ByteString))
-> [(FilePath, ByteString)]
-> RIO env [(Path Abs File, ByteString)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
             (\(FilePath
fpOrig,ByteString
bytes) ->
                   do -- Apply the mustache template to the filenames
                      -- as well, so that we can have file names
                      -- depend on the project name.
                      ByteString
fp <- ByteString -> RIO env ByteString
forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasLogFunc env) =>
ByteString -> m ByteString
applyMustache (ByteString -> RIO env ByteString)
-> ByteString -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TLE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
TL.pack FilePath
fpOrig
                      Path Rel File
path <- FilePath -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile (FilePath -> RIO env (Path Rel File))
-> FilePath -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
TL.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TLE.decodeUtf8 ByteString
fp
                      ByteString
bytes' <- ByteString -> RIO env ByteString
forall (m :: * -> *) env.
(MonadThrow m, MonadIO m, MonadReader env m, HasLogFunc env) =>
ByteString -> m ByteString
applyMustache ByteString
bytes
                      (Path Abs File, ByteString) -> RIO env (Path Abs File, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir
dir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
path, ByteString
bytes'))
             (Map FilePath ByteString -> [(FilePath, ByteString)]
forall k a. Map k a -> [(k, a)]
M.toList Map FilePath ByteString
files))
  where
    onlyMissingKeys :: SubstitutionError -> [FilePath]
onlyMissingKeys (Mustache.VariableNotFound [Text]
ks) = (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack [Text]
ks
    onlyMissingKeys SubstitutionError
_ = []

-- | Check if we're going to overwrite any existing files.
checkForOverwrite :: (MonadIO m, MonadThrow m) => [Path Abs File] -> m ()
checkForOverwrite :: [Path Abs File] -> m ()
checkForOverwrite [Path Abs File]
files = do
    [Path Abs File]
overwrites <- (Path Abs File -> m Bool) -> [Path Abs File] -> m [Path Abs File]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Path Abs File -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist [Path Abs File]
files
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Path Abs File] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
overwrites) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NewException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([Path Abs File] -> NewException
AttemptedOverwrites [Path Abs File]
overwrites)

-- | Write files to the new project directory.
writeTemplateFiles
    :: MonadIO m
    => Map (Path Abs File) LB.ByteString -> m ()
writeTemplateFiles :: Map (Path Abs File) ByteString -> m ()
writeTemplateFiles Map (Path Abs File) ByteString
files =
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    [(Path Abs File, ByteString)]
-> ((Path Abs File, ByteString) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
        (Map (Path Abs File) ByteString -> [(Path Abs File, ByteString)]
forall k a. Map k a -> [(k, a)]
M.toList Map (Path Abs File) ByteString
files)
        (\(Path Abs File
fp,ByteString
bytes) ->
              do Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)
                 Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
fp (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
lazyByteString ByteString
bytes)

-- | Run any initialization functions, such as Git.
runTemplateInits
    :: HasConfig env
    => Path Abs Dir
    -> RIO env ()
runTemplateInits :: Path Abs Dir -> RIO env ()
runTemplateInits Path Abs Dir
dir = do
    Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
configL
    case Config -> Maybe SCM
configScmInit Config
config of
        Maybe SCM
Nothing -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just SCM
Git ->
            FilePath -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
FilePath -> m a -> m a
withWorkingDir (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
dir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
            RIO env () -> (SomeException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny (FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env ())
-> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"git" [FilePath
"init"] ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_)
                  (\SomeException
_ -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"git init failed to run, ignoring ...")

-- | Display help for the templates command.
templatesHelp :: HasLogFunc env => RIO env ()
templatesHelp :: RIO env ()
templatesHelp = do
  let url :: FilePath
url = FilePath
defaultTemplatesHelpUrl
  Request
req <- (Request -> Request) -> RIO env Request -> RIO env Request
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Request
setGithubHeaders (FilePath -> RIO env Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseUrlThrow FilePath
url)
  Response ByteString
resp <- Request -> RIO env (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLbs Request
req RIO env (Response ByteString)
-> (HttpException -> RIO env (Response ByteString))
-> RIO env (Response ByteString)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (NewException -> RIO env (Response ByteString)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NewException -> RIO env (Response ByteString))
-> (HttpException -> NewException)
-> HttpException
-> RIO env (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> NewException
FailedToDownloadTemplatesHelp)
  case ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody Response ByteString
resp of
    Left UnicodeException
err -> NewException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NewException -> RIO env ()) -> NewException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> UnicodeException -> NewException
BadTemplatesHelpEncoding FilePath
url UnicodeException
err
    Right Text
txt -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
txt

--------------------------------------------------------------------------------
-- Defaults

-- | The default service to use to download templates.
defaultRepoService :: RepoService
defaultRepoService :: RepoService
defaultRepoService = RepoService
Github

-- | Default web URL to get the `stack templates` help output.
defaultTemplatesHelpUrl :: String
defaultTemplatesHelpUrl :: FilePath
defaultTemplatesHelpUrl =
    FilePath
"https://raw.githubusercontent.com/commercialhaskell/stack-templates/master/STACK_HELP.md"

--------------------------------------------------------------------------------
-- Exceptions

-- | Exception that might occur when making a new project.
data NewException
    = FailedToLoadTemplate !TemplateName
                           !FilePath
    | FailedToDownloadTemplate !TemplateName
                               !VerifiedDownloadException
    | AlreadyExists !(Path Abs Dir)
    | MissingParameters !PackageName !TemplateName !(Set String) !(Path Abs File)
    | InvalidTemplate !TemplateName !String
    | AttemptedOverwrites [Path Abs File]
    | FailedToDownloadTemplatesHelp !HttpException
    | BadTemplatesHelpEncoding
        !String -- URL it's downloaded from
        !UnicodeException
    | Can'tUseWiredInName !PackageName
    deriving (Typeable)

instance Exception NewException

instance Show NewException where
    show :: NewException -> FilePath
show (FailedToLoadTemplate TemplateName
name FilePath
path) =
        FilePath
"Failed to load download template " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (TemplateName -> Text
templateName TemplateName
name) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        FilePath
" from " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        FilePath
path
    show (FailedToDownloadTemplate TemplateName
name (DownloadHttpError HttpException
httpError)) =
          FilePath
"There was an unexpected HTTP error while downloading template " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          Text -> FilePath
T.unpack (TemplateName -> Text
templateName TemplateName
name) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
": " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> HttpException -> FilePath
forall a. Show a => a -> FilePath
show HttpException
httpError
    show (FailedToDownloadTemplate TemplateName
name VerifiedDownloadException
_) =
        FilePath
"Failed to download template " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (TemplateName -> Text
templateName TemplateName
name) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        FilePath
": unknown reason"

    show (AlreadyExists Path Abs Dir
path) =
        FilePath
"Directory " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
path FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" already exists. Aborting."
    show (MissingParameters PackageName
name TemplateName
template Set FilePath
missingKeys Path Abs File
userConfigPath) =
        FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate
            FilePath
"\n"
            [ FilePath
"The following parameters were needed by the template but not provided: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
              FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (Set FilePath -> [FilePath]
forall a. Set a -> [a]
S.toList Set FilePath
missingKeys)
            , FilePath
"You can provide them in " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
              Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
userConfigPath FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
              FilePath
", like this:"
            , FilePath
"templates:"
            , FilePath
"  params:"
            , FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate
                  FilePath
"\n"
                  (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map
                       (\FilePath
key ->
                             FilePath
"    " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
key FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
": value")
                       (Set FilePath -> [FilePath]
forall a. Set a -> [a]
S.toList Set FilePath
missingKeys))
            , FilePath
"Or you can pass each one as parameters like this:"
            , FilePath
"stack new " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageName -> FilePath
packageNameString PackageName
name FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
              Text -> FilePath
T.unpack (TemplateName -> Text
templateName TemplateName
template) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
              FilePath
" " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
              [FilePath] -> FilePath
unwords
                  (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map
                       (\FilePath
key ->
                             FilePath
"-p \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
key FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
":value\"")
                       (Set FilePath -> [FilePath]
forall a. Set a -> [a]
S.toList Set FilePath
missingKeys))]
    show (InvalidTemplate TemplateName
name FilePath
why) =
        FilePath
"The template \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (TemplateName -> Text
templateName TemplateName
name) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        FilePath
"\" is invalid and could not be used. " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        FilePath
"The error was: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
why
    show (AttemptedOverwrites [Path Abs File]
fps) =
        FilePath
"The template would create the following files, but they already exist:\n" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        [FilePath] -> FilePath
unlines ((Path Abs File -> FilePath) -> [Path Abs File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
"  " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Path Abs File -> FilePath) -> Path Abs File -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath) [Path Abs File]
fps) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        FilePath
"Use --force to ignore this, and overwite these files."
    show (FailedToDownloadTemplatesHelp HttpException
ex) =
        FilePath
"Failed to download `stack templates` help. The HTTP error was: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> HttpException -> FilePath
forall a. Show a => a -> FilePath
show HttpException
ex
    show (BadTemplatesHelpEncoding FilePath
url UnicodeException
err) =
        FilePath
"UTF-8 decoding error on template info from\n    " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
url FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n\n" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> UnicodeException -> FilePath
forall a. Show a => a -> FilePath
show UnicodeException
err
    show (Can'tUseWiredInName PackageName
name) =
        FilePath
"The name \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageName -> FilePath
packageNameString PackageName
name FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\" is used by GHC wired-in packages, and so shouldn't be used as a package name"