{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  Yi.Keymap.Keys
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Combinators for building keymaps.

module Yi.Keymap.Keys
    (
     module Yi.Event,
     module Yi.Interact,
     printableChar, textChar,
     charOf, shift, meta, ctrl, super, hyper, spec, char,
     (>>!), (>>=!), (?>>), (?>>!), (?*>>), (?*>>!),
     ctrlCh, metaCh, hyperCh,
     optMod,
     pString
    ) where

import Prelude       hiding (error)

import Control.Monad (unless)
import qualified Control.Monad.Fail as Fail
import Data.Char     (isAlpha, isPrint, toUpper)
import Data.List     (nub, sort)
import Yi.Debug      (error)
import Yi.Event      (Event (..), Key (..), Modifier (..), eventToChar, prettyEvent)
import Yi.Interact   hiding (write)
import Yi.Keymap     (Action, KeymapM, YiAction, write)

printableChar :: (Fail.MonadFail m, MonadInteract m w Event) => m Char
printableChar :: m Char
printableChar = do
  Event (KASCII Char
c) [] <- m Event
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
m event
anyEvent
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Char -> Bool
isPrint Char
c) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
       String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unprintable character"
  Char -> m Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c

-- | Parse any character that can be inserted in the text.
textChar :: KeymapM Char
textChar :: KeymapM Char
textChar = do
    -- Why only ASCII?
    Event (KASCII Char
c) [] <- I Event Action Event
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
m event
anyEvent
    Char -> KeymapM Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c

pString :: (MonadInteract m w Event) => String -> m [Event]
pString :: String -> m [Event]
pString = [Event] -> m [Event]
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
[event] -> m [event]
events ([Event] -> m [Event])
-> (String -> [Event]) -> String -> m [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Event) -> String -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Event
char

charOf :: (Fail.MonadFail m, MonadInteract m w Event) => (Event -> Event) -> Char -> Char -> m Char
charOf :: (Event -> Event) -> Char -> Char -> m Char
charOf Event -> Event
modifier Char
l Char
h =
    do Event (KASCII Char
c) [Modifier]
_ <- Event -> Event -> m Event
forall e (m :: * -> *) w.
(Ord e, MonadInteract m w e) =>
e -> e -> m e
eventBetween (Event -> Event
modifier (Event -> Event) -> Event -> Event
forall a b. (a -> b) -> a -> b
$ Char -> Event
char Char
l) (Event -> Event
modifier (Event -> Event) -> Event -> Event
forall a b. (a -> b) -> a -> b
$ Char -> Event
char Char
h)
       Char -> m Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c

shift,ctrl,meta,super,hyper :: Event -> Event
shift :: Event -> Event
shift (Event (KASCII Char
c) [Modifier]
ms) | Char -> Bool
isAlpha Char
c = Key -> [Modifier] -> Event
Event (Char -> Key
KASCII (Char -> Char
toUpper Char
c)) [Modifier]
ms
                            | Bool
otherwise = Text -> Event
forall a. Text -> a
error Text
"shift: unhandled event"
shift (Event Key
k [Modifier]
ms) = Key -> [Modifier] -> Event
Event Key
k ([Modifier] -> Event) -> [Modifier] -> Event
forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Modifier]
forall a. Eq a => [a] -> [a]
nub ([Modifier] -> [Modifier]) -> [Modifier] -> [Modifier]
forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Modifier]
forall a. Ord a => [a] -> [a]
sort (Modifier
MShiftModifier -> [Modifier] -> [Modifier]
forall a. a -> [a] -> [a]
:[Modifier]
ms)

ctrl :: Event -> Event
ctrl (Event Key
k [Modifier]
ms) = Key -> [Modifier] -> Event
Event Key
k ([Modifier] -> Event) -> [Modifier] -> Event
forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Modifier]
forall a. Eq a => [a] -> [a]
nub ([Modifier] -> [Modifier]) -> [Modifier] -> [Modifier]
forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Modifier]
forall a. Ord a => [a] -> [a]
sort (Modifier
MCtrlModifier -> [Modifier] -> [Modifier]
forall a. a -> [a] -> [a]
:[Modifier]
ms)

meta :: Event -> Event
meta (Event Key
k [Modifier]
ms) = Key -> [Modifier] -> Event
Event Key
k ([Modifier] -> Event) -> [Modifier] -> Event
forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Modifier]
forall a. Eq a => [a] -> [a]
nub ([Modifier] -> [Modifier]) -> [Modifier] -> [Modifier]
forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Modifier]
forall a. Ord a => [a] -> [a]
sort (Modifier
MMetaModifier -> [Modifier] -> [Modifier]
forall a. a -> [a] -> [a]
:[Modifier]
ms)

super :: Event -> Event
super (Event Key
k [Modifier]
ms) = Key -> [Modifier] -> Event
Event Key
k ([Modifier] -> Event) -> [Modifier] -> Event
forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Modifier]
forall a. Eq a => [a] -> [a]
nub ([Modifier] -> [Modifier]) -> [Modifier] -> [Modifier]
forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Modifier]
forall a. Ord a => [a] -> [a]
sort (Modifier
MSuperModifier -> [Modifier] -> [Modifier]
forall a. a -> [a] -> [a]
:[Modifier]
ms)

