packages feed

mywork 1.0.0.0 → 1.0.1.0

raw patch · 46 files changed

+3457/−2960 lines, 46 filesdep +myworkdep ~basedep ~brickdep ~brick-panes

Dependencies added: mywork

Dependency ranges changed: base, brick, brick-panes, lens, vty

Files

CHANGELOG.md view
@@ -1,5 +1,35 @@ # Revision history for mywork -## 0.1.0.0 -- 202-09-15+## 1.0.1.0 -- 2022-10-13++### Operational++* NOTE: using this version will update the stored project information in a manner+  that is incompatible with version 1.0.0.0.  If you intend to return to version+  1.0.0.0, backup your project data file before saving from this version.++* Adds ability to specially recognize keywords and dates in note titles and+  sort and highlight accordingly.++* Cannot edit or delete a note unless it was created within mywork.  Project+  location notes and auto-generated notes such as repository location relations+  cannot be edited.++* Ctrl-S immediate save not available when displaying any modal other than the+  FileMgr modal.++* Enter in project search box clears search box but retains current selection.++* Miscellaneous small behavioral bug fixes.++### Internal/Implementation++* Improved internal efficiency when reading local location information.++* No storage of transient data in projects storage file.++* Split into a minimal application utilizing a library++## 1.0.0.0 -- 2022-10-01  * First version.
− app/Defs.hs 
@@ -1,320 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-}--module Defs where--import           Brick hiding (Location)-import           Brick.Focus-import           Brick.Panes-import           Control.Lens-import           Control.Monad ( guard )-import qualified Data.List as DL-import           Data.Text ( Text, pack, unpack )-import qualified Data.Text as T-import           Data.Time.Calendar-import           GHC.Generics ( Generic )-import           Path ( Path, Abs, Dir, File, toFilePath )---newtype Projects = Projects { projects :: [Project] }-  deriving (Generic, Monoid, Semigroup)--newtype ProjectName = ProjectName Text deriving (Eq, Ord)--data Project = Project { name :: ProjectName-                       , group :: Group-                       , role :: Role-                       , description :: Text-                       , language :: Either Text Language-                       , locations :: [Location]-                       }-  deriving Generic--data Group = Personal | Work | OtherGroup Text-  deriving (Eq, Generic)--data Role = Author | Maintainer | Contributor | User-  deriving (Show, Enum, Bounded, Eq, Ord, Generic)--data Language = Haskell | Rust | C | CPlusPlus | Python | JavaScript | Prolog-  deriving (Show, Eq, Generic)--data LocationSpec = LocalSpec (Path Abs Dir)-                  | RemoteSpec Text-                  deriving (Eq, Ord, Generic)--instance Show LocationSpec where-  show = \case-    LocalSpec p -> toFilePath p-    RemoteSpec r -> T.unpack r--data Location = Location { location :: LocationSpec-                         , locatedOn :: Maybe Day-                         , locValid :: Bool -- This should not be included in toJSON-                         , notes :: [Note]-                         }-  deriving Generic--data Note = Note { notedOn :: Day-                 , note :: Text-                 , noteSource :: NoteSource-                 }-  deriving (Eq, Ord, Generic)--data NoteSource = MyWorkDB | ProjLoc | MyWorkGenerated-  deriving (Eq, Ord)--numProjects :: Projects -> Int-numProjects = length . projects--languageText :: Either Text Language -> Text-languageText = either id (pack . show)---instance Show Group where-  show = \case-    Personal -> "Personal"-    Work -> "Work"-    OtherGroup g -> unpack g--newtype NoteTitle = NoteTitle Text deriving Eq--noteTitle :: Note -> NoteTitle-noteTitle = noteTitle' . note--noteTitle' :: Text -> NoteTitle-noteTitle' t = case T.lines t of-                 [] -> NoteTitle ""-                 (l:_) -> NoteTitle l---------------------------------------------------------------------------data MyWorkCore = MyWorkCore { myWorkFocus :: FocusRing WName }--initMyWorkCore :: MyWorkCore-initMyWorkCore = MyWorkCore { myWorkFocus = focusRing [ WProjList-                                                      , WLocations-                                                      ]-                            }--coreWorkFocusL :: Lens' MyWorkCore (FocusRing WName)-coreWorkFocusL f c = (\f' -> c { myWorkFocus = f' }) <$> f (myWorkFocus c)---data WName = WProjList | WLocations | WNotes | WName Text-  deriving (Eq, Ord)--instance Show WName where-  show = \case-    WProjList -> "Projects"-    WLocations -> "Location"-    WNotes -> "Notes"-    WName n -> unpack n---type MyWorkEvent = ()  -- No app-specific event for this simple app---class HasProjects s where-  getProjects :: s -> (Either Confirm Bool, Projects)---class HasMessage s where-  getMessage :: s -> [Widget WName]---instance HasFocus MyWorkCore WName where-  getFocus f s =-    let setFocus jn = case focused jn of-          Nothing -> s-          Just n -> s & coreWorkFocusL %~ focusSetCurrent n-    in setFocus <$> (f $ Focused $ focusGetCurrent (s^.coreWorkFocusL))---class HasSelection s where-  selectedProject :: s -> Maybe ProjectName--instance ( PanelOps Projects WName MyWorkEvent panes MyWorkCore-         , HasSelection (PaneState Projects MyWorkEvent)-         )-  => HasSelection (Panel WName MyWorkEvent MyWorkCore panes) where-  selectedProject = selectedProject . view (onPane @Projects)--class HasLocation s where-  -- | Returns the currently selected project and location-  selectedLocation :: s -> Maybe (ProjectName, LocationSpec)--instance ( PanelOps Location WName MyWorkEvent panes MyWorkCore-         , HasLocation (PaneState Location MyWorkEvent)-         )-  => HasLocation (Panel WName MyWorkEvent MyWorkCore panes) where-  selectedLocation = selectedLocation . view (onPane @Location)--class HasNote s where-  -- | Returns the currently selected location and note-  selectedNote :: s -> Maybe (LocationSpec, NoteTitle)--instance ( PanelOps Note WName MyWorkEvent panes MyWorkCore-         , HasNote (PaneState Note MyWorkEvent)-         )-  => HasNote (Panel WName MyWorkEvent MyWorkCore panes) where-  selectedNote = selectedNote . view (onPane @Note)---getCurrentProject :: HasSelection s => HasProjects s => s -> Maybe Project-getCurrentProject s = do pnm <- selectedProject s-                         let (_, prjs) = getProjects s-                         DL.find ((== pnm) . name) (projects prjs)--getCurrentLocation :: HasSelection s-                   => HasLocation s-                   => HasProjects s-                   => s -> Maybe (Project, Maybe Location)-getCurrentLocation s =-  do (p,l) <- selectedLocation s-     let (_,prjs) = getProjects s-     prj <- DL.find ((== p) . name) (projects prjs)-     return (prj, DL.find ((== l) . location) (locations prj))---getCurrentNote :: HasNote s => s -> Location -> Maybe Note-getCurrentNote s l = do (l',n) <- selectedNote s-                        guard (location l == l')-                        DL.find ((== n) . noteTitle) (notes l)--isLocationLocal :: Location -> Bool-isLocationLocal = isLocationLocal' . location--isLocationLocal' :: LocationSpec -> Bool-isLocationLocal' = \case-  LocalSpec _ -> True-  RemoteSpec _ -> False--isLocationTextLocal :: Text -> Bool-isLocationTextLocal t =-  not $ or [ "http://" `T.isPrefixOf` t-           , "https://" `T.isPrefixOf` t-           , "git@" `T.isPrefixOf` t-           , ":/" `T.isInfixOf` t-           ]--updateProject :: Maybe ProjectName -> Project -> Projects -> Projects-updateProject onm p (Projects ps) =-  let oldName = maybe (name p) id onm-      (match, other) = DL.partition ((== oldName) . name) ps-      p' = foldr (updateLocation Nothing) p (concatMap locations match)-  in Projects $ p' : other----- | Adds the specified Location to the Project, merging with the previous--- Location (with the same name or the previous name indicated by a Just in the--- the Maybe parameter).-updateLocation :: Maybe LocationSpec -> Location -> Project -> Project-updateLocation ol l p =-  let oldName = maybe (location l) id ol-      (match, other) = DL.partition ((== oldName) . location) (locations p)-      l' = foldr addNote l (concatMap notes match)-      addNote n lc = lc { notes = n : filter ((/= noteTitle n) . noteTitle) (notes lc) }-  in p { locations = l' : other }---updateLocNote :: Maybe NoteTitle -> Note -> Location -> Location-updateLocNote oldn n l =-  let oldName = maybe (noteTitle n) id oldn-  in l { notes = n : filter ((/= oldName) . noteTitle) (notes l) }---updateNote :: Maybe NoteTitle -> Note -> Location -> Project-           -> (Project, Location)-updateNote oldn n l p = let newL = updateLocNote oldn n l-                        in (updateLocation Nothing newL p, newL)---data OpOn = ProjectOp | LocationOp | NoteOp-  deriving (Eq, Enum, Bounded)--opOnSelection :: HasSelection s-              => HasLocation s-              => HasFocus s WName-              => s -> OpOn-opOnSelection s =-  case s ^. getFocus of-    Focused (Just WProjList) -> ProjectOp-    Focused (Just WLocations) -> LocationOp-    Focused (Just WNotes) -> NoteOp-    _ -> ProjectOp---data Confirm = ConfirmProjectDelete ProjectName-             | ConfirmLocationDelete ProjectName LocationSpec-             | ConfirmNoteDelete ProjectName LocationSpec NoteTitle-             | ConfirmLoad (Path Abs File)-             | ConfirmQuit---- The Show instance for Confirm is the message presented to the user in the--- confirmation window.-instance Show Confirm where-  show = \case-    ConfirmProjectDelete pname ->-      let ProjectName pnm = pname-      in "Are you sure you want to delete project " <> show pnm-         <> " and all associated locations and notes?"-    ConfirmLocationDelete pname locn ->-      let ProjectName pnm = pname-      in "Are you sure you want to remove location " <> show locn-         <> " from project " <> show pnm <> "?"-    ConfirmNoteDelete pname locn nt ->-      let ProjectName pnm = pname-          NoteTitle ntitle = nt-      in "Remove the following note from project " <> show pnm-         <> ", location " <> show locn <> "?\n\n  " <> show ntitle-    ConfirmLoad fp ->-      "Discard local changes and load projects from " <> show fp <> "?"-    ConfirmQuit -> "There are unsaved changes.  Are you sure you want to quit?"---tshow :: Show a => a -> Text-tshow = T.pack . show--------------------------------------------------------------------------a'Operation :: AttrName-a'Operation = attrName "Oper"--a'RoleAuthor, a'RoleContributor, a'RoleMaintainer, a'RoleUser :: AttrName-a'RoleAuthor = attrName "auth"-a'RoleContributor = attrName "contrib"-a'RoleMaintainer = attrName "maint"-a'RoleUser = attrName "user"--roleAttr :: Role -> AttrName-roleAttr = \case-  Author -> a'RoleAuthor-  Contributor -> a'RoleContributor-  Maintainer -> a'RoleMaintainer-  User -> a'RoleUser---a'ProjName :: AttrName-a'ProjName = attrName "projname"--a'Disabled :: AttrName-a'Disabled = attrName "disabled"--a'Selected :: AttrName-a'Selected = attrName "selected"--a'Error :: AttrName-a'Error = attrName "Error"--a'Notice :: AttrName-a'Notice = attrName "Notice"
− app/Defs/JSON.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Defs.JSON-where--import           Data.Aeson--import Defs---instance ToJSON ProjectName where toJSON (ProjectName pnm) = toJSON pnm-instance ToJSON LocationSpec where-  toJSON = genericToJSON locationSpecOptions-instance ToJSON Projects-instance ToJSON Project-instance ToJSON Group-instance ToJSON Role-instance ToJSON Language-instance ToJSON Location where-  -- only emit notes with NoteSource of MyWorkDB-  toJSON l = object [ ("location", toJSON (location l))-                    , ("locatedOn", toJSON (locatedOn l))-                    , ("locValid", toJSON (locValid l))-                    , ("notes",-                       toJSON (filter ((MyWorkDB ==) . noteSource) $ notes l))-                    ]-instance ToJSON Note where-  -- does not emit noteSource-  toJSON n = object [ ("note", toJSON (note n))-                    , ("notedOn", toJSON (notedOn n))-                    ]--instance FromJSON ProjectName where parseJSON = fmap ProjectName . parseJSON-instance FromJSON LocationSpec where-  parseJSON = genericParseJSON locationSpecOptions-instance FromJSON Projects-instance FromJSON Project where-  parseJSON = withObject "Project" $ \v -> Project-    <$> v .: "name"-    <*> v .:? "group" .!= Personal-    <*> v .: "role"-    <*> v .: "description"-    <*> v .: "language"-    <*> v .: "locations"--instance FromJSON Group-instance FromJSON Role-instance FromJSON Language-instance FromJSON Location where-  parseJSON = withObject "Location" $ \v -> Location-    <$> v .: "location"-    <*> v .: "locatedOn"-    <*> v .:? "locValid" .!= True -- assumed -- Added in v0.1.1.0-    <*> v .: "notes"-instance FromJSON Note where-  parseJSON = withObject "Note" $ \v -> Note-    <$> v .: "notedOn"-    <*> v .: "note"-    <*> pure MyWorkDB---locationSpecOptions :: Options-locationSpecOptions = defaultOptions { sumEncoding = UntaggedValue }
app/Main.hs view
@@ -1,98 +1,35 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-}  module Main where -import           Brick hiding ( Location )-import           Brick.Focus-import           Brick.Forms-import           Brick.Panes-import           Brick.Widgets.Border-import           Brick.Widgets.Border.Style-import           Brick.Widgets.Dialog-import           Brick.Widgets.Edit-import           Brick.Widgets.List-import           Control.Lens-import           Control.Monad ( unless, when )-import           Control.Monad.IO.Class ( liftIO )-import           Control.Monad.Reader ( ReaderT, runReaderT, ask, lift )-import           Control.Monad.Writer ( WriterT, execWriterT, tell )-import qualified Data.List as DL-import           Data.Maybe ( catMaybes )-import qualified Data.Text as T-import           Data.Version ( showVersion )-import           Graphics.Vty ( defAttr, withStyle, defaultStyleMask-                              , bold, reverseVideo, dim, underline-                              , black, white, yellow, red, green, cyan, rgbColor )-import qualified Graphics.Vty as Vty+import Brick+import Brick.Panes+import Control.Lens+import Data.Text ( unpack )+import Graphics.Vty ( Event(EvKey), Key(KUp) ) -import           Defs-import           Panes.AddProj-import           Panes.Confirmation-import           Panes.FileMgr-import           Panes.Help-import           Panes.Location ()-import           Panes.LocationInput-import           Panes.Messages-import           Panes.NoteInput-import           Panes.Notes ()-import           Panes.Operations-import           Panes.ProjInfo-import           Panes.Projects ()-import           Panes.Summary-import           Paths_mywork ( version )-import           Sync+import Defs+import Draw+import Events+import Panes.FileMgr+import Whole  -type MyWorkState = Panel WName MyWorkEvent MyWorkCore-                   '[ SummaryPane-                    , NoteInputPane-                    , LocationInputPane-                    , AddProjPane-                    , OperationsPane-                    , ProjInfoPane-                    , Note-                    , Location-                    , Projects-                    , FileMgrPane-                    , Confirm-                    , HelpPane-                    , MessagesPane-                    ]--initialState :: MyWorkState-initialState = focusRingUpdate myWorkFocusL-               $ addToPanel Never-               $ addToPanel WhenFocusedModalHandlingAllEvents-               $ addToPanel WhenFocusedModalHandlingAllEvents-               $ addToPanel WhenFocusedModalHandlingAllEvents-               $ addToPanel Never-               $ addToPanel Never-               $ addToPanel WhenFocused-               $ addToPanel WhenFocused-               $ addToPanel WhenFocused-               $ addToPanel WhenFocusedModal-               $ addToPanel WhenFocusedModalHandlingAllEvents-               $ addToPanel WhenFocusedModal-               $ addToPanel Never-               $ basePanel initMyWorkCore- main :: IO ()-main = do i <- initialState & onPane @FileMgrPane %%~ initFileMgr+main = do i0 <- initialState+          i <- i0 & onPane @FileMgrPane %%~ initFileMgr           s <- defaultMain myworkApp i           case getCurrentLocation s of             Just (p,mbl) ->-              do let ProjectName pnm = name p-                 putStrLn $ T.unpack $ pnm <> ": " <> description p+              do let ProjectName pnm = p ^. projNameL+                 putStrLn $ unpack $ pnm <> ": " <> p ^. descriptionL                  case mbl of                    Nothing -> return ()                    Just l ->-                     case location l of+                     case l ^. locationL of                        RemoteSpec r ->-                         putStrLn $ "Remote location: " <> T.unpack r+                         putStrLn $ "Remote location: " <> unpack r                        LocalSpec d -> do putStrLn "Local directory"                                          putStrLn $ show d @@ -108,383 +45,7 @@                     -- already be at the top, but this invokes the various                     -- wrappers that will update all the panes based on the                     -- Projects loaded by initFileMgr-                    handleMyWorkEvent (VtyEvent (Vty.EvKey Vty.KUp []))+                    handleMyWorkEvent (VtyEvent (EvKey KUp []))                 , appAttrMap = const myattrs                 } -myattrs :: AttrMap-myattrs = attrMap defAttr-          [-            (editAttr, white `on` black)-          , (editFocusedAttr, yellow `on` black)--          , (listAttr, defAttr `withStyle` defaultStyleMask)-          , (listSelectedAttr, defAttr `withStyle` bold)-          , (listSelectedFocusedAttr, defAttr `withStyle` reverseVideo)--          , (invalidFormInputAttr, fg red `withStyle` bold)-          , (focusedFormInputAttr, defAttr `withStyle` reverseVideo)--          , (buttonAttr, black `on` (rgbColor 100 100 (100::Int)))-          , (buttonSelectedAttr, black `on` green)--          , (a'Operation, white `on` (rgbColor 0 1 (0::Int)))--          , (a'RoleAuthor, fg $ rgbColor 0 255 (0::Int))-          , (a'RoleMaintainer, fg $ rgbColor 0 200 (130::Int))-          , (a'RoleContributor, fg $ rgbColor 0 145 (180::Int))-          , (a'RoleUser, defAttr)--          , (a'ProjName, defAttr `withStyle` bold `withStyle` underline)--          , (a'Disabled, defAttr `withStyle` dim)-          , (a'Selected, black `on` yellow)-          , (a'Error, fg red)-          , (a'Notice, fg cyan)-          ]--drawMyWork :: MyWorkState -> [Widget WName]-drawMyWork mws =-  let mainPanes =-        [-          borderWithLabel  (str $ " mywork " <> showVersion version <> " ")-          $ vBox $ catMaybes-          [-            panelDraw @SummaryPane mws-          , Just hBorder-          , Just $ hBox $ catMaybes-            [ hLimit 25-              <$> panelDraw @Projects mws-            , Just vBorder-            , Just $ vBox $ catMaybes $-              let pinfo = panelDraw @ProjInfoPane mws-              in [ pinfo-                 , const (hBorderWithLabel (str "Locations")) <$> pinfo-                 , vLimitPercent 28 <$> panelDraw @Location mws-                 , const (hBorderWithLabel (str "Notes")) <$> pinfo-                 , pinfo >> panelDraw @Note mws-                 ]-            ]-          , Just hBorder-          , panelDraw @MessagesPane mws-          , panelDraw @OperationsPane mws-          ]-        ]-      allPanes = catMaybes [ panelDraw @FileMgrPane mws-                           , panelDraw @AddProjPane mws-                           , panelDraw @LocationInputPane mws-                           , panelDraw @NoteInputPane mws-                           , panelDraw @Confirm mws-                           , panelDraw @HelpPane mws-                           ]-                 <> mainPanes-      disableLower = \case-        (m:ls) -> m : (withDefAttr a'Disabled <$> ls)-        o -> o-  in joinBorders . withBorderStyle unicode <$> disableLower allPanes---handleMyWorkEvent :: BrickEvent WName MyWorkEvent -> EventM WName MyWorkState ()-handleMyWorkEvent = \case-  AppEvent _ -> return () -- this app does not use these--  ---------------------------------------------------------  -- Application global actions-  --   * CTRL-q quits-  --   * CTRL-l refreshes vty-  --   * ESC dismisses any modal window--  VtyEvent (Vty.EvKey (Vty.KChar 'q') [Vty.MCtrl]) -> do-    s <- get-    if s ^. onPane @FileMgrPane . to unsavedChanges-      then modify ( (focusRingUpdate myWorkFocusL)-                    . (onPane @Confirm %~ showConfirmation ConfirmQuit)-                  )-      else halt-  VtyEvent (Vty.EvKey (Vty.KChar 'l') [Vty.MCtrl]) ->-    liftIO . Vty.refresh =<< getVtyHandle--  ---------------------------------------------------------  -- Other application global events (see Pane.Operations)--  -- Enter Load/Save modal dialog-  VtyEvent (Vty.EvKey (Vty.KFun 9) []) -> do-    resetMessages-    s <- get-    if s ^. onPane @FileMgrPane . to isFileMgrActive-      then return ()-      else do-        s' <- s & onPane @FileMgrPane %%~ liftIO . showFileMgr-        put $ s' & focusRingUpdate myWorkFocusL--  -- Quickly save to current file (if possible)-  ev@(VtyEvent (Vty.EvKey (Vty.KChar 's') [Vty.MCtrl])) -> do-    -- KWQ: do nothing if currently modal?!-    s <- get-    when (not $ s ^. onPane @FileMgrPane . to isFileMgrActive) $ do-      s' <- s & onPane @FileMgrPane %%~ liftIO . showFileMgr-      put $ s' & focusRingUpdate myWorkFocusL-    eventToPanel ev-    return ()--  -- Show help on F1-  VtyEvent (Vty.EvKey (Vty.KFun 1) []) ->-    modify $ onPane @HelpPane .~ initHelp--  -- Add an entry to the currently selected pane-  VtyEvent (Vty.EvKey (Vty.KFun 2) []) -> do-    resetMessages-    s <- get-    case opOnSelection s of-      ProjectOp ->-        put $ s-        & onPane @AddProjPane %~ initAddProj (snd $ getProjects s) Nothing-        & focusRingUpdate myWorkFocusL-      LocationOp -> addLocation s-      NoteOp -> addNote s--  -- Add a sub-entry to the currently selected pane entry-  VtyEvent (Vty.EvKey (Vty.KFun 3) []) -> do-    resetMessages-    s <- get-    case opOnSelection s of-      ProjectOp -> addLocation s-      LocationOp -> addNote s-      NoteOp -> addNote s  -- Note: F3 is not displayed, but no lower entry--  -- Edit the current selected entry in whichever pane is active-  VtyEvent (Vty.EvKey (Vty.KChar 'e') [Vty.MCtrl]) -> do-    isModal <- gets (isPanelModal myWorkFocusL)-    unless isModal $ do-      resetMessages-      s <- get-      case opOnSelection s of-        ProjectOp ->-          case getCurrentLocation s of-            Just (p, _) ->-              put $ s-              & onPane @AddProjPane %~ initAddProj (snd $ getProjects s) (Just p)-              & focusRingUpdate myWorkFocusL-            _ -> return ()-        LocationOp ->-          case getCurrentLocation s of-            Just (p, Just l) ->  -- KWQ: same as addLocation but Just l ...-              let n = name p-                  ls = locations p-              in put $ s-                 & onPane @LocationInputPane %~ initLocInput n ls (Just l)-                 & focusRingUpdate myWorkFocusL-            _ -> return ()-        NoteOp ->-          case getCurrentLocation s of-            Just (_, Just l) ->-              let nt = getCurrentNote s l-              in do s' <- s & onPane @NoteInputPane %%~ initNoteInput (notes l) nt-                    put $ s' & focusRingUpdate myWorkFocusL-            _ -> return ()--  -- Delete the current selected entry in whichever pane is active-  VtyEvent (Vty.EvKey Vty.KDel []) -> do-    isModal <- gets (isPanelModal myWorkFocusL)-    unless isModal $ do-      resetMessages-      s <- get-      let cnf =-            case opOnSelection s of-              ProjectOp ->-                case getCurrentLocation s of-                  Just (p, _) -> Just $ ConfirmProjectDelete (name p)-                  _ -> Nothing-              LocationOp ->-                case getCurrentLocation s of-                  Just (p, Just l) ->-                    Just $ ConfirmLocationDelete (name p) (location l)-                  _ -> Nothing-              NoteOp -> do (p, mbl) <- getCurrentLocation s-                           l <- mbl-                           nt <- noteTitle <$> getCurrentNote s l-                           pure $ ConfirmNoteDelete (name p) (location l) nt-      case cnf of-        Just cmsg -> put $ s & onPane @Confirm %~ showConfirmation cmsg-                             & focusRingUpdate myWorkFocusL-        Nothing -> return ()--  -- Otherwise, allow the Panes in the Panel to handle the event.  The wrappers-  -- handle updates for any inter-state transitions.-  ev -> eventToPanel ev--  where-    eventToPanel ev = do-      resetMessages-      s <- get-      (t,s') <- handleFocusAndPanelEvents myWorkFocusL s ev-      put s'-      when (exitedModal @FileMgrPane t s') $-             let fmn = Just $ (panelState @FileMgrPane s') ^. fileMgrNotices-             in modify-                (   (onPane @FileMgrPane . fileMgrNotices .~ mempty)-                  . (onPane @MessagesPane %~ updatePane fmn)-                )-      let postop = do handleConfirmation-                      handleNewProject-                      handleProjectChanges-                      mbprj <- handleProjectChange-                      mbprj' <- handleLocationInput mbprj-                      mbloc <- handleLocationChange mbprj'-                      handleNoteInput mbprj' mbloc-      refocus <- execWriterT $ runReaderT postop t-      when (or refocus) $ modify $ focusRingUpdate myWorkFocusL---addLocation :: MyWorkState -> EventM WName MyWorkState ()-addLocation s =-  case getCurrentProject s of-    Just p ->-      let n = name p-          ls = locations p-      in put $ s-         & onPane @LocationInputPane %~ initLocInput n ls Nothing-         & focusRingUpdate myWorkFocusL-    _ -> return ()---type Msg = Maybe (Widget WName)-type ReadCtxt = PanelTransition--addNote :: MyWorkState -> EventM WName MyWorkState ()-addNote s =-  case getCurrentLocation s of-    Just (_, Just l) -> do-      s' <- s & onPane @NoteInputPane %%~ initNoteInput (notes l) Nothing-      put $ s' & focusRingUpdate myWorkFocusL-    _ -> return ()---resetMessages :: EventM WName MyWorkState ()-resetMessages = modify $ onPane @MessagesPane %~ updatePane Nothing---type PostOpM a = ReaderT PanelTransition (WriterT [Bool] (EventM WName MyWorkState)) a--handleConfirmation :: PostOpM ()-handleConfirmation = do-  let confirmOp :: (PaneState Confirm MyWorkEvent -> a) -> PostOpM a-      confirmOp o = gets (view $ onPane @Confirm . to o)-  transition <- ask-  deactivatedConfirmation <- gets (exitedModal @Confirm transition)-  when deactivatedConfirmation $-    do (ps, confirmed) <- confirmOp getConfirmedAction-       modify $ onPane @Confirm .~ ps-       let toFM :: FileMgrOps -> PostOpM ()-           toFM msg = do modify (onPane @FileMgrPane %~ updatePane msg)-                         tell [True]-       case confirmed of-         Nothing -> return ()-         Just (ConfirmProjectDelete pname) -> toFM $ DelProject pname-         Just (ConfirmLocationDelete pname l) ->-           do toFM $ DelLocation pname l-              p <- gets getCurrentProject -- updated by DelLocation above-              modify (onPane @Location %~ updatePane p)-         Just (ConfirmNoteDelete pname locn nt) ->-           do toFM $ DelNote pname locn nt-              cl <- gets getCurrentLocation -- updated by DelNote-              let mbl = do (_,mbl') <- cl-                           mbl'-              modify (onPane @Note %~ updatePane mbl)-         Just (ConfirmLoad fp) -> do-           s <- get-           s' <- s & onPane @FileMgrPane %%~ fileMgrReadProjectsFile fp-           put s'-         Just ConfirmQuit -> lift $ lift halt--handleNewProject :: PostOpM ()-handleNewProject = do-  let inpOp :: (PaneState AddProjPane MyWorkEvent -> a) -> PostOpM a-      inpOp o = gets (view $ onPane @AddProjPane . to o)-  transition <- ask-  changed <- gets (exitedModal @AddProjPane transition)-  when changed $ do-    (mbOld, mbNewProj) <- inpOp projectInputResults-    case mbNewProj of-         Just newProj ->-           modify $ onPane @FileMgrPane %~ updatePane (UpdProject mbOld newProj)-         Nothing -> return ()--handleProjectChanges :: PostOpM ()-handleProjectChanges = lift $ do-  (changed,prjs) <- gets getProjects-  case changed of-    Left cnfrm -> do modify $ \s ->-                       if not $ s ^. onPane @Confirm . to isConfirmationActive-                       then s-                            & onPane @Confirm %~ showConfirmation cnfrm-                            & onPane @FileMgrPane %~ updatePane AckProjectChanges-                            & focusRingUpdate myWorkFocusL-                       else s-    Right True ->-      modify (   (onPane @Projects %~ updatePane prjs)-               . (onPane @FileMgrPane %~ updatePane AckProjectChanges)-             )-    Right False -> return ()---handleProjectChange :: PostOpM (Maybe Project)-handleProjectChange = do-  mbp <- gets getCurrentProject -- from ProjList pane-  pnm <- gets (fmap fst . selectedLocation) -- from Location pane-  let mustUpdate = pnm /= (name <$> mbp)-  when mustUpdate $ do modify $ onPane @Location %~ updatePane mbp-                       tell [True]-  return mbp--handleLocationInput :: Maybe Project -> PostOpM (Maybe Project)-handleLocationInput mbPrj = do-  let inpOp :: (PaneState LocationInputPane MyWorkEvent -> a) -> PostOpM a-      inpOp o = lift $ gets (view $ onPane @LocationInputPane . to o)-  transition <- ask-  changed <- gets (exitedModal @LocationInputPane transition)-  if changed-    then do (mbOldL, mbNewLoc) <- inpOp locationInputResults-            case (mbNewLoc, mbPrj) of-              (Just newLoc, Just p) -> do-                p' <- applyProjLocSync mbOldL p newLoc-                let u = UpdProject Nothing p'-                modify (   (onPane @FileMgrPane %~ updatePane u)-                         . (onPane @Location %~ updatePane (Just p'))-                       )-                return $ Just p'-              _ -> return mbPrj-    else return mbPrj---handleLocationChange :: Maybe Project -> PostOpM (Maybe Location)-handleLocationChange = \case-  Nothing -> return Nothing-  Just p -> do-    loc0 <- gets (fmap snd . selectedLocation) -- Location pane-    loc1 <- gets (fmap fst . selectedNote) -- Notes pane-    let mbl = DL.find ((== loc0) . Just . location) (locations p)-    unless (loc0 == loc1) $ do modify $ onPane @Note %~ updatePane mbl-                               tell [True]-    return mbl--handleNoteInput :: Maybe Project -> Maybe Location -> PostOpM ()-handleNoteInput mbPrj mbLoc = do-  let inpOp :: (PaneState NoteInputPane MyWorkEvent -> a) -> PostOpM a-      inpOp o = lift $ gets (view $ onPane @NoteInputPane . to o)-  transition <- ask-  changed <- gets (exitedModal @NoteInputPane transition)-  when changed $-    do (mbOldN, mbNewNote) <- inpOp noteInputResults-       case (mbNewNote, mbPrj, mbLoc) of-         (Just newNote, Just p, Just l) ->-           let (p',l') = updateNote mbOldN newNote l p-               u = UpdProject Nothing p'-           in do modify ( (onPane @FileMgrPane %~ updatePane u)-                          . (onPane @Note %~ updatePane (Just l'))-                        )-         _ -> do return ()---myWorkFocusL :: Lens' MyWorkState (FocusRing WName)-myWorkFocusL = onBaseState . coreWorkFocusL
− app/Panes/AddProj.hs 
@@ -1,321 +0,0 @@-{-# 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-            }
− app/Panes/Common/Attrs.hs 
@@ -1,20 +0,0 @@-module Panes.Common.Attrs where--import Data.Text ( Text )-import Brick-import Brick.Widgets.Border-import Brick.Widgets.Border.Style--import Defs----- | Adds a border with a title to the current widget.  First argument is True if--- the current widget has focus.-titledB :: Bool -> Text -> Widget WName -> Widget WName-titledB fcsd text =-  let ttlAttr = if fcsd then withAttr (attrName "Selected") else id-  in borderWithLabel (ttlAttr $ txt text)---modalB :: Text -> Widget WName -> Widget WName-modalB t = withBorderStyle unicodeBold . borderWithLabel (txt t)
− app/Panes/Common/Inputs.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}--module Panes.Common.Inputs-  -- (-  -- )-where--import           Brick hiding ( Location )-import           Brick.Forms-import           Control.Applicative ( (<|>) )-import           Control.Lens-import           Control.Monad ( guard )-import           Control.Monad.IO.Class ( MonadIO, liftIO )-import qualified Data.List as DL-import           Data.Text ( Text )-import qualified Data.Text as T-import           Data.Time.Calendar ( Day, fromGregorianValid )-import           Path ( parseAbsDir )-import           Path.IO ( doesDirExist, doesDirExist )-import           Text.Read ( readMaybe )--import           Defs----headText :: [Text] -> Text-headText = \case-  [] -> ""-  (o:_) -> o---textToDay :: Text -> Maybe Day-textToDay t =-  case T.split (`T.elem` "-/") t of-    [y,m,d] ->-      let validYear x = if x < (1800 :: Integer) then x + 2000 else x-          validMonth x = not (x < 1 || x > (12 :: Int))-          validDayOfMonth x = not (x < 1 || x > (31 :: Int))-          months = [ "january", "february", "march", "april"-                   , "may", "june", "july", "august"-                   , "september", "october", "november", "december"-                   ]-          ml = T.toLower m-          matchesMonth x = or [ ml == x, ml == T.take 3 x]-      in do y' <- validYear <$> readMaybe (T.unpack y)-            m' <- readMaybe (T.unpack m)-                  <|> (snd <$> (DL.find (matchesMonth . fst) $ zip months [1..]))-            guard (validMonth m')-            d' <- readMaybe (T.unpack d)-            guard (validDayOfMonth d')-            fromGregorianValid y' m' d'-    _ -> Nothing---locationInput :: [Location]-              -> Maybe Location-              -> Bool-              -> Lens' s LocationSpec-              -> s-              -> FormFieldState s e WName-locationInput locs mbLoc blankAllowed stateLens =-  let validate = \case-        [] -> if blankAllowed-              then Just (RemoteSpec "")-              else Nothing-        (l:_) ->-          let lr = RemoteSpec l-              ll = parseAbsDir $ T.unpack l-              ls = T.unpack l-          in if or-                [-                  -- Should not match any existing location-                  and [ ls `elem` (show . location <$> locs)-                      , maybe True ((ls /=) . show . location) mbLoc-                      ]--                  -- Check blank v.s. allowed and should be an absolute path if-                  -- it looks like a local path-                , and [ not blankAllowed-                      , maybe (isLocationTextLocal (T.pack ls)) (const False) ll-                      ]-                ]-             then Nothing  -- invalid-             else Just $ maybe lr LocalSpec ll-  in editField stateLens (WName "New Location") (Just 1)-     (T.pack . show) validate (txt . headText) id---validateLocationInput :: MonadIO m => Bool -> LocationSpec -> m (WName, Bool)-validateLocationInput blankAllowed l =-  let tgt = WName "New Location"-      ls = T.pack $ show l-  in if blankAllowed && T.null ls-     then return (tgt, True)-     else case l of-            LocalSpec lp -> (tgt,) <$> (liftIO $ doesDirExist lp)-            RemoteSpec _ -> return (tgt, True)---mbDateInput :: Lens' s (Maybe Day)-            -> s-            -> FormFieldState s e WName-mbDateInput stateLens =-  let validate = \case-        ("":_) -> Just Nothing-        (l:_) -> Just <$> textToDay l-        _ -> Nothing-      dayInit = maybe "" (T.pack . show)-      dayRender = txt . headText-  in editField stateLens (WName "Location Date (Y-M-D)")-     (Just 1) dayInit validate dayRender id
− app/Panes/Common/QQDefs.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module Panes.Common.QQDefs where--import Data.String-import Language.Haskell.TH ( ExpQ )-import Language.Haskell.TH.Quote---sq :: QuasiQuoter-sq = QuasiQuoter extractor-     (error "no q patterns")-     (error "no q types")-     (error "no q dec")--extractor :: String -> ExpQ-extractor s =-  case inSeps $ filter (/= '\r') s of-    Post a -> [|fromString a|]-    Pre _ -> error $ "No starting line found"-    MatchLine -> error $ "Only starting line found"-    Pass _ -> error $ "No ending line found"---data QState = Pre String | MatchLine | Pass String | Post String--inSeps :: String -> QState-inSeps =-  let sep = "\n----"-      sepl = length sep-      nxtC :: QState -> Char -> QState-      nxtC (Pre p) c = let p' = c : p-                           l = length p'-                       in if reverse p' == take l sep-                          then if l == sepl then MatchLine else Pre p'-                          else Pre $ take (sepl-1) p'-      nxtC MatchLine c = if '\n' == c then Pass "" else MatchLine-      nxtC (Pass s) c = let s' = c : s-                            sl = reverse $ take sepl s'-                        in if sl == sep-                           then Post (reverse $ drop sepl s')-                           else Pass s'-      nxtC (Post s) _ = Post s-    in foldl nxtC (Pre "")
− app/Panes/Confirmation.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Panes.Confirmation-  (-    isConfirmationActive-  , getConfirmedAction-  , showConfirmation-  )-where--import           Brick-import           Brick.Panes-import           Brick.Widgets.Dialog-import           Control.Lens-import           Data.Maybe ( isJust )-import qualified Data.Sequence as Seq-import qualified Graphics.Vty as Vty--import           Defs---instance Pane WName MyWorkEvent Confirm where-  data (PaneState Confirm MyWorkEvent) = Cf { cD :: Maybe (Dialog Bool)-                                            , cW :: Maybe Confirm-                                            }-  type (DrawConstraints Confirm s WName) = ( HasFocus s WName )-  initPaneState _ = Cf Nothing Nothing-  drawPane ps _ =-    let draw d = renderDialog d ( padBottom (Pad 1)-                                  $ padLeft (Pad 1)-                                  $ padRight (Pad 1)-                                  $ strWrap $ maybe "Really?" show $ cW ps)-    in draw <$> cD ps-  focusable _ ps = case cD ps of-                     Nothing -> mempty-                     Just _ -> Seq.fromList [ WName "Confirmation" ]-  handlePaneEvent _ = \case-    Vty.EvKey Vty.KEsc [] -> \_ -> return $ Cf Nothing Nothing-    Vty.EvKey Vty.KEnter [] -> \ps -> case cD ps of-      Nothing -> return ps  -- shouldn't happen-      Just d -> return $ ps { cD = Nothing-                            , cW = case dialogSelection d of-                                     Just True -> cW ps-                                     _ -> Nothing-                            }-    ev -> cDL . _Just %%~ \w -> nestEventM' w (handleDialogEvent ev)-  type (UpdateType Confirm) = Maybe Confirm-  updatePane mbCnf ps = ps { cW = mbCnf }---cDL :: Lens' (PaneState Confirm MyWorkEvent) (Maybe (Dialog Bool))-cDL = lens cD (\s v -> s { cD = v })----- | Returns true if the Confirmation modal is active and being displayed.  This--- is primarily used for detecting the transition from displayed -> not displayed--- which indicates the user made a decision.-isConfirmationActive :: PaneState Confirm MyWorkEvent -> Bool-isConfirmationActive = isJust . cD----- | Retrieve the confirmation, if there is one.------ Verifies that the state is valid for providing confirmation.  The confirmation--- status is cleared by this action in the returned pane state.-getConfirmedAction :: PaneState Confirm MyWorkEvent-                   -> (PaneState Confirm MyWorkEvent, Maybe Confirm)-getConfirmedAction ps = do-  case (cD ps, cW ps) of-    (Nothing, Just cnf) -> (ps { cW = Nothing }, Just cnf)-    _ -> (ps, Nothing)----- | Activate the confirmation modal with the provided Confirm message and--- action.-showConfirmation :: Confirm-                 -> PaneState Confirm MyWorkEvent-                 -> PaneState Confirm MyWorkEvent-showConfirmation for _ =-  let d = dialog Nothing -- (Just $ show for)-          (Just (1, [ ("OK", True), ("Cancel", False) ]))-          70  -- max width of dialog-  in Cf (Just d) (Just for)
− app/Panes/FileMgr.hs 
@@ -1,367 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Panes.FileMgr-  (-    FileMgrPane-  , FileMgrOps(..)-  , initFileMgr-  , showFileMgr-  , isFileMgrActive-  , fileMgrReadProjectsFile-  , unsavedChanges-  , fileMgrNotices-  )-where--import           Brick hiding ( Location )-import           Brick.Panes-import           Brick.Widgets.Center-import qualified Brick.Widgets.Core as BC-import           Brick.Widgets.FileBrowser-import qualified Control.Exception as X-import           Control.Lens-import           Control.Monad ( unless )-import           Control.Monad.IO.Class ( MonadIO, liftIO )-import           Data.Aeson ( eitherDecode, encode )-import qualified Data.ByteString.Lazy as BS-import           Data.Maybe ( catMaybes )-import           Data.Maybe ( isJust )-import qualified Data.Sequence as Seq-import qualified Graphics.Vty as Vty-import           Path ( Path, Abs, File, (</>), parseAbsFile-                      , relfile, reldir, parent, toFilePath )-import           Path.IO ( createDirIfMissing, doesFileExist-                         , XdgDirectory(XdgData), getXdgDir )--import           Defs-import           Defs.JSON ()-import           Panes.Common.Attrs-import           Sync---data FileMgrPane--data FileMgrOps = AckProjectChanges-                | UpdProject (Maybe ProjectName) Project -- add/replace project-                | DelProject ProjectName-                | DelLocation ProjectName LocationSpec-                | DelNote ProjectName LocationSpec NoteTitle--instance Pane WName MyWorkEvent FileMgrPane where-  data (PaneState FileMgrPane MyWorkEvent) =-    FB { fB :: Maybe (FileBrowser WName)-         -- ^ A Nothing value indicates the modal is not currently active-       , myProjects :: Projects-         -- ^ Current loaded set of projects-       , myProjFile :: Maybe (Path Abs File)-       , projsChanged :: Either Confirm Bool-         -- ^ True when myProjects has been updated; clear this via updatePane-       , unsavedChanges :: Bool-         -- ^ True when myProjects has been changed since the last load-       , errMsg :: String-         -- ^ Internal error message to display in the FileMgr modal-       , fmgrMsgs :: [ Widget WName ]-         -- ^ Messages to display when the FileMgr modal exits-       }-  type (DrawConstraints FileMgrPane s WName) = ( HasFocus s WName )-  type (EventConstraints FileMgrPane e) = ( HasFocus e WName )-  initPaneState _ = FB Nothing (Projects mempty) Nothing (Right False)-                    False "" mempty-  drawPane ps gs = drawFB ps gs <$> fB ps-  focusable _ ps = case fB ps of-                     Nothing -> mempty-                     Just _ -> Seq.fromList $ catMaybes-                               [-                                 Just $ WName "FMgr:Browser"-                               , const (WName "FMgr:SaveBtn") <$> myProjFile ps-                               , if isDirSelected ps-                                 then Nothing-                                 else Just $ WName "FMgr:SaveAsBtn"-                               ]-  handlePaneEvent bs ev ts =-    let isSearching = maybe False fileBrowserIsSearching (ts^.fBrowser)-    in case ev of-      Vty.EvKey Vty.KEsc [] | not isSearching -> return $ ts & fBrowser .~ Nothing-      Vty.EvKey (Vty.KChar 's') [Vty.MCtrl] -> do-        ts' <- case myProjFile ts of-          Just fp -> fileMgrSaveProjectsFile fp ts-          Nothing ->-            -- Ctrl-S dismisses the FileMgr window, even on failure-            return ts-        return $ ts'-          & exitMsgsL <>~ (if null (ts ^. errMsgL) then []-                           else [ withAttr a'Error $ str $ ts ^. errMsgL])-          & fBrowser .~ Nothing-      _ -> case bs^.getFocus of-             Focused (Just (WName "FMgr:Browser")) -> handleFileLoadEvent ev ts-             Focused (Just (WName "FMgr:SaveAsBtn")) -> handleFileSaveEvent ev ts-             Focused (Just (WName "FMgr:SaveBtn")) ->-               case myProjFile ts of-                 Just fp -> fileMgrSaveProjectsFile fp ts-                 Nothing -> return ts-             _ -> return ts-  type (UpdateType FileMgrPane) = FileMgrOps-  updatePane = \case-    AckProjectChanges ->-      \ps -> ps { projsChanged = Right False, fmgrMsgs = mempty }-    UpdProject mbOldNm prj ->-      (myProjectsL %~ updateProject mbOldNm prj)-      . (projsChangedL .~ Right True)-      . (unsavedChangesL .~ True)-    DelProject pname ->-      (myProjectsL %~ Projects . filter ((/= pname) . name) . projects)-      . (projsChangedL .~ Right True)-      . (unsavedChangesL .~ True)-    DelLocation pname locn ->-      let rmvLoc p = if name p == pname-                     then p { locations = filter (not . thisLoc) $ locations p }-                     else p-          thisLoc = ((== locn) . location)-      in (myProjectsL %~ Projects . fmap rmvLoc . projects)-         . (projsChangedL .~ Right True)-         . (unsavedChangesL .~ True)-    DelNote pname locn nt ->-      let rmvNote p = if name p == pname-                      then p { locations = rmvNote' <$> locations p }-                      else p-          rmvNote' l = if location l == locn-                       then l { notes = filter (not . thisNote) $ notes l }-                       else l-          thisNote = ((== nt) . noteTitle)-      in (myProjectsL %~ Projects . fmap rmvNote . projects)-         . (projsChangedL .~ Right True)-         . (unsavedChangesL .~ True)---fBrowser :: Lens' (PaneState FileMgrPane MyWorkEvent) (Maybe (FileBrowser WName))-fBrowser f ps = (\n -> ps { fB = n }) <$> f (fB ps)--myProjectsL :: Lens' (PaneState FileMgrPane MyWorkEvent) Projects-myProjectsL f wc = (\n -> wc { myProjects = n }) <$> f (myProjects wc)--myProjFileL :: Lens' (PaneState FileMgrPane MyWorkEvent) (Maybe (Path Abs File))-myProjFileL f wc = (\n -> wc { myProjFile = n }) <$> f (myProjFile wc)--projsChangedL :: Lens' (PaneState FileMgrPane MyWorkEvent) (Either Confirm Bool)-projsChangedL f wc = (\n -> wc { projsChanged = n }) <$> f (projsChanged wc)--unsavedChangesL :: Lens' (PaneState FileMgrPane MyWorkEvent) Bool-unsavedChangesL = lens unsavedChanges (\wc n -> wc { unsavedChanges = n })--errMsgL :: Lens' (PaneState FileMgrPane MyWorkEvent) String-errMsgL f wc = (\n -> wc { errMsg = n }) <$> f (errMsg wc)--exitMsgsL :: Lens' (PaneState FileMgrPane MyWorkEvent) [ Widget WName ]-exitMsgsL f wc = (\n -> wc { fmgrMsgs = n }) <$> f (fmgrMsgs wc)--isFileMgrActive :: PaneState FileMgrPane MyWorkEvent -> Bool-isFileMgrActive = isJust . fB--fileMgrNotices :: Lens' (PaneState FileMgrPane MyWorkEvent) [ Widget WName ]-fileMgrNotices = exitMsgsL--isDirSelected :: PaneState FileMgrPane MyWorkEvent -> Bool-isDirSelected ps =-  case fileBrowserCursor =<< fB ps of-    Just fi ->-      case fileStatusFileType <$> fileInfoFileStatus fi of-        Right (Just Directory) -> True-        Right (Just SymbolicLink) -> case fileInfoLinkTargetType fi of-                                       Just Directory -> True-                                       _ -> False-        _ -> False-    Nothing -> False---instance ( PanelOps FileMgrPane WName MyWorkEvent panes MyWorkCore-         , HasProjects (PaneState FileMgrPane MyWorkEvent)-         )-  => HasProjects (Panel WName MyWorkEvent MyWorkCore panes) where-  getProjects = getProjects . view (onPane @FileMgrPane)--instance HasProjects (PaneState FileMgrPane MyWorkEvent) where-  getProjects ps = (projsChanged ps, myProjects ps)---drawFB :: DrawConstraints FileMgrPane drawstate WName-       => PaneState FileMgrPane MyWorkEvent-       -> drawstate -> FileBrowser WName -> Widget WName-drawFB ps ds b =-  let width = 70-      fcsd = ds^.getFocus.to focused-      browserFocused = fcsd == Just (WName "FMgr:Browser")-      isDir = isDirSelected ps-      browserPane fb =-        vLimitPercent 55 $ hLimitPercent width-        $ titledB browserFocused "Choose a file"-        $ renderFileBrowser browserFocused fb-      helpPane =-        let esact = if browserFocused-                    then if isDir then "change directory" else "load file"-                    else "save"-        in padTop (BC.Pad 1) $ hLimitPercent width $ vBox-           [ hCenter $ txt "/: search, Ctrl-C or Esc: cancel search"-           , hCenter $ txt $ "Enter/Space: " <> esact-           , hCenter $ txt "TAB: select Save/Load options"-           , hCenter $ txt "ESC: quit"-           ]-      errDisplay fb = case fileBrowserException fb of-                        Nothing -> if null $ errMsg ps-                                   then emptyWidget-                                   else hLimitPercent width-                                        $ withDefAttr a'Error-                                        $ strWrap $ errMsg ps-                        Just e -> hLimitPercent width-                                  $ withDefAttr a'Error-                                  $ strWrap-                                  $ X.displayException e-      savePane = padTop (Pad 1)-                 $ vBox-                 [-                   let a = if fcsd == Just (WName "FMgr:SaveBtn")-                           then withAttr a'Selected-                           else if null f then withAttr a'Disabled else id-                       f = myProjFile ps-                       btxt = case f of-                                Nothing -> " "-                                Just x -> "[SAVE] " <> show x-                   in a $ str btxt-                 , if isDir-                   then withAttr a'Disabled $ str "[SAVE]"-                   else let a = if fcsd == Just (WName "FMgr:SaveAsBtn")-                                then withAttr a'Selected-                                else id-                            btxt =-                              case fileBrowserCursor =<< fB ps of-                                Just fi -> "[SAVE] " <> fileInfoFilePath fi-                                Nothing -> "[SAVE]"-                        in a $ str btxt-                 ]-  in centerLayer (browserPane b <=> errDisplay b <=> savePane <=> helpPane)---handleFileLoadEvent :: Vty.Event-                    -> PaneState FileMgrPane MyWorkEvent-                    -> EventM WName es (PaneState FileMgrPane MyWorkEvent)-handleFileLoadEvent ev ts =-  case ts^.fBrowser of-    Just fb -> do-      b <- nestEventM' fb $ handleFileBrowserEvent ev-      let selectFile =-            case fileBrowserCursor b of-              Nothing -> return $ ts & fBrowser .~ Just b  -- navigation-              Just f ->-                case parseAbsFile $ fileInfoFilePath f of-                  Just fp -> if unsavedChanges ts-                             then let msg = ConfirmLoad fp-                                  in return $ ts-                                     & projsChangedL .~ Left msg-                                     & fBrowser .~ Nothing-                                     -- KWQ: show confirmation dialog without dismissing file dialog?  (modal dialog stacking)-                             else (fBrowser .~ Nothing)-                                  <$> fileMgrReadProjectsFile fp ts-                  Nothing ->-                    -- Current selection is a directory; cannot load a directory,-                    -- so just allow the fBrowser to change to that directory.-                    return $ ts & fBrowser .~ Just b-      case ev of-        Vty.EvKey Vty.KEnter [] -> selectFile-        Vty.EvKey (Vty.KChar ' ') [] -> selectFile -- override filebrowser's default multi-select ability-        _ -> return $ ts & fBrowser .~ Just b & errMsgL .~ ""-    Nothing -> return ts  -- shouldn't happen---handleFileSaveEvent :: Vty.Event-                    -> PaneState FileMgrPane MyWorkEvent-                    -> EventM WName es (PaneState FileMgrPane MyWorkEvent)-handleFileSaveEvent ev ts =-  case fileBrowserCursor =<< ts^.fBrowser of-    Nothing -> return ts-    Just f ->-      case ev of-        Vty.EvKey Vty.KEnter [] -> doSave f-        Vty.EvKey (Vty.KChar ' ') [] -> doSave f-        _ -> return ts-  where-    doSave f = case parseAbsFile $ fileInfoFilePath f of-                 Just fp -> fileMgrSaveProjectsFile fp ts-                 Nothing -> return $ ts & errMsgL .~ dirErr-    dirErr = "Cannot save to a directory: please select a file"---ensureDefaultProjectFile :: IO (Path Abs File)-ensureDefaultProjectFile = do-  dataDir <- getXdgDir XdgData $ Just [reldir|mywork|]-  createDirIfMissing True dataDir-  let pFile = dataDir </> [relfile|projects.json|]-  e <- doesFileExist pFile-  unless e $ BS.writeFile (toFilePath pFile) ""-  return pFile----- | Called to initialize the FileMgr at startup.  Reads the default Projects--- file.-initFileMgr :: PaneState FileMgrPane MyWorkEvent-            -> IO (PaneState FileMgrPane MyWorkEvent)-initFileMgr ps = do-  f <- ensureDefaultProjectFile-  ps' <- fileMgrReadProjectsFile f ps-  let e = ps' ^. errMsgL-  unless (null e) $ error e-  return ps'---readProjectsFile :: MonadIO m => Path Abs File -> m (Either String Projects)-readProjectsFile fp = do-  newprjs <- eitherDecode <$> liftIO (BS.readFile $ toFilePath fp)-  case newprjs of-    Right prjs -> Right . Projects <$> mapM syncProject (projects prjs)-    e@(Left _) -> return e--fileMgrReadProjectsFile :: MonadIO m-                        => Path Abs File-                        -> PaneState FileMgrPane MyWorkEvent-                        -> m (PaneState FileMgrPane MyWorkEvent)-fileMgrReadProjectsFile fp ps = readProjectsFile fp >>= \case-  Left er -> return $ ps & errMsgL .~ er-  Right prjs -> return $ ps-                & myProjectsL .~ prjs-                & myProjFileL .~ Just fp-                & projsChangedL .~ Right True-                & unsavedChangesL .~ False-                & exitMsgsL <>~ [ withAttr a'Notice $ str $ "Loaded " <> show fp ]---fileMgrSaveProjectsFile :: MonadIO m-                        => Path Abs File-                        -> PaneState FileMgrPane MyWorkEvent-                        -> m (PaneState FileMgrPane MyWorkEvent)-fileMgrSaveProjectsFile fp ps =-  do liftIO $ BS.writeFile (toFilePath fp) (encode $ myProjects ps)-     return $ ps-       & fBrowser .~ Nothing-       & myProjFileL .~ Just fp-       & unsavedChangesL .~ False-       & exitMsgsL <>~ [ withAttr a'Notice $ str $ "Wrote " <> show fp ]---- | Called to display the FileMgr modal pane to allow the user to Load or Save.-showFileMgr :: PaneState FileMgrPane MyWorkEvent-            -> IO (PaneState FileMgrPane MyWorkEvent)-showFileMgr prev =-  case prev ^. fBrowser of-    Just _ -> return prev-    Nothing -> do-      let n = WName "FMgr:Browser"-      dataDir <- parent <$> ensureDefaultProjectFile-      fb <- newFileBrowser selectNonDirectories n (Just $ toFilePath dataDir)-      return $ prev & fBrowser .~ Just fb
− app/Panes/Help.hs 
@@ -1,141 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-}--module Panes.Help-  ( HelpPane(..)-  , initHelp-  )-where--import           Brick-import           Brick.Panes-import           Brick.Widgets.Center-import qualified Brick.Widgets.Core as BC-import qualified Data.Text as T-import qualified Graphics.Vty as Vty--import           Defs-import           Panes.Common.Attrs-import           Panes.Common.QQDefs---data HelpPane = HelpPane--instance Pane WName appEv HelpPane where-  data (PaneState HelpPane appEv) = H Bool-  initPaneState _ = H False-  focusable _ (H ps) = focus1If (WName "Help") ps-  drawPane (H ps) _ = if ps then Just drawHelp else Nothing-  handlePaneEvent _ ev ps = handleHelpEvent ps ev---initHelp :: PaneState HelpPane appEv-initHelp = H True---drawHelp :: Widget WName-drawHelp =-  let hsize = 70-      infoPane = vLimitPercent 80 $ hLimitPercent hsize-                 $ modalB "MyWork Help"-                 $ withVScrollBarHandles-                 $ withVScrollBars OnRight-                 $ viewport (WName "HelpScroll") Vertical-                 $ helpInfo-      helpInfo = vBox (txtWrap . (<> " ") <$> T.lines helpText)-      helpPane = padTop (BC.Pad 1) $ hLimitPercent hsize $ vBox-        [ hCenter $ txt "Arrow Up/Arrow Down : scroll vertically by lines"-        , hCenter $ txt "Page Up/Page Down : scroll vertically by page"-        , hCenter $ txt "ESC: quit"-        ]-  in centerLayer (infoPane <=> helpPane)---handleHelpEvent :: PaneState HelpPane appEv -> Vty.Event-                -> EventM WName es (PaneState HelpPane appEv)-handleHelpEvent hs = \case-  Vty.EvKey Vty.KEsc [] -> return $ H False-  Vty.EvKey Vty.KUp [] ->-    vScrollBy (viewportScroll (WName "HelpScroll")) (-1) >> return hs-  Vty.EvKey Vty.KDown [] ->-    vScrollBy (viewportScroll (WName "HelpScroll")) 1 >> return hs-  Vty.EvKey Vty.KPageUp [] ->-    vScrollBy (viewportScroll (WName "HelpScroll")) (-10) >> return hs-  Vty.EvKey Vty.KPageDown [] ->-    vScrollBy (viewportScroll (WName "HelpScroll")) 10 >> return hs-  _ -> return hs---helpText :: T.Text-helpText = [sq|-This is the displayed help information------------------------------------------The MyWork application is designed to help keep track of the things you are-working on.  This is particularly useful in a workflow where multiple projects-are being worked on, or where multiple instances of a particular project are-being worked on, with different efforts (bugfixes, features) in the different-instances.  Mentally switching contexts between the different projects and-locations can be a challenge, especially when trying to remember what was being-done in a particular location, or the relationship of that location to other-locations.--The MyWork application is a simple application that organizes and remembers-these different projects and locations, along with any notes you'd like to-attach to each location.  When switching from working on one thing to the next,-this application can provide a place to make a note about what was in-progress-in the current location, and read about the status of the new location to-reconstruct the context for that location.--Locations can be local directories or network VCS locations (e.g. github).-Local locations can provide more information, but it is helpful to also track-the public or remote locations for projects.--The display is divided into the following primary parts:--    +--------------------------------+-    | Summary                        |-    |--------------------------------|-    | Projects | Locations           |-    |          |                     |-    |          |                     |-    |          |                     |-    |          |---------------------|-    |          | Location Notes      |-    |          |                     |-    |          |                     |-    |--------------------------------|-    |           Controls             |-    +--------------------------------+---   TAB / Shift+TAB     -- switch between active panes-   Ctrl-S              -- save (to previously loaded file, if any)-   Ctrl-Q              -- quit--The full note area can be scrolled by using the Ctrl key in conjunction with-the arrow and page-up/page-down keys.--Each Project can have zero or more locations where that Project exists.  These-locations can be local directories, remote URLs (e.g. github), or any other-desired text.  Any local directory location may be scanned to find additional-locations automatically.  Each location can optionally have a date, which is-usually the date of the last update (local directory locations will-automatically update the date with the last modified date of the top-level-directory); the date is user information and locations will be sorted primarily-by date and secondarily by location text.--Each Location is associated with zero or more Notes.  Each Note is a free-form-text paragraph, whose first line acts as the note "title".  In addition to notes-entered by the user in mywork, if the location is local and contains an-"@MyWork" directory, any file in that directory with the .txt extension will be-added as a note.--The Summary area shows the total number of projects (by role), as well as the-date range of locations.-------------------------------------------|]
− app/Panes/Location.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Panes.Location () where--import           Brick hiding ( Location, on )-import           Brick.Panes-import           Brick.Widgets.List-import           Control.Lens-import           Data.Function ( on )-import qualified Data.List as DL-import           Data.Maybe ( fromMaybe )-import           Data.Time.Calendar-import qualified Data.Vector as V--import           Defs---instance Pane WName MyWorkEvent Location where-  data (PaneState Location MyWorkEvent) =-    L { lL :: List WName (LocationSpec, Bool, Maybe Day)-      , lP :: Maybe Project-      }-  type (InitConstraints Location s) = ( HasSelection s, HasProjects s )-  type (DrawConstraints Location s WName) = ( HasFocus s WName, HasSelection s )-  type (UpdateType Location) = Maybe Project-  initPaneState gs =-    let l = L (list (WName "Loc:LList") mempty 1) Nothing-        update x = do p <- selectedProject gs-                      prj <- DL.find ((== p) . name)-                                     (projects $ snd $ getProjects gs)-                      return $ updatePane (Just prj) x-    in fromMaybe l $ update l-  drawPane ps gs =-    let isFcsd = gs^.getFocus.to focused == Just WLocations-        rndr (l,v,d) =-          let lattr = if v then id else withAttr a'Error-          in (lattr (str $ show $ l)-              <+> vLimit 1 (fill ' ')-              <+> (if v-                    then str $ maybe "*" show d-                    else withAttr a'Error $ str "INVALID"-                  )-             )-                     -- <=> str " "-    in Just-       $ withVScrollBars OnRight-       $ renderList (const rndr) isFcsd (lL ps)-  focusable _ ps = focus1If WLocations-                   $ not $ null $ listElements $ lL ps-  handlePaneEvent _ ev = lList %%~ \w -> nestEventM' w (handleListEvent ev)-  updatePane = \case-    Nothing -> (lList %~ listReplace mempty Nothing) . (lProj .~ Nothing)-    Just prj -> \ps ->-      let ents = [ (location l, locValid l, locatedOn l)-                 | l <- locations prj ]-          np = if null ents then Nothing else Just 0-          curElem = maybe id listMoveTo $ listSelected $ lL ps-          locOrd (l,v,d) = (d,l,v)-          sortLocs = DL.reverse . DL.sortBy (compare `on` locOrd)-      in ps-         & lList %~ (curElem . listReplace (V.fromList $ sortLocs ents) np)-         & lProj .~ Just prj---lList :: Lens' (PaneState Location MyWorkEvent)-         (List WName (LocationSpec, Bool, Maybe Day))-lList f ps = (\n -> ps { lL = n }) <$> f (lL ps)--lProj :: Lens' (PaneState Location MyWorkEvent) (Maybe Project)-lProj f ps = (\n -> ps { lP = n }) <$> f (lP ps)---instance HasLocation (PaneState Location MyWorkEvent) where-  selectedLocation ps = do-    prj <- lP ps-    curr <- listSelectedElement $ lL ps-    return ( name prj, (\(l,_,_) -> l) $ snd curr )
− app/Panes/LocationInput.hs 
@@ -1,171 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Panes.LocationInput-  (-    LocationInputPane-  , initLocInput-  , isLocInputActive-  , locationInputResults-  )-where--import           Brick hiding ( Location )-import           Brick.Focus-import           Brick.Forms-import           Brick.Panes-import qualified Brick.Widgets.Center as C-import           Control.Lens-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---data LocationInputPane---data NewLoc = NewLoc { _nlName :: LocationSpec-                     , _nlDay :: Maybe Day-                     }--makeLenses ''NewLoc---blankNewLoc :: NewLoc-blankNewLoc = NewLoc (RemoteSpec "") Nothing--type LocForm = Form NewLoc MyWorkEvent WName--instance Pane WName MyWorkEvent LocationInputPane where-  data (PaneState LocationInputPane MyWorkEvent) = NL { nLF :: Maybe LocForm-                                                        -- Just == pane active-                                                      , nLoc :: Maybe Location-                                                      -- reset to Nothing when-                                                      -- nLF transitions Nothing-                                                      -- to Just-                                                      , nProj :: ProjectName-                                                      , nOrig :: Maybe Location-                                                      , nErr :: Maybe Text-                                                }-  type (EventType LocationInputPane WName MyWorkEvent) = BrickEvent WName MyWorkEvent-  initPaneState _ = NL Nothing Nothing (ProjectName "") Nothing Nothing-  drawPane ps _gs =-    C.centerLayer-    . modalB ((maybe "New" (const "Edit") $ nOrig ps)-              <> " " <> (let ProjectName pnm = nProj ps in T.pack $ show pnm)-              <> " Location")-    . vLimit 25-    . 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 ' ')-                  ]) <$> nLF ps-  focusable _ ps = case nLF ps of-                     Nothing -> mempty-                     Just f -> Seq.fromList $ focusRingToList $ formFocus f-  handlePaneEvent _ = \case-    VtyEvent (Vty.EvKey Vty.KEsc []) -> nLFL %%~ const (return Nothing)-    VtyEvent (Vty.EvKey (Vty.KChar 'd') [Vty.MCtrl]) -> \s ->-      let pf = s ^. nLFL-          np form = Location { location = form ^. nlName-                             , locatedOn = form ^. nlDay-                             , locValid = True  -- assumed-                             , notes = mempty-                            }-      in if maybe False allFieldsValid pf-         then do let l = np . formState <$> pf-                 return $ s & nLFL .~ Nothing & newLocation .~ l-         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 }-                & (nLFL . _Just %%~ \w -> nestEventM' w (handleFormEvent ev))---nLFL :: Lens' (PaneState LocationInputPane MyWorkEvent) (Maybe LocForm)-nLFL f s = (\n -> s { nLF = n }) <$> f (nLF s)--isLocInputActive :: PaneState LocationInputPane MyWorkEvent -> Bool-isLocInputActive = isJust . nLF---newLocation :: Lens' (PaneState LocationInputPane MyWorkEvent) (Maybe Location)-newLocation f s = (\n -> s { nLoc = n }) <$> f (nLoc s)----- | Returns the original location name (if any) and the new Location--- specification.-locationInputResults :: PaneState LocationInputPane MyWorkEvent-                     -> (Maybe LocationSpec, Maybe Location)-locationInputResults ps = (location <$> nOrig ps, nLoc ps)---validateForm :: EventM WName es (PaneState LocationInputPane MyWorkEvent)-             -> EventM WName es (PaneState LocationInputPane MyWorkEvent)-validateForm inner = do-  s <- inner-  case s ^. nLFL of-    Nothing -> return s-    Just pf ->-      do (tgt,valid) <- validateLocationInput False $ formState pf ^. nlName-         return $ s & nLFL %~ fmap (setFieldValid valid tgt)---initLocInput :: ProjectName-             -> [Location]-             -> Maybe Location-             -> PaneState LocationInputPane MyWorkEvent-             -> PaneState LocationInputPane MyWorkEvent-initLocInput projName locs mbLoc ps =-  case nLF 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-          labelWidth = 15-          nlForm =-            newForm-            [-              label "Location" @@= locationInput locs mbLoc False nlName-            , label "Date" @@= mbDateInput nlDay-            ]-            (case mbLoc of-               Nothing -> blankNewLoc-               Just l -> NewLoc { _nlName = location l-                                , _nlDay = locatedOn l-                                }-            )-      in NL { nLF = Just nlForm-            , nProj = projName-            , nLoc = Nothing-            , nOrig = mbLoc-            , nErr = Nothing-            }----- KWQ: could provide FileBrowser-like assistance for a local path--- KWQ: maybe even radio buttons: local, http, https, other
− app/Panes/Messages.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Panes.Messages-  (-    MessagesPane-  )-where--import           Brick-import           Brick.Panes-import           Control.Lens--import           Defs---data MessagesPane--instance Pane WName MyWorkEvent MessagesPane where-  data (PaneState MessagesPane MyWorkEvent) = M [Widget WName]-  type UpdateType MessagesPane = Maybe [Widget WName]-  initPaneState _ = M mempty-  drawPane (M msgs) _ = Just $ if null msgs then str " " else vBox msgs-  updatePane mbw (M msgs) = case mbw of-                              Nothing -> M mempty-                              Just ms -> M $ msgs <> ms---instance HasMessage (PaneState MessagesPane MyWorkEvent) where-  getMessage (M msgs) = msgs--instance ( PanelOps MessagesPane WName MyWorkEvent panes MyWorkCore-         , HasMessage (PaneState MessagesPane MyWorkEvent)-         )-  => HasMessage (Panel WName MyWorkEvent MyWorkCore panes) where-  getMessage = getMessage . view (onPane @MessagesPane)
− app/Panes/NoteInput.hs 
@@ -1,187 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Panes.NoteInput-  (-    NoteInputPane-  , initNoteInput-  , isNoteInputActive-  , noteInputResults-  )-where--import           Brick hiding ( Location )-import           Brick.Focus-import           Brick.Forms-import           Brick.Panes-import qualified Brick.Widgets.Center as C-import           Control.Lens-import           Control.Monad.IO.Class ( MonadIO, liftIO )-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           Data.Time.Clock ( getCurrentTime, utctDay )-import qualified Graphics.Vty as Vty--import           Defs-import           Panes.Common.Inputs-import           Panes.Common.Attrs---data NoteInputPane---data NewNote = NewNote { _nnText :: Text-                       , _nnDay :: Day-                       }--makeLenses ''NewNote---blankNewNote :: NewNote-blankNewNote = NewNote "" (toEnum 0)--type NoteForm = Form NewNote MyWorkEvent WName--instance Pane WName MyWorkEvent NoteInputPane where-  data (PaneState NoteInputPane MyWorkEvent) = NN { nNF :: Maybe NoteForm-                                                    -- Just == pane active-                                                  , nNote :: Maybe Note-                                                    -- reset to Nothing when-                                                    -- nNF transitions Nothing-                                                    -- to Just-                                                  -- KWQ , nProj :: Text-                                                  , nOrig :: Maybe Note-                                                  , nErr :: Maybe Text-                                                }-  type (EventType NoteInputPane WName MyWorkEvent) = BrickEvent WName MyWorkEvent-  initPaneState _ = NN Nothing Nothing Nothing Nothing-  drawPane ps _gs =-    C.centerLayer-    . modalB ((maybe "New" (const "Edit") $ nOrig ps)-               -- <> " " <> show (nProj ps)-               <> " Note")-    . vLimit 25-    . hLimitPercent 65-    . (\f -> vBox [ renderForm f-                  , padBottom (Pad 1) $ withAttr a'Error-                    $ maybe emptyWidget txt (nErr ps)-                  , emptyWidget-                  , vLimit 1 (fill ' ' <+> str "Ctrl-D = accept"-                              <+> fill ' ' <+> str "ESC = abort"-                              <+> fill ' ')-                  ]) <$> nNF ps-  focusable _ ps = case nNF ps of-                     Nothing -> mempty-                     Just f -> Seq.fromList $ focusRingToList $ formFocus f-  handlePaneEvent _ = \case-    VtyEvent (Vty.EvKey Vty.KEsc []) -> nNFL %%~ const (return Nothing)-    VtyEvent (Vty.EvKey (Vty.KChar 'd') [Vty.MCtrl]) -> \s ->-      let pf = s ^. nNFL-          np form = Note { note = form ^. nnText-                         , notedOn = form ^. nnDay-                         , noteSource = MyWorkDB-                         }-      in if maybe False allFieldsValid pf-         then-           return $ s & nNFL .~ Nothing & newNote .~ (np . formState <$> pf)-         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 }-                & (nNFL . _Just %%~ \w -> nestEventM' w (handleFormEvent ev))---nNFL :: Lens' (PaneState NoteInputPane MyWorkEvent) (Maybe NoteForm)-nNFL f s = (\n -> s { nNF = n }) <$> f (nNF s)--isNoteInputActive :: PaneState NoteInputPane MyWorkEvent -> Bool-isNoteInputActive = isJust . nNF---newNote :: Lens' (PaneState NoteInputPane MyWorkEvent) (Maybe Note)-newNote f s = (\n -> s { nNote = n }) <$> f (nNote s)----- | Returns the original note name (if any) and the new Note--- specification.-noteInputResults :: PaneState NoteInputPane MyWorkEvent-                 -> (Maybe NoteTitle, Maybe Note)-noteInputResults ps = (noteTitle <$> nOrig ps, nNote ps)----- KWQ: remove!?-validateForm :: EventM WName es (PaneState NoteInputPane MyWorkEvent)-             -> EventM WName es (PaneState NoteInputPane MyWorkEvent)-validateForm inner = do-  s <- inner-  case s ^. nNFL of-    Nothing -> return s-    Just _f -> return s---initNoteInput :: MonadIO m-              => [Note]-              -> Maybe Note-              -> PaneState NoteInputPane MyWorkEvent-              -> m (PaneState NoteInputPane MyWorkEvent)-initNoteInput curNotes mbNote ps = do-  now <- utctDay <$> liftIO getCurrentTime-  case nNF ps of-    Just _ -> return ps-    Nothing ->-      let label s = padBottom (Pad 1) . label' s-          label' s w = (vLimit 1 $ hLimit labelWidth-                        $ fill ' ' <+> str s <+> str ": ") <+> w-          labelWidth = 15-          nlForm =-            newForm-            [-              label "Note" @@=-              let validate = \case-                    [] -> Nothing-                    [""] -> Nothing-                    o -> let nt = noteTitle' $ T.unlines o-                         in if (nt `elem` (noteTitle <$> curNotes)-                                && (maybe True ((nt /=) . noteTitle) mbNote))-                            then Nothing  -- invalid-                            else Just $ T.intercalate "\n" o-              in editField nnText (WName "New Note")-                 Nothing-                 -- (Just 20)-                 id validate (txt . T.intercalate "\n") id-            , label "Date" @@= let validate = \case-                                     ("":_) -> Nothing-                                     (l:_) -> textToDay l-                                     _ -> Nothing-                                   dayInit = T.pack . show-                                   dayRender = txt . headText-                               in editField nnDay (WName "Note Date (Y-M-D)")-                                  (Just 1) dayInit validate dayRender id-            ]-            (case mbNote of-               Nothing -> blankNewNote { _nnDay = now }-               Just l -> NewNote { _nnText = note l-                                 , _nnDay = notedOn l-                                 }-            )-      in return $ NN { nNF = Just nlForm-                     -- , nProj = projName-                     , nNote = Nothing-                     , nOrig = mbNote-                     , nErr = Nothing-                     }
− app/Panes/Notes.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Panes.Notes () where--import           Brick hiding ( Location )-import           Brick.Panes-import           Brick.Widgets.List-import           Control.Lens-import           Control.Monad ( join )-import qualified Data.List as DL-import qualified Data.Text as T-import qualified Data.Vector as V-import qualified Graphics.Vty as Vty--import           Defs-import           Panes.Common.Inputs---instance Pane WName MyWorkEvent Note where-  data (PaneState Note MyWorkEvent) = N { nL :: List WName Note-                                        , nLoc :: Maybe Location-                                        }-  type (InitConstraints Note s) = ( HasLocation s-                                  , HasProjects s-                                  , HasSelection s-                                  )-  type (DrawConstraints Note s WName) = ( HasFocus s WName-                                        , HasLocation s-                                        )-  type (UpdateType Note) = Maybe Location-  initPaneState gs =-    let l = N (list (WName "Notes:List") mempty 1) Nothing-    in flip updatePane l $ join $ snd <$> getCurrentLocation gs-  updatePane mbl ps =-    let curElem = maybe id listMoveTo $ listSelected $ nL ps-        nl =-          case mbl of-            Just l -> curElem-                      . listReplace (V.fromList $ sortNotes $ notes l) (Just 0)-            Nothing -> listReplace mempty Nothing-        sortNotes = DL.reverse . DL.sort -- most recent first-    in N (nl (nL ps)) mbl-  drawPane ps gs =-    let isFcsd = gs^.getFocus.to focused == Just WNotes-        rndr nt = str (show (notedOn nt) <> " -- ")-                  <+> txt (headText $ T.lines $ note nt)-    in Just $ vBox [ withVScrollBars OnRight-                     $ renderList (const rndr) isFcsd (nL ps)-                     -- , hBorder-                   , vLimit 1 (fill '-'-                               <+> str " vv - Full Note - vv "-                               <+> fill '-')-                   , vLimitPercent 75-                     $ withVScrollBars OnRight-                     $ viewport (WName "Notes:Scroll") Vertical-                     $ txtWrap-                     $ maybe "" (note . snd) $ listSelectedElement (nL ps)-                   ]-  focusable _ ps = focus1If WNotes $ not $ null $ listElements $ nL ps-  handlePaneEvent _ =-    let scroll o amt = \ps ->-          do _ <- o (viewportScroll (WName "Notes:Scroll")) amt-             return ps-    in \case-      --   * Scroll full note region with CTRL-up/down/page-up/page-down-      Vty.EvKey Vty.KUp [Vty.MCtrl] -> scroll vScrollBy (-1)-      Vty.EvKey Vty.KDown [Vty.MCtrl] -> scroll vScrollBy 1-      Vty.EvKey Vty.KLeft [Vty.MCtrl] -> scroll hScrollBy (-1)-      Vty.EvKey Vty.KRight [Vty.MCtrl] -> scroll hScrollBy 1-      Vty.EvKey Vty.KPageUp [Vty.MCtrl] -> scroll vScrollBy (-10)-      Vty.EvKey Vty.KPageDown [Vty.MCtrl] -> scroll vScrollBy 10-      ev -> nList %%~ \w -> nestEventM' w (handleListEvent ev)---nList :: Lens' (PaneState Note MyWorkEvent) (List WName Note)-nList f ps = (\n -> ps { nL = n }) <$> f (nL ps)---instance HasNote (PaneState Note MyWorkEvent) where-  selectedNote ps = do-    curr <- listSelectedElement $ nL ps-    locn <- nLoc ps-    return ( location locn, noteTitle $ snd curr )
− app/Panes/Operations.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Panes.Operations-  (-    OperationsPane-  )-where--import           Brick-import           Brick.Panes-import qualified Data.List as DL-import           Data.Maybe ( catMaybes )--import           Defs---data OperationsPane--instance Pane WName MyWorkEvent OperationsPane where-  data (PaneState OperationsPane MyWorkEvent) = Unused-  type (DrawConstraints OperationsPane s WName) = ( HasSelection s-                                                  , HasProjects s-                                                  , HasLocation s-                                                  , HasFocus s WName-                                                  )-  initPaneState _ = Unused-  drawPane _ gs =-    let o = opOnSelection gs-        projInd = case selectedProject gs of-                    Nothing -> withAttr a'Disabled-                    Just _ -> id-        addWhat x = case x of-                      ProjectOp -> "Project"-                      LocationOp -> "Location"-                      NoteOp -> "Note"-        ops = DL.intersperse (fill ' ')-              $ withAttr a'Operation-              <$> catMaybes-              [-                Just $ str $ "F1 Help"-              , Just $ str $ "F2 Add " <> addWhat o-              , if o == maxBound-                then Nothing-                else Just $ projInd $ str $ "F3 Add " <> addWhat (succ o)-              -- , projInd $ str "F4: Add Note"-              , Just $ projInd $ str "C-e Edit"-              , Just $ projInd $ str "Del Delete"-              , Just $ str "F9 Load/Save"-              -- , Just $ str $ "C-q Quit"-              ]-    in Just $ vLimit 1 $ str " " <+> hBox ops <+> str " "
− app/Panes/ProjInfo.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Panes.ProjInfo-  (-    ProjInfoPane-  )-where--import           Brick-import           Brick.Panes-import qualified Data.List as DL--import           Defs---data ProjInfoPane--instance Pane WName MyWorkEvent ProjInfoPane where-  data (PaneState ProjInfoPane MyWorkEvent) = Unused-  type (DrawConstraints ProjInfoPane s WName) = ( HasSelection s-                                                , HasProjects s-                                                )-  initPaneState _ = Unused-  drawPane _ gs =-    case selectedProject gs of-      Nothing -> Nothing-      Just p ->-        let mkPane prj =-              vBox-              [ withAttr a'ProjName (let ProjectName nm = p in txt nm)-                <+> vLimit 1 (fill ' ')-                <+> str "  ["-                <+> (str $ show $ group prj)-                <+> str ", "-                <+> (withAttr (roleAttr $ role prj) $ str $ show $ role prj)-                <+> str "]"-              , str "    " <+> txtWrap (description prj)-              , str " "-              , txt $ "Language: " <> languageText (language prj)-              ]-        in mkPane <$> DL.find ((== p) . name) (projects $ snd $ getProjects gs)
− app/Panes/Projects.hs 
@@ -1,87 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Panes.Projects () where--import           Brick-import           Brick.Panes-import           Brick.Widgets.Edit-import           Brick.Widgets.List-import           Control.Lens-import qualified Data.List as DL-import qualified Data.Sequence as Seq-import           Data.Text ( Text )-import qualified Data.Text as T-import qualified Data.Text.Zipper as TZ-import qualified Data.Vector as V--import           Defs---instance Pane WName MyWorkEvent Projects where-  data (PaneState Projects MyWorkEvent) = P { pL :: List WName (Role, ProjectName)-                                            , pS :: Editor Text WName-                                            , oC :: [ (Role, ProjectName) ]-                                            }-  type (InitConstraints Projects s) = ( HasProjects s )-  type (DrawConstraints Projects s WName) = ( HasFocus s WName )-  type (EventType Projects WName MyWorkEvent) = BrickEvent WName MyWorkEvent-  type (UpdateType Projects) = Projects-  initPaneState s =-    let prjs = projects $ snd $ getProjects s-        oc = DL.sort (mkListEnt <$> prjs)-        pl = list (WName "Projs:List") (V.fromList oc) 1-        ps = editor (WName "Projs:Filter") (Just 1) ""-    in P pl ps oc-  drawPane ps gs =-    let isFcsd = gs^.getFocus.to focused == Just WProjList-        renderListEnt _ (r,n) = withAttr (roleAttr r)-                                $ let ProjectName nm = n in txt nm-        lst = withVScrollBars OnRight $ renderList renderListEnt isFcsd (pL ps)-        srch = str "Search: " <+> renderEditor (txt . head) isFcsd (pS ps)-    in Just $ vBox [ lst, srch ]-  handlePaneEvent _ ev ps =-    do ps1 <- case ev of-                VtyEvent ev' ->-                  ps & pList %%~ \w -> nestEventM' w (handleListEvent ev')-                _ -> return ps-       let origSearchText = head $ ps ^. pSrch . to getEditContents-       ps2 <- ps1 & pSrch %%~ \w -> nestEventM' w (handleEditorEvent ev)-       let searchText = head $ ps2 ^. pSrch . to getEditContents-       if searchText == origSearchText-         then return ps2-         else let nmtxt ent = let ProjectName pnt = snd ent in pnt-                  nc = if T.null searchText-                       then oC ps2-                       else filter ((searchText `T.isInfixOf`) . nmtxt) (oC ps2)-                  np = if null nc then Nothing else Just 0-              in return $ ps2 & pList %~ listReplace (V.fromList nc) np-  focusable _ _ = Seq.singleton WProjList-  updatePane newprjs ps =-    let oc = DL.sort (mkListEnt <$> projects newprjs)-        curElem = maybe id listMoveTo $ listSelected $ pL ps-    in ps-       & pList %~ (curElem . listReplace (V.fromList oc) (Just 0))-       & pSrch . editContentsL %~ TZ.clearZipper-       & pOrig .~ oc---pList :: Lens' (PaneState Projects MyWorkEvent) (List WName (Role, ProjectName))-pList f ps = (\n -> ps { pL = n }) <$> f (pL ps)--pSrch :: Lens' (PaneState Projects MyWorkEvent) (Editor Text WName)-pSrch f ps = (\n -> ps { pS = n }) <$> f (pS ps)--pOrig :: Lens' (PaneState Projects MyWorkEvent) [ (Role, ProjectName) ]-pOrig f ps = (\n -> ps { oC = n }) <$> f (oC ps)--mkListEnt :: Project -> (Role, ProjectName)-mkListEnt pr = (role pr, name pr)---instance HasSelection (PaneState Projects MyWorkEvent) where-  selectedProject = fmap (snd . snd) . listSelectedElement . pL
− app/Panes/Summary.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Panes.Summary-  (-    SummaryPane-  )-where--import           Brick-import           Brick.Panes-import           Data.Maybe ( catMaybes )--import           Defs---data SummaryPane--instance Pane WName MyWorkEvent SummaryPane where-  data (PaneState SummaryPane MyWorkEvent) = Unused-  type (DrawConstraints SummaryPane s WName) = ( HasProjects s )-  initPaneState _ = Unused-  drawPane _ s = Just $ drawSummary (snd $ getProjects s)---drawSummary :: Projects -> Widget WName-drawSummary prjcts =-    let prjs = projects prjcts-        prjcnt = (str "# Projects: " <+>)-                    $ foldr ((<+>) . (<+> str ", "))-                      (str ("Total=" <> show (length prjs)))-                    [ withAttr (roleAttr r) (str $ show r)-                      <+> str "="-                      <+> str (show (length fp))-                    | r <- [minBound .. maxBound]-                    , let fp = filter (isRole r) prjs-                    , not (null fp)-                    ]-        isRole r p = r == role p-        dateRange = if null projDates-                    then str ""-                    else str (show (minimum projDates)-                              <> ".."-                              <> show (maximum projDates)-                             )-        locDates prj = catMaybes (locatedOn <$> locations prj)-        projDates = concatMap locDates prjs-    in vLimit 1-       $ if null prjs-         then str "No projects defined"-         else prjcnt <+> fill ' ' <+> dateRange
− app/Sync.hs 
@@ -1,206 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TupleSections #-}--module Sync-  -- (-  -- )-where--import           Control.Applicative ( (<|>) )-import           Control.Monad ( filterM, foldM )-import           Control.Monad.IO.Class ( MonadIO, liftIO )-import           Control.Monad.State ( evalStateT, gets, modify )-import qualified Data.HashMap.Lazy as HM-import           Data.Ini-import qualified Data.List as DL-import           Data.Maybe ( catMaybes )-import           Data.Text ( Text )-import qualified Data.Text as T-import qualified Data.Text.IO as TIO-import           Data.Time.Calendar ( Day )-import           Data.Time.Clock ( getCurrentTime, utctDay )-import           Path ( (</>), Path, Abs, Dir, relfile, reldir-                      , toFilePath, parseAbsDir, fileExtension )-import           Path.IO ( doesDirExist, doesFileExist, getModificationTime-                         , listDir )--import           Defs---data LocationStatus = LocationStatus { locExists :: Maybe Bool-                                     , otherLocs :: [ (LType, LocationSpec) ]-                                     , locNotes :: [ Note ]-                                     , lastUpd :: Maybe Day-                                     }---- KWQ: attach LType to Location more permanently to provide more info?-data LType = GitRepo GitRemote | GitFork LType | DarcsRepo-  deriving Eq--newtype GitRemote = GitRemote Text-  deriving Eq---syncLocation :: MonadIO m => Location -> m LocationStatus-                -- KWQ: should return a flag indicating whether there were changes (e.g. new locations found), so that the project itself can be labelled as "changed" with "save needed"-syncLocation l = case location l of-  LocalSpec lcl ->-    do e <- liftIO $ doesDirExist lcl-       u <- if e-            then Just . utctDay <$> liftIO (getModificationTime lcl)-            else return Nothing-       o <- getOtherLocs lcl-       nts <- getLocNotes lcl-       return $ LocationStatus { locExists = Just e-                               , otherLocs = o-                               , locNotes = nts-                               , lastUpd = u-                               }-  RemoteSpec _ -> return LocationStatus { locExists = Nothing-                                        , otherLocs = mempty-                                        , locNotes = mempty-                                        , lastUpd = Nothing-                                        }---- | Searches for other locations based on the current location.  This will find--- locations like remote git repos, darcs repos, etc.------ These locations are added permanently to the project.-getOtherLocs :: MonadIO m => Path Abs Dir -> m [ (LType, LocationSpec) ]-getOtherLocs lcl = concat <$> sequence [ getGitLocs lcl-                                       , getDarcsLocs lcl-                                       ]---getGitLocs :: MonadIO m => Path Abs Dir -> m [ (LType, LocationSpec) ]-getGitLocs lcl =-  let gitCfgFile = lcl </> [relfile|.git/config|]-      gcRemote sname cfg locs =-        case T.words sname of-          ["remote", rmt] ->-            let t = GitRepo $ GitRemote-                    -- drop surrounding double-quotes-                    $ T.drop 1 $ T.take (T.length rmt - 1) rmt-            in locs <> catMaybes-               [ (t,) . toLocSpec <$> HM.lookup "url" cfg-               , (GitFork t,) . toLocSpec <$> HM.lookup "pushurl" cfg-               ]-          _ -> locs-      toLocSpec t = maybe (RemoteSpec t) LocalSpec $ parseAbsDir $ T.unpack t-      gcProc = HM.foldrWithKey gcRemote mempty . unIni-  in do ge <- liftIO (doesFileExist gitCfgFile)-        if ge-          then do gt <- liftIO $ TIO.readFile (toFilePath gitCfgFile)-                  case parseIni gt of-                    Left _e -> return mempty -- no error reporting-                    Right gc -> return $ gcProc gc-          else return mempty---getDarcsLocs :: MonadIO m => Path Abs Dir -> m [ (LType, LocationSpec) ]-getDarcsLocs lcl =-  let darcsRepos = lcl </> [relfile|_darcs/prefs/repos|]-      mkDarcs t = ( DarcsRepo-                  , maybe (RemoteSpec t) LocalSpec $ parseAbsDir $ T.unpack t-                  )-      lclExists (_,r) = case r of-        RemoteSpec _ -> return True-        LocalSpec d -> doesDirExist d-  in do de <- liftIO (doesFileExist darcsRepos)-        if de-          then do rst <- liftIO $ TIO.readFile $ toFilePath darcsRepos-                  let rsc = mkDarcs <$> T.lines rst-                  filterM lclExists rsc-          else return mempty---getLocNotes :: MonadIO m => Path Abs Dir -> m [ Note ]-getLocNotes lcl =-  let notesDir = lcl </> [reldir|@MyWork|]-      mkFileNote nl f =-        case fileExtension f of-          Just ".txt" ->-            do nt <- liftIO $ TIO.readFile (toFilePath f)-               nd <- utctDay <$> liftIO ( getModificationTime f)-               return $ Note { note = nt-                             , notedOn = nd-                             , noteSource = ProjLoc-                             } : nl-          _ -> return nl-  in do ne <- liftIO (doesDirExist notesDir)-        if ne-          then do (_,files) <- liftIO (listDir notesDir)-                  foldM mkFileNote mempty files-          else return mempty---applyLocSync :: Day -> LocationStatus -> Location -> Location-applyLocSync now locsts loc =-  let rmtnoteTxt :: (LType, LocationSpec) -> Text-      rmtnoteTxt = \case-        (GitRepo (GitRemote n), r) ->-          "Cloned from git repo " <> tshow n <> " @ " <> tshow r-        (GitFork (GitRepo (GitRemote n)), r) ->-          "Pushing to git repo " <> tshow n <> " fork @ " <>  tshow r-        (DarcsRepo, r) -> "Synced with darcs repo @ " <> tshow r-        (_, r) -> "Related to " <> tshow r-      addRmtNoteText ol cl =-        -- n.b. instead of using updateNote, which prefers the new note, this-        -- only adds a note if there isn't already one, preferring the existing-        -- one in case it has been updated (aside from the noteTitle).-        let rnt = rmtnoteTxt ol-            rn = Note { note = rnt, notedOn = now, noteSource = MyWorkGenerated }-        in case DL.find ((noteTitle' rnt ==) . noteTitle) (notes cl) of-             Nothing -> cl { notes = rn : notes cl }-             Just _ -> cl-      loc1 = foldr addRmtNoteText loc $ otherLocs locsts-      loc2 = foldr (updateLocNote Nothing) loc1 $ locNotes locsts-  in loc2 { locValid = maybe True id $ locExists locsts-          , locatedOn = lastUpd locsts <|> locatedOn loc-          }--applyProjLocSync :: MonadIO m-                 => Maybe LocationSpec -> Project -> Location -> m Project-applyProjLocSync mbOldL_ p_ l_ = evalStateT (go mbOldL_ p_ l_) mempty-  where-    go mbOldL p l =-      gets (location l `elem`) >>= \case-      True -> return p-      False ->-        do modify (location l :)-           locsts <- syncLocation l-           now <- utctDay <$> liftIO getCurrentTime-           let p' = updateLocation mbOldL (applyLocSync now locsts l) p-           let rmtspec rmtName =-                 DL.lookup (GitRepo (GitRemote rmtName)) $ otherLocs locsts-           let mkLoc (lt,ls) =-                 let nts = case lt of-                             GitRepo (GitRemote _) -> mempty-                             GitFork (GitRepo (GitRemote n)) ->-                               [ Note { note = "Fork of git repo @ " <>-                                               case rmtspec n of-                                                 Just rls -> tshow rls-                                                 Nothing -> "??"-                                      , notedOn = now-                                      , noteSource = MyWorkGenerated-                                      }-                               ]-                             DarcsRepo -> mempty-                             _ -> [ Note { note = "Related to " <> tshow ls-                                         , notedOn = now-                                         , noteSource = MyWorkGenerated-                                         }-                                  ]-                 in Location { location = ls-                             , locatedOn = Nothing-                             , locValid = True-                             , notes = nts-                             }-           foldM (go Nothing) p' (mkLoc <$> otherLocs locsts)---syncProject :: MonadIO m => Project -> m Project-syncProject p = foldM (applyProjLocSync Nothing) p $ locations p
+ lib/Defs.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Defs where++import           Brick hiding (Location)+import           Brick.Focus+import           Brick.Panes+import           Control.Applicative ( (<|>) )+import           Control.Lens+import           Control.Monad ( guard )+import qualified Data.List as DL+import           Data.Text ( Text, pack, unpack )+import qualified Data.Text as T+import           Data.Time.Calendar+import           Data.Time.Clock ( getCurrentTime, utctDay )+import           GHC.Generics ( Generic )+import           Numeric.Natural+import           Path ( Path, Abs, Dir, File, toFilePath )+import           Text.Read ( readMaybe )++import           Defs.Lenses+++type family ProjectCore a+type family LocationCore a+type family NoteCore a++newtype Projects_ core = Projects { projects :: [Project_ core] }+  deriving (Generic, Monoid, Semigroup)++newtype ProjectName = ProjectName Text deriving (Eq, Ord)++data Project_ core =+  Project { projName :: ProjectName+          , group :: Group+          , role :: Role+          , description :: Text+          , language :: Either Text Language+          , locations :: [Location_ core]+          , projCore :: ProjectCore core+          }+  deriving Generic++data Group = Personal | Work | OtherGroup Text+  deriving (Eq, Generic)++data Role = Author | Maintainer | Contributor | User+  deriving (Show, Enum, Bounded, Eq, Ord, Generic)++data Language = Haskell | Rust | C | CPlusPlus | Python | JavaScript | Prolog+  deriving (Show, Eq, Generic)++data LocationSpec = LocalSpec (Path Abs Dir)+                  | RemoteSpec Text+                  deriving (Eq, Ord, Generic)++instance Show LocationSpec where+  show = \case+    LocalSpec p -> toFilePath p+    RemoteSpec r -> T.unpack r++data Location_ core = Location { location :: LocationSpec+                               , locatedOn :: Maybe Day+                               , notes :: [Note_ core]+                               , locCore :: LocationCore core+                               }+  deriving Generic++data Note_ core = Note { notedOn :: Day+                       , note :: Text+                       , noteCore :: NoteCore core+                       }+  deriving (Generic)++data NoteSource = MyWorkDB | ProjLoc | MyWorkGenerated+  deriving (Eq, Ord)++newtype NoteTitle = NoteTitle Text deriving (Eq, Ord)++noteTitle :: Note_ core -> NoteTitle+noteTitle = noteTitle' . note++noteTitle' :: Text -> NoteTitle+noteTitle' t = case T.lines t of+                 [] -> NoteTitle ""+                 (l:_) -> NoteTitle l++noteBody :: Note_ core -> Text+noteBody = T.unlines . DL.drop 1 . T.lines . note++data NoteKeyword = INPROG+                 | TODO_ Day | TODO+                 | FUTURE_ Day | FUTURE+                 | BLOCKING+  deriving (Eq, Ord)++newtype NoteRemTitle = NoteRemTitle Text++nullaryNoteKeywords :: [ NoteKeyword ]+nullaryNoteKeywords = [ INPROG, TODO, FUTURE, BLOCKING ]+++----------------------------------------------------------------------++data Live++type Mutation = Natural++data ProjRT = ProjRT++data LocRT = LocRT { locValid :: Bool }++locValidL :: Lens' (Location_ Live) Bool+locValidL f l = (\x -> l { locCore = (locCore l) { locValid = x } })+                <$> f (locValid (locCore l))++data NoteRT = NoteRT { noteSource :: NoteSource+                     -- , noteMuta :: Mutation+                     }++noteSourceL :: Lens' (Note_ Live) NoteSource+noteSourceL f n = (\x -> n { noteCore = (noteCore n) { noteSource = x } })+                  <$> f (noteSource (noteCore n))++type instance ProjectCore Live = ProjRT++type instance LocationCore Live = LocRT++type instance NoteCore Live = NoteRT++type Projects = Projects_ Live+type Project = Project_ Live+type Location = Location_ Live+type Note = Note_ Live++----------------------------------------------------------------------++makeLensL ''Project_+makeLensL ''Location_+makeLensL ''Note_++----------------------------------------------------------------------++numProjects :: Projects -> Int+numProjects = length . projects++languageText :: Either Text Language -> Text+languageText = either id (pack . show)++canEditNote :: Note -> Bool+canEditNote n = n ^. noteSourceL == MyWorkDB+++instance Show Group where+  show = \case+    Personal -> "Personal"+    Work -> "Work"+    OtherGroup g -> unpack g+++noteKeyword :: Note_ core -> (Maybe NoteKeyword, NoteRemTitle)+noteKeyword n =+  let NoteTitle t = noteTitle n+  in case T.words t of+       ("FUTURE":dw:r)+         | Just d <- textToDay dw+           -> (Just $ FUTURE_ d, NoteRemTitle $ T.unwords r)+       ("TODO":dw:r)+         | Just d <- textToDay dw+           -> (Just $ TODO_ d, NoteRemTitle $ T.unwords r)+       (kw:r) -> let k = DL.find ((kw ==) . tshow) nullaryNoteKeywords+                     rt = NoteRemTitle $ maybe t (const $ T.unwords r) k+                 in (k, rt)+       [] -> (Nothing, NoteRemTitle t)++instance Show NoteKeyword where+  show = \case+    INPROG -> "IN-PROGRESS"+    TODO_ d -> "TODO " <> show d+    FUTURE_ d -> "FUTURE " <> show d+    TODO -> "TODO"+    FUTURE -> "FUTURE"+    BLOCKING -> "BLOCKING"++instance Eq (Note_ core) where+  n1 == n2 = noteTitle n1 == noteTitle n2 && notedOn n1 == notedOn n2++instance Ord (Note_ core) where+  compare n1 n2 =+    let noKWor (kw,_) = kw <|> Just BLOCKING+    in case compare (noKWor $ noteKeyword n1) (noKWor $ noteKeyword n2) of+         EQ -> case compare (notedOn n1) (notedOn n2) of+                 EQ -> compare (noteTitle n1) (noteTitle n2)+                 GT -> LT+                 LT -> GT+         o -> o+++----------------------------------------------------------------------++data MyWorkCore = MyWorkCore { myWorkFocus :: FocusRing WName+                             , today :: Day+                             }++initMyWorkCore :: IO MyWorkCore+initMyWorkCore = do+  t <- utctDay <$> getCurrentTime+  return $ MyWorkCore { myWorkFocus = focusRing [ WProjList+                                                , WLocations+                                                ]+                      , today = t+                      }++coreWorkFocusL :: Lens' MyWorkCore (FocusRing WName)+coreWorkFocusL f c = (\f' -> c { myWorkFocus = f' }) <$> f (myWorkFocus c)++todayL :: Lens' MyWorkCore Day+todayL f c = (\d -> c { today = d }) <$> f (today c)+++data WName = WProjList | WLocations | WNotes | WName Text+  deriving (Eq, Ord)++instance Show WName where+  show = \case+    WProjList -> "Projects"+    WLocations -> "Location"+    WNotes -> "Notes"+    WName n -> unpack n+++type MyWorkEvent = ()  -- No app-specific event for this simple app+++class HasDate s where+  getToday :: s -> Day++instance HasDate MyWorkCore where+  getToday = view todayL++instance HasDate (Panel WName MyWorkEvent MyWorkCore panes) where+  getToday = view (onBaseState . todayL)+++class HasProjects s where+  -- getProjects returns the current set of projects, along with either a+  -- confirmation that should be performed (which will update the Projects if+  -- accepted) or a boolena indication of whether the projects have been changed+  -- or not.+  getProjects :: s -> (Either Confirm Bool, Projects)+++class HasMessage s where+  getMessage :: s -> [Widget WName]+++instance HasFocus MyWorkCore WName where+  getFocus f s =+    let setFocus jn = case focused jn of+          Nothing -> s+          Just n -> s & coreWorkFocusL %~ focusSetCurrent n+    in setFocus <$> (f $ Focused $ focusGetCurrent (s^.coreWorkFocusL))+++class HasSelection s where+  selectedProject :: s -> Maybe ProjectName++instance ( PanelOps Projects WName MyWorkEvent panes MyWorkCore+         , HasSelection (PaneState Projects MyWorkEvent)+         )+  => HasSelection (Panel WName MyWorkEvent MyWorkCore panes) where+  selectedProject = selectedProject . view (onPane @Projects)++class HasLocation s where+  -- | Returns the currently selected project and location+  selectedLocation :: s -> Maybe (ProjectName, LocationSpec)++instance ( PanelOps Location WName MyWorkEvent panes MyWorkCore+         , HasLocation (PaneState Location MyWorkEvent)+         )+  => HasLocation (Panel WName MyWorkEvent MyWorkCore panes) where+  selectedLocation = selectedLocation . view (onPane @Location)++class HasNote s where+  -- | Returns the currently selected location and note+  selectedNote :: s -> Maybe (LocationSpec, NoteTitle)++instance ( PanelOps Note WName MyWorkEvent panes MyWorkCore+         , HasNote (PaneState Note MyWorkEvent)+         )+  => HasNote (Panel WName MyWorkEvent MyWorkCore panes) where+  selectedNote = selectedNote . view (onPane @Note)+++getCurrentProject :: HasSelection s => HasProjects s => s -> Maybe Project+getCurrentProject s = do pnm <- selectedProject s+                         let (_, prjs) = getProjects s+                         DL.find ((== pnm) . view projNameL) (projects prjs)++getCurrentLocation :: HasSelection s+                   => HasLocation s+                   => HasProjects s+                   => s -> Maybe (Project, Maybe Location)+getCurrentLocation s =+  do (p,l) <- selectedLocation s+     let (_,prjs) = getProjects s+     prj <- DL.find ((== p) . view projNameL) (projects prjs)+     return (prj, DL.find ((== l) . view locationL) (prj ^. locationsL))+++getCurrentNote :: HasNote s => s -> Location -> Maybe Note+getCurrentNote s l = do (l',n) <- selectedNote s+                        guard (l ^. locationL == l')+                        DL.find ((== n) . noteTitle) (l ^. notesL)++isLocationLocal :: Location -> Bool+isLocationLocal = isLocationLocal' . view locationL++isLocationLocal' :: LocationSpec -> Bool+isLocationLocal' = \case+  LocalSpec _ -> True+  RemoteSpec _ -> False++isLocationTextLocal :: Text -> Bool+isLocationTextLocal t =+  not $ or [ "http://" `T.isPrefixOf` t+           , "https://" `T.isPrefixOf` t+           , "git@" `T.isPrefixOf` t+           , ":/" `T.isInfixOf` t+           ]++updateProject :: Maybe ProjectName -> Project -> Projects -> Projects+updateProject onm p (Projects ps) =+  let oldName = maybe (p ^. projNameL) id onm+      (match, other) = DL.partition ((== oldName) . view projNameL) ps+      p' = foldr (updateLocation Nothing) p (concatMap (view locationsL) match)+  in Projects $ p' : other+++-- | Adds the specified Location to the Project, merging with the previous+-- Location (with the same name or the previous name indicated by a Just in the+-- the Maybe parameter).+updateLocation :: Maybe LocationSpec -> Location -> Project -> Project+updateLocation ol l p =+  let oldName = maybe (l ^. locationL) id ol+      isOldName = (oldName ==) . view locationL+      (match, other) = DL.partition isOldName (p ^. locationsL)+      l' = foldr addNote l (concatMap (view notesL) match)+      addNote n = notesL %~ (n :) . filter ((/= noteTitle n) . noteTitle)+  in p & locationsL .~ l' : other+++updateLocNote :: Maybe NoteTitle -> Note -> Location -> Location+updateLocNote oldn n =+  let oldName = maybe (noteTitle n) id oldn+  in notesL %~ (n :) . filter ((/= oldName) . noteTitle)+++updateNote :: Maybe NoteTitle -> Note -> Location -> Project+           -> (Project, Location)+updateNote oldn n l p = let newL = updateLocNote oldn n l+                        in (updateLocation Nothing newL p, newL)+++data OpOn = ProjectOp | LocationOp | NoteOp+  deriving (Eq, Enum, Bounded)++opOnSelection :: HasSelection s+              => HasLocation s+              => HasFocus s WName+              => s -> OpOn+opOnSelection s =+  case s ^. getFocus of+    Focused (Just WProjList) -> ProjectOp+    Focused (Just WLocations) -> LocationOp+    Focused (Just WNotes) -> NoteOp+    _ -> ProjectOp+++data Confirm = ConfirmProjectDelete ProjectName+             | ConfirmLocationDelete ProjectName LocationSpec+             | ConfirmNoteDelete ProjectName LocationSpec NoteTitle+             | ConfirmLoad (Path Abs File)+             | ConfirmQuit++-- The Show instance for Confirm is the message presented to the user in the+-- confirmation window.+instance Show Confirm where+  show = \case+    ConfirmProjectDelete pname ->+      let ProjectName pnm = pname+      in "Are you sure you want to delete project " <> show pnm+         <> " and all associated locations and notes?"+    ConfirmLocationDelete pname locn ->+      let ProjectName pnm = pname+      in "Are you sure you want to remove location " <> show locn+         <> " from project " <> show pnm <> "?"+    ConfirmNoteDelete pname locn nt ->+      let ProjectName pnm = pname+          NoteTitle ntitle = nt+      in "Remove the following note from project " <> show pnm+         <> ", location " <> show locn <> "?\n\n  " <> show ntitle+    ConfirmLoad fp ->+      "Discard local changes and load projects from " <> show fp <> "?"+    ConfirmQuit -> "There are unsaved changes.  Are you sure you want to quit?"+++----------------------------------------------------------------------++textToDay :: Text -> Maybe Day+textToDay t =+  case T.split (`T.elem` "-/.") t of+    [y,m,d] ->+      let validYear x = if x < (1800 :: Integer) then x + 2000 else x+          validMonth x = not (x < 1 || x > (12 :: Int))+          validDayOfMonth x = not (x < 1 || x > (31 :: Int))+          months = [ "january", "february", "march", "april"+                   , "may", "june", "july", "august"+                   , "september", "october", "november", "december"+                   ]+          ml = T.toLower m+          matchesMonth x = or [ ml == x, ml == T.take 3 x]+      in do y' <- validYear <$> readMaybe (T.unpack y)+            m' <- readMaybe (T.unpack m)+                  <|> (snd <$> (DL.find (matchesMonth . fst) $ zip months [1..]))+            guard (validMonth m')+            d' <- readMaybe (T.unpack d)+            guard (validDayOfMonth d')+            fromGregorianValid y' m' d'+    _ -> Nothing+++tshow :: Show a => a -> Text+tshow = T.pack . show++----------------------------------------------------------------------++a'Operation :: AttrName+a'Operation = attrName "Oper"++a'RoleAuthor, a'RoleContributor, a'RoleMaintainer, a'RoleUser :: AttrName+a'RoleAuthor = attrName "auth"+a'RoleContributor = attrName "contrib"+a'RoleMaintainer = attrName "maint"+a'RoleUser = attrName "user"++roleAttr :: Role -> AttrName+roleAttr = \case+  Author -> a'RoleAuthor+  Contributor -> a'RoleContributor+  Maintainer -> a'RoleMaintainer+  User -> a'RoleUser+++a'ProjName :: AttrName+a'ProjName = attrName "projname"++a'Disabled :: AttrName+a'Disabled = attrName "disabled"++a'Selected :: AttrName+a'Selected = attrName "selected"++a'Error :: AttrName+a'Error = attrName "Error"++a'Notice :: AttrName+a'Notice = attrName "Notice"++a'NoteSourceMyWork, a'NoteSourceProjLoc, a'NoteSourceGenerated :: AttrName+a'NoteSourceMyWork = attrName "Note:main"+a'NoteSourceProjLoc = attrName "Note:projloc"+a'NoteSourceGenerated = attrName "gen note"++a'NoteWordTODO, a'NoteWordInProg, a'NoteWordFuture, a'NoteWordBlocking+  , a'NoteWordExpired :: AttrName+a'NoteWordTODO = attrName "Note:TODO"+a'NoteWordInProg = attrName "Note:InProg"+a'NoteWordFuture = attrName "Note:Future"+a'NoteWordBlocking = attrName "Note:Blocking"+a'NoteWordExpired = attrName "Note:Expired"++noteKeywordAttr :: NoteKeyword -> AttrName+noteKeywordAttr = \case+  FUTURE_ _ -> a'NoteWordFuture+  FUTURE -> a'NoteWordFuture+  TODO_ _ -> a'NoteWordTODO+  TODO -> a'NoteWordTODO+  BLOCKING -> a'NoteWordBlocking+  INPROG -> a'NoteWordInProg
+ lib/Defs/JSON.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Defs.JSON () where++import Control.Applicative ( (<|>) )+import Data.Aeson++import Defs+import Defs.Static ()+++instance ToJSON ProjectName where toJSON (ProjectName pnm) = toJSON pnm+instance ToJSON LocationSpec where+  toJSON = genericToJSON locationSpecOptions+instance ToJSON (Projects_ ())+instance ToJSON (Project_ ()) where+  toJSON = genericToJSON projectOptions+instance ToJSON Group+instance ToJSON Role+instance ToJSON Language+instance ToJSON (Location_ ()) where+  toJSON = genericToJSON locationOptions+instance ToJSON (Note_ ()) where+  toJSON = genericToJSON noteOptions++instance FromJSON ProjectName where parseJSON = fmap ProjectName . parseJSON+instance FromJSON LocationSpec where+  parseJSON = genericParseJSON locationSpecOptions+instance FromJSON (Projects_ ())+instance FromJSON (Project_ ()) where+  parseJSON = withObject "Project" $ \v -> Project+    <$> (v .: "name" <|> v .: "projName")+    <*> v .:? "group" .!= Personal+    <*> v .: "role"+    <*> v .: "description"+    <*> v .: "language"+    <*> v .: "locations"+    <*> pure Nothing++instance FromJSON Group+instance FromJSON Role+instance FromJSON Language+instance FromJSON (Location_ ()) where+  parseJSON = withObject "Location" $ \v -> Location+    <$> v .: "location"+    <*> v .:? "locatedOn" .!= Nothing+    <*> v .: "notes"+    <*> pure Nothing+instance FromJSON (Note_ ())+++projectOptions :: Options+projectOptions = defaultOptions { omitNothingFields = True }++locationOptions :: Options+locationOptions = defaultOptions { omitNothingFields = True }++locationSpecOptions :: Options+locationSpecOptions = defaultOptions { sumEncoding = UntaggedValue }++noteOptions :: Options+noteOptions = defaultOptions { omitNothingFields = True }
+ lib/Defs/Lenses.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}++module Defs.Lenses+  (+    makeLensL+  )+where++import           Control.Lens+import qualified Language.Haskell.TH as TH++-- | This is a helper function use to create Lenses for structure+-- fields using Template Haskell.  It is similar to the 'makeLenses'+-- function provided by the 'lens' library but instead of converting+-- fields with a name of "_{fieldname}" to a lens of "fieldname", the+-- 'makeLensL' converts a field name of "{fieldname}" to a lens named+-- "fieldnameL" (appends an 'L' instead of removing a '_' prefix).++makeLensL :: TH.Name -> TH.DecsQ+makeLensL = makeLensesWith+            (lensRules+             & lensField+              .~ (\_ _ n -> [TopName $ TH.mkName $ TH.nameBase n <> "L"])+            )
+ lib/Defs/Static.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE TypeFamilies #-}++module Defs.Static+  -- (+  -- )+  where++import Control.Lens++import Defs+++type instance ProjectCore () = Maybe ()+type instance LocationCore () = Maybe ()+type instance NoteCore () = Maybe ()++hydrate :: Project_ () -> Project_ Live+hydrate dp = Project { projName = dp ^. projNameL+                     , group = dp ^. groupL+                     , role = dp ^. roleL+                     , description = dp ^. descriptionL+                     , language = dp ^. languageL+                     , locations = hydrateLoc <$> (dp ^. locationsL)+                     , projCore = ProjRT+                     }++hydrateLoc :: Location_ () -> Location_ Live+hydrateLoc dl = Location { location = dl ^. locationL+                         , locatedOn = dl ^. locatedOnL+                         , notes = hydrateNote <$> (dl ^. notesL)+                         , locCore = LocRT+                                     { locValid = True  -- default+                                     }+                         }++hydrateNote :: Note_ () -> Note_ Live+hydrateNote dn = Note { notedOn = dn ^. notedOnL+                      , note = dn ^. noteL+                      , noteCore = NoteRT+                                   { noteSource = MyWorkDB+                                   }++                      }+++dehydrate :: Project_ Live -> Project_ ()+dehydrate hp = Project { projName = hp ^. projNameL+                       , group = hp ^. groupL+                       , role = hp ^. roleL+                       , description = hp ^. descriptionL+                       , language = hp ^. languageL+                       , locations = dehydrateLoc <$> (hp ^. locationsL)+                       , projCore = Nothing+                       }++dehydrateLoc :: Location_ Live -> Location_ ()+dehydrateLoc hl = Location { location = hl ^. locationL+                           , locatedOn = hl ^. locatedOnL+                             -- only emit static notes, not dynamically generated+                             -- notes.+                           , notes =+                               let isStatic = (MyWorkDB ==) . view noteSourceL+                               in dehydrateNote+                                  <$> (filter isStatic $ hl ^. notesL)+                           , locCore = Nothing+                           }++dehydrateNote :: Note_ Live -> Note_ ()+dehydrateNote hn = Note { notedOn = hn ^. notedOnL+                        , note = hn ^. noteL+                        , noteCore = Nothing+                        }
+ lib/Draw.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}++module Draw+  (+    drawMyWork+  , myattrs+  )+where++import Brick hiding ( Location )+import Brick.Widgets.Edit+import Data.Maybe ( catMaybes )+import Brick.Widgets.Border+import Brick.Widgets.Border.Style+import Brick.Widgets.Dialog+import Brick.Forms+import Brick.Widgets.List+import Brick.Panes+import Data.Version ( showVersion )+import Graphics.Vty++import Defs+import Panes.AddProj+import Panes.FileMgr+import Panes.Help+import Panes.LocationInput+import Panes.Messages+import Panes.NoteInput+import Panes.Operations+import Panes.ProjInfo+import Panes.Summary+import Paths_mywork ( version )+import Whole+++myattrs :: AttrMap+myattrs = attrMap defAttr+          [+            (editAttr, white `on` black)+          , (editFocusedAttr, yellow `on` black)++          , (listAttr, defAttr `withStyle` defaultStyleMask)+          , (listSelectedAttr, defAttr `withStyle` bold `withStyle` underline)+          , (listSelectedFocusedAttr, defAttr `withStyle` reverseVideo)++          , (invalidFormInputAttr, fg red `withStyle` bold)+          , (focusedFormInputAttr, defAttr `withStyle` reverseVideo)++          , (buttonAttr, black `on` (rgbColor 100 100 (100::Int)))+          , (buttonSelectedAttr, black `on` green)++          , (a'Operation, white `on` (rgbColor 0 1 (0::Int)))++          , (a'RoleAuthor, fg $ rgbColor 0 255 (0::Int))+          , (a'RoleMaintainer, fg $ rgbColor 0 200 (130::Int))+          , (a'RoleContributor, fg $ rgbColor 0 145 (180::Int))+          , (a'RoleUser, defAttr)++          , (a'ProjName, defAttr `withStyle` bold `withStyle` underline)++          , (a'NoteSourceMyWork, defAttr)+          , (a'NoteSourceProjLoc, defAttr)+          , (a'NoteSourceGenerated, white `on` black `withStyle` dim)++          , (a'NoteWordTODO, fg (rgbColor 255 80 (0::Int)) `withStyle` bold)+          , (a'NoteWordInProg, magenta `on` white `withStyle` bold)+          , (a'NoteWordFuture, fg (rgbColor 255 200 (0::Int)) `withStyle` bold)+          , (a'NoteWordBlocking, white `on` blue `withStyle` bold)++          , (a'NoteWordExpired, red `on` black `withStyle` bold)++          , (a'Disabled, defAttr `withStyle` dim)+          , (a'Selected, black `on` yellow)+          , (a'Error, fg red)+          , (a'Notice, fg cyan)+          ]+++drawMyWork :: MyWorkState -> [Widget WName]+drawMyWork mws =+  let mainPanes =+        [+          borderWithLabel  (str $ " mywork " <> showVersion version <> " ")+          $ vBox $ catMaybes+          [+            panelDraw @SummaryPane mws+          , Just hBorder+          , Just $ hBox $ catMaybes+            [ hLimit 25+              <$> panelDraw @Projects mws+            , Just vBorder+            , Just $ vBox $ catMaybes $+              let pinfo = panelDraw @ProjInfoPane mws+              in [ pinfo+                 , const (hBorderWithLabel (str "Locations")) <$> pinfo+                 , vLimitPercent 28 <$> panelDraw @Location mws+                 , const (hBorderWithLabel (str "Notes")) <$> pinfo+                 , pinfo >> panelDraw @Note mws+                 ]+            ]+          , Just hBorder+          , panelDraw @MessagesPane mws+          , panelDraw @OperationsPane mws+          ]+        ]+      allPanes = catMaybes [ panelDraw @FileMgrPane mws+                           , panelDraw @AddProjPane mws+                           , panelDraw @LocationInputPane mws+                           , panelDraw @NoteInputPane mws+                           , panelDraw @Confirm mws+                           , panelDraw @HelpPane mws+                           ]+                 <> mainPanes+      disableLower = \case+        (m:ls) -> m : (withDefAttr a'Disabled <$> ls)+        o -> o+  in joinBorders . withBorderStyle unicode <$> disableLower allPanes
+ lib/Events.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}++module Events+  (+    handleMyWorkEvent+  )+where++import           Brick hiding ( Location )+import           Brick.Panes+import           Control.Lens+import           Control.Monad ( unless, when )+import           Control.Monad.IO.Class ( liftIO )+import           Control.Monad.Reader ( ReaderT, runReaderT, ask, lift )+import           Control.Monad.State ( evalStateT )+import           Control.Monad.Writer ( WriterT, execWriterT, tell )+import qualified Data.List as DL+import           Data.Time.Clock ( getCurrentTime, utctDay )+import qualified Graphics.Vty as Vty++import           Defs+import           Panes.AddProj+import           Panes.Confirmation+import           Panes.FileMgr+import           Panes.Help+import           Panes.LocationInput+import           Panes.Messages+import           Panes.NoteInput+import           Sync+import           Whole+++handleMyWorkEvent :: BrickEvent WName MyWorkEvent -> EventM WName MyWorkState ()+handleMyWorkEvent ev = do+  t <- utctDay <$> liftIO getCurrentTime+  modify $ onBaseState . todayL .~ t+  dispatchMyWorkEvent ev+++dispatchMyWorkEvent :: BrickEvent WName MyWorkEvent+                    -> EventM WName MyWorkState ()+dispatchMyWorkEvent = \case+  AppEvent _ -> return () -- this app does not use these++  --------------------------------------------------------+  -- Application global actions+  --   * CTRL-q quits+  --   * CTRL-l refreshes vty+  --   * ESC dismisses any modal window++  VtyEvent (Vty.EvKey (Vty.KChar 'q') [Vty.MCtrl]) -> do+    s <- get+    if s ^. onPane @FileMgrPane . to unsavedChanges+      then modify ( (focusRingUpdate myWorkFocusL)+                    . (onPane @Confirm %~ showConfirmation ConfirmQuit)+                  )+      else halt+  VtyEvent (Vty.EvKey (Vty.KChar 'l') [Vty.MCtrl]) ->+    liftIO . Vty.refresh =<< getVtyHandle++  --------------------------------------------------------+  -- Other application global events (see Pane.Operations)++  -- Enter Load/Save modal dialog+  VtyEvent (Vty.EvKey (Vty.KFun 9) []) -> do+    resetMessages+    s <- get+    if s ^. onPane @FileMgrPane . to isFileMgrActive+      then return ()+      else do+        s' <- s & onPane @FileMgrPane %%~ liftIO . showFileMgr+        put $ s' & focusRingUpdate myWorkFocusL++  -- Quickly save to current file (if possible)+  ev@(VtyEvent (Vty.EvKey (Vty.KChar 's') [Vty.MCtrl])) -> do+    isModal <- gets (isPanelModal myWorkFocusL)+    unless isModal $ do+      s <- get+      when (not $ s ^. onPane @FileMgrPane . to isFileMgrActive) $ do+        s' <- s & onPane @FileMgrPane %%~ liftIO . showFileMgr+        put $ s' & focusRingUpdate myWorkFocusL+    eventToPanel ev++  -- Show help on F1+  VtyEvent (Vty.EvKey (Vty.KFun 1) []) ->+    modify $ (   (focusRingUpdate myWorkFocusL)+               . (onPane @HelpPane .~ initHelp)+             )++  -- Add an entry to the currently selected pane+  VtyEvent (Vty.EvKey (Vty.KFun 2) []) -> do+    resetMessages+    s <- get+    case opOnSelection s of+      ProjectOp ->+        put $ s+        & onPane @AddProjPane %~ initAddProj (snd $ getProjects s) Nothing+        & focusRingUpdate myWorkFocusL+      LocationOp -> addLocation s+      NoteOp -> addNote s++  -- Add a sub-entry to the currently selected pane entry+  VtyEvent (Vty.EvKey (Vty.KFun 3) []) -> do+    resetMessages+    s <- get+    case opOnSelection s of+      ProjectOp -> addLocation s+      LocationOp -> addNote s+      NoteOp -> addNote s  -- Note: F3 is not displayed, but no lower entry++  -- Edit the current selected entry in whichever pane is active+  VtyEvent (Vty.EvKey (Vty.KChar 'e') [Vty.MCtrl]) -> do+    isModal <- gets (isPanelModal myWorkFocusL)+    unless isModal $ do+      resetMessages+      s <- get+      case opOnSelection s of+        ProjectOp ->+          case getCurrentLocation s of+            Just (p, _) ->+              put $ s+              & onPane @AddProjPane %~ initAddProj (snd $ getProjects s) (Just p)+              & focusRingUpdate myWorkFocusL+            _ -> return ()+        LocationOp ->+          case getCurrentLocation s of+            Just (p, Just l) ->  -- KWQ: same as addLocation but Just l ...+              let n = p ^. projNameL+                  ls = p ^. locationsL+              in put $ s+                 & onPane @LocationInputPane %~ initLocInput n ls (Just l)+                 & focusRingUpdate myWorkFocusL+            _ -> return ()+        NoteOp ->+          case getCurrentLocation s of+            Just (_, Just l) ->+              let nt = getCurrentNote s l+              in when (maybe False canEditNote nt) $ do+                s' <- s & onPane @NoteInputPane+                          %%~ initNoteInput (l ^. notesL) nt+                put $ s' & focusRingUpdate myWorkFocusL+            _ -> return ()++  -- Delete the current selected entry in whichever pane is active+  VtyEvent (Vty.EvKey Vty.KDel []) -> do+    isModal <- gets (isPanelModal myWorkFocusL)+    unless isModal $ do+      resetMessages+      s <- get+      let cnf =+            case opOnSelection s of+              ProjectOp ->+                ConfirmProjectDelete . view projNameL . fst <$> getCurrentLocation s+              LocationOp -> do+                (p, Just l) <- getCurrentLocation s+                return $ ConfirmLocationDelete (p ^. projNameL) (l ^. locationL)+              NoteOp -> do (p, mbl) <- getCurrentLocation s+                           l <- mbl+                           n <- getCurrentNote s l+                           let c = ConfirmNoteDelete (p ^. projNameL)+                                   (l ^. locationL)+                                   (noteTitle n)+                           if canEditNote n+                             then Just c+                             else Nothing+      case cnf of+        Just cmsg -> put $ s & onPane @Confirm %~ showConfirmation cmsg+                             & focusRingUpdate myWorkFocusL+        Nothing -> return ()++  -- Otherwise, allow the Panes in the Panel to handle the event.  The wrappers+  -- handle updates for any inter-state transitions.+  ev -> eventToPanel ev++  where+    eventToPanel ev = do+      resetMessages+      s <- get+      (t,s') <- handleFocusAndPanelEvents myWorkFocusL s ev+      put s'+      when (exitedModal @FileMgrPane t s') $+             let fmn = Just $ (panelState @FileMgrPane s') ^. fileMgrNotices+             in modify+                (   (onPane @FileMgrPane . fileMgrNotices .~ mempty)+                  . (onPane @MessagesPane %~ updatePane fmn)+                )+      let postop = do handleConfirmation+                      handleNewProject+                      handleProjectChanges+                      mbprj <- handleProjectChange+                      mbprj' <- handleLocationInput mbprj+                      mbloc <- handleLocationChange mbprj'+                      handleNoteInput mbprj' mbloc+      refocus <- execWriterT $ runReaderT postop t+      when (or refocus) $ modify $ focusRingUpdate myWorkFocusL+++addLocation :: MyWorkState -> EventM WName MyWorkState ()+addLocation s =+  case getCurrentProject s of+    Just p ->+      let n = p ^. projNameL+          ls = p ^. locationsL+      in put $ s+         & onPane @LocationInputPane %~ initLocInput n ls Nothing+         & focusRingUpdate myWorkFocusL+    _ -> return ()+++addNote :: MyWorkState -> EventM WName MyWorkState ()+addNote s =+  case getCurrentLocation s of+    Just (_, Just l) -> do+      s' <- s & onPane @NoteInputPane %%~ initNoteInput (l ^. notesL) Nothing+      put $ s' & focusRingUpdate myWorkFocusL+    _ -> return ()+++resetMessages :: EventM WName MyWorkState ()+resetMessages = modify $ onPane @MessagesPane %~ updatePane Nothing+++type PostOpM a = ReaderT PanelTransition (WriterT [Bool] (EventM WName MyWorkState)) a++handleConfirmation :: PostOpM ()+handleConfirmation = do+  let confirmOp :: (PaneState Confirm MyWorkEvent -> a) -> PostOpM a+      confirmOp o = gets (view $ onPane @Confirm . to o)+  transition <- ask+  deactivatedConfirmation <- gets (exitedModal @Confirm transition)+  when deactivatedConfirmation $+    do (ps, confirmed) <- confirmOp getConfirmedAction+       modify $ onPane @Confirm .~ ps+       let toFM :: FileMgrOps -> PostOpM ()+           toFM msg = do modify (onPane @FileMgrPane %~ updatePane msg)+                         tell [True]+       case confirmed of+         Nothing -> return ()+         Just (ConfirmProjectDelete pname) -> toFM $ DelProject pname+         Just (ConfirmLocationDelete pname l) ->+           do toFM $ DelLocation pname l+              p <- gets getCurrentProject -- updated by DelLocation above+              modify (onPane @Location %~ updatePane p)+         Just (ConfirmNoteDelete pname locn nt) ->+           do toFM $ DelNote pname locn nt+              cl <- gets getCurrentLocation -- updated by DelNote+              let mbl = do (_,mbl') <- cl+                           mbl'+              modify (onPane @Note %~ updatePane mbl)+         Just (ConfirmLoad fp) -> do+           s <- get+           s' <- s & onPane @FileMgrPane %%~ fileMgrReadProjectsFile fp+           put s'+         Just ConfirmQuit -> lift $ lift halt++handleNewProject :: PostOpM ()+handleNewProject = do+  let inpOp :: (PaneState AddProjPane MyWorkEvent -> a) -> PostOpM a+      inpOp o = gets (view $ onPane @AddProjPane . to o)+  transition <- ask+  changed <- gets (exitedModal @AddProjPane transition)+  when changed $ do+    (mbOld, mbNewProj) <- inpOp projectInputResults+    case mbNewProj of+         Just newProj ->+           modify $ onPane @FileMgrPane %~ updatePane (UpdProject mbOld newProj)+         Nothing -> return ()++handleProjectChanges :: PostOpM ()+handleProjectChanges = lift $ do+  (changed,prjs) <- gets getProjects+  case changed of+    Left cnfrm -> do modify $ \s ->+                       if not $ s ^. onPane @Confirm . to isConfirmationActive+                       then s+                            & onPane @Confirm %~ showConfirmation cnfrm+                            & onPane @FileMgrPane %~ updatePane AckProjectChanges+                            & focusRingUpdate myWorkFocusL+                       else s+    Right True ->+      modify (   (onPane @Projects %~ updatePane prjs)+               . (onPane @FileMgrPane %~ updatePane AckProjectChanges)+             )+    Right False -> return ()+++handleProjectChange :: PostOpM (Maybe Project)+handleProjectChange = do+  mbp <- gets getCurrentProject -- from ProjList pane+  pnm <- gets (fmap fst . selectedLocation) -- from Location pane+  let mustUpdate = pnm /= (view projNameL <$> mbp)+  when mustUpdate $ do modify $ onPane @Location %~ updatePane mbp+                       tell [True]+  return mbp++handleLocationInput :: Maybe Project -> PostOpM (Maybe Project)+handleLocationInput mbPrj = do+  let inpOp :: (PaneState LocationInputPane MyWorkEvent -> a) -> PostOpM a+      inpOp o = lift $ gets (view $ onPane @LocationInputPane . to o)+  transition <- ask+  changed <- gets (exitedModal @LocationInputPane transition)+  if changed+    then do (mbOldL, mbNewLoc) <- inpOp locationInputResults+            case (mbNewLoc, mbPrj) of+              (Just newLoc, Just p) -> do+                p' <- evalStateT (applyProjLocSync mbOldL p newLoc) mempty+                let u = UpdProject Nothing p'+                modify (   (onPane @FileMgrPane %~ updatePane u)+                         . (onPane @Location %~ updatePane (Just p'))+                       )+                return $ Just p'+              _ -> return mbPrj+    else return mbPrj+++handleLocationChange :: Maybe Project -> PostOpM (Maybe Location)+handleLocationChange mbp = do+  locSel <- gets (fmap snd . selectedLocation)+  let mbl = do p <- mbp+               DL.find ((== locSel) . Just . view locationL) (p ^. locationsL)+  modify $ onPane @Note %~ updatePane mbl+  return mbl+-- handleLocationChange = \case+--   Nothing -> return Nothing+--   Just p -> do+--     loc0 <- gets (fmap snd . selectedLocation) -- Location pane+--     loc1 <- gets (fmap fst . selectedNote) -- Notes pane+--     let mbl = DL.find ((== loc0) . Just . view locationL) (p ^. locationsL)+--     unless (loc0 == loc1) $ do modify $ onPane @Note %~ updatePane mbl+--                                tell [True]+--     return mbl++handleNoteInput :: Maybe Project -> Maybe Location -> PostOpM ()+handleNoteInput mbPrj mbLoc = do+  let inpOp :: (PaneState NoteInputPane MyWorkEvent -> a) -> PostOpM a+      inpOp o = lift $ gets (view $ onPane @NoteInputPane . to o)+  transition <- ask+  changed <- gets (exitedModal @NoteInputPane transition)+  when changed $+    do (mbOldN, mbNewNote) <- inpOp noteInputResults+       case (mbNewNote, mbPrj, mbLoc) of+         (Just newNote, Just p, Just l) ->+           let (p',l') = updateNote mbOldN newNote l p+               u = UpdProject Nothing p'+           in do modify ( (onPane @FileMgrPane %~ updatePane u)+                          . (onPane @Note %~ updatePane (Just l'))+                        )+         _ -> do return ()
+ lib/Panes/AddProj.hs view
@@ -0,0 +1,293 @@+{-# 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+            }
+ lib/Panes/Common/Attrs.hs view
@@ -0,0 +1,20 @@+module Panes.Common.Attrs where++import Data.Text ( Text )+import Brick+import Brick.Widgets.Border+import Brick.Widgets.Border.Style++import Defs+++-- | Adds a border with a title to the current widget.  First argument is True if+-- the current widget has focus.+titledB :: Bool -> Text -> Widget WName -> Widget WName+titledB fcsd text =+  let ttlAttr = if fcsd then withAttr (attrName "Selected") else id+  in borderWithLabel (ttlAttr $ txt text)+++modalB :: Text -> Widget WName -> Widget WName+modalB t = withBorderStyle unicodeBold . borderWithLabel (txt t)
+ lib/Panes/Common/Inputs.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}++module Panes.Common.Inputs+  -- (+  -- )+where++import           Brick hiding ( Location )+import           Brick.Forms+import           Control.Lens+import           Control.Monad.IO.Class ( MonadIO, liftIO )+import           Data.Text ( Text )+import qualified Data.Text as T+import           Data.Time.Calendar ( Day )+import           Path ( parseAbsDir )+import           Path.IO ( doesDirExist, doesDirExist )++import           Defs++++headText :: [Text] -> Text+headText = \case+  [] -> ""+  (o:_) -> o+++locationInput :: [Location]+              -> Maybe Location+              -> Bool+              -> Lens' s LocationSpec+              -> s+              -> FormFieldState s e WName+locationInput locs mbLoc blankAllowed stateLens =+  let validate = \case+        [] -> if blankAllowed+              then Just (RemoteSpec "")+              else Nothing+        (l:_) ->+          let lr = RemoteSpec l+              ll = parseAbsDir $ T.unpack l+              ls = T.unpack l+          in if or+                [+                  -- Should not match any existing location+                  and [ ls `elem` (show . view locationL <$> locs)+                      , maybe True ((ls /=) . show . view locationL) mbLoc+                      ]++                  -- Check blank v.s. allowed and should be an absolute path if+                  -- it looks like a local path+                , and [ not blankAllowed+                      , maybe (isLocationTextLocal (T.pack ls)) (const False) ll+                      ]+                ]+             then Nothing  -- invalid+             else Just $ maybe lr LocalSpec ll+  in editField stateLens (WName "New Location") (Just 1)+     (T.pack . show) validate (txt . headText) id+++validateLocationInput :: MonadIO m => Bool -> LocationSpec -> m (WName, Bool)+validateLocationInput blankAllowed l =+  let tgt = WName "New Location"+      ls = T.pack $ show l+  in if blankAllowed && T.null ls+     then return (tgt, True)+     else case l of+            LocalSpec lp -> (tgt,) <$> (liftIO $ doesDirExist lp)+            RemoteSpec _ -> return (tgt, True)+++mbDateInput :: Lens' s (Maybe Day)+            -> s+            -> FormFieldState s e WName+mbDateInput stateLens =+  let validate = \case+        ("":_) -> Just Nothing+        (l:_) -> Just <$> textToDay l+        _ -> Nothing+      dayInit = maybe "" (T.pack . show)+      dayRender = txt . headText+  in editField stateLens (WName "Location Date (Y-M-D)")+     (Just 1) dayInit validate dayRender id
+ lib/Panes/Common/QQDefs.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Panes.Common.QQDefs where++import Data.String+import Language.Haskell.TH ( ExpQ )+import Language.Haskell.TH.Quote+++sq :: QuasiQuoter+sq = QuasiQuoter extractor+     (error "no q patterns")+     (error "no q types")+     (error "no q dec")++extractor :: String -> ExpQ+extractor s =+  case inSeps $ filter (/= '\r') s of+    Post a -> [|fromString a|]+    Pre _ -> error $ "No starting line found"+    MatchLine -> error $ "Only starting line found"+    Pass _ -> error $ "No ending line found"+++data QState = Pre String | MatchLine | Pass String | Post String++inSeps :: String -> QState+inSeps =+  let sep = "\n----"+      sepl = length sep+      nxtC :: QState -> Char -> QState+      nxtC (Pre p) c = let p' = c : p+                           l = length p'+                       in if reverse p' == take l sep+                          then if l == sepl then MatchLine else Pre p'+                          else Pre $ take (sepl-1) p'+      nxtC MatchLine c = if '\n' == c then Pass "" else MatchLine+      nxtC (Pass s) c = let s' = c : s+                            sl = reverse $ take sepl s'+                        in if sl == sep+                           then Post (reverse $ drop sepl s')+                           else Pass s'+      nxtC (Post s) _ = Post s+    in foldl nxtC (Pre "")
+ lib/Panes/Confirmation.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Panes.Confirmation+  (+    isConfirmationActive+  , getConfirmedAction+  , showConfirmation+  )+where++import           Brick+import           Brick.Panes+import           Brick.Widgets.Dialog+import           Control.Lens+import           Data.Maybe ( isJust )+import qualified Data.Sequence as Seq+import qualified Graphics.Vty as Vty++import           Defs+++instance Pane WName MyWorkEvent Confirm where+  data (PaneState Confirm MyWorkEvent) = Cf { cD :: Maybe (Dialog Bool)+                                            , cW :: Maybe Confirm+                                            }+  type (DrawConstraints Confirm s WName) = ( HasFocus s WName )+  initPaneState _ = Cf Nothing Nothing+  drawPane ps _ =+    let draw d = renderDialog d ( padBottom (Pad 1)+                                  $ padLeft (Pad 1)+                                  $ padRight (Pad 1)+                                  $ strWrap $ maybe "Really?" show $ cW ps)+    in draw <$> cD ps+  focusable _ ps = case cD ps of+                     Nothing -> mempty+                     Just _ -> Seq.fromList [ WName "Confirmation" ]+  handlePaneEvent _ = \case+    Vty.EvKey Vty.KEsc [] -> \_ -> return $ Cf Nothing Nothing+    Vty.EvKey Vty.KEnter [] -> \ps -> case cD ps of+      Nothing -> return ps  -- shouldn't happen+      Just d -> return $ ps { cD = Nothing+                            , cW = case dialogSelection d of+                                     Just True -> cW ps+                                     _ -> Nothing+                            }+    ev -> cDL . _Just %%~ \w -> nestEventM' w (handleDialogEvent ev)+  type (UpdateType Confirm) = Maybe Confirm+  updatePane mbCnf ps = ps { cW = mbCnf }+++cDL :: Lens' (PaneState Confirm MyWorkEvent) (Maybe (Dialog Bool))+cDL = lens cD (\s v -> s { cD = v })+++-- | Returns true if the Confirmation modal is active and being displayed.  This+-- is primarily used for detecting the transition from displayed -> not displayed+-- which indicates the user made a decision.+isConfirmationActive :: PaneState Confirm MyWorkEvent -> Bool+isConfirmationActive = isJust . cD+++-- | Retrieve the confirmation, if there is one.+--+-- Verifies that the state is valid for providing confirmation.  The confirmation+-- status is cleared by this action in the returned pane state.+getConfirmedAction :: PaneState Confirm MyWorkEvent+                   -> (PaneState Confirm MyWorkEvent, Maybe Confirm)+getConfirmedAction ps = do+  case (cD ps, cW ps) of+    (Nothing, Just cnf) -> (ps { cW = Nothing }, Just cnf)+    _ -> (ps, Nothing)+++-- | Activate the confirmation modal with the provided Confirm message and+-- action.+showConfirmation :: Confirm+                 -> PaneState Confirm MyWorkEvent+                 -> PaneState Confirm MyWorkEvent+showConfirmation for _ =+  let d = dialog Nothing -- (Just $ show for)+          (Just (1, [ ("OK", True), ("Cancel", False) ]))+          70  -- max width of dialog+  in Cf (Just d) (Just for)
+ lib/Panes/FileMgr.hs view
@@ -0,0 +1,372 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Panes.FileMgr+  (+    FileMgrPane+  , FileMgrOps(..)+  , initFileMgr+  , showFileMgr+  , isFileMgrActive+  , fileMgrReadProjectsFile+  , unsavedChanges+  , fileMgrNotices+  )+where++import           Brick hiding ( Location )+import           Brick.Panes+import           Brick.Widgets.Center+import qualified Brick.Widgets.Core as BC+import           Brick.Widgets.FileBrowser+import qualified Control.Exception as X+import           Control.Lens+import           Control.Monad ( unless )+import           Control.Monad.IO.Class ( MonadIO, liftIO )+import           Data.Aeson ( eitherDecode, encode )+import qualified Data.ByteString.Lazy as BS+import           Data.Maybe ( catMaybes )+import           Data.Maybe ( isJust )+import qualified Data.Sequence as Seq+import qualified Graphics.Vty as Vty+import           Path ( Path, Abs, File, (</>), parseAbsFile+                      , relfile, reldir, parent, toFilePath )+import           Path.IO ( createDirIfMissing, doesFileExist+                         , XdgDirectory(XdgData), getXdgDir )++import           Defs+import           Defs.JSON ()+import           Defs.Static+import           Panes.Common.Attrs+import           Sync+++data FileMgrPane++data FileMgrOps = AckProjectChanges+                | UpdProject (Maybe ProjectName) Project -- add/replace project+                | DelProject ProjectName+                | DelLocation ProjectName LocationSpec+                | DelNote ProjectName LocationSpec NoteTitle++instance Pane WName MyWorkEvent FileMgrPane where+  data (PaneState FileMgrPane MyWorkEvent) =+    FB { fB :: Maybe (FileBrowser WName)+         -- ^ A Nothing value indicates the modal is not currently active+       , myProjects :: Projects+         -- ^ Current loaded set of projects+       , myProjFile :: Maybe (Path Abs File)+       , projsChanged :: Either Confirm Bool+         -- ^ True when myProjects has been updated; clear this via updatePane+       , unsavedChanges :: Bool+         -- ^ True when myProjects has been changed since the last load+       , errMsg :: String+         -- ^ Internal error message to display in the FileMgr modal+       , fmgrMsgs :: [ Widget WName ]+         -- ^ Messages to display when the FileMgr modal exits+       }+  type (DrawConstraints FileMgrPane s WName) = ( HasFocus s WName )+  type (EventConstraints FileMgrPane e) = ( HasFocus e WName )+  initPaneState _ = FB Nothing (Projects mempty) Nothing (Right False)+                    False "" mempty+  drawPane ps gs = drawFB ps gs <$> fB ps+  focusable _ ps = case fB ps of+                     Nothing -> mempty+                     Just _ -> Seq.fromList $ catMaybes+                               [+                                 Just $ WName "FMgr:Browser"+                               , const (WName "FMgr:SaveBtn") <$> myProjFile ps+                               , if isDirSelected ps+                                 then Nothing+                                 else Just $ WName "FMgr:SaveAsBtn"+                               ]+  handlePaneEvent bs ev ts =+    let isSearching = maybe False fileBrowserIsSearching (ts^.fBrowser)+    in case ev of+      Vty.EvKey Vty.KEsc [] | not isSearching -> return $ ts & fBrowser .~ Nothing+      Vty.EvKey (Vty.KChar 's') [Vty.MCtrl] -> do+        ts' <- case myProjFile ts of+          Just fp -> fileMgrSaveProjectsFile fp ts+          Nothing ->+            -- Ctrl-S dismisses the FileMgr window, even on failure+            return ts+        return $ ts'+          & exitMsgsL <>~ (if null (ts ^. errMsgL) then []+                           else [ withAttr a'Error $ str $ ts ^. errMsgL])+          & fBrowser .~ Nothing+      _ -> case bs^.getFocus of+             Focused (Just (WName "FMgr:Browser")) -> handleFileLoadEvent ev ts+             Focused (Just (WName "FMgr:SaveAsBtn")) -> handleFileSaveEvent ev ts+             Focused (Just (WName "FMgr:SaveBtn")) ->+               case myProjFile ts of+                 Just fp -> fileMgrSaveProjectsFile fp ts+                 Nothing -> return ts+             _ -> return ts+  type (UpdateType FileMgrPane) = FileMgrOps+  updatePane = \case+    AckProjectChanges ->+      \ps -> ps { projsChanged = Right False, fmgrMsgs = mempty }+    UpdProject mbOldNm prj ->+      (myProjectsL %~ updateProject mbOldNm prj)+      . (projsChangedL .~ Right True)+      . (unsavedChangesL .~ True)+    DelProject pname ->+      (myProjectsL %~ Projects . filter ((/= pname) . view projNameL) . projects)+      . (projsChangedL .~ Right True)+      . (unsavedChangesL .~ True)+    DelLocation pname locn ->+      let rmvLoc p = if p ^. projNameL == pname+                     then p & locationsL %~ filter (not . thisLoc)+                     else p+          thisLoc = ((== locn) . view locationL)+      in (myProjectsL %~ Projects . fmap rmvLoc . projects)+         . (projsChangedL .~ Right True)+         . (unsavedChangesL .~ True)+    DelNote pname locn nt ->+      let rmvNote p = if p ^. projNameL == pname+                      then p & locationsL %~ fmap rmvNote'+                      else p+          rmvNote' l = if l ^. locationL == locn+                       then l & notesL %~ filter (not . thisNote)+                       else l+          thisNote = ((== nt) . noteTitle)+      in (myProjectsL %~ Projects . fmap rmvNote . projects)+         . (projsChangedL .~ Right True)+         . (unsavedChangesL .~ True)+++fBrowser :: Lens' (PaneState FileMgrPane MyWorkEvent) (Maybe (FileBrowser WName))+fBrowser f ps = (\n -> ps { fB = n }) <$> f (fB ps)++myProjectsL :: Lens' (PaneState FileMgrPane MyWorkEvent) Projects+myProjectsL f wc = (\n -> wc { myProjects = n }) <$> f (myProjects wc)++myProjFileL :: Lens' (PaneState FileMgrPane MyWorkEvent) (Maybe (Path Abs File))+myProjFileL f wc = (\n -> wc { myProjFile = n }) <$> f (myProjFile wc)++projsChangedL :: Lens' (PaneState FileMgrPane MyWorkEvent) (Either Confirm Bool)+projsChangedL f wc = (\n -> wc { projsChanged = n }) <$> f (projsChanged wc)++unsavedChangesL :: Lens' (PaneState FileMgrPane MyWorkEvent) Bool+unsavedChangesL = lens unsavedChanges (\wc n -> wc { unsavedChanges = n })++errMsgL :: Lens' (PaneState FileMgrPane MyWorkEvent) String+errMsgL f wc = (\n -> wc { errMsg = n }) <$> f (errMsg wc)++exitMsgsL :: Lens' (PaneState FileMgrPane MyWorkEvent) [ Widget WName ]+exitMsgsL f wc = (\n -> wc { fmgrMsgs = n }) <$> f (fmgrMsgs wc)++isFileMgrActive :: PaneState FileMgrPane MyWorkEvent -> Bool+isFileMgrActive = isJust . fB++fileMgrNotices :: Lens' (PaneState FileMgrPane MyWorkEvent) [ Widget WName ]+fileMgrNotices = exitMsgsL++isDirSelected :: PaneState FileMgrPane MyWorkEvent -> Bool+isDirSelected ps =+  case fileBrowserCursor =<< fB ps of+    Just fi ->+      case fileStatusFileType <$> fileInfoFileStatus fi of+        Right (Just Directory) -> True+        Right (Just SymbolicLink) -> case fileInfoLinkTargetType fi of+                                       Just Directory -> True+                                       _ -> False+        _ -> False+    Nothing -> False+++instance ( PanelOps FileMgrPane WName MyWorkEvent panes MyWorkCore+         , HasProjects (PaneState FileMgrPane MyWorkEvent)+         )+  => HasProjects (Panel WName MyWorkEvent MyWorkCore panes) where+  getProjects = getProjects . view (onPane @FileMgrPane)++instance HasProjects (PaneState FileMgrPane MyWorkEvent) where+  getProjects ps = (projsChanged ps, myProjects ps)+++drawFB :: DrawConstraints FileMgrPane drawstate WName+       => PaneState FileMgrPane MyWorkEvent+       -> drawstate -> FileBrowser WName -> Widget WName+drawFB ps ds b =+  let width = 70+      fcsd = ds^.getFocus.to focused+      browserFocused = fcsd == Just (WName "FMgr:Browser")+      isDir = isDirSelected ps+      browserPane fb =+        vLimitPercent 55 $ hLimitPercent width+        $ titledB browserFocused "Choose a file"+        $ renderFileBrowser browserFocused fb+      helpPane =+        let esact = if browserFocused+                    then if isDir then "change directory" else "load file"+                    else "save"+        in padTop (BC.Pad 1) $ hLimitPercent width $ vBox+           [ hCenter $ txt "/: search, Ctrl-C or Esc: cancel search"+           , hCenter $ txt $ "Enter/Space: " <> esact+           , hCenter $ txt "TAB: select Save/Load options"+           , hCenter $ txt "ESC: quit"+           ]+      errDisplay fb = case fileBrowserException fb of+                        Nothing -> if null $ errMsg ps+                                   then emptyWidget+                                   else hLimitPercent width+                                        $ withDefAttr a'Error+                                        $ strWrap $ errMsg ps+                        Just e -> hLimitPercent width+                                  $ withDefAttr a'Error+                                  $ strWrap+                                  $ X.displayException e+      savePane = padTop (Pad 1)+                 $ vBox+                 [+                   let a = if fcsd == Just (WName "FMgr:SaveBtn")+                           then withAttr a'Selected+                           else if null f then withAttr a'Disabled else id+                       f = myProjFile ps+                       btxt = case f of+                                Nothing -> " "+                                Just x -> "[SAVE] " <> show x+                   in a $ str btxt+                 , if isDir+                   then withAttr a'Disabled $ str "[SAVE]"+                   else let a = if fcsd == Just (WName "FMgr:SaveAsBtn")+                                then withAttr a'Selected+                                else id+                            btxt =+                              case fileBrowserCursor =<< fB ps of+                                Just fi -> "[SAVE] " <> fileInfoFilePath fi+                                Nothing -> "[SAVE]"+                        in a $ str btxt+                 ]+  in centerLayer (browserPane b <=> errDisplay b <=> savePane <=> helpPane)+++handleFileLoadEvent :: Vty.Event+                    -> PaneState FileMgrPane MyWorkEvent+                    -> EventM WName es (PaneState FileMgrPane MyWorkEvent)+handleFileLoadEvent ev ts =+  case ts^.fBrowser of+    Just fb -> do+      b <- nestEventM' fb $ handleFileBrowserEvent ev+      let selectFile =+            case fileBrowserCursor b of+              Nothing -> return $ ts & fBrowser .~ Just b  -- navigation+              Just f ->+                case parseAbsFile $ fileInfoFilePath f of+                  Just fp -> if unsavedChanges ts+                             then let msg = ConfirmLoad fp+                                  in return $ ts+                                     & projsChangedL .~ Left msg+                                     & fBrowser .~ Nothing+                             else (fBrowser .~ Nothing)+                                  <$> fileMgrReadProjectsFile fp ts+                  Nothing ->+                    -- Current selection is a directory; cannot load a directory,+                    -- so just allow the fBrowser to change to that directory.+                    return $ ts & fBrowser .~ Just b+      case ev of+        Vty.EvKey Vty.KEnter [] -> selectFile+        Vty.EvKey (Vty.KChar ' ') [] -> selectFile -- override filebrowser's default multi-select ability+        _ -> return $ ts & fBrowser .~ Just b & errMsgL .~ ""+    Nothing -> return ts  -- shouldn't happen+++handleFileSaveEvent :: Vty.Event+                    -> PaneState FileMgrPane MyWorkEvent+                    -> EventM WName es (PaneState FileMgrPane MyWorkEvent)+handleFileSaveEvent ev ts =+  case fileBrowserCursor =<< ts^.fBrowser of+    Nothing -> return ts+    Just f ->+      case ev of+        Vty.EvKey Vty.KEnter [] -> doSave f+        Vty.EvKey (Vty.KChar ' ') [] -> doSave f+        _ -> return ts+  where+    doSave f = case parseAbsFile $ fileInfoFilePath f of+                 Just fp -> fileMgrSaveProjectsFile fp ts+                 Nothing -> return $ ts & errMsgL .~ dirErr+    dirErr = "Cannot save to a directory: please select a file"+++ensureDefaultProjectFile :: IO (Path Abs File)+ensureDefaultProjectFile = do+  dataDir <- getXdgDir XdgData $ Just [reldir|mywork|]+  createDirIfMissing True dataDir+  let pFile = dataDir </> [relfile|projects.json|]+  e <- doesFileExist pFile+  unless e $ BS.writeFile (toFilePath pFile) ""+  return pFile+++-- | Called to initialize the FileMgr at startup.  Reads the default Projects+-- file.+initFileMgr :: PaneState FileMgrPane MyWorkEvent+            -> IO (PaneState FileMgrPane MyWorkEvent)+initFileMgr ps = do+  f <- ensureDefaultProjectFile+  ps' <- fileMgrReadProjectsFile f ps+  let e = ps' ^. errMsgL+  unless (null e) $ error e+  return ps'+++readProjectsFile :: MonadIO m => Path Abs File -> m (Either String Projects)+readProjectsFile fp = do+  newprjs <- eitherDecode <$> liftIO (BS.readFile $ toFilePath fp)+  case newprjs of+    Right prjs ->+      Right . Projects <$> mapM (syncProject . hydrate) (projects prjs)+    Left e -> return $ Left e++fileMgrReadProjectsFile :: MonadIO m+                        => Path Abs File+                        -> PaneState FileMgrPane MyWorkEvent+                        -> m (PaneState FileMgrPane MyWorkEvent)+fileMgrReadProjectsFile fp ps = readProjectsFile fp >>= \case+  Left er -> return $ ps & errMsgL .~ er+  Right prjs -> return $ ps+                & myProjectsL .~ prjs+                & myProjFileL .~ Just fp+                & projsChangedL .~ Right True+                & unsavedChangesL .~ False+                & exitMsgsL <>~ [ withAttr a'Notice $ str $ "Loaded " <> show fp ]+++fileMgrSaveProjectsFile :: MonadIO m+                        => Path Abs File+                        -> PaneState FileMgrPane MyWorkEvent+                        -> m (PaneState FileMgrPane MyWorkEvent)+fileMgrSaveProjectsFile fp ps =+  do let prjs = Projects (dehydrate <$> (projects $ myProjects ps))+     liftIO $ BS.writeFile (toFilePath fp) (encode prjs)+     return $ ps+       & fBrowser .~ Nothing+       & myProjFileL .~ Just fp+       & unsavedChangesL .~ False+       & exitMsgsL <>~ [ withAttr a'Notice $ str $ "Wrote " <> show fp ]++-- | Called to display the FileMgr modal pane to allow the user to Load or Save.+showFileMgr :: PaneState FileMgrPane MyWorkEvent+            -> IO (PaneState FileMgrPane MyWorkEvent)+showFileMgr prev =+  case prev ^. fBrowser of+    Just _ -> return prev+    Nothing -> do+      let n = WName "FMgr:Browser"+      dataDir <- parent <$> ensureDefaultProjectFile+      fb <- newFileBrowser selectNonDirectories n (Just $ toFilePath dataDir)+      return $ prev & fBrowser .~ Just fb++----------------------------------------------------------------------+
+ lib/Panes/Help.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}++module Panes.Help+  ( HelpPane(..)+  , initHelp+  )+where++import           Brick+import           Brick.Panes+import           Brick.Widgets.Center+import qualified Brick.Widgets.Core as BC+import qualified Data.Text as T+import qualified Graphics.Vty as Vty++import           Defs+import           Panes.Common.Attrs+import           Panes.Common.QQDefs+++data HelpPane = HelpPane++instance Pane WName appEv HelpPane where+  data (PaneState HelpPane appEv) = H Bool+  initPaneState _ = H False+  focusable _ (H ps) = focus1If (WName "Help") ps+  drawPane (H ps) _ = if ps then Just drawHelp else Nothing+  handlePaneEvent _ ev ps = handleHelpEvent ps ev+++initHelp :: PaneState HelpPane appEv+initHelp = H True+++drawHelp :: Widget WName+drawHelp =+  let hsize = 70+      infoPane = vLimitPercent 80 $ hLimitPercent hsize+                 $ modalB "MyWork Help"+                 $ withVScrollBarHandles+                 $ withVScrollBars OnRight+                 $ viewport (WName "HelpScroll") Vertical+                 $ helpInfo+      helpInfo = vBox (txtWrap . (<> " ") <$> T.lines helpText)+      helpPane = padTop (BC.Pad 1) $ hLimitPercent hsize $ vBox+        [ hCenter $ txt "Arrow Up/Arrow Down : scroll vertically by lines"+        , hCenter $ txt "Page Up/Page Down : scroll vertically by page"+        , hCenter $ txt "ESC: quit"+        ]+  in centerLayer (infoPane <=> helpPane)+++handleHelpEvent :: PaneState HelpPane appEv -> Vty.Event+                -> EventM WName es (PaneState HelpPane appEv)+handleHelpEvent hs = \case+  Vty.EvKey Vty.KEsc [] -> return $ H False+  Vty.EvKey Vty.KUp [] ->+    vScrollBy (viewportScroll (WName "HelpScroll")) (-1) >> return hs+  Vty.EvKey Vty.KDown [] ->+    vScrollBy (viewportScroll (WName "HelpScroll")) 1 >> return hs+  Vty.EvKey Vty.KPageUp [] ->+    vScrollBy (viewportScroll (WName "HelpScroll")) (-10) >> return hs+  Vty.EvKey Vty.KPageDown [] ->+    vScrollBy (viewportScroll (WName "HelpScroll")) 10 >> return hs+  _ -> return hs+++helpText :: T.Text+helpText = [sq|+This is the displayed help information+----------------------------------------+The MyWork application is designed to help keep track of the things you are+working on.  This is particularly useful in a workflow where multiple projects+are being worked on, or where multiple instances of a particular project are+being worked on, with different efforts (bugfixes, features) in the different+instances.  Mentally switching contexts between the different projects and+locations can be a challenge, especially when trying to remember what was being+done in a particular location, or the relationship of that location to other+locations.++The MyWork application is a simple application that organizes and remembers+these different projects and locations, along with any notes you'd like to+attach to each location.  When switching from working on one thing to the next,+this application can provide a place to make a note about what was in-progress+in the current location, and read about the status of the new location to+reconstruct the context for that location.++Locations can be local directories or network VCS locations (e.g. github).+Local locations can provide more information, but it is helpful to also track+the public or remote locations for projects.++The display is divided into the following primary parts:++    +--------------------------------++    | Summary                        |+    |--------------------------------|+    | Projects | Locations           |+    |          |                     |+    |          |                     |+    |          |                     |+    |          |---------------------|+    |          | Location Notes      |+    |          |                     |+    |          |                     |+    |--------------------------------|+    |           Controls             |+    +--------------------------------++++   TAB / Shift+TAB     -- switch between active panes+   Ctrl-S              -- save (to previously loaded file, if any)+   Ctrl-Q              -- quit++The full note area can be scrolled by using the Ctrl key in conjunction with+the arrow and page-up/page-down keys.++Each Project can have zero or more locations where that Project exists.  These+locations can be local directories, remote URLs (e.g. github), or any other+desired text.  Any local directory location may be scanned to find additional+locations automatically.  Each location can optionally have a date, which is+usually the date of the last update (local directory locations will+automatically update the date with the last modified date of the top-level+directory); the date is user information and locations will be sorted primarily+by date and secondarily by location text.++Each Location is associated with zero or more Notes.  Each Note is a free-form+text paragraph, whose first line acts as the note "title".  In addition to notes+entered by the user in mywork, if the location is local and contains an+"@MyWork" directory, any file in that directory with the .txt extension will be+added as a note.  The first word of a note may be one of the following words+which will be highlighted specially:++  * TODO [date]+  * IN-PROGRESS+  * FUTURE [date]+  * BLOCKING++The TODO and FUTURE words may be followed by another word that specifies a date.+Dates in the past (expired) will be highlighted differently than dates in the+future (pending).++The Summary area shows the total number of projects (by role), as well as the+date range of locations.++----------------------------------------+|]
+ lib/Panes/Location.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Panes.Location () where++import           Brick hiding ( Location, on )+import           Brick.Panes+import           Brick.Widgets.List+import           Control.Lens+import           Data.Function ( on )+import qualified Data.List as DL+import           Data.Maybe ( fromMaybe )+import           Data.Time.Calendar+import qualified Data.Vector as V++import           Defs+++instance Pane WName MyWorkEvent Location where+  data (PaneState Location MyWorkEvent) =+    L { lL :: List WName (LocationSpec, Bool, Maybe Day)+      , lP :: Maybe Project+      }+  type (InitConstraints Location s) = ( HasSelection s, HasProjects s )+  type (DrawConstraints Location s WName) = ( HasFocus s WName, HasSelection s )+  type (UpdateType Location) = Maybe Project+  initPaneState gs =+    let l = L (list (WName "Loc:LList") mempty 1) Nothing+        update x = do p <- selectedProject gs+                      prj <- DL.find ((== p) . view projNameL)+                                     (projects $ snd $ getProjects gs)+                      return $ updatePane (Just prj) x+    in fromMaybe l $ update l+  drawPane ps gs =+    let isFcsd = gs^.getFocus.to focused == Just WLocations+        rndr (l,v,d) =+          let lattr = if v then id else withAttr a'Error+          in (lattr (str $ show $ l)+              <+> vLimit 1 (fill ' ')+              <+> (if v+                    then str $ maybe "*" show d+                    else withAttr a'Error $ str "INVALID"+                  )+             )+                     -- <=> str " "+    in Just+       $ withVScrollBars OnRight+       $ renderList (const rndr) isFcsd (lL ps)+  focusable _ ps = focus1If WLocations+                   $ not $ null $ listElements $ lL ps+  handlePaneEvent _ ev = lList %%~ \w -> nestEventM' w (handleListEvent ev)+  updatePane = \case+    Nothing -> (lList %~ listReplace mempty Nothing) . (lProj .~ Nothing)+    Just prj -> \ps ->+      let ents = [ (l ^. locationL, l ^. locValidL, l ^. locatedOnL)+                 | l <- prj ^. locationsL ]+          np = if null ents then Nothing else Just 0+          curElem = maybe id listMoveTo $ listSelected $ lL ps+          locOrd (l,v,d) = (d,l,v)+          sortLocs = DL.reverse . DL.sortBy (compare `on` locOrd)+      in ps+         & lList %~ (curElem . listReplace (V.fromList $ sortLocs ents) np)+         & lProj .~ Just prj+++lList :: Lens' (PaneState Location MyWorkEvent)+         (List WName (LocationSpec, Bool, Maybe Day))+lList f ps = (\n -> ps { lL = n }) <$> f (lL ps)++lProj :: Lens' (PaneState Location MyWorkEvent) (Maybe Project)+lProj f ps = (\n -> ps { lP = n }) <$> f (lP ps)+++instance HasLocation (PaneState Location MyWorkEvent) where+  selectedLocation ps = do+    prj <- lP ps+    curr <- listSelectedElement $ lL ps+    return ( prj ^. projNameL, (\(l,_,_) -> l) $ snd curr )
+ lib/Panes/LocationInput.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Panes.LocationInput+  (+    LocationInputPane+  , initLocInput+  , isLocInputActive+  , locationInputResults+  )+where++import           Brick hiding ( Location )+import           Brick.Focus+import           Brick.Forms+import           Brick.Panes+import qualified Brick.Widgets.Center as C+import           Control.Lens+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+++data LocationInputPane+++data NewLoc = NewLoc { _nlName :: LocationSpec+                     , _nlDay :: Maybe Day+                     }++makeLenses ''NewLoc+++blankNewLoc :: NewLoc+blankNewLoc = NewLoc (RemoteSpec "") Nothing++type LocForm = Form NewLoc MyWorkEvent WName++instance Pane WName MyWorkEvent LocationInputPane where+  data (PaneState LocationInputPane MyWorkEvent) = NL { nLF :: Maybe LocForm+                                                        -- Just == pane active+                                                      , nLoc :: Maybe Location+                                                      -- reset to Nothing when+                                                      -- nLF transitions Nothing+                                                      -- to Just+                                                      , nProj :: ProjectName+                                                      , nOrig :: Maybe Location+                                                      , nErr :: Maybe Text+                                                      }++  type (EventType LocationInputPane WName MyWorkEvent) = BrickEvent WName MyWorkEvent+  initPaneState _ = NL Nothing Nothing (ProjectName "") Nothing Nothing+  drawPane ps _gs =+    C.centerLayer+    . modalB ((maybe "New" (const "Edit") $ nOrig ps)+              <> " " <> (let ProjectName pnm = nProj ps in T.pack $ show pnm)+              <> " Location")+    . vLimit 25+    . 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 ' ')+                  ]) <$> nLF ps+  focusable _ ps = case nLF ps of+                     Nothing -> mempty+                     Just f -> Seq.fromList $ focusRingToList $ formFocus f+  handlePaneEvent _ = \case+    VtyEvent (Vty.EvKey Vty.KEsc []) -> nLFL %%~ const (return Nothing)+    VtyEvent (Vty.EvKey (Vty.KChar 'd') [Vty.MCtrl]) -> \s ->+      let pf = s ^. nLFL+          np form = Location { location = form ^. nlName+                             , locatedOn = form ^. nlDay+                             , notes = mempty+                             , locCore = LocRT+                                         { locValid = True  -- assumed+                                         }+                            }+      in if maybe False allFieldsValid pf+         then do let l = np . formState <$> pf+                 return $ s & nLFL .~ Nothing & newLocation .~ l+         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 }+                & (nLFL . _Just %%~ \w -> nestEventM' w (handleFormEvent ev))+++nLFL :: Lens' (PaneState LocationInputPane MyWorkEvent) (Maybe LocForm)+nLFL f s = (\n -> s { nLF = n }) <$> f (nLF s)++isLocInputActive :: PaneState LocationInputPane MyWorkEvent -> Bool+isLocInputActive = isJust . nLF+++newLocation :: Lens' (PaneState LocationInputPane MyWorkEvent) (Maybe Location)+newLocation f s = (\n -> s { nLoc = n }) <$> f (nLoc s)+++-- | Returns the original location name (if any) and the new Location+-- specification.+locationInputResults :: PaneState LocationInputPane MyWorkEvent+                     -> (Maybe LocationSpec, Maybe Location)+locationInputResults ps = (view locationL <$> nOrig ps, nLoc ps)+++validateForm :: EventM WName es (PaneState LocationInputPane MyWorkEvent)+             -> EventM WName es (PaneState LocationInputPane MyWorkEvent)+validateForm inner = do+  s <- inner+  case s ^. nLFL of+    Nothing -> return s+    Just pf ->+      do (tgt,valid) <- validateLocationInput False $ formState pf ^. nlName+         return $ s & nLFL %~ fmap (setFieldValid valid tgt)+++initLocInput :: ProjectName+             -> [Location]+             -> Maybe Location+             -> PaneState LocationInputPane MyWorkEvent+             -> PaneState LocationInputPane MyWorkEvent+initLocInput prjName locs mbLoc ps =+  case nLF 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+          labelWidth = 15+          nlForm =+            newForm+            [+              label "Location" @@= locationInput locs mbLoc False nlName+            , label "Date" @@= mbDateInput nlDay+            ]+            (case mbLoc of+               Nothing -> blankNewLoc+               Just l -> NewLoc { _nlName = l ^. locationL+                                , _nlDay = l ^. locatedOnL+                                }+            )+      in NL { nLF = Just nlForm+            , nProj = prjName+            , nLoc = Nothing+            , nOrig = mbLoc+            , nErr = Nothing+            }
+ lib/Panes/Messages.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Panes.Messages+  (+    MessagesPane+  )+where++import           Brick+import           Brick.Panes+import           Control.Lens++import           Defs+++data MessagesPane++instance Pane WName MyWorkEvent MessagesPane where+  data (PaneState MessagesPane MyWorkEvent) = M [Widget WName]+  type UpdateType MessagesPane = Maybe [Widget WName]+  initPaneState _ = M mempty+  drawPane (M msgs) _ = Just $ if null msgs then str " " else vBox msgs+  updatePane mbw (M msgs) = case mbw of+                              Nothing -> M mempty+                              Just ms -> M $ msgs <> ms+++instance HasMessage (PaneState MessagesPane MyWorkEvent) where+  getMessage (M msgs) = msgs++instance ( PanelOps MessagesPane WName MyWorkEvent panes MyWorkCore+         , HasMessage (PaneState MessagesPane MyWorkEvent)+         )+  => HasMessage (Panel WName MyWorkEvent MyWorkCore panes) where+  getMessage = getMessage . view (onPane @MessagesPane)
+ lib/Panes/NoteInput.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Panes.NoteInput+  (+    NoteInputPane+  , initNoteInput+  , isNoteInputActive+  , noteInputResults+  )+where++import           Brick hiding ( Location )+import           Brick.Focus+import           Brick.Forms+import           Brick.Panes+import qualified Brick.Widgets.Center as C+import           Control.Lens+import           Control.Monad.IO.Class ( MonadIO, liftIO )+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           Data.Time.Clock ( getCurrentTime, utctDay )+import qualified Graphics.Vty as Vty++import           Defs+import           Panes.Common.Inputs+import           Panes.Common.Attrs+++data NoteInputPane+++data NewNote = NewNote { _nnText :: Text+                       , _nnDay :: Day+                       }++makeLenses ''NewNote+++blankNewNote :: NewNote+blankNewNote = NewNote "" (toEnum 0)++type NoteForm = Form NewNote MyWorkEvent WName++instance Pane WName MyWorkEvent NoteInputPane where+  data (PaneState NoteInputPane MyWorkEvent) = NN { nNF :: Maybe NoteForm+                                                    -- Just == pane active+                                                  , nNote :: Maybe Note+                                                    -- reset to Nothing when+                                                    -- nNF transitions Nothing+                                                    -- to Just+                                                  -- KWQ , nProj :: Text+                                                  , nOrig :: Maybe Note+                                                  , nErr :: Maybe Text+                                                }+  type (EventType NoteInputPane WName MyWorkEvent) = BrickEvent WName MyWorkEvent+  initPaneState _ = NN Nothing Nothing Nothing Nothing+  drawPane ps _gs =+    C.centerLayer+    . modalB ((maybe "New" (const "Edit") $ nOrig ps)+               -- <> " " <> show (nProj ps)+               <> " Note")+    . vLimit 25+    . hLimitPercent 65+    . (\f -> vBox [ renderForm f+                  , padBottom (Pad 1) $ withAttr a'Error+                    $ maybe emptyWidget txt (nErr ps)+                  , emptyWidget+                  , vLimit 1 (fill ' ' <+> str "Ctrl-D = accept"+                              <+> fill ' ' <+> str "ESC = abort"+                              <+> fill ' ')+                  ]) <$> nNF ps+  focusable _ ps = case nNF ps of+                     Nothing -> mempty+                     Just f -> Seq.fromList $ focusRingToList $ formFocus f+  handlePaneEvent _ = \case+    VtyEvent (Vty.EvKey Vty.KEsc []) -> nNFL %%~ const (return Nothing)+    VtyEvent (Vty.EvKey (Vty.KChar 'd') [Vty.MCtrl]) -> \s ->+      let pf = s ^. nNFL+          np form = Note { note = form ^. nnText+                         , notedOn = form ^. nnDay+                         , noteCore =+                             NoteRT+                             { noteSource = MyWorkDB+                             }+                         }+      in if maybe False allFieldsValid pf+         then+           return $ s & nNFL .~ Nothing & newNote .~ (np . formState <$> pf)+         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 }+                & (nNFL . _Just %%~ \w -> nestEventM' w (handleFormEvent ev))+++nNFL :: Lens' (PaneState NoteInputPane MyWorkEvent) (Maybe NoteForm)+nNFL f s = (\n -> s { nNF = n }) <$> f (nNF s)++isNoteInputActive :: PaneState NoteInputPane MyWorkEvent -> Bool+isNoteInputActive = isJust . nNF+++newNote :: Lens' (PaneState NoteInputPane MyWorkEvent) (Maybe Note)+newNote f s = (\n -> s { nNote = n }) <$> f (nNote s)+++-- | Returns the original note name (if any) and the new Note+-- specification.+noteInputResults :: PaneState NoteInputPane MyWorkEvent+                 -> (Maybe NoteTitle, Maybe Note)+noteInputResults ps = (noteTitle <$> nOrig ps, nNote ps)+++-- KWQ: remove!?+validateForm :: EventM WName es (PaneState NoteInputPane MyWorkEvent)+             -> EventM WName es (PaneState NoteInputPane MyWorkEvent)+validateForm inner = do+  s <- inner+  case s ^. nNFL of+    Nothing -> return s+    Just _f -> return s+++initNoteInput :: MonadIO m+              => [Note]+              -> Maybe Note+              -> PaneState NoteInputPane MyWorkEvent+              -> m (PaneState NoteInputPane MyWorkEvent)+initNoteInput curNotes mbNote ps = do+  now <- utctDay <$> liftIO getCurrentTime+  case nNF ps of+    Just _ -> return ps+    Nothing ->+      let label s = padBottom (Pad 1) . label' s+          label' s w = (vLimit 1 $ hLimit labelWidth+                        $ fill ' ' <+> str s <+> str ": ") <+> w+          labelWidth = 15+          nlForm =+            newForm+            [+              label "Note" @@=+              let validate = \case+                    [] -> Nothing+                    [""] -> Nothing+                    o -> let nt = noteTitle' $ T.unlines o+                         in if (nt `elem` (noteTitle <$> curNotes)+                                && (maybe True ((nt /=) . noteTitle) mbNote))+                            then Nothing  -- invalid+                            else Just $ T.intercalate "\n" o+              in editField nnText (WName "New Note")+                 Nothing+                 -- (Just 20)+                 id validate (txt . T.intercalate "\n") id+            , label "Date" @@= let validate = \case+                                     ("":_) -> Nothing+                                     (l:_) -> textToDay l+                                     _ -> Nothing+                                   dayInit = T.pack . show+                                   dayRender = txt . headText+                               in editField nnDay (WName "Note Date (Y-M-D)")+                                  (Just 1) dayInit validate dayRender id+            ]+            (case mbNote of+               Nothing -> blankNewNote { _nnDay = now }+               Just l -> NewNote { _nnText = l ^. noteL+                                 , _nnDay = l ^. notedOnL+                                 }+            )+      in return $ NN { nNF = Just nlForm+                     -- , nProj = projName+                     , nNote = Nothing+                     , nOrig = mbNote+                     , nErr = Nothing+                     }
+ lib/Panes/Notes.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Panes.Notes () where++import           Brick hiding ( Location )+import           Brick.Panes+import           Brick.Widgets.List+import           Control.Lens+import           Control.Monad ( join )+import qualified Data.List as DL+import qualified Data.Vector as V+import qualified Graphics.Vty as Vty++import           Defs+++instance Pane WName MyWorkEvent Note where+  data (PaneState Note MyWorkEvent) = N { nL :: List WName Note+                                        , nLoc :: Maybe Location+                                        }+  type (InitConstraints Note s) = ( HasLocation s+                                  , HasProjects s+                                  , HasSelection s+                                  )+  type (DrawConstraints Note s WName) = ( HasFocus s WName+                                        , HasLocation s+                                        , HasDate s+                                        )+  type (UpdateType Note) = Maybe Location+  initPaneState gs =+    let l = N (list (WName "Notes:List") mempty 1) Nothing+    in flip updatePane l $ join $ snd <$> getCurrentLocation gs+  updatePane mbl ps =+    let curElem = maybe id listMoveTo $ listSelected $ nL ps+        nl =+          case mbl of+            Just l -> curElem+                      . listReplace (V.fromList $ sortNotes $ l^.notesL) (Just 0)+            Nothing -> listReplace mempty Nothing+        sortNotes = DL.sort -- see Ord instance for Note+    in N (nl (nL ps)) mbl+  drawPane ps gs =+    let isFcsd = gs^.getFocus.to focused == Just WNotes+        rndr nt = ttlAttr nt+                  $ str (show (nt ^. notedOnL))+                  <+> txt " -"+                  <+> (if nt ^. noteSourceL == ProjLoc+                      then txt "@ "+                      else txt "- ")+                  <+> ttl nt+        -- KWQ: show indication on Location or Project of expired/todo/inprog?+        ttlAttr nt = case nt ^. noteSourceL of+                       MyWorkDB -> withAttr a'NoteSourceMyWork+                       ProjLoc -> withAttr a'NoteSourceProjLoc+                       MyWorkGenerated -> withAttr a'NoteSourceGenerated+        pendColor present due =+          let ndays = fromEnum due - fromEnum present+              v = min (255::Int) ndays+              r = 255 - v+              g = if v == 0 then 0 else 25 + v `div` 2+              color = Vty.rgbColor r g 0+              amap = forceAttrMap (fg color)+          in updateAttrMap (const amap)+        ttl n = case noteKeyword n of+                  (Just (FUTURE_ d), NoteRemTitle r) ->+                    withAttr a'NoteWordFuture (txt "FUTURE")+                    <+> txt " "+                    <+> (if getToday gs <= d+                          then pendColor (getToday gs) d $ str $ show d+                          else withAttr a'NoteWordExpired $ str $ show d)+                    <+> txt " "+                    <+> txt r+                  (Just (TODO_ d), NoteRemTitle r) ->+                    withAttr a'NoteWordTODO (txt "TODO")+                    <+> txt " "+                    <+> (if getToday gs <= d+                          then pendColor (getToday gs) d $ str $ show d+                          else withAttr a'NoteWordExpired $ str $ show d)+                    <+> txt " "+                    <+> txt r+                  (Just o, NoteRemTitle r) ->+                    withAttr (noteKeywordAttr o) (str $ show o)+                    <+> txt " "+                    <+> txt r+                  (Nothing, NoteRemTitle t) -> txt t+    in Just $ vBox [ withVScrollBars OnRight+                     $ renderList (const rndr) isFcsd (nL ps)+                     -- , hBorder+                   , vLimit 1 (fill '-'+                               <+> str " vv - Full Note - vv "+                               <+> fill '-')+                   , let rndrN nt = vLimit 1 (ttlAttr nt $ ttl nt)+                                    <=>+                                    (vLimitPercent 75+                                     $ withVScrollBars OnRight+                                     $ viewport (WName "Notes:Scroll") Vertical+                                     $ txtWrap+                                     $ noteBody+                                     $ nt)+                         blank = str " "+                     in maybe blank (rndrN . snd) $ listSelectedElement $ nL ps+                   ]+  focusable _ ps = focus1If WNotes $ not $ null $ listElements $ nL ps+  handlePaneEvent _ =+    let scroll o amt = \ps ->+          do _ <- o (viewportScroll (WName "Notes:Scroll")) amt+             return ps+    in \case+      --   * Scroll full note region with CTRL-up/down/page-up/page-down+      Vty.EvKey Vty.KUp [Vty.MCtrl] -> scroll vScrollBy (-1)+      Vty.EvKey Vty.KDown [Vty.MCtrl] -> scroll vScrollBy 1+      Vty.EvKey Vty.KLeft [Vty.MCtrl] -> scroll hScrollBy (-1)+      Vty.EvKey Vty.KRight [Vty.MCtrl] -> scroll hScrollBy 1+      Vty.EvKey Vty.KPageUp [Vty.MCtrl] -> scroll vScrollBy (-10)+      Vty.EvKey Vty.KPageDown [Vty.MCtrl] -> scroll vScrollBy 10+      ev -> nList %%~ \w -> nestEventM' w (handleListEvent ev)+++nList :: Lens' (PaneState Note MyWorkEvent) (List WName Note)+nList f ps = (\n -> ps { nL = n }) <$> f (nL ps)+++instance HasNote (PaneState Note MyWorkEvent) where+  selectedNote ps = do+    curr <- listSelectedElement $ nL ps+    locn <- nLoc ps+    return ( locn ^. locationL, noteTitle $ snd curr )
+ lib/Panes/Operations.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Panes.Operations+  (+    OperationsPane+  )+where++import           Brick+import           Brick.Panes+import qualified Data.List as DL+import           Data.Maybe ( catMaybes )++import           Defs+++data OperationsPane++instance Pane WName MyWorkEvent OperationsPane where+  data (PaneState OperationsPane MyWorkEvent) = Unused+  type (DrawConstraints OperationsPane s WName) = ( HasSelection s+                                                  , HasProjects s+                                                  , HasLocation s+                                                  , HasNote s+                                                  , HasFocus s WName+                                                  )+  initPaneState _ = Unused+  drawPane _ gs =+    let o = opOnSelection gs+        projInd = case selectedProject gs of+                    Nothing -> withAttr a'Disabled+                    Just _ -> id+        addWhat x = case x of+                      ProjectOp -> "Project"+                      LocationOp -> "Location"+                      NoteOp -> "Note"+        canEdit = \case+          NoteOp -> maybe False id+                    $ do (_,l') <- getCurrentLocation gs+                         l <- l'+                         n <- getCurrentNote gs l+                         return $ canEditNote n+          _ -> True+        enabled b = if b then id else withAttr a'Disabled+        ops = DL.intersperse (fill ' ')+              $ withAttr a'Operation+              <$> catMaybes+              [+                Just $ str $ "F1 Help"+              , Just $ str $ "F2 Add " <> addWhat o+              , if o == maxBound+                then Nothing+                else Just $ projInd $ str $ "F3 Add " <> addWhat (succ o)+              -- , projInd $ str "F4: Add Note"+              , Just $ enabled (canEdit o) $ projInd $ str "C-e Edit"+              , Just $ enabled (canEdit o) $ projInd $ str "Del Delete"+              , Just $ str "F9 Load/Save"+              -- , Just $ str $ "C-q Quit"+              ]+    in Just $ vLimit 1 $ str " " <+> hBox ops <+> str " "
+ lib/Panes/ProjInfo.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Panes.ProjInfo+  (+    ProjInfoPane+  )+where++import           Brick+import           Brick.Panes+import           Control.Lens+import qualified Data.List as DL++import           Defs+++data ProjInfoPane++instance Pane WName MyWorkEvent ProjInfoPane where+  data (PaneState ProjInfoPane MyWorkEvent) = Unused+  type (DrawConstraints ProjInfoPane s WName) = ( HasSelection s+                                                , HasProjects s+                                                )+  initPaneState _ = Unused+  drawPane _ gs =+    case selectedProject gs of+      Nothing -> Nothing+      Just p ->+        let mkPane prj =+              vBox+              [ withAttr a'ProjName (let ProjectName nm = p in txt nm)+                <+> vLimit 1 (fill ' ')+                <+> str "  ["+                <+> (str $ show $ prj ^. groupL)+                <+> str ", "+                <+> (withAttr (roleAttr $ prj ^. roleL)+                     $ str $ show $ prj ^. roleL)+                <+> str "]"+              , str "    " <+> txtWrap (prj ^. descriptionL)+              , str " "+              , txt $ "Language: " <> languageText (prj ^. languageL)+              ]+            nameMatch = (== p) . view projNameL+        in mkPane <$> DL.find nameMatch (projects $ snd $ getProjects gs)
+ lib/Panes/Projects.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Panes.Projects () where++import           Brick+import           Brick.Panes+import           Brick.Widgets.Edit+import           Brick.Widgets.List+import           Control.Lens+import qualified Data.List as DL+import qualified Data.Sequence as Seq+import           Data.Text ( Text )+import qualified Data.Text as T+import qualified Data.Text.Zipper as TZ+import qualified Data.Vector as V+import qualified Graphics.Vty as Vty++import           Defs+++instance Pane WName MyWorkEvent Projects where+  data (PaneState Projects MyWorkEvent) = P { pL :: List WName (Role, ProjectName)+                                            , pS :: Editor Text WName+                                            , oC :: [ (Role, ProjectName) ]+                                            }+  type (InitConstraints Projects s) = ( HasProjects s )+  type (DrawConstraints Projects s WName) = ( HasFocus s WName )+  type (EventType Projects WName MyWorkEvent) = BrickEvent WName MyWorkEvent+  type (UpdateType Projects) = Projects++  initPaneState s =+    let prjs = projects $ snd $ getProjects s+        oc = DL.sort (mkListEnt <$> prjs)+        pl = list (WName "Projs:List") (V.fromList oc) 1+        ps = editor (WName "Projs:Filter") (Just 1) ""+    in P pl ps oc++  drawPane ps gs =+    let isFcsd = gs^.getFocus.to focused == Just WProjList+        renderListEnt _ (r,n) = withAttr (roleAttr r)+                                $ let ProjectName nm = n in txt nm+        lst = withVScrollBars OnRight $ renderList renderListEnt isFcsd (pL ps)+        srch = str "Search: " <+> renderEditor (txt . head) isFcsd (pS ps)+    in Just $ vBox [ lst, srch ]++  -- Pass the event to both the list and the search text box: since the search+  -- text box is only a single line, there is no conflict between the two+  -- widget's handling of events.+  handlePaneEvent _ ev ps = do+    -- Pass event to the list+    ps1 <- case ev of+             VtyEvent ev' ->+               ps & pList %%~ \w -> nestEventM' w (handleListEvent ev')+             _ -> return ps++    -- Pass event to the search list+    let origSearchText = head $ ps ^. pSrch . to getEditContents+    ps2 <- ps1 & pSrch %%~ \w -> nestEventM' w (handleEditorEvent ev)+    let searchText = head $ ps2 ^. pSrch . to getEditContents++    let ps3 =+          case ev of+            VtyEvent (Vty.EvKey Vty.KEnter []) ->+              -- this does nothing ordinarily, but if there is text in the search+              -- box, this will "select" the current element, returning the list+              -- to the full original contents and clearing the search box.+              let nl = oC ps2+                  np = if null nl then Nothing else Just 0+                  curElem = maybe id (listMoveToElement . snd)+                            $ listSelectedElement $ pL ps2+              in ps2+                 & pList %~ (curElem . listReplace (V.fromList nl) np)+                 & pSrch . editContentsL %~ TZ.clearZipper+            _ -> ps2+++    -- If the search box text was updated, by this event, update the list+    -- accordingly.+    if searchText == origSearchText+      then return ps3+      else let nmtxt ent = let ProjectName pnt = snd ent in pnt+               nc = if T.null searchText+                    then oC ps3+                    else filter ((searchText `T.isInfixOf`) . nmtxt) (oC ps3)+               np = if null nc then Nothing else Just 0+           in return $ ps3 & pList %~ listReplace (V.fromList nc) np++  focusable _ _ = Seq.singleton WProjList++  updatePane newprjs ps =+    let oc = DL.sort (mkListEnt <$> projects newprjs)+        curElem = maybe id listMoveTo $ listSelected $ pL ps+    in ps+       & pList %~ (curElem . listReplace (V.fromList oc) (Just 0))+       & pSrch . editContentsL %~ TZ.clearZipper+       & pOrig .~ oc+++pList :: Lens' (PaneState Projects MyWorkEvent) (List WName (Role, ProjectName))+pList f ps = (\n -> ps { pL = n }) <$> f (pL ps)++pSrch :: Lens' (PaneState Projects MyWorkEvent) (Editor Text WName)+pSrch f ps = (\n -> ps { pS = n }) <$> f (pS ps)++pOrig :: Lens' (PaneState Projects MyWorkEvent) [ (Role, ProjectName) ]+pOrig f ps = (\n -> ps { oC = n }) <$> f (oC ps)++mkListEnt :: Project -> (Role, ProjectName)+mkListEnt pr = (pr ^. roleL, pr ^. projNameL)+++instance HasSelection (PaneState Projects MyWorkEvent) where+  selectedProject = fmap (snd . snd) . listSelectedElement . pL
+ lib/Panes/Summary.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Panes.Summary+  (+    SummaryPane+  )+where++import           Brick+import           Brick.Panes+import           Control.Lens+import           Data.Maybe ( catMaybes )++import           Defs+++data SummaryPane++instance Pane WName MyWorkEvent SummaryPane where+  data (PaneState SummaryPane MyWorkEvent) = Unused+  type (DrawConstraints SummaryPane s WName) = ( HasProjects s )+  initPaneState _ = Unused+  drawPane _ s = Just $ drawSummary (snd $ getProjects s)+++drawSummary :: Projects -> Widget WName+drawSummary prjcts =+    let prjs = projects prjcts+        prjcnt = (str "# Projects: " <+>)+                    $ foldr ((<+>) . (<+> str ", "))+                      (str ("Total=" <> show (length prjs)))+                    [ withAttr (roleAttr r) (str $ show r)+                      <+> str "="+                      <+> str (show (length fp))+                    | r <- [minBound .. maxBound]+                    , let fp = filter (isRole r) prjs+                    , not (null fp)+                    ]+        isRole r p = r == p ^. roleL+        dateRange = if null projDates+                    then str ""+                    else str (show (minimum projDates)+                              <> ".."+                              <> show (maximum projDates)+                             )+        locDates prj = catMaybes (view locatedOnL <$> prj ^. locationsL)+        projDates = concatMap locDates prjs+    in vLimit 1+       $ if null prjs+         then str "No projects defined"+         else prjcnt <+> fill ' ' <+> dateRange
+ lib/Sync.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TupleSections #-}++module Sync+  -- (+  -- )+where++import           Control.Applicative ( (<|>) )+import           Control.Lens+import           Control.Monad ( filterM, foldM )+import           Control.Monad.IO.Class ( MonadIO, liftIO )+import           Control.Monad.State ( StateT, evalStateT, gets, modify )+import qualified Data.HashMap.Lazy as HM+import           Data.Ini+import qualified Data.List as DL+import           Data.Maybe ( catMaybes )+import           Data.Text ( Text )+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import           Data.Time.Calendar ( Day )+import           Data.Time.Clock ( getCurrentTime, utctDay )+import           Path ( (</>), Path, Abs, Dir, relfile, reldir+                      , toFilePath, parseAbsDir, fileExtension )+import           Path.IO ( doesDirExist, doesFileExist, getModificationTime+                         , listDir )++import           Defs+++data LocationStatus = LocationStatus { locExists :: Maybe Bool+                                     , otherLocs :: [ (LType, LocationSpec) ]+                                     , locNotes :: [ Note ]+                                     , lastUpd :: Maybe Day+                                     }++data LType = GitRepo GitRemote | GitFork LType | DarcsRepo+  deriving Eq++newtype GitRemote = GitRemote Text+  deriving Eq+++syncLocation :: MonadIO m => Location -> m LocationStatus+syncLocation l = case l ^. locationL of+  LocalSpec lcl ->+    do e <- liftIO $ doesDirExist lcl+       u <- if e+            then Just . utctDay <$> liftIO (getModificationTime lcl)+            else return Nothing+       o <- getOtherLocs lcl+       nts <- getLocNotes lcl+       return $ LocationStatus { locExists = Just e+                               , otherLocs = o+                               , locNotes = nts+                               , lastUpd = u+                               }+  RemoteSpec _ -> return LocationStatus { locExists = Nothing+                                        , otherLocs = mempty+                                        , locNotes = mempty+                                        , lastUpd = Nothing+                                        }++-- | Searches for other locations based on the current location.  This will find+-- locations like remote git repos, darcs repos, etc.+--+-- These locations are added permanently to the project.+getOtherLocs :: MonadIO m => Path Abs Dir -> m [ (LType, LocationSpec) ]+getOtherLocs lcl = concat <$> sequence [ getGitLocs lcl+                                       , getDarcsLocs lcl+                                       ]+++getGitLocs :: MonadIO m => Path Abs Dir -> m [ (LType, LocationSpec) ]+getGitLocs lcl =+  let gitCfgFile = lcl </> [relfile|.git/config|]+      gcRemote sname cfg locs =+        case T.words sname of+          ["remote", rmt] ->+            let t = GitRepo $ GitRemote+                    -- drop surrounding double-quotes+                    $ T.drop 1 $ T.take (T.length rmt - 1) rmt+            in locs <> catMaybes+               [ (t,) . toLocSpec <$> HM.lookup "url" cfg+               , (GitFork t,) . toLocSpec <$> HM.lookup "pushurl" cfg+               ]+          _ -> locs+      toLocSpec t = maybe (RemoteSpec t) LocalSpec $ parseAbsDir $ T.unpack t+      gcProc = HM.foldrWithKey gcRemote mempty . unIni+  in do ge <- liftIO (doesFileExist gitCfgFile)+        if ge+          then do gt <- liftIO $ TIO.readFile (toFilePath gitCfgFile)+                  case parseIni gt of+                    Left _e -> return mempty -- no error reporting+                    Right gc -> return $ gcProc gc+          else return mempty+++getDarcsLocs :: MonadIO m => Path Abs Dir -> m [ (LType, LocationSpec) ]+getDarcsLocs lcl =+  let darcsRepos = lcl </> [relfile|_darcs/prefs/repos|]+      mkDarcs t = ( DarcsRepo+                  , maybe (RemoteSpec t) LocalSpec $ parseAbsDir $ T.unpack t+                  )+      lclExists (_,r) = case r of+        RemoteSpec _ -> return True+        LocalSpec d -> doesDirExist d+  in do de <- liftIO (doesFileExist darcsRepos)+        if de+          then do rst <- liftIO $ TIO.readFile $ toFilePath darcsRepos+                  let rsc = mkDarcs <$> T.lines rst+                  filterM lclExists rsc+          else return mempty+++getLocNotes :: MonadIO m => Path Abs Dir -> m [ Note ]+getLocNotes lcl =+  let notesDir = lcl </> [reldir|@MyWork|]+      mkFileNote nl f =+        case fileExtension f of+          Just ".txt" ->+            do nt <- liftIO $ TIO.readFile (toFilePath f)+               nd <- utctDay <$> liftIO ( getModificationTime f)+               return $ Note { note = nt+                             , notedOn = nd+                             , noteCore =+                                 NoteRT+                                 { noteSource = ProjLoc+                                 }+                             } : nl+          _ -> return nl+  in do ne <- liftIO (doesDirExist notesDir)+        if ne+          then do (_,files) <- liftIO (listDir notesDir)+                  foldM mkFileNote mempty files+          else return mempty+++applyLocSync :: Day -> LocationStatus -> Location -> Location+applyLocSync now locsts loc =+  let rmtnoteTxt :: (LType, LocationSpec) -> Text+      rmtnoteTxt = \case+        (GitRepo (GitRemote n), r) ->+          "Cloned from git repo " <> tshow n <> " @ " <> tshow r+        (GitFork (GitRepo (GitRemote n)), r) ->+          "Pushing to git repo " <> tshow n <> " fork @ " <>  tshow r+        (DarcsRepo, r) -> "Synced with darcs repo @ " <> tshow r+        (_, r) -> "Related to " <> tshow r+      addRmtNoteText ol cl =+        -- n.b. instead of using updateNote, which prefers the new note, this+        -- only adds a note if there isn't already one, preferring the existing+        -- one in case it has been updated (aside from the noteTitle).+        let rnt = rmtnoteTxt ol+            rn = Note { note = rnt, notedOn = now+                      , noteCore = NoteRT { noteSource = MyWorkGenerated }+                      }+        in case DL.find ((noteTitle' rnt ==) . noteTitle) (cl ^. notesL) of+             Nothing -> cl & notesL <>~ [rn]+             Just _ -> cl+      loc1 = foldr addRmtNoteText loc $ otherLocs locsts+      loc2 = foldr (updateLocNote Nothing) loc1 $ locNotes locsts+  in loc2 & locValidL .~ maybe True id (locExists locsts)+          & locatedOnL .~ (lastUpd locsts <|> loc ^. locatedOnL)++applyProjLocSync :: MonadIO m+                 => Maybe LocationSpec -> Project -> Location+                 -> StateT [LocationSpec] m Project+applyProjLocSync = go+  where+    go :: MonadIO m => Maybe LocationSpec -> Project -> Location -> StateT [LocationSpec] m Project+    go mbOldL p l =+      -- Check if this location was already processed+      gets (l ^. locationL `elem`) >>= \case+      True -> return p+      False ->+        do modify (l ^. locationL :)+           -- This location was not previously processed, so process it now+           locsts <- syncLocation l+           now <- utctDay <$> liftIO getCurrentTime++           -- Remove any previous dynamic notes+           let l' = l { notes = filter ((MyWorkDB ==) . view noteSourceL) $ notes l }++           let p' = updateLocation mbOldL (applyLocSync now locsts l') p+           let rmtspec rmtName =+                 DL.lookup (GitRepo (GitRemote rmtName)) $ otherLocs locsts+           let mkLoc (lt,ls) =+                 let nts = case lt of+                             GitRepo (GitRemote _) -> mempty+                             GitFork (GitRepo (GitRemote n)) ->+                               [ Note { note = "Fork of git repo @ " <>+                                               case rmtspec n of+                                                 Just rls -> tshow rls+                                                 Nothing -> "??"+                                      , notedOn = now+                                      , noteCore =+                                          NoteRT+                                          { noteSource = MyWorkGenerated+                                          }+                                      }+                               ]+                             DarcsRepo -> mempty+                             _ -> [ Note { note = "Related to " <> tshow ls+                                         , notedOn = now+                                         , noteCore =+                                             NoteRT+                                             { noteSource = MyWorkGenerated+                                             }+                                         }+                                  ]+                 in Location { location = ls+                             , locatedOn = Nothing+                             , notes = nts+                             , locCore = LocRT+                                         { locValid = True+                                         }+                             }+           foldM (go Nothing) p' (mkLoc <$> otherLocs locsts)+++-- | Called to synchronize (load) a Project's dynamic information by searching+-- local locations for that dynamic information.  If the first argument is true,+-- this is a re-synchronization, so any existing dynamic information is discarded+-- first.+syncProject :: MonadIO m => Project -> m Project+syncProject p = evalStateT (foldM (applyProjLocSync Nothing) p $ p ^. locationsL) mempty
+ lib/Whole.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DataKinds #-}++module Whole+  (+    MyWorkState+  , initialState+  , myWorkFocusL+  )+where++import Brick.Focus ( FocusRing )+import Brick.Panes+import Control.Lens ( Lens' )++import Defs+import Panes.AddProj+import Panes.Confirmation ()+import Panes.FileMgr+import Panes.Help+import Panes.Location ()+import Panes.LocationInput+import Panes.Messages+import Panes.NoteInput+import Panes.Notes ()+import Panes.Operations+import Panes.ProjInfo+import Panes.Projects ()+import Panes.Summary+++type MyWorkState = Panel WName MyWorkEvent MyWorkCore+                   '[ SummaryPane+                    , NoteInputPane+                    , LocationInputPane+                    , AddProjPane+                    , OperationsPane+                    , ProjInfoPane+                    , Note+                    , Location+                    , Projects+                    , FileMgrPane+                    , Confirm+                    , HelpPane+                    , MessagesPane+                    ]+++myWorkFocusL :: Lens' MyWorkState (FocusRing WName)+myWorkFocusL = onBaseState . coreWorkFocusL+++initialState :: IO MyWorkState+initialState = focusRingUpdate myWorkFocusL+               . addToPanel Never+               . addToPanel WhenFocusedModalHandlingAllEvents+               . addToPanel WhenFocusedModalHandlingAllEvents+               . addToPanel WhenFocusedModalHandlingAllEvents+               . addToPanel Never+               . addToPanel Never+               . addToPanel WhenFocused+               . addToPanel WhenFocused+               . addToPanel WhenFocused+               . addToPanel WhenFocusedModal+               . addToPanel WhenFocusedModalHandlingAllEvents+               . addToPanel WhenFocusedModal+               . addToPanel Never+               . basePanel+               <$> initMyWorkCore
mywork.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               mywork-version:            1.0.0.0+version:            1.0.1.0 synopsis:     Tool to keep track of what you have been working on and where. @@ -33,15 +33,18 @@                   -Wsimplifiable-class-constraints                   -Wpartial-fields                   -fhide-source-paths-                  -threaded -executable mywork+library     import:           settings-    main-is:          Main.hs+    hs-source-dirs:   lib     autogen-modules:  Paths_mywork     other-modules:    Paths_mywork-                      Defs+    exposed-modules:  Defs                       Defs.JSON+                      Defs.Lenses+                      Defs.Static+                      Draw+                      Events                       Panes.AddProj                       Panes.Common.Attrs                       Panes.Common.Inputs@@ -59,7 +62,7 @@                       Panes.Notes                       Panes.Summary                       Sync-    hs-source-dirs:   app+                      Whole     default-language: Haskell2010     build-depends:    base >= 4.13 && < 4.18                     , brick >= 1.0 && < 1.4@@ -79,3 +82,18 @@                     , unordered-containers >= 0.2 && < 0.3                     , vector >= 0.13 && < 0.14                     , vty >= 5.35 && < 5.38++executable mywork+    import:           settings+    ghc-options:      -threaded+    main-is:          Main.hs+    default-language: Haskell2010+    hs-source-dirs:   app+    build-depends:    base+                    , brick+                    , brick-panes+                    , lens+                    , mtl+                    , mywork+                    , text+                    , vty