{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}

{-|
Module      : Headroom.Command.Init
Description : Handler for the @init@ command
Copyright   : (c) 2019-2020 Vaclav Svejcar
License     : BSD-3-Clause
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

Module representing the @init@ command, responsible for generating all the
required files (configuration, templates) for the given project, which are then
required by the @run@ or @gen@ commands.
-}

module Headroom.Command.Init
  ( Env(..)
  , Paths(..)
  , commandInit
  , doesAppConfigExist
  , findSupportedFileTypes
  )
where

import           Headroom.Command.Utils         ( bootstrap )
import           Headroom.Configuration         ( makeHeadersConfig
                                                , parseConfiguration
                                                )
import           Headroom.Data.Has              ( Has(..) )
import           Headroom.Embedded              ( configFileStub
                                                , defaultConfig
                                                , licenseTemplate
                                                )
import           Headroom.FileSystem            ( createDirectory
                                                , doesFileExist
                                                , fileExtension
                                                , findFiles
                                                )
import           Headroom.FileType              ( fileTypeByExt )
import           Headroom.Meta                  ( TemplateType )
import           Headroom.Serialization         ( prettyPrintYAML )
import           Headroom.Template              ( Template(..) )
import           Headroom.Types                 ( ApplicationError(..)
                                                , CommandInitError(..)
                                                , CommandInitOptions(..)
                                                , FileType(..)
                                                , LicenseType(..)
                                                , PartialConfiguration(..)
                                                )
import           Headroom.UI                    ( Progress(..)
                                                , zipWithProgress
                                                )
import           RIO
import qualified RIO.Char                      as C
import           RIO.FilePath                   ( (</>) )
import qualified RIO.List                      as L
import qualified RIO.Map                       as M
import qualified RIO.NonEmpty                  as NE
import qualified RIO.Text                      as T
import qualified RIO.Text.Partial              as TP



-- | /RIO/ Environment for the @init@ command.
data Env = Env
  { Env -> LogFunc
envLogFunc     :: !LogFunc
  , Env -> CommandInitOptions
envInitOptions :: !CommandInitOptions
  , Env -> Paths
envPaths       :: !Paths
  }

-- | Paths to various locations of file system.
data Paths = Paths
  { Paths -> FilePath
pConfigFile   :: !FilePath
  , Paths -> FilePath
pTemplatesDir :: !FilePath
  }

instance HasLogFunc Env where
  logFuncL :: (LogFunc -> f LogFunc) -> Env -> f Env
logFuncL = (Env -> LogFunc) -> (Env -> LogFunc -> Env) -> Lens' Env LogFunc
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Env -> LogFunc
envLogFunc (\x :: Env
x y :: LogFunc
y -> Env
x { envLogFunc :: LogFunc
envLogFunc = LogFunc
y })

instance Has CommandInitOptions Env where
  hasLens :: (CommandInitOptions -> f CommandInitOptions) -> Env -> f Env
hasLens = (Env -> CommandInitOptions)
-> (Env -> CommandInitOptions -> Env)
-> Lens' Env CommandInitOptions
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Env -> CommandInitOptions
envInitOptions (\x :: Env
x y :: CommandInitOptions
y -> Env
x { envInitOptions :: CommandInitOptions
envInitOptions = CommandInitOptions
y })

instance Has Paths Env where
  hasLens :: (Paths -> f Paths) -> Env -> f Env
hasLens = (Env -> Paths) -> (Env -> Paths -> Env) -> Lens' Env Paths
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Env -> Paths
envPaths (\x :: Env
x y :: Paths
y -> Env
x { envPaths :: Paths
envPaths = Paths
y })

--------------------------------------------------------------------------------

env' :: CommandInitOptions -> LogFunc -> IO Env
env' :: CommandInitOptions -> LogFunc -> IO Env
env' opts :: CommandInitOptions
opts logFunc :: LogFunc
logFunc = do
  let paths :: Paths
