Authorship options for stack new (#744)

Author: chrisdone

src/Stack/Config.hs

@@ -166,6 +166,10 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} =
             Just i -> return i
      let configConcurrentTests = fromMaybe True configMonoidConcurrentTests
 
+     let configAuthorEmail = configMonoidAuthorEmail
+         configAuthorName = configMonoidAuthorName
+         configScmInit = configMonoidScmInit
+
      return Config {..}
 
 -- | Get the directory on Windows where we should install extra programs. For

src/Stack/Constants.hs

@@ -31,13 +31,17 @@ module Stack.Constants
     ,hpcDirFromDir
     ,dotHpc
     ,objectInterfaceDir
-    ,templatesDir)
+    ,templatesDir
+    ,defaultAuthorEmail
+    ,defaultAuthorName
+    ,globalConfigPath
+    ,authorEmailKey
+    ,authorNameKey
+    ,scmInitKey)
     where
 
-
 import           Control.Monad.Catch (MonadThrow)
 import           Control.Monad.Reader
-
 import           Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
 import           Data.Text (Text)
@@ -295,3 +299,15 @@ implicitGlobalDir p =
 -- | Where .mix files go.
 dotHpc :: Path Rel Dir
 dotHpc = $(mkRelDir ".hpc")
+
+-- | Default author email.
+defaultAuthorEmail :: Text
+defaultAuthorEmail = "[email protected]"
+
+-- | Default author name.
+defaultAuthorName :: Text
+defaultAuthorName = "Example Author Name"
+
+-- | Global config path.
+globalConfigPath :: Config -> Path Abs File
+globalConfigPath = (</> $(mkRelFile "stack.yaml")) . configStackRoot

src/Stack/New.hs

@@ -48,6 +48,7 @@ import           Path.IO
 import           Stack.Constants
 import           Stack.Types
 import           Stack.Types.TemplateName
+import           System.Process.Run
 import           Text.Hastache
 import           Text.Hastache.Context
 import           Text.ProjectTemplate
@@ -77,6 +78,7 @@ new opts = do
             templateText <- loadTemplate template
             files <- applyTemplate project absDir templateText
             writeTemplateFiles files
+            runTemplateInits absDir
             return absDir
   where
     template = newOptsTemplate opts
@@ -107,11 +109,16 @@ loadTemplate name = do
 
 -- | Apply and unpack a template into a directory.
 applyTemplate
-    :: (MonadIO m, MonadThrow m)
+    :: (MonadIO m, MonadThrow m, MonadReader r m, HasConfig r, MonadLogger m)
     => PackageName -> Path Abs Dir -> Text -> m (Map (Path Abs File) LB.ByteString)
 applyTemplate project dir template = do
+    config <- asks getConfig
+    displayContext config
     applied <-
-        hastacheStr defaultConfig template (mkStrContext contextFunction)
+        hastacheStr
+            defaultConfig
+            template
+            (mkStrContext (contextFunction config))
     files :: Map FilePath LB.ByteString <-
         execWriterT $
         yield (T.encodeUtf8 (LT.toStrict applied)) $$
@@ -123,9 +130,31 @@ applyTemplate project dir template = do
                    do path <- parseRelFile fp
                       return (dir </> path, bytes))
              (M.toList files))
-  where contextFunction :: String -> MuType m
-        contextFunction "name" = MuVariable (packageNameString project)
-        contextFunction _      = MuNothing
+  where
+    context config =
+        [ ("name", packageNameText project)
+        , ( authorEmailKey
+          , fromMaybe defaultAuthorEmail (configAuthorEmail config))
+        , (authorNameKey, fromMaybe defaultAuthorName (configAuthorName config))]
+    contextFunction :: Config -> String -> MuType m
+    contextFunction config key =
+        case lookup (T.pack key) (context config) of
+            Nothing -> MuNothing
+            Just value -> MuVariable value
+
+-- | Display the context being used for the template.
+displayContext :: MonadLogger m => Config -> m ()
+displayContext config = do
+    $logInfo "Using the following authorship configuration:"
+    $logInfo
+        (authorEmailKey <> ": " <>
+         fromMaybe defaultAuthorEmail (configAuthorEmail config))
+    $logInfo
+        (authorNameKey <> ": " <>
+         fromMaybe defaultAuthorName (configAuthorName config))
+    $logInfo
+        ("Copy these to " <> T.pack (toFilePath (globalConfigPath config)) <>
+         " and edit to use different values.")
 
 -- | Write files to the new project directory.
 writeTemplateFiles
@@ -138,6 +167,21 @@ writeTemplateFiles files = do
               do createTree (parent fp)
                  liftIO (LB.writeFile (toFilePath fp) bytes))
 
+-- | Run any initialization functions, such as Git.
+runTemplateInits
+    :: (MonadIO m, MonadReader r m, HasConfig r, MonadLogger m, MonadCatch m)
+    => Path Abs Dir -> m ()
+runTemplateInits dir = do
+    menv <- getMinimalEnvOverride
+    config <- asks getConfig
+    case configScmInit config of
+        Nothing -> return ()
+        Just Git ->
+            do catch
+                   (callProcess (Just dir) menv "git" ["init"])
+                   (\(_ :: ProcessExitedUnsuccessfully) ->
+                         $logInfo "git init failed to run, ignoring ...")
+
 --------------------------------------------------------------------------------
 -- Getting templates list
 

src/Stack/Types/Config.hs

