gale client

root / KeyName.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
{-# LANGUAGE PatternGuards #-}
module KeyName(
    stringToKeys,
    keyCanon,
    keysToString,
    showKeyInfo,
    buildKeyTable,
    getKeyHelpTable
    ) where

import Data.Char
import ConfigFile
import GenUtil
import KeyHelpTable
import Data.List
import Screen(Key(..))

stringToKeys :: String -> [Key]
stringToKeys "" = []
stringToKeys ('\\':'x':a:b:cs) = (dh [a,b]) : stringToKeys cs  where
    dh x = case readHex x of
        Nothing -> KeyUnknown 0
        Just k -> KeyChar (chr k)
--stringToKeys ('<':c:'-':x:'>':cs) | c `elem` "cC" = KeyChar (ord (toLower x) - 0x40) : stringToKeys cs
stringToKeys ('<':cs) = let (n,r) = span (/= '>') cs in
     case lookup ((map toLower $ filter (not . isSpace) n)) ftl of
        Just k -> k
        Nothing -> KeyUnknown 0
      : stringToKeys (drop 1 r)
stringToKeys (c:cs) = KeyChar c : stringToKeys cs


namedKeyTableInt = [
    ("NUL",0),
    ("Backspace",8),
    ("BS",8),
    ("Tab",9),
    ("Enter",13),
    ("Enter",10),
    ("NL",10),
    ("CR",13),
    ("Return",13),
    ("ESC",27),
    ("Space",32),
    ("LT",60),
    ("Backslash",92),
    ("SingleQuote",39),
    ("DoubleQuote",34),
    ("Bar",124),
    ("Backspace",127)
    ]

namedKeyTableKey = [
    ("Up",KeyUp),
    ("Down",KeyDown),
    ("Left",KeyLeft),
    ("Right",KeyRight),
    ("Help",KeyHelp),
    ("Undo",KeyUndo),
    ("Insert",KeyIC),
    ("Home",KeyHome),
    ("End",KeyEnd),
    ("PageUp",KeyPPage),
    ("PageDown",KeyNPage),
    ("Delete",KeyDC),
    ("Enter",KeyEnter),
    ("Print",KeyPrint),
    ("Backspace",KeyBackspace)
    ]


fTable = map (\n -> ('F':show n,KeyF n)) [0..31]

cTable = map (\n -> ("C-" ++ [chr (n + 64)], KeyChar (chr n))) [0..31]

ft,ftl :: [(String,Key)]
ft = fTable ++ namedKeyTableKey ++ map (\(x,y) -> (x, KeyChar (chr y))) namedKeyTableInt ++ cTable
ftl = map (\(x,y) -> (map toLower x,y)) ft

kg :: [[Key]]
kg = transitiveGroup $ map (snub . map snd) (groupBy (\(x,_) (y,_) -> x == y)
        (sort ftl))

lkg :: Key -> [Key]
lkg k = case lookup k kgm of
        Just g -> g
        Nothing -> [k]
kgm = concatMap (\xs -> map (\x -> (x,xs)) xs) kg

transitiveGroup :: Eq a => [[a]] -> [[a]]
transitiveGroup gs = tg [] gs where
    tg x [] = x
    tg gs (g:rg) = tg (f gs g) rg
    f [] g = [g]
    f (x:xs) g | isConjoint g x = nub (x ++ g):xs
    f (x:xs) g = x:f xs g

showKeyInfo :: String
showKeyInfo = unlines $ (buildTableRL $ map (\(x,y) -> (x,show y)) ft) ++ sort (map (show . sort) kg)


keyCanon :: Key -> Key
keyCanon k | ((y:_):_) <- [z| z <- kg, k `elem` z] = y
keyCanon k = k

keysToString ks = concatMap ck ks where
    ck c | (x:_) <- [n| (n,k) <- ft, k == c] = '<' : (x ++ ">")
    ck (KeyChar c) | ord c >= 0x80 && ord c < 0xa0 = "<" ++ show c ++ ">"
    ck (KeyChar c) = [c]
    ck k = "<KeyUnknown:" ++ show k ++ ">"


type Action = String



buildKeyTable :: IO [(Key,Action)]
buildKeyTable = do
    cl <- configLookupList "bind"
    let fl = concatMap ((\x -> do (a:b:_) <- return x ; return (a,b)) . words) cl
    return  (concatMap mk fl) where
        mk (k,a) | (k:_) <- stringToKeys k = map (rtup a) (lkg k)
        mk _ = []


{-# NOTINLINE getKeyHelpTable #-}
getKeyHelpTable :: (Int,Int) -> IO String
getKeyHelpTable (_,_) = buildKeyTable >>= \kt -> let
    tl = concatMap f (keyHelpTable gk)
    f (Right (x,y)) = [(x,y)]
    f (Left x) = [("",""),(x ++ ":","")]
    gk :: String -> String
    gk s = maybe "" id $ lookup s m
    m :: [(String,String)]
    m = [ (fst (head xs),ks (snub (snds xs))) | xs <- groupFst (sort [ (y,x) | (x,y) <- kt])]
    ks ks = concatInter ", " (snub $ map (\x -> keysToString [x]) ks)

      in return $ unlines (bTableRL tl)

bTableRL :: [(String,String)] -> [String]
bTableRL ps = map f ps where
    f ("","") = ""
    f (x,"") = x
    f ("",y) = y
    f (x,y) = replicate (bs - length x) ' ' ++ x ++ replicate 4 ' ' ++ y
    bs = maximum (map (length . fst) [p | p <- ps, not (null (snd p))])