diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# keylayouts diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/keylayouts.cabal b/keylayouts.cabal new file mode 100644 --- /dev/null +++ b/keylayouts.cabal @@ -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 diff --git a/src/Keyboard.hs b/src/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/Keyboard.hs @@ -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 "\n%s\n%s\n%s%s%s\n" + (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\n%s\t" (unlines . fmap toXML $ as) :: String) + (case keyboard_terminators k of + [] -> ("" :: String) + ts -> printf "\n\t\n%s\t" (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\n%s\t" . 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 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\n%s\t" + (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\n%s\t\t" + (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" $ 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\n%s\t" + (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\n%s\t\t" + (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" c o + KeyNamedAction (Virtual (BS.unpack -> c)) (Id (BS.unpack -> a)) -> printf "\t\t\t" c a + KeyAction (Virtual (BS.unpack -> c)) ws -> printf "\t\t\t\n%s\t\t\t" c $ toXML ws +-- +-- | Single Action within 'Key' +instance XML (NonEmpty When) where + fromXML (XML "action" _ (fmap fromXML -> ws)) = NE.fromList ws + toXML = printf "\n%s" . 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\n%s\t\t" + (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" 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" + (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" + (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 diff --git a/src/XML.hs b/src/XML.hs new file mode 100644 --- /dev/null +++ b/src/XML.hs @@ -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