{-# language StandaloneDeriving, FlexibleInstances, MagicHash, OverloadedStrings,PatternSynonyms, BlockArguments, ViewPatterns #-}
module Keyboard (module Keyboard, XenoException(..)) where
import Text.Printf
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.Map (Map, (!))
import Data.Word (Word8)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as Text
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Char (toLower)
import XML
import Data.String

newtype Id a = Id {Id a -> ByteString
unId :: ByteString}
instance IsString (Id a) where fromString :: String -> Id a
fromString = ByteString -> Id a
forall a. ByteString -> Id a
Id (ByteString -> Id a) -> (String -> ByteString) -> String -> Id a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack
newtype Ix a = Ix {Ix a -> Word
unIx :: Word}
newtype Group = Group {Group -> Word
unGroup :: Word}

parse :: ByteString -> Either XenoException Keyboard
parse :: ByteString -> Either XenoException Keyboard
parse = (Node -> Keyboard)
-> Either XenoException Node -> Either XenoException Keyboard
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> Keyboard
forall a. XML a => Node -> a
fromXML (Either XenoException Node -> Either XenoException Keyboard)
-> (ByteString -> Either XenoException Node)
-> ByteString
-> Either XenoException Keyboard
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either XenoException Node
XML.parse

export :: Keyboard -> ByteString
export :: Keyboard -> ByteString
export = String -> ByteString
BS.pack (String -> ByteString)
-> (Keyboard -> String) -> Keyboard -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Keyboard -> String
forall a. XML a => a -> String
toXML

data Keyboard = Keyboard {Keyboard -> Group
keyboard_group :: Group
                         ,Keyboard -> Word
keyboard_id :: Word
                         ,Keyboard -> ByteString
keyboard_name :: ByteString
                         ,Keyboard -> Maybe Word
keyboard_maxout :: Maybe Word
                         ,Keyboard -> Layouts
keyboard_layouts :: Layouts
                         ,Keyboard -> ModifierMap
keyboard_modifierMap :: ModifierMap
                         ,Keyboard -> NonEmpty KeyMapSet
keyboard_keyMapSets :: NonEmpty KeyMapSet
                         ,Keyboard -> [Action]
keyboard_actions :: [Action]
                         ,Keyboard -> [When_Terminator]
keyboard_terminators :: [When_Terminator] }

instance XML Keyboard where
  fromXML :: Node -> Keyboard
fromXML (XML ByteString
"keyboard" Map ByteString ByteString
as [Node]
cs)
    = Keyboard :: Group
-> Word
-> ByteString
-> Maybe Word
-> Layouts
-> ModifierMap
-> NonEmpty KeyMapSet
-> [Action]
-> [When_Terminator]
-> Keyboard
Keyboard {keyboard_group :: Group
keyboard_group = Group -> ByteString -> Map ByteString Group -> Group
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Word -> Group
Group Word
126) ByteString
"group" (Map ByteString Group -> Group) -> Map ByteString Group -> Group
forall a b. (a -> b) -> a -> b
$ (ByteString -> Group)
-> Map ByteString ByteString -> Map ByteString Group
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word -> Group
Group (Word -> Group) -> (ByteString -> Word) -> ByteString -> Group
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Word
forall a. Read a => ByteString -> a
readBS) Map ByteString ByteString
as
               ,keyboard_id :: Word
keyboard_id = Word -> ByteString -> Map ByteString Word -> Word
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Word
1 ByteString
"id" (Map ByteString Word -> Word) -> Map ByteString Word -> Word
forall a b. (a -> b) -> a -> b
$ (ByteString -> Word)
-> Map ByteString ByteString -> Map ByteString Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Word
forall a. Read a => ByteString -> a
readBS) Map ByteString ByteString
as
               ,keyboard_name :: ByteString
keyboard_name = Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"name"
               ,keyboard_maxout :: Maybe Word
keyboard_maxout = (String -> Word
forall a. Read a => String -> a
read (String -> Word) -> (ByteString -> String) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS.unpack) (ByteString -> Word) -> Maybe ByteString -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"maxount" Map ByteString ByteString
as
               ,keyboard_layouts :: Layouts
keyboard_layouts = ByteString -> [Node] -> Layouts
forall c (t :: * -> *).
(XML c, Foldable t) =>
ByteString -> t Node -> c
find# ByteString
"layouts" [Node]
cs
               ,keyboard_modifierMap :: ModifierMap
keyboard_modifierMap = ByteString -> [Node] -> ModifierMap
forall c (t :: * -> *).
(XML c, Foldable t) =>
ByteString -> t Node -> c
find# ByteString
"modifierMap" [Node]
cs
               ,keyboard_keyMapSets :: NonEmpty KeyMapSet
keyboard_keyMapSets = [KeyMapSet] -> NonEmpty KeyMapSet
forall a. [a] -> NonEmpty a
NE.fromList ([KeyMapSet] -> NonEmpty KeyMapSet)
-> [KeyMapSet] -> NonEmpty KeyMapSet
forall a b. (a -> b) -> a -> b
$ ByteString -> [Node] -> [KeyMapSet]
forall b. XML b => ByteString -> [Node] -> [b]
find' ByteString
"keyMapSet" [Node]
cs
               ,keyboard_actions :: [Action]
keyboard_actions = case [Node]
cs [Node] -> ([Node] -> Maybe Node) -> Maybe Node
forall a b. a -> (a -> b) -> b
& (Node -> Bool) -> [Node] -> Maybe Node
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find \ Node
a -> Node -> ByteString
name Node
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"actions" of
                 Maybe Node
Nothing -> []
                 Just (XML ByteString
"actions" Map ByteString ByteString
_ [Node]
cs) -> (Node -> Action) -> [Node] -> [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> Action
forall a. XML a => Node -> a
fromXML [Node]
cs
               ,keyboard_terminators :: [When_Terminator]
keyboard_terminators = case [Node]
cs [Node] -> ([Node] -> Maybe Node) -> Maybe Node
forall a b. a -> (a -> b) -> b
& (Node -> Bool) -> [Node] -> Maybe Node
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find \ Node
a -> Node -> ByteString
name Node
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"terminators" of
                  Maybe Node
Nothing -> []
                  Just (XML ByteString
"terminators" Map ByteString ByteString
_ [Node]
cs) -> (Node -> When_Terminator) -> [Node] -> [When_Terminator]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> When_Terminator
forall a. XML a => Node -> a
fromXML [Node]
cs}
  toXML :: Keyboard -> String
