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)

-- TODO make the string overlapping instance nicer
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

-- | This quasiquoter lets you use [key|enter|] at compile time,
--   so you don't get a Maybe as you would from mkKey
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"
  ]