{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- KWQ: adding a project *just* with a location could potentially query the (local) location for the details.
-- KWQ: if adding a project and capable of scanning for details (cabal file, etc.), what if determined project name is different than current project name (i.e. adding a bad location)?
-- KWQ: with more VCS sophistication, it could compare different locations (esp to canonical location) to determine if ahead/behind/etc.
-- KWQ: location dates as the latest date of any file touched in that location (this could be a big scan! Limit depth to 1? Just dirs?)
-- KWQ: locationstatus git recognition could add branch info for local location?
-- KWQ: global "find location"
-- KWQ: adding a Pull Request as a new location (F5 context-specific)
-- KWQ: TODO notes
-- KWQ: ON_DATE notes
-- KWQ: notes should show location/source. Only MyWorkDB notes should be editable.
-- KWQ: no notes for git/darcs relationships... part of location instead?
-- KWQ: changing dir on exit doesn't work (because it's the tui sub-proc that changes dir), and it probably shouldn't without explicit direction, but can we echo to stdout better?
-- KWQ: group heirarchy: work/ARCOS/RACK
-- KWQ: Multi-language projects (e.g. RACK is Java, Python, Prolog, SADL, ...
-- KWQ: should full note be a separate pane? yes?
-- KWQ; filebrowser helper for location
-- KWQ: check remote VCS
-- KWQ: location for hackage
-- KWQ: check hackage status/date
-- KWQ: pull requests notification
-- KWQ: build failures notification
-- KWQ: indication in ProjInfo of which VCS (Git, Darcs, etc.).
-- KWQ: if submodules, sync gets locations and create projects/locations for those submodules? How to relate to the main project?
-- KWQ: Projects list differentiation: Work, Personal, other [filtering? visual grouping? what sorting for the Projects list?]
-- KWQ: sorting for all panes. (and filtering)
-- KWQ: Notes could be two lists with a scrollable edit window between, associated with the selected list item. This makes scrolling hard though, because need to intercept event to split between two lists. However, how bad is it if there is just a single list and the list render function just draws one entry extra long? However, another bad effect here is that a very long note can consume the list display area, making scrolling very awkward (similar to MH with large embedded messages). Maybe the separate area really is the best visual design...
-- KWQ: NAmedStr, SayText, Seq, etc.
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 [ -- withVScrollBars OnRight
-- $ viewport (WName "AddProjForm:viewport") Vertical
-- $
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 { name = 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
, locValid = True -- assumed
, notes = mempty
}
]
}
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 = (name <$> 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` (name <$> projects prjs) &&
(maybe True ((nm /=) . name) 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 = name p
, _npRole = role p
, _npGroupG = case group p of
Personal -> Just Personal
Work -> Just Work
OtherGroup _ -> Nothing
, _npGroupT = case group p of
OtherGroup t -> t
_ -> ""
, _npLangR = language p
, _npLangT = case language p of
Right _ -> ""
Left t -> t
, _npDesc = description p
, _npLoc = RemoteSpec ""
, _npLocDate = Nothing
}
)
in NP { nPF = Just npForm
, nPrj = Nothing
, nOrig = mbProj
, nErr = Nothing
}