toXML Keyboard
k = String
-> Word
-> Word
-> String
-> String
-> String
-> String
-> String
-> String
-> String
-> String
forall r. PrintfType r => String -> r
printf String
"<keyboard group=\"%d\" id=\"%d\" name=%s %s>\n%s\n%s\n%s%s%s\n</keyboard>"
                   (Group -> Word
unGroup (Group -> Word) -> Group -> Word
forall a b. (a -> b) -> a -> b
$ Keyboard -> Group
keyboard_group Keyboard
k)
                   (Keyboard -> Word
keyboard_id Keyboard
k)
                   (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Keyboard -> ByteString
keyboard_name Keyboard
k)
                   (case Keyboard -> Maybe Word
keyboard_maxout Keyboard
k of
                     Maybe Word
Nothing -> (String
"" :: String)
                     Just Word
i -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"maxout=\"%s\"" (Word -> String
forall a. Show a => a -> String
show Word
i) :: String)
                   (Layouts -> String
forall a. XML a => a -> String
toXML (Layouts -> String) -> Layouts -> String
forall a b. (a -> b) -> a -> b
$ Keyboard -> Layouts
keyboard_layouts Keyboard
k)
                   (ModifierMap -> String
forall a. XML a => a -> String
toXML (ModifierMap -> String) -> ModifierMap -> String
forall a b. (a -> b) -> a -> b
$ Keyboard -> ModifierMap
keyboard_modifierMap Keyboard
k)
                   ([String] -> String
unlines ([String] -> String)
-> (NonEmpty KeyMapSet -> [String]) -> NonEmpty KeyMapSet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyMapSet -> String) -> [KeyMapSet] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KeyMapSet -> String
forall a. XML a => a -> String
toXML ([KeyMapSet] -> [String])
-> (NonEmpty KeyMapSet -> [KeyMapSet])
-> NonEmpty KeyMapSet
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty KeyMapSet -> [KeyMapSet]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty KeyMapSet -> String) -> NonEmpty KeyMapSet -> String
forall a b. (a -> b) -> a -> b
$ Keyboard -> NonEmpty KeyMapSet
keyboard_keyMapSets Keyboard
k)
                   (case Keyboard -> [Action]
keyboard_actions Keyboard
k of
                     [] -> (String
"" :: String)
                     [Action]
as -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\n\t<actions>\n%s\t</actions>" ([String] -> String
unlines ([String] -> String)
-> ([Action] -> [String]) -> [Action] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Action -> String) -> [Action] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Action -> String
forall a. XML a => a -> String
toXML ([Action] -> String) -> [Action] -> String
forall a b. (a -> b) -> a -> b
$ [Action]
as) :: String)
                   (case Keyboard -> [When_Terminator]
keyboard_terminators Keyboard
k of
                     [] -> (String
"" :: String)
                     [When_Terminator]
ts -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\n\t<terminators>\n%s\t</terminators>" ([String] -> String
unlines ([String] -> String)
-> ([When_Terminator] -> [String]) -> [When_Terminator] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (When_Terminator -> String) -> [When_Terminator] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap When_Terminator -> String
forall a. XML a => a -> String
toXML ([When_Terminator] -> String) -> [When_Terminator] -> String
forall a b. (a -> b) -> a -> b
$ [When_Terminator]
ts) :: String)

newtype Layouts = Layouts {Layouts -> NonEmpty Layout
layouts_layouts :: NonEmpty Layout}
instance XML Layouts where
  fromXML :: Node -> Layouts
fromXML (XML ByteString
"layouts" Map ByteString ByteString
as [Node]
cs) = NonEmpty Layout -> Layouts
Layouts (NonEmpty Layout -> Layouts)
-> ([Layout] -> NonEmpty Layout) -> [Layout] -> Layouts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Layout] -> NonEmpty Layout
forall a. [a] -> NonEmpty a
NE.fromList ([Layout] -> Layouts) -> [Layout] -> Layouts
forall a b. (a -> b) -> a -> b
$ ByteString -> [Node] -> [Layout]
forall b. XML b => ByteString -> [Node] -> [b]
find' ByteString
"layout" [Node]
cs
  toXML :: Layouts -> String
toXML (Layouts NonEmpty Layout
ls) = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t<layouts>\n%s\t</layouts>" (String -> String) -> ([Layout] -> String) -> [Layout] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ([Layout] -> [String]) -> [Layout] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Layout -> String) -> [Layout] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Layout -> String
forall a. XML a => a -> String
toXML ([Layout] -> String) -> [Layout] -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty Layout -> [Layout]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Layout
ls
data Layout
  = Layout {Layout -> Word
layout_first :: Word, Layout -> Word
layout_last :: Word
           ,Layout -> Id ModifierMap
layout_modifiers :: Id ModifierMap
           ,Layout -> KeyMapSet_Id
layout_mapSet :: KeyMapSet_Id}
instance XML Layout where
  fromXML :: Node -> Layout
fromXML (XML ByteString
"layout" Map ByteString ByteString
as [Node]
cs)
    = Layout :: Word -> Word -> Id ModifierMap -> KeyMapSet_Id -> Layout
Layout {layout_first :: Word
layout_first = ByteString -> Word
forall a. Read a => ByteString -> a
readBS (ByteString -> Word) -> ByteString -> Word
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"first"
             ,layout_last :: Word
layout_last = ByteString -> Word
forall a. Read a => ByteString -> a
readBS (ByteString -> Word) -> ByteString -> Word
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"last"
             ,layout_modifiers :: Id ModifierMap
layout_modifiers = ByteString -> Id ModifierMap
forall a. ByteString -> Id a
Id (ByteString -> Id ModifierMap) -> ByteString -> Id ModifierMap
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"modifiers"
             ,layout_mapSet :: KeyMapSet_Id
layout_mapSet = ByteString -> KeyMapSet_Id
forall a. Read a => ByteString -> a
readBS (ByteString -> KeyMapSet_Id) -> ByteString -> KeyMapSet_Id
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"mapSet"}
  toXML :: Layout -> String
toXML Layout
l = String -> Word -> Word -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t<layout first=\"%d\" last=\"%d\" modifiers=\"%s\" mapSet=\"%s\" />"
                   (Layout -> Word
layout_first Layout
l)
                   (Layout -> Word
layout_last Layout
l)
                   (ByteString -> String
BS.unpack (ByteString -> String)
-> (Id ModifierMap -> ByteString) -> Id ModifierMap -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id ModifierMap -> ByteString
forall a. Id a -> ByteString
unId (Id ModifierMap -> String) -> Id ModifierMap -> String
forall a b. (a -> b) -> a -> b
$ Layout -> Id ModifierMap
layout_modifiers Layout
l)
                   (KeyMapSet_Id -> String
forall a. Show a => a -> String
show (KeyMapSet_Id -> String) -> KeyMapSet_Id -> String
forall a b. (a -> b) -> a -> b
$ Layout -> KeyMapSet_Id
layout_mapSet Layout
l)

data ModifierMap
  = ModifierMap {ModifierMap -> Id ModifierMap
modifierMap_id :: Id ModifierMap
                ,ModifierMap -> Ix KeyMap
modifierMap_defaultIndex :: Ix KeyMap
                ,ModifierMap -> NonEmpty KeyMapSelect
modifierMap_keyMapSelects :: NonEmpty KeyMapSelect}
instance XML ModifierMap where
  fromXML :: Node -> ModifierMap
