keylayouts (empty) → 0.1.0.0
raw patch · 6 files changed
+397/−0 lines, 6 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, pretty-simple, text, xeno
Files
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- keylayouts.cabal +39/−0
- src/Keyboard.hs +297/−0
- src/XML.hs +28/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# keylayouts
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ keylayouts.cabal view
@@ -0,0 +1,39 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.3.+--+-- see: https://github.com/sol/hpack+--+-- hash: 9a60543d05d9fdc1e3ddcf3c35eb3403ec57ae009bd8ca2d2a8c23bd4d9f4b49++name: keylayouts+version: 0.1.0.0+synopsis: Tools for macOS .keylayout files+description: Datatypes, parsing, and printing for .keylayout files, Used for advanced keyboard mappings on macOS. https://developer.apple.com/library/archive/technotes/tn2056/_index.html+category: xml, configuration+homepage: https://github.com/daig/keylayouts#readme+author: Dai+maintainer: daig@sodality.cc+copyright: 2020 Dai+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md++library+ exposed-modules:+ Keyboard+ other-modules:+ XML+ hs-source-dirs:+ src+ default-extensions: LambdaCase BlockArguments StandaloneDeriving FlexibleInstances OverloadedStrings PatternSynonyms ViewPatterns+ build-depends:+ base >=4.7 && <5+ , bytestring+ , containers+ , pretty-simple+ , text+ , xeno+ default-language: Haskell2010
+ src/Keyboard.hs view
@@ -0,0 +1,297 @@+{-# 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 Text.Pretty.Simple+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 {unId :: ByteString}+instance IsString (Id a) where fromString = Id . BS.pack+newtype Ix a = Ix {unIx :: Word}+newtype Group = Group {unGroup :: Word}++parse :: ByteString -> Either XenoException Keyboard+parse = fmap fromXML . XML.parse++export :: Keyboard -> ByteString+export = BS.pack . toXML++data Keyboard = Keyboard {keyboard_group :: Group+ ,keyboard_id :: Word+ ,keyboard_name :: ByteString+ ,keyboard_maxout :: Maybe Word+ ,keyboard_layouts :: Layouts+ ,keyboard_modifierMap :: ModifierMap+ ,keyboard_keyMapSets :: NonEmpty KeyMapSet+ ,keyboard_actions :: [Action]+ ,keyboard_terminators :: [When_Terminator] }++instance XML Keyboard where+ fromXML (XML "keyboard" as cs)+ = Keyboard {keyboard_group = Map.findWithDefault (Group 126) "group" $ fmap (Group . readBS) as+ ,keyboard_id = Map.findWithDefault 1 "id" $ fmap (readBS) as+ ,keyboard_name = as ! "name"+ ,keyboard_maxout = (read . BS.unpack) <$> Map.lookup "maxount" as+ ,keyboard_layouts = find# "layouts" cs+ ,keyboard_modifierMap = find# "modifierMap" cs+ ,keyboard_keyMapSets = NE.fromList $ find' "keyMapSet" cs+ ,keyboard_actions = case cs & find \ a -> name a == "actions" of+ Nothing -> []+ Just (XML "actions" _ cs) -> fmap fromXML cs+ ,keyboard_terminators = case cs & find \ a -> name a == "terminators" of+ Nothing -> []+ Just (XML "terminators" _ cs) -> fmap fromXML cs}+ toXML k = printf "<keyboard group=\"%d\" id=\"%d\" name=%s %s>\n%s\n%s\n%s%s%s\n</keyboard>"+ (unGroup $ keyboard_group k)+ (keyboard_id k)+ (show $ keyboard_name k)+ (case keyboard_maxout k of+ Nothing -> ("" :: String)+ Just i -> printf "maxout=\"%s\"" (show i) :: String)+ (toXML $ keyboard_layouts k)+ (toXML $ keyboard_modifierMap k)+ (unlines . fmap toXML . NE.toList $ keyboard_keyMapSets k)+ (case keyboard_actions k of+ [] -> ("" :: String)+ as -> printf "\n\t<actions>\n%s\t</actions>" (unlines . fmap toXML $ as) :: String)+ (case keyboard_terminators k of+ [] -> ("" :: String)+ ts -> printf "\n\t<terminators>\n%s\t</terminators>" (unlines . fmap toXML $ ts) :: String)++newtype Layouts = Layouts {layouts_layouts :: NonEmpty Layout}+instance XML Layouts where+ fromXML (XML "layouts" as cs) = Layouts . NE.fromList $ find' "layout" cs+ toXML (Layouts ls) = printf "\t<layouts>\n%s\t</layouts>" . unlines . fmap toXML $ NE.toList ls+data Layout+ = Layout {layout_first :: Word, layout_last :: Word+ ,layout_modifiers :: Id ModifierMap+ ,layout_mapSet :: KeyMapSet_Id}+instance XML Layout where+ fromXML (XML "layout" as cs)+ = Layout {layout_first = readBS $ as ! "first"+ ,layout_last = readBS $ as ! "last"+ ,layout_modifiers = Id $ as ! "modifiers"+ ,layout_mapSet = readBS $ as ! "mapSet"}+ toXML l = printf "\t\t<layout first=\"%d\" last=\"%d\" modifiers=\"%s\" mapSet=\"%s\" />"+ (layout_first l)+ (layout_last l)+ (BS.unpack . unId $ layout_modifiers l)+ (show $ layout_mapSet l)++data ModifierMap+ = ModifierMap {modifierMap_id :: Id ModifierMap+ ,modifierMap_defaultIndex :: Ix KeyMap+ ,modifierMap_keyMapSelects :: NonEmpty KeyMapSelect}+instance XML ModifierMap where+ fromXML (XML "modifierMap" as cs)+ = ModifierMap {modifierMap_id = Id $ as ! "id"+ ,modifierMap_defaultIndex = Ix . readBS $ as ! "defaultIndex"+ ,modifierMap_keyMapSelects = NE.fromList $ find' "keyMapSelect" cs}+ toXML m = printf "\t<modifierMap id=\"%s\" defaultIndex=\"%d\">\n%s\t</modifierMap>"+ (BS.unpack . unId $ modifierMap_id m)+ (unIx $ modifierMap_defaultIndex m)+ (unlines . fmap toXML . NE.toList $ modifierMap_keyMapSelects m)++data KeyMapSelect+ = KeyMapSelect {keyMapSelect_mapIndex :: Ix KeyMap+ ,keyMapSelect_modifiers :: NonEmpty Modifier }+instance XML KeyMapSelect where+ fromXML (XML "keyMapSelect" as cs)+ = KeyMapSelect {keyMapSelect_mapIndex = Ix . readBS $ as ! "mapIndex"+ ,keyMapSelect_modifiers = NE.fromList $ find' "modifier" cs+ }+ toXML kms = printf "\t\t<keyMapSelect mapIndex=\"%d\">\n%s\t\t</keyMapSelect>"+ (unIx $ keyMapSelect_mapIndex kms)+ (unlines . fmap toXML . NE.toList $ keyMapSelect_modifiers kms)++newtype Modifier = Modifier {modifier_keys :: ModifierChord}+instance XML Modifier where+ fromXML (XML "modifier" as _) = Modifier $ parseChord $ as ! "keys" where+ parseChord :: ByteString -> ModifierChord+ parseChord (BS.words -> c) = ModifierChord $ Map.fromList $ fmap parseModifier c where+ parseModifier :: ByteString -> (ModifierKey, ModifierStatus)+ parseModifier = \case+ (BS.stripPrefix "command" -> Just (status -> s)) -> (Command, s)+ (BS.stripPrefix "caps" -> Just (status -> s)) -> (Caps, s)+ (BS.stripPrefix "any" -> Just (modifier -> (m,s)) ) -> (Mod m Any, s)+ (BS.stripPrefix "right" -> Just (modifier -> (m,s)) ) -> (Mod m R, s)+ (modifier -> (m , s)) -> (Mod m L, s)+ _ -> error "parseModifier"+ status = \case {"" -> (:!); "?" -> (:?); _ -> error "status"}+ modifier (BS.map toLower -> m) = case m of+ (BS.stripPrefix "shift" -> Just (status -> s)) -> (Shift , s)+ (BS.stripPrefix "option" -> Just (status -> s)) -> (Option , s)+ (BS.stripPrefix "control" -> Just (status -> s)) -> (Option , s)+ x -> error $ "modifier " ++ show x+ toXML (Modifier ks) = printf "\t\t\t<modifier keys=\"%s\" />" $ printChord ks where+ printChord :: ModifierChord -> String+ printChord (ModifierChord (Map.toList -> m)) = unwords $ fmap (\(mk,s) -> printKey mk ++ printStatus s) m+ printKey = \case+ Caps -> "caps"+ Command -> "command"+ Mod (show -> md) s -> case s of {L -> uncap md; R -> "right" ++ md; Any -> "any" ++ md}+ uncap (a:as) = toLower a : as+ printStatus = \case {(:!) -> ""; (:?) -> "?"}+ +newtype ModifierChord = ModifierChord (Map ModifierKey ModifierStatus)+data Mod = Shift | Option | Control deriving (Eq, Ord)+data Side = L | R | Any deriving (Eq,Ord)+instance Semigroup Side where L <> L = L; R <> R = R; _ <> _ = Any+data ModifierKey = Mod Mod Side | Command | Caps deriving (Eq,Ord)+data ModifierStatus = (:!) {- ^ Required -} | (:?) {- ^ Irrelevant -} deriving Eq+instance Semigroup ModifierChord where+ ModifierChord m <> n = Map.foldrWithKey (\k v r -> include k v r) n m where+ include :: ModifierKey -> ModifierStatus -> ModifierChord -> ModifierChord+ include k v (ModifierChord m) = case k of+ Mod mod Any -> ModifierChord $ Map.insert k v $ Map.delete (Mod mod L) $ Map.delete (Mod mod R) m+ Mod mod s | Map.lookup (Mod mod $ swap s) m == Just v -> include (Mod mod Any) v (ModifierChord m)+ _ -> ModifierChord $ Map.insert k v m+ where swap L = R; swap R = L; swap Any = Any++instance Monoid ModifierChord where mempty = ModifierChord Map.empty++data KeyMapSet_Id = ANSI | JIS {- ^ Japan -} deriving (Eq, Read)+data KeyMapSet = KeyMapSet {keyMapSet_id :: KeyMapSet_Id, keyMapSet_keyMaps :: NonEmpty KeyMap}+instance XML KeyMapSet where+ fromXML (XML "keyMapSet" (readBS . (! "id") -> i) cs)+ = KeyMapSet {keyMapSet_id = i+ ,keyMapSet_keyMaps = NE.fromList $ find' "keyMap" cs}+ toXML kms = printf "\t<keyMapSet id=\"%s\">\n%s\t</keyMapSet>"+ (show $ keyMapSet_id kms)+ (unlines . fmap toXML . NE.toList $ keyMapSet_keyMaps kms)++data KeyMap+ = KeyMap {keyMap_index :: Ix KeyMap+ ,keyMap_base :: Maybe (KeyMapSet_Id, Ix KeyMap)+ ,keyMap_keys :: NonEmpty Key }+instance XML KeyMap where+ fromXML (XML "keyMap" as cs)+ = KeyMap {keyMap_index = Ix . readBS $ as ! "index"+ ,keyMap_base = (,) <$> ( readBS <$> Map.lookup "baseMapSet" as)+ <*> (Ix . readBS <$> Map.lookup "baseIndex" as)+ ,keyMap_keys = NE.fromList $ find' "key" cs}+ toXML km = printf "\t\t<keyMap index=\"%d\"%s>\n%s\t\t</keyMap>"+ (unIx $ keyMap_index km)+ (case keyMap_base km of+ Nothing -> "" :: String+ Just (bms,Ix bi) -> printf " baseMapSet=\"%s\" baseIndex=\"%d\"" (show bms) bi)+ (unlines $ fmap toXML $ NE.toList $ keyMap_keys km)+ ++data KeyCode = Virtual ByteString+data Key = KeyOutput {key_code :: KeyCode , key_output :: ByteString}+ | KeyNamedAction {key_code :: KeyCode, key_namedAction :: Id Action}+ | KeyAction {key_code :: KeyCode, key_action :: NonEmpty When}+instance XML Key where+ fromXML (XML "key" as cs) = let (Just (Virtual -> code), as') = Map.updateLookupWithKey (\_ _ -> Nothing) "code" as+ in case (Map.toList as',cs) of+ ([("output",o)], []) -> KeyOutput code o+ ([("action",a)], []) -> KeyNamedAction code (Id a)+ ([], [a]) -> KeyAction code $ fromXML a+ _ -> error "fromXML Key"+ toXML = \case+ KeyOutput (Virtual (BS.unpack -> c)) (BS.unpack -> o) -> printf "\t\t\t<key code=\"%s\" output=\"%s\" />" c o+ KeyNamedAction (Virtual (BS.unpack -> c)) (Id (BS.unpack -> a)) -> printf "\t\t\t<key code=\"%s\" action=\"%s\" />" c a+ KeyAction (Virtual (BS.unpack -> c)) ws -> printf "\t\t\t<key code=\"%s\">\n%s\t\t\t</key>" c $ toXML ws+--+-- | Single Action within 'Key'+instance XML (NonEmpty When) where+ fromXML (XML "action" _ (fmap fromXML -> ws)) = NE.fromList ws+ toXML = printf "<XXaction>\n%s</XXaction>" . unlines . fmap toXML . NE.toList++data Action = Action {action_id :: Id Action, action_whens :: NonEmpty When}+instance XML Action where+ fromXML (XML "action" ((Id . (! "id")) -> i) cs) = Action i . NE.fromList $ fmap fromXML cs+ toXML a = printf "\t\t<action id=\"%s\">\n%s\t\t</action>"+ (BS.unpack . unId $ action_id a)+ (unlines . fmap toXML . NE.toList $ action_whens a)++type StateNum = Word+data State = State ByteString | None+data When+ = WhenRange {when_range :: (StateNum,StateNum)+ ,when_range_next :: Maybe StateNum+ ,when_range_output :: Maybe Char+ ,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 :: State+ ,when_next :: Maybe State+ ,when_output :: Maybe ByteString+ }+instance XML When where+ fromXML (XML "when" as cs) = + let state = as ! "state"+ in case (Map.lookup "through" as, Map.lookup "next" as, Map.lookup "output" as, Map.lookup "multiplier" as) of+ (Just t,n,o,m) -> WhenRange {when_range = (readBS state,readBS t)+ ,when_range_next = readBS <$> n+ ,when_range_output = (Text.head . Text.decodeUtf16LE) <$> o+ ,when_multiplier = readBS <$> m}+ (Nothing,n,o,Nothing) -> When (parseState state) (parseState <$> n) o+ _ -> error "fromXML When"+ where parseState = \case "none" -> None; s -> State s+ toXML = \case+ WhenRange (a,b) n o m -> printf "\t\t\t<when state=\"%d\" through=\"%d\"%s%s%s/>" a b+ (case n of+ Nothing -> "" :: String+ Just a -> printf " next=\"%d\"" a)+ (case o of+ Nothing -> "" :: String+ Just a -> printf " output=\"%s\"" [a])+ (case m of+ Nothing -> "" :: String+ Just a -> printf " multiplier=\"%d\"" a)+ + When s n o -> printf "\t\t\t<when state=\"%s\"%s%s />"+ (printState s)+ (case n of+ Nothing -> "" :: String+ Just a -> printf " next=\"%s\"" $ printState a)+ (case o of+ Nothing -> "" :: String+ Just a -> printf " output=\"%s\"" $ BS.unpack a)+ where printState = \case {None -> "none"; State s -> BS.unpack s}++data When_Terminator = When_Terminator {when_terminator_state :: State, when_terminator_output :: ByteString}+instance XML When_Terminator where+ fromXML (XML "when" as _) = When_Terminator (State $ as ! "state") (as ! "output")+ toXML (When_Terminator s o) = printf "\t\t<when state=\"%s\" output=\"%s\" />"+ (case s of None -> "none"; State a -> BS.unpack a)+ (BS.unpack 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
+ src/XML.hs view
@@ -0,0 +1,28 @@+{-# language MagicHash #-}+module XML (module XML, module X) where+import Xeno.DOM as X+import Xeno.Types as X+import Data.Function as X ((&))+import Data.List as X (find)+import qualified Data.Map as Map+import Data.Map (Map, (!))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS++class XML a where+ fromXML :: Node -> a+ toXML :: a -> String++just# :: Maybe a -> a+just# = \case Just a -> a; _ -> error "just# Nothing"+find# n x = fromXML . just# $ x & find \ a -> name a == n +find' n x = fmap fromXML $ x & filter \ a -> name a == n ++pattern XML :: ByteString -> Map ByteString ByteString -> [Node] -> Node+pattern XML {xml_name, xml_attributes , xml_children}+ <- ((\n -> (name n+ , Map.fromList $ attributes n+ , children n)) -> (xml_name,xml_attributes,xml_children))++readBS :: Read a => ByteString -> a+readBS = read . BS.unpack