summoner-tui-2.0.0.0: src/Summoner/Tui.hs
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ViewPatterns #-}
{- |
Copyright: (c) 2018-2019 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>
TUI for the Summoner tool. See demo in the README.md file.
-}
module Summoner.Tui
( summonTui
) where
import Brick (App (..), AttrMap, BrickEvent (..), Widget, attrMap, continue, customMain, halt,
simpleApp, str, txt, vBox, withAttr, (<+>))
import Brick.Focus (focusRingCursor)
import Brick.Forms (allFieldsValid, focusedFormInputAttr, formFocus, formState, handleFormEvent,
invalidFormInputAttr, renderForm)
import Brick.Main (ViewportScroll, neverShowCursor, vScrollBy, viewportScroll)
import Brick.Types (EventM, Next, ViewportType (Vertical))
import Brick.Util (fg)
import Brick.Widgets.Border (borderAttr)
import Brick.Widgets.Center (center)
import Brick.Widgets.Core (emptyWidget, fill, hLimit, hLimitPercent, padTopBottom, strWrap, txtWrap,
vLimit, viewport)
import Brick.Widgets.Edit (editAttr, editFocusedAttr)
import Brick.Widgets.List (listSelectedAttr, listSelectedFocusedAttr)
import Lens.Micro ((.~), (^.))
import Relude.Extra.Enum (universe)
import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, listDirectory)
import Summoner.Ansi (errorMessage, infoMessage)
import Summoner.CLI (Command (..), NewOpts (..), ShowOpts (..), getCustomLicenseText,
getFinalConfig, runConfig, runScript, summon)
import Summoner.Config (ConfigP (cFiles))
import Summoner.Decision (Decision (..))
import Summoner.Default (defaultConfigFile)
import Summoner.GhcVer (ghcTable)
import Summoner.License (License (..), LicenseName, parseLicenseName, showLicenseWithDesc)
import Summoner.Mode (isNonInteractive)
import Summoner.Project (generateProjectNonInteractive, initializeProject)
import Summoner.Source (fetchSources)
import Summoner.Tui.Field (disabledAttr)
import Summoner.Tui.Form (KitForm, SummonForm (..), getCurrentFocus, isActive, mkForm, recreateForm)
import Summoner.Tui.Kit
import Summoner.Tui.Validation (ctrlD, formErrorMessages, handleAutofill, projectDescNewLine,
summonFormValidation)
import Summoner.Tui.Widget (borderLabel, listInBorder)
import qualified Brick (on)
import qualified Graphics.Vty as V
import qualified Paths_summoner_tui as Meta (version)
-- | Main function that parses @CLI@ arguments and runs @summoner@ in TUI mode.
summonTui :: IO ()
summonTui = summon Meta.version runTuiCommand
-- | Run TUI specific to each command.
runTuiCommand :: Command -> IO ()
runTuiCommand = \case
New opts -> summonTuiNew opts
ShowInfo opts -> summonTuiShow opts
Script opts -> runScript opts -- TODO: implement TUI for script command
Config opts -> runConfig opts
----------------------------------------------------------------------------
-- New command
----------------------------------------------------------------------------
{- | TUI for creating new project. Contains interactive elements like text input
fields or checkboxes to configure settings for new project.
-}
summonTuiNew :: NewOpts -> IO ()
summonTuiNew newOpts@NewOpts{..} = do
-- configure initial state for TUI application
finalConfig <- getFinalConfig newOpts
when (isNonInteractive newOptsInteractivity) $ do
generateProjectNonInteractive
newOptsConnectMode
newOptsProjectName
finalConfig
() <$ exitSuccess
files <- fetchSources newOptsConnectMode (cFiles finalConfig)
configFilePath <- findConfigFile
let initialKit = configToSummonKit
newOptsProjectName
newOptsConnectMode
configFilePath
files
finalConfig
-- run TUI app
skForm <- runTuiNew initialKit
-- perform actions depending on the final state
let kit = formState skForm
if allFieldsValid skForm && (kit ^. shouldSummon == Yes)
then finalSettings kit >>= initializeProject
else errorMessage "Aborting summoner"
where
findConfigFile :: IO (Maybe FilePath)
findConfigFile = if newOptsIgnoreFile
then pure Nothing
else case newOptsConfigFile of
Nothing -> defaultConfigFile >>= \file ->
ifM (doesFileExist file) (pure $ Just file) (pure Nothing)
justFile -> pure justFile
-- | Check content of current directory and create form after forming 'SummonKit'.
runTuiNew :: SummonKit -> IO (KitForm e)
runTuiNew kit = do
filesAndDirs <- listDirectory =<< getCurrentDirectory
dirs <- filterM doesDirectoryExist filesAndDirs
runApp (appNew dirs) (summonFormValidation dirs $ mkForm kit)
-- | Represents @new@ command app behaviour.
appNew :: [FilePath] -> App (KitForm e) e SummonForm
appNew dirs = App
{ appDraw = drawNew dirs
, appHandleEvent = \s ev -> if formState s ^. shouldSummon == Idk
then case ev of
VtyEvent (V.EvKey V.KEnter []) -> halt $ changeShouldSummon Yes s
VtyEvent (V.EvKey V.KEsc []) -> withForm ev s (changeShouldSummon Nop)
_ -> continue s
else case ev of
VtyEvent V.EvResize {} -> continue s
VtyEvent (V.EvKey V.KEnter [V.MMeta]) ->
withForm ev s (validateForm . projectDescNewLine)
VtyEvent (V.EvKey V.KEnter []) ->
if allFieldsValid s
then withForm ev s (changeShouldSummon Idk)
else continue s
VtyEvent (V.EvKey V.KEsc []) -> halt s
VtyEvent (V.EvKey (V.KChar 'd') [V.MCtrl]) ->
withForm ev s (validateForm . ctrlD)
-- Handle active/inactive checkboxes
VtyEvent (V.EvKey (V.KChar ' ') []) -> case getCurrentFocus s of
Nothing -> withFormDef ev s
Just field -> handleCheckboxActivation ev s field
-- Run handler for autofill actions
VtyEvent (V.EvKey key [])
| keyTriggersAutofill key
-> withForm ev s (validateForm . handleAutofill)
MouseDown n _ _ _ -> handleCheckboxActivation ev s n
-- Handle skip of deactivated checkboxes
VtyEvent (V.EvKey (V.KChar '\t') []) -> loopWhileInactive ev s
VtyEvent (V.EvKey V.KBackTab []) -> loopWhileInactive ev s
-- Default action
_ -> withFormDef ev s
, appChooseCursor = focusRingCursor formFocus
, appStartEvent = pure
, appAttrMap = const theMap
}
where
withForm ev s f = handleFormEvent ev s >>= continue . f
withFormDef ev s = withForm ev s validateForm
changeShouldSummon :: Decision -> KitForm e -> KitForm e
changeShouldSummon newShould f = mkForm $ formState f & shouldSummon .~ newShould
validateForm :: KitForm e -> KitForm e
validateForm = summonFormValidation dirs
mkNewForm :: KitForm e -> KitForm e
mkNewForm = recreateForm validateForm
-- Activate/Deactivate checkboxes depending on current field change
handleCheckboxActivation
:: BrickEvent SummonForm e
-> KitForm e
-> SummonForm
-> EventM SummonForm (Next (KitForm e))
handleCheckboxActivation ev form = \case
CabalField -> withForm ev form mkNewForm
StackField -> withForm ev form mkNewForm
GitHubEnable -> withForm ev form mkNewForm
GitHubDisable -> withForm ev form mkNewForm
GitHubNoUpload -> withForm ev form mkNewForm
_ -> withFormDef ev form
-- Handles form event until current element is active
loopWhileInactive
:: BrickEvent SummonForm e
-> KitForm e
-> EventM SummonForm (Next (KitForm e))
loopWhileInactive ev form = do
newForm <- handleFormEvent ev form
case getCurrentFocus newForm of
Nothing -> continue newForm
Just field -> if not $ isActive (formState newForm) field
then loopWhileInactive ev newForm
else continue newForm
-- Autofill is only triggered on characters and backspace keys.
keyTriggersAutofill :: V.Key -> Bool
keyTriggersAutofill (V.KChar _) = True
keyTriggersAutofill V.KBS = True
keyTriggersAutofill _ = False
-- | Draws the form for @new@ command.
drawNew :: [FilePath] -> KitForm e -> [Widget SummonForm]
drawNew dirs kitForm = case kit ^. shouldSummon of
Idk -> [confirmDialog]
_ -> [formWidget]
where
kit :: SummonKit
kit = formState kitForm
confirmDialog :: Widget SummonForm
confirmDialog = center $ hLimit 55 $ borderLabel "Confirm" $ padTopBottom 2 $ vBox
[ str "• Enter – Press Enter to create the project"
, str "• Esc – Or Esc to go back to settings"
]
formWidget :: Widget SummonForm
formWidget = vBox
[ form <+> tree
, status <+> help
]
form :: Widget SummonForm
form = borderLabel "Summon new project" (renderForm kitForm)
tree :: Widget SummonForm
tree = hLimitPercent 25 $ vLimit 22 $ borderLabel "Project Structure" $ vBox
[ withAttr "tree" $ txt $ renderWidgetTree kit
-- to fill all the space that widget should take.
, fill ' '
]
status :: Widget SummonForm
status = hLimitPercent 45 $
borderLabel "Status" $ vBox
[ informationBlock
, validationBlock
, configBlock
, fill ' '
]
where
informationBlock :: Widget SummonForm
informationBlock = case getCurrentFocus kitForm of
Just UserOwner -> infoTxt "GitHub username"
Just ProjectCat -> infoTxt "Comma-separated categories as used at Hackage"
Just Ghcs -> infoTxt "Space separated GHC versions"
_ -> emptyWidget
infoTxt :: Text -> Widget SummonForm
infoTxt = withAttr "blue-fg" . txtWrap . (<>) " ⓘ "
validationBlock :: Widget SummonForm
validationBlock = vBox $ case formErrorMessages dirs kitForm of
[] -> [withAttr "green-fg" $ str " ✔ Project configuration is valid"]
fields -> map (\msg -> withAttr "red-fg" $ strWrap $ " ☓ " ++ msg) fields
configBlock :: Widget SummonForm
configBlock = case kit ^. configFile of
Nothing -> emptyWidget
Just file -> infoTxt $ toText file <> " file is used"
help, helpBody :: Widget SummonForm
help = borderLabel "Help" (helpBody <+> fill ' ')
helpBody = vBox
[ str "• Enter : create the project"
, str "• Esc : quit"
, str "• Ctrl+d : remove input of the text field"
, str "• Arrows : up/down arrows to choose license"
, str "• Alt+Enter : switch to new line"
]
----------------------------------------------------------------------------
-- Show command
----------------------------------------------------------------------------
-- | Simply shows info about GHC versions or licenses in TUI.
summonTuiShow :: ShowOpts -> IO ()
summonTuiShow = \case
GhcList -> runTuiShowGhcVersions
LicenseList Nothing -> runTuiShowAllLicenses
LicenseList (Just name) -> runTuiShowLicense name
runTuiShowGhcVersions :: IO ()
runTuiShowGhcVersions = runSimpleApp drawGhcVersions
where
drawGhcVersions :: Widget ()
drawGhcVersions = listInBorder "Supported GHC versions" 60 0 ghcTable
runTuiShowAllLicenses :: IO ()
runTuiShowAllLicenses = runSimpleApp drawLicenseNames
where
drawLicenseNames :: Widget ()
drawLicenseNames = listInBorder "Supported licenses" 70 4 (map showLicenseWithDesc universe)
runTuiShowLicense :: String -> IO ()
runTuiShowLicense (toText -> name) = case parseLicenseName name of
Nothing -> do
errorMessage $ "Error parsing license name: " <> name
infoMessage "Use 'summon show license' command to see the list of all available licenses"
Just licenseName -> do
lc <- getCustomLicenseText licenseName
runApp (licenseApp licenseName lc) ()
where
licenseApp :: LicenseName -> License -> App () e ()
licenseApp licenseName lc = App
{ appDraw = drawScrollableLicense licenseName lc
, appStartEvent = pure
, appAttrMap = const theMap
, appChooseCursor = neverShowCursor
, appHandleEvent = \() event -> case event of
VtyEvent (V.EvKey V.KDown []) -> vScrollBy licenseScroll 1 >> continue ()
VtyEvent (V.EvKey V.KUp []) -> vScrollBy licenseScroll (-1) >> continue ()
VtyEvent (V.EvKey V.KEsc []) -> halt ()
_ -> continue ()
}
licenseScroll :: ViewportScroll ()
licenseScroll = viewportScroll ()
drawScrollableLicense :: LicenseName -> License -> () -> [Widget ()]
drawScrollableLicense licenseName (License lc) = const [ui]
where
ui :: Widget ()
ui = center
$ hLimit 80
$ borderLabel ("License: " ++ show licenseName)
$ viewport () Vertical
$ vBox
$ map (\t -> if t == "" then txt "\n" else txtWrap t)
$ lines lc
----------------------------------------------------------------------------
-- Internal
----------------------------------------------------------------------------
-- | Runs brick application with given start state.
runApp :: Ord n => App s e n -> s -> IO s
runApp app s = do
initialVty <- buildVty
customMain initialVty buildVty Nothing app s
where
buildVty :: IO V.Vty
buildVty = do
v <- V.mkVty =<< V.standardIOConfig
V.setMode (V.outputIface v) V.Mouse True
pure v
-- | Runs the app without any state.
runSimpleApp :: Ord n => Widget n -> IO ()
runSimpleApp w = runApp (mkSimpleApp w) ()
-- | Creates simple brick app that doesn't have state and just displays given 'Widget'.
mkSimpleApp :: Widget n -> App () e n
mkSimpleApp w = (simpleApp w)
{ appAttrMap = const theMap
}
-- | Styles, colours that are used across the app.
theMap :: AttrMap
theMap = attrMap V.defAttr
[ (editAttr, V.black `Brick.on` V.cyan)
, (editFocusedAttr, V.black `Brick.on` V.white)
, (invalidFormInputAttr, V.white `Brick.on` V.red)
, (focusedFormInputAttr, V.black `Brick.on` V.yellow)
, (listSelectedAttr, V.black `Brick.on` V.cyan)
, (listSelectedFocusedAttr, V.black `Brick.on` V.white)
, (disabledAttr, fg V.brightBlack)
, ("blue-fg", fg V.blue)
, ("green-fg", fg V.green)
, ("yellow-fg", fg V.yellow)
, ("red-fg", fg V.brightRed)
, (borderAttr, fg V.cyan)
, ("tree", fg V.cyan)
]