hyper :: Event -> Event
hyper (Event Key
k [Modifier]
ms) = Key -> [Modifier] -> Event
Event Key
k ([Modifier] -> Event) -> [Modifier] -> Event
forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Modifier]
forall a. Eq a => [a] -> [a]
nub ([Modifier] -> [Modifier]) -> [Modifier] -> [Modifier]
forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Modifier]
forall a. Ord a => [a] -> [a]
sort (Modifier
MHyperModifier -> [Modifier] -> [Modifier]
forall a. a -> [a] -> [a]
:[Modifier]
ms)

char :: Char -> Event
char :: Char -> Event
char Char
'\t' = Key -> [Modifier] -> Event
Event Key
KTab []
char Char
'\r' = Key -> [Modifier] -> Event
Event Key
KEnter []
char Char
'\n' = Key -> [Modifier] -> Event
Event Key
KEnter []
char Char
c = Key -> [Modifier] -> Event
Event (Char -> Key
KASCII Char
c) []

ctrlCh :: Char -> Event
ctrlCh :: Char -> Event
ctrlCh = Event -> Event
ctrl (Event -> Event) -> (Char -> Event) -> Char -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Event
char

metaCh :: Char -> Event
metaCh :: Char -> Event
metaCh = Event -> Event
meta (Event -> Event) -> (Char -> Event) -> Char -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Event
char

hyperCh :: Char -> Event
hyperCh :: Char -> Event
hyperCh = Event -> Event
hyper (Event -> Event) -> (Char -> Event) -> Char -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Event
char

-- | @optMod f ev@ produces a 'MonadInteract' that consumes @ev@ or @f ev@
optMod ::(Fail.MonadFail m, MonadInteract m w Event) => (Event -> Event) -> Event -> m Event
optMod :: (Event -> Event) -> Event -> m Event
optMod Event -> Event
f Event
ev = [Event] -> m Event
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event, MonadFail m) =>
[event] -> m event
oneOf [Event
ev, Event -> Event
f Event
ev]

-- | Convert a special key into an event
spec :: Key -> Event
spec :: Key -> Event
spec Key
k = Key -> [Modifier] -> Event
Event Key
k []

-- | > p >>! act = p >> 'write' act
(>>!) :: (MonadInteract m Action Event, YiAction a x, Show x) => m b -> a -> m ()
m b
p >>! :: m b -> a -> m ()
>>! a
act = m b
p m b -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m ()
forall (m :: * -> *) ev a x.
(MonadInteract m Action ev, YiAction a x, Show x) =>
a -> m ()
write a
act

-- | > p >>=! act = p >>= 'write' . act
(>>=!) :: (MonadInteract m Action Event, YiAction a x, Show x) => m b -> (b -> a) -> m ()
m b
p >>=! :: m b -> (b -> a) -> m ()
>>=! b -> a
act = m b
p m b -> (b -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m ()
forall (m :: * -> *) ev a x.
(MonadInteract m Action ev, YiAction a x, Show x) =>
a -> m ()
write (a -> m ()) -> (b -> a) -> b -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
act

-- | @ ev ?>> proc = 'event' ev >> proc @
(?>>) :: (MonadInteract m action Event) => Event -> m a -> m a
Event
ev ?>> :: Event -> m a -> m a
?>> m a
proc = Event -> m Event
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
event -> m event
event Event
ev m Event -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
proc

-- | @ ev ?>>! act = 'event' ev >> 'write' act @
(?>>!) :: (MonadInteract m Action Event, YiAction a x, Show x) => Event -> a -> m ()
Event
ev ?>>! :: Event -> a -> m ()
?>>! a
act = Event -> m Event
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
event -> m event
event Event
ev m Event -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m ()
forall (m :: * -> *) ev a x.
(MonadInteract m Action ev, YiAction a x, Show x) =>
a -> m ()
write a
act

-- | @ ev ?*>> proc = 'events' ev >> proc @
(?*>>) :: (MonadInteract m action Event) => [Event] -> m a -> m a
[Event]
ev ?*>> :: [Event] -> m a -> m a
?*>> m a
proc = [Event] -> m [Event]
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
[event] -> m [event]
events [Event]
ev m [Event] -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
proc

-- | @ ev ?*>>! act = 'events' ev >> 'write' act @
(?*>>!) :: (MonadInteract m Action Event, YiAction a x, Show x) => [Event] -> a -> m ()
[Event]
ev ?*>>! :: [Event] -> a -> m ()
?*>>! a
act = [Event] -> m [Event]
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
[event] -> m [event]
events [Event]
ev m [Event] -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m ()
forall (m :: * -> *) ev a x.
(MonadInteract m Action ev, YiAction a x, Show x) =>
a -> m ()
write a
act

infixl 1 >>!
infixl 1 >>=!
infixr 0 ?>>!
infixr 0 ?>>
infixr 0 ?*>>!
infixr 0 ?*>>