Keymap.hs

{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{- HLINT ignore "Use tuple-section" -}

module Keymap where

import Brick.Keybindings
import qualified Brick.Keybindings.KeyEvents as B
import Conferer.Config ((/.))
import Conferer.FromConfig (DefaultConfig (..), FromConfig (..), fetchFromConfig)
import Data.List (groupBy)
import qualified Data.Text as T
import Data.Tuple (swap)
import Data.Yaml (ToJSON (..), Value (..), object, (.=))
import Editor.Keymap (EditorAction (..), editorKeyConfigWithUserConfig, editorKeyEvents)
import qualified Graphics.Vty as V

data GlobalAction
  = Quit
  | Hush
  | Panic
  | CustomAction T.Text
  deriving (Show, Eq, Ord)

data FullKeyConfig = FullKeyConfig
  { kGlobal :: KeyConfig GlobalAction,
    kEditor :: KeyConfig EditorAction
  }
  deriving (Show)

data CustomKeymap = CustomKeymap
  { customGlobal :: [(Binding, GlobalAction)],
    customEditor :: [(Binding, EditorAction)]
  }
  deriving (Show)

customKeyConfig :: CustomKeymap -> FullKeyConfig
customKeyConfig (CustomKeymap gl ed) = FullKeyConfig (globalKeyConfigWithUserConfig gl) (editorKeyConfigWithUserConfig ed)

defaultGlobalBindings :: [(GlobalAction, [Binding])]
defaultGlobalBindings =
  [ (Quit, [ctrl 'q']),
    (Hush, [meta '.']),
    (Panic, [meta ','])
  ]

globalKeyEventsFromUserConfig :: [(Binding, GlobalAction)] -> KeyEvents GlobalAction
globalKeyEventsFromUserConfig conf = B.keyEvents $ map (\(_, ac) -> (ppAction ac, ac)) conf

globalKeyConfigWithUserConfig :: [(Binding, GlobalAction)] -> KeyConfig GlobalAction
globalKeyConfigWithUserConfig conf = newKeyConfig (globalKeyEventsFromUserConfig conf) defaultGlobalBindings conf'
  where
    conf' = map toBinding $ groupBy (\(_, a1) (_, a2) -> a1 == a2) conf
    toBinding [] = error "Error in toBinding"
    toBinding ((b, a) : bs) = (a, BindingList $ b : map fst bs)

instance FromConfig (Binding, GlobalAction) where
  fromConfig key configSource = do
    b <- fetchFromConfig (key /. "binding") configSource :: IO T.Text
    a <- fetchFromConfig (key /. "action") configSource :: IO T.Text
    return (parseShortcut b, interpretAction a)
    where
      parseShortcut :: T.Text -> Binding
      parseShortcut shortcut = case parseBinding (T.strip shortcut) of
        Left err -> error $ "Could not parse keymap file: " <> err
        Right b -> b

instance FromConfig (Binding, EditorAction) where
  fromConfig key configSource = do
    b <- fetchFromConfig (key /. "binding") configSource :: IO T.Text
    a <- fetchFromConfig (key /. "action") configSource :: IO T.Text
    return (parseShortcut b, parseAction a)
    where
      parseAction :: T.Text -> EditorAction
      parseAction x = case lookup x $ keyEventsList editorKeyEvents of
        Just ac -> ac
        Nothing -> error "Could not parse action in editor keymap file."
      parseShortcut :: T.Text -> Binding
      parseShortcut shortcut = case parseBinding (T.strip shortcut) of
        Left err -> error $ "Could not parse keymap file: " <> err
        Right b -> b

instance FromConfig CustomKeymap where
  fromConfig key configSource = do
    gl <- fetchFromConfig (key /. "global") configSource :: IO [(Binding, GlobalAction)]
    ed <- fetchFromConfig (key /. "editor") configSource :: IO [(Binding, EditorAction)]
    return $ CustomKeymap gl ed

interpretAction :: T.Text -> GlobalAction
interpretAction txtVal = case T.toLower (T.strip txtVal) of
  "quit" -> Quit
  "hush" -> Hush
  "panic" -> Panic
  other -> CustomAction other

ppAction :: GlobalAction -> T.Text
ppAction Quit = "quit"
ppAction Hush = "hush"
ppAction Panic = "panic"
ppAction (CustomAction other) = other

instance ToJSON BindingState where
  toJSON (BindingList (b : _)) = toJSON $ ppBinding b
  toJSON _ = Null

instance ToJSON Binding where
  toJSON = toJSON . ppBinding

instance ToJSON GlobalAction where
  toJSON = toJSON . ppAction

instance ToJSON EditorAction where
  toJSON ac = maybe Null toJSON $ lookup ac $ map swap $ keyEventsList editorKeyEvents

instance ToJSON CustomKeymap where
  toJSON (CustomKeymap gl ed) =
    object
      [ "global" .= toJSON (map (\(b, a) -> object ["binding" .= b, "action" .= a]) gl),
        "editor" .= toJSON (map (\(b, a) -> object ["binding" .= b, "action" .= a]) ed)
      ]

instance DefaultConfig CustomKeymap where
  configDef = CustomKeymap [(ctrl 'q', Quit), (meta '.', Hush), (meta ',', Panic)] [(ctrl '@', Hint), (meta V.KEnter, Eval), (ctrl '_', CommentLine)]