@@ -15,8 +15,8 @@ import           Control.Applicative ((<|>), (<$>), (<*>), pure)
 import           Control.Exception
 import           Control.Monad (liftM, mzero)
 import           Control.Monad.Catch (MonadThrow, throwM)
-import           Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)
 import           Control.Monad.Logger (LogLevel(..))
+import           Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)
 import           Data.Aeson.Extended
                  (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object,
                   (.=), (.:), (..:), (..:?), (..!=), Value(String, Object),
@@ -29,9 +29,9 @@ import           Data.Either (partitionEithers)
 import           Data.Hashable (Hashable)
 import           Data.Map (Map)
 import qualified Data.Map as Map
+import           Data.Monoid
 import           Data.Set (Set)
 import qualified Data.Set as Set
-import           Data.Monoid
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Data.Text.Encoding (encodeUtf8, decodeUtf8)
@@ -40,9 +40,9 @@ import           Data.Yaml (ParseException)
 import           Distribution.System (Platform)
 import qualified Distribution.Text
 import           Distribution.Version (anyVersion)
-import qualified Paths_stack as Meta
 import           Network.HTTP.Client (parseUrl)
 import           Path
+import qualified Paths_stack as Meta
 import           Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName)
 import           Stack.Types.Docker
 import           Stack.Types.FlagName
@@ -111,6 +111,12 @@ data Config =
          ,configConcurrentTests     :: !Bool
          -- ^ Run test suites concurrently
          ,configImage               :: !ImageOpts
+         ,configAuthorEmail         :: !(Maybe Text)
+         -- ^ Email of the author using stack.
+         ,configAuthorName          :: !(Maybe Text)
+         -- ^ Name of the author using stack.
+         ,configScmInit             :: !(Maybe SCM)
+         -- ^ Initialize SCM (e.g. git) when creating new projects.
          }
 
 -- | Information on a single package index
@@ -500,6 +506,12 @@ data ConfigMonoid =
     -- ^ Used to override the binary installation dir
     ,configMonoidImageOpts           :: !ImageOptsMonoid
     -- ^ Image creation options.
+    ,configMonoidAuthorEmail         :: !(Maybe Text)
+    -- ^ Author's email address.
+    ,configMonoidAuthorName          :: !(Maybe Text)
+    -- ^ Author's name.
+    ,configMonoidScmInit             :: !(Maybe SCM)
+    -- ^ Initialize SCM (e.g. git init) when making new projects?
     }
   deriving Show
 
@@ -523,6 +535,9 @@ instance Monoid ConfigMonoid where
     , configMonoidConcurrentTests = Nothing
     , configMonoidLocalBinPath = Nothing
     , configMonoidImageOpts = mempty
+    , configMonoidAuthorEmail = mempty
+    , configMonoidAuthorName = mempty
+    , configMonoidScmInit = Nothing
     }
   mappend l r = ConfigMonoid
     { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r
@@ -544,6 +559,9 @@ instance Monoid ConfigMonoid where
     , configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r
     , configMonoidLocalBinPath = configMonoidLocalBinPath l <|> configMonoidLocalBinPath r
     , configMonoidImageOpts = configMonoidImageOpts l <> configMonoidImageOpts r
+    , configMonoidAuthorName = configMonoidAuthorName l <|> configMonoidAuthorName r
+    , configMonoidAuthorEmail = configMonoidAuthorEmail l <|> configMonoidAuthorEmail r
+    , configMonoidScmInit = configMonoidScmInit l <|> configMonoidScmInit r
     }
 
 instance FromJSON (ConfigMonoid, [JSONWarning]) where
@@ -574,6 +592,9 @@ parseConfigMonoidJSON obj = do
     configMonoidConcurrentTests <- obj ..:? "concurrent-tests"
     configMonoidLocalBinPath <- obj ..:? "local-bin-path"
     configMonoidImageOpts <- jsonSubWarnings (obj ..:? "image" ..!= mempty)
+    configMonoidAuthorName <- obj ..:? authorNameKey
+    configMonoidAuthorEmail <- obj ..:? authorEmailKey
+    configMonoidScmInit <- obj ..:? scmInitKey
     return ConfigMonoid {..}
 
 -- | Newtype for non-orphan FromJSON instance.
@@ -849,3 +870,29 @@ packageEntryCurrDir = PackageEntry
     , peLocation = PLFilePath "."
     , peSubdirs = []
     }
+
+-- | A software control system.
+data SCM = Git
+  deriving (Show)
+
+instance FromJSON SCM where
+    parseJSON v = do
+        s <- parseJSON v
+        case s of
+            "git" -> return Git
+            _ -> fail ("Unknown or unsupported SCM: " <> s)
+
+instance ToJSON SCM where
+    toJSON Git = toJSON ("git" :: Text)
+
+-- | Key used for the YAML file and templates.
+authorEmailKey :: Text
+authorEmailKey = "author-email"
+
+-- | Key used for the YAML file and templates.
+authorNameKey :: Text
+authorNameKey = "author-name"
+
+-- | Key used for the YAML file and templates.
+scmInitKey :: Text
+scmInitKey = "scm-init"

src/System/Process/Run.hs

@@ -11,7 +11,8 @@
 module System.Process.Run
     (runIn
     ,callProcess
-    ,callProcess')
+    ,callProcess'
+    ,ProcessExitedUnsuccessfully)
     where
 
 import           Control.Exception.Lifted