{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Parsing and pretty-printing for keys (as in, keys on a keyboard)
-- and key combos.
module Swarm.Language.Key (
  KeyCombo,
  mkKeyCombo,
  parseKeyComboFull,
  parseKeyCombo,
  prettyKeyCombo,
  specialKeyNames,
)
where

import Data.Aeson (FromJSON, ToJSON)
import Data.Foldable (asum)
import Data.Hashable (Hashable)
import Data.Kind qualified
import Data.List (sort, (\\))
import Data.Set (Set)
import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void
import GHC.Generics hiding (from)
import Graphics.Vty.Input.Events qualified as V
import Text.Megaparsec
import Text.Megaparsec.Char (char, string)
import Text.Megaparsec.Char.Lexer (decimal)
import Witch (from)

------------------------------------------------------------
-- Parsing

deriving instance Hashable V.Modifier
deriving instance Hashable V.Key

-- | A keyboard input, represented as a key + modifiers.  Invariant:
--   the modifier list is always sorted.
data KeyCombo = KeyCombo V.Key [V.Modifier]
  deriving (KeyCombo -> KeyCombo -> Bool
(KeyCombo -> KeyCombo -> Bool)
-> (KeyCombo -> KeyCombo -> Bool) -> Eq KeyCombo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyCombo -> KeyCombo -> Bool
== :: KeyCombo -> KeyCombo -> Bool
$c/= :: KeyCombo -> KeyCombo -> Bool
/= :: KeyCombo -> KeyCombo -> Bool
Eq, Eq KeyCombo
Eq KeyCombo =>
(KeyCombo -> KeyCombo -> Ordering)
-> (KeyCombo -> KeyCombo -> Bool)
-> (KeyCombo -> KeyCombo -> Bool)
-> (KeyCombo -> KeyCombo -> Bool)
-> (KeyCombo -> KeyCombo -> Bool)
-> (KeyCombo -> KeyCombo -> KeyCombo)
-> (KeyCombo -> KeyCombo -> KeyCombo)
-> Ord KeyCombo
KeyCombo -> KeyCombo -> Bool
KeyCombo -> KeyCombo -> Ordering
KeyCombo -> KeyCombo -> KeyCombo
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: KeyCombo -> KeyCombo -> Ordering
compare :: KeyCombo -> KeyCombo -> Ordering
$c< :: KeyCombo -> KeyCombo -> Bool
< :: KeyCombo -> KeyCombo -> Bool
$c<= :: KeyCombo -> KeyCombo -> Bool
<= :: KeyCombo -> KeyCombo -> Bool
$c> :: KeyCombo -> KeyCombo -> Bool
> :: KeyCombo -> KeyCombo -> Bool
$c>= :: KeyCombo -> KeyCombo -> Bool
>= :: KeyCombo -> KeyCombo -> Bool
$cmax :: KeyCombo -> KeyCombo -> KeyCombo
max :: KeyCombo -> KeyCombo -> KeyCombo
$cmin :: KeyCombo -> KeyCombo -> KeyCombo
min :: KeyCombo -> KeyCombo -> KeyCombo
Ord, Int -> KeyCombo -> ShowS
[KeyCombo] -> ShowS
KeyCombo -> String
(Int -> KeyCombo -> ShowS)
-> (KeyCombo -> String) -> ([KeyCombo] -> ShowS) -> Show KeyCombo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyCombo -> ShowS
showsPrec :: Int -> KeyCombo -> ShowS
$cshow :: KeyCombo -> String
show :: KeyCombo -> String
$cshowList :: [KeyCombo] -> ShowS
showList :: [KeyCombo] -> ShowS
Show, (forall x. KeyCombo -> Rep KeyCombo x)
-> (forall x. Rep KeyCombo x -> KeyCombo) -> Generic KeyCombo
forall x. Rep KeyCombo x -> KeyCombo
forall x. KeyCombo -> Rep KeyCombo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. KeyCombo -> Rep KeyCombo x
from :: forall x. KeyCombo -> Rep KeyCombo x
$cto :: forall x. Rep KeyCombo x -> KeyCombo
to :: forall x. Rep KeyCombo x -> KeyCombo
Generic, Eq KeyCombo
Eq KeyCombo =>
(Int -> KeyCombo -> Int) -> (KeyCombo -> Int) -> Hashable KeyCombo
Int -> KeyCombo -> Int
KeyCombo -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> KeyCombo -> Int
hashWithSalt :: Int -> KeyCombo -> Int
$chash :: KeyCombo -> Int
hash :: KeyCombo -> Int
Hashable, Maybe KeyCombo
Value -> Parser [KeyCombo]
Value -> Parser KeyCombo
(Value -> Parser KeyCombo)
-> (Value -> Parser [KeyCombo])
-> Maybe KeyCombo
-> FromJSON KeyCombo
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser KeyCombo
parseJSON :: Value -> Parser KeyCombo
$cparseJSONList :: Value -> Parser [KeyCombo]
parseJSONList :: Value -> Parser [KeyCombo]
$comittedField :: Maybe KeyCombo
omittedField :: Maybe KeyCombo
FromJSON, [KeyCombo] -> Value
[KeyCombo] -> Encoding
KeyCombo -> Bool
KeyCombo -> Value
KeyCombo -> Encoding
(KeyCombo -> Value)
-> (KeyCombo -> Encoding)
-> ([KeyCombo] -> Value)
-> ([KeyCombo] -> Encoding)
-> (KeyCombo -> Bool)
-> ToJSON KeyCombo
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: KeyCombo -> Value
toJSON :: KeyCombo -> Value
$ctoEncoding :: KeyCombo -> Encoding
toEncoding :: KeyCombo -> Encoding
$ctoJSONList :: [KeyCombo] -> Value
toJSONList :: [KeyCombo] -> Value
$ctoEncodingList :: [KeyCombo] -> Encoding
toEncodingList :: [KeyCombo] -> Encoding
$comitField :: KeyCombo -> Bool
omitField :: KeyCombo -> Bool
ToJSON)

deriving instance FromJSON V.Key
deriving instance FromJSON V.Modifier
deriving instance ToJSON V.Key
deriving instance ToJSON V.Modifier

type SParser = Parsec Void Text

-- | Smart constructor for 'KeyCombo'.
mkKeyCombo :: [V.Modifier] -> V.Key -> KeyCombo
mkKeyCombo :: [Modifier] -> Key -> KeyCombo
mkKeyCombo [Modifier]
mods Key
k = Key -> [Modifier] -> KeyCombo
KeyCombo Key
k ([Modifier] -> [Modifier]
forall a. Ord a => [a] -> [a]
sort [Modifier]
mods)

-- | Parse a key combo with nothing after it.
parseKeyComboFull :: SParser KeyCombo
parseKeyComboFull :: SParser KeyCombo
parseKeyComboFull = SParser KeyCombo
parseKeyCombo SParser KeyCombo
-> ParsecT Void Text Identity () -> SParser KeyCombo
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

-- | Parse a key combo like @\"M-C-F5\"@, @\"Down\"@, or @\"C-x\"@.
parseKeyCombo :: SParser KeyCombo
parseKeyCombo :: SParser KeyCombo
parseKeyCombo =
  [Modifier] -> Key -> KeyCombo
mkKeyCombo ([Modifier] -> Key -> KeyCombo)
-> ParsecT Void Text Identity [Modifier]
-> ParsecT Void Text Identity (Key -> KeyCombo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Modifier
-> ParsecT Void Text Identity [Modifier]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void Text Identity Modifier
-> ParsecT Void Text Identity Modifier
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Modifier
parseModifier ParsecT Void Text Identity Modifier
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Modifier
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-')) ParsecT Void Text Identity (Key -> KeyCombo)
-> ParsecT Void Text Identity Key -> SParser KeyCombo
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Key
parseKey

parseModifier :: SParser V.Modifier
parseModifier :: ParsecT Void Text Identity Modifier
parseModifier =
  Modifier
V.MShift Modifier
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Modifier
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"S"
    ParsecT Void Text Identity Modifier
-> ParsecT Void Text Identity Modifier
-> ParsecT Void Text Identity Modifier
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Modifier
V.MCtrl Modifier
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Modifier
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"C"
    ParsecT Void Text Identity Modifier
-> ParsecT Void Text Identity Modifier
-> ParsecT Void Text Identity Modifier
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Modifier
V.MMeta Modifier
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Modifier
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"M"
    ParsecT Void Text Identity Modifier
-> ParsecT Void Text Identity Modifier
-> ParsecT Void Text Identity Modifier
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Modifier
V.MAlt Modifier
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Modifier
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"A"

parseKey :: SParser V.Key
parseKey :: ParsecT Void Text Identity Key
parseKey =
  -- For an explanation of the 'reverse', see Note [Key names are not prefix-free]
  ([ParsecT Void Text Identity Key] -> ParsecT Void Text Identity Key
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([ParsecT Void Text Identity Key]
 -> ParsecT Void Text Identity Key)
-> (Set Text -> [ParsecT Void Text Identity Key])
-> Set Text
-> ParsecT Void Text Identity Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> ParsecT Void Text Identity Key)
-> [Text] -> [ParsecT Void Text Identity Key]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ParsecT Void Text Identity Key
specialKeyParser ([Text] -> [ParsecT Void Text Identity Key])
-> (Set Text -> [Text])
-> Set Text
-> [ParsecT Void Text Identity Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> (Set Text -> [Text]) -> Set Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> ParsecT Void Text Identity Key)
-> Set Text -> ParsecT Void Text Identity Key
forall a b. (a -> b) -> a -> b
$ Set Text
specialKeyNames)
    ParsecT Void Text Identity Key
-> ParsecT Void Text Identity Key -> ParsecT Void Text Identity Key
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Key
parseFunctionKey
    ParsecT Void Text Identity Key
-> ParsecT Void Text Identity Key -> ParsecT Void Text Identity Key
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Key
parseCharKey

-- Note [Key names are not prefix-free]
--
-- The names of special keys are not prefix-free, and in particular
-- include 'Down', 'DownRight', 'DownLeft', and also 'Up', 'UpRight',
-- 'UpLeft'.  When we try to parse a particular name with 'string' it
-- will backtrack as long as the whole string is not consumed, which
-- means it's OK if key names share a common prefix, like Enter and
-- Esc.  However, when one key name is a prefix of another we have to
-- be careful of the order in which we try parsing them, and in
-- particular we must try parsing the longer one first. If we have
-- 'Up' come first and then 'UpLeft', for example, given the input
-- "UpLeft" the 'Up' would succeed, but then the entire parse would
-- fail since there is input left over.  If we simply reverse the list
-- of key names (which are sorted alphabetically), it guarantees that
-- longer names will come before names which are prefixes of them.

parseFunctionKey :: SParser V.Key
parseFunctionKey :: ParsecT Void Text Identity Key
parseFunctionKey = Int -> Key
V.KFun (Int -> Key)
-> ParsecT Void Text Identity Int -> ParsecT Void Text Identity Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Int -> ParsecT Void Text Identity Int
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'F' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Int -> ParsecT Void Text Identity Int
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal)

