module System.Console.Haskeline.Key(Key(..),
            Modifier(..),
            BaseKey(..),
            noModifier,
            simpleKey,
            simpleChar,
            metaChar,
            ctrlChar,
            metaKey,
            ctrlKey,
            parseKey
            ) where

import Data.Bits
import Data.Char
import Data.Maybe
import Data.List (intercalate)
import Control.Monad

data Key = Key Modifier BaseKey
            deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
/= :: 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
$ccompare :: Key -> Key -> Ordering
compare :: Key -> Key -> Ordering
$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
>= :: Key -> Key -> Bool
$cmax :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
min :: Key -> Key -> Key
Ord)

instance Show Key where
    show :: Key -> [Char]
show (Key Modifier
modifier BaseKey
base)
        | Modifier
modifier Modifier -> Modifier -> Bool
forall a. Eq a => a -> a -> Bool
== Modifier
noModifier = BaseKey -> [Char]
forall a. Show a => a -> [Char]
show BaseKey
base
        | Bool
otherwise = Modifier -> [Char]
forall a. Show a => a -> [Char]
show Modifier
modifier [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ BaseKey -> [Char]
forall a. Show a => a -> [Char]
show BaseKey
base

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
$c== :: Modifier -> Modifier -> Bool
== :: Modifier -> Modifier -> Bool
$c/= :: Modifier -> Modifier -> Bool
/= :: 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
$ccompare :: Modifier -> Modifier -> Ordering
compare :: Modifier -> Modifier -> Ordering
$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
>= :: Modifier -> Modifier -> Bool
$cmax :: Modifier -> Modifier -> Modifier
max :: Modifier -> Modifier -> Modifier
$cmin :: Modifier -> Modifier -> Modifier
min :: Modifier -> Modifier -> Modifier
Ord)

instance Show Modifier where
    show :: Modifier -> [Char]
show Modifier
m = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-"
            ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes [(Modifier -> Bool) -> [Char] -> Maybe [Char]
forall {a}. (Modifier -> Bool) -> a -> Maybe a
maybeUse Modifier -> Bool
hasControl [Char]
"ctrl"
                        , (Modifier -> Bool) -> [Char] -> Maybe [Char]
forall {a}. (Modifier -> Bool) -> a -> Maybe a
maybeUse Modifier -> Bool
hasMeta [Char]
"meta"
                        , (Modifier -> Bool) -> [Char] -> Maybe [Char]
forall {a}. (Modifier -> Bool) -> a -> Maybe a
maybeUse Modifier -> Bool
hasShift [Char]
"shift"
                        ]
        where
            maybeUse :: (Modifier -> Bool) -> a -> Maybe a
maybeUse Modifier -> Bool
f 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

-- Note: a few of these aren't really keys (e.g., KillLine),
-- but they provide useful enough binding points to include.
data BaseKey = KeyChar Char
             | FunKey Int
             | LeftKey | RightKey | DownKey | UpKey
             | KillLine | Home | End | PageDown | PageUp
             | Backspace | Delete
             | SearchReverse | SearchForward
            deriving (BaseKey -> BaseKey -> Bool
(BaseKey -> BaseKey -> Bool)
-> (BaseKey -> BaseKey -> Bool) -> Eq BaseKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BaseKey -> BaseKey -> Bool
== :: BaseKey -> BaseKey -> Bool
$c/= :: BaseKey -> BaseKey -> Bool
/= :: 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
$ccompare :: BaseKey -> BaseKey -> Ordering
compare :: BaseKey -> BaseKey -> Ordering
$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
>= :: BaseKey -> BaseKey -> Bool
$cmax :: BaseKey -> BaseKey -> BaseKey
max :: BaseKey -> BaseKey -> BaseKey
$cmin :: BaseKey -> BaseKey -> BaseKey
min :: BaseKey -> BaseKey -> BaseKey
Ord)

instance Show BaseKey where
    show :: BaseKey -> [Char]
