{-|

Module      : Abacus.App.Events
Description : Application event handling
Copyright   : (C) Jonathan Lamothe
License     : AGPL-3.0-or-later
Maintainer  : jonathan@jlamothe.net
Stability   : experimental
Portability : POSIX

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public
License along with this program.  If not, see
<https://www.gnu.org/licenses/>.

-}

{-# LANGUAGE OverloadedStrings #-}

module Abacus.App.Events (appKeyDispatcher) where

import Brick (EventM, halt)
import Brick.Keybindings
  ( Binding
  , KeyConfig
  , KeyDispatcher
  , KeyEventHandler
  , bind
  , ctrl
  , keyDispatcher
  , keyEvents
  , newKeyConfig
  , onEvent
  , shift
  )
import Control.Monad.State.Class (modify)
import Data.Char (chr, ord)
import Data.Either (fromRight)
import Graphics.Vty.Input.Events
  (Key (KUp, KDown, KLeft, KRight, KHome, KEnd))

import Abacus.App.Actions
import Abacus.App.Types

-- | Application keyboard configuration
appKeyDispatcher :: KeyDispatcher KeyEventID (EventM () AppState)
appKeyDispatcher = fromRight (error "can't build key dispatcher") $
  keyDispatcher keyConfig eventBindings

-- | The key configuration
keyConfig :: KeyConfig KeyEventID
keyConfig = newKeyConfig (keyEvents []) keyBindings []

-- | Binds a "KeyEventID" to its associated action
eventBindings :: [KeyEventHandler KeyEventID (EventM () AppState)]
eventBindings =
  [ onEvent QuitE "Quits the program" halt
  , onEvent MoveUpE "Moves the cursor up" $
    modify moveUp
  , onEvent MoveDownE "Moves the cursor down" $
    modify moveDown
  , onEvent BeadLeftE "Moves a bead to the left" $
    modify beadLeft
  , onEvent BeadRightE "Moves a bead to the right" $
    modify beadRight
  , onEvent RungLeftE "Moves all beads to the left of the rung" $
    modify rungLeft
  , onEvent RungRightE "Moves all beads to the right of the rung" $
    modify rungRight
  ] ++ map
    ( \n -> onEvent (SelRungE n) "Moves to a numbered rung" $
      modify $ selRung n
    )
    [0..9]

-- | Key bindings
keyBindings :: [(KeyEventID, [Binding])]
keyBindings =
  [ ( QuitE
    , [ ctrl 'c'
      , bind 'q'
      ]
    )
  , ( MoveUpE
    , [ bind KUp
      , bind 'k'
      ]
    )
  , ( MoveDownE
    , [ bind KDown
      , bind 'j'
      ]
    )
  , ( BeadLeftE
    , [ bind KLeft
      , bind 'h'
      ]
    )
  , ( BeadRightE
    , [ bind KRight
      , bind 'l'
      ]
    )
  , ( RungLeftE
    , [ shift KLeft
      , bind KHome
      , bind 'H'
      ]
    )
  , ( RungRightE
    , [ shift KRight
      , bind KEnd
      , bind 'L'
      ]
    )
  ] ++ map
    ( \n ->
      ( SelRungE n
      , [bind $ chr $ ord '0' + n]
      )
    )
    [0..9]

--jl