module System.Console.Haskeline.Key(Key(..),
Modifier(..),
BaseKey(..),
noModifier,
simpleKey,
simpleChar,
metaChar,
ctrlChar,
metaKey,
ctrlKey,
parseKey
) where
import Data.Char
import Control.Monad
import Data.Maybe
import Data.Bits
data Key = Key Modifier BaseKey
deriving (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,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,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)
data Modifier = Modifier {Modifier -> Bool
hasControl, Modifier -> Bool
hasMeta, Modifier -> Bool
hasShift :: Bool}
deriving (Modifier -> Modifier -> Bool
(Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Bool) -> Eq Modifier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Modifier -> Modifier -> Bool
$c/= :: Modifier -> Modifier -> Bool
== :: Modifier -> Modifier -> Bool
$c== :: Modifier -> Modifier -> Bool
Eq,Eq Modifier
Eq Modifier =>
(Modifier -> Modifier -> Ordering)
-> (Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Modifier)
-> (Modifier -> Modifier -> Modifier)
-> Ord Modifier
Modifier -> Modifier -> Bool
Modifier -> Modifier -> Ordering
Modifier -> Modifier -> Modifier
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 :: Modifier -> Modifier -> Modifier
$cmin :: Modifier -> Modifier -> Modifier
max :: Modifier -> Modifier -> Modifier
$cmax :: Modifier -> Modifier -> Modifier
>= :: Modifier -> Modifier -> Bool
$c>= :: Modifier -> Modifier -> Bool
> :: Modifier -> Modifier -> Bool
$c> :: Modifier -> Modifier -> Bool
<= :: Modifier -> Modifier -> Bool
$c<= :: Modifier -> Modifier -> Bool
< :: Modifier -> Modifier -> Bool
$c< :: Modifier -> Modifier -> Bool
compare :: Modifier -> Modifier -> Ordering
$ccompare :: Modifier -> Modifier -> Ordering
$cp1Ord :: Eq Modifier
Ord)
instance Show Modifier where
show :: Modifier -> String
show m :: Modifier
m = [String] -> String
forall a. Show a => a -> String
show ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [(Modifier -> Bool) -> String -> Maybe String
forall a. (Modifier -> Bool) -> a -> Maybe a
maybeUse Modifier -> Bool
hasControl "ctrl"
, (Modifier -> Bool) -> String -> Maybe String
forall a. (Modifier -> Bool) -> a -> Maybe a
maybeUse Modifier -> Bool
hasMeta "meta"
, (Modifier -> Bool) -> String -> Maybe String
forall a. (Modifier -> Bool) -> a -> Maybe a
maybeUse Modifier -> Bool
hasShift "shift"
]
where
maybeUse :: (Modifier -> Bool) -> a -> Maybe a
maybeUse f :: Modifier -> Bool
f str :: a
str = if Modifier -> Bool
f Modifier
m then a -> Maybe a
forall a. a -> Maybe a
Just a
str else Maybe a
forall a. Maybe a
Nothing
noModifier :: Modifier
noModifier :: Modifier
noModifier = Bool -> Bool -> Bool -> Modifier
Modifier Bool
False Bool
False Bool
False
data BaseKey = KeyChar Char
| FunKey Int
| LeftKey | RightKey | DownKey | UpKey
| KillLine | Home | End | PageDown | PageUp
| Backspace | Delete
deriving (Int -> BaseKey -> ShowS
[BaseKey] -> ShowS
BaseKey -> String
(Int -> BaseKey -> ShowS)
-> (BaseKey -> String) -> ([BaseKey] -> ShowS) -> Show BaseKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BaseKey] -> ShowS
$cshowList :: [BaseKey] -> ShowS
show :: BaseKey -> String
$cshow :: BaseKey -> String
showsPrec :: Int -> BaseKey -> ShowS
$cshowsPrec :: Int -> BaseKey -> ShowS
Show,BaseKey -> BaseKey -> Bool
(BaseKey -> BaseKey -> Bool)
-> (BaseKey -> BaseKey -> Bool) -> Eq BaseKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BaseKey -> BaseKey -> Bool
$c/= :: BaseKey -> BaseKey -> Bool
== :: BaseKey -> BaseKey -> Bool
$c== :: BaseKey -> BaseKey -> Bool
Eq,Eq BaseKey
Eq BaseKey =>
(BaseKey -> BaseKey -> Ordering)
-> (BaseKey -> BaseKey -> Bool)
-> (BaseKey -> BaseKey -> Bool)
-> (BaseKey -> BaseKey -> Bool)
-> (BaseKey -> BaseKey -> Bool)
-> (BaseKey -> BaseKey -> BaseKey)
-> (BaseKey -> BaseKey -> BaseKey)
-> Ord BaseKey
BaseKey -> BaseKey -> Bool
BaseKey -> BaseKey -> Ordering
BaseKey -> BaseKey -> BaseKey
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 :: BaseKey -> BaseKey -> BaseKey
$cmin :: BaseKey -> BaseKey -> BaseKey
max :: BaseKey -> BaseKey -> BaseKey
$cmax :: BaseKey -> BaseKey -> BaseKey
>= :: BaseKey -> BaseKey -> Bool
$c>= :: BaseKey -> BaseKey -> Bool
> :: BaseKey -> BaseKey -> Bool
$c> :: BaseKey -> BaseKey -> Bool
<= :: BaseKey -> BaseKey -> Bool
$c<= :: BaseKey -> BaseKey -> Bool
< :: BaseKey -> BaseKey -> Bool
$c< :: BaseKey -> BaseKey -> Bool
compare :: BaseKey -> BaseKey -> Ordering
$ccompare :: BaseKey -> BaseKey -> Ordering
$cp1Ord :: Eq BaseKey
Ord)
simpleKey :: BaseKey -> Key
simpleKey :: BaseKey -> Key
simpleKey = Modifier -> BaseKey -> Key
Key Modifier
noModifier
metaKey :: Key -> Key
metaKey :: Key -> Key
metaKey (Key m :: Modifier
m bc :: BaseKey
bc) = Modifier -> BaseKey -> Key
Key Modifier
m {hasMeta :: Bool
hasMeta = Bool
True} BaseKey
bc
ctrlKey :: Key -> Key
ctrlKey :: Key -> Key
ctrlKey (Key m :: Modifier
m bc :: BaseKey
bc) = Modifier -> BaseKey -> Key
Key Modifier
m {hasControl :: Bool
hasControl = Bool
True} BaseKey
bc
simpleChar, metaChar, ctrlChar :: Char -> Key
simpleChar :: Char -> Key
simpleChar = BaseKey -> Key
simpleKey (BaseKey -> Key) -> (Char -> BaseKey) -> Char -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> BaseKey
KeyChar
metaChar :: Char -> Key
metaChar = Key -> Key
metaKey (Key -> Key) -> (Char -> Key) -> Char -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Key
simpleChar
ctrlChar :: Char -> Key
ctrlChar = Char -> Key
simpleChar (Char -> Key) -> (Char -> Char) -> Char -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
setControlBits
setControlBits :: Char -> Char
setControlBits :: Char -> Char
setControlBits '?' = Int -> Char
forall a. Enum a => Int -> a
toEnum 127
setControlBits c :: Char
c = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int -> Int
forall a. Bits a => a -> a
complement (Int -> Int
forall a. Bits a => Int -> a
bit 5 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
forall a. Bits a => Int -> a
bit 6)
specialKeys :: [(String,BaseKey)]
specialKeys :: [(String, BaseKey)]
specialKeys = [("left",BaseKey
LeftKey)
,("right",BaseKey
RightKey)
,("down",BaseKey
DownKey)
,("up",BaseKey
UpKey)
,("killline",BaseKey
KillLine)
,("home",BaseKey
Home)
,("end",BaseKey
End)
,("pagedown",BaseKey
PageDown)
,("pageup",BaseKey
PageUp)
,("backspace",BaseKey
Backspace)
,("delete",BaseKey
Delete)
,("return",Char -> BaseKey
KeyChar '\n')
,("enter",Char -> BaseKey
KeyChar '\n')
,("tab",Char -> BaseKey
KeyChar '\t')
,("esc",Char -> BaseKey
KeyChar '\ESC')
,("escape",Char -> BaseKey
KeyChar '\ESC')
]
parseModifiers :: [String] -> BaseKey -> Key
parseModifiers :: [String] -> BaseKey -> Key
parseModifiers strs :: [String]
strs = Modifier -> BaseKey -> Key
Key Modifier
mods
where mods :: Modifier
mods = ((Modifier -> Modifier)
-> (Modifier -> Modifier) -> Modifier -> Modifier)
-> [Modifier -> Modifier] -> Modifier -> Modifier
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (Modifier -> Modifier)
-> (Modifier -> Modifier) -> Modifier -> Modifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((String -> Modifier -> Modifier)
-> [String] -> [Modifier -> Modifier]
forall a b. (a -> b) -> [a] -> [b]
map String -> Modifier -> Modifier
parseModifier [String]
strs) Modifier
noModifier
parseModifier :: String -> (Modifier -> Modifier)
parseModifier :: String -> Modifier -> Modifier
parseModifier str :: String
str m :: Modifier
m = case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
str of
"ctrl" -> Modifier
m {hasControl :: Bool
hasControl = Bool
True}
"control" -> Modifier
m {hasControl :: Bool
hasControl = Bool
True}
"meta" -> Modifier
m {hasMeta :: Bool
hasMeta = Bool
True}
"shift" -> Modifier
m {hasShift :: Bool
hasShift = Bool
True}
_ -> Modifier
m
breakAtDashes :: String -> [String]
breakAtDashes :: String -> [String]
breakAtDashes "" = []
breakAtDashes str :: String
str = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='-') String
str of
(xs :: String
xs,'-':rest :: String
rest) -> String
xs String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
breakAtDashes String
rest
(xs :: String
xs,_) -> [String
xs]
parseKey :: String -> Maybe Key
parseKey :: String -> Maybe Key
parseKey str :: String
str = (Key -> Key) -> Maybe Key -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> Key
canonicalizeKey (Maybe Key -> Maybe Key) -> Maybe Key -> Maybe Key
forall a b. (a -> b) -> a -> b
$
case [String] -> [String]
forall a. [a] -> [a]
reverse (String -> [String]
breakAtDashes String
str) of
[ks :: String
ks] -> (BaseKey -> Key) -> Maybe BaseKey -> Maybe Key
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM BaseKey -> Key
simpleKey (String -> Maybe BaseKey
parseBaseKey String
ks)
ks :: String
ks:ms :: [String]
ms -> (BaseKey -> Key) -> Maybe BaseKey -> Maybe Key
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([String] -> BaseKey -> Key
parseModifiers [String]
ms) (String -> Maybe BaseKey
parseBaseKey String
ks)
[] -> Maybe Key
forall a. Maybe a
Nothing
parseBaseKey :: String -> Maybe BaseKey
parseBaseKey :: String -> Maybe BaseKey
parseBaseKey ks :: String
ks = String -> [(String, BaseKey)] -> Maybe BaseKey
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
ks) [(String, BaseKey)]
specialKeys
Maybe BaseKey -> Maybe BaseKey -> Maybe BaseKey
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Maybe BaseKey
parseFunctionKey String
ks
Maybe BaseKey -> Maybe BaseKey -> Maybe BaseKey
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Maybe BaseKey
parseKeyChar String
ks
where
parseKeyChar :: String -> Maybe BaseKey
parseKeyChar [c :: Char
c] | Char -> Bool
isPrint Char
c = BaseKey -> Maybe BaseKey
forall a. a -> Maybe a
Just (Char -> BaseKey
KeyChar Char
c)
parseKeyChar _ = Maybe BaseKey
forall a. Maybe a
Nothing
parseFunctionKey :: String -> Maybe BaseKey
parseFunctionKey (f :: Char
f:ns :: String
ns) | Char
f Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "fF" = case ReadS Int
forall a. Read a => ReadS a
reads String
ns of
[(n :: Int
n,"")] -> BaseKey -> Maybe BaseKey
forall a. a -> Maybe a
Just (Int -> BaseKey
FunKey Int
n)
_ -> Maybe BaseKey
forall a. Maybe a
Nothing
parseFunctionKey _ = Maybe BaseKey
forall a. Maybe a
Nothing
canonicalizeKey :: Key -> Key
canonicalizeKey :: Key -> Key
canonicalizeKey (Key m :: Modifier
m (KeyChar c :: Char
c))
| Modifier -> Bool
hasControl Modifier
m = Modifier -> BaseKey -> Key
Key Modifier
m {hasControl :: Bool
hasControl = Bool
False}
(Char -> BaseKey
KeyChar (Char -> Char
setControlBits Char
c))
| Modifier -> Bool
hasShift Modifier
m = Modifier -> BaseKey -> Key
Key Modifier
m {hasShift :: Bool
hasShift = Bool
False} (Char -> BaseKey
KeyChar (Char -> Char
toUpper Char
c))
canonicalizeKey k :: Key
k = Key
k