show (KeyChar Char
'\n') = [Char]
"Return"
    show (KeyChar Char
'\t') = [Char]
"Tab"
    show (KeyChar Char
'\ESC') = [Char]
"Esc"
    show (KeyChar Char
c)
        | Char -> Bool
isPrint Char
c = [Char
c]
        | Char -> Bool
isPrint Char
unCtrld = [Char]
"ctrl-" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
unCtrld]
        | Bool
otherwise = Char -> [Char]
forall a. Show a => a -> [Char]
show Char
c
      where
        unCtrld :: Char
unCtrld = Int -> Char
forall a. Enum a => Int -> a
toEnum (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
ctrlBits)
    show (FunKey Int
n) = Char
'f' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
    show BaseKey
LeftKey = [Char]
"Left"
    show BaseKey
RightKey = [Char]
"Right"
    show BaseKey
DownKey = [Char]
"Down"
    show BaseKey
UpKey = [Char]
"Up"
    show BaseKey
KillLine = [Char]
"KillLine"
    show BaseKey
Home = [Char]
"Home"
    show BaseKey
End = [Char]
"End"
    show BaseKey
PageDown = [Char]
"PageDown"
    show BaseKey
PageUp = [Char]
"PageUp"
    show BaseKey
Backspace = [Char]
"Backspace"
    show BaseKey
Delete = [Char]
"Delete"
    show BaseKey
SearchReverse = [Char]
"SearchReverse"
    show BaseKey
SearchForward = [Char]
"SearchForward"

simpleKey :: BaseKey -> Key
simpleKey :: BaseKey -> Key
simpleKey = Modifier -> BaseKey -> Key
Key Modifier
noModifier

metaKey :: Key -> Key
metaKey :: Key -> Key
metaKey (Key Modifier
m BaseKey
bc) = Modifier -> BaseKey -> Key
Key Modifier
m {hasMeta :: Bool
hasMeta = Bool
True} BaseKey
bc

