More temporary drawing code, internal zipper repr

bunyan.cabal

@@ -24,6 +24,7 @@ library
                      , text
                      , vty
   default-language:    Haskell2010
+  ghc-options:         -Wall
   default-extensions:  ScopedTypeVariables
 
 executable bunyan

src/Bunyan.hs

@@ -1,13 +1,11 @@
 module Bunyan where
 
-import           Data.Monoid ((<>))
-import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified System.Process as Sys
 
-import           Bunyan.Log
-import           Bunyan.App
-import           Bunyan.Pretty
+import qualified Bunyan.Log as Log
+import qualified Bunyan.App as App
+import qualified Bunyan.Pretty as Pretty
 
 data Config = Config
   { cfgEditorCommand :: String
@@ -20,8 +18,8 @@ main cfg = do
   let pr = (Sys.proc "git" ["log"]) { Sys.cwd = Just (cfgGitRepo cfg)
                                     , Sys.std_out = Sys.CreatePipe
                                     }
-  rs <- Sys.withCreateProcess pr $ \ _ (Just stdin) _ ph -> do
+  rs <- Sys.withCreateProcess pr $ \ _ (Just stdin) _ _ -> do
     T.hGetContents stdin
-  let entries = parseLogEntry rs
-  cats <- runApp entries
-  T.putStrLn (pretty cats)
+  let entries = Log.parseLogEntry rs
+  cats <- App.runApp entries
+  T.putStrLn (Pretty.pretty cats)

src/Bunyan/App.hs

@@ -3,12 +3,12 @@
 module Bunyan.App (runApp) where
 
 import qualified Brick
+import qualified Data.Foldable as F
 import qualified Data.Map as M
 import           Data.Monoid ((<>))
 import qualified Data.Sequence as S
 import qualified Data.Text as T
 import qualified Graphics.Vty as Vty
-import qualified Graphics.Vty.Input.Events as Vty
 
 import qualified Bunyan.Log as Log
 
@@ -18,15 +18,63 @@ data Modal
   | ConfirmQuitModal
   deriving (Eq, Show)
 
-data Annot
-  = Annot T.Text Log.Entry
-  | Skip Log.Entry
+data AnnotEntry = AnnotEntry
+  { aeAnnot :: Maybe Annotation
+  , aeEntry :: Log.Entry
+  } deriving (Eq, Show)
+
+data Annotation
+  = Annotation T.Text
+  | Skip
   deriving (Eq, Show)
 
+data EntryZipper = EntryZipper
+  { ezBefore  :: S.Seq AnnotEntry
+  , ezAfter   :: S.Seq AnnotEntry
+  , ezCurrent :: AnnotEntry
+  } deriving (Eq, Show)
+
+toZipper :: S.Seq Log.Entry -> EntryZipper
+toZipper sq
+  | car S.:< cdr <- S.viewl sq = EntryZipper
+    { ezBefore  = S.empty
+    , ezCurrent = AnnotEntry Nothing car
+    , ezAfter   = fmap (AnnotEntry Nothing) cdr
+    }
+  | otherwise = error "empty history"
+
+getCurrentCommit :: EntryZipper -> T.Text
+getCurrentCommit
+  = Log.logCommit . aeEntry . ezCurrent
+
+zipperPrev :: EntryZipper -> EntryZipper
+zipperPrev ez = case S.viewr (ezBefore ez) of
+  S.EmptyR -> ez
+  cdr S.:> car -> ez
+    { ezBefore  = cdr
+    , ezAfter   = ezCurrent ez S.<| ezAfter ez
+    , ezCurrent = car
+    }
+
+zipperNext :: EntryZipper -> EntryZipper
+zipperNext ez = case S.viewl (ezAfter ez) of
+  S.EmptyL -> ez
+  car S.:< cdr -> ez
+    { ezBefore  = ezBefore ez S.|> ezCurrent ez
+    , ezAfter   = cdr
+    , ezCurrent = car
+    }
+
+annotCurrent :: T.Text -> EntryZipper -> EntryZipper
+annotCurrent annot ez = ez
+  { ezCurrent = (ezCurrent ez) { aeAnnot = Just (Annotation annot) } }
+
+skipCurrent :: EntryZipper -> EntryZipper
+skipCurrent ez = ez
+  { ezCurrent = (ezCurrent ez) { aeAnnot = Just Skip } }
+
 data State = State
-  { stateSections :: M.Map T.Text (S.Seq (S.Seq T.Text))
-  , stateCommits  :: S.Seq Log.Entry
-  , stateFinished :: S.Seq Annot
+  { stateCommits  :: EntryZipper
   , stateKeys     :: M.Map Char T.Text
   , stateModal    :: Maybe Modal
   , stateStatus   :: T.Text
@@ -44,15 +92,25 @@ defaultSections =
 
 newState :: S.Seq Log.Entry -> State
 newState commits = State
-  { stateSections = M.fromList
-    [ (name, mempty) | (_, name) <- defaultSections ]
-  , stateKeys = M.fromList defaultSections
-  , stateCommits = commits
-  , stateFinished = S.empty
+  { stateKeys = M.fromList defaultSections
+  , stateCommits = toZipper commits
   , stateModal = Nothing
   , stateStatus = ""
   }
 
+zipperToSeq :: EntryZipper -> S.Seq AnnotEntry
+zipperToSeq ez =
+  ezBefore ez <> S.singleton (ezCurrent ez) <> ezAfter ez
+
+mkSections :: EntryZipper -> M.Map T.Text (S.Seq (S.Seq T.Text))
+mkSections ez =
+  let sq = zipperToSeq ez
+  in M.unionsWith (<>) [ M.singleton annot (S.singleton (Log.logMessage entry))
+                       | AnnotEntry { aeAnnot = mbAnnot
+                                    , aeEntry = entry
+                                    } <- F.toList sq
+                       , Just (Annotation annot) <- [mbAnnot]
+                       ]
 
 
 runApp :: S.Seq Log.Entry -> IO (M.Map T.Text (S.Seq (S.Seq T.Text)))
@@ -60,7 +118,7 @@ runApp entries = do
   let state = newState entries
       vty = Vty.mkVty Vty.defaultConfig
   final <- Brick.customMain vty Nothing app state
-  return (stateSections final)
+  return (mkSections (stateCommits final))
 
 
 app :: Brick.App State () ()
@@ -78,32 +136,52 @@ draw st
   | Just ConfirmQuitModal <- stateModal st =
       [ Brick.txt "Are you sure you want to quit? (y/n)" ]
   | otherwise =
-      [ Brick.vBox
-        [ Brick.str (show (stateModal st))
-        , Brick.txt (stateStatus st)
-        ]
+      let cmts = stateCommits st
+      in [ Brick.viewport () Brick.Vertical $ Brick.vBox $
+           (map (renderEntry False) (F.toList (ezBefore cmts)) ++
+            [ renderEntry True (ezCurrent cmts) ] ++
+            map (renderEntry False) (F.toList (ezAfter cmts)))
       ]
+  where renderEntry isFocus AnnotEntry
+          { aeAnnot = annot
+          , aeEntry = Log.Entry
+                        { Log.logMessage = msg
+                        , Log.logCommit  = cmt
+                        }
+          } = (if isFocus then Brick.visible else id) $ Brick.hBox
+                [ if isFocus
+                    then Brick.txt "> "
+                    else Brick.txt "  "
+                , case annot of
+                    Nothing -> Brick.txt "[]"
+                    Just Skip -> Brick.txt "skip"
+                    Just (Annotation a) -> Brick.txt a
+                , Brick.txt " | "
+                , Brick.txt cmt
+                , Brick.txt ": "
+                , Brick.vBox (map Brick.txt (F.toList msg))
+                ]
 
 
 type EventHandler =
   State -> Vty.Key -> [Vty.Modifier] -> Brick.EventM () (Brick.Next State)
 
 event :: State -> Brick.BrickEvent () () -> Brick.EventM () (Brick.Next State)
-event st (Brick.VtyEvent (Vty.EvKey key mod)) =
+event st (Brick.VtyEvent (Vty.EvKey key md)) =
   case stateModal st of
-    Nothing -> mainEvent st key mod
-    Just ConfirmQuitModal -> confirmQuitEvent st key mod
-    Just (AddSectionModal ()) -> addSectionEvent st key mod
+    Nothing -> mainEvent st key md
+    Just ConfirmQuitModal -> confirmQuitEvent st key md
+    Just (AddSectionModal ()) -> addSectionEvent st key md
 event st _ = Brick.continue st
 
 
 mainEvent :: EventHandler
 mainEvent st (Vty.KChar ' ') [] = do
-  let car S.:< cdr = S.viewl (stateCommits st)
+  let commits = stateCommits st
+      current = getCurrentCommit commits
   Brick.continue st
-    { stateFinished = Skip car S.<| stateFinished st
-    , stateCommits = cdr
-    , stateStatus = "skipped"
+    { stateCommits = zipperNext (skipCurrent commits)
+    , stateStatus = ("skipped " <> current)
     }
 
 mainEvent st (Vty.KChar 'q') [] =
@@ -112,16 +190,19 @@ mainEvent st (Vty.KChar 'q') [] =
 mainEvent st (Vty.KChar 'a') [] =
   Brick.continue st { stateModal = Just (AddSectionModal ()) }
 
+mainEvent st (Vty.KChar 'j') [] =
+  Brick.continue st { stateCommits = zipperNext (stateCommits st) }
+
+mainEvent st (Vty.KChar 'k') [] =
+  Brick.continue st { stateCommits = zipperPrev (stateCommits st) }
+
 mainEvent st (Vty.KChar c) []
   | Just annot <- M.lookup c (stateKeys st) = do
-      let car S.:< cdr = S.viewl (stateCommits st)
+      let commits = stateCommits st
+          current = getCurrentCommit commits
       Brick.continue st
-        { stateFinished = Annot annot car S.<| stateFinished st
-        , stateCommits  = cdr
-        , stateSections =
-          M.adjust ((Log.logMessage car) S.<|) annot (stateSections st)
-        , stateStatus =
-          "Added " <> Log.logCommit car <> " to section " <> annot
+        { stateCommits = zipperNext (annotCurrent annot commits)
+        , stateStatus = "Added " <> current <> " to " <> annot
         }
   | otherwise =
     Brick.continue st { stateStatus = "Unknown keybindings: " <> T.pack (show c) }