{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Summoner.CLI
(
Command (..)
, NewOpts (..)
, ShowOpts (..)
, summon
, summonCli
, runScript
, getFinalConfig
) where
import Data.Version (Version, showVersion)
import Development.GitRev (gitCommitDate, gitDirty, gitHash)
import NeatInterpolation (text)
import Options.Applicative (Parser, ParserInfo, ParserPrefs, argument, command, customExecParser,
flag, fullDesc, help, helpLongEquals, helper, info, infoFooter,
infoHeader, infoOption, long, maybeReader, metavar, option, optional,
prefs, progDesc, short, showHelpOnEmpty, strArgument, strOption,
subparser, subparserInline, switch, value)
import Options.Applicative.Help.Chunk (stringChunk)
import Relude.Extra.Enum (universe)
import Relude.Extra.Validation (Validation (..))
import Shellmet (($?), ($|))
import System.Directory (doesFileExist)
import System.Info (os)
import Summoner.Ansi (blueCode, boldCode, errorMessage, infoMessage, redCode, resetCode,
successMessage, warningMessage)
import Summoner.Config (Config, ConfigP (..), PartialConfig, defaultConfig, finalise,
loadFileConfig)
import Summoner.CustomPrelude (CustomPrelude (..))
import Summoner.Decision (Decision (..))
import Summoner.Default (defaultConfigFile, defaultGHC)
import Summoner.GhcVer (GhcVer, ghcTable, parseGhcVer)
import Summoner.License (License (..), LicenseName (..), fetchLicense, parseLicenseName,
showLicenseWithDesc)
import Summoner.Project (generateProject)
import Summoner.Settings (Tool, parseTool)
import Summoner.Template.Script (scriptFile)
import Summoner.Text (endLine)
import qualified Data.Text as T
import qualified Paths_summoner as Meta (version)
summon :: Version -> (Command -> IO ()) -> IO ()
summon version performCommand =
customExecParser summonerParserPrefs (cliParser version) >>= performCommand
where
summonerParserPrefs :: ParserPrefs
summonerParserPrefs = prefs
$ helpLongEquals
<> showHelpOnEmpty
<> subparserInline
summonCli :: IO ()
summonCli = summon Meta.version runCliCommand
runCliCommand :: Command -> IO ()
runCliCommand = \case
New opts -> runNew opts
Script opts -> runScript opts
ShowInfo opts -> runShow opts
runShow :: ShowOpts -> IO ()
runShow = \case
GhcList -> showBulletList id ghcTable
LicenseList Nothing -> showBulletList @LicenseName showLicenseWithDesc universe
LicenseList (Just name) ->
case parseLicenseName (toText name) of
Nothing -> do
errorMessage "This wasn't a valid choice."
infoMessage "Here is the list of supported licenses:"
showBulletList @LicenseName show universe
Just licenseName -> do
fetchedLicense <- fetchLicense licenseName
putTextLn $ unLicense fetchedLicense
where
showBulletList :: (a -> Text) -> [a] -> IO ()
showBulletList showT = mapM_ (infoMessage . T.append "➤ " . showT)
runScript :: ScriptOpts -> IO ()
runScript ScriptOpts{..} = do
let pathTxt = toText scriptOptsName
whenM (doesFileExist scriptOptsName) $ do
errorMessage $ "File already exists: " <> pathTxt
exitFailure
let script = scriptFile scriptOptsGhc scriptOptsTool
writeFileText scriptOptsName script
unless (os == "mingw32") $
"chmod" ["+x", pathTxt]
successMessage $ "Successfully created script: " <> pathTxt
runNew :: NewOpts -> IO ()
runNew newOpts@NewOpts{..} = do
finalConfig <- getFinalConfig newOpts
generateProject newOptsOffline newOptsProjectName finalConfig
getFinalConfig :: NewOpts -> IO Config
getFinalConfig NewOpts{..} = do
fileConfig <- readFileConfig newOptsIgnoreFile newOptsConfigFile
gitConfig <- guessFromGit
let unionConfig = defaultConfig <> gitConfig <> fileConfig <> newOptsCliConfig
case finalise unionConfig of
Success c -> pure c
Failure msgs -> for_ msgs errorMessage >> exitFailure
where
guessFromGit :: IO PartialConfig
guessFromGit = do
gitOwner <- (Just <$> "git" $| ["config", "user.login"]) $? pure Nothing
gitName <- (Just <$> "git" $| ["config", "user.name"]) $? pure Nothing
gitEmail <- (Just <$> "git" $| ["config", "user.email"]) $? pure Nothing
pure $ defaultConfig
{ cOwner = Last gitOwner
, cFullName = Last gitName
, cEmail = Last gitEmail
}
readFileConfig :: Bool -> Maybe FilePath -> IO PartialConfig
readFileConfig ignoreFile maybeFile = if ignoreFile then pure mempty else do
(isDefault, file) <- case maybeFile of
Nothing -> (True,) <$> defaultConfigFile
Just x -> pure (False, x)
isFile <- doesFileExist file
if isFile then do
infoMessage $ "Configurations from " <> toText file <> " will be used."
loadFileConfig file
else if isDefault then do
fp <- toText <$> defaultConfigFile
warningMessage $ "Default config " <> fp <> " file is missing."
pure mempty
else do
errorMessage $ "Specified configuration file " <> toText file <> " is not found."
exitFailure
data Command
= New NewOpts
| Script ScriptOpts
| ShowInfo ShowOpts
data NewOpts = NewOpts
{ newOptsProjectName :: Text
, newOptsIgnoreFile :: Bool
, newOptsOffline :: Bool
, newOptsConfigFile :: Maybe FilePath
, newOptsCliConfig :: PartialConfig
}
data ScriptOpts = ScriptOpts
{ scriptOptsTool :: !Tool
, scriptOptsName :: !FilePath
, scriptOptsGhc :: !GhcVer
}
data ShowOpts
= GhcList
| LicenseList (Maybe String)
cliParser :: Version -> ParserInfo Command
cliParser version = modifyHeader
$ modifyFooter
$ info ( helper <*> versionP version <*> summonerP )
$ fullDesc
<> progDesc "Set up your own Haskell project"
versionP :: Version -> Parser (a -> a)
versionP version = infoOption (summonerVersion version)
$ long "version"
<> short 'v'
<> help "Show summoner's version"
summonerVersion :: Version -> String
summonerVersion version = toString
$ intercalate "\n"
$ [sVersion, sHash, sDate] ++ [sDirty | $(gitDirty)]
where
sVersion = blueCode <> boldCode <> "Summoner " <> "v" <> showVersion version <> resetCode
sHash = " ➤ " <> blueCode <> boldCode <> "Git revision: " <> resetCode <> $(gitHash)
sDate = " ➤ " <> blueCode <> boldCode <> "Commit date: " <> resetCode <> $(gitCommitDate)
sDirty = redCode <> "There are non-committed files." <> resetCode
summonerP :: Parser Command
summonerP = subparser
$ command "new" (info (helper <*> newP) $ progDesc "Create a new Haskell project")
<> command "script" (info (helper <*> scriptP) $ progDesc "Create a new Haskell script")
<> command "show" (info (helper <*> showP) $ progDesc "Show supported licenses or ghc versions")
showP :: Parser Command
showP = ShowInfo <$> subparser
( command "ghc" (info (helper <*> pure GhcList) $ progDesc "Show supported ghc versions")
<> command "license" (info (helper <*> licenseText) $ progDesc "Show supported licenses")
)
licenseText :: Parser ShowOpts
licenseText = LicenseList <$> optional
(strArgument (metavar "LICENSE_NAME" <> help "Show specific license text"))
scriptP :: Parser Command
scriptP = do
scriptOptsTool <- toolArgP
scriptOptsGhc <- ghcVerP
scriptOptsName <- strOption
$ long "name"
<> short 'n'
<> value "my_script"
<> metavar "FILE_NAME"
<> help "Name of the script file"
pure $ Script ScriptOpts{..}
toolArgP :: Parser Tool
toolArgP = argument
(maybeReader $ parseTool . toText)
(metavar "BUILD_TOOL")
ghcVerP :: Parser GhcVer
ghcVerP = option
(maybeReader $ parseGhcVer . toText)
( long "ghc"
<> short 'g'
<> value defaultGHC
<> metavar "GHC_VERSION"
<> help "Version of the compiler to be used for script"
)
newP :: Parser Command
newP = do
newOptsProjectName <- strArgument (metavar "PROJECT_NAME")
newOptsIgnoreFile <- ignoreFileP
noUpload <- noUploadP
newOptsOffline <- offlineP
newOptsConfigFile <- optional fileP
cabal <- cabalP
stack <- stackP
preludePack <- optional preludePackP
preludeMod <- optional preludeModP
with <- optional withP
without <- optional withoutP
pure $ New $ NewOpts
{ newOptsCliConfig = (maybeToMonoid $ with <> without)
{ cPrelude = Last $ CustomPrelude <$> preludePack <*> preludeMod
, cCabal = cabal
, cStack = stack
, cNoUpload = Any $ noUpload || newOptsOffline
}
, ..
}
targetsP :: Decision -> Parser PartialConfig
targetsP d = do
cGitHub <- githubP d
cTravis <- travisP d
cAppVey <- appVeyorP d
cPrivate <- privateP d
cLib <- libraryP d
cExe <- execP d
cTest <- testP d
cBench <- benchmarkP d
pure mempty
{ cGitHub = cGitHub
, cTravis = cTravis
, cAppVey = cAppVey
, cPrivate= cPrivate
, cLib = cLib
, cExe = cExe
, cTest = cTest
, cBench = cBench
}
githubP :: Decision -> Parser Decision
githubP d = flag Idk d
$ long "github"
<> short 'g'
<> help "GitHub integration"
travisP :: Decision -> Parser Decision
travisP d = flag Idk d
$ long "travis"
<> short 'c'
<> help "Travis CI integration"
appVeyorP :: Decision -> Parser Decision
appVeyorP d = flag Idk d
$ long "app-veyor"
<> short 'w'
<> help "AppVeyor CI integration"
privateP :: Decision -> Parser Decision
privateP d = flag Idk d
$ long "private"
<> short 'p'
<> help "Private repository"
libraryP :: Decision -> Parser Decision
libraryP d = flag Idk d
$ long "library"
<> short 'l'
<> help "Library folder"
execP :: Decision -> Parser Decision
execP d = flag Idk d
$ long "exec"
<> short 'e'
<> help "Executable target"
testP :: Decision -> Parser Decision
testP d = flag Idk d
$ long "test"
<> short 't'
<> help "Test target"
benchmarkP :: Decision -> Parser Decision
benchmarkP d = flag Idk d
$ long "benchmark"
<> short 'b'
<> help "Benchmarks"
withP :: Parser PartialConfig
withP = subparser $ mconcat
[ metavar "with [OPTIONS]"
, command "with" $ info (helper <*> targetsP Yes) (progDesc "Specify options to enable")
]
withoutP :: Parser PartialConfig
withoutP = subparser $ mconcat
[ metavar "without [OPTIONS]"
, command "without" $ info (helper <*> targetsP Nop) (progDesc "Specify options to disable")
]
ignoreFileP :: Parser Bool
ignoreFileP = switch $ long "ignore-config" <> help "Ignore configuration file"
noUploadP :: Parser Bool
noUploadP = switch $ long "no-upload" <> help "Do not upload to GitHub. Special case of the '--offline' flag."
offlineP :: Parser Bool
offlineP = switch
$ long "offline"
<> help "Offline mode: create project with 'All Rights Reserved' license and without uploading to GitHub."
fileP :: Parser FilePath
fileP = strOption
$ long "file"
<> short 'f'
<> metavar "FILENAME"
<> help "Path to the toml file with configurations. If not specified '~/.summoner.toml' will be used if present"
preludePackP :: Parser Text
preludePackP = strOption
$ long "prelude-package"
<> metavar "PACKAGE_NAME"
<> help "Name for the package of the custom prelude to use in the project"
preludeModP :: Parser Text
preludeModP = strOption
$ long "prelude-module"
<> metavar "MODULE_NAME"
<> help "Name for the module of the custom prelude to use in the project"
cabalP :: Parser Decision
cabalP = flag Idk Yes
$ long "cabal"
<> help "Cabal support for the project"
stackP :: Parser Decision
stackP = flag Idk Yes
$ long "stack"
<> help "Stack support for the project"
modifyHeader :: ParserInfo a -> ParserInfo a
modifyHeader p = p {infoHeader = stringChunk $ toString artHeader}
modifyFooter :: ParserInfo a -> ParserInfo a
modifyFooter p = p {infoFooter = stringChunk $ toString artFooter}
artHeader :: Text
artHeader = [text|
$endLine
___
╱ . ╲
│╲_/│ │
│ │ ╱│
___________________________________________________-' │
╱ │
╱ .-. │
│ ╱ ╲ │
│ │\_. │ Summoner — tool for creating Haskell projects │
│\│ │ ╱│ │
│ `-_-' │ ╱
│ │_____________________________________________╱
│ │
╲ ╱
`-_-'
|]
artFooter :: Text
artFooter = [text|
$endLine
, * +
+ o * ┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┓
* @ ╭─╮ . ________┃ ┃_______
╱| . │λ│ @ ' ╲ ┃ λ Haskell's summon scroll λ ┃ ╱
_╱ ╰─ ╰╥╯ O ╲ ┃ ┃ ╱
.─╲"╱. * ║ + ╱ ┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┛ ╲
╱ ( ) ╲_ ║ ╱__________) (_________╲
╲ ╲(')╲__(╱
╱╱`)╱ `╮ ║
`╲. ╱╱ ( │ ║
╲.╲╱ │ ║
`╰══════════╯
$endLine
|]