ctrlKey :: Key -> Key
ctrlKey :: Key -> Key
ctrlKey (Key Modifier
m 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 Char
'?' = Int -> Char
forall a. Enum a => Int -> a
toEnum Int
127
setControlBits 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
ctrlBits

ctrlBits :: Int
ctrlBits :: Int
ctrlBits = Int -> Int
forall a. Bits a => Int -> a
bit Int
5 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
forall a. Bits a => Int -> a
bit Int
6

specialKeys :: [(String,BaseKey)]
specialKeys :: [([Char], BaseKey)]
specialKeys = [([Char]
"left",BaseKey
LeftKey)
              ,([Char]
"right",BaseKey
RightKey)
              ,([Char]
"down",BaseKey
DownKey)
              ,([Char]
"up",BaseKey
UpKey)
              ,([Char]
"killline",BaseKey
KillLine)
              ,([Char]
"home",BaseKey
Home)
              ,([Char]
"end",BaseKey
End)
              ,([Char]
"pagedown",BaseKey
PageDown)
              ,([Char]
"pageup",BaseKey
PageUp)
              ,([Char]
"backspace",BaseKey
Backspace)
              ,([Char]
"delete",BaseKey
Delete)
              ,([Char]
"return",Char -> BaseKey
KeyChar Char
'\n')
              ,([Char]
"enter",Char -> BaseKey
KeyChar Char
'\n')
              ,([Char]
"tab",Char -> BaseKey
KeyChar Char
'\t')
              ,([Char]
"esc",Char -> BaseKey
KeyChar Char
'\ESC')
              ,([Char]
"escape",Char -> BaseKey
KeyChar Char
'\ESC')
              ,([Char]
"reversesearchhistory",BaseKey
SearchReverse)
              ,([Char]
"forwardsearchhistory",BaseKey
SearchForward)
              ]

parseModifiers :: [String] -> BaseKey -> Key
parseModifiers :: [[Char]] -> BaseKey -> Key
parseModifiers [[Char]]
strs = Modifier -> BaseKey -> Key
Key Modifier
mods
    where mods :: Modifier
mods = ((Modifier -> Modifier)
 -> (Modifier -> Modifier) -> Modifier -> Modifier)
-> [Modifier -> Modifier] -> Modifier -> Modifier
forall a. (a -> a -> a) -> [a] -> a
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
(.) (([Char] -> Modifier -> Modifier)
-> [[Char]] -> [Modifier -> Modifier]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Modifier -> Modifier
parseModifier [[Char]]
strs) Modifier
noModifier

parseModifier :: String -> (Modifier -> Modifier)
parseModifier :: [Char] -> Modifier -> Modifier
parseModifier [Char]
str Modifier
m = case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
str of
    [Char]
"ctrl" -> Modifier
m {hasControl :: Bool
hasControl = Bool
True}
    [Char]
"control" -> Modifier
m {hasControl :: Bool
hasControl = Bool
True}
    [Char]
"meta" -> Modifier
m {hasMeta :: Bool
hasMeta = Bool
True}
    [Char]
"shift" -> Modifier
m {hasShift :: Bool
hasShift = Bool
True}
    [Char]
_ -> Modifier
m

breakAtDashes :: String -> [String]
breakAtDashes :: [Char] -> [[Char]]
breakAtDashes [Char]
"" = []
breakAtDashes [Char]
str = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-') [Char]
str of
    ([Char]
xs,Char
'-':[Char]
rest) -> [Char]
xs [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
breakAtDashes [Char]
rest
    ([Char]
xs,[Char]
_) -> [[Char]
xs]

parseKey :: String -> Maybe Key
parseKey :: [Char] -> Maybe Key
parseKey [Char]
str = (Key -> Key) -> Maybe Key -> Maybe Key
forall a b. (a -> b) -> Maybe a -> Maybe b
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 [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([Char] -> [[Char]]
breakAtDashes [Char]
str) of
        [[Char]
ks] -> (BaseKey -> Key) -> Maybe BaseKey -> Maybe Key
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM BaseKey -> Key
simpleKey ([Char] -> Maybe BaseKey
parseBaseKey [Char]
ks)
        [Char]
ks:[[Char]]
ms -> (BaseKey -> Key) -> Maybe BaseKey -> Maybe Key
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([[Char]] -> BaseKey -> Key
parseModifiers [[Char]]
ms) ([Char] -> Maybe BaseKey
parseBaseKey [Char]
ks)
        [] -> Maybe Key
forall a. Maybe a
Nothing

parseBaseKey :: String -> Maybe BaseKey
parseBaseKey :: [Char] -> Maybe BaseKey
parseBaseKey [Char]
ks = [Char] -> [([Char], 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 [Char]
ks) [([Char], BaseKey)]
specialKeys
                Maybe BaseKey -> Maybe BaseKey -> Maybe BaseKey
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [Char] -> Maybe BaseKey
parseFunctionKey [Char]
ks
                Maybe BaseKey -> Maybe BaseKey -> Maybe BaseKey
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [Char] -> Maybe BaseKey
parseKeyChar [Char]
ks
    where
        parseKeyChar :: [Char] -> Maybe BaseKey
parseKeyChar [Char
c] | Char -> Bool
isPrint Char
c = BaseKey -> Maybe BaseKey
forall a. a -> Maybe a
Just (Char -> BaseKey
KeyChar Char
c)
        parseKeyChar [Char]
_ = Maybe BaseKey
forall a. Maybe a
Nothing

        parseFunctionKey :: [Char] -> Maybe BaseKey
parseFunctionKey (Char
f:[Char]
ns) | Char
f Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"fF" = case ReadS Int
forall a. Read a => ReadS a
reads [Char]
ns of
            [(Int
n,[Char]
"")]    -> BaseKey -> Maybe BaseKey
forall a. a -> Maybe a
Just (Int -> BaseKey
FunKey Int
n)
            [(Int, [Char])]
_           -> Maybe BaseKey
forall a. Maybe a
Nothing
        parseFunctionKey [Char]
_ = Maybe BaseKey
forall a. Maybe a
Nothing

canonicalizeKey :: Key -> Key
canonicalizeKey :: Key -> Key
canonicalizeKey (Key Modifier
m (KeyChar 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 Key
k = Key
k