#137 Add command-line variables to stack new

src/Stack/New.hs

@@ -2,16 +2,19 @@
 {-# LANGUAGE TemplateHaskell   #-}
 module Stack.New
     ( newProject
+    , NewOpts(..)
     ) where
 
 import           Control.Monad          (filterM, forM_, forM, unless)
 import           Control.Monad.IO.Class (MonadIO, liftIO)
-import           Control.Monad.Logger   (MonadLogger, logInfo)
+import           Control.Monad.Logger   (MonadLogger, logInfo, logDebug, logError)
 import           Data.ByteString        (ByteString)
 import qualified Data.ByteString        as S
 import           Data.FileEmbed         (embedDir)
+import qualified Data.List              as List
 import           Data.Map               (Map)
 import qualified Data.Map               as Map
+import           Data.Monoid            ((<>))
 import qualified Data.Text              as T
 import qualified Data.Text.Encoding     as T
 import qualified Data.Text.Lazy         as LT
@@ -21,44 +24,88 @@ import           System.Directory       (createDirectoryIfMissing,
 import           System.FilePath        (takeDirectory,
                                          takeFileName,
                                          dropTrailingPathSeparator)
+import           System.Exit            (exitFailure)
 import           Text.Hastache
 import           Text.Hastache.Context
 
 import           Stack.Init (InitOpts(forceOverwrite))
 
-newProject :: (MonadIO m, MonadLogger m)
-           => InitOpts
-           -> m ()
-newProject initOpts = do
-    $logInfo "NOTE: Currently stack new functionality is very rudimentary"
-    $logInfo "There are plans to make this feature more useful in the future"
-    $logInfo "For more information, see: https://github.com/commercialhaskell/stack/issues/137"
-    $logInfo "For now, we'll just be generating a basic project structure in your current directory"
+data NewOpts = NewOpts
+    { newOptsTemplateRepository :: String
+    , newOptsTemplate :: Maybe Template
+    , newOptsTemplateArgs :: [String]
+    , newOptsInitOpts :: InitOpts
+    }
 
-    exist <- filterM (liftIO . doesFileExist) (Map.keys files)
-    unless (forceOverwrite initOpts || null exist) $
-       error $ unlines
-           $ "The following files already exist, refusing to overwrite (no --force):"
-           : map ("- " ++) exist
+type Template = String
 
-    $logInfo ""
+defaultTemplate :: Template
+defaultTemplate = "new-template"
+
+-- TODO(DanBurton): support multiple templates
+-- Get the files associated with a given template
+getFiles :: (MonadIO m, MonadLogger m)
+         => String -> Template -> m (Map FilePath ByteString)
+getFiles _repo "new-template" = return $  Map.fromList $(embedDir "new-template")
+getFiles repo template = do
+    $logError $
+        "Error fetching template: " <> T.pack template <> "\n"
+        <> "     from repository: " <> T.pack repo <> "\n"
+        <> "\n"
+        <> "Sorry, only new-template is supported right now.\n"
+        <> "Support for more templates soon to come.\n"
+        <> "See: https://github.com/commercialhaskell/stack/issues/137"
+    liftIO exitFailure -- the end
 
-    -- Detect settings for mustache template.
+-- Detect default key:value pairs for mustache template.
+getDefaultArgs :: (MonadIO m, MonadLogger m) => m [(String, String)]
+getDefaultArgs = do
     currentDirectory <- liftIO getCurrentDirectory
     let name = takeFileName $ dropTrailingPathSeparator currentDirectory
+    return [("name", name)]
+
+-- Take a list of strings of the form "key:val" and turn into a list of tuples.
+toArgs :: [String] -> [(String, String)]
+toArgs = map toArg
+  where
+    toArg s = case break (== ':') s of
+        (key, ':':val) -> (key, val)
+        _-> (s, "") -- TODO(DanBurton): Handle this error case better.
+
+newProject :: (MonadIO m, MonadLogger m)
+           => NewOpts
+           -> m ()
+newProject newOpts = do
+    let NewOpts repo templateMay args0 initOpts = newOpts
+
+    $logDebug "Calculating template arguments"
+    defaultArgs <- getDefaultArgs
+    -- TODO(DanBurton): Do this logic in the arg parser instead.
+    let (template, args1) = case templateMay of
+            Nothing -> (defaultTemplate, args0)
+            -- If the "template" arg has a colon, treat as arg instead.
+            Just template0 -> case break (== ':') template0 of
+               (_, []) -> (template0, args0)
+               (_key, _colonVal) -> (defaultTemplate, template0:args0)
+    let args = toArgs args1 ++ defaultArgs
+
+    $logDebug "Loading template files"
+    files <- getFiles repo template
 
-    let contextLookup "name" = MuVariable name
-        contextLookup _ = MuNothing
+    let contextLookup key = case List.lookup key args of
+            Just val -> MuVariable val
+            Nothing  -> MuNothing
 
-    let runHastache template =
-            hastacheStr defaultConfig template (mkStrContext contextLookup)
+    let runHastache text =
+            hastacheStr defaultConfig text (mkStrContext contextLookup)
 
     -- Render file paths and file contents via mustache.
     -- There is some unsafety in `unMustache` on file names,
     -- because file names could collide.
     -- I believe the correct way to handle this is to tell template creators
     -- to be careful to avoid this if they use mustache in file names.
     -- ~ Dan Burton
+    $logDebug "Rendering templates"
     files' <- liftIO $ forM (Map.toList files) $ \(fp, bs) -> do
         let fpText = T.pack fp
         fpLText' <- runHastache fpText
@@ -70,11 +117,18 @@ newProject initOpts = do
 
         return (fp', bs')
 
+    $logDebug "Checking presence of template files"
+    exist <- filterM (liftIO . doesFileExist) (map fst files')
+    unless (forceOverwrite initOpts || null exist) $
+       error $ unlines
+           $ "The following files already exist, refusing to overwrite (no --force):"
+           : map ("- " ++) exist
+
+    $logDebug "Writing template files"
+    $logInfo ""
+
     forM_ files' $ \(fp, bs) -> do
         $logInfo $ T.pack $ "Writing: " ++ fp
         liftIO $ do
             createDirectoryIfMissing True $ takeDirectory fp
             S.writeFile fp bs
-
-files :: Map FilePath ByteString
-files = Map.fromList $(embedDir "new-template")

src/Stack/Options.hs

@@ -11,6 +11,7 @@ module Stack.Options
     ,execOptsParser
     ,globalOptsParser
     ,initOptsParser
+    ,newOptsParser
     ,logLevelOptsParser
     ,resolverOptsParser
     ,solverOptsParser
@@ -38,6 +39,7 @@ import Stack.Docker
 import qualified Stack.Docker as Docker
 import Stack.Dot
 import Stack.Init
+import Stack.New (NewOpts(..))
 import Stack.Solver
 import Stack.Types
 import Data.Attoparsec.Args (EscapingMode (Escaping), parseArgs)
@@ -529,3 +531,19 @@ testOptsParser = TestOpts
                True
                (long "no-run-tests" <>
                 help "Disable running of tests. (Tests will still be built.)")
+
+newOptsParser :: Parser NewOpts
+newOptsParser =
+    NewOpts <$> templateRepositoryParser
+            <*> optional templateParser
+            <*> many templateArgParser
+            <*> initOptsParser
+  where
+    templateRepositoryParser = strOption
+         $ long "template-repository"
+        <> metavar "REPO"
+        <> value "https://github.com/commercialhaskell/stack-templates"
+    -- TODO(DanBurton): reject argument if it has a colon.
+    templateParser = strArgument $ metavar "TEMPLATE"
+    -- TODO(DanBurton): reject argument if it doesn't have a colon.
+    templateArgParser = strArgument $ metavar "ARG:VAL"

src/main/Main.hs

@@ -120,7 +120,7 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter ->
              addCommand "new"
                         "Create a brand new project"
                         newCmd
-                        initOptsParser
+                        newOptsParser
              addCommand "init"
                         "Initialize a stack project based on one or more cabal packages"
                         initCmd
@@ -610,10 +610,10 @@ initCmd :: InitOpts -> GlobalOpts -> IO ()
 initCmd initOpts go = withConfig go $ initProject initOpts
 
 -- | Project creation
-newCmd :: InitOpts -> GlobalOpts -> IO ()
-newCmd initOpts go@GlobalOpts{..} = withConfig go $ do
-    newProject initOpts
-    initProject initOpts
+newCmd :: NewOpts -> GlobalOpts -> IO ()
+newCmd newOpts go@GlobalOpts{..} = withConfig go $ do
+    newProject newOpts
+    initProject (newOptsInitOpts newOpts)
 
 -- | Fix up extra-deps for a project
 solverCmd :: Bool -- ^ modify stack.yaml automatically?