{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
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)
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
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)
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
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 =
(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
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
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))]
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. [a] -> [a]
tail (forall a. Show a => a -> String
show Key
k)