{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} module Panes.AddProj ( AddProjPane , initAddProj , isAddProjActive , projectInputResults ) where import Brick hiding ( Location ) import Brick.Focus import Brick.Forms import Brick.Panes import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Core as BC import qualified Brick.Widgets.Table as BT import Control.Lens hiding ( under ) import Data.Either ( isRight ) import qualified Data.List as DL import Data.Maybe ( isJust ) import qualified Data.Sequence as Seq import Data.Text ( Text ) import qualified Data.Text as T import Data.Time.Calendar ( Day ) import qualified Graphics.Vty as Vty import Defs import Panes.Common.Attrs import Panes.Common.Inputs import Sync data AddProjPane data NewProj = NewProj { _npName :: ProjectName , _npRole :: Role , _npGroupG :: Maybe Group , _npGroupT :: Text , _npLangR :: Either Text Language , _npLangT :: Text , _npDesc :: Text , _npLoc :: LocationSpec , _npLocDate :: Maybe Day } makeLenses ''NewProj blankNewProj :: NewProj blankNewProj = NewProj (ProjectName "") User (Just Personal) "" (Right C) "" "" (RemoteSpec "") Nothing type ProjForm = Form NewProj MyWorkEvent WName instance Pane WName MyWorkEvent AddProjPane where data (PaneState AddProjPane MyWorkEvent) = NP { nPF :: Maybe ProjForm -- Just == pane active , nPrj :: Maybe Project -- reset to Nothing when nPF -- transitions Nothing -> Just , nOrig :: Maybe Project , nErr :: Maybe Text } type (EventType AddProjPane WName MyWorkEvent) = BrickEvent WName MyWorkEvent initPaneState _ = NP Nothing Nothing Nothing Nothing drawPane ps _gs = C.centerLayer . modalB ((maybe "New" (const "Edit") $ nOrig ps) <> " Project") . vLimitPercent 80 . hLimitPercent 65 . (\f -> vBox [ renderForm f , padBottom (Pad 1) $ withAttr a'Error $ maybe (txt " ") txt (nErr ps) , emptyWidget , vLimit 1 (fill ' ' <+> str "Ctrl-D = accept" <+> fill ' ' <+> str "ESC = abort" <+> fill ' ') ]) <$> nPF ps focusable _ ps = case nPF ps of Nothing -> mempty Just f -> Seq.fromList $ focusRingToList $ formFocus f handlePaneEvent _ = \case VtyEvent (Vty.EvKey Vty.KEsc []) -> nPFL %%~ const (return Nothing) VtyEvent (Vty.EvKey (Vty.KChar 'd') [Vty.MCtrl]) -> \s -> let pf = s ^. nPFL np form = Project { projName = form ^. npName , group = case form ^. npGroupG of Just r -> r Nothing -> OtherGroup $ form ^. npGroupT , role = form ^. npRole , language = case form ^. npLangR of r@(Right _) -> r Left _ -> Left $ form ^. npLangT , description = form ^. npDesc , locations = case form ^. npLoc of RemoteSpec rs | T.null rs -> mempty _ -> [ Location { location = form ^. npLoc , locatedOn = form ^. npLocDate , notes = mempty , locCore = LocRT { locValid = True -- assumed } } ] , projCore = ProjRT } in if maybe False allFieldsValid pf then do let p0 = np . formState <$> pf p <- case p0 of Nothing -> return Nothing Just jp -> Just <$> syncProject jp return $ s & nPFL .~ Nothing & newProject .~ p else let badflds = maybe "none" (foldr (\n a -> if T.null a then T.pack n else T.pack n <> ", " <> a) "" . fmap show . invalidFields) pf errmsg = "Correct invalid entries before accepting: " in return $ s { nErr = Just $ errmsg <> badflds } ev -> \s -> validateForm $ s { nErr = Nothing } & (nPFL . _Just %%~ \w -> nestEventM' w (handleFormEvent ev)) nPFL :: Lens' (PaneState AddProjPane MyWorkEvent) (Maybe ProjForm) nPFL f s = (\n -> s { nPF = n }) <$> f (nPF s) isAddProjActive :: PaneState AddProjPane MyWorkEvent -> Bool isAddProjActive = isJust . nPF newProject :: Lens' (PaneState AddProjPane MyWorkEvent) (Maybe Project) newProject f s = (\n -> s { nPrj = n}) <$> f (nPrj s) -- | Returns the original project name (if any) and the new Project -- specification. projectInputResults :: PaneState AddProjPane MyWorkEvent -> (Maybe ProjectName, Maybe Project) projectInputResults ps = (view projNameL <$> nOrig ps, nPrj ps) validateForm :: EventM WName es (PaneState AddProjPane MyWorkEvent) -> EventM WName es (PaneState AddProjPane MyWorkEvent) validateForm inner = do s <- inner case s ^. nPFL of Nothing -> return s Just pf -> do let isOK1 = or [ formState pf ^. npGroupG /= Nothing , formState pf ^. npGroupT /= "" ] let tgtfld1 = WName "Other Group Text" let isOK2 = or [ isRight (formState pf ^. npLangR) , formState pf ^. npLangT /= "" ] let tgtfld2 = WName "Other Language Name" (ltgt, lvalid) <- validateLocationInput True $ formState pf ^. npLoc return $ s & nPFL %~ fmap (setFieldValid isOK1 tgtfld1) & nPFL %~ fmap (setFieldValid isOK2 tgtfld2) & nPFL %~ fmap (setFieldValid lvalid ltgt) initAddProj :: Projects -> Maybe Project -> PaneState AddProjPane MyWorkEvent -> PaneState AddProjPane MyWorkEvent initAddProj prjs mbProj ps = case nPF ps of Just _ -> ps Nothing -> let label s = padBottom (Pad 1) . label' s label' s w = (vLimit 1 $ hLimit labelWidth $ fill ' ' <+> str s <+> str ": ") <+> w under s w = padBottom (Pad 1) $ vLimit 1 $ padLeft (Pad (labelWidth + 4)) $ str s <+> w labelWidth = 18 numCols lastSolo nc = let go wdgs = if null wdgs then [] else fmap padded (DL.take nc (wdgs <> DL.repeat emptyWidget)) : go (DL.drop nc wdgs) padded = padRight (BC.Pad 2) renderT = BT.renderTable . BT.surroundingBorder False . BT.rowBorders False . BT.columnBorders False in if lastSolo then \wdgs -> if null wdgs then emptyWidget else (renderT $ BT.table $ go $ DL.init wdgs) <=> DL.last wdgs else renderT . BT.table . go projFields = [ label "Project name" @@= let validate = \case [] -> Nothing [""] -> Nothing (nmt:_) -> let nm = ProjectName nmt in if nm `elem` (view projNameL <$> projects prjs) && (maybe True ((nm /=) . view projNameL) mbProj) then Nothing -- invalid else Just nm in editField npName (WName "New Project Name") (Just 1) (\(ProjectName nm) -> nm) validate (txt . headText) id , label' "Group" @@= radioField npGroupG [ (Just Personal, (WName "+Prj:Grp:Personal"), "Personal") , (Just Work, (WName "+Prj:Grp:Work"), "Work") , (Nothing, (WName "Other Group Text"), "Other") ] , under "...: " @@= editTextField npGroupT (WName "+Proj:Grp:Text") (Just 1) , label "Role" @@= -- setFieldConcat (hBox . DL.intersperse (str " ")) . setFieldConcat (numCols False 2) . radioField npRole [ (Author, (WName "+Prj:Role:Author"), "Author") , (Maintainer, (WName "+Prj:Role:Maintainer"), "Maintainer") , (Contributor, (WName "+Prj:Role:Contributor"), "Contributor") , (User, (WName "+Prj:Role:User"), "User") ] , label' "Language" @@= setFieldConcat (numCols True 4) . radioField npLangR [ (Right C, (WName "+Prj:Lang:C"), "C") , (Right CPlusPlus, (WName "+Prj:Lang:CPP"), "C++") , (Right Haskell, (WName "+Prj:Lang:Haskell"), "Haskell") , (Right JavaScript, (WName "+Prj:Lang:JS"), "JavaScript") , (Right Prolog, (WName "+Prj:Lang:Prolog"), "Prolog") , (Right Python, (WName "+Prj:Lang:Python"), "Python") , (Right Rust, (WName "+Prj:Lang:Rust"), "Rust") , (Left "", (WName "Other Language Name"), "Custom") ] , under "...: " @@= editTextField npLangT (WName "+Prj:Lang:Text") (Just 1) , label "Description" @@= editTextField npDesc (WName "+Prj:Desc") Nothing ] locFields = case mbProj of Nothing -> -- Only query for the initial location if this is a new project; -- do not query for an existing project. [ label "Initial location" @@= locationInput mempty Nothing True npLoc , label "Location date" @@= mbDateInput npLocDate ] _ -> [] npForm = newForm (projFields <> locFields) (case mbProj of Nothing -> blankNewProj Just p -> NewProj { _npName = p ^. projNameL , _npRole = p ^. roleL , _npGroupG = case p ^. groupL of Personal -> Just Personal Work -> Just Work OtherGroup _ -> Nothing , _npGroupT = case p ^. groupL of OtherGroup t -> t _ -> "" , _npLangR = p ^. languageL , _npLangT = case p ^. languageL of Right _ -> "" Left t -> t , _npDesc = p ^. descriptionL , _npLoc = RemoteSpec "" , _npLocDate = Nothing } ) in NP { nPF = Just npForm , nPrj = Nothing , nOrig = mbProj , nErr = Nothing }