fromXML (XML ByteString
"modifierMap" Map ByteString ByteString
as [Node]
cs)
    = ModifierMap :: Id ModifierMap -> Ix KeyMap -> NonEmpty KeyMapSelect -> ModifierMap
ModifierMap {modifierMap_id :: Id ModifierMap
modifierMap_id = ByteString -> Id ModifierMap
forall a. ByteString -> Id a
Id (ByteString -> Id ModifierMap) -> ByteString -> Id ModifierMap
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"id"
                  ,modifierMap_defaultIndex :: Ix KeyMap
modifierMap_defaultIndex = Word -> Ix KeyMap
forall a. Word -> Ix a
Ix (Word -> Ix KeyMap)
-> (ByteString -> Word) -> ByteString -> Ix KeyMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Word
forall a. Read a => ByteString -> a
readBS (ByteString -> Ix KeyMap) -> ByteString -> Ix KeyMap
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"defaultIndex"
                  ,modifierMap_keyMapSelects :: NonEmpty KeyMapSelect
modifierMap_keyMapSelects =  [KeyMapSelect] -> NonEmpty KeyMapSelect
forall a. [a] -> NonEmpty a
NE.fromList ([KeyMapSelect] -> NonEmpty KeyMapSelect)
-> [KeyMapSelect] -> NonEmpty KeyMapSelect
forall a b. (a -> b) -> a -> b
$ ByteString -> [Node] -> [KeyMapSelect]
forall b. XML b => ByteString -> [Node] -> [b]
find' ByteString
"keyMapSelect" [Node]
cs}
  toXML :: ModifierMap -> String
toXML ModifierMap
m = String -> String -> Word -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t<modifierMap id=\"%s\" defaultIndex=\"%d\">\n%s\t</modifierMap>"
                   (ByteString -> String
BS.unpack (ByteString -> String)
-> (Id ModifierMap -> ByteString) -> Id ModifierMap -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id ModifierMap -> ByteString
forall a. Id a -> ByteString
unId (Id ModifierMap -> String) -> Id ModifierMap -> String
forall a b. (a -> b) -> a -> b
$ ModifierMap -> Id ModifierMap
modifierMap_id ModifierMap
m)
                   (Ix KeyMap -> Word
forall a. Ix a -> Word
unIx (Ix KeyMap -> Word) -> Ix KeyMap -> Word
forall a b. (a -> b) -> a -> b
$ ModifierMap -> Ix KeyMap
modifierMap_defaultIndex ModifierMap
m)
                   ([String] -> String
unlines ([String] -> String)
-> (NonEmpty KeyMapSelect -> [String])
-> NonEmpty KeyMapSelect
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyMapSelect -> String) -> [KeyMapSelect] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KeyMapSelect -> String
forall a. XML a => a -> String
toXML ([KeyMapSelect] -> [String])
-> (NonEmpty KeyMapSelect -> [KeyMapSelect])
-> NonEmpty KeyMapSelect
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty KeyMapSelect -> [KeyMapSelect]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty KeyMapSelect -> String)
-> NonEmpty KeyMapSelect -> String
forall a b. (a -> b) -> a -> b
$ ModifierMap -> NonEmpty KeyMapSelect
modifierMap_keyMapSelects ModifierMap
m)

data KeyMapSelect
  = KeyMapSelect {KeyMapSelect -> Ix KeyMap
keyMapSelect_mapIndex :: Ix KeyMap
                 ,KeyMapSelect -> NonEmpty Modifier
keyMapSelect_modifiers :: NonEmpty Modifier }
instance XML KeyMapSelect where
  fromXML :: Node -> KeyMapSelect
fromXML (XML ByteString
"keyMapSelect" Map ByteString ByteString
as [Node]
cs)
    = KeyMapSelect :: Ix KeyMap -> NonEmpty Modifier -> KeyMapSelect
KeyMapSelect {keyMapSelect_mapIndex :: Ix KeyMap
keyMapSelect_mapIndex = Word -> Ix KeyMap
forall a. Word -> Ix a
Ix (Word -> Ix KeyMap)
-> (ByteString -> Word) -> ByteString -> Ix KeyMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Word
forall a. Read a => ByteString -> a
readBS (ByteString -> Ix KeyMap) -> ByteString -> Ix KeyMap
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"mapIndex"
                   ,keyMapSelect_modifiers :: NonEmpty Modifier
keyMapSelect_modifiers = [Modifier] -> NonEmpty Modifier
forall a. [a] -> NonEmpty a
NE.fromList ([Modifier] -> NonEmpty Modifier)
-> [Modifier] -> NonEmpty Modifier
forall a b. (a -> b) -> a -> b
$ ByteString -> [Node] -> [Modifier]
forall b. XML b => ByteString -> [Node] -> [b]
find' ByteString
"modifier" [Node]
cs
    }
  toXML :: KeyMapSelect -> String
toXML KeyMapSelect
kms = String -> Word -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t<keyMapSelect mapIndex=\"%d\">\n%s\t\t</keyMapSelect>"
                     (Ix KeyMap -> Word
forall a. Ix a -> Word
unIx (Ix KeyMap -> Word) -> Ix KeyMap -> Word
forall a b. (a -> b) -> a -> b
$ KeyMapSelect -> Ix KeyMap
keyMapSelect_mapIndex KeyMapSelect
kms)
                     ([String] -> String
unlines ([String] -> String)
-> (NonEmpty Modifier -> [String]) -> NonEmpty Modifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Modifier -> String) -> [Modifier] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Modifier -> String
forall a. XML a => a -> String
toXML ([Modifier] -> [String])
-> (NonEmpty Modifier -> [Modifier])
-> NonEmpty Modifier
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Modifier -> [Modifier]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Modifier -> String) -> NonEmpty Modifier -> String
forall a b. (a -> b) -> a -> b
$ KeyMapSelect -> NonEmpty Modifier
keyMapSelect_modifiers KeyMapSelect
kms)

newtype Modifier = Modifier {Modifier -> ModifierChord
modifier_keys :: ModifierChord}
instance XML Modifier where
  fromXML :: Node -> Modifier
fromXML (XML ByteString
"modifier" Map ByteString ByteString
as [Node]
_) = ModifierChord -> Modifier
Modifier (ModifierChord -> Modifier) -> ModifierChord -> Modifier
forall a b. (a -> b) -> a -> b
$ ByteString -> ModifierChord
parseChord (ByteString -> ModifierChord) -> ByteString -> ModifierChord
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"keys" where
    parseChord :: ByteString -> ModifierChord
    parseChord :: ByteString -> ModifierChord