parseCharKey :: SParser V.Key
parseCharKey :: ParsecT Void Text Identity Key
parseCharKey = Char -> Key
V.KChar (Char -> Key)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle

specialKeyParser :: Text -> SParser V.Key
specialKeyParser :: Text -> ParsecT Void Text Identity Key
specialKeyParser Text
t = String -> Key
forall a. Read a => String -> a
read (String -> Key) -> (Text -> String) -> Text -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'K' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source target. From source target => source -> target
from @Text (Text -> Key)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
t

-- https://stackoverflow.com/questions/51848587/list-constructor-names-using-generics-in-haskell
specialKeyNames :: Set Text
specialKeyNames :: Set Text
specialKeyNames = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> ([Text] -> [Text]) -> [Text] -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map HasCallStack => Text -> Text
Text -> Text
T.tail ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *). Names' f => [Text]
names' @(Rep V.Key) [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Text
"KChar", Text
"KFun"])

class Names' (f :: Data.Kind.Type -> Data.Kind.Type) where
  names' :: [Text]
instance (Names' f) => Names' (M1 D t f) where
  names' :: [Text]
names' = forall (f :: * -> *). Names' f => [Text]
names' @f
instance (Names' f, Names' g) => Names' (f :+: g) where
  names' :: [Text]
names' = forall (f :: * -> *). Names' f => [Text]
names' @f [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *). Names' f => [Text]
names' @g
instance (Constructor c) => Names' (C1 c f) where
  names' :: [Text]
names' = [forall source target. From source target => source -> target
from @String (M1 C c f Any -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName (C1 c f g
forall {g}. C1 c f g
forall a. HasCallStack => a
undefined :: C1 c f g))]

