Browse Source

Naive implementation that (only just) works

Start of work on #137
137-stack-new
Khan Thompson 7 years ago
parent
commit
8a6d98739e
  1. 103
      src/Stack/NewProject.hs
  2. 22
      src/main/Main.hs
  3. 1
      stack.cabal

103
src/Stack/NewProject.hs

@ -0,0 +1,103 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.NewProject where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Data.List (intercalate)
import Data.Monoid
import qualified Data.Text as T
import Stack.Types.StackT
import System.Directory
import System.Exit
import System.FilePath
import System.Process
data NewProjectDependency =
NewProjectDependency
{ name :: T.Text
, version :: Maybe T.Text }
deriving (Eq,Show)
data NewProjectArgs =
NewProjectArgs
{ npaProjectName :: T.Text
, npaTemplateName :: T.Text
, npaDependencies :: [NewProjectDependency] }
deriving (Eq,Show)
-- | Create a new project
create :: NewProjectArgs -> StackLoggingT IO ()
create args@NewProjectArgs{..} = do
$logInfo $ "Creating new project named " <> npaProjectName <> " using template '" <> npaTemplateName <> "'."
defaultTemplate args
$logInfo "stack new complete."
defaultTemplate :: NewProjectArgs -> StackLoggingT IO ()
defaultTemplate args@NewProjectArgs{..} = do
let directoryName = T.unpack npaProjectName
$logInfo "Creating default template"
$logInfo "Creating directory"
alreadyExists <- liftIO $ doesDirectoryExist directoryName
when alreadyExists $ error ("Directory " <> directoryName <> " already exists.")
liftIO $ createDirectory directoryName
$logInfo "Running cabal"
(_, _, _, ph) <- liftIO $
createProcess (proc "cabal" ["init", "--main-is=Main.hs", "--source-dir=src"])
{ delegate_ctlc = True
, cwd = Just directoryName }
cabalExitCode <- liftIO $ waitForProcess ph
case cabalExitCode of
ExitFailure code -> error $ "Cabal failed with an exit code of " <> show code
_ -> return ()
$logInfo "Verifying license"
licenseExists <- liftIO $ doesFileExist (directoryName </> "LICENSE")
when (not licenseExists) $ do
$logInfo "LICENSE file was not autogenerated - touching one now"
liftIO $ writeFile (directoryName </> "LICENSE") "\n"
$logInfo "Creating Main module"
liftIO $ createDirectory (directoryName </> "src")
liftIO $ writeFile (directoryName </> "src" </> "Main.hs")
$ T.unpack $ T.intercalate "\n"
[ "module Main where"
, ""
, "main :: IO ()"
, "main = putStrLn \"Hello, " <> npaProjectName <> "\""
, ""]
$logInfo "Creating stack.yaml file"
liftIO $ writeFile (directoryName </> "stack.yaml") (createStackYaml args)
$logInfo "Running stack build" -- TODO: Actually call into build
(_, _, _, stackProcessHandle) <- liftIO $
createProcess (proc "stack" ["build"])
{ delegate_ctlc = True
, cwd = Just directoryName }
stackExitCode <- liftIO $ waitForProcess stackProcessHandle
case stackExitCode of
ExitFailure code -> error $ "Stack build failed with an exit code of " <> show code
_ -> return ()
return ()
createStackYaml :: NewProjectArgs -> String
createStackYaml NewProjectArgs{..} =
let resolver = "lts-2.9"
packages = ["."]
asPackageEntry x = "- " <> x <> "\n"
in "resolver: " <> resolver <> "\n" <>
"packages: " <> "\n" <> intercalate "\n" (map asPackageEntry packages)

22
src/main/Main.hs

@ -40,6 +40,7 @@ import qualified Stack.Docker as Docker
import Stack.Exec
import Stack.Fetch
import Stack.GhcPkg (getCabalPkgVer)
import qualified Stack.NewProject as NewProject
import qualified Stack.PackageIndex
import Stack.Path
import Stack.Setup
@ -92,8 +93,8 @@ main =
buildOpts
addCommand "new"
"Create a brand new project"
(error "new command not yet implemented, check out https://github.com/commercialhaskell/stack/issues/137 for status and to get involved")
(pure ())
newProjectCmd
newProjectCmdOpts
addCommand "setup"
"Get the appropriate ghc for your project"
setupCmd
@ -334,6 +335,12 @@ installCmd :: BuildOpts -> GlobalOpts -> IO ()
installCmd opts go@GlobalOpts{..} = withBuildConfig go ExecStrategy $
Stack.Build.build opts { boptsInstallExes = True }
-- | New
newProjectCmd :: NewProject.NewProjectArgs -> GlobalOpts -> IO ()
newProjectCmd newArgs go@GlobalOpts{..} = do
(manager,_) <- loadConfigWithOpts go
runStackLoggingT manager globalLogLevel $ NewProject.create newArgs
-- | Unpack packages to the filesystem
unpackCmd :: [String] -> GlobalOpts -> IO ()
unpackCmd names go@GlobalOpts{..} = do
@ -464,6 +471,17 @@ buildOpts =
onlySnapshot = flag False True
(long "only-snapshot" <>
help "Only build packages for the snapshot database, not the local database")
-- | Parser for new stack project arguments
newProjectCmdOpts :: Parser NewProject.NewProjectArgs
newProjectCmdOpts = NewProject.NewProjectArgs <$> projectName <*> templateName <*> dependencies
where projectName = T.pack <$> strArgument (metavar "NAME")
templateName = T.pack <$> strOption (metavar "TEMPLATE" <> short 't' <> long "template" <> value "default")
dependencies = many (option dependencyReader $ metavar "DEPENDENCY" <> short 'd' <> long "dependency")
dependencyReader :: ReadM NewProject.NewProjectDependency
dependencyReader = do
dontAllowVersionOverideYet <- T.pack <$> readerAsk -- TODO: Github issue
return $ NewProject.NewProjectDependency dontAllowVersionOverideYet Nothing
-- | Parser for docker cleanup arguments.
dockerCleanupOpts :: Parser Docker.CleanupOpts

1
stack.cabal

@ -35,6 +35,7 @@ library
Stack.Fetch
Stack.Exec
Stack.GhcPkg
Stack.NewProject
Stack.Package
Stack.PackageDump
Stack.PackageIndex

Loading…
Cancel
Save