parseChord (ByteString -> [ByteString]
BS.words -> [ByteString]
c) = Map ModifierKey ModifierStatus -> ModifierChord
ModifierChord (Map ModifierKey ModifierStatus -> ModifierChord)
-> Map ModifierKey ModifierStatus -> ModifierChord
forall a b. (a -> b) -> a -> b
$ [(ModifierKey, ModifierStatus)] -> Map ModifierKey ModifierStatus
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ModifierKey, ModifierStatus)] -> Map ModifierKey ModifierStatus)
-> [(ModifierKey, ModifierStatus)]
-> Map ModifierKey ModifierStatus
forall a b. (a -> b) -> a -> b
$ (ByteString -> (ModifierKey, ModifierStatus))
-> [ByteString] -> [(ModifierKey, ModifierStatus)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> (ModifierKey, ModifierStatus)
parseModifier [ByteString]
c where
      parseModifier :: ByteString -> (ModifierKey, ModifierStatus)
      parseModifier :: ByteString -> (ModifierKey, ModifierStatus)
parseModifier = \case
        (ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"command" -> Just (ByteString -> ModifierStatus
status -> ModifierStatus
s)) -> (ModifierKey
Command, ModifierStatus
s)
        (ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"caps" -> Just (ByteString -> ModifierStatus
status -> ModifierStatus
s)) -> (ModifierKey
Caps, ModifierStatus
s)
        (ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"any" -> Just (ByteString -> (Mod, ModifierStatus)
modifier -> (Mod
m,ModifierStatus
s)) ) -> (Mod -> Side -> ModifierKey
Mod Mod
m Side
Any, ModifierStatus
s)
        (ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"right" -> Just (ByteString -> (Mod, ModifierStatus)
modifier -> (Mod
m,ModifierStatus
s)) ) -> (Mod -> Side -> ModifierKey
Mod Mod
m Side
R, ModifierStatus
s)
        (ByteString -> (Mod, ModifierStatus)
modifier -> (Mod
m , ModifierStatus
s)) -> (Mod -> Side -> ModifierKey
Mod Mod
m Side
L, ModifierStatus
s)
        ByteString
_ -> String -> (ModifierKey, ModifierStatus)
forall a. HasCallStack => String -> a
error String
"parseModifier"
      status :: ByteString -> ModifierStatus
status = \case {ByteString
"" -> ModifierStatus
(:!); ByteString
"?" -> ModifierStatus
(:?); ByteString
_ -> String -> ModifierStatus
forall a. HasCallStack => String -> a
error String
"status"}
      modifier :: ByteString -> (Mod, ModifierStatus)
modifier ((Char -> Char) -> ByteString -> ByteString
BS.map Char -> Char
toLower -> ByteString
m) = case ByteString
m of
        (ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"shift" -> Just (ByteString -> ModifierStatus
status -> ModifierStatus
s)) -> (Mod
Shift , ModifierStatus
s)
        (ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"option" -> Just (ByteString -> ModifierStatus
status -> ModifierStatus
s)) -> (Mod
Option , ModifierStatus
s)
        (ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"control" -> Just (ByteString -> ModifierStatus
status -> ModifierStatus
s)) -> (Mod
Option , ModifierStatus
s)
        ByteString
x -> String -> (Mod, ModifierStatus)
forall a. HasCallStack => String -> a
error (String -> (Mod, ModifierStatus))
-> String -> (Mod, ModifierStatus)
forall a b. (a -> b) -> a -> b
$ String
"modifier " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
x
  toXML :: Modifier -> String
toXML (Modifier ModifierChord
ks) = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t\t<modifier keys=\"%s\" />" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ModifierChord -> String
printChord ModifierChord
ks where
    printChord :: ModifierChord -> String
    printChord :: ModifierChord -> String
printChord (ModifierChord (Map ModifierKey ModifierStatus -> [(ModifierKey, ModifierStatus)]
forall k a. Map k a -> [(k, a)]
Map.toList -> [(ModifierKey, ModifierStatus)]
m)) = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((ModifierKey, ModifierStatus) -> String)
-> [(ModifierKey, ModifierStatus)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ModifierKey
mk,ModifierStatus
s) -> ModifierKey -> String
printKey ModifierKey
mk String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModifierStatus -> String
printStatus ModifierStatus
s)  [(ModifierKey, ModifierStatus)]
m
    printKey :: ModifierKey -> String
printKey = \case
      ModifierKey
Caps -> String
"caps"
      ModifierKey
Command -> String
"command"
      Mod (Mod -> String
forall a. Show a => a -> String
show -> String
md) Side
s -> case Side
s of {Side
L -> String -> String
uncap String
md; Side
R -> String
"right" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
md; Side
Any -> String
"any" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
md}
    uncap :: String -> String
uncap (Char
a:String
as) = Char -> Char
toLower Char
a Char -> String -> String
forall a. a -> [a] -> [a]
: String
as
    printStatus :: ModifierStatus -> String
printStatus = \case {ModifierStatus
(:!) -> String
""; ModifierStatus
(:?) -> String
"?"}
      
