Key.hs

{-# LANGUAGE DeriveGeneric #-}
-- | Basic definitions for 'Key's, 'Mod'ifiers, and 'Chord's of 'Key's and
-- 'Mod'ifiers. We can read key 'Chord's from "Graphics.Vty" 'Vty.EvKey' events
-- using 'fromVty'.
--
-- This module is intended for qualified import:
--
-- > import qualified Vgrep.Key as Key
--
-- We define our own 'Key' and 'Mod' types rather than using "Graphics.Vty"'s
-- 'Vty.Key' and 'Vty.Modifier', because it simplifies parsing (of keys like
-- 'Space' and 'Tab', which are represented as @' '@ and @'\t'@ in
-- "Graphics.Vty"), and because a 'Set' of 'Mod's is simpler to check for
-- equality than a list of 'Vty.Modifier's.
module Vgrep.Key
  ( Chord (..)
  , Key (..)
  , Mod (..)
  , fromVty
  , key
  , withModifier
  )where

import           Control.Applicative
import           Data.Set                  (Set)
import qualified Data.Set                  as S
import           GHC.Generics
import qualified Graphics.Vty.Input.Events as Vty
import           Prelude                   hiding (Left, Right)


-- | A chord of keys and modifiers pressed simultaneously.
data Chord = Chord (Set Mod) Key
    deriving (Eq, Ord, Show, Generic)

data Key
    = Char Char | Space
    | Esc | Backspace | Enter | Del | Tab
    | Left | Right | Up     | Down
    | Home | End   | PageUp | PageDown
    deriving (Eq, Ord, Show, Read, Generic)

data Mod
    = Ctrl
    | Meta
    | Shift
    deriving (Eq, Ord, Show, Generic)


-- | Reads the key and modifiers from an 'Vty.Event'. Non-key events and events
-- with unknown keys are mapped to 'Nothing'.
fromVty :: Vty.Event -> Maybe Chord
fromVty = \case
    Vty.EvKey k ms -> liftA2 Chord (mapModifiers ms) (mapKey k)
    _otherwise     -> Nothing

mapModifiers :: [Vty.Modifier] -> Maybe (Set Mod)
mapModifiers = Just . S.fromList . map go
  where
    go = \case
        Vty.MCtrl  -> Ctrl
        Vty.MShift -> Shift
        Vty.MMeta  -> Meta
        Vty.MAlt   -> Meta

mapKey :: Vty.Key -> Maybe Key
mapKey = \case
    Vty.KChar ' '  -> Just Space
    Vty.KEsc       -> Just Esc
    Vty.KBS        -> Just Backspace
    Vty.KEnter     -> Just Enter
    Vty.KDel       -> Just Del
    Vty.KChar '\t' -> Just Tab
    Vty.KLeft      -> Just Left
    Vty.KRight     -> Just Right
    Vty.KUp        -> Just Up
    Vty.KDown      -> Just Down
    Vty.KHome      -> Just Home
    Vty.KEnd       -> Just End
    Vty.KPageUp    -> Just PageUp
    Vty.KPageDown  -> Just PageDown
    Vty.KChar c    -> Just (Char c)
    _otherwise     -> Nothing


-- | Build a 'Chord' from a single 'Key'
key :: Key -> Chord
key = Chord S.empty

-- | Add a 'Mod'ifier to a 'Chord'
withModifier :: Chord -> Mod -> Chord
withModifier (Chord ms k) m = Chord (S.insert m ms) k