{-# 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.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 GHC.Generics hiding (from)
import Graphics.Vty.Input.Events qualified as V
import Swarm.Language.Parse
import Text.Megaparsec
import Text.Megaparsec.Char (char, string)
import Text.Megaparsec.Char.Lexer (decimal)
import Witch (from)

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

-- | 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyCombo -> KeyCombo -> Bool
$c/= :: KeyCombo -> KeyCombo -> Bool
== :: KeyCombo -> KeyCombo -> Bool
$c== :: KeyCombo -> KeyCombo -> Bool
Eq, Eq 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
min :: KeyCombo -> KeyCombo -> KeyCombo
$cmin :: KeyCombo -> KeyCombo -> KeyCombo
max :: KeyCombo -> KeyCombo -> KeyCombo
$cmax :: KeyCombo -> KeyCombo -> KeyCombo
>= :: KeyCombo -> KeyCombo -> Bool
$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
compare :: KeyCombo -> KeyCombo -> Ordering
$ccompare :: KeyCombo -> KeyCombo -> Ordering
Ord, Int -> KeyCombo -> ShowS
[KeyCombo] -> ShowS
KeyCombo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyCombo] -> ShowS
$cshowList :: [KeyCombo] -> ShowS
show :: KeyCombo -> String
$cshow :: KeyCombo -> String
showsPrec :: Int -> KeyCombo -> ShowS
$cshowsPrec :: Int -> KeyCombo -> ShowS
Show, 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
$cto :: forall x. Rep KeyCombo x -> KeyCombo
$cfrom :: forall x. KeyCombo -> Rep KeyCombo x
Generic, Value -> Parser [KeyCombo]
Value -> Parser KeyCombo
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [KeyCombo]
$cparseJSONList :: Value -> Parser [KeyCombo]
parseJSON :: Value -> Parser KeyCombo
$cparseJSON :: Value -> Parser KeyCombo
FromJSON, [KeyCombo] -> Encoding
[KeyCombo] -> Value
KeyCombo -> Encoding
KeyCombo -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [KeyCombo] -> Encoding
$ctoEncodingList :: [KeyCombo] -> Encoding
toJSONList :: [KeyCombo] -> Value
$ctoJSONList :: [KeyCombo] -> Value
toEncoding :: KeyCombo -> Encoding
$ctoEncoding :: KeyCombo -> Encoding
toJSON :: KeyCombo -> Value
$ctoJSON :: KeyCombo -> Value
ToJSON)

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

-- | 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 (forall a. Ord a => [a] -> [a]
sort [Modifier]
mods)

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

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

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

parseKey :: Parser V.Key
parseKey :: Parser Key
parseKey =
  -- For an explanation of the 'reverse', see Note [Key names are not prefix-free]
  (forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Parser Key
specialKeyParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Set Text
specialKeyNames)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Key
parseFunctionKey
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser 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 :: Parser V.Key
parseFunctionKey :: Parser Key
parseFunctionKey = Int -> Key
V.KFun forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'F' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal)

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

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

-- https://stackoverflow.com/questions/51848587/list-constructor-names-using-generics-in-haskell
specialKeyNames :: Set Text
specialKeyNames :: Set Text
specialKeyNames = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.tail forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *). Names' f => [Text]
names' @(Rep V.Key) 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 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 (forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (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 (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    V.KChar Char
c -> [Char
c]
    V.KFun Int
n -> Char
'F' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
n
    Key
k -> forall a. Int -> [a] -> [a]
drop Int
1 (forall a. Show a => a -> String
show Key
k)