newtype ModifierChord = ModifierChord (Map ModifierKey ModifierStatus)
data Mod = Shift | Option | Control deriving (Mod -> Mod -> Bool
(Mod -> Mod -> Bool) -> (Mod -> Mod -> Bool) -> Eq Mod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mod -> Mod -> Bool
$c/= :: Mod -> Mod -> Bool
== :: Mod -> Mod -> Bool
$c== :: Mod -> Mod -> Bool
Eq, Eq Mod
Eq Mod
-> (Mod -> Mod -> Ordering)
-> (Mod -> Mod -> Bool)
-> (Mod -> Mod -> Bool)
-> (Mod -> Mod -> Bool)
-> (Mod -> Mod -> Bool)
-> (Mod -> Mod -> Mod)
-> (Mod -> Mod -> Mod)
-> Ord Mod
Mod -> Mod -> Bool
Mod -> Mod -> Ordering
Mod -> Mod -> Mod
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 :: Mod -> Mod -> Mod
$cmin :: Mod -> Mod -> Mod
max :: Mod -> Mod -> Mod
$cmax :: Mod -> Mod -> Mod
>= :: Mod -> Mod -> Bool
$c>= :: Mod -> Mod -> Bool
> :: Mod -> Mod -> Bool
$c> :: Mod -> Mod -> Bool
<= :: Mod -> Mod -> Bool
$c<= :: Mod -> Mod -> Bool
< :: Mod -> Mod -> Bool
$c< :: Mod -> Mod -> Bool
compare :: Mod -> Mod -> Ordering
$ccompare :: Mod -> Mod -> Ordering
$cp1Ord :: Eq Mod
Ord)
data Side = L | R | Any deriving (Side -> Side -> Bool
(Side -> Side -> Bool) -> (Side -> Side -> Bool) -> Eq Side
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Side -> Side -> Bool
$c/= :: Side -> Side -> Bool
== :: Side -> Side -> Bool
$c== :: Side -> Side -> Bool
Eq,Eq Side
Eq Side
-> (Side -> Side -> Ordering)
-> (Side -> Side -> Bool)
-> (Side -> Side -> Bool)
-> (Side -> Side -> Bool)
-> (Side -> Side -> Bool)
-> (Side -> Side -> Side)
-> (Side -> Side -> Side)
-> Ord Side
Side -> Side -> Bool
Side -> Side -> Ordering
Side -> Side -> Side
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 :: Side -> Side -> Side
$cmin :: Side -> Side -> Side
max :: Side -> Side -> Side
$cmax :: Side -> Side -> Side
>= :: Side -> Side -> Bool
$c>= :: Side -> Side -> Bool
> :: Side -> Side -> Bool
$c> :: Side -> Side -> Bool
<= :: Side -> Side -> Bool
$c<= :: Side -> Side -> Bool
< :: Side -> Side -> Bool
$c< :: Side -> Side -> Bool
compare :: Side -> Side -> Ordering
$ccompare :: Side -> Side -> Ordering
$cp1Ord :: Eq Side
Ord)
instance Semigroup Side where Side
L <> :: Side -> Side -> Side
<> Side
L = Side
L; Side
R <> Side
R = Side
R; Side
_ <> Side
_ = Side
Any
data ModifierKey = Mod Mod Side | Command | Caps deriving (ModifierKey -> ModifierKey -> Bool
(ModifierKey -> ModifierKey -> Bool)
-> (ModifierKey -> ModifierKey -> Bool) -> Eq ModifierKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModifierKey -> ModifierKey -> Bool
$c/= :: ModifierKey -> ModifierKey -> Bool
== :: ModifierKey -> ModifierKey -> Bool
$c== :: ModifierKey -> ModifierKey -> Bool
Eq,Eq ModifierKey
Eq ModifierKey
-> (ModifierKey -> ModifierKey -> Ordering)
-> (ModifierKey -> ModifierKey -> Bool)
-> (ModifierKey -> ModifierKey -> Bool)
-> (ModifierKey -> ModifierKey -> Bool)
-> (ModifierKey -> ModifierKey -> Bool)
-> (ModifierKey -> ModifierKey -> ModifierKey)
-> (ModifierKey -> ModifierKey -> ModifierKey)
-> Ord ModifierKey
ModifierKey -> ModifierKey -> Bool
ModifierKey -> ModifierKey -> Ordering
ModifierKey -> ModifierKey -> ModifierKey
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 :: ModifierKey -> ModifierKey -> ModifierKey
$cmin :: ModifierKey -> ModifierKey -> ModifierKey
max :: ModifierKey -> ModifierKey -> ModifierKey
$cmax :: ModifierKey -> ModifierKey -> ModifierKey
>= :: ModifierKey -> ModifierKey -> Bool
$c>= :: ModifierKey -> ModifierKey -> Bool
> :: ModifierKey -> ModifierKey -> Bool
$c> :: ModifierKey -> ModifierKey -> Bool
<= :: ModifierKey -> ModifierKey -> Bool
$c<= :: ModifierKey -> ModifierKey -> Bool
< :: ModifierKey -> ModifierKey -> Bool
$c< :: ModifierKey -> ModifierKey -> Bool
compare :: ModifierKey -> ModifierKey -> Ordering
$ccompare :: ModifierKey -> ModifierKey -> Ordering
$cp1Ord :: Eq ModifierKey
Ord)
data ModifierStatus = (:!) {- ^ Required -} | (:?) {- ^ Irrelevant -} deriving ModifierStatus -> ModifierStatus -> Bool
(ModifierStatus -> ModifierStatus -> Bool)
-> (ModifierStatus -> ModifierStatus -> Bool) -> Eq ModifierStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModifierStatus -> ModifierStatus -> Bool
$c/= :: ModifierStatus -> ModifierStatus -> Bool
== :: ModifierStatus -> ModifierStatus -> Bool
$c== :: ModifierStatus -> ModifierStatus -> Bool
Eq
instance Semigroup ModifierChord where
  ModifierChord Map ModifierKey ModifierStatus
m <> :: ModifierChord -> ModifierChord -> ModifierChord
<> ModifierChord
n = (ModifierKey -> ModifierStatus -> ModifierChord -> ModifierChord)
-> ModifierChord -> Map ModifierKey ModifierStatus -> ModifierChord
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\ModifierKey
k ModifierStatus
v ModifierChord
r -> ModifierKey -> ModifierStatus -> ModifierChord -> ModifierChord
include ModifierKey
k ModifierStatus
v ModifierChord
r) ModifierChord
n Map ModifierKey ModifierStatus
m where
      include :: ModifierKey -> ModifierStatus -> ModifierChord -> ModifierChord
      include :: ModifierKey -> ModifierStatus -> ModifierChord -> ModifierChord
include ModifierKey
k ModifierStatus
v (ModifierChord Map ModifierKey ModifierStatus
m) = case ModifierKey
k of
          Mod Mod
mod Side
Any -> Map ModifierKey ModifierStatus -> ModifierChord
ModifierChord (Map ModifierKey ModifierStatus -> ModifierChord)
-> Map ModifierKey ModifierStatus -> ModifierChord
forall a b. (a -> b) -> a -> b
$ ModifierKey
-> ModifierStatus
-> Map ModifierKey ModifierStatus
-> Map ModifierKey ModifierStatus
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ModifierKey
k ModifierStatus
v (Map ModifierKey ModifierStatus -> Map ModifierKey ModifierStatus)
-> Map ModifierKey ModifierStatus -> Map ModifierKey ModifierStatus
forall a b. (a -> b) -> a -> b
$ ModifierKey
-> Map ModifierKey ModifierStatus -> Map ModifierKey ModifierStatus
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Mod -> Side -> ModifierKey
Mod Mod
mod Side
L) (Map ModifierKey ModifierStatus -> Map ModifierKey ModifierStatus)
-> Map ModifierKey ModifierStatus -> Map ModifierKey ModifierStatus
forall a b. (a -> b) -> a -> b
$ ModifierKey
-> Map ModifierKey ModifierStatus -> Map ModifierKey ModifierStatus
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Mod -> Side -> ModifierKey
Mod Mod
mod Side
R) Map ModifierKey ModifierStatus
m
          Mod Mod
mod Side
s | ModifierKey
-> Map ModifierKey ModifierStatus -> Maybe ModifierStatus
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Mod -> Side -> ModifierKey
Mod Mod
mod (Side -> ModifierKey) -> Side -> ModifierKey
forall a b. (a -> b) -> a -> b
$ Side -> Side
swap Side
s) Map ModifierKey ModifierStatus
m Maybe ModifierStatus -> Maybe ModifierStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ModifierStatus -> Maybe ModifierStatus
forall a. a -> Maybe a
Just ModifierStatus
v -> ModifierKey -> ModifierStatus -> ModifierChord -> ModifierChord
include (Mod -> Side -> ModifierKey
Mod Mod
mod Side
Any) ModifierStatus
v (Map ModifierKey ModifierStatus -> ModifierChord
ModifierChord Map ModifierKey ModifierStatus
m)
          ModifierKey
