module AutoGUI.Keys
( mkKey
, keyToText
, key
, isValidKey
, keys
, Key
)
where
import CPython.Simple.Instances
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
newtype Key = Key String
deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Int -> Key -> ShowS
$cshowsPrec :: Int -> Key -> ShowS
Show, Eq Key
Eq Key
-> (Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
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 :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmax :: Key -> Key -> Key
>= :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c< :: Key -> Key -> Bool
compare :: Key -> Key -> Ordering
$ccompare :: Key -> Key -> Ordering
$cp1Ord :: Eq Key
Ord, Key -> Q Exp
Key -> Q (TExp Key)
(Key -> Q Exp) -> (Key -> Q (TExp Key)) -> Lift Key
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Key -> Q (TExp Key)
$cliftTyped :: Key -> Q (TExp Key)
lift :: Key -> Q Exp
$clift :: Key -> Q Exp
Lift)
instance ToPy Key where
toPy :: Key -> IO SomeObject
toPy (Key String
str) = Text -> IO SomeObject
forall a. ToPy a => a -> IO SomeObject
toPy (Text -> IO SomeObject) -> Text -> IO SomeObject
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
str
mkKey :: Text -> Maybe Key
mkKey :: Text -> Maybe Key
mkKey Text
key = if Text -> Bool
isValidKey Text
key then Key -> Maybe Key
forall a. a -> Maybe a
Just (String -> Key
Key (Text -> String
T.unpack Text
key)) else Maybe Key
forall a. Maybe a
Nothing
keyToText :: Key -> Text
keyToText :: Key -> Text
keyToText (Key String
text) = String -> Text
T.pack String
text
key :: QuasiQuoter
key :: QuasiQuoter
key =
QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
compileKeyExp
, quotePat :: String -> Q Pat
quotePat = String -> Q Pat
compileKeyPat
, quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Key is not a declaration"
, quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"Key is not a type"
}
where
compileKeyExp :: String -> Q Exp
compileKeyExp :: String -> Q Exp
compileKeyExp String
s = case Text -> Maybe Key
mkKey (String -> Text
T.pack String
s) of
Maybe Key
Nothing -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"`" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"` is not a valid key"
Just Key
key -> [|key|]
compileKeyPat :: String -> Q Pat
compileKeyPat :: String -> Q Pat
compileKeyPat String
s = case Text -> Maybe Key
mkKey (String -> Text
T.pack String
s) of
Maybe Key
Nothing -> String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Pat) -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String
"`" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"` is not a valid key"
Just (Key String
str) -> Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Pat] -> Pat
ConP 'Key [Lit -> Pat
LitP (Lit -> Pat) -> Lit -> Pat
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
str]
isValidKey :: Text -> Bool
isValidKey :: Text -> Bool
isValidKey Text
key = Text
key Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
keysText
keys :: Set Key
keys :: Set Key
keys = (Text -> Key) -> Set Text -> Set Key
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (String -> Key
Key (String -> Key) -> (Text -> String) -> Text -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) Set Text
keysText
keysText :: Set Text
keysText :: Set Text
keysText = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
[ Text
"\t"
, Text
"\n"
, Text
"\r"
, Text
" "
, Text
"!"
, Text
"'"
, Text
"#"
, Text
"$"
, Text
"%"
, Text
"&"
, Text
"\""
, Text
"("
, Text
")"
, Text
"*"
, Text
"+"
, Text
","
, Text
"-"
, Text
"."
, Text
"/"
, Text
"0"
, Text
"1"
, Text
"2"
, Text
"3"
, Text
"4"
, Text
"5"
, Text
"6"
, Text
"7"
, Text
"8"
, Text
"9"
, Text
":"
, Text
";"
, Text
"<"
, Text
"="
, Text
">"
, Text
"?"
, Text
"@"
, Text
"["
, Text
"\\"
, Text
"]"
, Text
"^"
, Text
"_"
, Text
"`"
, Text
"a"
, Text
"b"
, Text
"c"
, Text
"d"
, Text
"e"
, Text
"f"
, Text
"g"
, Text
"h"
, Text
"i"
, Text
"j"
, Text
"k"
, Text
"l"
, Text
"m"
, Text
"n"
, Text
"o"
, Text
"p"
, Text
"q"
, Text
"r"
, Text
"s"
, Text
"t"
, Text
"u"
, Text
"v"
, Text
"w"
, Text
"x"
, Text
"y"
, Text
"z"
, Text
"{"
, Text
"|"
, Text
"}"
, Text
"~"
, Text
"accept"
, Text
"add"
, Text
"alt"
, Text
"altleft"
, Text
"altright"
, Text
"apps"
, Text
"backspace"
, Text
"browserback"
, Text
"browserfavorites"
, Text
"browserforward"
, Text
"browserhome"
, Text
"browserrefresh"
, Text
"browsersearch"
, Text
"browserstop"
, Text
"capslock"
, Text
"clear"
, Text
"convert"
, Text
"ctrl"
, Text
"ctrlleft"
, Text
"ctrlright"
, Text
"decimal"
, Text
"del"
, Text
"delete"
, Text
"divide"
, Text
"down"
, Text
"end"
, Text
"enter"
, Text
"esc"
, Text
"escape"
, Text
"execute"
, Text
"f1"
, Text
"f10"
, Text
"f11"
, Text
"f12"
, Text
"f13"
, Text
"f14"
, Text
"f15"
, Text
"f16"
, Text
"f17"
, Text
"f18"
, Text
"f19"
, Text
"f2"
, Text
"f20"
, Text
"f21"
, Text
"f22"
, Text
"f23"
, Text
"f24"
, Text
"f3"
, Text
"f4"
, Text
"f5"
, Text
"f6"
, Text
"f7"
, Text
"f8"
, Text
"f9"
, Text
"final"
, Text
"fn"
, Text
"hanguel"
, Text
"hangul"
, Text
"hanja"
, Text
"help"
, Text
"home"
, Text
"insert"
, Text
"junja"
, Text
"kana"
, Text
"kanji"
, Text
"launchapp1"
, Text
"launchapp2"
, Text
"launchmail"
, Text
"launchmediaselect"
, Text
"left"
, Text
"modechange"
, Text
"multiply"
, Text
"nexttrack"
, Text
"nonconvert"
, Text
"num0"
, Text
"num1"
, Text
"num2"
, Text
"num3"
, Text
"num4"
, Text
"num5"
, Text
"num6"
, Text
"num7"
, Text
"num8"
, Text
"num9"
, Text
"numlock"
, Text
"pagedown"
, Text
"pageup"
, Text
"pause"
, Text
"pgdn"
, Text
"pgup"
, Text
"playpause"
, Text
"prevtrack"
, Text
"print"
, Text
"printscreen"
, Text
"prntscrn"
, Text
"prtsc"
, Text
"prtscr"
, Text
"return"
, Text
"right"
, Text
"scrolllock"
, Text
"select"
, Text
"separator"
, Text
"shift"
, Text
"shiftleft"
, Text
"shiftright"
, Text
"sleep"
, Text
"space"
, Text
"stop"
, Text
"subtract"
, Text
"tab"
, Text
"up"
, Text
"volumedown"
, Text
"volumemute"
, Text
"volumeup"
, Text
"win"
, Text
"winleft"
, Text
"winright"
, Text
"yen"
, Text
"command"
, Text
"option"
, Text
"optionleft"
, Text
"optionright"
]