paths = $WPaths :: FilePath -> FilePath -> Paths
Paths { 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 -> CommandInitOptions -> Paths -> Env
Env { envLogFunc :: LogFunc
envLogFunc = LogFunc
logFunc, envInitOptions :: CommandInitOptions
envInitOptions = CommandInitOptions
opts, envPaths :: Paths
envPaths = Paths
paths }

-- | Handler for @init@ command.
commandInit :: CommandInitOptions -- ^ @init@ command options
            -> IO ()              -- ^ execution result
commandInit :: CommandInitOptions -> IO ()
commandInit opts :: CommandInitOptions
opts = (LogFunc -> IO Env) -> Bool -> RIO Env () -> IO ()
forall env a. (LogFunc -> IO env) -> Bool -> RIO env a -> IO a
bootstrap (CommandInitOptions -> LogFunc -> IO Env
env' CommandInitOptions
opts) Bool
False (RIO Env () -> IO ()) -> RIO Env () -> IO ()
forall a b. (a -> b) -> a -> b
$ RIO Env Bool
forall env. (HasLogFunc env, Has Paths 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.
(Has CommandInitOptions env, HasLogFunc env) =>
RIO env [FileType]
findSupportedFileTypes
    RIO Env ()
forall env. (HasLogFunc env, Has Paths env) => RIO env ()
makeTemplatesDir
    [FileType] -> RIO Env ()
forall env.
(Has CommandInitOptions env, HasLogFunc env, Has Paths env) =>
[FileType] -> RIO env ()
createTemplates [FileType]
fileTypes
    RIO Env ()
forall env.
(Has CommandInitOptions env, HasLogFunc env, Has Paths env) =>
RIO env ()
createConfigFile
  True -> do
    Paths
paths <- RIO Env Paths
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
    ApplicationError -> RIO Env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ApplicationError -> RIO Env ()) -> ApplicationError -> RIO Env ()
forall a b. (a -> b) -> a -> b
$ CommandInitError -> ApplicationError
CommandInitError (FilePath -> CommandInitError
AppConfigAlreadyExists (FilePath -> CommandInitError) -> FilePath -> CommandInitError
forall a b. (a -> b) -> a -> b
$ Paths -> FilePath
pConfigFile Paths
paths)

-- | Recursively scans provided source paths for known file types for which
-- templates can be generated.
findSupportedFileTypes :: (Has CommandInitOptions env, HasLogFunc env)
                       => RIO env [FileType]
findSupportedFileTypes :: RIO env [FileType]
findSupportedFileTypes = do
  CommandInitOptions
opts           <- RIO env CommandInitOptions
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
  PartialHeadersConfig
pHeadersConfig <- PartialConfiguration -> PartialHeadersConfig
pcLicenseHeaders (PartialConfiguration -> PartialHeadersConfig)
-> RIO env PartialConfiguration -> RIO env PartialHeadersConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> RIO env PartialConfiguration
forall (m :: * -> *).
MonadThrow m =>
ByteString -> m PartialConfiguration
parseConfiguration ByteString
forall a. IsString a => a
defaultConfig
  HeadersConfig
headersConfig  <- PartialHeadersConfig -> RIO env HeadersConfig
forall (m :: * -> *).
MonadThrow m =>
PartialHeadersConfig -> m HeadersConfig
makeHeadersConfig PartialHeadersConfig
pHeadersConfig
  [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))
                     (CommandInitOptions -> [FilePath]
cioSourcePaths CommandInitOptions
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
>=> HeadersConfig -> Text -> Maybe FileType
fileTypeByExt HeadersConfig
headersConfig)
                            ([[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
    [] -> ApplicationError -> RIO env [FileType]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ApplicationError -> RIO env [FileType])
-> ApplicationError -> RIO env [FileType]
forall a b. (a -> b) -> a -> b
$ CommandInitError -> ApplicationError
CommandInitError CommandInitError
NoProvidedSourcePaths
    _  -> 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 :: (Has CommandInitOptions env, HasLogFunc env, Has Paths env)
                => [FileType]
                -> RIO env ()
createTemplates :: [FileType] -> RIO env ()
createTemplates fileTypes :: [FileType]
fileTypes = do
  CommandInitOptions
opts       <- RIO env CommandInitOptions
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
  Paths {..} <- RIO env Paths
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
  ((Progress, (LicenseType, FileType)) -> RIO env ())
-> [(Progress, (LicenseType, FileType))] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(p :: Progress
p, lf :: (LicenseType, FileType)
lf) -> FilePath -> (LicenseType, FileType) -> Progress -> RIO env ()
forall env.
HasLogFunc env =>
FilePath -> (LicenseType, FileType) -> Progress -> RIO env ()
createTemplate FilePath
pTemplatesDir (LicenseType, FileType)
lf Progress
p)
        ([(LicenseType, FileType)] -> [(Progress, (LicenseType, FileType))]
forall a. [a] -> [(Progress, a)]
zipWithProgress ([(LicenseType, FileType)]
 -> [(Progress, (LicenseType, FileType))])
-> [(LicenseType, FileType)]
-> [(Progress, (LicenseType, FileType))]
forall a b. (a -> b) -> a -> b
$ (FileType -> (LicenseType, FileType))
-> [FileType] -> [(LicenseType, FileType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CommandInitOptions -> LicenseType
cioLicenseType CommandInitOptions
opts, ) [FileType]
fileTypes)

createTemplate :: (HasLogFunc env)
               => FilePath
               -> (LicenseType, FileType)
               -> Progress
               -> RIO env ()
createTemplate :: FilePath -> (LicenseType, FileType) -> Progress -> RIO env ()
createTemplate templatesDir :: FilePath
templatesDir (licenseType :: LicenseType
licenseType, 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
$ Template TemplateType => NonEmpty Text
forall t. Template t => NonEmpty Text
templateExtensions @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  = LicenseType -> FileType -> Text
forall a. IsString a => LicenseType -> FileType -> a
licenseTemplate LicenseType
licenseType FileType
fileType
  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 :: (Has CommandInitOptions env, HasLogFunc env, Has Paths env)
                 => RIO env ()
createConfigFile :: RIO env ()
createConfigFile = do
  CommandInitOptions
opts         <- RIO env CommandInitOptions
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
  p :: Paths
p@Paths {..} <- RIO env Paths
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
  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
pConfigFile
  FilePath -> Text -> RIO env ()
forall (m :: * -> *). MonadIO m => FilePath -> Text -> m ()
writeFileUtf8 FilePath
pConfigFile (CommandInitOptions -> Paths -> Text
configuration CommandInitOptions
opts Paths
p)
 where
  configuration :: CommandInitOptions -> Paths -> Text
configuration opts :: CommandInitOptions
opts paths :: Paths
paths =
    let withSourcePaths :: Text -> Text
withSourcePaths = Text -> Text -> Text -> Text
TP.replace
          "source-paths: []"
          (Text -> [FilePath] -> Text
forall a. ToJSON a => Text -> a -> Text
toYamlList "source-paths" ([FilePath] -> Text) -> [FilePath] -> Text
forall a b. (a -> b) -> a -> b
$ CommandInitOptions -> [FilePath]
cioSourcePaths CommandInitOptions
opts)
        withTemplatePaths :: Text -> Text
withTemplatePaths = Text -> Text -> Text -> Text
TP.replace
          "template-paths: []"
          (Text -> [FilePath] -> Text
forall a. ToJSON a => Text -> a -> Text
toYamlList "template-paths" [Paths -> FilePath
pTemplatesDir Paths
paths])
    in  Text -> Text
withTemplatePaths (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
withSourcePaths (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
forall a. IsString a => a
configFileStub
  toYamlList :: Text -> a -> Text
toYamlList field :: Text
field list :: a
list =
    Text -> Text
T.stripEnd (Text -> Text) -> (Map Text a -> Text) -> Map Text a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text a -> Text
forall a. ToJSON a => a -> Text
prettyPrintYAML (Map Text a -> Text) -> Map Text a -> Text
forall a b. (a -> b) -> a -> b
$ [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text
field :: Text, a
list)]

-- | Checks whether application config file already exists.
doesAppConfigExist :: (HasLogFunc env, Has Paths env) => RIO env Bool
doesAppConfigExist :: RIO env Bool
doesAppConfigExist = do
  Paths {..} <- RIO env Paths
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
  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
pConfigFile

-- | Creates directory for template files.
makeTemplatesDir :: (HasLogFunc env, Has Paths env) => RIO env ()
makeTemplatesDir :: RIO env ()
makeTemplatesDir = do
  Paths {..} <- RIO env Paths
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
  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
pTemplatesDir
  FilePath -> RIO env ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
createDirectory FilePath
pTemplatesDir