_ -> Map ModifierKey ModifierStatus -> ModifierChord
ModifierChord (Map ModifierKey ModifierStatus -> ModifierChord)
-> Map ModifierKey ModifierStatus -> ModifierChord
forall a b. (a -> b) -> a -> b
$ ModifierKey
-> ModifierStatus
-> Map ModifierKey ModifierStatus
-> Map ModifierKey ModifierStatus
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ModifierKey
k ModifierStatus
v Map ModifierKey ModifierStatus
m
        where swap :: Side -> Side
swap Side
L = Side
R; swap Side
R = Side
L; swap Side
Any = Side
Any

instance Monoid ModifierChord where mempty :: ModifierChord
mempty = Map ModifierKey ModifierStatus -> ModifierChord
ModifierChord Map ModifierKey ModifierStatus
forall k a. Map k a
Map.empty

data KeyMapSet_Id = ANSI | JIS {- ^ Japan -} deriving (KeyMapSet_Id -> KeyMapSet_Id -> Bool
(KeyMapSet_Id -> KeyMapSet_Id -> Bool)
-> (KeyMapSet_Id -> KeyMapSet_Id -> Bool) -> Eq KeyMapSet_Id
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyMapSet_Id -> KeyMapSet_Id -> Bool
$c/= :: KeyMapSet_Id -> KeyMapSet_Id -> Bool
== :: KeyMapSet_Id -> KeyMapSet_Id -> Bool
$c== :: KeyMapSet_Id -> KeyMapSet_Id -> Bool
Eq, ReadPrec [KeyMapSet_Id]
ReadPrec KeyMapSet_Id
Int -> ReadS KeyMapSet_Id
ReadS [KeyMapSet_Id]
(Int -> ReadS KeyMapSet_Id)
-> ReadS [KeyMapSet_Id]
-> ReadPrec KeyMapSet_Id
-> ReadPrec [KeyMapSet_Id]
-> Read KeyMapSet_Id
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [KeyMapSet_Id]
$creadListPrec :: ReadPrec [KeyMapSet_Id]
readPrec :: ReadPrec KeyMapSet_Id
$creadPrec :: ReadPrec KeyMapSet_Id
readList :: ReadS [KeyMapSet_Id]
$creadList :: ReadS [KeyMapSet_Id]
readsPrec :: Int -> ReadS KeyMapSet_Id
$creadsPrec :: Int -> ReadS KeyMapSet_Id
Read)
data KeyMapSet = KeyMapSet {KeyMapSet -> KeyMapSet_Id
keyMapSet_id :: KeyMapSet_Id, KeyMapSet -> NonEmpty KeyMap
keyMapSet_keyMaps :: NonEmpty KeyMap}
instance XML KeyMapSet where
  fromXML :: Node -> KeyMapSet
fromXML (XML ByteString
"keyMapSet" (ByteString -> KeyMapSet_Id
forall a. Read a => ByteString -> a
readBS (ByteString -> KeyMapSet_Id)
-> (Map ByteString ByteString -> ByteString)
-> Map ByteString ByteString
-> KeyMapSet_Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"id") -> KeyMapSet_Id
i) [Node]
cs)
    = KeyMapSet :: KeyMapSet_Id -> NonEmpty KeyMap -> KeyMapSet
KeyMapSet {keyMapSet_id :: KeyMapSet_Id
keyMapSet_id = KeyMapSet_Id
i
                ,keyMapSet_keyMaps :: NonEmpty KeyMap
keyMapSet_keyMaps = [KeyMap] -> NonEmpty KeyMap
forall a. [a] -> NonEmpty a
NE.fromList ([KeyMap] -> NonEmpty KeyMap) -> [KeyMap] -> NonEmpty KeyMap
forall a b. (a -> b) -> a -> b
$ ByteString -> [Node] -> [KeyMap]
forall b. XML b => ByteString -> [Node] -> [b]
find' ByteString
"keyMap" [Node]
cs}
  toXML :: KeyMapSet -> String
toXML KeyMapSet
kms = String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t<keyMapSet id=\"%s\">\n%s\t</keyMapSet>"
                     (KeyMapSet_Id -> String
forall a. Show a => a -> String
show (KeyMapSet_Id -> String) -> KeyMapSet_Id -> String
forall a b. (a -> b) -> a -> b
$ KeyMapSet -> KeyMapSet_Id
keyMapSet_id KeyMapSet
kms)
                     ([String] -> String
unlines ([String] -> String)
-> (NonEmpty KeyMap -> [String]) -> NonEmpty KeyMap -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyMap -> String) -> [KeyMap] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KeyMap -> String
forall a. XML a => a -> String
toXML ([KeyMap] -> [String])
-> (NonEmpty KeyMap -> [KeyMap]) -> NonEmpty KeyMap -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty KeyMap -> [KeyMap]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty KeyMap -> String) -> NonEmpty KeyMap -> String
forall a b. (a -> b) -> a -> b
$ KeyMapSet -> NonEmpty KeyMap
keyMapSet_keyMaps KeyMapSet
kms)

data KeyMap
 = KeyMap {KeyMap -> Ix KeyMap
keyMap_index :: Ix KeyMap
          ,KeyMap -> Maybe (KeyMapSet_Id, Ix KeyMap)
keyMap_base :: Maybe (KeyMapSet_Id, Ix KeyMap)
          ,KeyMap -> NonEmpty Key
keyMap_keys :: NonEmpty Key }
instance XML KeyMap where
  fromXML :: Node -> KeyMap
fromXML (XML ByteString
"keyMap" Map ByteString ByteString
as [Node]
cs)
    = KeyMap :: Ix KeyMap
-> Maybe (KeyMapSet_Id, Ix KeyMap) -> NonEmpty Key -> KeyMap
KeyMap {keyMap_index :: Ix KeyMap
keyMap_index = Word -> Ix KeyMap
forall a. Word -> Ix a
Ix (Word -> Ix KeyMap)
-> (ByteString -> Word) -> ByteString -> Ix KeyMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Word
forall a. Read a => ByteString -> a
readBS (ByteString -> Ix KeyMap) -> ByteString -> Ix KeyMap
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"index"
             ,keyMap_base :: Maybe (KeyMapSet_Id, Ix KeyMap)
keyMap_base = (,) (KeyMapSet_Id -> Ix KeyMap -> (KeyMapSet_Id, Ix KeyMap))
-> Maybe KeyMapSet_Id
-> Maybe (Ix KeyMap -> (KeyMapSet_Id, Ix KeyMap))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (     ByteString -> KeyMapSet_Id
forall a. Read a => ByteString -> a
readBS (ByteString -> KeyMapSet_Id)
-> Maybe ByteString -> Maybe KeyMapSet_Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"baseMapSet" Map ByteString ByteString
as)
                                Maybe (Ix KeyMap -> (KeyMapSet_Id, Ix KeyMap))
-> Maybe (Ix KeyMap) -> Maybe (KeyMapSet_Id, Ix KeyMap)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word -> Ix KeyMap
forall a. Word -> Ix a
Ix (Word -> Ix KeyMap)
-> (ByteString -> Word) -> ByteString -> Ix KeyMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Word
forall a. Read a => ByteString -> a
readBS (ByteString -> Ix KeyMap) -> Maybe ByteString -> Maybe (Ix KeyMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"baseIndex"  Map ByteString ByteString
as)
             ,keyMap_keys :: NonEmpty Key
keyMap_keys = [Key] -> NonEmpty Key
forall a. [a] -> NonEmpty a
NE.fromList ([Key] -> NonEmpty Key) -> [Key] -> NonEmpty Key
forall a b. (a -> b) -> a -> b
$ ByteString -> [Node] -> [Key]
forall b. XML b => ByteString -> [Node] -> [b]
find' ByteString
"key" [Node]
cs}
  toXML :: KeyMap -> String
