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