{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ViewPatterns #-}
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 System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, listDirectory)
import Summoner.Ansi (errorMessage, infoMessage)
import Summoner.CLI (Command (..), NewOpts (..), ShowOpts (..), getFinalConfig, runScript, summon)
import Summoner.Decision (Decision (..))
import Summoner.Default (defaultConfigFile)
import Summoner.GhcVer (showGhcVer)
import Summoner.License (License (..), LicenseName, fetchLicense, parseLicenseName,
showLicenseWithDesc)
import Summoner.Project (initializeProject)
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, 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)
summonTui :: IO ()
summonTui = summon Meta.version runTuiCommand
runTuiCommand :: Command -> IO ()
runTuiCommand = \case
New opts -> summonTuiNew opts
Script opts -> runScript opts
ShowInfo opts -> summonTuiShow opts
summonTuiNew :: NewOpts -> IO ()
summonTuiNew newOpts@NewOpts{..} = do
finalConfig <- getFinalConfig newOpts
configFilePath <- findConfigFile
let initialKit = configToSummonKit
newOptsProjectName
newOptsOffline
configFilePath
finalConfig
skForm <- runTuiNew initialKit
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
runTuiNew :: SummonKit -> IO (KitForm e)
runTuiNew kit = do
filesAndDirs <- listDirectory =<< getCurrentDirectory
dirs <- filterM doesDirectoryExist filesAndDirs
runApp (appNew dirs) (summonFormValidation dirs $ mkForm kit)
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 []) ->
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)
VtyEvent (V.EvKey (V.KChar ' ') []) -> case getCurrentFocus s of
Nothing -> withFormDef ev s
Just field -> handleCheckboxActivation ev s field
MouseDown n _ _ _ -> handleCheckboxActivation ev s n
VtyEvent (V.EvKey (V.KChar '\t') []) -> loopWhileInactive ev s
VtyEvent (V.EvKey V.KBackTab []) -> loopWhileInactive ev s
_ -> 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
handleCheckboxActivation
:: BrickEvent SummonForm e
-> KitForm e
-> SummonForm
-> EventM SummonForm (Next (KitForm e))
handleCheckboxActivation ev form = \case
StackField -> withForm ev form mkNewForm
GitHubEnable -> withForm ev form mkNewForm
GitHubDisable -> withForm ev form mkNewForm
GitHubNoUpload -> withForm ev form mkNewForm
_ -> withFormDef ev form
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
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 21 $ borderLabel "Project Structure" $ vBox
[ withAttr "tree" $ txt $ renderWidgetTree kit
, 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"
]
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" 30 0 (map showGhcVer universe)
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 <- fetchLicense 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
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
runSimpleApp :: Ord n => Widget n -> IO ()
runSimpleApp w = runApp (mkSimpleApp w) ()
mkSimpleApp :: Widget n -> App () e n
mkSimpleApp w = (simpleApp w)
{ appAttrMap = const theMap
}
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)
, ("red-fg", fg V.brightRed)
, (borderAttr, fg V.cyan)
, ("tree", fg V.cyan)
]