toXML KeyMap
km = String -> Word -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t<keyMap index=\"%d\"%s>\n%s\t\t</keyMap>"
                 (Ix KeyMap -> Word
forall a. Ix a -> Word
unIx (Ix KeyMap -> Word) -> Ix KeyMap -> Word
forall a b. (a -> b) -> a -> b
$ KeyMap -> Ix KeyMap
keyMap_index KeyMap
km)
                 (case KeyMap -> Maybe (KeyMapSet_Id, Ix KeyMap)
keyMap_base KeyMap
km of
                   Maybe (KeyMapSet_Id, Ix KeyMap)
Nothing -> String
"" :: String
                   Just (KeyMapSet_Id
bms,Ix Word
bi) -> String -> String -> Word -> String
forall r. PrintfType r => String -> r
printf String
" baseMapSet=\"%s\" baseIndex=\"%d\"" (KeyMapSet_Id -> String
forall a. Show a => a -> String
show KeyMapSet_Id
bms) Word
bi)
                 ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Key -> String) -> [Key] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> String
forall a. XML a => a -> String
toXML ([Key] -> [String]) -> [Key] -> [String]
forall a b. (a -> b) -> a -> b
$ NonEmpty Key -> [Key]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Key -> [Key]) -> NonEmpty Key -> [Key]
forall a b. (a -> b) -> a -> b
$ KeyMap -> NonEmpty Key
keyMap_keys KeyMap
km)
 

data KeyCode = Virtual ByteString
data Key = KeyOutput {Key -> KeyCode
key_code :: KeyCode , Key -> ByteString
key_output :: ByteString}
         | KeyNamedAction {key_code :: KeyCode, Key -> Id Action
key_namedAction :: Id Action}
         | KeyAction {key_code :: KeyCode, Key -> NonEmpty When
key_action :: NonEmpty When}
instance XML Key where
  fromXML :: Node -> Key
fromXML (XML ByteString
"key" Map ByteString ByteString
as [Node]
cs) = let (Just (ByteString -> KeyCode
Virtual -> KeyCode
code), Map ByteString ByteString
as') = (ByteString -> ByteString -> Maybe ByteString)
-> ByteString
-> Map ByteString ByteString
-> (Maybe ByteString, Map ByteString ByteString)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\ByteString
_ ByteString
_ -> Maybe ByteString
forall a. Maybe a
Nothing) ByteString
"code" Map ByteString ByteString
as
                              in case (Map ByteString ByteString -> [(ByteString, ByteString)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ByteString ByteString
as',[Node]
cs) of
    ([(ByteString
"output",ByteString
o)], []) -> KeyCode -> ByteString -> Key
KeyOutput KeyCode
code ByteString
o
    ([(ByteString
"action",ByteString
a)], []) -> KeyCode -> Id Action -> Key
KeyNamedAction KeyCode
code (ByteString -> Id Action
forall a. ByteString -> Id a
Id ByteString
a)
    ([], [Node
a]) -> KeyCode -> NonEmpty When -> Key
KeyAction KeyCode
code (NonEmpty When -> Key) -> NonEmpty When -> Key
forall a b. (a -> b) -> a -> b
$ Node -> NonEmpty When
forall a. XML a => Node -> a
fromXML Node
a
    ([(ByteString, ByteString)], [Node])
_ -> String -> Key
forall a. HasCallStack => String -> a
error String
"fromXML Key"
  toXML :: Key -> String
toXML = \case
    KeyOutput (Virtual (ByteString -> String
BS.unpack -> String
c)) (ByteString -> String
BS.unpack -> String
o) -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t\t<key code=\"%s\" output=\"%s\" />" String
c String
o
    KeyNamedAction (Virtual (ByteString -> String
BS.unpack -> String
c)) (Id (ByteString -> String
BS.unpack -> String
a)) -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t\t<key code=\"%s\" action=\"%s\" />" String
c String
a
    KeyAction (Virtual (ByteString -> String
BS.unpack -> String
c)) NonEmpty When
ws -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t\t<key code=\"%s\">\n%s\t\t\t</key>" String
c (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty When -> String
forall a. XML a => a -> String
toXML NonEmpty When
ws
--
-- | Single Action within 'Key'
instance XML (NonEmpty When) where
  fromXML :: Node -> NonEmpty When
fromXML (XML ByteString
"action" Map ByteString ByteString
_ ((Node -> When) -> [Node] -> [When]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> When
forall a. XML a => Node -> a
fromXML -> [When]
ws)) = [When] -> NonEmpty When
forall a. [a] -> NonEmpty a
NE.fromList [When]
ws
  toXML :: NonEmpty When -> String
toXML = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"<XXaction>\n%s</XXaction>" (String -> String)
-> (NonEmpty When -> String) -> NonEmpty When -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> (NonEmpty When -> [String]) -> NonEmpty When -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (When -> String) -> [When] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap When -> String
forall a. XML a => a -> String
toXML ([When] -> [String])
-> (NonEmpty When -> [When]) -> NonEmpty When -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty When -> [When]
forall a. NonEmpty a -> [a]
NE.toList

data Action = Action {Action -> Id Action
action_id :: Id Action, Action -> NonEmpty When
action_whens :: NonEmpty When}
instance XML Action where
  fromXML :: Node -> Action
fromXML (XML ByteString
"action" ((ByteString -> Id Action
forall a. ByteString -> Id a
Id (ByteString -> Id Action)
-> (Map ByteString ByteString -> ByteString)
-> Map ByteString ByteString
-> Id Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"id")) -> Id Action
i) [Node]
cs) = Id Action -> NonEmpty When -> Action
Action Id Action
i (NonEmpty When -> Action)
-> ([When] -> NonEmpty When) -> [When] -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [When] -> NonEmpty When
forall a. [a] -> NonEmpty a
NE.fromList ([When] -> Action) -> [When] -> Action
forall a b. (a -> b) -> a -> b
$ (Node -> When) -> [Node] -> [When]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> When
forall a. XML a => Node -> a
fromXML [Node]
cs
  toXML :: Action -> String
toXML Action
a = String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t<action id=\"%s\">\n%s\t\t</action>"
                   (ByteString -> String
BS.unpack (ByteString -> String)
-> (Id Action -> ByteString) -> Id Action -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id Action -> ByteString
forall a. Id a -> ByteString
unId (Id Action -> String) -> Id Action -> String
forall a b. (a -> b) -> a -> b
$ Action -> Id Action
action_id Action
a)
                   ([String] -> String
unlines ([String] -> String)
-> (NonEmpty When -> [String]) -> NonEmpty When -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (When -> String) -> [When] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap When -> String
forall a. XML a => a -> String
toXML ([When] -> [String])
-> (NonEmpty When -> [When]) -> NonEmpty When -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty When -> [When]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty When -> String) -> NonEmpty When -> String
forall a b. (a -> b) -> a -> b
$ Action -> NonEmpty When
action_whens Action
a)

