module Hbro.Keys (
Tree(..),
Stroke,
Bindings,
Mode(..),
Status(..),
mode,
strokes,
StatusReader(..),
StatusWriter(..),
StatusState,
mkStroke,
merge,
lookup,
deserialize,
prefixMod,
serialize,
toString,
mkBinding,
toBindings)
where
import Control.Lens
import Control.Monad hiding(forM_)
import Data.Default
import Data.Functor
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as S hiding(foldl)
import Graphics.UI.Gtk.Abstract.Widget
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.UI.Gtk.Gdk.Keys
import Prelude hiding(lookup, mapM_)
data Tree edge leaf = Empty | Leaf leaf | Branch (Map edge (Tree edge leaf)) deriving(Show)
type Stroke = (Set Modifier, String)
type Bindings m = Tree Stroke (m ())
data Mode = Normal | Insert deriving(Eq, Ord)
data Status = Status {
_mode :: Mode,
_strokes :: [Stroke]
}
instance Default Status where
def = Status Normal []
makeLenses ''Status
class StatusReader m where
readStatus :: Simple Lens Status a -> m a
class StatusWriter m where
writeStatus :: Simple Lens Status a -> a -> m ()
type (StatusState m) = (StatusReader m, StatusWriter m)
instance Ord Modifier where
compare x y = compare (show x) (show y)
mkStroke :: [Modifier] -> KeyVal -> Maybe Stroke
mkStroke m k = Just . (S.fromList m,) =<< toString k
toBranch :: Ord a => ([a], b) -> Tree a b
toBranch ([], a) = Leaf a
toBranch ((h:t), a) = Branch (M.fromList [(h, toBranch (t, a))])
merge :: Ord a => Tree a b -> Tree a b -> Tree a b
merge Empty x = x
merge x Empty = x
merge (Leaf _) (Leaf b) = Leaf b
merge (Leaf _) (Branch b) = Branch b
merge (Branch _) (Leaf b) = Leaf b
merge (Branch a) (Branch b) = Branch $ M.unionWith merge a b
lookup :: Ord a => [a] -> Tree a b -> Maybe (Tree a b)
lookup _ Empty = Nothing
lookup [] (Leaf x) = Just (Leaf x)
lookup [] x = Just x
lookup _ (Leaf _) = Nothing
lookup (h:t) (Branch m) = M.lookup h m >>= lookup t
toString :: KeyVal -> Maybe String
toString keyVal = case keyToChar keyVal of
Just ' ' -> Just "<Space>"
Just char -> Just [char]
_ -> case keyName keyVal of
"Caps_Lock" -> Nothing
"Shift_L" -> Nothing
"Shift_R" -> Nothing
"Control_L" -> Nothing
"Control_R" -> Nothing
"Alt_L" -> Nothing
"Alt_R" -> Nothing
"Super_L" -> Nothing
"Super_R" -> Nothing
"Menu" -> Nothing
"ISO_Level3_Shift" -> Nothing
"dead_circumflex" -> Just "^"
"dead_diaeresis" -> Just "ยจ"
x -> Just ('<':x ++ ">")
serialize :: Stroke -> String
serialize (m, k) = S.foldr (++) "" (S.map serializeMod m) ++ k
serializeMod :: Modifier -> String
serializeMod Control = "C-"
serializeMod Alt = "M-"
serializeMod _ = ""
deserialize :: String -> Maybe [Stroke]
deserialize "" = Just []
deserialize (' ':t) = deserialize t
deserialize ('C':'-':t) = prefixMod Control =<< deserialize t
deserialize ('M':'-':t) = prefixMod Alt =<< deserialize t
deserialize (k:' ':t) = prepend k <$> deserialize t
deserialize (k:t) = prefixVal k =<< deserialize t
prefixMod :: Modifier -> [Stroke] -> Maybe [Stroke]
prefixMod modifier ((m, keys):t) = Just ((S.insert modifier m, keys):t)
prefixMod _ _ = Nothing
prefixVal :: Char -> [Stroke] -> Maybe [Stroke]
prefixVal k [] = Just [(S.empty, [k])]
prefixVal k ((modifiers, keys):t)
| S.null modifiers = Just ((modifiers, k:keys):t)
| otherwise = Nothing
prepend :: Char -> [Stroke] -> [Stroke]
prepend k x = (S.empty, [k]):x
mkBinding :: String -> m () -> Maybe (Bindings m)
mkBinding keys action = toBranch . (, action) <$> deserialize keys
toBindings :: [(String, m ())] -> Bindings m
toBindings = foldl merge Empty . catMaybes . map (\(a, b) -> mkBinding a b)