content: {-# LANGUAGE OverloadedStrings #-}
  
  -- | Load and show Swarm keybindings.
  --
  -- SPDX-License-Identifier: BSD-3-Clause
  module Swarm.TUI.Model.KeyBindings (
    initKeyHandlingState,
    KeybindingPrint (..),
    showKeybindings,
    handlerNameKeysDescription,
  ) where
  
  import Brick
  import Brick.Keybindings as BK
  import Control.Carrier.Lift (runM)
  import Control.Carrier.Throw.Either (runThrow)
  import Control.Effect.Accum
  import Control.Effect.Lift
  import Control.Effect.Throw
  import Control.Lens hiding (from, (<.>))
  import Data.Bifunctor (second)
  import Data.Maybe (fromMaybe, mapMaybe)
  import Data.Text (Text)
  import Data.Text qualified as T
  import Swarm.Failure (Asset (..), LoadingFailure (..), SystemFailure (..))
  import Swarm.Pretty (prettyText)
  import Swarm.ResourceLoading (getSwarmConfigIniFile)
  import Swarm.TUI.Controller.EventHandlers
  import Swarm.TUI.Model
  import Swarm.TUI.Model.Event (SwarmEvent, defaultSwarmBindings, swarmEvents)
  
  -- See Note [how Swarm event handlers work]
  
  loadKeybindingConfig ::
    (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
    m [(SwarmEvent, BindingState)]
  loadKeybindingConfig = do
    (iniExists, ini) <- sendIO $ getSwarmConfigIniFile False
    if not iniExists
      then return []
      else do
        loadedCustomBindings <- sendIO $ keybindingsFromFile swarmEvents "keybindings" ini
        case loadedCustomBindings of
          Left e -> throwError $ AssetNotLoaded Keybindings ini (SystemFailure . CustomFailure $ T.pack e)
          Right bs -> pure $ fromMaybe [] bs
  
  initKeyHandlingState ::
    (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
    m KeyEventHandlingState
  initKeyHandlingState = do
    customBindings <- loadKeybindingConfig
    let cfg = newKeyConfig swarmEvents defaultSwarmBindings customBindings
    dispatchers <- createKeyDispatchers cfg
    return $ KeyEventHandlingState cfg dispatchers
  
  data KeybindingPrint = MarkdownPrint | TextPrint | IniPrint
    deriving (Eq, Ord, Show)
  
  showKeybindings :: KeybindingPrint -> IO Text
  showKeybindings kPrint = do
    bindings <- runM $ runThrow @SystemFailure initKeyHandlingState
    pure $ case bindings of
      Left e -> prettyText e
      Right bs -> showTable kPrint (bs ^. keyConfig) keySections
   where
    showTable = \case
      MarkdownPrint -> keybindingMarkdownTable
      TextPrint -> keybindingTextTable
      IniPrint -> keybindingINI
  
  keySections :: [(Text, [KeyEventHandler SwarmEvent (EventM Name AppState)])]
  keySections =
    [ ("Main game (always active)", mainEventHandlers)
    , ("REPL panel", replEventHandlers)
    , ("World view panel", worldEventHandlers)
    , ("Robot inventory panel", robotEventHandlers)
    ]
  
  keybindingINI :: Ord k => KeyConfig k -> [(Text, [KeyEventHandler k m])] -> Text
  keybindingINI kc sections =
    T.intercalate "\n" $
      "[keybindings]\n"
        : "; Uncomment the assignment and set comma separated list"
        : "; of keybindings or \"unbound\" on the right. See:"
        : "; https://hackage.haskell.org/package/brick/docs/Brick-Keybindings-Parse.html#v:parseBinding\n"
        : concatMap sectionsINI handlersData
   where
    handlersData = map (second $ mapMaybe handlerData) sections
    handlerData h = case kehEventTrigger h of
      ByKey _ -> Nothing
      ByEvent k -> Just (k, handlerDescription $ kehHandler h)
    section s = "\n;;;; " <> s <> "\n"
    sectionsINI (s, hs) = section s : map (keyBindingEventINI kc) hs
  
  keyBindingEventINI :: Ord k => KeyConfig k -> (k, Text) -> Text
  keyBindingEventINI kc (ev, description) =
    T.unlines
      [ ";; " <> description
      , commentDefault <> name <> " = " <> bindingList
      ]
   where
    commentDefault = if custom then "" else "; "
    (custom, bindingList) = case lookupKeyConfigBindings kc ev of
      Just Unbound -> (True, "unbound")
      Just (BindingList bs) -> (True, listBindings bs)
      Nothing ->
        ( False
        , if null (allDefaultBindings kc ev)
            then "unbound"
            else listBindings $ allDefaultBindings kc ev
        )
    listBindings = T.intercalate "," . fmap ppBinding
    name = fromMaybe "(unnamed)" $ keyEventName (keyConfigEvents kc) ev
  
  handlerNameKeysDescription :: Ord k => KeyConfig k -> KeyEventHandler k m -> (Text, Text, Text)
  handlerNameKeysDescription kc keh = (name, keys, desc)
   where
    desc = handlerDescription $ kehHandler keh
    (name, keys) = case kehEventTrigger keh of
      ByKey b -> ("(non-customizable key)", ppBinding b)
      ByEvent ev ->
        let name' = fromMaybe "(unnamed)" $ keyEventName (keyConfigEvents kc) ev
         in case lookupKeyConfigBindings kc ev of
              Nothing ->
                if not (null (allDefaultBindings kc ev))
                  then (name', T.intercalate "," $ ppBinding <$> allDefaultBindings kc ev)
                  else (name', "unbound")
              Just Unbound ->
                (name', "unbound")
              Just (BindingList bs) ->
                let result =
                      if not (null bs)
                        then T.intercalate "," $ ppBinding <$> bs
                        else "unbound"
                 in (name', result)
  