gdritter repos bunyan / master
More temporary drawing code, internal zipper repr Getty Ritter 6 years ago
3 changed file(s) with 121 addition(s) and 41 deletion(s). Collapse all Expand all
+1
-0
bunyan.cabal less more
2424 , text
2525 , vty
2626 default-language: Haskell2010
27 ghc-options: -Wall
2728 default-extensions: ScopedTypeVariables
2829
2930 executable bunyan
+113
-32
src/Bunyan/App.hs less more
33 module Bunyan.App (runApp) where
44
55 import qualified Brick
6 import qualified Data.Foldable as F
67 import qualified Data.Map as M
78 import Data.Monoid ((<>))
89 import qualified Data.Sequence as S
910 import qualified Data.Text as T
1011 import qualified Graphics.Vty as Vty
11 import qualified Graphics.Vty.Input.Events as Vty
1212
1313 import qualified Bunyan.Log as Log
1414
1818 | ConfirmQuitModal
1919 deriving (Eq, Show)
2020
21 data Annot
22 = Annot T.Text Log.Entry
23 | Skip Log.Entry
21 data AnnotEntry = AnnotEntry
22 { aeAnnot :: Maybe Annotation
23 , aeEntry :: Log.Entry
24 } deriving (Eq, Show)
25
26 data Annotation
27 = Annotation T.Text
28 | Skip
2429 deriving (Eq, Show)
2530
31 data EntryZipper = EntryZipper
32 { ezBefore :: S.Seq AnnotEntry
33 , ezAfter :: S.Seq AnnotEntry
34 , ezCurrent :: AnnotEntry
35 } deriving (Eq, Show)
36
37 toZipper :: S.Seq Log.Entry -> EntryZipper
38 toZipper sq
39 | car S.:< cdr <- S.viewl sq = EntryZipper
40 { ezBefore = S.empty
41 , ezCurrent = AnnotEntry Nothing car
42 , ezAfter = fmap (AnnotEntry Nothing) cdr
43 }
44 | otherwise = error "empty history"
45
46 getCurrentCommit :: EntryZipper -> T.Text
47 getCurrentCommit
48 = Log.logCommit . aeEntry . ezCurrent
49
50 zipperPrev :: EntryZipper -> EntryZipper
51 zipperPrev ez = case S.viewr (ezBefore ez) of
52 S.EmptyR -> ez
53 cdr S.:> car -> ez
54 { ezBefore = cdr
55 , ezAfter = ezCurrent ez S.<| ezAfter ez
56 , ezCurrent = car
57 }
58
59 zipperNext :: EntryZipper -> EntryZipper
60 zipperNext ez = case S.viewl (ezAfter ez) of
61 S.EmptyL -> ez
62 car S.:< cdr -> ez
63 { ezBefore = ezBefore ez S.|> ezCurrent ez
64 , ezAfter = cdr
65 , ezCurrent = car
66 }
67
68 annotCurrent :: T.Text -> EntryZipper -> EntryZipper
69 annotCurrent annot ez = ez
70 { ezCurrent = (ezCurrent ez) { aeAnnot = Just (Annotation annot) } }
71
72 skipCurrent :: EntryZipper -> EntryZipper
73 skipCurrent ez = ez
74 { ezCurrent = (ezCurrent ez) { aeAnnot = Just Skip } }
75
2676 data State = State
27 { stateSections :: M.Map T.Text (S.Seq (S.Seq T.Text))
28 , stateCommits :: S.Seq Log.Entry
29 , stateFinished :: S.Seq Annot
77 { stateCommits :: EntryZipper
3078 , stateKeys :: M.Map Char T.Text
3179 , stateModal :: Maybe Modal
3280 , stateStatus :: T.Text
4492
4593 newState :: S.Seq Log.Entry -> State
4694 newState commits = State
47 { stateSections = M.fromList
48 [ (name, mempty) | (_, name) <- defaultSections ]
49 , stateKeys = M.fromList defaultSections
50 , stateCommits = commits
51 , stateFinished = S.empty
95 { stateKeys = M.fromList defaultSections
96 , stateCommits = toZipper commits
5297 , stateModal = Nothing
5398 , stateStatus = ""
5499 }
55100
101 zipperToSeq :: EntryZipper -> S.Seq AnnotEntry
102 zipperToSeq ez =
103 ezBefore ez <> S.singleton (ezCurrent ez) <> ezAfter ez
104
105 mkSections :: EntryZipper -> M.Map T.Text (S.Seq (S.Seq T.Text))
106 mkSections ez =
107 let sq = zipperToSeq ez
108 in M.unionsWith (<>) [ M.singleton annot (S.singleton (Log.logMessage entry))
109 | AnnotEntry { aeAnnot = mbAnnot
110 , aeEntry = entry
111 } <- F.toList sq
112 , Just (Annotation annot) <- [mbAnnot]
113 ]
56114
57115
58116 runApp :: S.Seq Log.Entry -> IO (M.Map T.Text (S.Seq (S.Seq T.Text)))
60118 let state = newState entries
61119 vty = Vty.mkVty Vty.defaultConfig
62120 final <- Brick.customMain vty Nothing app state
63 return (stateSections final)
121 return (mkSections (stateCommits final))
64122
65123
66124 app :: Brick.App State () ()
78136 | Just ConfirmQuitModal <- stateModal st =
79137 [ Brick.txt "Are you sure you want to quit? (y/n)" ]
80138 | otherwise =
81 [ Brick.vBox
82 [ Brick.str (show (stateModal st))
83 , Brick.txt (stateStatus st)
84 ]
139 let cmts = stateCommits st
140 in [ Brick.viewport () Brick.Vertical $ Brick.vBox $
141 (map (renderEntry False) (F.toList (ezBefore cmts)) ++
142 [ renderEntry True (ezCurrent cmts) ] ++
143 map (renderEntry False) (F.toList (ezAfter cmts)))
85144 ]
145 where renderEntry isFocus AnnotEntry
146 { aeAnnot = annot
147 , aeEntry = Log.Entry
148 { Log.logMessage = msg
149 , Log.logCommit = cmt
150 }
151 } = (if isFocus then Brick.visible else id) $ Brick.hBox
152 [ if isFocus
153 then Brick.txt "> "
154 else Brick.txt " "
155 , case annot of
156 Nothing -> Brick.txt "[]"
157 Just Skip -> Brick.txt "skip"
158 Just (Annotation a) -> Brick.txt a
159 , Brick.txt " | "
160 , Brick.txt cmt
161 , Brick.txt ": "
162 , Brick.vBox (map Brick.txt (F.toList msg))
163 ]
86164
87165
88166 type EventHandler =
89167 State -> Vty.Key -> [Vty.Modifier] -> Brick.EventM () (Brick.Next State)
90168
91169 event :: State -> Brick.BrickEvent () () -> Brick.EventM () (Brick.Next State)
92 event st (Brick.VtyEvent (Vty.EvKey key mod)) =
170 event st (Brick.VtyEvent (Vty.EvKey key md)) =
93171 case stateModal st of
94 Nothing -> mainEvent st key mod
95 Just ConfirmQuitModal -> confirmQuitEvent st key mod
96 Just (AddSectionModal ()) -> addSectionEvent st key mod
172 Nothing -> mainEvent st key md
173 Just ConfirmQuitModal -> confirmQuitEvent st key md
174 Just (AddSectionModal ()) -> addSectionEvent st key md
97175 event st _ = Brick.continue st
98176
99177
100178 mainEvent :: EventHandler
101179 mainEvent st (Vty.KChar ' ') [] = do
102 let car S.:< cdr = S.viewl (stateCommits st)
180 let commits = stateCommits st
181 current = getCurrentCommit commits
103182 Brick.continue st
104 { stateFinished = Skip car S.<| stateFinished st
105 , stateCommits = cdr
106 , stateStatus = "skipped"
183 { stateCommits = zipperNext (skipCurrent commits)
184 , stateStatus = ("skipped " <> current)
107185 }
108186
109187 mainEvent st (Vty.KChar 'q') [] =
112190 mainEvent st (Vty.KChar 'a') [] =
113191 Brick.continue st { stateModal = Just (AddSectionModal ()) }
114192
193 mainEvent st (Vty.KChar 'j') [] =
194 Brick.continue st { stateCommits = zipperNext (stateCommits st) }
195
196 mainEvent st (Vty.KChar 'k') [] =
197 Brick.continue st { stateCommits = zipperPrev (stateCommits st) }
198
115199 mainEvent st (Vty.KChar c) []
116200 | Just annot <- M.lookup c (stateKeys st) = do
117 let car S.:< cdr = S.viewl (stateCommits st)
201 let commits = stateCommits st
202 current = getCurrentCommit commits
118203 Brick.continue st
119 { stateFinished = Annot annot car S.<| stateFinished st
120 , stateCommits = cdr
121 , stateSections =
122 M.adjust ((Log.logMessage car) S.<|) annot (stateSections st)
123 , stateStatus =
124 "Added " <> Log.logCommit car <> " to section " <> annot
204 { stateCommits = zipperNext (annotCurrent annot commits)
205 , stateStatus = "Added " <> current <> " to " <> annot
125206 }
126207 | otherwise =
127208 Brick.continue st { stateStatus = "Unknown keybindings: " <> T.pack (show c) }
+7
-9
src/Bunyan.hs less more
11 module Bunyan where
22
3 import Data.Monoid ((<>))
4 import qualified Data.Text as T
53 import qualified Data.Text.IO as T
64 import qualified System.Process as Sys
75
8 import Bunyan.Log
9 import Bunyan.App
10 import Bunyan.Pretty
6 import qualified Bunyan.Log as Log
7 import qualified Bunyan.App as App
8 import qualified Bunyan.Pretty as Pretty
119
1210 data Config = Config
1311 { cfgEditorCommand :: String
2018 let pr = (Sys.proc "git" ["log"]) { Sys.cwd = Just (cfgGitRepo cfg)
2119 , Sys.std_out = Sys.CreatePipe
2220 }
23 rs <- Sys.withCreateProcess pr $ \ _ (Just stdin) _ ph -> do
21 rs <- Sys.withCreateProcess pr $ \ _ (Just stdin) _ _ -> do
2422 T.hGetContents stdin
25 let entries = parseLogEntry rs
26 cats <- runApp entries
27 T.putStrLn (pretty cats)
23 let entries = Log.parseLogEntry rs
24 cats <- App.runApp entries
25 T.putStrLn (Pretty.pretty cats)