System/Console/Haskeline/Key.hs

    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 (Eq,Ord)

    instance Show Key where
        show (Key modifier base)
            | modifier == noModifier = show base
            | otherwise = show modifier ++ "-" ++ show base

    data Modifier = Modifier {hasControl, hasMeta, hasShift :: Bool}
                deriving (Eq,Ord)

    instance Show Modifier where
        show m = intercalate "-"
                $ catMaybes [maybeUse hasControl "ctrl"
                            , maybeUse hasMeta "meta"
                            , maybeUse hasShift "shift"
                            ]
            where
                maybeUse f str = if f m then Just str else Nothing

    noModifier :: Modifier
    noModifier = Modifier False False 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 (Eq, Ord)

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

    simpleKey :: BaseKey -> Key
    simpleKey = Key noModifier

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

    ctrlKey :: Key -> Key
    ctrlKey (Key m bc) = Key m {hasControl = True} bc

    simpleChar, metaChar, ctrlChar :: Char -> Key
    simpleChar = simpleKey . KeyChar
    metaChar = metaKey . simpleChar

    ctrlChar = simpleChar . setControlBits

    setControlBits :: Char -> Char
    setControlBits '?' = toEnum 127
    setControlBits c = toEnum $ fromEnum c .&. complement ctrlBits

    ctrlBits :: Int
    ctrlBits = bit 5 .|. bit 6

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

    parseModifiers :: [String] -> BaseKey -> Key
    parseModifiers strs = Key mods
        where mods = foldl1 (.) (map parseModifier strs) noModifier

    parseModifier :: String -> (Modifier -> Modifier)
    parseModifier str m = case map toLower str of
        "ctrl" -> m {hasControl = True}
        "control" -> m {hasControl = True}
        "meta" -> m {hasMeta = True}
        "shift" -> m {hasShift = True}
        _ -> m

    breakAtDashes :: String -> [String]
    breakAtDashes "" = []
    breakAtDashes str = case break (=='-') str of
        (xs,'-':rest) -> xs : breakAtDashes rest
        (xs,_) -> [xs]

    parseKey :: String -> Maybe Key
    parseKey str = fmap canonicalizeKey $
        case reverse (breakAtDashes str) of
            [ks] -> liftM simpleKey (parseBaseKey ks)
            ks:ms -> liftM (parseModifiers ms) (parseBaseKey ks)
            [] -> Nothing

    parseBaseKey :: String -> Maybe BaseKey
    parseBaseKey ks = lookup (map toLower ks) specialKeys
                    `mplus` parseFunctionKey ks
                    `mplus` parseKeyChar ks
        where
            parseKeyChar [c] | isPrint c = Just (KeyChar c)
            parseKeyChar _ = Nothing

            parseFunctionKey (f:ns) | f `elem` "fF" = case reads ns of
                [(n,"")]    -> Just (FunKey n)
                _           -> Nothing
            parseFunctionKey _ = Nothing

    canonicalizeKey :: Key -> Key
    canonicalizeKey (Key m (KeyChar c))
        | hasControl m = Key m {hasControl = False}
                            (KeyChar (setControlBits c))
        | hasShift m = Key m {hasShift = False} (KeyChar (toUpper c))
    canonicalizeKey k = k