{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Headroom.Command.Init
( commandInit
, doesAppConfigExist
, findSupportedFileTypes
)
where
import Headroom.AppConfig ( AppConfig(..)
, prettyPrintAppConfig
)
import Headroom.Command.Init.Env
import Headroom.Command.Shared ( bootstrap )
import Headroom.Embedded ( licenseTemplate )
import Headroom.FileSystem ( fileExtension
, findFiles
)
import Headroom.FileType ( FileType
, fileTypeByExt
)
import Headroom.Global ( TemplateType )
import Headroom.License ( License(..) )
import Headroom.Template ( templateExtensions )
import Headroom.Types ( HeadroomError(..)
, InitCommandError(..)
)
import Headroom.UI.Progress ( Progress(..)
, zipWithProgress
)
import RIO
import qualified RIO.Char as C
import RIO.Directory ( createDirectory
, doesFileExist
, getCurrentDirectory
)
import RIO.FilePath ( (</>) )
import qualified RIO.HashMap as HM
import qualified RIO.List as L
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
env' :: InitOptions -> LogFunc -> IO Env
env' :: InitOptions -> LogFunc -> IO Env
env' opts :: InitOptions
opts logFunc :: LogFunc
logFunc = do
FilePath
currentDir <- IO FilePath
forall (m :: * -> *). MonadIO m => m FilePath
getCurrentDirectory
let paths :: Paths
paths = $WPaths :: FilePath -> FilePath -> FilePath -> Paths
Paths { pCurrentDir :: FilePath
pCurrentDir = FilePath
currentDir
, pConfigFile :: FilePath
pConfigFile = ".headroom.yaml"
, pTemplatesDir :: FilePath
pTemplatesDir = "headroom-templates"
}
Env -> IO Env
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env -> IO Env) -> Env -> IO Env
forall a b. (a -> b) -> a -> b
$ $WEnv :: LogFunc -> InitOptions -> Paths -> Env
Env { envLogFunc :: LogFunc
envLogFunc = LogFunc
logFunc, envInitOptions :: InitOptions
envInitOptions = InitOptions
opts, envPaths :: Paths
envPaths = Paths
paths }
commandInit :: InitOptions
-> IO ()
commandInit :: InitOptions -> IO ()
commandInit opts :: InitOptions
opts = (LogFunc -> IO Env) -> Bool -> RIO Env () -> IO ()
forall env a. (LogFunc -> IO env) -> Bool -> RIO env a -> IO a
bootstrap (InitOptions -> LogFunc -> IO Env
env' InitOptions
opts) Bool
False (RIO Env () -> IO ()) -> RIO Env () -> IO ()
forall a b. (a -> b) -> a -> b
$ RIO Env Bool
forall env. (HasLogFunc env, HasPaths env) => RIO env Bool
doesAppConfigExist RIO Env Bool -> (Bool -> RIO Env ()) -> RIO Env ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
False -> do
[FileType]
fileTypes <- RIO Env [FileType]
forall env.
(HasInitOptions env, HasLogFunc env) =>
RIO env [FileType]
findSupportedFileTypes
RIO Env ()
forall env. (HasLogFunc env, HasPaths env) => RIO env ()
makeTemplatesDir
[FileType] -> RIO Env ()
forall env.
(HasInitOptions env, HasLogFunc env, HasPaths env) =>
[FileType] -> RIO env ()
createTemplates [FileType]
fileTypes
RIO Env ()
forall env.
(HasInitOptions env, HasLogFunc env, HasPaths env) =>
RIO env ()
createConfigFile
True -> HeadroomError -> RIO Env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HeadroomError -> RIO Env ()) -> HeadroomError -> RIO Env ()
forall a b. (a -> b) -> a -> b
$ InitCommandError -> HeadroomError
InitCommandError InitCommandError
AppConfigAlreadyExists
findSupportedFileTypes :: (HasInitOptions env, HasLogFunc env)
=> RIO env [FileType]
findSupportedFileTypes :: RIO env [FileType]
findSupportedFileTypes = do
InitOptions
opts <- Getting InitOptions env InitOptions -> RIO env InitOptions
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting InitOptions env InitOptions
forall env. HasInitOptions env => Lens' env InitOptions
initOptionsL
[FileType]
fileTypes <- do
[[FilePath]]
allFiles <- (FilePath -> RIO env [FilePath])
-> [FilePath] -> RIO env [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\path :: FilePath
path -> FilePath -> (FilePath -> Bool) -> RIO env [FilePath]
forall (m :: * -> *).
MonadIO m =>
FilePath -> (FilePath -> Bool) -> m [FilePath]
findFiles FilePath
path (Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
True)) (InitOptions -> [FilePath]
ioSourcePaths InitOptions
opts)
let allFileTypes :: [Maybe FileType]
allFileTypes = (FilePath -> Maybe FileType) -> [FilePath] -> [Maybe FileType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> Maybe Text
fileExtension (FilePath -> Maybe Text)
-> (Text -> Maybe FileType) -> FilePath -> Maybe FileType
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> Maybe FileType
fileTypeByExt) ([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]]
allFiles)
[FileType] -> RIO env [FileType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileType] -> RIO env [FileType])
-> [FileType] -> RIO env [FileType]
forall a b. (a -> b) -> a -> b
$ [FileType] -> [FileType]
forall a. Eq a => [a] -> [a]
L.nub ([FileType] -> [FileType])
-> ([Maybe FileType] -> [FileType])
-> [Maybe FileType]
-> [FileType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe FileType] -> [FileType]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FileType] -> [FileType]) -> [Maybe FileType] -> [FileType]
forall a b. (a -> b) -> a -> b
$ [Maybe FileType]
allFileTypes
case [FileType]
fileTypes of
[] -> HeadroomError -> RIO env [FileType]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HeadroomError -> RIO env [FileType])
-> HeadroomError -> RIO env [FileType]
forall a b. (a -> b) -> a -> b
$ InitCommandError -> HeadroomError
InitCommandError InitCommandError
NoSourcePaths
_ -> do
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
$ "Found supported file types: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [FileType] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow [FileType]
fileTypes
[FileType] -> RIO env [FileType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FileType]
fileTypes
createTemplates :: (HasInitOptions env, HasLogFunc env, HasPaths env)
=> [FileType]
-> RIO env ()
createTemplates :: [FileType] -> RIO env ()
createTemplates fileTypes :: [FileType]
fileTypes = do
InitOptions
opts <- Getting InitOptions env InitOptions -> RIO env InitOptions
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting InitOptions env InitOptions
forall env. HasInitOptions env => Lens' env InitOptions
initOptionsL
Paths
paths <- Getting Paths env Paths -> RIO env Paths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Paths env Paths
forall env. HasPaths env => Lens' env Paths
pathsL
let templatesDir :: FilePath
templatesDir = Paths -> FilePath
pCurrentDir Paths
paths FilePath -> FilePath -> FilePath
</> Paths -> FilePath
pTemplatesDir Paths
paths
((Progress, License) -> RIO env ())
-> [(Progress, License)] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(p :: Progress
p, l :: License
l) -> FilePath -> License -> Progress -> RIO env ()
forall env.
HasLogFunc env =>
FilePath -> License -> Progress -> RIO env ()
createTemplate FilePath
templatesDir License
l Progress
p)
([License] -> [(Progress, License)]
forall a. [a] -> [(Progress, a)]
zipWithProgress ([License] -> [(Progress, License)])
-> [License] -> [(Progress, License)]
forall a b. (a -> b) -> a -> b
$ (FileType -> License) -> [FileType] -> [License]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LicenseType -> FileType -> License
License (InitOptions -> LicenseType
ioLicenseType InitOptions
opts)) [FileType]
fileTypes)
createTemplate :: (HasLogFunc env)
=> FilePath
-> License
-> Progress
-> RIO env ()
createTemplate :: FilePath -> License -> Progress -> RIO env ()
createTemplate templatesDir :: FilePath
templatesDir license :: License
license@(License _ fileType :: FileType
fileType) progress :: Progress
progress = do
let extension :: Text
extension = NonEmpty Text -> Text
forall a. NonEmpty a -> a
NE.head (NonEmpty Text -> Text) -> NonEmpty Text -> Text
forall a b. (a -> b) -> a -> b
$ Proxy TemplateType -> NonEmpty Text
forall t (proxy :: * -> *). Template t => proxy t -> NonEmpty Text
templateExtensions (Proxy TemplateType
forall k (t :: k). Proxy t
Proxy :: Proxy TemplateType)
file :: FilePath
file = ((Char -> Char) -> FilePath -> FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
C.toLower (FilePath -> FilePath)
-> (FileType -> FilePath) -> FileType -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileType -> FilePath
forall a. Show a => a -> FilePath
show (FileType -> FilePath) -> FileType -> FilePath
forall a b. (a -> b) -> a -> b
$ FileType
fileType) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> "." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
extension
filePath :: FilePath
filePath = FilePath
templatesDir FilePath -> FilePath -> FilePath
</> FilePath
file
template :: Text
template = License -> Text
forall a. IsString a => License -> a
licenseTemplate License
license
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
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
[Progress -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Progress
progress, " Creating template file in ", FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
filePath]
FilePath -> Text -> RIO env ()
forall (m :: * -> *). MonadIO m => FilePath -> Text -> m ()
writeFileUtf8 FilePath
filePath Text
template
createConfigFile :: (HasInitOptions env, HasLogFunc env, HasPaths env)
=> RIO env ()
createConfigFile :: RIO env ()
createConfigFile = do
InitOptions
opts <- Getting InitOptions env InitOptions -> RIO env InitOptions
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting InitOptions env InitOptions
forall env. HasInitOptions env => Lens' env InitOptions
initOptionsL
Paths
paths <- Getting Paths env Paths -> RIO env Paths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Paths env Paths
forall env. HasPaths env => Lens' env Paths
pathsL
let filePath :: FilePath
filePath = Paths -> FilePath
pCurrentDir Paths
paths FilePath -> FilePath -> FilePath
</> Paths -> FilePath
pConfigFile Paths
paths
content :: Text
content = AppConfig -> Text
prettyPrintAppConfig (AppConfig -> Text) -> AppConfig -> Text
forall a b. (a -> b) -> a -> b
$ InitOptions -> Paths -> AppConfig
appConfig InitOptions
opts Paths
paths
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
$ "Creating YAML config file in " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
filePath
FilePath -> Text -> RIO env ()
forall (m :: * -> *). MonadIO m => FilePath -> Text -> m ()
writeFileUtf8 FilePath
filePath Text
content
where
variables :: HashMap Text Text
variables = [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
[ ("author" , "John Smith")
, ("email" , "john.smith@example.com")
, ("project", "My project")
, ("year" , "2020")
]
appConfig :: InitOptions -> Paths -> AppConfig
appConfig opts :: InitOptions
opts paths :: Paths
paths = AppConfig
forall a. Monoid a => a
mempty { acSourcePaths :: [FilePath]
acSourcePaths = InitOptions -> [FilePath]
ioSourcePaths InitOptions
opts
, acTemplatePaths :: [FilePath]
acTemplatePaths = [Paths -> FilePath
pTemplatesDir Paths
paths]
, acVariables :: HashMap Text Text
acVariables = HashMap Text Text
variables
}
doesAppConfigExist :: (HasLogFunc env, HasPaths env) => RIO env Bool
doesAppConfigExist :: RIO env Bool
doesAppConfigExist = do
Paths
paths <- Getting Paths env Paths -> RIO env Paths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Paths env Paths
forall env. HasPaths env => Lens' env Paths
pathsL
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo "Verifying that there's no existing Headroom configuration..."
FilePath -> RIO env Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist (FilePath -> RIO env Bool) -> FilePath -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Paths -> FilePath
pCurrentDir Paths
paths FilePath -> FilePath -> FilePath
</> Paths -> FilePath
pConfigFile Paths
paths
makeTemplatesDir :: (HasLogFunc env, HasPaths env) => RIO env ()
makeTemplatesDir :: RIO env ()
makeTemplatesDir = do
Paths
paths <- Getting Paths env Paths -> RIO env Paths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Paths env Paths
forall env. HasPaths env => Lens' env Paths
pathsL
let templatesDir :: FilePath
templatesDir = Paths -> FilePath
pCurrentDir Paths
paths FilePath -> FilePath -> FilePath
</> Paths -> FilePath
pTemplatesDir Paths
paths
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
$ "Creating directory for templates in " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
templatesDir
FilePath -> RIO env ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
createDirectory FilePath
templatesDir