------------------------------------------------------------
-- Pretty-printing

-- | Pretty-print a key combo, e.g. @\"C-M-F5\"@.  Right inverse to
--   'parseKeyCombo'.  Left inverse up to reordering of modifiers.
prettyKeyCombo :: KeyCombo -> Text
prettyKeyCombo :: KeyCombo -> Text
prettyKeyCombo (KeyCombo Key
k [Modifier]
mods) = Text -> Text -> Text
T.append ([Text] -> Text
T.concat ((Modifier -> Text) -> [Modifier] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Modifier -> Text
prettyModifier [Modifier]
mods)) (Key -> Text
prettyKey Key
k)

prettyModifier :: V.Modifier -> Text
prettyModifier :: Modifier -> Text
prettyModifier Modifier
m = forall source target. From source target => source -> target
from @String [Modifier -> Char
modifierChar Modifier
m, Char
'-']
 where
  modifierChar :: Modifier -> Char
modifierChar = \case
    Modifier
V.MAlt -> Char
'A'
    Modifier
V.MCtrl -> Char
'C'
    Modifier
V.MMeta -> Char
'M'
    Modifier
V.MShift -> Char
'S'

prettyKey :: V.Key -> Text
prettyKey :: Key -> Text
prettyKey =
  forall source target. From source target => source -> target
from @String (String -> Text) -> (Key -> String) -> Key -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    V.KChar Char
c -> [Char
c]
    V.KFun Int
n -> Char
'F' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
n
    Key
k -> Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 (Key -> String
forall a. Show a => a -> String
show Key
k)