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 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 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

data BaseKey = KeyChar Char
             | FunKey Int
             | LeftKey | RightKey | DownKey | UpKey
             -- TODO: is KillLine really a key?
             | 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 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 -> 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')
              ]

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