type StateNum = Word
data State = State ByteString | None
data When
  = WhenRange {When -> (Word, Word)
when_range :: (StateNum,StateNum)
              ,When -> Maybe Word
when_range_next :: Maybe StateNum
              ,When -> Maybe Char
when_range_output :: Maybe Char
              ,When -> Maybe Word8
when_multiplier :: Maybe Word8 -- ^ The difference between the input state and the start of the range
                                              -- is multiplied by this number, then added to the next state number
                                              -- and/or the output UTF-16 value.
              }
  | When {When -> State
when_state :: State
         ,When -> Maybe State
when_next :: Maybe State
         ,When -> Maybe ByteString
when_output :: Maybe ByteString
         }
instance XML When where
  fromXML :: Node -> When
fromXML (XML ByteString
"when" Map ByteString ByteString
as [Node]
cs) = 
    let state :: ByteString
state = Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"state"
    in case (ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"through" Map ByteString ByteString
as, ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"next" Map ByteString ByteString
as, ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"output" Map ByteString ByteString
as, ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"multiplier" Map ByteString ByteString
as) of
      (Just ByteString
t,Maybe ByteString
n,Maybe ByteString
o,Maybe ByteString
m) ->  WhenRange :: (Word, Word) -> Maybe Word -> Maybe Char -> Maybe Word8 -> When
WhenRange {when_range :: (Word, Word)
when_range = (ByteString -> Word
forall a. Read a => ByteString -> a
readBS ByteString
state,ByteString -> Word
forall a. Read a => ByteString -> a
readBS ByteString
t)
                                   ,when_range_next :: Maybe Word
when_range_next = ByteString -> Word
forall a. Read a => ByteString -> a
readBS (ByteString -> Word) -> Maybe ByteString -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
n
                                   ,when_range_output :: Maybe Char
when_range_output = (Text -> Char
Text.head (Text -> Char) -> (ByteString -> Text) -> ByteString -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf16LE) (ByteString -> Char) -> Maybe ByteString -> Maybe Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
o
                                   ,when_multiplier :: Maybe Word8
when_multiplier = ByteString -> Word8
forall a. Read a => ByteString -> a
readBS (ByteString -> Word8) -> Maybe ByteString -> Maybe Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
m}
      (Maybe ByteString
Nothing,Maybe ByteString
n,Maybe ByteString
o,Maybe ByteString
Nothing) -> State -> Maybe State -> Maybe ByteString -> When
When  (ByteString -> State
parseState ByteString
state) (ByteString -> State
parseState (ByteString -> State) -> Maybe ByteString -> Maybe State
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
n) Maybe ByteString
o
      (Maybe ByteString, Maybe ByteString, Maybe ByteString,
 Maybe ByteString)
_ -> String -> When
forall a. HasCallStack => String -> a
error String
"fromXML When"
      where parseState :: ByteString -> State
parseState = \case ByteString
"none" -> State
None; ByteString
s -> ByteString -> State
State ByteString
s
  toXML :: When -> String
toXML = \case
    WhenRange (Word
a,Word
b) Maybe Word
n Maybe Char
o Maybe Word8
m -> String -> Word -> Word -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t\t<when state=\"%d\" through=\"%d\"%s%s%s/>" Word
a Word
b
                                    (case Maybe Word
n of
                                      Maybe Word
Nothing -> String
"" :: String
                                      Just Word
a -> String -> Word -> String
forall r. PrintfType r => String -> r
printf String
" next=\"%d\"" Word
a)
                                    (case Maybe Char
o of
                                      Maybe Char
Nothing -> String
"" :: String
                                      Just Char
a -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
" output=\"%s\"" [Char
a])
                                    (case Maybe Word8
m of
                                      Maybe Word8
Nothing -> String
"" :: String
                                      Just Word8
a -> String -> Word8 -> String
forall r. PrintfType r => String -> r
printf String
" multiplier=\"%d\"" Word8
a)
                                      
    When State
s Maybe State
n Maybe ByteString
o -> String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t\t<when state=\"%s\"%s%s />"
                         (State -> String
printState State
s)
                         (case Maybe State
n of
                           Maybe State
Nothing -> String
"" :: String
                           Just State
a -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
" next=\"%s\"" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ State -> String
printState State
a)
                         (case Maybe ByteString
o of
                           Maybe ByteString
Nothing -> String
"" :: String
                           Just ByteString
a -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
" output=\"%s\"" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
a)
    where printState :: State -> String
printState = \case {State
None -> String
"none"; State ByteString
s -> ByteString -> String
BS.unpack ByteString
s}

data When_Terminator = When_Terminator {When_Terminator -> State
when_terminator_state :: State, When_Terminator -> ByteString
when_terminator_output :: ByteString}
instance XML When_Terminator where
  fromXML :: Node -> When_Terminator
fromXML (XML ByteString
"when" Map ByteString ByteString
as [Node]
_) = State -> ByteString -> When_Terminator
When_Terminator (ByteString -> State
State (ByteString -> State) -> ByteString -> State
forall a b. (a -> b) -> a -> b
$ Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"state") (Map ByteString ByteString
as Map ByteString ByteString -> ByteString -> ByteString
forall k a. Ord k => Map k a -> k -> a
! ByteString
"output")
  toXML :: When_Terminator -> String
toXML (When_Terminator State
s ByteString
o) = String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\t\t<when state=\"%s\" output=\"%s\" />"
                                       (case State
s of State
None -> String
"none"; State ByteString
a -> ByteString -> String
BS.unpack ByteString
a)
                                       (ByteString -> String
BS.unpack ByteString
o)


deriving instance Show Keyboard
deriving instance Show Group
deriving instance Show Layouts
deriving instance Show ModifierMap
deriving instance Show KeyMapSet
deriving instance Show Action
deriving instance Show When_Terminator
deriving instance Show Layout
deriving instance Show (Id a)
deriving instance Show (Ix a)
deriving instance Show KeyMapSelect
deriving instance Show KeyMapSet_Id
deriving instance Show KeyMap
deriving instance Show When
deriving instance Show State
deriving instance Show Modifier
deriving instance Show Key
deriving instance Show ModifierChord
deriving instance Show KeyCode
deriving instance Show ModifierKey
deriving instance Show ModifierStatus
deriving instance Show Mod
deriving instance Show Side