{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK show-extensions #-}
module Yi.Keymap.Vim.EventUtils
( stringToEvent
, eventToEventString
, parseEvents
, stringToRepeatableAction
, normalizeCount
, splitCountedCommand
) where
import Data.Char (isDigit, toUpper)
import Data.List (foldl')
import qualified Data.Map as M (Map, fromList, lookup)
import Data.Monoid ((<>))
import qualified Data.Text as T (break, cons, null, pack, singleton, snoc, span, unpack)
import Data.Tuple (swap)
import Yi.Event
import Yi.Keymap.Keys (char, ctrl, meta, spec)
import Yi.Keymap.Vim.Common (EventString (Ev), RepeatableAction (RepeatableAction))
import Yi.String (showT)
specMap :: M.Map EventString Key
specMap :: Map EventString Key
specMap = [(EventString, Key)] -> Map EventString Key
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(EventString, Key)]
specList
invSpecMap :: M.Map Key EventString
invSpecMap :: Map Key EventString
invSpecMap = [(Key, EventString)] -> Map Key EventString
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Key, EventString)] -> Map Key EventString)
-> [(Key, EventString)] -> Map Key EventString
forall a b. (a -> b) -> a -> b
$ ((EventString, Key) -> (Key, EventString))
-> [(EventString, Key)] -> [(Key, EventString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EventString, Key) -> (Key, EventString)
forall a b. (a, b) -> (b, a)
swap [(EventString, Key)]
specList
specList :: [(EventString, Key)]
specList :: [(EventString, Key)]
specList =
[ (Text -> EventString
Ev "Esc", Key
KEsc)
, (Text -> EventString
Ev "CR", Key
KEnter)
, (Text -> EventString
Ev "BS", Key
KBS)
, (Text -> EventString
Ev "Tab", Key
KTab)
, (Text -> EventString
Ev "Down", Key
KDown)
, (Text -> EventString
Ev "Up", Key
KUp)
, (Text -> EventString
Ev "Left", Key
KLeft)
, (Text -> EventString
Ev "Right", Key
KRight)
, (Text -> EventString
Ev "PageUp", Key
KPageUp)
, (Text -> EventString
Ev "PageDown", Key
KPageDown)
, (Text -> EventString
Ev "Home", Key
KHome)
, (Text -> EventString
Ev "End", Key
KEnd)
, (Text -> EventString
Ev "Ins", Key
KIns)
, (Text -> EventString
Ev "Del", Key
KDel)
]
stringToEvent :: String -> Event
stringToEvent :: String -> Event
stringToEvent "<" = String -> Event
forall a. HasCallStack => String -> a
error "Invalid event string \"<\""
stringToEvent "<C-@>" = (Key -> [Modifier] -> Event
Event (Char -> Key
KASCII ' ') [Modifier
MCtrl])
stringToEvent s :: String
s@('<':'C':'-':_) = Int -> String -> (Event -> Event) -> Event
stringToEvent' 3 String
s Event -> Event
ctrl
stringToEvent s :: String
s@('<':'M':'-':_) = Int -> String -> (Event -> Event) -> Event
stringToEvent' 3 String
s Event -> Event
meta
stringToEvent s :: String
s@('<':'a':'-':_) = Int -> String -> (Event -> Event) -> Event
stringToEvent' 3 String
s Event -> Event
meta
stringToEvent "<lt>" = Char -> Event
char '<'
stringToEvent [c :: Char
c] = Char -> Event
char Char
c
stringToEvent ('<':'F':d :: Char
d:'>':[]) | Char -> Bool
isDigit Char
d = Key -> Event
spec (Int -> Key
KFun (Int -> Key) -> Int -> Key
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read [Char
d])
stringToEvent ('<':'F':'1':d :: Char
d:'>':[]) | Char -> Bool
isDigit Char
d = Key -> Event
spec (Int -> Key
KFun (Int -> Key) -> Int -> Key
forall a b. (a -> b) -> a -> b
$ 10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. Read a => String -> a
read [Char
d])
stringToEvent s :: String
s@('<':_) = Int -> String -> (Event -> Event) -> Event
stringToEvent' 1 String
s Event -> Event
forall a. a -> a
id
stringToEvent s :: String
s = String -> Event
forall a. HasCallStack => String -> a
error ("Invalid event string " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s)
stringToEvent' :: Int -> String -> (Event -> Event) -> Event
stringToEvent' :: Int -> String -> (Event -> Event) -> Event
stringToEvent' toDrop :: Int
toDrop inputString :: String
inputString modifier :: Event -> Event
modifier =
let analyzedString :: String
analyzedString = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
toDrop String
inputString
in case String
analyzedString of
[c :: Char
c,'>'] -> Event -> Event
modifier (Char -> Event
char Char
c)
_ -> if String -> Char
forall a. [a] -> a
last String
analyzedString Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '>'
then String -> Event
forall a. HasCallStack => String -> a
error ("Invalid event string " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
inputString)
else case EventString -> Map EventString Key -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> EventString
Ev (Text -> EventString) -> (String -> Text) -> String -> EventString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> EventString) -> String -> EventString
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
init String
analyzedString) Map EventString Key
specMap of
Just k :: Key
k -> Event -> Event
modifier (Key -> [Modifier] -> Event
Event Key
k [])
Nothing -> String -> Event
forall a. HasCallStack => String -> a
error (String -> Event) -> String -> Event
forall a b. (a -> b) -> a -> b
$ "Couldn't convert string " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
inputString String -> String -> String
forall a. [a] -> [a] -> [a]
++ " to event"
eventToEventString :: Event -> EventString
eventToEventString :: Event -> EventString
eventToEventString e :: Event
e = case Event
e of
Event (KASCII '<') [] -> Text -> EventString
Ev "<lt>"
Event (KASCII ' ') [MCtrl] -> Text -> EventString
Ev "<C-@>"
Event (KASCII c :: Char
c) [] -> Text -> EventString
Ev (Text -> EventString) -> Text -> EventString
forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton Char
c
Event (KASCII c :: Char
c) [MCtrl] -> Text -> EventString
Ev (Text -> EventString) -> Text -> EventString
forall a b. (a -> b) -> a -> b
$ Modifier -> Char -> Text
mkMod Modifier
MCtrl Char
c
Event (KASCII c :: Char
c) [MMeta] -> Text -> EventString
Ev (Text -> EventString) -> Text -> EventString
forall a b. (a -> b) -> a -> b
$ Modifier -> Char -> Text
mkMod Modifier
MMeta Char
c
Event (KASCII c :: Char
c) [MShift] -> Text -> EventString
Ev (Text -> EventString) -> (Char -> Text) -> Char -> EventString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton (Char -> EventString) -> Char -> EventString
forall a b. (a -> b) -> a -> b
$ Char -> Char
toUpper Char
c
Event (KFun x :: Int
x) [] -> Text -> EventString
Ev (Text -> EventString) -> Text -> EventString
forall a b. (a -> b) -> a -> b
$ "<F" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
x Text -> Char -> Text
`T.snoc` '>'
v :: Event
v@(Event k :: Key
k mods :: [Modifier]
mods) -> case Key -> Map Key EventString -> Maybe EventString
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Key
k Map Key EventString
invSpecMap of
Just (Ev s :: Text
s) -> case [Modifier]
mods of
[] -> Text -> EventString
Ev (Text -> EventString) -> Text -> EventString
forall a b. (a -> b) -> a -> b
$ '<' Char -> Text -> Text
`T.cons` Text
s Text -> Char -> Text
`T.snoc` '>'
[MCtrl] -> Text -> EventString
Ev (Text -> EventString) -> Text -> EventString
forall a b. (a -> b) -> a -> b
$ "<C-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Char -> Text
`T.snoc` '>'
[MMeta] -> Text -> EventString
Ev (Text -> EventString) -> Text -> EventString
forall a b. (a -> b) -> a -> b
$ "<M-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Char -> Text
`T.snoc` '>'
_ -> String -> EventString
forall a. HasCallStack => String -> a
error (String -> EventString) -> String -> EventString
forall a b. (a -> b) -> a -> b
$ "Couldn't convert event <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
forall a. Show a => a -> String
show Event
v
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "> to string, because of unknown modifiers"
Nothing -> String -> EventString
forall a. HasCallStack => String -> a
error (String -> EventString) -> String -> EventString
forall a b. (a -> b) -> a -> b
$ "Couldn't convert event <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
forall a. Show a => a -> String
show Event
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "> to string"
where
f :: Modifier -> Char
f MCtrl = 'C'
f MMeta = 'M'
f _ = '×'
mkMod :: Modifier -> Char -> Text
mkMod m :: Modifier
m c :: Char
c = '<' Char -> Text -> Text
`T.cons` Modifier -> Char
f Modifier
m Char -> Text -> Text
`T.cons` '-'
Char -> Text -> Text
`T.cons` Char
c Char -> Text -> Text
`T.cons` Char -> Text
T.singleton '>'
parseEvents :: EventString -> [Event]
parseEvents :: EventString -> [Event]
parseEvents (Ev x :: Text
x) = ([Event], String) -> [Event]
forall a b. (a, b) -> a
fst (([Event], String) -> [Event])
-> (String -> ([Event], String)) -> String -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Event], String) -> Char -> ([Event], String))
-> ([Event], String) -> String -> ([Event], String)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Event], String) -> Char -> ([Event], String)
go ([], []) (String -> [Event]) -> String -> [Event]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
x
where go :: ([Event], String) -> Char -> ([Event], String)
go (evs :: [Event]
evs, s :: String
s) '\n' = ([Event]
evs, String
s)
go (evs :: [Event]
evs, []) '<' = ([Event]
evs, "<")
go (evs :: [Event]
evs, []) c :: Char
c = ([Event]
evs [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++ [Char -> Event
char Char
c], [])
go (evs :: [Event]
evs, s :: String
s) '>' = ([Event]
evs [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++ [String -> Event
stringToEvent (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ ">")], [])
go (evs :: [Event]
evs, s :: String
s) c :: Char
c = ([Event]
evs, String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c])
stringToRepeatableAction :: EventString -> RepeatableAction
stringToRepeatableAction :: EventString -> RepeatableAction
stringToRepeatableAction s :: EventString
s = Int -> EventString -> RepeatableAction
RepeatableAction Int
count EventString
command
where (count :: Int
count, command :: EventString
command) = EventString -> (Int, EventString)
splitCountedCommand EventString
s
splitCountedCommand :: EventString -> (Int, EventString)
splitCountedCommand :: EventString -> (Int, EventString)
splitCountedCommand (Ev s :: Text
s) = (Int
count, Text -> EventString
Ev Text
commandString)
where (countString :: Text
countString, commandString :: Text
commandString) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isDigit Text
s
count :: Int
count = case Text
countString of
"" -> 1
x :: Text
x -> String -> Int
forall a. Read a => String -> a
read (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
x
normalizeCount :: EventString -> EventString
normalizeCount :: EventString -> EventString
normalizeCount s :: EventString
s =
if Text -> Bool
T.null Text
countedObject
then EventString
s
else Text -> EventString
Ev (Text -> EventString) -> Text -> EventString
forall a b. (a -> b) -> a -> b
$ Int -> Text
forall a. Show a => a -> Text
showT (Int
operatorCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
objectCount) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
operator Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
object
where (operatorCount :: Int
operatorCount, Ev rest1 :: Text
rest1) = EventString -> (Int, EventString)
splitCountedCommand EventString
s
(operator :: Text
operator, countedObject :: Text
countedObject) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isDigit Text
rest1
(objectCount :: Int
objectCount, Ev object :: Text
object) = EventString -> (Int, EventString)
splitCountedCommand (Text -> EventString
Ev Text
countedObject)