bunyan/src/Bunyan/App.hs

{-# LANGUAGE OverloadedStrings #-}

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 Bunyan.Log as Log


data Modal
  = AddSectionModal ()
  | ConfirmQuitModal
  deriving (Eq, Show)

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
  { stateCommits  :: EntryZipper
  , stateKeys     :: M.Map Char T.Text
  , stateModal    :: Maybe Modal
  , stateStatus   :: T.Text
  } deriving (Eq, Show)


defaultSections :: [(Char, T.Text)]
defaultSections =
  [ ('f', "New features")
  , ('b', "Bug fixes")
  , ('p', "Package changes")
  , ('d', "Documentation changes")
  , ('i', "Performance improvements")
  ]

newState :: S.Seq Log.Entry -> State
newState commits = State
  { 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)))
runApp entries = do
  let state = newState entries
      vty = Vty.mkVty Vty.defaultConfig
  final <- Brick.customMain vty Nothing app state
  return (mkSections (stateCommits final))


app :: Brick.App State () ()
app = Brick.App
  { Brick.appDraw         = draw
  , Brick.appChooseCursor = Brick.showFirstCursor
  , Brick.appHandleEvent  = event
  , Brick.appStartEvent   = return
  , Brick.appAttrMap      = \ _ -> Brick.forceAttrMap mempty
  }


draw :: State -> [Brick.Widget ()]
draw st
  | Just ConfirmQuitModal <- stateModal st =
      [ Brick.txt "Are you sure you want to quit? (y/n)" ]
  | otherwise =
      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 md)) =
  case stateModal st of
    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 commits = stateCommits st
      current = getCurrentCommit commits
  Brick.continue st
    { stateCommits = zipperNext (skipCurrent commits)
    , stateStatus = ("skipped " <> current)
    }

mainEvent st (Vty.KChar 'q') [] =
  Brick.continue st { stateModal = Just ConfirmQuitModal }

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 commits = stateCommits st
          current = getCurrentCommit commits
      Brick.continue st
        { stateCommits = zipperNext (annotCurrent annot commits)
        , stateStatus = "Added " <> current <> " to " <> annot
        }
  | otherwise =
    Brick.continue st { stateStatus = "Unknown keybindings: " <> T.pack (show c) }

mainEvent st _ _ = Brick.continue st


confirmQuitEvent :: EventHandler
confirmQuitEvent st (Vty.KChar 'y') _ = Brick.halt st
confirmQuitEvent st _ _  = Brick.continue st { stateModal = Nothing }


addSectionEvent :: EventHandler
addSectionEvent st _ _ = Brick.continue st { stateModal = Nothing }