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
/= :: 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)

instance Show Key where
    show :: Key -> String
show (Key Modifier
modifier BaseKey
base)
        | Modifier
modifier Modifier -> Modifier -> Bool
forall a. Eq a => a -> a -> Bool
== Modifier
noModifier = BaseKey -> String
forall a. Show a => a -> String
show BaseKey
base
        | Bool
otherwise = Modifier -> String
forall a. Show a => a -> String
show Modifier
modifier String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ BaseKey -> String
forall a. Show a => a -> String
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
/= :: 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 Modifier
m = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-"
            ([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 String
"ctrl"
                        , (Modifier -> Bool) -> String -> Maybe String
forall a. (Modifier -> Bool) -> a -> Maybe a
maybeUse Modifier -> Bool
hasMeta String
"meta"
                        , (Modifier -> Bool) -> String -> Maybe String
forall a. (Modifier -> Bool) -> a -> Maybe a
maybeUse Modifier -> Bool
hasShift String
"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
/= :: 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)

instance Show BaseKey where
    show :: BaseKey -> String
show (KeyChar Char
'\n') = String
"Return"
    show (KeyChar Char
'\t') = String
"Tab"
    show (KeyChar Char
'\ESC') = String
"Esc"
    show (KeyChar Char
c)
        | Char -> Bool
isPrint Char
c = [Char
c]
        | Char -> Bool
isPrint Char
unCtrld = String
"ctrl-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
unCtrld]
        | Bool
otherwise = Char -> String
forall a. Show a => a -> String
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 -> String
forall a. Show a => a -> String
show Int
n
    show BaseKey
LeftKey = String
"Left"
    show BaseKey
RightKey = String
"Right"
    show BaseKey
DownKey = String
"Down"
    show BaseKey
UpKey = String
"Up"
    show BaseKey
KillLine = String
"KillLine"
    show BaseKey
Home = String
"Home"
    show BaseKey
End = String
"End"
    show BaseKey
PageDown = String
"PageDown"
    show BaseKey
PageUp = String
"PageUp"
    show BaseKey
Backspace = String
"Backspace"
    show BaseKey
Delete = String
"Delete"
    show BaseKey
SearchReverse = String
"SearchReverse"
    show BaseKey
SearchForward = String
"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 :: [(String, BaseKey)]
specialKeys = [(String
"left",BaseKey
LeftKey)
              ,(String
"right",BaseKey
RightKey)
              ,(String
"down",BaseKey
DownKey)
              ,(String
"up",BaseKey
UpKey)
              ,(String
"killline",BaseKey
KillLine)
              ,(String
"home",BaseKey
Home)
              ,(String
"end",BaseKey
End)
              ,(String
"pagedown",BaseKey
PageDown)
              ,(String
"pageup",BaseKey
PageUp)
              ,(String
"backspace",BaseKey
Backspace)
              ,(String
"delete",BaseKey
Delete)
              ,(String
"return",Char -> BaseKey
KeyChar Char
'\n')
              ,(String
"enter",Char -> BaseKey
KeyChar Char
'\n')
              ,(String
"tab",Char -> BaseKey
KeyChar Char
'\t')
              ,(String
"esc",Char -> BaseKey
KeyChar Char
'\ESC')
              ,(String
"escape",Char -> BaseKey
KeyChar Char
'\ESC')
              ,(String
"reversesearchhistory",BaseKey
SearchReverse)
              ,(String
"forwardsearchhistory",BaseKey
SearchForward)
              ]

parseModifiers :: [String] -> BaseKey -> Key
parseModifiers :: [String] -> BaseKey -> Key
parseModifiers [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 String
str Modifier
m = case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
str of
    String
"ctrl" -> Modifier
m {hasControl :: Bool
hasControl = Bool
True}
    String
"control" -> Modifier
m {hasControl :: Bool
hasControl = Bool
True}
    String
"meta" -> Modifier
m {hasMeta :: Bool
hasMeta = Bool
True}
    String
"shift" -> Modifier
m {hasShift :: Bool
hasShift = Bool
True}
    String
_ -> Modifier
m

breakAtDashes :: String -> [String]
breakAtDashes :: String -> [String]
breakAtDashes String
"" = []
breakAtDashes 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
==Char
'-') String
str of
    (String
xs,Char
'-':String
rest) -> String
xs String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
breakAtDashes String
rest
    (String
xs,String
_) -> [String
xs]

parseKey :: String -> Maybe Key
parseKey :: String -> Maybe Key
parseKey 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
        [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)
        String
ks:[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 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 [Char
c] | Char -> Bool
isPrint Char
c = BaseKey -> Maybe BaseKey
forall a. a -> Maybe a
Just (Char -> BaseKey
KeyChar Char
c)
        parseKeyChar String
_ = Maybe BaseKey
forall a. Maybe a
Nothing

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